1 //===-- Mangler.cpp -------------------------------------------------------===//
2 //
3 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
4 // See https://llvm.org/LICENSE.txt for license information.
5 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
6 //
7 //===----------------------------------------------------------------------===//
8 
9 #include "flang/Lower/Mangler.h"
10 #include "flang/Common/reference.h"
11 #include "flang/Lower/Support/Utils.h"
12 #include "flang/Optimizer/Builder/Todo.h"
13 #include "flang/Optimizer/Dialect/FIRType.h"
14 #include "flang/Optimizer/Support/InternalNames.h"
15 #include "flang/Semantics/tools.h"
16 #include "llvm/ADT/ArrayRef.h"
17 #include "llvm/ADT/Optional.h"
18 #include "llvm/ADT/SmallVector.h"
19 #include "llvm/ADT/StringRef.h"
20 #include "llvm/ADT/Twine.h"
21 #include "llvm/Support/MD5.h"
22 
23 // recursively build the vector of module scopes
24 static void moduleNames(const Fortran::semantics::Scope &scope,
25                         llvm::SmallVector<llvm::StringRef> &result) {
26   if (scope.IsTopLevel())
27     return;
28   moduleNames(scope.parent(), result);
29   if (scope.kind() == Fortran::semantics::Scope::Kind::Module)
30     if (const Fortran::semantics::Symbol *symbol = scope.symbol())
31       result.emplace_back(toStringRef(symbol->name()));
32 }
33 
34 static llvm::SmallVector<llvm::StringRef>
35 moduleNames(const Fortran::semantics::Symbol &symbol) {
36   const Fortran::semantics::Scope &scope = symbol.owner();
37   llvm::SmallVector<llvm::StringRef> result;
38   moduleNames(scope, result);
39   return result;
40 }
41 
42 static llvm::Optional<llvm::StringRef>
43 hostName(const Fortran::semantics::Symbol &symbol) {
44   const Fortran::semantics::Scope &scope = symbol.owner();
45   if (scope.kind() == Fortran::semantics::Scope::Kind::Subprogram) {
46     assert(scope.symbol() && "subprogram scope must have a symbol");
47     return toStringRef(scope.symbol()->name());
48   }
49   if (scope.kind() == Fortran::semantics::Scope::Kind::MainProgram)
50     // Do not use the main program name, if any, because it may lead to name
51     // collision with procedures with the same name in other compilation units
52     // (technically illegal, but all compilers are able to compile and link
53     // properly these programs).
54     return llvm::StringRef("");
55   return {};
56 }
57 
58 static const Fortran::semantics::Symbol *
59 findInterfaceIfSeperateMP(const Fortran::semantics::Symbol &symbol) {
60   const Fortran::semantics::Scope &scope = symbol.owner();
61   if (symbol.attrs().test(Fortran::semantics::Attr::MODULE) &&
62       scope.IsSubmodule()) {
63     // FIXME symbol from MpSubprogramStmt do not seem to have
64     // Attr::MODULE set.
65     const Fortran::semantics::Symbol *iface =
66         scope.parent().FindSymbol(symbol.name());
67     assert(iface && "Separate module procedure must be declared");
68     return iface;
69   }
70   return nullptr;
71 }
72 
73 // Mangle the name of `symbol` to make it unique within FIR's symbol table using
74 // the FIR name mangler, `mangler`
75 std::string
76 Fortran::lower::mangle::mangleName(const Fortran::semantics::Symbol &symbol,
77                                    bool keepExternalInScope) {
78   // Resolve host and module association before mangling
79   const auto &ultimateSymbol = symbol.GetUltimate();
80   auto symbolName = toStringRef(ultimateSymbol.name());
81 
82   // The Fortran and BIND(C) namespaces are counterintuitive. A
83   // BIND(C) name is substituted early having precedence over the
84   // Fortran name of the subprogram. By side-effect, this allows
85   // multiple subprocedures with identical Fortran names to be legally
86   // present in the program. Assume the BIND(C) name is unique.
87   if (auto *overrideName = ultimateSymbol.GetBindName())
88     return *overrideName;
89   // TODO: the case of procedure that inherits the BIND(C) through another
90   // interface (procedure(iface)), should be dealt within GetBindName()
91   // directly, or some semantics wrapper.
92   if (!Fortran::semantics::IsPointer(ultimateSymbol) &&
93       Fortran::semantics::IsBindCProcedure(ultimateSymbol) &&
94       Fortran::semantics::ClassifyProcedure(symbol) !=
95           Fortran::semantics::ProcedureDefinitionClass::Internal)
96     return ultimateSymbol.name().ToString();
97 
98   return std::visit(
99       Fortran::common::visitors{
100           [&](const Fortran::semantics::MainProgramDetails &) {
101             return fir::NameUniquer::doProgramEntry().str();
102           },
103           [&](const Fortran::semantics::SubprogramDetails &) {
104             // Mangle external procedure without any scope prefix.
105             if (!keepExternalInScope &&
106                 Fortran::semantics::IsExternal(ultimateSymbol))
107               return fir::NameUniquer::doProcedure(llvm::None, llvm::None,
108                                                    symbolName);
109             // Separate module subprograms must be mangled according to the
110             // scope where they were declared (the symbol we have is the
111             // definition).
112             const Fortran::semantics::Symbol *interface = &ultimateSymbol;
113             if (const auto *mpIface = findInterfaceIfSeperateMP(ultimateSymbol))
114               interface = mpIface;
115             llvm::SmallVector<llvm::StringRef> modNames =
116                 moduleNames(*interface);
117             return fir::NameUniquer::doProcedure(modNames, hostName(*interface),
118                                                  symbolName);
119           },
120           [&](const Fortran::semantics::ProcEntityDetails &) {
121             // Mangle procedure pointers and dummy procedures as variables
122             if (Fortran::semantics::IsPointer(ultimateSymbol) ||
123                 Fortran::semantics::IsDummy(ultimateSymbol))
124               return fir::NameUniquer::doVariable(moduleNames(ultimateSymbol),
125                                                   hostName(ultimateSymbol),
126                                                   symbolName);
127             // Otherwise, this is an external procedure, even if it does not
128             // have an explicit EXTERNAL attribute. Mangle it without any
129             // prefix.
130             return fir::NameUniquer::doProcedure(llvm::None, llvm::None,
131                                                  symbolName);
132           },
133           [&](const Fortran::semantics::ObjectEntityDetails &) {
134             llvm::SmallVector<llvm::StringRef> modNames =
135                 moduleNames(ultimateSymbol);
136             llvm::Optional<llvm::StringRef> optHost = hostName(ultimateSymbol);
137             if (Fortran::semantics::IsNamedConstant(ultimateSymbol))
138               return fir::NameUniquer::doConstant(modNames, optHost,
139                                                   symbolName);
140             return fir::NameUniquer::doVariable(modNames, optHost, symbolName);
141           },
142           [&](const Fortran::semantics::NamelistDetails &) {
143             llvm::SmallVector<llvm::StringRef> modNames =
144                 moduleNames(ultimateSymbol);
145             llvm::Optional<llvm::StringRef> optHost = hostName(ultimateSymbol);
146             return fir::NameUniquer::doNamelistGroup(modNames, optHost,
147                                                      symbolName);
148           },
149           [&](const Fortran::semantics::CommonBlockDetails &) {
150             return fir::NameUniquer::doCommonBlock(symbolName);
151           },
152           [&](const Fortran::semantics::DerivedTypeDetails &) -> std::string {
153             // Derived type mangling must used mangleName(DerivedTypeSpec&) so
154             // that kind type parameter values can be mangled.
155             llvm::report_fatal_error(
156                 "only derived type instances can be mangled");
157           },
158           [](const auto &) -> std::string { TODO_NOLOC("symbol mangling"); },
159       },
160       ultimateSymbol.details());
161 }
162 
163 std::string Fortran::lower::mangle::mangleName(
164     const Fortran::semantics::DerivedTypeSpec &derivedType) {
165   // Resolve host and module association before mangling
166   const Fortran::semantics::Symbol &ultimateSymbol =
167       derivedType.typeSymbol().GetUltimate();
168   llvm::StringRef symbolName = toStringRef(ultimateSymbol.name());
169   llvm::SmallVector<llvm::StringRef> modNames = moduleNames(ultimateSymbol);
170   llvm::Optional<llvm::StringRef> optHost = hostName(ultimateSymbol);
171   llvm::SmallVector<std::int64_t> kinds;
172   for (const auto &param :
173        Fortran::semantics::OrderParameterDeclarations(ultimateSymbol)) {
174     const auto &paramDetails =
175         param->get<Fortran::semantics::TypeParamDetails>();
176     if (paramDetails.attr() == Fortran::common::TypeParamAttr::Kind) {
177       const Fortran::semantics::ParamValue *paramValue =
178           derivedType.FindParameter(param->name());
179       assert(paramValue && "derived type kind parameter value not found");
180       const Fortran::semantics::MaybeIntExpr paramExpr =
181           paramValue->GetExplicit();
182       assert(paramExpr && "derived type kind param not explicit");
183       std::optional<int64_t> init =
184           Fortran::evaluate::ToInt64(paramValue->GetExplicit());
185       assert(init && "derived type kind param is not constant");
186       kinds.emplace_back(*init);
187     }
188   }
189   return fir::NameUniquer::doType(modNames, optHost, symbolName, kinds);
190 }
191 
192 std::string Fortran::lower::mangle::demangleName(llvm::StringRef name) {
193   auto result = fir::NameUniquer::deconstruct(name);
194   return result.second.name;
195 }
196 
197 //===----------------------------------------------------------------------===//
198 // Array Literals Mangling
199 //===----------------------------------------------------------------------===//
200 
201 static std::string typeToString(Fortran::common::TypeCategory cat, int kind) {
202   switch (cat) {
203   case Fortran::common::TypeCategory::Integer:
204     return "i" + std::to_string(kind);
205   case Fortran::common::TypeCategory::Real:
206     return "r" + std::to_string(kind);
207   case Fortran::common::TypeCategory::Complex:
208     return "z" + std::to_string(kind);
209   case Fortran::common::TypeCategory::Logical:
210     return "l" + std::to_string(kind);
211   case Fortran::common::TypeCategory::Character:
212     return "c" + std::to_string(kind);
213   case Fortran::common::TypeCategory::Derived:
214     // FIXME: Replace "DT" with the (fully qualified) type name.
215     return "dt.DT";
216   }
217   llvm_unreachable("bad TypeCategory");
218 }
219 
220 std::string Fortran::lower::mangle::mangleArrayLiteral(
221     const uint8_t *addr, size_t size,
222     const Fortran::evaluate::ConstantSubscripts &shape,
223     Fortran::common::TypeCategory cat, int kind,
224     Fortran::common::ConstantSubscript charLen) {
225   std::string typeId = "";
226   for (Fortran::evaluate::ConstantSubscript extent : shape)
227     typeId.append(std::to_string(extent)).append("x");
228   if (charLen >= 0)
229     typeId.append(std::to_string(charLen)).append("x");
230   typeId.append(typeToString(cat, kind));
231   std::string name =
232       fir::NameUniquer::doGenerated("ro."s.append(typeId).append("."));
233   if (!size)
234     return name += "null";
235   llvm::MD5 hashValue{};
236   hashValue.update(llvm::ArrayRef<uint8_t>{addr, size});
237   llvm::MD5::MD5Result hashResult;
238   hashValue.final(hashResult);
239   llvm::SmallString<32> hashString;
240   llvm::MD5::stringifyResult(hashResult, hashString);
241   return name += hashString.c_str();
242 }
243 
244 //===----------------------------------------------------------------------===//
245 // Intrinsic Procedure Mangling
246 //===----------------------------------------------------------------------===//
247 
248 /// Helper to encode type into string for intrinsic procedure names.
249 /// Note: mlir has Type::dump(ostream) methods but it may add "!" that is not
250 /// suitable for function names.
251 static std::string typeToString(mlir::Type t) {
252   if (auto refT{t.dyn_cast<fir::ReferenceType>()})
253     return "ref_" + typeToString(refT.getEleTy());
254   if (auto i{t.dyn_cast<mlir::IntegerType>()}) {
255     return "i" + std::to_string(i.getWidth());
256   }
257   if (auto cplx{t.dyn_cast<fir::ComplexType>()}) {
258     return "z" + std::to_string(cplx.getFKind());
259   }
260   if (auto real{t.dyn_cast<fir::RealType>()}) {
261     return "r" + std::to_string(real.getFKind());
262   }
263   if (auto f{t.dyn_cast<mlir::FloatType>()}) {
264     return "f" + std::to_string(f.getWidth());
265   }
266   if (auto logical{t.dyn_cast<fir::LogicalType>()}) {
267     return "l" + std::to_string(logical.getFKind());
268   }
269   if (auto character{t.dyn_cast<fir::CharacterType>()}) {
270     return "c" + std::to_string(character.getFKind());
271   }
272   if (auto boxCharacter{t.dyn_cast<fir::BoxCharType>()}) {
273     return "bc" + std::to_string(boxCharacter.getEleTy().getFKind());
274   }
275   llvm_unreachable("no mangling for type");
276 }
277 
278 std::string fir::mangleIntrinsicProcedure(llvm::StringRef intrinsic,
279                                           mlir::FunctionType funTy) {
280   std::string name = "fir.";
281   name.append(intrinsic.str()).append(".");
282   assert(funTy.getNumResults() == 1 && "only function mangling supported");
283   name.append(typeToString(funTy.getResult(0)));
284   unsigned e = funTy.getNumInputs();
285   for (decltype(e) i = 0; i < e; ++i)
286     name.append(".").append(typeToString(funTy.getInput(i)));
287   return name;
288 }
289