1 //===-- Allocatable.cpp -- Allocatable statements lowering ----------------===//
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 // Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
10 //
11 //===----------------------------------------------------------------------===//
12 
13 #include "flang/Lower/Allocatable.h"
14 #include "flang/Evaluate/tools.h"
15 #include "flang/Lower/AbstractConverter.h"
16 #include "flang/Lower/PFTBuilder.h"
17 #include "flang/Lower/Runtime.h"
18 #include "flang/Lower/StatementContext.h"
19 #include "flang/Lower/Todo.h"
20 #include "flang/Optimizer/Builder/FIRBuilder.h"
21 #include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
22 #include "flang/Optimizer/Dialect/FIROps.h"
23 #include "flang/Optimizer/Dialect/FIROpsSupport.h"
24 #include "flang/Optimizer/Support/FatalError.h"
25 #include "flang/Parser/parse-tree.h"
26 #include "flang/Semantics/tools.h"
27 #include "flang/Semantics/type.h"
28 #include "llvm/Support/CommandLine.h"
29 
30 /// By default fir memory operation fir::AllocMemOp/fir::FreeMemOp are used.
31 /// This switch allow forcing the use of runtime and descriptors for everything.
32 /// This is mainly intended as a debug switch.
33 static llvm::cl::opt<bool> useAllocateRuntime(
34     "use-alloc-runtime",
35     llvm::cl::desc("Lower allocations to fortran runtime calls"),
36     llvm::cl::init(false));
37 /// Switch to force lowering of allocatable and pointers to descriptors in all
38 /// cases for debug purposes.
39 static llvm::cl::opt<bool> useDescForMutableBox(
40     "use-desc-for-alloc",
41     llvm::cl::desc("Always use descriptors for POINTER and ALLOCATABLE"),
42     llvm::cl::init(false));
43 
44 //===----------------------------------------------------------------------===//
45 // MutableBoxValue creation implementation
46 //===----------------------------------------------------------------------===//
47 
48 /// Is this symbol a pointer to a pointer array that does not have the
49 /// CONTIGUOUS attribute ?
50 static inline bool
51 isNonContiguousArrayPointer(const Fortran::semantics::Symbol &sym) {
52   return Fortran::semantics::IsPointer(sym) && sym.Rank() != 0 &&
53          !sym.attrs().test(Fortran::semantics::Attr::CONTIGUOUS);
54 }
55 
56 /// Is this a local procedure symbol in a procedure that contains internal
57 /// procedures ?
58 static bool mayBeCapturedInInternalProc(const Fortran::semantics::Symbol &sym) {
59   const Fortran::semantics::Scope &owner = sym.owner();
60   Fortran::semantics::Scope::Kind kind = owner.kind();
61   // Test if this is a procedure scope that contains a subprogram scope that is
62   // not an interface.
63   if (kind == Fortran::semantics::Scope::Kind::Subprogram ||
64       kind == Fortran::semantics::Scope::Kind::MainProgram)
65     for (const Fortran::semantics::Scope &childScope : owner.children())
66       if (childScope.kind() == Fortran::semantics::Scope::Kind::Subprogram)
67         if (const Fortran::semantics::Symbol *childSym = childScope.symbol())
68           if (const auto *details =
69                   childSym->detailsIf<Fortran::semantics::SubprogramDetails>())
70             if (!details->isInterface())
71               return true;
72   return false;
73 }
74 
75 /// In case it is safe to track the properties in variables outside a
76 /// descriptor, create the variables to hold the mutable properties of the
77 /// entity var. The variables are not initialized here.
78 static fir::MutableProperties
79 createMutableProperties(Fortran::lower::AbstractConverter &converter,
80                         mlir::Location loc,
81                         const Fortran::lower::pft::Variable &var,
82                         mlir::ValueRange nonDeferredParams) {
83   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
84   const Fortran::semantics::Symbol &sym = var.getSymbol();
85   // Globals and dummies may be associated, creating local variables would
86   // require keeping the values and descriptor before and after every single
87   // impure calls in the current scope (not only the ones taking the variable as
88   // arguments. All.) Volatile means the variable may change in ways not defined
89   // per Fortran, so lowering can most likely not keep the descriptor and values
90   // in sync as needed.
91   // Pointers to non contiguous arrays need to be represented with a fir.box to
92   // account for the discontiguity.
93   // Pointer/Allocatable in internal procedure are descriptors in the host link,
94   // and it would increase complexity to sync this descriptor with the local
95   // values every time the host link is escaping.
96   if (var.isGlobal() || Fortran::semantics::IsDummy(sym) ||
97       Fortran::semantics::IsFunctionResult(sym) ||
98       sym.attrs().test(Fortran::semantics::Attr::VOLATILE) ||
99       isNonContiguousArrayPointer(sym) || useAllocateRuntime ||
100       useDescForMutableBox || mayBeCapturedInInternalProc(sym))
101     return {};
102   fir::MutableProperties mutableProperties;
103   std::string name = converter.mangleName(sym);
104   mlir::Type baseAddrTy = converter.genType(sym);
105   if (auto boxType = baseAddrTy.dyn_cast<fir::BoxType>())
106     baseAddrTy = boxType.getEleTy();
107   // Allocate and set a variable to hold the address.
108   // It will be set to null in setUnallocatedStatus.
109   mutableProperties.addr =
110       builder.allocateLocal(loc, baseAddrTy, name + ".addr", "",
111                             /*shape=*/llvm::None, /*typeparams=*/llvm::None);
112   // Allocate variables to hold lower bounds and extents.
113   int rank = sym.Rank();
114   mlir::Type idxTy = builder.getIndexType();
115   for (decltype(rank) i = 0; i < rank; ++i) {
116     mlir::Value lboundVar =
117         builder.allocateLocal(loc, idxTy, name + ".lb" + std::to_string(i), "",
118                               /*shape=*/llvm::None, /*typeparams=*/llvm::None);
119     mlir::Value extentVar =
120         builder.allocateLocal(loc, idxTy, name + ".ext" + std::to_string(i), "",
121                               /*shape=*/llvm::None, /*typeparams=*/llvm::None);
122     mutableProperties.lbounds.emplace_back(lboundVar);
123     mutableProperties.extents.emplace_back(extentVar);
124   }
125 
126   // Allocate variable to hold deferred length parameters.
127   mlir::Type eleTy = baseAddrTy;
128   if (auto newTy = fir::dyn_cast_ptrEleTy(eleTy))
129     eleTy = newTy;
130   if (auto seqTy = eleTy.dyn_cast<fir::SequenceType>())
131     eleTy = seqTy.getEleTy();
132   if (auto record = eleTy.dyn_cast<fir::RecordType>())
133     if (record.getNumLenParams() != 0)
134       TODO(loc, "deferred length type parameters.");
135   if (fir::isa_char(eleTy) && nonDeferredParams.empty()) {
136     mlir::Value lenVar =
137         builder.allocateLocal(loc, builder.getCharacterLengthType(),
138                               name + ".len", "", /*shape=*/llvm::None,
139                               /*typeparams=*/llvm::None);
140     mutableProperties.deferredParams.emplace_back(lenVar);
141   }
142   return mutableProperties;
143 }
144 
145 fir::MutableBoxValue Fortran::lower::createMutableBox(
146     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
147     const Fortran::lower::pft::Variable &var, mlir::Value boxAddr,
148     mlir::ValueRange nonDeferredParams) {
149 
150   fir::MutableProperties mutableProperties =
151       createMutableProperties(converter, loc, var, nonDeferredParams);
152   fir::MutableBoxValue box(boxAddr, nonDeferredParams, mutableProperties);
153   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
154   if (!var.isGlobal() && !Fortran::semantics::IsDummy(var.getSymbol()))
155     fir::factory::disassociateMutableBox(builder, loc, box);
156   return box;
157 }
158