Bug Summary

File:build/source/flang/lib/Lower/ConvertExpr.cpp
Warning:line 6981, column 3
Potential memory leak

Annotated Source Code

Press '?' to see keyboard shortcuts

clang -cc1 -cc1 -triple x86_64-pc-linux-gnu -analyze -disable-free -clear-ast-before-backend -disable-llvm-verifier -discard-value-names -main-file-name ConvertExpr.cpp -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=cplusplus -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -analyzer-config-compatibility-mode=true -mrelocation-model pic -pic-level 2 -mframe-pointer=none -relaxed-aliasing -fmath-errno -ffp-contract=on -fno-rounding-math -mconstructor-aliases -funwind-tables=2 -target-cpu x86-64 -tune-cpu generic -debugger-tuning=gdb -ffunction-sections -fdata-sections -fcoverage-compilation-dir=/build/source/build-llvm/tools/clang/stage2-bins -resource-dir /usr/lib/llvm-17/lib/clang/17 -isystem /build/source/llvm/../mlir/include -isystem tools/mlir/include -isystem tools/clang/include -isystem /build/source/llvm/../clang/include -D FLANG_INCLUDE_TESTS=1 -D FLANG_LITTLE_ENDIAN=1 -D FLANG_VENDOR="Debian " -D _DEBUG -D _GLIBCXX_ASSERTIONS -D _GNU_SOURCE -D _LIBCPP_ENABLE_ASSERTIONS -D __STDC_CONSTANT_MACROS -D __STDC_FORMAT_MACROS -D __STDC_LIMIT_MACROS -I tools/flang/lib/Lower -I /build/source/flang/lib/Lower -I /build/source/flang/include -I tools/flang/include -I include -I /build/source/llvm/include -D _FORTIFY_SOURCE=2 -D NDEBUG -U NDEBUG -internal-isystem /usr/lib/gcc/x86_64-linux-gnu/10/../../../../include/c++/10 -internal-isystem /usr/lib/gcc/x86_64-linux-gnu/10/../../../../include/x86_64-linux-gnu/c++/10 -internal-isystem /usr/lib/gcc/x86_64-linux-gnu/10/../../../../include/c++/10/backward -internal-isystem /usr/lib/llvm-17/lib/clang/17/include -internal-isystem /usr/local/include -internal-isystem /usr/lib/gcc/x86_64-linux-gnu/10/../../../../x86_64-linux-gnu/include -internal-externc-isystem /usr/include/x86_64-linux-gnu -internal-externc-isystem /include -internal-externc-isystem /usr/include -fmacro-prefix-map=/build/source/build-llvm/tools/clang/stage2-bins=build-llvm/tools/clang/stage2-bins -fmacro-prefix-map=/build/source/= -fcoverage-prefix-map=/build/source/build-llvm/tools/clang/stage2-bins=build-llvm/tools/clang/stage2-bins -fcoverage-prefix-map=/build/source/= -source-date-epoch 1683717183 -O2 -Wno-unused-command-line-argument -Wno-unused-parameter -Wwrite-strings -Wno-missing-field-initializers -Wno-long-long -Wno-maybe-uninitialized -Wno-class-memaccess -Wno-redundant-move -Wno-pessimizing-move -Wno-noexcept-type -Wno-comment -Wno-misleading-indentation -Wno-deprecated-copy -Wno-ctad-maybe-unsupported -std=c++17 -fdeprecated-macro -fdebug-compilation-dir=/build/source/build-llvm/tools/clang/stage2-bins -fdebug-prefix-map=/build/source/build-llvm/tools/clang/stage2-bins=build-llvm/tools/clang/stage2-bins -fdebug-prefix-map=/build/source/= -ferror-limit 19 -fvisibility-inlines-hidden -stack-protector 2 -fgnuc-version=4.2.1 -fcolor-diagnostics -vectorize-loops -vectorize-slp -analyzer-output=html -analyzer-config stable-report-filename=true -faddrsig -D__GCC_HAVE_DWARF2_CFI_ASM=1 -o /tmp/scan-build-2023-05-10-133810-16478-1 -x c++ /build/source/flang/lib/Lower/ConvertExpr.cpp

/build/source/flang/lib/Lower/ConvertExpr.cpp

1//===-- ConvertExpr.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// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
10//
11//===----------------------------------------------------------------------===//
12
13#include "flang/Lower/ConvertExpr.h"
14#include "flang/Common/default-kinds.h"
15#include "flang/Common/unwrap.h"
16#include "flang/Evaluate/fold.h"
17#include "flang/Evaluate/real.h"
18#include "flang/Evaluate/traverse.h"
19#include "flang/Lower/Allocatable.h"
20#include "flang/Lower/Bridge.h"
21#include "flang/Lower/BuiltinModules.h"
22#include "flang/Lower/CallInterface.h"
23#include "flang/Lower/Coarray.h"
24#include "flang/Lower/ComponentPath.h"
25#include "flang/Lower/ConvertCall.h"
26#include "flang/Lower/ConvertConstant.h"
27#include "flang/Lower/ConvertProcedureDesignator.h"
28#include "flang/Lower/ConvertType.h"
29#include "flang/Lower/ConvertVariable.h"
30#include "flang/Lower/CustomIntrinsicCall.h"
31#include "flang/Lower/DumpEvaluateExpr.h"
32#include "flang/Lower/Mangler.h"
33#include "flang/Lower/Runtime.h"
34#include "flang/Lower/Support/Utils.h"
35#include "flang/Optimizer/Builder/Character.h"
36#include "flang/Optimizer/Builder/Complex.h"
37#include "flang/Optimizer/Builder/Factory.h"
38#include "flang/Optimizer/Builder/IntrinsicCall.h"
39#include "flang/Optimizer/Builder/Runtime/Assign.h"
40#include "flang/Optimizer/Builder/Runtime/Character.h"
41#include "flang/Optimizer/Builder/Runtime/Derived.h"
42#include "flang/Optimizer/Builder/Runtime/Inquiry.h"
43#include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
44#include "flang/Optimizer/Builder/Runtime/Ragged.h"
45#include "flang/Optimizer/Builder/Todo.h"
46#include "flang/Optimizer/Dialect/FIRAttr.h"
47#include "flang/Optimizer/Dialect/FIRDialect.h"
48#include "flang/Optimizer/Dialect/FIROpsSupport.h"
49#include "flang/Optimizer/Support/FatalError.h"
50#include "flang/Runtime/support.h"
51#include "flang/Semantics/expression.h"
52#include "flang/Semantics/symbol.h"
53#include "flang/Semantics/tools.h"
54#include "flang/Semantics/type.h"
55#include "mlir/Dialect/Func/IR/FuncOps.h"
56#include "llvm/ADT/TypeSwitch.h"
57#include "llvm/Support/CommandLine.h"
58#include "llvm/Support/Debug.h"
59#include "llvm/Support/ErrorHandling.h"
60#include "llvm/Support/raw_ostream.h"
61#include <algorithm>
62#include <optional>
63
64#define DEBUG_TYPE"flang-lower-expr" "flang-lower-expr"
65
66using namespace Fortran::runtime;
67
68//===----------------------------------------------------------------------===//
69// The composition and structure of Fortran::evaluate::Expr is defined in
70// the various header files in include/flang/Evaluate. You are referred
71// there for more information on these data structures. Generally speaking,
72// these data structures are a strongly typed family of abstract data types
73// that, composed as trees, describe the syntax of Fortran expressions.
74//
75// This part of the bridge can traverse these tree structures and lower them
76// to the correct FIR representation in SSA form.
77//===----------------------------------------------------------------------===//
78
79static llvm::cl::opt<bool> generateArrayCoordinate(
80 "gen-array-coor",
81 llvm::cl::desc("in lowering create ArrayCoorOp instead of CoordinateOp"),
82 llvm::cl::init(false));
83
84// The default attempts to balance a modest allocation size with expected user
85// input to minimize bounds checks and reallocations during dynamic array
86// construction. Some user codes may have very large array constructors for
87// which the default can be increased.
88static llvm::cl::opt<unsigned> clInitialBufferSize(
89 "array-constructor-initial-buffer-size",
90 llvm::cl::desc(
91 "set the incremental array construction buffer size (default=32)"),
92 llvm::cl::init(32u));
93
94// Lower TRANSPOSE as an "elemental" function that swaps the array
95// expression's iteration space, so that no runtime call is needed.
96// This lowering may help get rid of unnecessary creation of temporary
97// arrays. Note that the runtime TRANSPOSE implementation may be different
98// from the "inline" FIR, e.g. it may diagnose out-of-memory conditions
99// during the temporary allocation whereas the inline implementation
100// relies on AllocMemOp that will silently return null in case
101// there is not enough memory.
102//
103// If it is set to false, then TRANSPOSE will be lowered using
104// a runtime call. If it is set to true, then the lowering is controlled
105// by LoweringOptions::optimizeTranspose bit (see isTransposeOptEnabled
106// function in this file).
107static llvm::cl::opt<bool> optimizeTranspose(
108 "opt-transpose",
109 llvm::cl::desc("lower transpose without using a runtime call"),
110 llvm::cl::init(true));
111
112// When copy-in/copy-out is generated for a boxed object we may
113// either produce loops to copy the data or call the Fortran runtime's
114// Assign function. Since the data copy happens under a runtime check
115// (for IsContiguous) the copy loops can hardly provide any value
116// to optimizations, instead, the optimizer just wastes compilation
117// time on these loops.
118//
119// This internal option will force the loops generation, when set
120// to true. It is false by default.
121//
122// Note that for copy-in/copy-out of non-boxed objects (e.g. for passing
123// arguments by value) we always generate loops. Since the memory for
124// such objects is contiguous, it may be better to expose them
125// to the optimizer.
126static llvm::cl::opt<bool> inlineCopyInOutForBoxes(
127 "inline-copyinout-for-boxes",
128 llvm::cl::desc(
129 "generate loops for copy-in/copy-out of objects with descriptors"),
130 llvm::cl::init(false));
131
132/// The various semantics of a program constituent (or a part thereof) as it may
133/// appear in an expression.
134///
135/// Given the following Fortran declarations.
136/// ```fortran
137/// REAL :: v1, v2, v3
138/// REAL, POINTER :: vp1
139/// REAL :: a1(c), a2(c)
140/// REAL ELEMENTAL FUNCTION f1(arg) ! array -> array
141/// FUNCTION f2(arg) ! array -> array
142/// vp1 => v3 ! 1
143/// v1 = v2 * vp1 ! 2
144/// a1 = a1 + a2 ! 3
145/// a1 = f1(a2) ! 4
146/// a1 = f2(a2) ! 5
147/// ```
148///
149/// In line 1, `vp1` is a BoxAddr to copy a box value into. The box value is
150/// constructed from the DataAddr of `v3`.
151/// In line 2, `v1` is a DataAddr to copy a value into. The value is constructed
152/// from the DataValue of `v2` and `vp1`. DataValue is implicitly a double
153/// dereference in the `vp1` case.
154/// In line 3, `a1` and `a2` on the rhs are RefTransparent. The `a1` on the lhs
155/// is CopyInCopyOut as `a1` is replaced elementally by the additions.
156/// In line 4, `a2` can be RefTransparent, ByValueArg, RefOpaque, or BoxAddr if
157/// `arg` is declared as C-like pass-by-value, VALUE, INTENT(?), or ALLOCATABLE/
158/// POINTER, respectively. `a1` on the lhs is CopyInCopyOut.
159/// In line 5, `a2` may be DataAddr or BoxAddr assuming f2 is transformational.
160/// `a1` on the lhs is again CopyInCopyOut.
161enum class ConstituentSemantics {
162 // Scalar data reference semantics.
163 //
164 // For these let `v` be the location in memory of a variable with value `x`
165 DataValue, // refers to the value `x`
166 DataAddr, // refers to the address `v`
167 BoxValue, // refers to a box value containing `v`
168 BoxAddr, // refers to the address of a box value containing `v`
169
170 // Array data reference semantics.
171 //
172 // For these let `a` be the location in memory of a sequence of value `[xs]`.
173 // Let `x_i` be the `i`-th value in the sequence `[xs]`.
174
175 // Referentially transparent. Refers to the array's value, `[xs]`.
176 RefTransparent,
177 // Refers to an ephemeral address `tmp` containing value `x_i` (15.5.2.3.p7
178 // note 2). (Passing a copy by reference to simulate pass-by-value.)
179 ByValueArg,
180 // Refers to the merge of array value `[xs]` with another array value `[ys]`.
181 // This merged array value will be written into memory location `a`.
182 CopyInCopyOut,
183 // Similar to CopyInCopyOut but `a` may be a transient projection (rather than
184 // a whole array).
185 ProjectedCopyInCopyOut,
186 // Similar to ProjectedCopyInCopyOut, except the merge value is not assigned
187 // automatically by the framework. Instead, and address for `[xs]` is made
188 // accessible so that custom assignments to `[xs]` can be implemented.
189 CustomCopyInCopyOut,
190 // Referentially opaque. Refers to the address of `x_i`.
191 RefOpaque
192};
193
194/// Convert parser's INTEGER relational operators to MLIR. TODO: using
195/// unordered, but we may want to cons ordered in certain situation.
196static mlir::arith::CmpIPredicate
197translateRelational(Fortran::common::RelationalOperator rop) {
198 switch (rop) {
199 case Fortran::common::RelationalOperator::LT:
200 return mlir::arith::CmpIPredicate::slt;
201 case Fortran::common::RelationalOperator::LE:
202 return mlir::arith::CmpIPredicate::sle;
203 case Fortran::common::RelationalOperator::EQ:
204 return mlir::arith::CmpIPredicate::eq;
205 case Fortran::common::RelationalOperator::NE:
206 return mlir::arith::CmpIPredicate::ne;
207 case Fortran::common::RelationalOperator::GT:
208 return mlir::arith::CmpIPredicate::sgt;
209 case Fortran::common::RelationalOperator::GE:
210 return mlir::arith::CmpIPredicate::sge;
211 }
212 llvm_unreachable("unhandled INTEGER relational operator")::llvm::llvm_unreachable_internal("unhandled INTEGER relational operator"
, "flang/lib/Lower/ConvertExpr.cpp", 212)
;
213}
214
215/// Convert parser's REAL relational operators to MLIR.
216/// The choice of order (O prefix) vs unorder (U prefix) follows Fortran 2018
217/// requirements in the IEEE context (table 17.1 of F2018). This choice is
218/// also applied in other contexts because it is easier and in line with
219/// other Fortran compilers.
220/// FIXME: The signaling/quiet aspect of the table 17.1 requirement is not
221/// fully enforced. FIR and LLVM `fcmp` instructions do not give any guarantee
222/// whether the comparison will signal or not in case of quiet NaN argument.
223static mlir::arith::CmpFPredicate
224translateFloatRelational(Fortran::common::RelationalOperator rop) {
225 switch (rop) {
226 case Fortran::common::RelationalOperator::LT:
227 return mlir::arith::CmpFPredicate::OLT;
228 case Fortran::common::RelationalOperator::LE:
229 return mlir::arith::CmpFPredicate::OLE;
230 case Fortran::common::RelationalOperator::EQ:
231 return mlir::arith::CmpFPredicate::OEQ;
232 case Fortran::common::RelationalOperator::NE:
233 return mlir::arith::CmpFPredicate::UNE;
234 case Fortran::common::RelationalOperator::GT:
235 return mlir::arith::CmpFPredicate::OGT;
236 case Fortran::common::RelationalOperator::GE:
237 return mlir::arith::CmpFPredicate::OGE;
238 }
239 llvm_unreachable("unhandled REAL relational operator")::llvm::llvm_unreachable_internal("unhandled REAL relational operator"
, "flang/lib/Lower/ConvertExpr.cpp", 239)
;
240}
241
242static mlir::Value genActualIsPresentTest(fir::FirOpBuilder &builder,
243 mlir::Location loc,
244 fir::ExtendedValue actual) {
245 if (const auto *ptrOrAlloc = actual.getBoxOf<fir::MutableBoxValue>())
246 return fir::factory::genIsAllocatedOrAssociatedTest(builder, loc,
247 *ptrOrAlloc);
248 // Optional case (not that optional allocatable/pointer cannot be absent
249 // when passed to CMPLX as per 15.5.2.12 point 3 (7) and (8)). It is
250 // therefore possible to catch them in the `then` case above.
251 return builder.create<fir::IsPresentOp>(loc, builder.getI1Type(),
252 fir::getBase(actual));
253}
254
255/// Convert the array_load, `load`, to an extended value. If `path` is not
256/// empty, then traverse through the components designated. The base value is
257/// `newBase`. This does not accept an array_load with a slice operand.
258static fir::ExtendedValue
259arrayLoadExtValue(fir::FirOpBuilder &builder, mlir::Location loc,
260 fir::ArrayLoadOp load, llvm::ArrayRef<mlir::Value> path,
261 mlir::Value newBase, mlir::Value newLen = {}) {
262 // Recover the extended value from the load.
263 if (load.getSlice())
264 fir::emitFatalError(loc, "array_load with slice is not allowed");
265 mlir::Type arrTy = load.getType();
266 if (!path.empty()) {
267 mlir::Type ty = fir::applyPathToType(arrTy, path);
268 if (!ty)
269 fir::emitFatalError(loc, "path does not apply to type");
270 if (!ty.isa<fir::SequenceType>()) {
271 if (fir::isa_char(ty)) {
272 mlir::Value len = newLen;
273 if (!len)
274 len = fir::factory::CharacterExprHelper{builder, loc}.getLength(
275 load.getMemref());
276 if (!len) {
277 assert(load.getTypeparams().size() == 1 &&(static_cast <bool> (load.getTypeparams().size() == 1 &&
"length must be in array_load") ? void (0) : __assert_fail (
"load.getTypeparams().size() == 1 && \"length must be in array_load\""
, "flang/lib/Lower/ConvertExpr.cpp", 278, __extension__ __PRETTY_FUNCTION__
))
278 "length must be in array_load")(static_cast <bool> (load.getTypeparams().size() == 1 &&
"length must be in array_load") ? void (0) : __assert_fail (
"load.getTypeparams().size() == 1 && \"length must be in array_load\""
, "flang/lib/Lower/ConvertExpr.cpp", 278, __extension__ __PRETTY_FUNCTION__
))
;
279 len = load.getTypeparams()[0];
280 }
281 return fir::CharBoxValue{newBase, len};
282 }
283 return newBase;
284 }
285 arrTy = ty.cast<fir::SequenceType>();
286 }
287
288 auto arrayToExtendedValue =
289 [&](const llvm::SmallVector<mlir::Value> &extents,
290 const llvm::SmallVector<mlir::Value> &origins) -> fir::ExtendedValue {
291 mlir::Type eleTy = fir::unwrapSequenceType(arrTy);
292 if (fir::isa_char(eleTy)) {
293 mlir::Value len = newLen;
294 if (!len)
295 len = fir::factory::CharacterExprHelper{builder, loc}.getLength(
296 load.getMemref());
297 if (!len) {
298 assert(load.getTypeparams().size() == 1 &&(static_cast <bool> (load.getTypeparams().size() == 1 &&
"length must be in array_load") ? void (0) : __assert_fail (
"load.getTypeparams().size() == 1 && \"length must be in array_load\""
, "flang/lib/Lower/ConvertExpr.cpp", 299, __extension__ __PRETTY_FUNCTION__
))
299 "length must be in array_load")(static_cast <bool> (load.getTypeparams().size() == 1 &&
"length must be in array_load") ? void (0) : __assert_fail (
"load.getTypeparams().size() == 1 && \"length must be in array_load\""
, "flang/lib/Lower/ConvertExpr.cpp", 299, __extension__ __PRETTY_FUNCTION__
))
;
300 len = load.getTypeparams()[0];
301 }
302 return fir::CharArrayBoxValue(newBase, len, extents, origins);
303 }
304 return fir::ArrayBoxValue(newBase, extents, origins);
305 };
306 // Use the shape op, if there is one.
307 mlir::Value shapeVal = load.getShape();
308 if (shapeVal) {
309 if (!mlir::isa<fir::ShiftOp>(shapeVal.getDefiningOp())) {
310 auto extents = fir::factory::getExtents(shapeVal);
311 auto origins = fir::factory::getOrigins(shapeVal);
312 return arrayToExtendedValue(extents, origins);
313 }
314 if (!fir::isa_box_type(load.getMemref().getType()))
315 fir::emitFatalError(loc, "shift op is invalid in this context");
316 }
317
318 // If we're dealing with the array_load op (not a subobject) and the load does
319 // not have any type parameters, then read the extents from the original box.
320 // The origin may be either from the box or a shift operation. Create and
321 // return the array extended value.
322 if (path.empty() && load.getTypeparams().empty()) {
323 auto oldBox = load.getMemref();
324 fir::ExtendedValue exv = fir::factory::readBoxValue(builder, loc, oldBox);
325 auto extents = fir::factory::getExtents(loc, builder, exv);
326 auto origins = fir::factory::getNonDefaultLowerBounds(builder, loc, exv);
327 if (shapeVal) {
328 // shapeVal is a ShiftOp and load.memref() is a boxed value.
329 newBase = builder.create<fir::ReboxOp>(loc, oldBox.getType(), oldBox,
330 shapeVal, /*slice=*/mlir::Value{});
331 origins = fir::factory::getOrigins(shapeVal);
332 }
333 return fir::substBase(arrayToExtendedValue(extents, origins), newBase);
334 }
335 TODO(loc, "path to a POINTER, ALLOCATABLE, or other component that requires "do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "337" ": not yet implemented: ") + llvm::Twine("path to a POINTER, ALLOCATABLE, or other component that requires "
"dereferencing; generating the type parameters is a hard " "requirement for correctness."
), false); } while (false)
336 "dereferencing; generating the type parameters is a hard "do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "337" ": not yet implemented: ") + llvm::Twine("path to a POINTER, ALLOCATABLE, or other component that requires "
"dereferencing; generating the type parameters is a hard " "requirement for correctness."
), false); } while (false)
337 "requirement for correctness.")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "337" ": not yet implemented: ") + llvm::Twine("path to a POINTER, ALLOCATABLE, or other component that requires "
"dereferencing; generating the type parameters is a hard " "requirement for correctness."
), false); } while (false)
;
338}
339
340/// Place \p exv in memory if it is not already a memory reference. If
341/// \p forceValueType is provided, the value is first casted to the provided
342/// type before being stored (this is mainly intended for logicals whose value
343/// may be `i1` but needed to be stored as Fortran logicals).
344static fir::ExtendedValue
345placeScalarValueInMemory(fir::FirOpBuilder &builder, mlir::Location loc,
346 const fir::ExtendedValue &exv,
347 mlir::Type storageType) {
348 mlir::Value valBase = fir::getBase(exv);
349 if (fir::conformsWithPassByRef(valBase.getType()))
350 return exv;
351
352 assert(!fir::hasDynamicSize(storageType) &&(static_cast <bool> (!fir::hasDynamicSize(storageType) &&
"only expect statically sized scalars to be by value") ? void
(0) : __assert_fail ("!fir::hasDynamicSize(storageType) && \"only expect statically sized scalars to be by value\""
, "flang/lib/Lower/ConvertExpr.cpp", 353, __extension__ __PRETTY_FUNCTION__
))
353 "only expect statically sized scalars to be by value")(static_cast <bool> (!fir::hasDynamicSize(storageType) &&
"only expect statically sized scalars to be by value") ? void
(0) : __assert_fail ("!fir::hasDynamicSize(storageType) && \"only expect statically sized scalars to be by value\""
, "flang/lib/Lower/ConvertExpr.cpp", 353, __extension__ __PRETTY_FUNCTION__
))
;
354
355 // Since `a` is not itself a valid referent, determine its value and
356 // create a temporary location at the beginning of the function for
357 // referencing.
358 mlir::Value val = builder.createConvert(loc, storageType, valBase);
359 mlir::Value temp = builder.createTemporary(
360 loc, storageType,
361 llvm::ArrayRef<mlir::NamedAttribute>{
362 Fortran::lower::getAdaptToByRefAttr(builder)});
363 builder.create<fir::StoreOp>(loc, val, temp);
364 return fir::substBase(exv, temp);
365}
366
367// Copy a copy of scalar \p exv in a new temporary.
368static fir::ExtendedValue
369createInMemoryScalarCopy(fir::FirOpBuilder &builder, mlir::Location loc,
370 const fir::ExtendedValue &exv) {
371 assert(exv.rank() == 0 && "input to scalar memory copy must be a scalar")(static_cast <bool> (exv.rank() == 0 && "input to scalar memory copy must be a scalar"
) ? void (0) : __assert_fail ("exv.rank() == 0 && \"input to scalar memory copy must be a scalar\""
, "flang/lib/Lower/ConvertExpr.cpp", 371, __extension__ __PRETTY_FUNCTION__
))
;
372 if (exv.getCharBox() != nullptr)
373 return fir::factory::CharacterExprHelper{builder, loc}.createTempFrom(exv);
374 if (fir::isDerivedWithLenParameters(exv))
375 TODO(loc, "copy derived type with length parameters")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "375" ": not yet implemented: ") + llvm::Twine("copy derived type with length parameters"
), false); } while (false)
;
376 mlir::Type type = fir::unwrapPassByRefType(fir::getBase(exv).getType());
377 fir::ExtendedValue temp = builder.createTemporary(loc, type);
378 fir::factory::genScalarAssignment(builder, loc, temp, exv);
379 return temp;
380}
381
382// An expression with non-zero rank is an array expression.
383template <typename A>
384static bool isArray(const A &x) {
385 return x.Rank() != 0;
386}
387
388/// Is this a variable wrapped in parentheses?
389template <typename A>
390static bool isParenthesizedVariable(const A &) {
391 return false;
392}
393template <typename T>
394static bool isParenthesizedVariable(const Fortran::evaluate::Expr<T> &expr) {
395 using ExprVariant = decltype(Fortran::evaluate::Expr<T>::u);
396 using Parentheses = Fortran::evaluate::Parentheses<T>;
397 if constexpr (Fortran::common::HasMember<Parentheses, ExprVariant>) {
398 if (const auto *parentheses = std::get_if<Parentheses>(&expr.u))
399 return Fortran::evaluate::IsVariable(parentheses->left());
400 return false;
401 } else {
402 return std::visit([&](const auto &x) { return isParenthesizedVariable(x); },
403 expr.u);
404 }
405}
406
407/// Generate a load of a value from an address. Beware that this will lose
408/// any dynamic type information for polymorphic entities (note that unlimited
409/// polymorphic cannot be loaded and must not be provided here).
410static fir::ExtendedValue genLoad(fir::FirOpBuilder &builder,
411 mlir::Location loc,
412 const fir::ExtendedValue &addr) {
413 return addr.match(
414 [](const fir::CharBoxValue &box) -> fir::ExtendedValue { return box; },
415 [&](const fir::PolymorphicValue &p) -> fir::ExtendedValue {
416 if (fir::unwrapRefType(fir::getBase(p).getType())
417 .isa<fir::RecordType>())
418 return p;
419 mlir::Value load = builder.create<fir::LoadOp>(loc, fir::getBase(p));
420 return fir::PolymorphicValue(load, p.getSourceBox());
421 },
422 [&](const fir::UnboxedValue &v) -> fir::ExtendedValue {
423 if (fir::unwrapRefType(fir::getBase(v).getType())
424 .isa<fir::RecordType>())
425 return v;
426 return builder.create<fir::LoadOp>(loc, fir::getBase(v));
427 },
428 [&](const fir::MutableBoxValue &box) -> fir::ExtendedValue {
429 return genLoad(builder, loc,
430 fir::factory::genMutableBoxRead(builder, loc, box));
431 },
432 [&](const fir::BoxValue &box) -> fir::ExtendedValue {
433 return genLoad(builder, loc,
434 fir::factory::readBoxValue(builder, loc, box));
435 },
436 [&](const auto &) -> fir::ExtendedValue {
437 fir::emitFatalError(
438 loc, "attempting to load whole array or procedure address");
439 });
440}
441
442/// Create an optional dummy argument value from entity \p exv that may be
443/// absent. This can only be called with numerical or logical scalar \p exv.
444/// If \p exv is considered absent according to 15.5.2.12 point 1., the returned
445/// value is zero (or false), otherwise it is the value of \p exv.
446static fir::ExtendedValue genOptionalValue(fir::FirOpBuilder &builder,
447 mlir::Location loc,
448 const fir::ExtendedValue &exv,
449 mlir::Value isPresent) {
450 mlir::Type eleType = fir::getBaseTypeOf(exv);
451 assert(exv.rank() == 0 && fir::isa_trivial(eleType) &&(static_cast <bool> (exv.rank() == 0 && fir::isa_trivial
(eleType) && "must be a numerical or logical scalar")
? void (0) : __assert_fail ("exv.rank() == 0 && fir::isa_trivial(eleType) && \"must be a numerical or logical scalar\""
, "flang/lib/Lower/ConvertExpr.cpp", 452, __extension__ __PRETTY_FUNCTION__
))
452 "must be a numerical or logical scalar")(static_cast <bool> (exv.rank() == 0 && fir::isa_trivial
(eleType) && "must be a numerical or logical scalar")
? void (0) : __assert_fail ("exv.rank() == 0 && fir::isa_trivial(eleType) && \"must be a numerical or logical scalar\""
, "flang/lib/Lower/ConvertExpr.cpp", 452, __extension__ __PRETTY_FUNCTION__
))
;
453 return builder
454 .genIfOp(loc, {eleType}, isPresent,
455 /*withElseRegion=*/true)
456 .genThen([&]() {
457 mlir::Value val = fir::getBase(genLoad(builder, loc, exv));
458 builder.create<fir::ResultOp>(loc, val);
459 })
460 .genElse([&]() {
461 mlir::Value zero = fir::factory::createZeroValue(builder, loc, eleType);
462 builder.create<fir::ResultOp>(loc, zero);
463 })
464 .getResults()[0];
465}
466
467/// Create an optional dummy argument address from entity \p exv that may be
468/// absent. If \p exv is considered absent according to 15.5.2.12 point 1., the
469/// returned value is a null pointer, otherwise it is the address of \p exv.
470static fir::ExtendedValue genOptionalAddr(fir::FirOpBuilder &builder,
471 mlir::Location loc,
472 const fir::ExtendedValue &exv,
473 mlir::Value isPresent) {
474 // If it is an exv pointer/allocatable, then it cannot be absent
475 // because it is passed to a non-pointer/non-allocatable.
476 if (const auto *box = exv.getBoxOf<fir::MutableBoxValue>())
477 return fir::factory::genMutableBoxRead(builder, loc, *box);
478 // If this is not a POINTER or ALLOCATABLE, then it is already an OPTIONAL
479 // address and can be passed directly.
480 return exv;
481}
482
483/// Create an optional dummy argument address from entity \p exv that may be
484/// absent. If \p exv is considered absent according to 15.5.2.12 point 1., the
485/// returned value is an absent fir.box, otherwise it is a fir.box describing \p
486/// exv.
487static fir::ExtendedValue genOptionalBox(fir::FirOpBuilder &builder,
488 mlir::Location loc,
489 const fir::ExtendedValue &exv,
490 mlir::Value isPresent) {
491 // Non allocatable/pointer optional box -> simply forward
492 if (exv.getBoxOf<fir::BoxValue>())
493 return exv;
494
495 fir::ExtendedValue newExv = exv;
496 // Optional allocatable/pointer -> Cannot be absent, but need to translate
497 // unallocated/diassociated into absent fir.box.
498 if (const auto *box = exv.getBoxOf<fir::MutableBoxValue>())
499 newExv = fir::factory::genMutableBoxRead(builder, loc, *box);
500
501 // createBox will not do create any invalid memory dereferences if exv is
502 // absent. The created fir.box will not be usable, but the SelectOp below
503 // ensures it won't be.
504 mlir::Value box = builder.createBox(loc, newExv);
505 mlir::Type boxType = box.getType();
506 auto absent = builder.create<fir::AbsentOp>(loc, boxType);
507 auto boxOrAbsent = builder.create<mlir::arith::SelectOp>(
508 loc, boxType, isPresent, box, absent);
509 return fir::BoxValue(boxOrAbsent);
510}
511
512/// Is this a call to an elemental procedure with at least one array argument?
513static bool
514isElementalProcWithArrayArgs(const Fortran::evaluate::ProcedureRef &procRef) {
515 if (procRef.IsElemental())
516 for (const std::optional<Fortran::evaluate::ActualArgument> &arg :
517 procRef.arguments())
518 if (arg && arg->Rank() != 0)
519 return true;
520 return false;
521}
522template <typename T>
523static bool isElementalProcWithArrayArgs(const Fortran::evaluate::Expr<T> &) {
524 return false;
525}
526template <>
527bool isElementalProcWithArrayArgs(const Fortran::lower::SomeExpr &x) {
528 if (const auto *procRef = std::get_if<Fortran::evaluate::ProcedureRef>(&x.u))
529 return isElementalProcWithArrayArgs(*procRef);
530 return false;
531}
532
533/// \p argTy must be a tuple (pair) of boxproc and integral types. Convert the
534/// \p funcAddr argument to a boxproc value, with the host-association as
535/// required. Call the factory function to finish creating the tuple value.
536static mlir::Value
537createBoxProcCharTuple(Fortran::lower::AbstractConverter &converter,
538 mlir::Type argTy, mlir::Value funcAddr,
539 mlir::Value charLen) {
540 auto boxTy =
541 argTy.cast<mlir::TupleType>().getType(0).cast<fir::BoxProcType>();
542 mlir::Location loc = converter.getCurrentLocation();
543 auto &builder = converter.getFirOpBuilder();
544
545 // While character procedure arguments are expected here, Fortran allows
546 // actual arguments of other types to be passed instead.
547 // To support this, we cast any reference to the expected type or extract
548 // procedures from their boxes if needed.
549 mlir::Type fromTy = funcAddr.getType();
550 mlir::Type toTy = boxTy.getEleTy();
551 if (fir::isa_ref_type(fromTy))
552 funcAddr = builder.createConvert(loc, toTy, funcAddr);
553 else if (fromTy.isa<fir::BoxProcType>())
554 funcAddr = builder.create<fir::BoxAddrOp>(loc, toTy, funcAddr);
555
556 auto boxProc = [&]() -> mlir::Value {
557 if (auto host = Fortran::lower::argumentHostAssocs(converter, funcAddr))
558 return builder.create<fir::EmboxProcOp>(
559 loc, boxTy, llvm::ArrayRef<mlir::Value>{funcAddr, host});
560 return builder.create<fir::EmboxProcOp>(loc, boxTy, funcAddr);
561 }();
562 return fir::factory::createCharacterProcedureTuple(builder, loc, argTy,
563 boxProc, charLen);
564}
565
566/// Given an optional fir.box, returns an fir.box that is the original one if
567/// it is present and it otherwise an unallocated box.
568/// Absent fir.box are implemented as a null pointer descriptor. Generated
569/// code may need to unconditionally read a fir.box that can be absent.
570/// This helper allows creating a fir.box that can be read in all cases
571/// outside of a fir.if (isPresent) region. However, the usages of the value
572/// read from such box should still only be done in a fir.if(isPresent).
573static fir::ExtendedValue
574absentBoxToUnallocatedBox(fir::FirOpBuilder &builder, mlir::Location loc,
575 const fir::ExtendedValue &exv,
576 mlir::Value isPresent) {
577 mlir::Value box = fir::getBase(exv);
578 mlir::Type boxType = box.getType();
579 assert(boxType.isa<fir::BoxType>() && "argument must be a fir.box")(static_cast <bool> (boxType.isa<fir::BoxType>() &&
"argument must be a fir.box") ? void (0) : __assert_fail ("boxType.isa<fir::BoxType>() && \"argument must be a fir.box\""
, "flang/lib/Lower/ConvertExpr.cpp", 579, __extension__ __PRETTY_FUNCTION__
))
;
580 mlir::Value emptyBox =
581 fir::factory::createUnallocatedBox(builder, loc, boxType, std::nullopt);
582 auto safeToReadBox =
583 builder.create<mlir::arith::SelectOp>(loc, isPresent, box, emptyBox);
584 return fir::substBase(exv, safeToReadBox);
585}
586
587// Helper to get the ultimate first symbol. This works around the fact that
588// symbol resolution in the front end doesn't always resolve a symbol to its
589// ultimate symbol but may leave placeholder indirections for use and host
590// associations.
591template <typename A>
592const Fortran::semantics::Symbol &getFirstSym(const A &obj) {
593 return obj.GetFirstSymbol().GetUltimate();
594}
595
596// Helper to get the ultimate last symbol.
597template <typename A>
598const Fortran::semantics::Symbol &getLastSym(const A &obj) {
599 return obj.GetLastSymbol().GetUltimate();
600}
601
602// Return true if TRANSPOSE should be lowered without a runtime call.
603static bool
604isTransposeOptEnabled(const Fortran::lower::AbstractConverter &converter) {
605 return optimizeTranspose &&
606 converter.getLoweringOptions().getOptimizeTranspose();
607}
608
609// A set of visitors to detect if the given expression
610// is a TRANSPOSE call that should be lowered without using
611// runtime TRANSPOSE implementation.
612template <typename T>
613static bool isOptimizableTranspose(const T &,
614 const Fortran::lower::AbstractConverter &) {
615 return false;
616}
617
618static bool
619isOptimizableTranspose(const Fortran::evaluate::ProcedureRef &procRef,
620 const Fortran::lower::AbstractConverter &converter) {
621 const Fortran::evaluate::SpecificIntrinsic *intrin =
622 procRef.proc().GetSpecificIntrinsic();
623 if (isTransposeOptEnabled(converter) && intrin &&
624 intrin->name == "transpose") {
625 const std::optional<Fortran::evaluate::ActualArgument> matrix =
626 procRef.arguments().at(0);
627 return !(matrix && matrix->GetType() && matrix->GetType()->IsPolymorphic());
628 }
629 return false;
630}
631
632template <typename T>
633static bool
634isOptimizableTranspose(const Fortran::evaluate::FunctionRef<T> &funcRef,
635 const Fortran::lower::AbstractConverter &converter) {
636 return isOptimizableTranspose(
637 static_cast<const Fortran::evaluate::ProcedureRef &>(funcRef), converter);
638}
639
640template <typename T>
641static bool
642isOptimizableTranspose(Fortran::evaluate::Expr<T> expr,
643 const Fortran::lower::AbstractConverter &converter) {
644 // If optimizeTranspose is not enabled, return false right away.
645 if (!isTransposeOptEnabled(converter))
646 return false;
647
648 return std::visit(
649 [&](const auto &e) { return isOptimizableTranspose(e, converter); },
650 expr.u);
651}
652
653namespace {
654
655/// Lowering of Fortran::evaluate::Expr<T> expressions
656class ScalarExprLowering {
657public:
658 using ExtValue = fir::ExtendedValue;
659
660 explicit ScalarExprLowering(mlir::Location loc,
661 Fortran::lower::AbstractConverter &converter,
662 Fortran::lower::SymMap &symMap,
663 Fortran::lower::StatementContext &stmtCtx,
664 bool inInitializer = false)
665 : location{loc}, converter{converter},
666 builder{converter.getFirOpBuilder()}, stmtCtx{stmtCtx}, symMap{symMap},
667 inInitializer{inInitializer} {}
668
669 ExtValue genExtAddr(const Fortran::lower::SomeExpr &expr) {
670 return gen(expr);
671 }
672
673 /// Lower `expr` to be passed as a fir.box argument. Do not create a temp
674 /// for the expr if it is a variable that can be described as a fir.box.
675 ExtValue genBoxArg(const Fortran::lower::SomeExpr &expr) {
676 bool saveUseBoxArg = useBoxArg;
677 useBoxArg = true;
678 ExtValue result = gen(expr);
679 useBoxArg = saveUseBoxArg;
680 return result;
681 }
682
683 ExtValue genExtValue(const Fortran::lower::SomeExpr &expr) {
684 return genval(expr);
685 }
686
687 /// Lower an expression that is a pointer or an allocatable to a
688 /// MutableBoxValue.
689 fir::MutableBoxValue
690 genMutableBoxValue(const Fortran::lower::SomeExpr &expr) {
691 // Pointers and allocatables can only be:
692 // - a simple designator "x"
693 // - a component designator "a%b(i,j)%x"
694 // - a function reference "foo()"
695 // - result of NULL() or NULL(MOLD) intrinsic.
696 // NULL() requires some context to be lowered, so it is not handled
697 // here and must be lowered according to the context where it appears.
698 ExtValue exv = std::visit(
699 [&](const auto &x) { return genMutableBoxValueImpl(x); }, expr.u);
700 const fir::MutableBoxValue *mutableBox =
701 exv.getBoxOf<fir::MutableBoxValue>();
702 if (!mutableBox)
703 fir::emitFatalError(getLoc(), "expr was not lowered to MutableBoxValue");
704 return *mutableBox;
705 }
706
707 template <typename T>
708 ExtValue genMutableBoxValueImpl(const T &) {
709 // NULL() case should not be handled here.
710 fir::emitFatalError(getLoc(), "NULL() must be lowered in its context");
711 }
712
713 /// A `NULL()` in a position where a mutable box is expected has the same
714 /// semantics as an absent optional box value. Note: this code should
715 /// be depreciated because the rank information is not known here. A
716 /// scalar fir.box is created: it should not be cast to an array box type
717 /// later, but there is no way to enforce that here.
718 ExtValue genMutableBoxValueImpl(const Fortran::evaluate::NullPointer &) {
719 mlir::Location loc = getLoc();
720 mlir::Type noneTy = mlir::NoneType::get(builder.getContext());
721 mlir::Type polyRefTy = fir::PointerType::get(noneTy);
722 mlir::Type boxType = fir::BoxType::get(polyRefTy);
723 mlir::Value nullConst = builder.createNullConstant(loc, polyRefTy);
724 mlir::Value tempBox =
725 builder.createTemporary(loc, boxType, /*shape=*/mlir::ValueRange{});
726 mlir::Value nullBox = builder.create<fir::EmboxOp>(loc, boxType, nullConst);
727 builder.create<fir::StoreOp>(loc, nullBox, tempBox);
728 return fir::MutableBoxValue(tempBox,
729 /*lenParameters=*/mlir::ValueRange{},
730 /*mutableProperties=*/{});
731 }
732
733 template <typename T>
734 ExtValue
735 genMutableBoxValueImpl(const Fortran::evaluate::FunctionRef<T> &funRef) {
736 return genRawProcedureRef(funRef, converter.genType(toEvExpr(funRef)));
737 }
738
739 template <typename T>
740 ExtValue
741 genMutableBoxValueImpl(const Fortran::evaluate::Designator<T> &designator) {
742 return std::visit(
743 Fortran::common::visitors{
744 [&](const Fortran::evaluate::SymbolRef &sym) -> ExtValue {
745 return converter.getSymbolExtendedValue(*sym, &symMap);
746 },
747 [&](const Fortran::evaluate::Component &comp) -> ExtValue {
748 return genComponent(comp);
749 },
750 [&](const auto &) -> ExtValue {
751 fir::emitFatalError(getLoc(),
752 "not an allocatable or pointer designator");
753 }},
754 designator.u);
755 }
756
757 template <typename T>
758 ExtValue genMutableBoxValueImpl(const Fortran::evaluate::Expr<T> &expr) {
759 return std::visit([&](const auto &x) { return genMutableBoxValueImpl(x); },
760 expr.u);
761 }
762
763 mlir::Location getLoc() { return location; }
764
765 template <typename A>
766 mlir::Value genunbox(const A &expr) {
767 ExtValue e = genval(expr);
768 if (const fir::UnboxedValue *r = e.getUnboxed())
769 return *r;
770 fir::emitFatalError(getLoc(), "unboxed expression expected");
771 }
772
773 /// Generate an integral constant of `value`
774 template <int KIND>
775 mlir::Value genIntegerConstant(mlir::MLIRContext *context,
776 std::int64_t value) {
777 mlir::Type type =
778 converter.genType(Fortran::common::TypeCategory::Integer, KIND);
779 return builder.createIntegerConstant(getLoc(), type, value);
780 }
781
782 /// Generate a logical/boolean constant of `value`
783 mlir::Value genBoolConstant(bool value) {
784 return builder.createBool(getLoc(), value);
785 }
786
787 mlir::Type getSomeKindInteger() { return builder.getIndexType(); }
788
789 mlir::func::FuncOp getFunction(llvm::StringRef name,
790 mlir::FunctionType funTy) {
791 if (mlir::func::FuncOp func = builder.getNamedFunction(name))
792 return func;
793 return builder.createFunction(getLoc(), name, funTy);
794 }
795
796 template <typename OpTy>
797 mlir::Value createCompareOp(mlir::arith::CmpIPredicate pred,
798 const ExtValue &left, const ExtValue &right) {
799 if (const fir::UnboxedValue *lhs = left.getUnboxed())
800 if (const fir::UnboxedValue *rhs = right.getUnboxed())
801 return builder.create<OpTy>(getLoc(), pred, *lhs, *rhs);
802 fir::emitFatalError(getLoc(), "array compare should be handled in genarr");
803 }
804 template <typename OpTy, typename A>
805 mlir::Value createCompareOp(const A &ex, mlir::arith::CmpIPredicate pred) {
806 ExtValue left = genval(ex.left());
807 return createCompareOp<OpTy>(pred, left, genval(ex.right()));
808 }
809
810 template <typename OpTy>
811 mlir::Value createFltCmpOp(mlir::arith::CmpFPredicate pred,
812 const ExtValue &left, const ExtValue &right) {
813 if (const fir::UnboxedValue *lhs = left.getUnboxed())
814 if (const fir::UnboxedValue *rhs = right.getUnboxed())
815 return builder.create<OpTy>(getLoc(), pred, *lhs, *rhs);
816 fir::emitFatalError(getLoc(), "array compare should be handled in genarr");
817 }
818 template <typename OpTy, typename A>
819 mlir::Value createFltCmpOp(const A &ex, mlir::arith::CmpFPredicate pred) {
820 ExtValue left = genval(ex.left());
821 return createFltCmpOp<OpTy>(pred, left, genval(ex.right()));
822 }
823
824 /// Create a call to the runtime to compare two CHARACTER values.
825 /// Precondition: This assumes that the two values have `fir.boxchar` type.
826 mlir::Value createCharCompare(mlir::arith::CmpIPredicate pred,
827 const ExtValue &left, const ExtValue &right) {
828 return fir::runtime::genCharCompare(builder, getLoc(), pred, left, right);
829 }
830
831 template <typename A>
832 mlir::Value createCharCompare(const A &ex, mlir::arith::CmpIPredicate pred) {
833 ExtValue left = genval(ex.left());
834 return createCharCompare(pred, left, genval(ex.right()));
835 }
836
837 /// Returns a reference to a symbol or its box/boxChar descriptor if it has
838 /// one.
839 ExtValue gen(Fortran::semantics::SymbolRef sym) {
840 fir::ExtendedValue exv = converter.getSymbolExtendedValue(sym, &symMap);
841 if (const auto *box = exv.getBoxOf<fir::MutableBoxValue>())
842 return fir::factory::genMutableBoxRead(builder, getLoc(), *box);
843 return exv;
844 }
845
846 ExtValue genLoad(const ExtValue &exv) {
847 return ::genLoad(builder, getLoc(), exv);
848 }
849
850 ExtValue genval(Fortran::semantics::SymbolRef sym) {
851 mlir::Location loc = getLoc();
852 ExtValue var = gen(sym);
853 if (const fir::UnboxedValue *s = var.getUnboxed())
854 if (fir::isa_ref_type(s->getType())) {
855 // A function with multiple entry points returning different types
856 // tags all result variables with one of the largest types to allow
857 // them to share the same storage. A reference to a result variable
858 // of one of the other types requires conversion to the actual type.
859 fir::UnboxedValue addr = *s;
860 if (Fortran::semantics::IsFunctionResult(sym)) {
861 mlir::Type resultType = converter.genType(*sym);
862 if (addr.getType() != resultType)
863 addr = builder.createConvert(loc, builder.getRefType(resultType),
864 addr);
865 }
866 return genLoad(addr);
867 }
868 return var;
869 }
870
871 ExtValue genval(const Fortran::evaluate::BOZLiteralConstant &) {
872 TODO(getLoc(), "BOZ")do { fir::emitFatalError(getLoc(), llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "872" ": not yet implemented: ") + llvm::Twine("BOZ"), false
); } while (false)
;
873 }
874
875 /// Return indirection to function designated in ProcedureDesignator.
876 /// The type of the function indirection is not guaranteed to match the one
877 /// of the ProcedureDesignator due to Fortran implicit typing rules.
878 ExtValue genval(const Fortran::evaluate::ProcedureDesignator &proc) {
879 return Fortran::lower::convertProcedureDesignator(getLoc(), converter, proc,
880 symMap, stmtCtx);
881 }
882 ExtValue genval(const Fortran::evaluate::NullPointer &) {
883 return builder.createNullConstant(getLoc());
884 }
885
886 static bool
887 isDerivedTypeWithLenParameters(const Fortran::semantics::Symbol &sym) {
888 if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType())
889 if (const Fortran::semantics::DerivedTypeSpec *derived =
890 declTy->AsDerived())
891 return Fortran::semantics::CountLenParameters(*derived) > 0;
892 return false;
893 }
894
895 /// A structure constructor is lowered two ways. In an initializer context,
896 /// the entire structure must be constant, so the aggregate value is
897 /// constructed inline. This allows it to be the body of a GlobalOp.
898 /// Otherwise, the structure constructor is in an expression. In that case, a
899 /// temporary object is constructed in the stack frame of the procedure.
900 ExtValue genval(const Fortran::evaluate::StructureConstructor &ctor) {
901 mlir::Location loc = getLoc();
902 if (inInitializer)
903 return Fortran::lower::genInlinedStructureCtorLit(converter, loc, ctor);
904 mlir::Type ty = translateSomeExprToFIRType(converter, toEvExpr(ctor));
905 auto recTy = ty.cast<fir::RecordType>();
906 auto fieldTy = fir::FieldType::get(ty.getContext());
907 mlir::Value res = builder.createTemporary(loc, recTy);
908 mlir::Value box = builder.createBox(loc, fir::ExtendedValue{res});
909 fir::runtime::genDerivedTypeInitialize(builder, loc, box);
910
911 for (const auto &value : ctor.values()) {
912 const Fortran::semantics::Symbol &sym = *value.first;
913 const Fortran::lower::SomeExpr &expr = value.second.value();
914 if (sym.test(Fortran::semantics::Symbol::Flag::ParentComp)) {
915 ExtValue from = gen(expr);
916 mlir::Type fromTy = fir::unwrapPassByRefType(
917 fir::unwrapRefType(fir::getBase(from).getType()));
918 mlir::Value resCast =
919 builder.createConvert(loc, builder.getRefType(fromTy), res);
920 fir::factory::genRecordAssignment(builder, loc, resCast, from);
921 continue;
922 }
923
924 if (isDerivedTypeWithLenParameters(sym))
925 TODO(loc, "component with length parameters in structure constructor")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "925" ": not yet implemented: ") + llvm::Twine("component with length parameters in structure constructor"
), false); } while (false)
;
926
927 llvm::StringRef name = toStringRef(sym.name());
928 // FIXME: type parameters must come from the derived-type-spec
929 mlir::Value field = builder.create<fir::FieldIndexOp>(
930 loc, fieldTy, name, ty,
931 /*typeParams=*/mlir::ValueRange{} /*TODO*/);
932 mlir::Type coorTy = builder.getRefType(recTy.getType(name));
933 auto coor = builder.create<fir::CoordinateOp>(loc, coorTy,
934 fir::getBase(res), field);
935 ExtValue to = fir::factory::componentToExtendedValue(builder, loc, coor);
936 to.match(
937 [&](const fir::UnboxedValue &toPtr) {
938 ExtValue value = genval(expr);
939 fir::factory::genScalarAssignment(builder, loc, to, value);
940 },
941 [&](const fir::CharBoxValue &) {
942 ExtValue value = genval(expr);
943 fir::factory::genScalarAssignment(builder, loc, to, value);
944 },
945 [&](const fir::ArrayBoxValue &) {
946 Fortran::lower::createSomeArrayAssignment(converter, to, expr,
947 symMap, stmtCtx);
948 },
949 [&](const fir::CharArrayBoxValue &) {
950 Fortran::lower::createSomeArrayAssignment(converter, to, expr,
951 symMap, stmtCtx);
952 },
953 [&](const fir::BoxValue &toBox) {
954 fir::emitFatalError(loc, "derived type components must not be "
955 "represented by fir::BoxValue");
956 },
957 [&](const fir::PolymorphicValue &) {
958 TODO(loc, "polymorphic component in derived type assignment")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "958" ": not yet implemented: ") + llvm::Twine("polymorphic component in derived type assignment"
), false); } while (false)
;
959 },
960 [&](const fir::MutableBoxValue &toBox) {
961 if (toBox.isPointer()) {
962 Fortran::lower::associateMutableBox(converter, loc, toBox, expr,
963 /*lbounds=*/std::nullopt,
964 stmtCtx);
965 return;
966 }
967 // For allocatable components, a deep copy is needed.
968 TODO(loc, "allocatable components in derived type assignment")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "968" ": not yet implemented: ") + llvm::Twine("allocatable components in derived type assignment"
), false); } while (false)
;
969 },
970 [&](const fir::ProcBoxValue &toBox) {
971 TODO(loc, "procedure pointer component in derived type assignment")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "971" ": not yet implemented: ") + llvm::Twine("procedure pointer component in derived type assignment"
), false); } while (false)
;
972 });
973 }
974 return res;
975 }
976
977 /// Lowering of an <i>ac-do-variable</i>, which is not a Symbol.
978 ExtValue genval(const Fortran::evaluate::ImpliedDoIndex &var) {
979 mlir::Value value = converter.impliedDoBinding(toStringRef(var.name));
980 // The index value generated by the implied-do has Index type,
981 // while computations based on it inside the loop body are using
982 // the original data type. So we need to cast it appropriately.
983 mlir::Type varTy = converter.genType(toEvExpr(var));
984 return builder.createConvert(getLoc(), varTy, value);
985 }
986
987 ExtValue genval(const Fortran::evaluate::DescriptorInquiry &desc) {
988 ExtValue exv = desc.base().IsSymbol() ? gen(getLastSym(desc.base()))
989 : gen(desc.base().GetComponent());
990 mlir::IndexType idxTy = builder.getIndexType();
991 mlir::Location loc = getLoc();
992 auto castResult = [&](mlir::Value v) {
993 using ResTy = Fortran::evaluate::DescriptorInquiry::Result;
994 return builder.createConvert(
995 loc, converter.genType(ResTy::category, ResTy::kind), v);
996 };
997 switch (desc.field()) {
998 case Fortran::evaluate::DescriptorInquiry::Field::Len:
999 return castResult(fir::factory::readCharLen(builder, loc, exv));
1000 case Fortran::evaluate::DescriptorInquiry::Field::LowerBound:
1001 return castResult(fir::factory::readLowerBound(
1002 builder, loc, exv, desc.dimension(),
1003 builder.createIntegerConstant(loc, idxTy, 1)));
1004 case Fortran::evaluate::DescriptorInquiry::Field::Extent:
1005 return castResult(
1006 fir::factory::readExtent(builder, loc, exv, desc.dimension()));
1007 case Fortran::evaluate::DescriptorInquiry::Field::Rank:
1008 TODO(loc, "rank inquiry on assumed rank")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "1008" ": not yet implemented: ") + llvm::Twine("rank inquiry on assumed rank"
), false); } while (false)
;
1009 case Fortran::evaluate::DescriptorInquiry::Field::Stride:
1010 // So far the front end does not generate this inquiry.
1011 TODO(loc, "stride inquiry")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "1011" ": not yet implemented: ") + llvm::Twine("stride inquiry"
), false); } while (false)
;
1012 }
1013 llvm_unreachable("unknown descriptor inquiry")::llvm::llvm_unreachable_internal("unknown descriptor inquiry"
, "flang/lib/Lower/ConvertExpr.cpp", 1013)
;
1014 }
1015
1016 ExtValue genval(const Fortran::evaluate::TypeParamInquiry &) {
1017 TODO(getLoc(), "type parameter inquiry")do { fir::emitFatalError(getLoc(), llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "1017" ": not yet implemented: ") + llvm::Twine("type parameter inquiry"
), false); } while (false)
;
1018 }
1019
1020 mlir::Value extractComplexPart(mlir::Value cplx, bool isImagPart) {
1021 return fir::factory::Complex{builder, getLoc()}.extractComplexPart(
1022 cplx, isImagPart);
1023 }
1024
1025 template <int KIND>
1026 ExtValue genval(const Fortran::evaluate::ComplexComponent<KIND> &part) {
1027 return extractComplexPart(genunbox(part.left()), part.isImaginaryPart);
1028 }
1029
1030 template <int KIND>
1031 ExtValue genval(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
1032 Fortran::common::TypeCategory::Integer, KIND>> &op) {
1033 mlir::Value input = genunbox(op.left());
1034 // Like LLVM, integer negation is the binary op "0 - value"
1035 mlir::Value zero = genIntegerConstant<KIND>(builder.getContext(), 0);
1036 return builder.create<mlir::arith::SubIOp>(getLoc(), zero, input);
1037 }
1038 template <int KIND>
1039 ExtValue genval(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
1040 Fortran::common::TypeCategory::Real, KIND>> &op) {
1041 return builder.create<mlir::arith::NegFOp>(getLoc(), genunbox(op.left()));
1042 }
1043 template <int KIND>
1044 ExtValue genval(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
1045 Fortran::common::TypeCategory::Complex, KIND>> &op) {
1046 return builder.create<fir::NegcOp>(getLoc(), genunbox(op.left()));
1047 }
1048
1049 template <typename OpTy>
1050 mlir::Value createBinaryOp(const ExtValue &left, const ExtValue &right) {
1051 assert(fir::isUnboxedValue(left) && fir::isUnboxedValue(right))(static_cast <bool> (fir::isUnboxedValue(left) &&
fir::isUnboxedValue(right)) ? void (0) : __assert_fail ("fir::isUnboxedValue(left) && fir::isUnboxedValue(right)"
, "flang/lib/Lower/ConvertExpr.cpp", 1051, __extension__ __PRETTY_FUNCTION__
))
;
1052 mlir::Value lhs = fir::getBase(left);
1053 mlir::Value rhs = fir::getBase(right);
1054 assert(lhs.getType() == rhs.getType() && "types must be the same")(static_cast <bool> (lhs.getType() == rhs.getType() &&
"types must be the same") ? void (0) : __assert_fail ("lhs.getType() == rhs.getType() && \"types must be the same\""
, "flang/lib/Lower/ConvertExpr.cpp", 1054, __extension__ __PRETTY_FUNCTION__
))
;
1055 return builder.create<OpTy>(getLoc(), lhs, rhs);
1056 }
1057
1058 template <typename OpTy, typename A>
1059 mlir::Value createBinaryOp(const A &ex) {
1060 ExtValue left = genval(ex.left());
1061 return createBinaryOp<OpTy>(left, genval(ex.right()));
1062 }
1063
1064#undef GENBIN
1065#define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp)template <int KIND> CC genarr(const Fortran::evaluate::
GenBinEvOp<Fortran::evaluate::Type< Fortran::common::TypeCategory
::GenBinTyCat, KIND>> &x) { return createBinaryOp<
GenBinFirOp>(x); }
\
1066 template <int KIND> \
1067 ExtValue genval(const Fortran::evaluate::GenBinEvOp<Fortran::evaluate::Type< \
1068 Fortran::common::TypeCategory::GenBinTyCat, KIND>> &x) { \
1069 return createBinaryOp<GenBinFirOp>(x); \
1070 }
1071
1072 GENBIN(Add, Integer, mlir::arith::AddIOp)template <int KIND> CC genarr(const Fortran::evaluate::
Add<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Integer, KIND>> &x) { return createBinaryOp<mlir
::arith::AddIOp>(x); }
1073 GENBIN(Add, Real, mlir::arith::AddFOp)template <int KIND> CC genarr(const Fortran::evaluate::
Add<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Real, KIND>> &x) { return createBinaryOp<mlir::
arith::AddFOp>(x); }
1074 GENBIN(Add, Complex, fir::AddcOp)template <int KIND> CC genarr(const Fortran::evaluate::
Add<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Complex, KIND>> &x) { return createBinaryOp<fir
::AddcOp>(x); }
1075 GENBIN(Subtract, Integer, mlir::arith::SubIOp)template <int KIND> CC genarr(const Fortran::evaluate::
Subtract<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Integer, KIND>> &x) { return createBinaryOp<mlir
::arith::SubIOp>(x); }
1076 GENBIN(Subtract, Real, mlir::arith::SubFOp)template <int KIND> CC genarr(const Fortran::evaluate::
Subtract<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Real, KIND>> &x) { return createBinaryOp<mlir::
arith::SubFOp>(x); }
1077 GENBIN(Subtract, Complex, fir::SubcOp)template <int KIND> CC genarr(const Fortran::evaluate::
Subtract<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Complex, KIND>> &x) { return createBinaryOp<fir
::SubcOp>(x); }
1078 GENBIN(Multiply, Integer, mlir::arith::MulIOp)template <int KIND> CC genarr(const Fortran::evaluate::
Multiply<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Integer, KIND>> &x) { return createBinaryOp<mlir
::arith::MulIOp>(x); }
1079 GENBIN(Multiply, Real, mlir::arith::MulFOp)template <int KIND> CC genarr(const Fortran::evaluate::
Multiply<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Real, KIND>> &x) { return createBinaryOp<mlir::
arith::MulFOp>(x); }
1080 GENBIN(Multiply, Complex, fir::MulcOp)template <int KIND> CC genarr(const Fortran::evaluate::
Multiply<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Complex, KIND>> &x) { return createBinaryOp<fir
::MulcOp>(x); }
1081 GENBIN(Divide, Integer, mlir::arith::DivSIOp)template <int KIND> CC genarr(const Fortran::evaluate::
Divide<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Integer, KIND>> &x) { return createBinaryOp<mlir
::arith::DivSIOp>(x); }
1082 GENBIN(Divide, Real, mlir::arith::DivFOp)template <int KIND> CC genarr(const Fortran::evaluate::
Divide<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Real, KIND>> &x) { return createBinaryOp<mlir::
arith::DivFOp>(x); }
1083 GENBIN(Divide, Complex, fir::DivcOp)template <int KIND> CC genarr(const Fortran::evaluate::
Divide<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Complex, KIND>> &x) { return createBinaryOp<fir
::DivcOp>(x); }
1084
1085 template <Fortran::common::TypeCategory TC, int KIND>
1086 ExtValue genval(
1087 const Fortran::evaluate::Power<Fortran::evaluate::Type<TC, KIND>> &op) {
1088 mlir::Type ty = converter.genType(TC, KIND);
1089 mlir::Value lhs = genunbox(op.left());
1090 mlir::Value rhs = genunbox(op.right());
1091 return fir::genPow(builder, getLoc(), ty, lhs, rhs);
1092 }
1093
1094 template <Fortran::common::TypeCategory TC, int KIND>
1095 ExtValue genval(
1096 const Fortran::evaluate::RealToIntPower<Fortran::evaluate::Type<TC, KIND>>
1097 &op) {
1098 mlir::Type ty = converter.genType(TC, KIND);
1099 mlir::Value lhs = genunbox(op.left());
1100 mlir::Value rhs = genunbox(op.right());
1101 return fir::genPow(builder, getLoc(), ty, lhs, rhs);
1102 }
1103
1104 template <int KIND>
1105 ExtValue genval(const Fortran::evaluate::ComplexConstructor<KIND> &op) {
1106 mlir::Value realPartValue = genunbox(op.left());
1107 return fir::factory::Complex{builder, getLoc()}.createComplex(
1108 KIND, realPartValue, genunbox(op.right()));
1109 }
1110
1111 template <int KIND>
1112 ExtValue genval(const Fortran::evaluate::Concat<KIND> &op) {
1113 ExtValue lhs = genval(op.left());
1114 ExtValue rhs = genval(op.right());
1115 const fir::CharBoxValue *lhsChar = lhs.getCharBox();
1116 const fir::CharBoxValue *rhsChar = rhs.getCharBox();
1117 if (lhsChar && rhsChar)
1118 return fir::factory::CharacterExprHelper{builder, getLoc()}
1119 .createConcatenate(*lhsChar, *rhsChar);
1120 TODO(getLoc(), "character array concatenate")do { fir::emitFatalError(getLoc(), llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "1120" ": not yet implemented: ") + llvm::Twine("character array concatenate"
), false); } while (false)
;
1121 }
1122
1123 /// MIN and MAX operations
1124 template <Fortran::common::TypeCategory TC, int KIND>
1125 ExtValue
1126 genval(const Fortran::evaluate::Extremum<Fortran::evaluate::Type<TC, KIND>>
1127 &op) {
1128 mlir::Value lhs = genunbox(op.left());
1129 mlir::Value rhs = genunbox(op.right());
1130 switch (op.ordering) {
1131 case Fortran::evaluate::Ordering::Greater:
1132 return fir::genMax(builder, getLoc(),
1133 llvm::ArrayRef<mlir::Value>{lhs, rhs});
1134 case Fortran::evaluate::Ordering::Less:
1135 return fir::genMin(builder, getLoc(),
1136 llvm::ArrayRef<mlir::Value>{lhs, rhs});
1137 case Fortran::evaluate::Ordering::Equal:
1138 llvm_unreachable("Equal is not a valid ordering in this context")::llvm::llvm_unreachable_internal("Equal is not a valid ordering in this context"
, "flang/lib/Lower/ConvertExpr.cpp", 1138)
;
1139 }
1140 llvm_unreachable("unknown ordering")::llvm::llvm_unreachable_internal("unknown ordering", "flang/lib/Lower/ConvertExpr.cpp"
, 1140)
;
1141 }
1142
1143 // Change the dynamic length information without actually changing the
1144 // underlying character storage.
1145 fir::ExtendedValue
1146 replaceScalarCharacterLength(const fir::ExtendedValue &scalarChar,
1147 mlir::Value newLenValue) {
1148 mlir::Location loc = getLoc();
1149 const fir::CharBoxValue *charBox = scalarChar.getCharBox();
1150 if (!charBox)
1151 fir::emitFatalError(loc, "expected scalar character");
1152 mlir::Value charAddr = charBox->getAddr();
1153 auto charType =
1154 fir::unwrapPassByRefType(charAddr.getType()).cast<fir::CharacterType>();
1155 if (charType.hasConstantLen()) {
1156 // Erase previous constant length from the base type.
1157 fir::CharacterType::LenType newLen = fir::CharacterType::unknownLen();
1158 mlir::Type newCharTy = fir::CharacterType::get(
1159 builder.getContext(), charType.getFKind(), newLen);
1160 mlir::Type newType = fir::ReferenceType::get(newCharTy);
1161 charAddr = builder.createConvert(loc, newType, charAddr);
1162 return fir::CharBoxValue{charAddr, newLenValue};
1163 }
1164 return fir::CharBoxValue{charAddr, newLenValue};
1165 }
1166
1167 template <int KIND>
1168 ExtValue genval(const Fortran::evaluate::SetLength<KIND> &x) {
1169 mlir::Value newLenValue = genunbox(x.right());
1170 fir::ExtendedValue lhs = gen(x.left());
1171 fir::factory::CharacterExprHelper charHelper(builder, getLoc());
1172 fir::CharBoxValue temp = charHelper.createCharacterTemp(
1173 charHelper.getCharacterType(fir::getBase(lhs).getType()), newLenValue);
1174 charHelper.createAssign(temp, lhs);
1175 return fir::ExtendedValue{temp};
1176 }
1177
1178 template <int KIND>
1179 ExtValue genval(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
1180 Fortran::common::TypeCategory::Integer, KIND>> &op) {
1181 return createCompareOp<mlir::arith::CmpIOp>(op,
1182 translateRelational(op.opr));
1183 }
1184 template <int KIND>
1185 ExtValue genval(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
1186 Fortran::common::TypeCategory::Real, KIND>> &op) {
1187 return createFltCmpOp<mlir::arith::CmpFOp>(
1188 op, translateFloatRelational(op.opr));
1189 }
1190 template <int KIND>
1191 ExtValue genval(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
1192 Fortran::common::TypeCategory::Complex, KIND>> &op) {
1193 return createFltCmpOp<fir::CmpcOp>(op, translateFloatRelational(op.opr));
1194 }
1195 template <int KIND>
1196 ExtValue genval(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
1197 Fortran::common::TypeCategory::Character, KIND>> &op) {
1198 return createCharCompare(op, translateRelational(op.opr));
1199 }
1200
1201 ExtValue
1202 genval(const Fortran::evaluate::Relational<Fortran::evaluate::SomeType> &op) {
1203 return std::visit([&](const auto &x) { return genval(x); }, op.u);
1204 }
1205
1206 template <Fortran::common::TypeCategory TC1, int KIND,
1207 Fortran::common::TypeCategory TC2>
1208 ExtValue
1209 genval(const Fortran::evaluate::Convert<Fortran::evaluate::Type<TC1, KIND>,
1210 TC2> &convert) {
1211 mlir::Type ty = converter.genType(TC1, KIND);
1212 auto fromExpr = genval(convert.left());
1213 auto loc = getLoc();
1214 return fromExpr.match(
1215 [&](const fir::CharBoxValue &boxchar) -> ExtValue {
1216 if constexpr (TC1 == Fortran::common::TypeCategory::Character &&
1217 TC2 == TC1) {
1218 // Use char_convert. Each code point is translated from a
1219 // narrower/wider encoding to the target encoding. For example, 'A'
1220 // may be translated from 0x41 : i8 to 0x0041 : i16. The symbol
1221 // for euro (0x20AC : i16) may be translated from a wide character
1222 // to "0xE2 0x82 0xAC" : UTF-8.
1223 mlir::Value bufferSize = boxchar.getLen();
1224 auto kindMap = builder.getKindMap();
1225 mlir::Value boxCharAddr = boxchar.getAddr();
1226 auto fromTy = boxCharAddr.getType();
1227 if (auto charTy = fromTy.dyn_cast<fir::CharacterType>()) {
1228 // boxchar is a value, not a variable. Turn it into a temporary.
1229 // As a value, it ought to have a constant LEN value.
1230 assert(charTy.hasConstantLen() && "must have constant length")(static_cast <bool> (charTy.hasConstantLen() &&
"must have constant length") ? void (0) : __assert_fail ("charTy.hasConstantLen() && \"must have constant length\""
, "flang/lib/Lower/ConvertExpr.cpp", 1230, __extension__ __PRETTY_FUNCTION__
))
;
1231 mlir::Value tmp = builder.createTemporary(loc, charTy);
1232 builder.create<fir::StoreOp>(loc, boxCharAddr, tmp);
1233 boxCharAddr = tmp;
1234 }
1235 auto fromBits =
1236 kindMap.getCharacterBitsize(fir::unwrapRefType(fromTy)
1237 .cast<fir::CharacterType>()
1238 .getFKind());
1239 auto toBits = kindMap.getCharacterBitsize(
1240 ty.cast<fir::CharacterType>().getFKind());
1241 if (toBits < fromBits) {
1242 // Scale by relative ratio to give a buffer of the same length.
1243 auto ratio = builder.createIntegerConstant(
1244 loc, bufferSize.getType(), fromBits / toBits);
1245 bufferSize =
1246 builder.create<mlir::arith::MulIOp>(loc, bufferSize, ratio);
1247 }
1248 auto dest = builder.create<fir::AllocaOp>(
1249 loc, ty, mlir::ValueRange{bufferSize});
1250 builder.create<fir::CharConvertOp>(loc, boxCharAddr,
1251 boxchar.getLen(), dest);
1252 return fir::CharBoxValue{dest, boxchar.getLen()};
1253 } else {
1254 fir::emitFatalError(
1255 loc, "unsupported evaluate::Convert between CHARACTER type "
1256 "category and non-CHARACTER category");
1257 }
1258 },
1259 [&](const fir::UnboxedValue &value) -> ExtValue {
1260 return builder.convertWithSemantics(loc, ty, value);
1261 },
1262 [&](auto &) -> ExtValue {
1263 fir::emitFatalError(loc, "unsupported evaluate::Convert");
1264 });
1265 }
1266
1267 template <typename A>
1268 ExtValue genval(const Fortran::evaluate::Parentheses<A> &op) {
1269 ExtValue input = genval(op.left());
1270 mlir::Value base = fir::getBase(input);
1271 mlir::Value newBase =
1272 builder.create<fir::NoReassocOp>(getLoc(), base.getType(), base);
1273 return fir::substBase(input, newBase);
1274 }
1275
1276 template <int KIND>
1277 ExtValue genval(const Fortran::evaluate::Not<KIND> &op) {
1278 mlir::Value logical = genunbox(op.left());
1279 mlir::Value one = genBoolConstant(true);
1280 mlir::Value val =
1281 builder.createConvert(getLoc(), builder.getI1Type(), logical);
1282 return builder.create<mlir::arith::XOrIOp>(getLoc(), val, one);
1283 }
1284
1285 template <int KIND>
1286 ExtValue genval(const Fortran::evaluate::LogicalOperation<KIND> &op) {
1287 mlir::IntegerType i1Type = builder.getI1Type();
1288 mlir::Value slhs = genunbox(op.left());
1289 mlir::Value srhs = genunbox(op.right());
1290 mlir::Value lhs = builder.createConvert(getLoc(), i1Type, slhs);
1291 mlir::Value rhs = builder.createConvert(getLoc(), i1Type, srhs);
1292 switch (op.logicalOperator) {
1293 case Fortran::evaluate::LogicalOperator::And:
1294 return createBinaryOp<mlir::arith::AndIOp>(lhs, rhs);
1295 case Fortran::evaluate::LogicalOperator::Or:
1296 return createBinaryOp<mlir::arith::OrIOp>(lhs, rhs);
1297 case Fortran::evaluate::LogicalOperator::Eqv:
1298 return createCompareOp<mlir::arith::CmpIOp>(
1299 mlir::arith::CmpIPredicate::eq, lhs, rhs);
1300 case Fortran::evaluate::LogicalOperator::Neqv:
1301 return createCompareOp<mlir::arith::CmpIOp>(
1302 mlir::arith::CmpIPredicate::ne, lhs, rhs);
1303 case Fortran::evaluate::LogicalOperator::Not:
1304 // lib/evaluate expression for .NOT. is Fortran::evaluate::Not<KIND>.
1305 llvm_unreachable(".NOT. is not a binary operator")::llvm::llvm_unreachable_internal(".NOT. is not a binary operator"
, "flang/lib/Lower/ConvertExpr.cpp", 1305)
;
1306 }
1307 llvm_unreachable("unhandled logical operation")::llvm::llvm_unreachable_internal("unhandled logical operation"
, "flang/lib/Lower/ConvertExpr.cpp", 1307)
;
1308 }
1309
1310 template <Fortran::common::TypeCategory TC, int KIND>
1311 ExtValue
1312 genval(const Fortran::evaluate::Constant<Fortran::evaluate::Type<TC, KIND>>
1313 &con) {
1314 return Fortran::lower::convertConstant(
1315 converter, getLoc(), con,
1316 /*outlineBigConstantsInReadOnlyMemory=*/!inInitializer);
1317 }
1318
1319 fir::ExtendedValue genval(
1320 const Fortran::evaluate::Constant<Fortran::evaluate::SomeDerived> &con) {
1321 if (auto ctor = con.GetScalarValue())
1322 return genval(*ctor);
1323 return Fortran::lower::convertConstant(
1324 converter, getLoc(), con,
1325 /*outlineBigConstantsInReadOnlyMemory=*/false);
1326 }
1327
1328 template <typename A>
1329 ExtValue genval(const Fortran::evaluate::ArrayConstructor<A> &) {
1330 fir::emitFatalError(getLoc(), "array constructor: should not reach here");
1331 }
1332
1333 ExtValue gen(const Fortran::evaluate::ComplexPart &x) {
1334 mlir::Location loc = getLoc();
1335 auto idxTy = builder.getI32Type();
1336 ExtValue exv = gen(x.complex());
1337 mlir::Value base = fir::getBase(exv);
1338 fir::factory::Complex helper{builder, loc};
1339 mlir::Type eleTy =
1340 helper.getComplexPartType(fir::dyn_cast_ptrEleTy(base.getType()));
1341 mlir::Value offset = builder.createIntegerConstant(
1342 loc, idxTy,
1343 x.part() == Fortran::evaluate::ComplexPart::Part::RE ? 0 : 1);
1344 mlir::Value result = builder.create<fir::CoordinateOp>(
1345 loc, builder.getRefType(eleTy), base, mlir::ValueRange{offset});
1346 return {result};
1347 }
1348 ExtValue genval(const Fortran::evaluate::ComplexPart &x) {
1349 return genLoad(gen(x));
1350 }
1351
1352 /// Reference to a substring.
1353 ExtValue gen(const Fortran::evaluate::Substring &s) {
1354 // Get base string
1355 auto baseString = std::visit(
1356 Fortran::common::visitors{
1357 [&](const Fortran::evaluate::DataRef &x) { return gen(x); },
1358 [&](const Fortran::evaluate::StaticDataObject::Pointer &p)
1359 -> ExtValue {
1360 if (std::optional<std::string> str = p->AsString())
1361 return fir::factory::createStringLiteral(builder, getLoc(),
1362 *str);
1363 // TODO: convert StaticDataObject to Constant<T> and use normal
1364 // constant path. Beware that StaticDataObject data() takes into
1365 // account build machine endianness.
1366 TODO(getLoc(),do { fir::emitFatalError(getLoc(), llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "1367" ": not yet implemented: ") + llvm::Twine("StaticDataObject::Pointer substring with kind > 1"
), false); } while (false)
1367 "StaticDataObject::Pointer substring with kind > 1")do { fir::emitFatalError(getLoc(), llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "1367" ": not yet implemented: ") + llvm::Twine("StaticDataObject::Pointer substring with kind > 1"
), false); } while (false)
;
1368 },
1369 },
1370 s.parent());
1371 llvm::SmallVector<mlir::Value> bounds;
1372 mlir::Value lower = genunbox(s.lower());
1373 bounds.push_back(lower);
1374 if (Fortran::evaluate::MaybeExtentExpr upperBound = s.upper()) {
1375 mlir::Value upper = genunbox(*upperBound);
1376 bounds.push_back(upper);
1377 }
1378 fir::factory::CharacterExprHelper charHelper{builder, getLoc()};
1379 return baseString.match(
1380 [&](const fir::CharBoxValue &x) -> ExtValue {
1381 return charHelper.createSubstring(x, bounds);
1382 },
1383 [&](const fir::CharArrayBoxValue &) -> ExtValue {
1384 fir::emitFatalError(
1385 getLoc(),
1386 "array substring should be handled in array expression");
1387 },
1388 [&](const auto &) -> ExtValue {
1389 fir::emitFatalError(getLoc(), "substring base is not a CharBox");
1390 });
1391 }
1392
1393 /// The value of a substring.
1394 ExtValue genval(const Fortran::evaluate::Substring &ss) {
1395 // FIXME: why is the value of a substring being lowered the same as the
1396 // address of a substring?
1397 return gen(ss);
1398 }
1399
1400 ExtValue genval(const Fortran::evaluate::Subscript &subs) {
1401 if (auto *s = std::get_if<Fortran::evaluate::IndirectSubscriptIntegerExpr>(
1402 &subs.u)) {
1403 if (s->value().Rank() > 0)
1404 fir::emitFatalError(getLoc(), "vector subscript is not scalar");
1405 return {genval(s->value())};
1406 }
1407 fir::emitFatalError(getLoc(), "subscript triple notation is not scalar");
1408 }
1409 ExtValue genSubscript(const Fortran::evaluate::Subscript &subs) {
1410 return genval(subs);
1411 }
1412
1413 ExtValue gen(const Fortran::evaluate::DataRef &dref) {
1414 return std::visit([&](const auto &x) { return gen(x); }, dref.u);
1415 }
1416 ExtValue genval(const Fortran::evaluate::DataRef &dref) {
1417 return std::visit([&](const auto &x) { return genval(x); }, dref.u);
1418 }
1419
1420 // Helper function to turn the Component structure into a list of nested
1421 // components, ordered from largest/leftmost to smallest/rightmost:
1422 // - where only the smallest/rightmost item may be allocatable or a pointer
1423 // (nested allocatable/pointer components require nested coordinate_of ops)
1424 // - that does not contain any parent components
1425 // (the front end places parent components directly in the object)
1426 // Return the object used as the base coordinate for the component chain.
1427 static Fortran::evaluate::DataRef const *
1428 reverseComponents(const Fortran::evaluate::Component &cmpt,
1429 std::list<const Fortran::evaluate::Component *> &list) {
1430 if (!getLastSym(cmpt).test(Fortran::semantics::Symbol::Flag::ParentComp))
1431 list.push_front(&cmpt);
1432 return std::visit(
1433 Fortran::common::visitors{
1434 [&](const Fortran::evaluate::Component &x) {
1435 if (Fortran::semantics::IsAllocatableOrPointer(getLastSym(x)))
1436 return &cmpt.base();
1437 return reverseComponents(x, list);
1438 },
1439 [&](auto &) { return &cmpt.base(); },
1440 },
1441 cmpt.base().u);
1442 }
1443
1444 // Return the coordinate of the component reference
1445 ExtValue genComponent(const Fortran::evaluate::Component &cmpt) {
1446 std::list<const Fortran::evaluate::Component *> list;
1447 const Fortran::evaluate::DataRef *base = reverseComponents(cmpt, list);
1448 llvm::SmallVector<mlir::Value> coorArgs;
1449 ExtValue obj = gen(*base);
1450 mlir::Type ty = fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(obj).getType());
1451 mlir::Location loc = getLoc();
1452 auto fldTy = fir::FieldType::get(&converter.getMLIRContext());
1453 // FIXME: need to thread the LEN type parameters here.
1454 for (const Fortran::evaluate::Component *field : list) {
1455 auto recTy = ty.cast<fir::RecordType>();
1456 const Fortran::semantics::Symbol &sym = getLastSym(*field);
1457 llvm::StringRef name = toStringRef(sym.name());
1458 coorArgs.push_back(builder.create<fir::FieldIndexOp>(
1459 loc, fldTy, name, recTy, fir::getTypeParams(obj)));
1460 ty = recTy.getType(name);
1461 }
1462 // If parent component is referred then it has no coordinate argument.
1463 if (coorArgs.size() == 0)
1464 return obj;
1465 ty = builder.getRefType(ty);
1466 return fir::factory::componentToExtendedValue(
1467 builder, loc,
1468 builder.create<fir::CoordinateOp>(loc, ty, fir::getBase(obj),
1469 coorArgs));
1470 }
1471
1472 ExtValue gen(const Fortran::evaluate::Component &cmpt) {
1473 // Components may be pointer or allocatable. In the gen() path, the mutable
1474 // aspect is lost to simplify handling on the client side. To retain the
1475 // mutable aspect, genMutableBoxValue should be used.
1476 return genComponent(cmpt).match(
1477 [&](const fir::MutableBoxValue &mutableBox) {
1478 return fir::factory::genMutableBoxRead(builder, getLoc(), mutableBox);
1479 },
1480 [](auto &box) -> ExtValue { return box; });
1481 }
1482
1483 ExtValue genval(const Fortran::evaluate::Component &cmpt) {
1484 return genLoad(gen(cmpt));
1485 }
1486
1487 // Determine the result type after removing `dims` dimensions from the array
1488 // type `arrTy`
1489 mlir::Type genSubType(mlir::Type arrTy, unsigned dims) {
1490 mlir::Type unwrapTy = fir::dyn_cast_ptrOrBoxEleTy(arrTy);
1491 assert(unwrapTy && "must be a pointer or box type")(static_cast <bool> (unwrapTy && "must be a pointer or box type"
) ? void (0) : __assert_fail ("unwrapTy && \"must be a pointer or box type\""
, "flang/lib/Lower/ConvertExpr.cpp", 1491, __extension__ __PRETTY_FUNCTION__
))
;
1492 auto seqTy = unwrapTy.cast<fir::SequenceType>();
1493 llvm::ArrayRef<int64_t> shape = seqTy.getShape();
1494 assert(shape.size() > 0 && "removing columns for sequence sans shape")(static_cast <bool> (shape.size() > 0 && "removing columns for sequence sans shape"
) ? void (0) : __assert_fail ("shape.size() > 0 && \"removing columns for sequence sans shape\""
, "flang/lib/Lower/ConvertExpr.cpp", 1494, __extension__ __PRETTY_FUNCTION__
))
;
1495 assert(dims <= shape.size() && "removing more columns than exist")(static_cast <bool> (dims <= shape.size() &&
"removing more columns than exist") ? void (0) : __assert_fail
("dims <= shape.size() && \"removing more columns than exist\""
, "flang/lib/Lower/ConvertExpr.cpp", 1495, __extension__ __PRETTY_FUNCTION__
))
;
1496 fir::SequenceType::Shape newBnds;
1497 // follow Fortran semantics and remove columns (from right)
1498 std::size_t e = shape.size() - dims;
1499 for (decltype(e) i = 0; i < e; ++i)
1500 newBnds.push_back(shape[i]);
1501 if (!newBnds.empty())
1502 return fir::SequenceType::get(newBnds, seqTy.getEleTy());
1503 return seqTy.getEleTy();
1504 }
1505
1506 // Generate the code for a Bound value.
1507 ExtValue genval(const Fortran::semantics::Bound &bound) {
1508 if (bound.isExplicit()) {
1509 Fortran::semantics::MaybeSubscriptIntExpr sub = bound.GetExplicit();
1510 if (sub.has_value())
1511 return genval(*sub);
1512 return genIntegerConstant<8>(builder.getContext(), 1);
1513 }
1514 TODO(getLoc(), "non explicit semantics::Bound implementation")do { fir::emitFatalError(getLoc(), llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "1514" ": not yet implemented: ") + llvm::Twine("non explicit semantics::Bound implementation"
), false); } while (false)
;
1515 }
1516
1517 static bool isSlice(const Fortran::evaluate::ArrayRef &aref) {
1518 for (const Fortran::evaluate::Subscript &sub : aref.subscript())
1519 if (std::holds_alternative<Fortran::evaluate::Triplet>(sub.u))
1520 return true;
1521 return false;
1522 }
1523
1524 /// Lower an ArrayRef to a fir.coordinate_of given its lowered base.
1525 ExtValue genCoordinateOp(const ExtValue &array,
1526 const Fortran::evaluate::ArrayRef &aref) {
1527 mlir::Location loc = getLoc();
1528 // References to array of rank > 1 with non constant shape that are not
1529 // fir.box must be collapsed into an offset computation in lowering already.
1530 // The same is needed with dynamic length character arrays of all ranks.
1531 mlir::Type baseType =
1532 fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(array).getType());
1533 if ((array.rank() > 1 && fir::hasDynamicSize(baseType)) ||
1534 fir::characterWithDynamicLen(fir::unwrapSequenceType(baseType)))
1535 if (!array.getBoxOf<fir::BoxValue>())
1536 return genOffsetAndCoordinateOp(array, aref);
1537 // Generate a fir.coordinate_of with zero based array indexes.
1538 llvm::SmallVector<mlir::Value> args;
1539 for (const auto &subsc : llvm::enumerate(aref.subscript())) {
1540 ExtValue subVal = genSubscript(subsc.value());
1541 assert(fir::isUnboxedValue(subVal) && "subscript must be simple scalar")(static_cast <bool> (fir::isUnboxedValue(subVal) &&
"subscript must be simple scalar") ? void (0) : __assert_fail
("fir::isUnboxedValue(subVal) && \"subscript must be simple scalar\""
, "flang/lib/Lower/ConvertExpr.cpp", 1541, __extension__ __PRETTY_FUNCTION__
))
;
1542 mlir::Value val = fir::getBase(subVal);
1543 mlir::Type ty = val.getType();
1544 mlir::Value lb = getLBound(array, subsc.index(), ty);
1545 args.push_back(builder.create<mlir::arith::SubIOp>(loc, ty, val, lb));
1546 }
1547 mlir::Value base = fir::getBase(array);
1548 mlir::Type eleTy = fir::dyn_cast_ptrOrBoxEleTy(base.getType());
1549 if (auto classTy = eleTy.dyn_cast<fir::ClassType>())
1550 eleTy = classTy.getEleTy();
1551 auto seqTy = eleTy.cast<fir::SequenceType>();
1552 assert(args.size() == seqTy.getDimension())(static_cast <bool> (args.size() == seqTy.getDimension(
)) ? void (0) : __assert_fail ("args.size() == seqTy.getDimension()"
, "flang/lib/Lower/ConvertExpr.cpp", 1552, __extension__ __PRETTY_FUNCTION__
))
;
1553 mlir::Type ty = builder.getRefType(seqTy.getEleTy());
1554 auto addr = builder.create<fir::CoordinateOp>(loc, ty, base, args);
1555 return fir::factory::arrayElementToExtendedValue(builder, loc, array, addr);
1556 }
1557
1558 /// Lower an ArrayRef to a fir.coordinate_of using an element offset instead
1559 /// of array indexes.
1560 /// This generates offset computation from the indexes and length parameters,
1561 /// and use the offset to access the element with a fir.coordinate_of. This
1562 /// must only be used if it is not possible to generate a normal
1563 /// fir.coordinate_of using array indexes (i.e. when the shape information is
1564 /// unavailable in the IR).
1565 ExtValue genOffsetAndCoordinateOp(const ExtValue &array,
1566 const Fortran::evaluate::ArrayRef &aref) {
1567 mlir::Location loc = getLoc();
1568 mlir::Value addr = fir::getBase(array);
1569 mlir::Type arrTy = fir::dyn_cast_ptrEleTy(addr.getType());
1570 auto eleTy = arrTy.cast<fir::SequenceType>().getEleTy();
1571 mlir::Type seqTy = builder.getRefType(builder.getVarLenSeqTy(eleTy));
1572 mlir::Type refTy = builder.getRefType(eleTy);
1573 mlir::Value base = builder.createConvert(loc, seqTy, addr);
1574 mlir::IndexType idxTy = builder.getIndexType();
1575 mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
1576 mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0);
1577 auto getLB = [&](const auto &arr, unsigned dim) -> mlir::Value {
1578 return arr.getLBounds().empty() ? one : arr.getLBounds()[dim];
1579 };
1580 auto genFullDim = [&](const auto &arr, mlir::Value delta) -> mlir::Value {
1581 mlir::Value total = zero;
1582 assert(arr.getExtents().size() == aref.subscript().size())(static_cast <bool> (arr.getExtents().size() == aref.subscript
().size()) ? void (0) : __assert_fail ("arr.getExtents().size() == aref.subscript().size()"
, "flang/lib/Lower/ConvertExpr.cpp", 1582, __extension__ __PRETTY_FUNCTION__
))
;
1583 delta = builder.createConvert(loc, idxTy, delta);
1584 unsigned dim = 0;
1585 for (auto [ext, sub] : llvm::zip(arr.getExtents(), aref.subscript())) {
1586 ExtValue subVal = genSubscript(sub);
1587 assert(fir::isUnboxedValue(subVal))(static_cast <bool> (fir::isUnboxedValue(subVal)) ? void
(0) : __assert_fail ("fir::isUnboxedValue(subVal)", "flang/lib/Lower/ConvertExpr.cpp"
, 1587, __extension__ __PRETTY_FUNCTION__))
;
1588 mlir::Value val =
1589 builder.createConvert(loc, idxTy, fir::getBase(subVal));
1590 mlir::Value lb = builder.createConvert(loc, idxTy, getLB(arr, dim));
1591 mlir::Value diff = builder.create<mlir::arith::SubIOp>(loc, val, lb);
1592 mlir::Value prod =
1593 builder.create<mlir::arith::MulIOp>(loc, delta, diff);
1594 total = builder.create<mlir::arith::AddIOp>(loc, prod, total);
1595 if (ext)
1596 delta = builder.create<mlir::arith::MulIOp>(loc, delta, ext);
1597 ++dim;
1598 }
1599 mlir::Type origRefTy = refTy;
1600 if (fir::factory::CharacterExprHelper::isCharacterScalar(refTy)) {
1601 fir::CharacterType chTy =
1602 fir::factory::CharacterExprHelper::getCharacterType(refTy);
1603 if (fir::characterWithDynamicLen(chTy)) {
1604 mlir::MLIRContext *ctx = builder.getContext();
1605 fir::KindTy kind =
1606 fir::factory::CharacterExprHelper::getCharacterKind(chTy);
1607 fir::CharacterType singleTy =
1608 fir::CharacterType::getSingleton(ctx, kind);
1609 refTy = builder.getRefType(singleTy);
1610 mlir::Type seqRefTy =
1611 builder.getRefType(builder.getVarLenSeqTy(singleTy));
1612 base = builder.createConvert(loc, seqRefTy, base);
1613 }
1614 }
1615 auto coor = builder.create<fir::CoordinateOp>(
1616 loc, refTy, base, llvm::ArrayRef<mlir::Value>{total});
1617 // Convert to expected, original type after address arithmetic.
1618 return builder.createConvert(loc, origRefTy, coor);
1619 };
1620 return array.match(
1621 [&](const fir::ArrayBoxValue &arr) -> ExtValue {
1622 // FIXME: this check can be removed when slicing is implemented
1623 if (isSlice(aref))
1624 fir::emitFatalError(
1625 getLoc(),
1626 "slice should be handled in array expression context");
1627 return genFullDim(arr, one);
1628 },
1629 [&](const fir::CharArrayBoxValue &arr) -> ExtValue {
1630 mlir::Value delta = arr.getLen();
1631 // If the length is known in the type, fir.coordinate_of will
1632 // already take the length into account.
1633 if (fir::factory::CharacterExprHelper::hasConstantLengthInType(arr))
1634 delta = one;
1635 return fir::CharBoxValue(genFullDim(arr, delta), arr.getLen());
1636 },
1637 [&](const fir::BoxValue &arr) -> ExtValue {
1638 // CoordinateOp for BoxValue is not generated here. The dimensions
1639 // must be kept in the fir.coordinate_op so that potential fir.box
1640 // strides can be applied by codegen.
1641 fir::emitFatalError(
1642 loc, "internal: BoxValue in dim-collapsed fir.coordinate_of");
1643 },
1644 [&](const auto &) -> ExtValue {
1645 fir::emitFatalError(loc, "internal: array processing failed");
1646 });
1647 }
1648
1649 /// Lower an ArrayRef to a fir.array_coor.
1650 ExtValue genArrayCoorOp(const ExtValue &exv,
1651 const Fortran::evaluate::ArrayRef &aref) {
1652 mlir::Location loc = getLoc();
1653 mlir::Value addr = fir::getBase(exv);
1654 mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(addr.getType());
1655 mlir::Type eleTy = arrTy.cast<fir::SequenceType>().getEleTy();
1656 mlir::Type refTy = builder.getRefType(eleTy);
1657 mlir::IndexType idxTy = builder.getIndexType();
1658 llvm::SmallVector<mlir::Value> arrayCoorArgs;
1659 // The ArrayRef is expected to be scalar here, arrays are handled in array
1660 // expression lowering. So no vector subscript or triplet is expected here.
1661 for (const auto &sub : aref.subscript()) {
1662 ExtValue subVal = genSubscript(sub);
1663 assert(fir::isUnboxedValue(subVal))(static_cast <bool> (fir::isUnboxedValue(subVal)) ? void
(0) : __assert_fail ("fir::isUnboxedValue(subVal)", "flang/lib/Lower/ConvertExpr.cpp"
, 1663, __extension__ __PRETTY_FUNCTION__))
;
1664 arrayCoorArgs.push_back(
1665 builder.createConvert(loc, idxTy, fir::getBase(subVal)));
1666 }
1667 mlir::Value shape = builder.createShape(loc, exv);
1668 mlir::Value elementAddr = builder.create<fir::ArrayCoorOp>(
1669 loc, refTy, addr, shape, /*slice=*/mlir::Value{}, arrayCoorArgs,
1670 fir::getTypeParams(exv));
1671 return fir::factory::arrayElementToExtendedValue(builder, loc, exv,
1672 elementAddr);
1673 }
1674
1675 /// Return the coordinate of the array reference.
1676 ExtValue gen(const Fortran::evaluate::ArrayRef &aref) {
1677 ExtValue base = aref.base().IsSymbol() ? gen(getFirstSym(aref.base()))
1678 : gen(aref.base().GetComponent());
1679 // Check for command-line override to use array_coor op.
1680 if (generateArrayCoordinate)
1681 return genArrayCoorOp(base, aref);
1682 // Otherwise, use coordinate_of op.
1683 return genCoordinateOp(base, aref);
1684 }
1685
1686 /// Return lower bounds of \p box in dimension \p dim. The returned value
1687 /// has type \ty.
1688 mlir::Value getLBound(const ExtValue &box, unsigned dim, mlir::Type ty) {
1689 assert(box.rank() > 0 && "must be an array")(static_cast <bool> (box.rank() > 0 && "must be an array"
) ? void (0) : __assert_fail ("box.rank() > 0 && \"must be an array\""
, "flang/lib/Lower/ConvertExpr.cpp", 1689, __extension__ __PRETTY_FUNCTION__
))
;
1690 mlir::Location loc = getLoc();
1691 mlir::Value one = builder.createIntegerConstant(loc, ty, 1);
1692 mlir::Value lb = fir::factory::readLowerBound(builder, loc, box, dim, one);
1693 return builder.createConvert(loc, ty, lb);
1694 }
1695
1696 ExtValue genval(const Fortran::evaluate::ArrayRef &aref) {
1697 return genLoad(gen(aref));
1698 }
1699
1700 ExtValue gen(const Fortran::evaluate::CoarrayRef &coref) {
1701 return Fortran::lower::CoarrayExprHelper{converter, getLoc(), symMap}
1702 .genAddr(coref);
1703 }
1704
1705 ExtValue genval(const Fortran::evaluate::CoarrayRef &coref) {
1706 return Fortran::lower::CoarrayExprHelper{converter, getLoc(), symMap}
1707 .genValue(coref);
1708 }
1709
1710 template <typename A>
1711 ExtValue gen(const Fortran::evaluate::Designator<A> &des) {
1712 return std::visit([&](const auto &x) { return gen(x); }, des.u);
1713 }
1714 template <typename A>
1715 ExtValue genval(const Fortran::evaluate::Designator<A> &des) {
1716 return std::visit([&](const auto &x) { return genval(x); }, des.u);
1717 }
1718
1719 mlir::Type genType(const Fortran::evaluate::DynamicType &dt) {
1720 if (dt.category() != Fortran::common::TypeCategory::Derived)
1721 return converter.genType(dt.category(), dt.kind());
1722 if (dt.IsUnlimitedPolymorphic())
1723 return mlir::NoneType::get(&converter.getMLIRContext());
1724 return converter.genType(dt.GetDerivedTypeSpec());
1725 }
1726
1727 /// Lower a function reference
1728 template <typename A>
1729 ExtValue genFunctionRef(const Fortran::evaluate::FunctionRef<A> &funcRef) {
1730 if (!funcRef.GetType().has_value())
1731 fir::emitFatalError(getLoc(), "a function must have a type");
1732 mlir::Type resTy = genType(*funcRef.GetType());
1733 return genProcedureRef(funcRef, {resTy});
1734 }
1735
1736 /// Lower function call `funcRef` and return a reference to the resultant
1737 /// value. This is required for lowering expressions such as `f1(f2(v))`.
1738 template <typename A>
1739 ExtValue gen(const Fortran::evaluate::FunctionRef<A> &funcRef) {
1740 ExtValue retVal = genFunctionRef(funcRef);
1741 mlir::Type resultType = converter.genType(toEvExpr(funcRef));
1742 return placeScalarValueInMemory(builder, getLoc(), retVal, resultType);
1743 }
1744
1745 /// Helper to lower intrinsic arguments for inquiry intrinsic.
1746 ExtValue
1747 lowerIntrinsicArgumentAsInquired(const Fortran::lower::SomeExpr &expr) {
1748 if (Fortran::evaluate::IsAllocatableOrPointerObject(
1749 expr, converter.getFoldingContext()))
1750 return genMutableBoxValue(expr);
1751 /// Do not create temps for array sections whose properties only need to be
1752 /// inquired: create a descriptor that will be inquired.
1753 if (Fortran::evaluate::IsVariable(expr) && isArray(expr) &&
1754 !Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr))
1755 return lowerIntrinsicArgumentAsBox(expr);
1756 return gen(expr);
1757 }
1758
1759 /// Helper to lower intrinsic arguments to a fir::BoxValue.
1760 /// It preserves all the non default lower bounds/non deferred length
1761 /// parameter information.
1762 ExtValue lowerIntrinsicArgumentAsBox(const Fortran::lower::SomeExpr &expr) {
1763 mlir::Location loc = getLoc();
1764 ExtValue exv = genBoxArg(expr);
1765 auto exvTy = fir::getBase(exv).getType();
1766 if (exvTy.isa<mlir::FunctionType>()) {
1767 auto boxProcTy = builder.getBoxProcType(exvTy.cast<mlir::FunctionType>());
1768 return builder.create<fir::EmboxProcOp>(loc, boxProcTy,
1769 fir::getBase(exv));
1770 }
1771 mlir::Value box = builder.createBox(loc, exv, exv.isPolymorphic());
1772 if (Fortran::lower::isParentComponent(expr)) {
1773 fir::ExtendedValue newExv =
1774 Fortran::lower::updateBoxForParentComponent(converter, box, expr);
1775 box = fir::getBase(newExv);
1776 }
1777 return fir::BoxValue(
1778 box, fir::factory::getNonDefaultLowerBounds(builder, loc, exv),
1779 fir::factory::getNonDeferredLenParams(exv));
1780 }
1781
1782 /// Generate a call to a Fortran intrinsic or intrinsic module procedure.
1783 ExtValue genIntrinsicRef(
1784 const Fortran::evaluate::ProcedureRef &procRef,
1785 std::optional<mlir::Type> resultType,
1786 std::optional<const Fortran::evaluate::SpecificIntrinsic> intrinsic =
1787 std::nullopt) {
1788 llvm::SmallVector<ExtValue> operands;
1789
1790 std::string name =
1791 intrinsic ? intrinsic->name
1792 : procRef.proc().GetSymbol()->GetUltimate().name().ToString();
1793 mlir::Location loc = getLoc();
1794 if (intrinsic && Fortran::lower::intrinsicRequiresCustomOptionalHandling(
1795 procRef, *intrinsic, converter)) {
1796 using ExvAndPresence = std::pair<ExtValue, std::optional<mlir::Value>>;
1797 llvm::SmallVector<ExvAndPresence, 4> operands;
1798 auto prepareOptionalArg = [&](const Fortran::lower::SomeExpr &expr) {
1799 ExtValue optionalArg = lowerIntrinsicArgumentAsInquired(expr);
1800 mlir::Value isPresent =
1801 genActualIsPresentTest(builder, loc, optionalArg);
1802 operands.emplace_back(optionalArg, isPresent);
1803 };
1804 auto prepareOtherArg = [&](const Fortran::lower::SomeExpr &expr,
1805 fir::LowerIntrinsicArgAs lowerAs) {
1806 switch (lowerAs) {
1807 case fir::LowerIntrinsicArgAs::Value:
1808 operands.emplace_back(genval(expr), std::nullopt);
1809 return;
1810 case fir::LowerIntrinsicArgAs::Addr:
1811 operands.emplace_back(gen(expr), std::nullopt);
1812 return;
1813 case fir::LowerIntrinsicArgAs::Box:
1814 operands.emplace_back(lowerIntrinsicArgumentAsBox(expr),
1815 std::nullopt);
1816 return;
1817 case fir::LowerIntrinsicArgAs::Inquired:
1818 operands.emplace_back(lowerIntrinsicArgumentAsInquired(expr),
1819 std::nullopt);
1820 return;
1821 }
1822 };
1823 Fortran::lower::prepareCustomIntrinsicArgument(
1824 procRef, *intrinsic, resultType, prepareOptionalArg, prepareOtherArg,
1825 converter);
1826
1827 auto getArgument = [&](std::size_t i, bool loadArg) -> ExtValue {
1828 if (loadArg && fir::conformsWithPassByRef(
1829 fir::getBase(operands[i].first).getType()))
1830 return genLoad(operands[i].first);
1831 return operands[i].first;
1832 };
1833 auto isPresent = [&](std::size_t i) -> std::optional<mlir::Value> {
1834 return operands[i].second;
1835 };
1836 return Fortran::lower::lowerCustomIntrinsic(
1837 builder, loc, name, resultType, isPresent, getArgument,
1838 operands.size(), stmtCtx);
1839 }
1840
1841 const fir::IntrinsicArgumentLoweringRules *argLowering =
1842 fir::getIntrinsicArgumentLowering(name);
1843 for (const auto &arg : llvm::enumerate(procRef.arguments())) {
1844 auto *expr =
1845 Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
1846
1847 if (!expr && arg.value() && arg.value()->GetAssumedTypeDummy()) {
1848 // Assumed type optional.
1849 const Fortran::evaluate::Symbol *assumedTypeSym =
1850 arg.value()->GetAssumedTypeDummy();
1851 auto symBox = symMap.lookupSymbol(*assumedTypeSym);
1852 ExtValue exv =
1853 converter.getSymbolExtendedValue(*assumedTypeSym, &symMap);
1854 if (argLowering) {
1855 fir::ArgLoweringRule argRules =
1856 fir::lowerIntrinsicArgumentAs(*argLowering, arg.index());
1857 // Note: usages of TYPE(*) is limited by C710 but C_LOC and
1858 // IS_CONTIGUOUS may require an assumed size TYPE(*) to be passed to
1859 // the intrinsic library utility as a fir.box.
1860 if (argRules.lowerAs == fir::LowerIntrinsicArgAs::Box &&
1861 !fir::getBase(exv).getType().isa<fir::BaseBoxType>()) {
1862 operands.emplace_back(
1863 fir::factory::createBoxValue(builder, loc, exv));
1864 continue;
1865 }
1866 }
1867 operands.emplace_back(std::move(exv));
1868 continue;
1869 }
1870 if (!expr) {
1871 // Absent optional.
1872 operands.emplace_back(fir::getAbsentIntrinsicArgument());
1873 continue;
1874 }
1875 if (!argLowering) {
1876 // No argument lowering instruction, lower by value.
1877 operands.emplace_back(genval(*expr));
1878 continue;
1879 }
1880 // Ad-hoc argument lowering handling.
1881 fir::ArgLoweringRule argRules =
1882 fir::lowerIntrinsicArgumentAs(*argLowering, arg.index());
1883 if (argRules.handleDynamicOptional &&
1884 Fortran::evaluate::MayBePassedAsAbsentOptional(
1885 *expr, converter.getFoldingContext())) {
1886 ExtValue optional = lowerIntrinsicArgumentAsInquired(*expr);
1887 mlir::Value isPresent = genActualIsPresentTest(builder, loc, optional);
1888 switch (argRules.lowerAs) {
1889 case fir::LowerIntrinsicArgAs::Value:
1890 operands.emplace_back(
1891 genOptionalValue(builder, loc, optional, isPresent));
1892 continue;
1893 case fir::LowerIntrinsicArgAs::Addr:
1894 operands.emplace_back(
1895 genOptionalAddr(builder, loc, optional, isPresent));
1896 continue;
1897 case fir::LowerIntrinsicArgAs::Box:
1898 operands.emplace_back(
1899 genOptionalBox(builder, loc, optional, isPresent));
1900 continue;
1901 case fir::LowerIntrinsicArgAs::Inquired:
1902 operands.emplace_back(optional);
1903 continue;
1904 }
1905 llvm_unreachable("bad switch")::llvm::llvm_unreachable_internal("bad switch", "flang/lib/Lower/ConvertExpr.cpp"
, 1905)
;
1906 }
1907 switch (argRules.lowerAs) {
1908 case fir::LowerIntrinsicArgAs::Value:
1909 operands.emplace_back(genval(*expr));
1910 continue;
1911 case fir::LowerIntrinsicArgAs::Addr:
1912 operands.emplace_back(gen(*expr));
1913 continue;
1914 case fir::LowerIntrinsicArgAs::Box:
1915 operands.emplace_back(lowerIntrinsicArgumentAsBox(*expr));
1916 continue;
1917 case fir::LowerIntrinsicArgAs::Inquired:
1918 operands.emplace_back(lowerIntrinsicArgumentAsInquired(*expr));
1919 continue;
1920 }
1921 llvm_unreachable("bad switch")::llvm::llvm_unreachable_internal("bad switch", "flang/lib/Lower/ConvertExpr.cpp"
, 1921)
;
1922 }
1923 // Let the intrinsic library lower the intrinsic procedure call
1924 return Fortran::lower::genIntrinsicCall(builder, getLoc(), name, resultType,
1925 operands, stmtCtx);
1926 }
1927
1928 /// helper to detect statement functions
1929 static bool
1930 isStatementFunctionCall(const Fortran::evaluate::ProcedureRef &procRef) {
1931 if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())
1932 if (const auto *details =
1933 symbol->detailsIf<Fortran::semantics::SubprogramDetails>())
1934 return details->stmtFunction().has_value();
1935 return false;
1936 }
1937
1938 /// Generate Statement function calls
1939 ExtValue genStmtFunctionRef(const Fortran::evaluate::ProcedureRef &procRef) {
1940 const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol();
1941 assert(symbol && "expected symbol in ProcedureRef of statement functions")(static_cast <bool> (symbol && "expected symbol in ProcedureRef of statement functions"
) ? void (0) : __assert_fail ("symbol && \"expected symbol in ProcedureRef of statement functions\""
, "flang/lib/Lower/ConvertExpr.cpp", 1941, __extension__ __PRETTY_FUNCTION__
))
;
1942 const auto &details = symbol->get<Fortran::semantics::SubprogramDetails>();
1943
1944 // Statement functions have their own scope, we just need to associate
1945 // the dummy symbols to argument expressions. They are no
1946 // optional/alternate return arguments. Statement functions cannot be
1947 // recursive (directly or indirectly) so it is safe to add dummy symbols to
1948 // the local map here.
1949 symMap.pushScope();
1950 for (auto [arg, bind] :
1951 llvm::zip(details.dummyArgs(), procRef.arguments())) {
1952 assert(arg && "alternate return in statement function")(static_cast <bool> (arg && "alternate return in statement function"
) ? void (0) : __assert_fail ("arg && \"alternate return in statement function\""
, "flang/lib/Lower/ConvertExpr.cpp", 1952, __extension__ __PRETTY_FUNCTION__
))
;
1953 assert(bind && "optional argument in statement function")(static_cast <bool> (bind && "optional argument in statement function"
) ? void (0) : __assert_fail ("bind && \"optional argument in statement function\""
, "flang/lib/Lower/ConvertExpr.cpp", 1953, __extension__ __PRETTY_FUNCTION__
))
;
1954 const auto *expr = bind->UnwrapExpr();
1955 // TODO: assumed type in statement function, that surprisingly seems
1956 // allowed, probably because nobody thought of restricting this usage.
1957 // gfortran/ifort compiles this.
1958 assert(expr && "assumed type used as statement function argument")(static_cast <bool> (expr && "assumed type used as statement function argument"
) ? void (0) : __assert_fail ("expr && \"assumed type used as statement function argument\""
, "flang/lib/Lower/ConvertExpr.cpp", 1958, __extension__ __PRETTY_FUNCTION__
))
;
1959 // As per Fortran 2018 C1580, statement function arguments can only be
1960 // scalars, so just pass the box with the address. The only care is to
1961 // to use the dummy character explicit length if any instead of the
1962 // actual argument length (that can be bigger).
1963 if (const Fortran::semantics::DeclTypeSpec *type = arg->GetType())
1964 if (type->category() == Fortran::semantics::DeclTypeSpec::Character)
1965 if (const Fortran::semantics::MaybeIntExpr &lenExpr =
1966 type->characterTypeSpec().length().GetExplicit()) {
1967 mlir::Value len = fir::getBase(genval(*lenExpr));
1968 // F2018 7.4.4.2 point 5.
1969 len = fir::factory::genMaxWithZero(builder, getLoc(), len);
1970 symMap.addSymbol(*arg,
1971 replaceScalarCharacterLength(gen(*expr), len));
1972 continue;
1973 }
1974 symMap.addSymbol(*arg, gen(*expr));
1975 }
1976
1977 // Explicitly map statement function host associated symbols to their
1978 // parent scope lowered symbol box.
1979 for (const Fortran::semantics::SymbolRef &sym :
1980 Fortran::evaluate::CollectSymbols(*details.stmtFunction()))
1981 if (const auto *details =
1982 sym->detailsIf<Fortran::semantics::HostAssocDetails>())
1983 if (!symMap.lookupSymbol(*sym))
1984 symMap.addSymbol(*sym, gen(details->symbol()));
1985
1986 ExtValue result = genval(details.stmtFunction().value());
1987 LLVM_DEBUG(llvm::dbgs() << "stmt-function: " << result << '\n')do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { llvm::dbgs() << "stmt-function: "
<< result << '\n'; } } while (false)
;
1988 symMap.popScope();
1989 return result;
1990 }
1991
1992 /// Create a contiguous temporary array with the same shape,
1993 /// length parameters and type as mold. It is up to the caller to deallocate
1994 /// the temporary.
1995 ExtValue genArrayTempFromMold(const ExtValue &mold,
1996 llvm::StringRef tempName) {
1997 mlir::Type type = fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(mold).getType());
1998 assert(type && "expected descriptor or memory type")(static_cast <bool> (type && "expected descriptor or memory type"
) ? void (0) : __assert_fail ("type && \"expected descriptor or memory type\""
, "flang/lib/Lower/ConvertExpr.cpp", 1998, __extension__ __PRETTY_FUNCTION__
))
;
1999 mlir::Location loc = getLoc();
2000 llvm::SmallVector<mlir::Value> extents =
2001 fir::factory::getExtents(loc, builder, mold);
2002 llvm::SmallVector<mlir::Value> allocMemTypeParams =
2003 fir::getTypeParams(mold);
2004 mlir::Value charLen;
2005 mlir::Type elementType = fir::unwrapSequenceType(type);
2006 if (auto charType = elementType.dyn_cast<fir::CharacterType>()) {
2007 charLen = allocMemTypeParams.empty()
2008 ? fir::factory::readCharLen(builder, loc, mold)
2009 : allocMemTypeParams[0];
2010 if (charType.hasDynamicLen() && allocMemTypeParams.empty())
2011 allocMemTypeParams.push_back(charLen);
2012 } else if (fir::hasDynamicSize(elementType)) {
2013 TODO(loc, "creating temporary for derived type with length parameters")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "2013" ": not yet implemented: ") + llvm::Twine("creating temporary for derived type with length parameters"
), false); } while (false)
;
2014 }
2015
2016 mlir::Value temp = builder.create<fir::AllocMemOp>(
2017 loc, type, tempName, allocMemTypeParams, extents);
2018 if (fir::unwrapSequenceType(type).isa<fir::CharacterType>())
2019 return fir::CharArrayBoxValue{temp, charLen, extents};
2020 return fir::ArrayBoxValue{temp, extents};
2021 }
2022
2023 /// Copy \p source array into \p dest array. Both arrays must be
2024 /// conforming, but neither array must be contiguous.
2025 void genArrayCopy(ExtValue dest, ExtValue source) {
2026 return createSomeArrayAssignment(converter, dest, source, symMap, stmtCtx);
2027 }
2028
2029 /// Lower a non-elemental procedure reference and read allocatable and pointer
2030 /// results into normal values.
2031 ExtValue genProcedureRef(const Fortran::evaluate::ProcedureRef &procRef,
2032 std::optional<mlir::Type> resultType) {
2033 ExtValue res = genRawProcedureRef(procRef, resultType);
2034 // In most contexts, pointers and allocatable do not appear as allocatable
2035 // or pointer variable on the caller side (see 8.5.3 note 1 for
2036 // allocatables). The few context where this can happen must call
2037 // genRawProcedureRef directly.
2038 if (const auto *box = res.getBoxOf<fir::MutableBoxValue>())
2039 return fir::factory::genMutableBoxRead(builder, getLoc(), *box);
2040 return res;
2041 }
2042
2043 /// Like genExtAddr, but ensure the address returned is a temporary even if \p
2044 /// expr is variable inside parentheses.
2045 ExtValue genTempExtAddr(const Fortran::lower::SomeExpr &expr) {
2046 // In general, genExtAddr might not create a temp for variable inside
2047 // parentheses to avoid creating array temporary in sub-expressions. It only
2048 // ensures the sub-expression is not re-associated with other parts of the
2049 // expression. In the call semantics, there is a difference between expr and
2050 // variable (see R1524). For expressions, a variable storage must not be
2051 // argument associated since it could be modified inside the call, or the
2052 // variable could also be modified by other means during the call.
2053 if (!isParenthesizedVariable(expr))
2054 return genExtAddr(expr);
2055 if (expr.Rank() > 0)
2056 return asArray(expr);
2057 mlir::Location loc = getLoc();
2058 return genExtValue(expr).match(
2059 [&](const fir::CharBoxValue &boxChar) -> ExtValue {
2060 return fir::factory::CharacterExprHelper{builder, loc}.createTempFrom(
2061 boxChar);
2062 },
2063 [&](const fir::UnboxedValue &v) -> ExtValue {
2064 mlir::Type type = v.getType();
2065 mlir::Value value = v;
2066 if (fir::isa_ref_type(type))
2067 value = builder.create<fir::LoadOp>(loc, value);
2068 mlir::Value temp = builder.createTemporary(loc, value.getType());
2069 builder.create<fir::StoreOp>(loc, value, temp);
2070 return temp;
2071 },
2072 [&](const fir::BoxValue &x) -> ExtValue {
2073 // Derived type scalar that may be polymorphic.
2074 if (fir::isPolymorphicType(fir::getBase(x).getType()))
2075 TODO(loc, "polymorphic array temporary")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "2075" ": not yet implemented: ") + llvm::Twine("polymorphic array temporary"
), false); } while (false)
;
2076 assert(!x.hasRank() && x.isDerived())(static_cast <bool> (!x.hasRank() && x.isDerived
()) ? void (0) : __assert_fail ("!x.hasRank() && x.isDerived()"
, "flang/lib/Lower/ConvertExpr.cpp", 2076, __extension__ __PRETTY_FUNCTION__
))
;
2077 if (x.isDerivedWithLenParameters())
2078 fir::emitFatalError(
2079 loc, "making temps for derived type with length parameters");
2080 // TODO: polymorphic aspects should be kept but for now the temp
2081 // created always has the declared type.
2082 mlir::Value var =
2083 fir::getBase(fir::factory::readBoxValue(builder, loc, x));
2084 auto value = builder.create<fir::LoadOp>(loc, var);
2085 mlir::Value temp = builder.createTemporary(loc, value.getType());
2086 builder.create<fir::StoreOp>(loc, value, temp);
2087 return temp;
2088 },
2089 [&](const fir::PolymorphicValue &p) -> ExtValue {
2090 TODO(loc, "creating polymorphic temporary")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "2090" ": not yet implemented: ") + llvm::Twine("creating polymorphic temporary"
), false); } while (false)
;
2091 },
2092 [&](const auto &) -> ExtValue {
2093 fir::emitFatalError(loc, "expr is not a scalar value");
2094 });
2095 }
2096
2097 /// Helper structure to track potential copy-in of non contiguous variable
2098 /// argument into a contiguous temp. It is used to deallocate the temp that
2099 /// may have been created as well as to the copy-out from the temp to the
2100 /// variable after the call.
2101 struct CopyOutPair {
2102 ExtValue var;
2103 ExtValue temp;
2104 // Flag to indicate if the argument may have been modified by the
2105 // callee, in which case it must be copied-out to the variable.
2106 bool argMayBeModifiedByCall;
2107 // Optional boolean value that, if present and false, prevents
2108 // the copy-out and temp deallocation.
2109 std::optional<mlir::Value> restrictCopyAndFreeAtRuntime;
2110 };
2111 using CopyOutPairs = llvm::SmallVector<CopyOutPair, 4>;
2112
2113 /// Helper to read any fir::BoxValue into other fir::ExtendedValue categories
2114 /// not based on fir.box.
2115 /// This will lose any non contiguous stride information and dynamic type and
2116 /// should only be called if \p exv is known to be contiguous or if its base
2117 /// address will be replaced by a contiguous one. If \p exv is not a
2118 /// fir::BoxValue, this is a no-op.
2119 ExtValue readIfBoxValue(const ExtValue &exv) {
2120 if (const auto *box = exv.getBoxOf<fir::BoxValue>())
2121 return fir::factory::readBoxValue(builder, getLoc(), *box);
2122 return exv;
2123 }
2124
2125 /// Generate a contiguous temp to pass \p actualArg as argument \p arg. The
2126 /// creation of the temp and copy-in can be made conditional at runtime by
2127 /// providing a runtime boolean flag \p restrictCopyAtRuntime (in which case
2128 /// the temp and copy will only be made if the value is true at runtime).
2129 ExtValue genCopyIn(const ExtValue &actualArg,
2130 const Fortran::lower::CallerInterface::PassedEntity &arg,
2131 CopyOutPairs &copyOutPairs,
2132 std::optional<mlir::Value> restrictCopyAtRuntime,
2133 bool byValue) {
2134 const bool doCopyOut = !byValue && arg.mayBeModifiedByCall();
2135 llvm::StringRef tempName = byValue ? ".copy" : ".copyinout";
2136 mlir::Location loc = getLoc();
2137 bool isActualArgBox = fir::isa_box_type(fir::getBase(actualArg).getType());
2138 mlir::Value isContiguousResult;
2139 mlir::Type addrType = fir::HeapType::get(
2140 fir::unwrapPassByRefType(fir::getBase(actualArg).getType()));
2141
2142 if (isActualArgBox) {
2143 // Check at runtime if the argument is contiguous so no copy is needed.
2144 isContiguousResult =
2145 fir::runtime::genIsContiguous(builder, loc, fir::getBase(actualArg));
2146 }
2147
2148 auto doCopyIn = [&]() -> ExtValue {
2149 ExtValue temp = genArrayTempFromMold(actualArg, tempName);
2150 if (!arg.mayBeReadByCall()) {
2151 return temp;
2152 }
2153 if (!isActualArgBox || inlineCopyInOutForBoxes) {
2154 genArrayCopy(temp, actualArg);
2155 return temp;
2156 }
2157
2158 // Generate Assign() call to copy data from the actualArg
2159 // to a temporary.
2160 mlir::Value destBox = fir::getBase(builder.createBox(loc, temp));
2161 mlir::Value boxRef = builder.createTemporary(loc, destBox.getType());
2162 builder.create<fir::StoreOp>(loc, destBox, boxRef);
2163 fir::runtime::genAssign(builder, loc, boxRef, fir::getBase(actualArg));
2164 return temp;
2165 };
2166
2167 auto noCopy = [&]() {
2168 mlir::Value box = fir::getBase(actualArg);
2169 mlir::Value boxAddr = builder.create<fir::BoxAddrOp>(loc, addrType, box);
2170 builder.create<fir::ResultOp>(loc, boxAddr);
2171 };
2172
2173 auto combinedCondition = [&]() {
2174 if (isActualArgBox) {
2175 mlir::Value zero =
2176 builder.createIntegerConstant(loc, builder.getI1Type(), 0);
2177 mlir::Value notContiguous = builder.create<mlir::arith::CmpIOp>(
2178 loc, mlir::arith::CmpIPredicate::eq, isContiguousResult, zero);
2179 if (!restrictCopyAtRuntime) {
2180 restrictCopyAtRuntime = notContiguous;
2181 } else {
2182 mlir::Value cond = builder.create<mlir::arith::AndIOp>(
2183 loc, *restrictCopyAtRuntime, notContiguous);
2184 restrictCopyAtRuntime = cond;
2185 }
2186 }
2187 };
2188
2189 if (!restrictCopyAtRuntime) {
2190 if (isActualArgBox) {
2191 // isContiguousResult = genIsContiguousCall();
2192 mlir::Value addr =
2193 builder
2194 .genIfOp(loc, {addrType}, isContiguousResult,
2195 /*withElseRegion=*/true)
2196 .genThen([&]() { noCopy(); })
2197 .genElse([&] {
2198 ExtValue temp = doCopyIn();
2199 builder.create<fir::ResultOp>(loc, fir::getBase(temp));
2200 })
2201 .getResults()[0];
2202 fir::ExtendedValue temp =
2203 fir::substBase(readIfBoxValue(actualArg), addr);
2204 combinedCondition();
2205 copyOutPairs.emplace_back(
2206 CopyOutPair{actualArg, temp, doCopyOut, restrictCopyAtRuntime});
2207 return temp;
2208 }
2209
2210 ExtValue temp = doCopyIn();
2211 copyOutPairs.emplace_back(CopyOutPair{actualArg, temp, doCopyOut, {}});
2212 return temp;
2213 }
2214
2215 // Otherwise, need to be careful to only copy-in if allowed at runtime.
2216 mlir::Value addr =
2217 builder
2218 .genIfOp(loc, {addrType}, *restrictCopyAtRuntime,
2219 /*withElseRegion=*/true)
2220 .genThen([&]() {
2221 if (isActualArgBox) {
2222 // isContiguousResult = genIsContiguousCall();
2223 // Avoid copyin if the argument is contiguous at runtime.
2224 mlir::Value addr1 =
2225 builder
2226 .genIfOp(loc, {addrType}, isContiguousResult,
2227 /*withElseRegion=*/true)
2228 .genThen([&]() { noCopy(); })
2229 .genElse([&]() {
2230 ExtValue temp = doCopyIn();
2231 builder.create<fir::ResultOp>(loc,
2232 fir::getBase(temp));
2233 })
2234 .getResults()[0];
2235 builder.create<fir::ResultOp>(loc, addr1);
2236 } else {
2237 ExtValue temp = doCopyIn();
2238 builder.create<fir::ResultOp>(loc, fir::getBase(temp));
2239 }
2240 })
2241 .genElse([&]() {
2242 mlir::Value nullPtr = builder.createNullConstant(loc, addrType);
2243 builder.create<fir::ResultOp>(loc, nullPtr);
2244 })
2245 .getResults()[0];
2246 // Associate the temp address with actualArg lengths and extents if a
2247 // temporary is generated. Otherwise the same address is associated.
2248 fir::ExtendedValue temp = fir::substBase(readIfBoxValue(actualArg), addr);
2249 combinedCondition();
2250 copyOutPairs.emplace_back(
2251 CopyOutPair{actualArg, temp, doCopyOut, restrictCopyAtRuntime});
2252 return temp;
2253 }
2254
2255 /// Generate copy-out if needed and free the temporary for an argument that
2256 /// has been copied-in into a contiguous temp.
2257 void genCopyOut(const CopyOutPair &copyOutPair) {
2258 mlir::Location loc = getLoc();
2259 bool isActualArgBox =
2260 fir::isa_box_type(fir::getBase(copyOutPair.var).getType());
2261 auto doCopyOut = [&]() {
2262 if (!copyOutPair.argMayBeModifiedByCall) {
2263 return;
2264 }
2265 if (!isActualArgBox || inlineCopyInOutForBoxes) {
2266 genArrayCopy(copyOutPair.var, copyOutPair.temp);
2267 return;
2268 }
2269 // Generate Assign() call to copy data from the temporary
2270 // to the actualArg. Note that in case the actual argument
2271 // is ALLOCATABLE/POINTER the Assign() implementation
2272 // should not engage its reallocation, because the temporary
2273 // is rank, shape and type compatible with it.
2274 mlir::Value srcBox =
2275 fir::getBase(builder.createBox(loc, copyOutPair.temp));
2276 mlir::Value destBox =
2277 fir::getBase(builder.createBox(loc, copyOutPair.var));
2278 mlir::Value destBoxRef = builder.createTemporary(loc, destBox.getType());
2279 builder.create<fir::StoreOp>(loc, destBox, destBoxRef);
2280 fir::runtime::genAssign(builder, loc, destBoxRef, srcBox);
2281 };
2282 if (!copyOutPair.restrictCopyAndFreeAtRuntime) {
2283 doCopyOut();
2284 builder.create<fir::FreeMemOp>(loc, fir::getBase(copyOutPair.temp));
2285 return;
2286 }
2287
2288 builder.genIfThen(loc, *copyOutPair.restrictCopyAndFreeAtRuntime)
2289 .genThen([&]() {
2290 doCopyOut();
2291 builder.create<fir::FreeMemOp>(loc, fir::getBase(copyOutPair.temp));
2292 })
2293 .end();
2294 }
2295
2296 /// Lower a designator to a variable that may be absent at runtime into an
2297 /// ExtendedValue where all the properties (base address, shape and length
2298 /// parameters) can be safely read (set to zero if not present). It also
2299 /// returns a boolean mlir::Value telling if the variable is present at
2300 /// runtime.
2301 /// This is useful to later be able to do conditional copy-in/copy-out
2302 /// or to retrieve the base address without having to deal with the case
2303 /// where the actual may be an absent fir.box.
2304 std::pair<ExtValue, mlir::Value>
2305 prepareActualThatMayBeAbsent(const Fortran::lower::SomeExpr &expr) {
2306 mlir::Location loc = getLoc();
2307 if (Fortran::evaluate::IsAllocatableOrPointerObject(
2308 expr, converter.getFoldingContext())) {
2309 // Fortran 2018 15.5.2.12 point 1: If unallocated/disassociated,
2310 // it is as if the argument was absent. The main care here is to
2311 // not do a copy-in/copy-out because the temp address, even though
2312 // pointing to a null size storage, would not be a nullptr and
2313 // therefore the argument would not be considered absent on the
2314 // callee side. Note: if wholeSymbol is optional, it cannot be
2315 // absent as per 15.5.2.12 point 7. and 8. We rely on this to
2316 // un-conditionally read the allocatable/pointer descriptor here.
2317 fir::MutableBoxValue mutableBox = genMutableBoxValue(expr);
2318 mlir::Value isPresent = fir::factory::genIsAllocatedOrAssociatedTest(
2319 builder, loc, mutableBox);
2320 fir::ExtendedValue actualArg =
2321 fir::factory::genMutableBoxRead(builder, loc, mutableBox);
2322 return {actualArg, isPresent};
2323 }
2324 // Absent descriptor cannot be read. To avoid any issue in
2325 // copy-in/copy-out, and when retrieving the address/length
2326 // create an descriptor pointing to a null address here if the
2327 // fir.box is absent.
2328 ExtValue actualArg = gen(expr);
2329 mlir::Value actualArgBase = fir::getBase(actualArg);
2330 mlir::Value isPresent = builder.create<fir::IsPresentOp>(
2331 loc, builder.getI1Type(), actualArgBase);
2332 if (!actualArgBase.getType().isa<fir::BoxType>())
2333 return {actualArg, isPresent};
2334 ExtValue safeToReadBox =
2335 absentBoxToUnallocatedBox(builder, loc, actualArg, isPresent);
2336 return {safeToReadBox, isPresent};
2337 }
2338
2339 /// Create a temp on the stack for scalar actual arguments that may be absent
2340 /// at runtime, but must be passed via a temp if they are presents.
2341 fir::ExtendedValue
2342 createScalarTempForArgThatMayBeAbsent(ExtValue actualArg,
2343 mlir::Value isPresent) {
2344 mlir::Location loc = getLoc();
2345 mlir::Type type = fir::unwrapRefType(fir::getBase(actualArg).getType());
2346 if (fir::isDerivedWithLenParameters(actualArg))
2347 TODO(loc, "parametrized derived type optional scalar argument copy-in")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "2347" ": not yet implemented: ") + llvm::Twine("parametrized derived type optional scalar argument copy-in"
), false); } while (false)
;
2348 if (const fir::CharBoxValue *charBox = actualArg.getCharBox()) {
2349 mlir::Value len = charBox->getLen();
2350 mlir::Value zero = builder.createIntegerConstant(loc, len.getType(), 0);
2351 len = builder.create<mlir::arith::SelectOp>(loc, isPresent, len, zero);
2352 mlir::Value temp = builder.createTemporary(
2353 loc, type, /*name=*/{},
2354 /*shape=*/{}, mlir::ValueRange{len},
2355 llvm::ArrayRef<mlir::NamedAttribute>{
2356 Fortran::lower::getAdaptToByRefAttr(builder)});
2357 return fir::CharBoxValue{temp, len};
2358 }
2359 assert((fir::isa_trivial(type) || type.isa<fir::RecordType>()) &&(static_cast <bool> ((fir::isa_trivial(type) || type.isa
<fir::RecordType>()) && "must be simple scalar"
) ? void (0) : __assert_fail ("(fir::isa_trivial(type) || type.isa<fir::RecordType>()) && \"must be simple scalar\""
, "flang/lib/Lower/ConvertExpr.cpp", 2360, __extension__ __PRETTY_FUNCTION__
))
2360 "must be simple scalar")(static_cast <bool> ((fir::isa_trivial(type) || type.isa
<fir::RecordType>()) && "must be simple scalar"
) ? void (0) : __assert_fail ("(fir::isa_trivial(type) || type.isa<fir::RecordType>()) && \"must be simple scalar\""
, "flang/lib/Lower/ConvertExpr.cpp", 2360, __extension__ __PRETTY_FUNCTION__
))
;
2361 return builder.createTemporary(
2362 loc, type,
2363 llvm::ArrayRef<mlir::NamedAttribute>{
2364 Fortran::lower::getAdaptToByRefAttr(builder)});
2365 }
2366
2367 template <typename A>
2368 bool isCharacterType(const A &exp) {
2369 if (auto type = exp.GetType())
2370 return type->category() == Fortran::common::TypeCategory::Character;
2371 return false;
2372 }
2373
2374 /// Lower an actual argument that must be passed via an address.
2375 /// This generates of the copy-in/copy-out if the actual is not contiguous, or
2376 /// the creation of the temp if the actual is a variable and \p byValue is
2377 /// true. It handles the cases where the actual may be absent, and all of the
2378 /// copying has to be conditional at runtime.
2379 /// If the actual argument may be dynamically absent, return an additional
2380 /// boolean mlir::Value that if true means that the actual argument is
2381 /// present.
2382 std::pair<ExtValue, std::optional<mlir::Value>>
2383 prepareActualToBaseAddressLike(
2384 const Fortran::lower::SomeExpr &expr,
2385 const Fortran::lower::CallerInterface::PassedEntity &arg,
2386 CopyOutPairs &copyOutPairs, bool byValue) {
2387 mlir::Location loc = getLoc();
2388 const bool isArray = expr.Rank() > 0;
2389 const bool actualArgIsVariable = Fortran::evaluate::IsVariable(expr);
2390 // It must be possible to modify VALUE arguments on the callee side, even
2391 // if the actual argument is a literal or named constant. Hence, the
2392 // address of static storage must not be passed in that case, and a copy
2393 // must be made even if this is not a variable.
2394 // Note: isArray should be used here, but genBoxArg already creates copies
2395 // for it, so do not duplicate the copy until genBoxArg behavior is changed.
2396 const bool isStaticConstantByValue =
2397 byValue && Fortran::evaluate::IsActuallyConstant(expr) &&
2398 (isCharacterType(expr));
2399 const bool variableNeedsCopy =
2400 actualArgIsVariable &&
2401 (byValue || (isArray && !Fortran::evaluate::IsSimplyContiguous(
2402 expr, converter.getFoldingContext())));
2403 const bool needsCopy = isStaticConstantByValue || variableNeedsCopy;
2404 auto [argAddr, isPresent] =
2405 [&]() -> std::pair<ExtValue, std::optional<mlir::Value>> {
2406 if (!actualArgIsVariable && !needsCopy)
2407 // Actual argument is not a variable. Make sure a variable address is
2408 // not passed.
2409 return {genTempExtAddr(expr), std::nullopt};
2410 ExtValue baseAddr;
2411 if (arg.isOptional() && Fortran::evaluate::MayBePassedAsAbsentOptional(
2412 expr, converter.getFoldingContext())) {
2413 auto [actualArgBind, isPresent] = prepareActualThatMayBeAbsent(expr);
2414 const ExtValue &actualArg = actualArgBind;
2415 if (!needsCopy)
2416 return {actualArg, isPresent};
2417
2418 if (isArray)
2419 return {genCopyIn(actualArg, arg, copyOutPairs, isPresent, byValue),
2420 isPresent};
2421 // Scalars, create a temp, and use it conditionally at runtime if
2422 // the argument is present.
2423 ExtValue temp =
2424 createScalarTempForArgThatMayBeAbsent(actualArg, isPresent);
2425 mlir::Type tempAddrTy = fir::getBase(temp).getType();
2426 mlir::Value selectAddr =
2427 builder
2428 .genIfOp(loc, {tempAddrTy}, isPresent,
2429 /*withElseRegion=*/true)
2430 .genThen([&]() {
2431 fir::factory::genScalarAssignment(builder, loc, temp,
2432 actualArg);
2433 builder.create<fir::ResultOp>(loc, fir::getBase(temp));
2434 })
2435 .genElse([&]() {
2436 mlir::Value absent =
2437 builder.create<fir::AbsentOp>(loc, tempAddrTy);
2438 builder.create<fir::ResultOp>(loc, absent);
2439 })
2440 .getResults()[0];
2441 return {fir::substBase(temp, selectAddr), isPresent};
2442 }
2443 // Actual cannot be absent, the actual argument can safely be
2444 // copied-in/copied-out without any care if needed.
2445 if (isArray) {
2446 ExtValue box = genBoxArg(expr);
2447 if (needsCopy)
2448 return {genCopyIn(box, arg, copyOutPairs,
2449 /*restrictCopyAtRuntime=*/std::nullopt, byValue),
2450 std::nullopt};
2451 // Contiguous: just use the box we created above!
2452 // This gets "unboxed" below, if needed.
2453 return {box, std::nullopt};
2454 }
2455 // Actual argument is a non-optional, non-pointer, non-allocatable
2456 // scalar.
2457 ExtValue actualArg = genExtAddr(expr);
2458 if (needsCopy)
2459 return {createInMemoryScalarCopy(builder, loc, actualArg),
2460 std::nullopt};
2461 return {actualArg, std::nullopt};
2462 }();
2463 // Scalar and contiguous expressions may be lowered to a fir.box,
2464 // either to account for potential polymorphism, or because lowering
2465 // did not account for some contiguity hints.
2466 // Here, polymorphism does not matter (an entity of the declared type
2467 // is passed, not one of the dynamic type), and the expr is known to
2468 // be simply contiguous, so it is safe to unbox it and pass the
2469 // address without making a copy.
2470 return {readIfBoxValue(argAddr), isPresent};
2471 }
2472
2473 /// Lower a non-elemental procedure reference.
2474 ExtValue genRawProcedureRef(const Fortran::evaluate::ProcedureRef &procRef,
2475 std::optional<mlir::Type> resultType) {
2476 mlir::Location loc = getLoc();
2477 if (isElementalProcWithArrayArgs(procRef))
2478 fir::emitFatalError(loc, "trying to lower elemental procedure with array "
2479 "arguments as normal procedure");
2480
2481 if (const Fortran::evaluate::SpecificIntrinsic *intrinsic =
2482 procRef.proc().GetSpecificIntrinsic())
2483 return genIntrinsicRef(procRef, resultType, *intrinsic);
2484
2485 if (Fortran::lower::isIntrinsicModuleProcRef(procRef))
2486 return genIntrinsicRef(procRef, resultType);
2487
2488 if (isStatementFunctionCall(procRef))
2489 return genStmtFunctionRef(procRef);
2490
2491 Fortran::lower::CallerInterface caller(procRef, converter);
2492 using PassBy = Fortran::lower::CallerInterface::PassEntityBy;
2493
2494 llvm::SmallVector<fir::MutableBoxValue> mutableModifiedByCall;
2495 // List of <var, temp> where temp must be copied into var after the call.
2496 CopyOutPairs copyOutPairs;
2497
2498 mlir::FunctionType callSiteType = caller.genFunctionType();
2499
2500 // Lower the actual arguments and map the lowered values to the dummy
2501 // arguments.
2502 for (const Fortran::lower::CallInterface<
2503 Fortran::lower::CallerInterface>::PassedEntity &arg :
2504 caller.getPassedArguments()) {
2505 const auto *actual = arg.entity;
2506 mlir::Type argTy = callSiteType.getInput(arg.firArgument);
2507 if (!actual) {
2508 // Optional dummy argument for which there is no actual argument.
2509 caller.placeInput(arg, builder.genAbsentOp(loc, argTy));
2510 continue;
2511 }
2512 const auto *expr = actual->UnwrapExpr();
2513 if (!expr)
2514 TODO(loc, "assumed type actual argument")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "2514" ": not yet implemented: ") + llvm::Twine("assumed type actual argument"
), false); } while (false)
;
2515
2516 if (arg.passBy == PassBy::Value) {
2517 ExtValue argVal = genval(*expr);
2518 if (!fir::isUnboxedValue(argVal))
2519 fir::emitFatalError(
2520 loc, "internal error: passing non trivial value by value");
2521 caller.placeInput(arg, fir::getBase(argVal));
2522 continue;
2523 }
2524
2525 if (arg.passBy == PassBy::MutableBox) {
2526 if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
2527 *expr)) {
2528 // If expr is NULL(), the mutableBox created must be a deallocated
2529 // pointer with the dummy argument characteristics (see table 16.5
2530 // in Fortran 2018 standard).
2531 // No length parameters are set for the created box because any non
2532 // deferred type parameters of the dummy will be evaluated on the
2533 // callee side, and it is illegal to use NULL without a MOLD if any
2534 // dummy length parameters are assumed.
2535 mlir::Type boxTy = fir::dyn_cast_ptrEleTy(argTy);
2536 assert(boxTy && boxTy.isa<fir::BaseBoxType>() &&(static_cast <bool> (boxTy && boxTy.isa<fir::
BaseBoxType>() && "must be a fir.box type") ? void
(0) : __assert_fail ("boxTy && boxTy.isa<fir::BaseBoxType>() && \"must be a fir.box type\""
, "flang/lib/Lower/ConvertExpr.cpp", 2537, __extension__ __PRETTY_FUNCTION__
))
2537 "must be a fir.box type")(static_cast <bool> (boxTy && boxTy.isa<fir::
BaseBoxType>() && "must be a fir.box type") ? void
(0) : __assert_fail ("boxTy && boxTy.isa<fir::BaseBoxType>() && \"must be a fir.box type\""
, "flang/lib/Lower/ConvertExpr.cpp", 2537, __extension__ __PRETTY_FUNCTION__
))
;
2538 mlir::Value boxStorage = builder.createTemporary(loc, boxTy);
2539 mlir::Value nullBox = fir::factory::createUnallocatedBox(
2540 builder, loc, boxTy, /*nonDeferredParams=*/{});
2541 builder.create<fir::StoreOp>(loc, nullBox, boxStorage);
2542 caller.placeInput(arg, boxStorage);
2543 continue;
2544 }
2545 if (fir::isPointerType(argTy) &&
2546 !Fortran::evaluate::IsObjectPointer(
2547 *expr, converter.getFoldingContext())) {
2548 // Passing a non POINTER actual argument to a POINTER dummy argument.
2549 // Create a pointer of the dummy argument type and assign the actual
2550 // argument to it.
2551 mlir::Value irBox =
2552 builder.createTemporary(loc, fir::unwrapRefType(argTy));
2553 // Non deferred parameters will be evaluated on the callee side.
2554 fir::MutableBoxValue pointer(irBox,
2555 /*nonDeferredParams=*/mlir::ValueRange{},
2556 /*mutableProperties=*/{});
2557 Fortran::lower::associateMutableBox(converter, loc, pointer, *expr,
2558 /*lbounds=*/std::nullopt,
2559 stmtCtx);
2560 caller.placeInput(arg, irBox);
2561 continue;
2562 }
2563 // Passing a POINTER to a POINTER, or an ALLOCATABLE to an ALLOCATABLE.
2564 fir::MutableBoxValue mutableBox = genMutableBoxValue(*expr);
2565 mlir::Value irBox =
2566 fir::factory::getMutableIRBox(builder, loc, mutableBox);
2567 caller.placeInput(arg, irBox);
2568 if (arg.mayBeModifiedByCall())
2569 mutableModifiedByCall.emplace_back(std::move(mutableBox));
2570 if (fir::isAllocatableType(argTy) && arg.isIntentOut() &&
2571 Fortran::semantics::IsBindCProcedure(*procRef.proc().GetSymbol())) {
2572 if (mutableBox.isDerived() || mutableBox.isPolymorphic() ||
2573 mutableBox.isUnlimitedPolymorphic()) {
2574 mlir::Value isAlloc = fir::factory::genIsAllocatedOrAssociatedTest(
2575 builder, loc, mutableBox);
2576 builder.genIfThen(loc, isAlloc)
2577 .genThen([&]() {
2578 Fortran::lower::genDeallocateBox(converter, mutableBox, loc);
2579 })
2580 .end();
2581 } else {
2582 Fortran::lower::genDeallocateBox(converter, mutableBox, loc);
2583 }
2584 }
2585 continue;
2586 }
2587 if (arg.passBy == PassBy::BaseAddress || arg.passBy == PassBy::BoxChar ||
2588 arg.passBy == PassBy::BaseAddressValueAttribute ||
2589 arg.passBy == PassBy::CharBoxValueAttribute) {
2590 const bool byValue = arg.passBy == PassBy::BaseAddressValueAttribute ||
2591 arg.passBy == PassBy::CharBoxValueAttribute;
2592 ExtValue argAddr =
2593 prepareActualToBaseAddressLike(*expr, arg, copyOutPairs, byValue)
2594 .first;
2595 if (arg.passBy == PassBy::BaseAddress ||
2596 arg.passBy == PassBy::BaseAddressValueAttribute) {
2597 caller.placeInput(arg, fir::getBase(argAddr));
2598 } else {
2599 assert(arg.passBy == PassBy::BoxChar ||(static_cast <bool> (arg.passBy == PassBy::BoxChar || arg
.passBy == PassBy::CharBoxValueAttribute) ? void (0) : __assert_fail
("arg.passBy == PassBy::BoxChar || arg.passBy == PassBy::CharBoxValueAttribute"
, "flang/lib/Lower/ConvertExpr.cpp", 2600, __extension__ __PRETTY_FUNCTION__
))
2600 arg.passBy == PassBy::CharBoxValueAttribute)(static_cast <bool> (arg.passBy == PassBy::BoxChar || arg
.passBy == PassBy::CharBoxValueAttribute) ? void (0) : __assert_fail
("arg.passBy == PassBy::BoxChar || arg.passBy == PassBy::CharBoxValueAttribute"
, "flang/lib/Lower/ConvertExpr.cpp", 2600, __extension__ __PRETTY_FUNCTION__
))
;
2601 auto helper = fir::factory::CharacterExprHelper{builder, loc};
2602 auto boxChar = argAddr.match(
2603 [&](const fir::CharBoxValue &x) -> mlir::Value {
2604 // If a character procedure was passed instead, handle the
2605 // mismatch.
2606 auto funcTy =
2607 x.getAddr().getType().dyn_cast<mlir::FunctionType>();
2608 if (funcTy && funcTy.getNumResults() == 1 &&
2609 funcTy.getResult(0).isa<fir::BoxCharType>()) {
2610 auto boxTy = funcTy.getResult(0).cast<fir::BoxCharType>();
2611 mlir::Value ref = builder.createConvert(
2612 loc, builder.getRefType(boxTy.getEleTy()), x.getAddr());
2613 auto len = builder.create<fir::UndefOp>(
2614 loc, builder.getCharacterLengthType());
2615 return builder.create<fir::EmboxCharOp>(loc, boxTy, ref, len);
2616 }
2617 return helper.createEmbox(x);
2618 },
2619 [&](const fir::CharArrayBoxValue &x) {
2620 return helper.createEmbox(x);
2621 },
2622 [&](const auto &x) -> mlir::Value {
2623 // Fortran allows an actual argument of a completely different
2624 // type to be passed to a procedure expecting a CHARACTER in the
2625 // dummy argument position. When this happens, the data pointer
2626 // argument is simply assumed to point to CHARACTER data and the
2627 // LEN argument used is garbage. Simulate this behavior by
2628 // free-casting the base address to be a !fir.char reference and
2629 // setting the LEN argument to undefined. What could go wrong?
2630 auto dataPtr = fir::getBase(x);
2631 assert(!dataPtr.getType().template isa<fir::BoxType>())(static_cast <bool> (!dataPtr.getType().template isa<
fir::BoxType>()) ? void (0) : __assert_fail ("!dataPtr.getType().template isa<fir::BoxType>()"
, "flang/lib/Lower/ConvertExpr.cpp", 2631, __extension__ __PRETTY_FUNCTION__
))
;
2632 return builder.convertWithSemantics(
2633 loc, argTy, dataPtr,
2634 /*allowCharacterConversion=*/true);
2635 });
2636 caller.placeInput(arg, boxChar);
2637 }
2638 } else if (arg.passBy == PassBy::Box) {
2639 if (arg.mustBeMadeContiguous() &&
2640 !Fortran::evaluate::IsSimplyContiguous(
2641 *expr, converter.getFoldingContext())) {
2642 // If the expression is a PDT, or a polymorphic entity, or an assumed
2643 // rank, it cannot currently be safely handled by
2644 // prepareActualToBaseAddressLike that is intended to prepare
2645 // arguments that can be passed as simple base address.
2646 if (auto dynamicType = expr->GetType())
2647 if (dynamicType->IsPolymorphic())
2648 TODO(loc, "passing a polymorphic entity to an OPTIONAL "do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "2649" ": not yet implemented: ") + llvm::Twine("passing a polymorphic entity to an OPTIONAL "
"CONTIGUOUS argument"), false); } while (false)
2649 "CONTIGUOUS argument")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "2649" ": not yet implemented: ") + llvm::Twine("passing a polymorphic entity to an OPTIONAL "
"CONTIGUOUS argument"), false); } while (false)
;
2650 if (fir::isRecordWithTypeParameters(
2651 fir::unwrapSequenceType(fir::unwrapPassByRefType(argTy))))
2652 TODO(loc, "passing to an OPTIONAL CONTIGUOUS derived type argument "do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "2653" ": not yet implemented: ") + llvm::Twine("passing to an OPTIONAL CONTIGUOUS derived type argument "
"with length parameters"), false); } while (false)
2653 "with length parameters")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "2653" ": not yet implemented: ") + llvm::Twine("passing to an OPTIONAL CONTIGUOUS derived type argument "
"with length parameters"), false); } while (false)
;
2654 if (Fortran::evaluate::IsAssumedRank(*expr))
2655 TODO(loc, "passing an assumed rank entity to an OPTIONAL "do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "2656" ": not yet implemented: ") + llvm::Twine("passing an assumed rank entity to an OPTIONAL "
"CONTIGUOUS argument"), false); } while (false)
2656 "CONTIGUOUS argument")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "2656" ": not yet implemented: ") + llvm::Twine("passing an assumed rank entity to an OPTIONAL "
"CONTIGUOUS argument"), false); } while (false)
;
2657 // Assumed shape VALUE are currently TODO in the call interface
2658 // lowering.
2659 const bool byValue = false;
2660 auto [argAddr, isPresentValue] =
2661 prepareActualToBaseAddressLike(*expr, arg, copyOutPairs, byValue);
2662 mlir::Value box = builder.createBox(loc, argAddr);
2663 if (isPresentValue) {
2664 mlir::Value convertedBox = builder.createConvert(loc, argTy, box);
2665 auto absent = builder.create<fir::AbsentOp>(loc, argTy);
2666 caller.placeInput(arg,
2667 builder.create<mlir::arith::SelectOp>(
2668 loc, *isPresentValue, convertedBox, absent));
2669 } else {
2670 caller.placeInput(arg, builder.createBox(loc, argAddr));
2671 }
2672
2673 } else if (arg.isOptional() &&
2674 Fortran::evaluate::IsAllocatableOrPointerObject(
2675 *expr, converter.getFoldingContext())) {
2676 // Before lowering to an address, handle the allocatable/pointer
2677 // actual argument to optional fir.box dummy. It is legal to pass
2678 // unallocated/disassociated entity to an optional. In this case, an
2679 // absent fir.box must be created instead of a fir.box with a null
2680 // value (Fortran 2018 15.5.2.12 point 1).
2681 //
2682 // Note that passing an absent allocatable to a non-allocatable
2683 // optional dummy argument is illegal (15.5.2.12 point 3 (8)). So
2684 // nothing has to be done to generate an absent argument in this case,
2685 // and it is OK to unconditionally read the mutable box here.
2686 fir::MutableBoxValue mutableBox = genMutableBoxValue(*expr);
2687 mlir::Value isAllocated =
2688 fir::factory::genIsAllocatedOrAssociatedTest(builder, loc,
2689 mutableBox);
2690 auto absent = builder.create<fir::AbsentOp>(loc, argTy);
2691 /// For now, assume it is not OK to pass the allocatable/pointer
2692 /// descriptor to a non pointer/allocatable dummy. That is a strict
2693 /// interpretation of 18.3.6 point 4 that stipulates the descriptor
2694 /// has the dummy attributes in BIND(C) contexts.
2695 mlir::Value box = builder.createBox(
2696 loc, fir::factory::genMutableBoxRead(builder, loc, mutableBox));
2697
2698 // NULL() passed as argument is passed as a !fir.box<none>. Since
2699 // select op requires the same type for its two argument, convert
2700 // !fir.box<none> to !fir.class<none> when the argument is
2701 // polymorphic.
2702 if (fir::isBoxNone(box.getType()) && fir::isPolymorphicType(argTy)) {
2703 box = builder.createConvert(
2704 loc,
2705 fir::ClassType::get(mlir::NoneType::get(builder.getContext())),
2706 box);
2707 } else if (box.getType().isa<fir::BoxType>() &&
2708 fir::isPolymorphicType(argTy)) {
2709 box = builder.create<fir::ReboxOp>(loc, argTy, box, mlir::Value{},
2710 /*slice=*/mlir::Value{});
2711 }
2712
2713 // Need the box types to be exactly similar for the selectOp.
2714 mlir::Value convertedBox = builder.createConvert(loc, argTy, box);
2715 caller.placeInput(arg, builder.create<mlir::arith::SelectOp>(
2716 loc, isAllocated, convertedBox, absent));
2717 } else {
2718 auto dynamicType = expr->GetType();
2719 mlir::Value box;
2720
2721 // Special case when an intrinsic scalar variable is passed to a
2722 // function expecting an optional unlimited polymorphic dummy
2723 // argument.
2724 // The presence test needs to be performed before emboxing otherwise
2725 // the program will crash.
2726 if (dynamicType->category() !=
2727 Fortran::common::TypeCategory::Derived &&
2728 expr->Rank() == 0 && fir::isUnlimitedPolymorphicType(argTy) &&
2729 arg.isOptional()) {
2730 ExtValue opt = lowerIntrinsicArgumentAsInquired(*expr);
2731 mlir::Value isPresent = genActualIsPresentTest(builder, loc, opt);
2732 box =
2733 builder
2734 .genIfOp(loc, {argTy}, isPresent, /*withElseRegion=*/true)
2735 .genThen([&]() {
2736 auto boxed = builder.createBox(
2737 loc, genBoxArg(*expr), fir::isPolymorphicType(argTy));
2738 builder.create<fir::ResultOp>(loc, boxed);
2739 })
2740 .genElse([&]() {
2741 auto absent =
2742 builder.create<fir::AbsentOp>(loc, argTy).getResult();
2743 builder.create<fir::ResultOp>(loc, absent);
2744 })
2745 .getResults()[0];
2746 } else {
2747 // Make sure a variable address is only passed if the expression is
2748 // actually a variable.
2749 box = Fortran::evaluate::IsVariable(*expr)
2750 ? builder.createBox(loc, genBoxArg(*expr),
2751 fir::isPolymorphicType(argTy),
2752 fir::isAssumedType(argTy))
2753 : builder.createBox(getLoc(), genTempExtAddr(*expr),
2754 fir::isPolymorphicType(argTy),
2755 fir::isAssumedType(argTy));
2756 if (box.getType().isa<fir::BoxType>() &&
2757 fir::isPolymorphicType(argTy) && !fir::isAssumedType(argTy)) {
2758 mlir::Type actualTy = argTy;
2759 if (Fortran::lower::isParentComponent(*expr))
2760 actualTy = fir::BoxType::get(converter.genType(*expr));
2761 // Rebox can only be performed on a present argument.
2762 if (arg.isOptional()) {
2763 mlir::Value isPresent =
2764 genActualIsPresentTest(builder, loc, box);
2765 box = builder
2766 .genIfOp(loc, {actualTy}, isPresent,
2767 /*withElseRegion=*/true)
2768 .genThen([&]() {
2769 auto rebox =
2770 builder
2771 .create<fir::ReboxOp>(
2772 loc, actualTy, box, mlir::Value{},
2773 /*slice=*/mlir::Value{})
2774 .getResult();
2775 builder.create<fir::ResultOp>(loc, rebox);
2776 })
2777 .genElse([&]() {
2778 auto absent =
2779 builder.create<fir::AbsentOp>(loc, actualTy)
2780 .getResult();
2781 builder.create<fir::ResultOp>(loc, absent);
2782 })
2783 .getResults()[0];
2784 } else {
2785 box = builder.create<fir::ReboxOp>(loc, actualTy, box,
2786 mlir::Value{},
2787 /*slice=*/mlir::Value{});
2788 }
2789 } else if (Fortran::lower::isParentComponent(*expr)) {
2790 fir::ExtendedValue newExv =
2791 Fortran::lower::updateBoxForParentComponent(converter, box,
2792 *expr);
2793 box = fir::getBase(newExv);
2794 }
2795 }
2796 caller.placeInput(arg, box);
2797 }
2798 } else if (arg.passBy == PassBy::AddressAndLength) {
2799 ExtValue argRef = genExtAddr(*expr);
2800 caller.placeAddressAndLengthInput(arg, fir::getBase(argRef),
2801 fir::getLen(argRef));
2802 } else if (arg.passBy == PassBy::CharProcTuple) {
2803 ExtValue argRef = genExtAddr(*expr);
2804 mlir::Value tuple = createBoxProcCharTuple(
2805 converter, argTy, fir::getBase(argRef), fir::getLen(argRef));
2806 caller.placeInput(arg, tuple);
2807 } else {
2808 TODO(loc, "pass by value in non elemental function call")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "2808" ": not yet implemented: ") + llvm::Twine("pass by value in non elemental function call"
), false); } while (false)
;
2809 }
2810 }
2811
2812 ExtValue result = Fortran::lower::genCallOpAndResult(
2813 loc, converter, symMap, stmtCtx, caller, callSiteType, resultType);
2814
2815 // Sync pointers and allocatables that may have been modified during the
2816 // call.
2817 for (const auto &mutableBox : mutableModifiedByCall)
2818 fir::factory::syncMutableBoxFromIRBox(builder, loc, mutableBox);
2819 // Handle case where result was passed as argument
2820
2821 // Copy-out temps that were created for non contiguous variable arguments if
2822 // needed.
2823 for (const auto &copyOutPair : copyOutPairs)
2824 genCopyOut(copyOutPair);
2825
2826 return result;
2827 }
2828
2829 template <typename A>
2830 ExtValue genval(const Fortran::evaluate::FunctionRef<A> &funcRef) {
2831 ExtValue result = genFunctionRef(funcRef);
2832 if (result.rank() == 0 && fir::isa_ref_type(fir::getBase(result).getType()))
2833 return genLoad(result);
2834 return result;
2835 }
2836
2837 ExtValue genval(const Fortran::evaluate::ProcedureRef &procRef) {
2838 std::optional<mlir::Type> resTy;
2839 if (procRef.hasAlternateReturns())
2840 resTy = builder.getIndexType();
2841 return genProcedureRef(procRef, resTy);
2842 }
2843
2844 template <typename A>
2845 bool isScalar(const A &x) {
2846 return x.Rank() == 0;
2847 }
2848
2849 /// Helper to detect Transformational function reference.
2850 template <typename T>
2851 bool isTransformationalRef(const T &) {
2852 return false;
2853 }
2854 template <typename T>
2855 bool isTransformationalRef(const Fortran::evaluate::FunctionRef<T> &funcRef) {
2856 return !funcRef.IsElemental() && funcRef.Rank();
2857 }
2858 template <typename T>
2859 bool isTransformationalRef(Fortran::evaluate::Expr<T> expr) {
2860 return std::visit([&](const auto &e) { return isTransformationalRef(e); },
2861 expr.u);
2862 }
2863
2864 template <typename A>
2865 ExtValue asArray(const A &x) {
2866 return Fortran::lower::createSomeArrayTempValue(converter, toEvExpr(x),
2867 symMap, stmtCtx);
2868 }
2869
2870 /// Lower an array value as an argument. This argument can be passed as a box
2871 /// value, so it may be possible to avoid making a temporary.
2872 template <typename A>
2873 ExtValue asArrayArg(const Fortran::evaluate::Expr<A> &x) {
2874 return std::visit([&](const auto &e) { return asArrayArg(e, x); }, x.u);
2875 }
2876 template <typename A, typename B>
2877 ExtValue asArrayArg(const Fortran::evaluate::Expr<A> &x, const B &y) {
2878 return std::visit([&](const auto &e) { return asArrayArg(e, y); }, x.u);
2879 }
2880 template <typename A, typename B>
2881 ExtValue asArrayArg(const Fortran::evaluate::Designator<A> &, const B &x) {
2882 // Designator is being passed as an argument to a procedure. Lower the
2883 // expression to a boxed value.
2884 auto someExpr = toEvExpr(x);
2885 return Fortran::lower::createBoxValue(getLoc(), converter, someExpr, symMap,
2886 stmtCtx);
2887 }
2888 template <typename A, typename B>
2889 ExtValue asArrayArg(const A &, const B &x) {
2890 // If the expression to pass as an argument is not a designator, then create
2891 // an array temp.
2892 return asArray(x);
2893 }
2894
2895 template <typename A>
2896 ExtValue gen(const Fortran::evaluate::Expr<A> &x) {
2897 // Whole array symbols or components, and results of transformational
2898 // functions already have a storage and the scalar expression lowering path
2899 // is used to not create a new temporary storage.
2900 if (isScalar(x) ||
2901 Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(x) ||
2902 (isTransformationalRef(x) && !isOptimizableTranspose(x, converter)))
2903 return std::visit([&](const auto &e) { return genref(e); }, x.u);
2904 if (useBoxArg)
2905 return asArrayArg(x);
2906 return asArray(x);
2907 }
2908 template <typename A>
2909 ExtValue genval(const Fortran::evaluate::Expr<A> &x) {
2910 if (isScalar(x) || Fortran::evaluate::UnwrapWholeSymbolDataRef(x) ||
2911 inInitializer)
2912 return std::visit([&](const auto &e) { return genval(e); }, x.u);
2913 return asArray(x);
2914 }
2915
2916 template <int KIND>
2917 ExtValue genval(const Fortran::evaluate::Expr<Fortran::evaluate::Type<
2918 Fortran::common::TypeCategory::Logical, KIND>> &exp) {
2919 return std::visit([&](const auto &e) { return genval(e); }, exp.u);
2920 }
2921
2922 using RefSet =
2923 std::tuple<Fortran::evaluate::ComplexPart, Fortran::evaluate::Substring,
2924 Fortran::evaluate::DataRef, Fortran::evaluate::Component,
2925 Fortran::evaluate::ArrayRef, Fortran::evaluate::CoarrayRef,
2926 Fortran::semantics::SymbolRef>;
2927 template <typename A>
2928 static constexpr bool inRefSet = Fortran::common::HasMember<A, RefSet>;
2929
2930 template <typename A, typename = std::enable_if_t<inRefSet<A>>>
2931 ExtValue genref(const A &a) {
2932 return gen(a);
2933 }
2934 template <typename A>
2935 ExtValue genref(const A &a) {
2936 if (inInitializer) {
2937 // Initialization expressions can never allocate memory.
2938 return genval(a);
2939 }
2940 mlir::Type storageType = converter.genType(toEvExpr(a));
2941 return placeScalarValueInMemory(builder, getLoc(), genval(a), storageType);
2942 }
2943
2944 template <typename A, template <typename> typename T,
2945 typename B = std::decay_t<T<A>>,
2946 std::enable_if_t<
2947 std::is_same_v<B, Fortran::evaluate::Expr<A>> ||
2948 std::is_same_v<B, Fortran::evaluate::Designator<A>> ||
2949 std::is_same_v<B, Fortran::evaluate::FunctionRef<A>>,
2950 bool> = true>
2951 ExtValue genref(const T<A> &x) {
2952 return gen(x);
2953 }
2954
2955private:
2956 mlir::Location location;
2957 Fortran::lower::AbstractConverter &converter;
2958 fir::FirOpBuilder &builder;
2959 Fortran::lower::StatementContext &stmtCtx;
2960 Fortran::lower::SymMap &symMap;
2961 bool inInitializer = false;
2962 bool useBoxArg = false; // expression lowered as argument
2963};
2964} // namespace
2965
2966// Helper for changing the semantics in a given context. Preserves the current
2967// semantics which is resumed when the "push" goes out of scope.
2968#define PushSemantics(PushVal)[[maybe_unused]] auto pushSemanticsLocalVariable__LINE__ = Fortran
::common::ScopedSet(semant, PushVal);
\
2969 [[maybe_unused]] auto pushSemanticsLocalVariable##__LINE__2969 = \
2970 Fortran::common::ScopedSet(semant, PushVal);
2971
2972static bool isAdjustedArrayElementType(mlir::Type t) {
2973 return fir::isa_char(t) || fir::isa_derived(t) || t.isa<fir::SequenceType>();
2974}
2975static bool elementTypeWasAdjusted(mlir::Type t) {
2976 if (auto ty = t.dyn_cast<fir::ReferenceType>())
2977 return isAdjustedArrayElementType(ty.getEleTy());
2978 return false;
2979}
2980static mlir::Type adjustedArrayElementType(mlir::Type t) {
2981 return isAdjustedArrayElementType(t) ? fir::ReferenceType::get(t) : t;
2982}
2983
2984/// Helper to generate calls to scalar user defined assignment procedures.
2985static void genScalarUserDefinedAssignmentCall(fir::FirOpBuilder &builder,
2986 mlir::Location loc,
2987 mlir::func::FuncOp func,
2988 const fir::ExtendedValue &lhs,
2989 const fir::ExtendedValue &rhs) {
2990 auto prepareUserDefinedArg =
2991 [](fir::FirOpBuilder &builder, mlir::Location loc,
2992 const fir::ExtendedValue &value, mlir::Type argType) -> mlir::Value {
2993 if (argType.isa<fir::BoxCharType>()) {
2994 const fir::CharBoxValue *charBox = value.getCharBox();
2995 assert(charBox && "argument type mismatch in elemental user assignment")(static_cast <bool> (charBox && "argument type mismatch in elemental user assignment"
) ? void (0) : __assert_fail ("charBox && \"argument type mismatch in elemental user assignment\""
, "flang/lib/Lower/ConvertExpr.cpp", 2995, __extension__ __PRETTY_FUNCTION__
))
;
2996 return fir::factory::CharacterExprHelper{builder, loc}.createEmbox(
2997 *charBox);
2998 }
2999 if (argType.isa<fir::BaseBoxType>()) {
3000 mlir::Value box =
3001 builder.createBox(loc, value, argType.isa<fir::ClassType>());
3002 return builder.createConvert(loc, argType, box);
3003 }
3004 // Simple pass by address.
3005 mlir::Type argBaseType = fir::unwrapRefType(argType);
3006 assert(!fir::hasDynamicSize(argBaseType))(static_cast <bool> (!fir::hasDynamicSize(argBaseType))
? void (0) : __assert_fail ("!fir::hasDynamicSize(argBaseType)"
, "flang/lib/Lower/ConvertExpr.cpp", 3006, __extension__ __PRETTY_FUNCTION__
))
;
3007 mlir::Value from = fir::getBase(value);
3008 if (argBaseType != fir::unwrapRefType(from.getType())) {
3009 // With logicals, it is possible that from is i1 here.
3010 if (fir::isa_ref_type(from.getType()))
3011 from = builder.create<fir::LoadOp>(loc, from);
3012 from = builder.createConvert(loc, argBaseType, from);
3013 }
3014 if (!fir::isa_ref_type(from.getType())) {
3015 mlir::Value temp = builder.createTemporary(loc, argBaseType);
3016 builder.create<fir::StoreOp>(loc, from, temp);
3017 from = temp;
3018 }
3019 return builder.createConvert(loc, argType, from);
3020 };
3021 assert(func.getNumArguments() == 2)(static_cast <bool> (func.getNumArguments() == 2) ? void
(0) : __assert_fail ("func.getNumArguments() == 2", "flang/lib/Lower/ConvertExpr.cpp"
, 3021, __extension__ __PRETTY_FUNCTION__))
;
3022 mlir::Type lhsType = func.getFunctionType().getInput(0);
3023 mlir::Type rhsType = func.getFunctionType().getInput(1);
3024 mlir::Value lhsArg = prepareUserDefinedArg(builder, loc, lhs, lhsType);
3025 mlir::Value rhsArg = prepareUserDefinedArg(builder, loc, rhs, rhsType);
3026 builder.create<fir::CallOp>(loc, func, mlir::ValueRange{lhsArg, rhsArg});
3027}
3028
3029/// Convert the result of a fir.array_modify to an ExtendedValue given the
3030/// related fir.array_load.
3031static fir::ExtendedValue arrayModifyToExv(fir::FirOpBuilder &builder,
3032 mlir::Location loc,
3033 fir::ArrayLoadOp load,
3034 mlir::Value elementAddr) {
3035 mlir::Type eleTy = fir::unwrapPassByRefType(elementAddr.getType());
3036 if (fir::isa_char(eleTy)) {
3037 auto len = fir::factory::CharacterExprHelper{builder, loc}.getLength(
3038 load.getMemref());
3039 if (!len) {
3040 assert(load.getTypeparams().size() == 1 &&(static_cast <bool> (load.getTypeparams().size() == 1 &&
"length must be in array_load") ? void (0) : __assert_fail (
"load.getTypeparams().size() == 1 && \"length must be in array_load\""
, "flang/lib/Lower/ConvertExpr.cpp", 3041, __extension__ __PRETTY_FUNCTION__
))
3041 "length must be in array_load")(static_cast <bool> (load.getTypeparams().size() == 1 &&
"length must be in array_load") ? void (0) : __assert_fail (
"load.getTypeparams().size() == 1 && \"length must be in array_load\""
, "flang/lib/Lower/ConvertExpr.cpp", 3041, __extension__ __PRETTY_FUNCTION__
))
;
3042 len = load.getTypeparams()[0];
3043 }
3044 return fir::CharBoxValue{elementAddr, len};
3045 }
3046 return elementAddr;
3047}
3048
3049//===----------------------------------------------------------------------===//
3050//
3051// Lowering of scalar expressions in an explicit iteration space context.
3052//
3053//===----------------------------------------------------------------------===//
3054
3055// Shared code for creating a copy of a derived type element. This function is
3056// called from a continuation.
3057inline static fir::ArrayAmendOp
3058createDerivedArrayAmend(mlir::Location loc, fir::ArrayLoadOp destLoad,
3059 fir::FirOpBuilder &builder, fir::ArrayAccessOp destAcc,
3060 const fir::ExtendedValue &elementExv, mlir::Type eleTy,
3061 mlir::Value innerArg) {
3062 if (destLoad.getTypeparams().empty()) {
3063 fir::factory::genRecordAssignment(builder, loc, destAcc, elementExv);
3064 } else {
3065 auto boxTy = fir::BoxType::get(eleTy);
3066 auto toBox = builder.create<fir::EmboxOp>(loc, boxTy, destAcc.getResult(),
3067 mlir::Value{}, mlir::Value{},
3068 destLoad.getTypeparams());
3069 auto fromBox = builder.create<fir::EmboxOp>(
3070 loc, boxTy, fir::getBase(elementExv), mlir::Value{}, mlir::Value{},
3071 destLoad.getTypeparams());
3072 fir::factory::genRecordAssignment(builder, loc, fir::BoxValue(toBox),
3073 fir::BoxValue(fromBox));
3074 }
3075 return builder.create<fir::ArrayAmendOp>(loc, innerArg.getType(), innerArg,
3076 destAcc);
3077}
3078
3079inline static fir::ArrayAmendOp
3080createCharArrayAmend(mlir::Location loc, fir::FirOpBuilder &builder,
3081 fir::ArrayAccessOp dstOp, mlir::Value &dstLen,
3082 const fir::ExtendedValue &srcExv, mlir::Value innerArg,
3083 llvm::ArrayRef<mlir::Value> bounds) {
3084 fir::CharBoxValue dstChar(dstOp, dstLen);
3085 fir::factory::CharacterExprHelper helper{builder, loc};
3086 if (!bounds.empty()) {
3087 dstChar = helper.createSubstring(dstChar, bounds);
3088 fir::factory::genCharacterCopy(fir::getBase(srcExv), fir::getLen(srcExv),
3089 dstChar.getAddr(), dstChar.getLen(), builder,
3090 loc);
3091 // Update the LEN to the substring's LEN.
3092 dstLen = dstChar.getLen();
3093 }
3094 // For a CHARACTER, we generate the element assignment loops inline.
3095 helper.createAssign(fir::ExtendedValue{dstChar}, srcExv);
3096 // Mark this array element as amended.
3097 mlir::Type ty = innerArg.getType();
3098 auto amend = builder.create<fir::ArrayAmendOp>(loc, ty, innerArg, dstOp);
3099 return amend;
3100}
3101
3102/// Build an ExtendedValue from a fir.array<?x...?xT> without actually setting
3103/// the actual extents and lengths. This is only to allow their propagation as
3104/// ExtendedValue without triggering verifier failures when propagating
3105/// character/arrays as unboxed values. Only the base of the resulting
3106/// ExtendedValue should be used, it is undefined to use the length or extents
3107/// of the extended value returned,
3108inline static fir::ExtendedValue
3109convertToArrayBoxValue(mlir::Location loc, fir::FirOpBuilder &builder,
3110 mlir::Value val, mlir::Value len) {
3111 mlir::Type ty = fir::unwrapRefType(val.getType());
3112 mlir::IndexType idxTy = builder.getIndexType();
3113 auto seqTy = ty.cast<fir::SequenceType>();
3114 auto undef = builder.create<fir::UndefOp>(loc, idxTy);
3115 llvm::SmallVector<mlir::Value> extents(seqTy.getDimension(), undef);
3116 if (fir::isa_char(seqTy.getEleTy()))
3117 return fir::CharArrayBoxValue(val, len ? len : undef, extents);
3118 return fir::ArrayBoxValue(val, extents);
3119}
3120
3121//===----------------------------------------------------------------------===//
3122//
3123// Lowering of array expressions.
3124//
3125//===----------------------------------------------------------------------===//
3126
3127namespace {
3128class ArrayExprLowering {
3129 using ExtValue = fir::ExtendedValue;
3130
3131 /// Structure to keep track of lowered array operands in the
3132 /// array expression. Useful to later deduce the shape of the
3133 /// array expression.
3134 struct ArrayOperand {
3135 /// Array base (can be a fir.box).
3136 mlir::Value memref;
3137 /// ShapeOp, ShapeShiftOp or ShiftOp
3138 mlir::Value shape;
3139 /// SliceOp
3140 mlir::Value slice;
3141 /// Can this operand be absent ?
3142 bool mayBeAbsent = false;
3143 };
3144
3145 using ImplicitSubscripts = Fortran::lower::details::ImplicitSubscripts;
3146 using PathComponent = Fortran::lower::PathComponent;
3147
3148 /// Active iteration space.
3149 using IterationSpace = Fortran::lower::IterationSpace;
3150 using IterSpace = const Fortran::lower::IterationSpace &;
3151
3152 /// Current continuation. Function that will generate IR for a single
3153 /// iteration of the pending iterative loop structure.
3154 using CC = Fortran::lower::GenerateElementalArrayFunc;
3155
3156 /// Projection continuation. Function that will project one iteration space
3157 /// into another.
3158 using PC = std::function<IterationSpace(IterSpace)>;
3159 using ArrayBaseTy =
3160 std::variant<std::monostate, const Fortran::evaluate::ArrayRef *,
3161 const Fortran::evaluate::DataRef *>;
3162 using ComponentPath = Fortran::lower::ComponentPath;
3163
3164public:
3165 //===--------------------------------------------------------------------===//
3166 // Regular array assignment
3167 //===--------------------------------------------------------------------===//
3168
3169 /// Entry point for array assignments. Both the left-hand and right-hand sides
3170 /// can either be ExtendedValue or evaluate::Expr.
3171 template <typename TL, typename TR>
3172 static void lowerArrayAssignment(Fortran::lower::AbstractConverter &converter,
3173 Fortran::lower::SymMap &symMap,
3174 Fortran::lower::StatementContext &stmtCtx,
3175 const TL &lhs, const TR &rhs) {
3176 ArrayExprLowering ael(converter, stmtCtx, symMap,
3177 ConstituentSemantics::CopyInCopyOut);
3178 ael.lowerArrayAssignment(lhs, rhs);
3179 }
3180
3181 template <typename TL, typename TR>
3182 void lowerArrayAssignment(const TL &lhs, const TR &rhs) {
3183 mlir::Location loc = getLoc();
3184 /// Here the target subspace is not necessarily contiguous. The ArrayUpdate
3185 /// continuation is implicitly returned in `ccStoreToDest` and the ArrayLoad
3186 /// in `destination`.
3187 PushSemantics(ConstituentSemantics::ProjectedCopyInCopyOut)[[maybe_unused]] auto pushSemanticsLocalVariable__LINE__ = Fortran
::common::ScopedSet(semant, ConstituentSemantics::ProjectedCopyInCopyOut
);
;
3188 ccStoreToDest = genarr(lhs);
3189 determineShapeOfDest(lhs);
3190 semant = ConstituentSemantics::RefTransparent;
3191 ExtValue exv = lowerArrayExpression(rhs);
3192 if (explicitSpaceIsActive()) {
3193 explicitSpace->finalizeContext();
3194 builder.create<fir::ResultOp>(loc, fir::getBase(exv));
3195 } else {
3196 builder.create<fir::ArrayMergeStoreOp>(
3197 loc, destination, fir::getBase(exv), destination.getMemref(),
3198 destination.getSlice(), destination.getTypeparams());
3199 }
3200 }
3201
3202 //===--------------------------------------------------------------------===//
3203 // WHERE array assignment, FORALL assignment, and FORALL+WHERE array
3204 // assignment
3205 //===--------------------------------------------------------------------===//
3206
3207 /// Entry point for array assignment when the iteration space is explicitly
3208 /// defined (Fortran's FORALL) with or without masks, and/or the implied
3209 /// iteration space involves masks (Fortran's WHERE). Both contexts (explicit
3210 /// space and implicit space with masks) may be present.
3211 static void lowerAnyMaskedArrayAssignment(
3212 Fortran::lower::AbstractConverter &converter,
3213 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
3214 const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
3215 Fortran::lower::ExplicitIterSpace &explicitSpace,
3216 Fortran::lower::ImplicitIterSpace &implicitSpace) {
3217 if (explicitSpace.isActive() && lhs.Rank() == 0) {
3218 // Scalar assignment expression in a FORALL context.
3219 ArrayExprLowering ael(converter, stmtCtx, symMap,
3220 ConstituentSemantics::RefTransparent,
3221 &explicitSpace, &implicitSpace);
3222 ael.lowerScalarAssignment(lhs, rhs);
3223 return;
3224 }
3225 // Array assignment expression in a FORALL and/or WHERE context.
3226 ArrayExprLowering ael(converter, stmtCtx, symMap,
3227 ConstituentSemantics::CopyInCopyOut, &explicitSpace,
3228 &implicitSpace);
3229 ael.lowerArrayAssignment(lhs, rhs);
3230 }
3231
3232 //===--------------------------------------------------------------------===//
3233 // Array assignment to array of pointer box values.
3234 //===--------------------------------------------------------------------===//
3235
3236 /// Entry point for assignment to pointer in an array of pointers.
3237 static void lowerArrayOfPointerAssignment(
3238 Fortran::lower::AbstractConverter &converter,
3239 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
3240 const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
3241 Fortran::lower::ExplicitIterSpace &explicitSpace,
3242 Fortran::lower::ImplicitIterSpace &implicitSpace,
3243 const llvm::SmallVector<mlir::Value> &lbounds,
3244 std::optional<llvm::SmallVector<mlir::Value>> ubounds) {
3245 ArrayExprLowering ael(converter, stmtCtx, symMap,
3246 ConstituentSemantics::CopyInCopyOut, &explicitSpace,
3247 &implicitSpace);
3248 ael.lowerArrayOfPointerAssignment(lhs, rhs, lbounds, ubounds);
3249 }
3250
3251 /// Scalar pointer assignment in an explicit iteration space.
3252 ///
3253 /// Pointers may be bound to targets in a FORALL context. This is a scalar
3254 /// assignment in the sense there is never an implied iteration space, even if
3255 /// the pointer is to a target with non-zero rank. Since the pointer
3256 /// assignment must appear in a FORALL construct, correctness may require that
3257 /// the array of pointers follow copy-in/copy-out semantics. The pointer
3258 /// assignment may include a bounds-spec (lower bounds), a bounds-remapping
3259 /// (lower and upper bounds), or neither.
3260 void lowerArrayOfPointerAssignment(
3261 const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
3262 const llvm::SmallVector<mlir::Value> &lbounds,
3263 std::optional<llvm::SmallVector<mlir::Value>> ubounds) {
3264 setPointerAssignmentBounds(lbounds, ubounds);
3265 if (rhs.Rank() == 0 ||
3266 (Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(rhs) &&
3267 Fortran::evaluate::IsAllocatableOrPointerObject(
3268 rhs, converter.getFoldingContext()))) {
3269 lowerScalarAssignment(lhs, rhs);
3270 return;
3271 }
3272 TODO(getLoc(),do { fir::emitFatalError(getLoc(), llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "3273" ": not yet implemented: ") + llvm::Twine("auto boxing of a ranked expression on RHS for pointer assignment"
), false); } while (false)
3273 "auto boxing of a ranked expression on RHS for pointer assignment")do { fir::emitFatalError(getLoc(), llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "3273" ": not yet implemented: ") + llvm::Twine("auto boxing of a ranked expression on RHS for pointer assignment"
), false); } while (false)
;
3274 }
3275
3276 //===--------------------------------------------------------------------===//
3277 // Array assignment to allocatable array
3278 //===--------------------------------------------------------------------===//
3279
3280 /// Entry point for assignment to allocatable array.
3281 static void lowerAllocatableArrayAssignment(
3282 Fortran::lower::AbstractConverter &converter,
3283 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
3284 const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
3285 Fortran::lower::ExplicitIterSpace &explicitSpace,
3286 Fortran::lower::ImplicitIterSpace &implicitSpace) {
3287 ArrayExprLowering ael(converter, stmtCtx, symMap,
3288 ConstituentSemantics::CopyInCopyOut, &explicitSpace,
3289 &implicitSpace);
3290 ael.lowerAllocatableArrayAssignment(lhs, rhs);
3291 }
3292
3293 /// Lower an assignment to allocatable array, where the LHS array
3294 /// is represented with \p lhs extended value produced in different
3295 /// branches created in genReallocIfNeeded(). The RHS lowering
3296 /// is provided via \p rhsCC continuation.
3297 void lowerAllocatableArrayAssignment(ExtValue lhs, CC rhsCC) {
3298 mlir::Location loc = getLoc();
3299 // Check if the initial destShape is null, which means
3300 // it has not been computed from rhs (e.g. rhs is scalar).
3301 bool destShapeIsEmpty = destShape.empty();
3302 // Create ArrayLoad for the mutable box and save it into `destination`.
3303 PushSemantics(ConstituentSemantics::ProjectedCopyInCopyOut)[[maybe_unused]] auto pushSemanticsLocalVariable__LINE__ = Fortran
::common::ScopedSet(semant, ConstituentSemantics::ProjectedCopyInCopyOut
);
;
3304 ccStoreToDest = genarr(lhs);
3305 // destShape is either non-null on entry to this function,
3306 // or has been just set by lhs lowering.
3307 assert(!destShape.empty() && "destShape must have been set.")(static_cast <bool> (!destShape.empty() && "destShape must have been set."
) ? void (0) : __assert_fail ("!destShape.empty() && \"destShape must have been set.\""
, "flang/lib/Lower/ConvertExpr.cpp", 3307, __extension__ __PRETTY_FUNCTION__
))
;
3308 // Finish lowering the loop nest.
3309 assert(destination && "destination must have been set")(static_cast <bool> (destination && "destination must have been set"
) ? void (0) : __assert_fail ("destination && \"destination must have been set\""
, "flang/lib/Lower/ConvertExpr.cpp", 3309, __extension__ __PRETTY_FUNCTION__
))
;
3310 ExtValue exv = lowerArrayExpression(rhsCC, destination.getType());
3311 if (!explicitSpaceIsActive())
3312 builder.create<fir::ArrayMergeStoreOp>(
3313 loc, destination, fir::getBase(exv), destination.getMemref(),
3314 destination.getSlice(), destination.getTypeparams());
3315 // destShape may originally be null, if rhs did not define a shape.
3316 // In this case the destShape is computed from lhs, and we may have
3317 // multiple different lhs values for different branches created
3318 // in genReallocIfNeeded(). We cannot reuse destShape computed
3319 // in different branches, so we have to reset it,
3320 // so that it is recomputed for the next branch FIR generation.
3321 if (destShapeIsEmpty)
3322 destShape.clear();
3323 }
3324
3325 /// Assignment to allocatable array.
3326 ///
3327 /// The semantics are reverse that of a "regular" array assignment. The rhs
3328 /// defines the iteration space of the computation and the lhs is
3329 /// resized/reallocated to fit if necessary.
3330 void lowerAllocatableArrayAssignment(const Fortran::lower::SomeExpr &lhs,
3331 const Fortran::lower::SomeExpr &rhs) {
3332 // With assignment to allocatable, we want to lower the rhs first and use
3333 // its shape to determine if we need to reallocate, etc.
3334 mlir::Location loc = getLoc();
3335 // FIXME: If the lhs is in an explicit iteration space, the assignment may
3336 // be to an array of allocatable arrays rather than a single allocatable
3337 // array.
3338 if (explicitSpaceIsActive() && lhs.Rank() > 0)
3339 TODO(loc, "assignment to whole allocatable array inside FORALL")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "3339" ": not yet implemented: ") + llvm::Twine("assignment to whole allocatable array inside FORALL"
), false); } while (false)
;
3340
3341 fir::MutableBoxValue mutableBox =
3342 Fortran::lower::createMutableBox(loc, converter, lhs, symMap);
3343 if (rhs.Rank() > 0)
3344 determineShapeOfDest(rhs);
3345 auto rhsCC = [&]() {
3346 PushSemantics(ConstituentSemantics::RefTransparent)[[maybe_unused]] auto pushSemanticsLocalVariable__LINE__ = Fortran
::common::ScopedSet(semant, ConstituentSemantics::RefTransparent
);
;
3347 return genarr(rhs);
3348 }();
3349
3350 llvm::SmallVector<mlir::Value> lengthParams;
3351 // Currently no safe way to gather length from rhs (at least for
3352 // character, it cannot be taken from array_loads since it may be
3353 // changed by concatenations).
3354 if ((mutableBox.isCharacter() && !mutableBox.hasNonDeferredLenParams()) ||
3355 mutableBox.isDerivedWithLenParameters())
3356 TODO(loc, "gather rhs LEN parameters in assignment to allocatable")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "3356" ": not yet implemented: ") + llvm::Twine("gather rhs LEN parameters in assignment to allocatable"
), false); } while (false)
;
3357
3358 // The allocatable must take lower bounds from the expr if it is
3359 // reallocated and the right hand side is not a scalar.
3360 const bool takeLboundsIfRealloc = rhs.Rank() > 0;
3361 llvm::SmallVector<mlir::Value> lbounds;
3362 // When the reallocated LHS takes its lower bounds from the RHS,
3363 // they will be non default only if the RHS is a whole array
3364 // variable. Otherwise, lbounds is left empty and default lower bounds
3365 // will be used.
3366 if (takeLboundsIfRealloc &&
3367 Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(rhs)) {
3368 assert(arrayOperands.size() == 1 &&(static_cast <bool> (arrayOperands.size() == 1 &&
"lbounds can only come from one array") ? void (0) : __assert_fail
("arrayOperands.size() == 1 && \"lbounds can only come from one array\""
, "flang/lib/Lower/ConvertExpr.cpp", 3369, __extension__ __PRETTY_FUNCTION__
))
3369 "lbounds can only come from one array")(static_cast <bool> (arrayOperands.size() == 1 &&
"lbounds can only come from one array") ? void (0) : __assert_fail
("arrayOperands.size() == 1 && \"lbounds can only come from one array\""
, "flang/lib/Lower/ConvertExpr.cpp", 3369, __extension__ __PRETTY_FUNCTION__
))
;
3370 auto lbs = fir::factory::getOrigins(arrayOperands[0].shape);
3371 lbounds.append(lbs.begin(), lbs.end());
3372 }
3373 auto assignToStorage = [&](fir::ExtendedValue newLhs) {
3374 // The lambda will be called repeatedly by genReallocIfNeeded().
3375 lowerAllocatableArrayAssignment(newLhs, rhsCC);
3376 };
3377 fir::factory::MutableBoxReallocation realloc =
3378 fir::factory::genReallocIfNeeded(builder, loc, mutableBox, destShape,
3379 lengthParams, assignToStorage);
3380 if (explicitSpaceIsActive()) {
3381 explicitSpace->finalizeContext();
3382 builder.create<fir::ResultOp>(loc, fir::getBase(realloc.newValue));
3383 }
3384 fir::factory::finalizeRealloc(builder, loc, mutableBox, lbounds,
3385 takeLboundsIfRealloc, realloc);
3386 }
3387
3388 /// Entry point for when an array expression appears in a context where the
3389 /// result must be boxed. (BoxValue semantics.)
3390 static ExtValue
3391 lowerBoxedArrayExpression(Fortran::lower::AbstractConverter &converter,
3392 Fortran::lower::SymMap &symMap,
3393 Fortran::lower::StatementContext &stmtCtx,
3394 const Fortran::lower::SomeExpr &expr) {
3395 ArrayExprLowering ael{converter, stmtCtx, symMap,
3396 ConstituentSemantics::BoxValue};
3397 return ael.lowerBoxedArrayExpr(expr);
3398 }
3399
3400 ExtValue lowerBoxedArrayExpr(const Fortran::lower::SomeExpr &exp) {
3401 PushSemantics(ConstituentSemantics::BoxValue)[[maybe_unused]] auto pushSemanticsLocalVariable__LINE__ = Fortran
::common::ScopedSet(semant, ConstituentSemantics::BoxValue);
;
3402 return std::visit(
3403 [&](const auto &e) {
3404 auto f = genarr(e);
3405 ExtValue exv = f(IterationSpace{});
3406 if (fir::getBase(exv).getType().template isa<fir::BaseBoxType>())
3407 return exv;
3408 fir::emitFatalError(getLoc(), "array must be emboxed");
3409 },
3410 exp.u);
3411 }
3412
3413 /// Entry point into lowering an expression with rank. This entry point is for
3414 /// lowering a rhs expression, for example. (RefTransparent semantics.)
3415 static ExtValue
3416 lowerNewArrayExpression(Fortran::lower::AbstractConverter &converter,
3417 Fortran::lower::SymMap &symMap,
3418 Fortran::lower::StatementContext &stmtCtx,
3419 const Fortran::lower::SomeExpr &expr) {
3420 ArrayExprLowering ael{converter, stmtCtx, symMap};
3421 ael.determineShapeOfDest(expr);
3422 ExtValue loopRes = ael.lowerArrayExpression(expr);
3423 fir::ArrayLoadOp dest = ael.destination;
3424 mlir::Value tempRes = dest.getMemref();
3425 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
3426 mlir::Location loc = converter.getCurrentLocation();
3427 builder.create<fir::ArrayMergeStoreOp>(loc, dest, fir::getBase(loopRes),
3428 tempRes, dest.getSlice(),
3429 dest.getTypeparams());
3430
3431 auto arrTy =
3432 fir::dyn_cast_ptrEleTy(tempRes.getType()).cast<fir::SequenceType>();
3433 if (auto charTy =
3434 arrTy.getEleTy().template dyn_cast<fir::CharacterType>()) {
3435 if (fir::characterWithDynamicLen(charTy))
3436 TODO(loc, "CHARACTER does not have constant LEN")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "3436" ": not yet implemented: ") + llvm::Twine("CHARACTER does not have constant LEN"
), false); } while (false)
;
3437 mlir::Value len = builder.createIntegerConstant(
3438 loc, builder.getCharacterLengthType(), charTy.getLen());
3439 return fir::CharArrayBoxValue(tempRes, len, dest.getExtents());
3440 }
3441 return fir::ArrayBoxValue(tempRes, dest.getExtents());
3442 }
3443
3444 static void lowerLazyArrayExpression(
3445 Fortran::lower::AbstractConverter &converter,
3446 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
3447 const Fortran::lower::SomeExpr &expr, mlir::Value raggedHeader) {
3448 ArrayExprLowering ael(converter, stmtCtx, symMap);
3449 ael.lowerLazyArrayExpression(expr, raggedHeader);
3450 }
3451
3452 /// Lower the expression \p expr into a buffer that is created on demand. The
3453 /// variable containing the pointer to the buffer is \p var and the variable
3454 /// containing the shape of the buffer is \p shapeBuffer.
3455 void lowerLazyArrayExpression(const Fortran::lower::SomeExpr &expr,
3456 mlir::Value header) {
3457 mlir::Location loc = getLoc();
3458 mlir::TupleType hdrTy = fir::factory::getRaggedArrayHeaderType(builder);
3459 mlir::IntegerType i32Ty = builder.getIntegerType(32);
3460
3461 // Once the loop extents have been computed, which may require being inside
3462 // some explicit loops, lazily allocate the expression on the heap. The
3463 // following continuation creates the buffer as needed.
3464 ccPrelude = [=](llvm::ArrayRef<mlir::Value> shape) {
3465 mlir::IntegerType i64Ty = builder.getIntegerType(64);
3466 mlir::Value byteSize = builder.createIntegerConstant(loc, i64Ty, 1);
3467 fir::runtime::genRaggedArrayAllocate(
3468 loc, builder, header, /*asHeaders=*/false, byteSize, shape);
3469 };
3470
3471 // Create a dummy array_load before the loop. We're storing to a lazy
3472 // temporary, so there will be no conflict and no copy-in. TODO: skip this
3473 // as there isn't any necessity for it.
3474 ccLoadDest = [=](llvm::ArrayRef<mlir::Value> shape) -> fir::ArrayLoadOp {
3475 mlir::Value one = builder.createIntegerConstant(loc, i32Ty, 1);
3476 auto var = builder.create<fir::CoordinateOp>(
3477 loc, builder.getRefType(hdrTy.getType(1)), header, one);
3478 auto load = builder.create<fir::LoadOp>(loc, var);
3479 mlir::Type eleTy =
3480 fir::unwrapSequenceType(fir::unwrapRefType(load.getType()));
3481 auto seqTy = fir::SequenceType::get(eleTy, shape.size());
3482 mlir::Value castTo =
3483 builder.createConvert(loc, fir::HeapType::get(seqTy), load);
3484 mlir::Value shapeOp = builder.genShape(loc, shape);
3485 return builder.create<fir::ArrayLoadOp>(
3486 loc, seqTy, castTo, shapeOp, /*slice=*/mlir::Value{}, std::nullopt);
3487 };
3488 // Custom lowering of the element store to deal with the extra indirection
3489 // to the lazy allocated buffer.
3490 ccStoreToDest = [=](IterSpace iters) {
3491 mlir::Value one = builder.createIntegerConstant(loc, i32Ty, 1);
3492 auto var = builder.create<fir::CoordinateOp>(
3493 loc, builder.getRefType(hdrTy.getType(1)), header, one);
3494 auto load = builder.create<fir::LoadOp>(loc, var);
3495 mlir::Type eleTy =
3496 fir::unwrapSequenceType(fir::unwrapRefType(load.getType()));
3497 auto seqTy = fir::SequenceType::get(eleTy, iters.iterVec().size());
3498 auto toTy = fir::HeapType::get(seqTy);
3499 mlir::Value castTo = builder.createConvert(loc, toTy, load);
3500 mlir::Value shape = builder.genShape(loc, genIterationShape());
3501 llvm::SmallVector<mlir::Value> indices = fir::factory::originateIndices(
3502 loc, builder, castTo.getType(), shape, iters.iterVec());
3503 auto eleAddr = builder.create<fir::ArrayCoorOp>(
3504 loc, builder.getRefType(eleTy), castTo, shape,
3505 /*slice=*/mlir::Value{}, indices, destination.getTypeparams());
3506 mlir::Value eleVal =
3507 builder.createConvert(loc, eleTy, iters.getElement());
3508 builder.create<fir::StoreOp>(loc, eleVal, eleAddr);
3509 return iters.innerArgument();
3510 };
3511
3512 // Lower the array expression now. Clean-up any temps that may have
3513 // been generated when lowering `expr` right after the lowered value
3514 // was stored to the ragged array temporary. The local temps will not
3515 // be needed afterwards.
3516 stmtCtx.pushScope();
3517 [[maybe_unused]] ExtValue loopRes = lowerArrayExpression(expr);
3518 stmtCtx.finalizeAndPop();
3519 assert(fir::getBase(loopRes))(static_cast <bool> (fir::getBase(loopRes)) ? void (0) :
__assert_fail ("fir::getBase(loopRes)", "flang/lib/Lower/ConvertExpr.cpp"
, 3519, __extension__ __PRETTY_FUNCTION__))
;
3520 }
3521
3522 static void
3523 lowerElementalUserAssignment(Fortran::lower::AbstractConverter &converter,
3524 Fortran::lower::SymMap &symMap,
3525 Fortran::lower::StatementContext &stmtCtx,
3526 Fortran::lower::ExplicitIterSpace &explicitSpace,
3527 Fortran::lower::ImplicitIterSpace &implicitSpace,
3528 const Fortran::evaluate::ProcedureRef &procRef) {
3529 ArrayExprLowering ael(converter, stmtCtx, symMap,
3530 ConstituentSemantics::CustomCopyInCopyOut,
3531 &explicitSpace, &implicitSpace);
3532 assert(procRef.arguments().size() == 2)(static_cast <bool> (procRef.arguments().size() == 2) ?
void (0) : __assert_fail ("procRef.arguments().size() == 2",
"flang/lib/Lower/ConvertExpr.cpp", 3532, __extension__ __PRETTY_FUNCTION__
))
;
3533 const auto *lhs = procRef.arguments()[0].value().UnwrapExpr();
3534 const auto *rhs = procRef.arguments()[1].value().UnwrapExpr();
3535 assert(lhs && rhs &&(static_cast <bool> (lhs && rhs && "user defined assignment arguments must be expressions"
) ? void (0) : __assert_fail ("lhs && rhs && \"user defined assignment arguments must be expressions\""
, "flang/lib/Lower/ConvertExpr.cpp", 3536, __extension__ __PRETTY_FUNCTION__
))
3536 "user defined assignment arguments must be expressions")(static_cast <bool> (lhs && rhs && "user defined assignment arguments must be expressions"
) ? void (0) : __assert_fail ("lhs && rhs && \"user defined assignment arguments must be expressions\""
, "flang/lib/Lower/ConvertExpr.cpp", 3536, __extension__ __PRETTY_FUNCTION__
))
;
3537 mlir::func::FuncOp func =
3538 Fortran::lower::CallerInterface(procRef, converter).getFuncOp();
3539 ael.lowerElementalUserAssignment(func, *lhs, *rhs);
3540 }
3541
3542 void lowerElementalUserAssignment(mlir::func::FuncOp userAssignment,
3543 const Fortran::lower::SomeExpr &lhs,
3544 const Fortran::lower::SomeExpr &rhs) {
3545 mlir::Location loc = getLoc();
3546 PushSemantics(ConstituentSemantics::CustomCopyInCopyOut)[[maybe_unused]] auto pushSemanticsLocalVariable__LINE__ = Fortran
::common::ScopedSet(semant, ConstituentSemantics::CustomCopyInCopyOut
);
;
3547 auto genArrayModify = genarr(lhs);
3548 ccStoreToDest = [=](IterSpace iters) -> ExtValue {
3549 auto modifiedArray = genArrayModify(iters);
3550 auto arrayModify = mlir::dyn_cast_or_null<fir::ArrayModifyOp>(
3551 fir::getBase(modifiedArray).getDefiningOp());
3552 assert(arrayModify && "must be created by ArrayModifyOp")(static_cast <bool> (arrayModify && "must be created by ArrayModifyOp"
) ? void (0) : __assert_fail ("arrayModify && \"must be created by ArrayModifyOp\""
, "flang/lib/Lower/ConvertExpr.cpp", 3552, __extension__ __PRETTY_FUNCTION__
))
;
3553 fir::ExtendedValue lhs =
3554 arrayModifyToExv(builder, loc, destination, arrayModify.getResult(0));
3555 genScalarUserDefinedAssignmentCall(builder, loc, userAssignment, lhs,
3556 iters.elementExv());
3557 return modifiedArray;
3558 };
3559 determineShapeOfDest(lhs);
3560 semant = ConstituentSemantics::RefTransparent;
3561 auto exv = lowerArrayExpression(rhs);
3562 if (explicitSpaceIsActive()) {
3563 explicitSpace->finalizeContext();
3564 builder.create<fir::ResultOp>(loc, fir::getBase(exv));
3565 } else {
3566 builder.create<fir::ArrayMergeStoreOp>(
3567 loc, destination, fir::getBase(exv), destination.getMemref(),
3568 destination.getSlice(), destination.getTypeparams());
3569 }
3570 }
3571
3572 /// Lower an elemental subroutine call with at least one array argument.
3573 /// An elemental subroutine is an exception and does not have copy-in/copy-out
3574 /// semantics. See 15.8.3.
3575 /// Do NOT use this for user defined assignments.
3576 static void
3577 lowerElementalSubroutine(Fortran::lower::AbstractConverter &converter,
3578 Fortran::lower::SymMap &symMap,
3579 Fortran::lower::StatementContext &stmtCtx,
3580 const Fortran::lower::SomeExpr &call) {
3581 ArrayExprLowering ael(converter, stmtCtx, symMap,
3582 ConstituentSemantics::RefTransparent);
3583 ael.lowerElementalSubroutine(call);
3584 }
3585
3586 static const std::optional<Fortran::evaluate::ActualArgument>
3587 extractPassedArgFromProcRef(const Fortran::evaluate::ProcedureRef &procRef,
3588 Fortran::lower::AbstractConverter &converter) {
3589 // First look for passed object in actual arguments.
3590 for (const std::optional<Fortran::evaluate::ActualArgument> &arg :
3591 procRef.arguments())
3592 if (arg && arg->isPassedObject())
3593 return arg;
3594
3595 // If passed object is not found by here, it means the call was fully
3596 // resolved to the correct procedure. Look for the pass object in the
3597 // dummy arguments. Pick the first polymorphic one.
3598 Fortran::lower::CallerInterface caller(procRef, converter);
3599 unsigned idx = 0;
3600 for (const auto &arg : caller.characterize().dummyArguments) {
3601 if (const auto *dummy =
3602 std::get_if<Fortran::evaluate::characteristics::DummyDataObject>(
3603 &arg.u))
3604 if (dummy->type.type().IsPolymorphic())
3605 return procRef.arguments()[idx];
3606 ++idx;
3607 }
3608 return std::nullopt;
3609 }
3610
3611 // TODO: See the comment in genarr(const Fortran::lower::Parentheses<T>&).
3612 // This is skipping generation of copy-in/copy-out code for analysis that is
3613 // required when arguments are in parentheses.
3614 void lowerElementalSubroutine(const Fortran::lower::SomeExpr &call) {
3615 if (const auto *procRef =
3616 std::get_if<Fortran::evaluate::ProcedureRef>(&call.u))
3617 setLoweredProcRef(procRef);
3618 auto f = genarr(call);
3619 llvm::SmallVector<mlir::Value> shape = genIterationShape();
3620 auto [iterSpace, insPt] = genImplicitLoops(shape, /*innerArg=*/{});
3621 f(iterSpace);
3622 finalizeElementCtx();
3623 builder.restoreInsertionPoint(insPt);
3624 }
3625
3626 ExtValue lowerScalarAssignment(const Fortran::lower::SomeExpr &lhs,
3627 const Fortran::lower::SomeExpr &rhs) {
3628 PushSemantics(ConstituentSemantics::RefTransparent)[[maybe_unused]] auto pushSemanticsLocalVariable__LINE__ = Fortran
::common::ScopedSet(semant, ConstituentSemantics::RefTransparent
);
;
3629 // 1) Lower the rhs expression with array_fetch op(s).
3630 IterationSpace iters;
3631 iters.setElement(genarr(rhs)(iters));
3632 // 2) Lower the lhs expression to an array_update.
3633 semant = ConstituentSemantics::ProjectedCopyInCopyOut;
3634 auto lexv = genarr(lhs)(iters);
3635 // 3) Finalize the inner context.
3636 explicitSpace->finalizeContext();
3637 // 4) Thread the array value updated forward. Note: the lhs might be
3638 // ill-formed (performing scalar assignment in an array context),
3639 // in which case there is no array to thread.
3640 auto loc = getLoc();
3641 auto createResult = [&](auto op) {
3642 mlir::Value oldInnerArg = op.getSequence();
3643 std::size_t offset = explicitSpace->argPosition(oldInnerArg);
3644 explicitSpace->setInnerArg(offset, fir::getBase(lexv));
3645 finalizeElementCtx();
3646 builder.create<fir::ResultOp>(loc, fir::getBase(lexv));
3647 };
3648 if (mlir::Operation *defOp = fir::getBase(lexv).getDefiningOp()) {
3649 llvm::TypeSwitch<mlir::Operation *>(defOp)
3650 .Case([&](fir::ArrayUpdateOp op) { createResult(op); })
3651 .Case([&](fir::ArrayAmendOp op) { createResult(op); })
3652 .Case([&](fir::ArrayModifyOp op) { createResult(op); })
3653 .Default([&](mlir::Operation *) { finalizeElementCtx(); });
3654 } else {
3655 // `lhs` isn't from a `fir.array_load`, so there is no array modifications
3656 // to thread through the iteration space.
3657 finalizeElementCtx();
3658 }
3659 return lexv;
3660 }
3661
3662 static ExtValue lowerScalarUserAssignment(
3663 Fortran::lower::AbstractConverter &converter,
3664 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
3665 Fortran::lower::ExplicitIterSpace &explicitIterSpace,
3666 mlir::func::FuncOp userAssignmentFunction,
3667 const Fortran::lower::SomeExpr &lhs,
3668 const Fortran::lower::SomeExpr &rhs) {
3669 Fortran::lower::ImplicitIterSpace implicit;
3670 ArrayExprLowering ael(converter, stmtCtx, symMap,
3671 ConstituentSemantics::RefTransparent,
3672 &explicitIterSpace, &implicit);
3673 return ael.lowerScalarUserAssignment(userAssignmentFunction, lhs, rhs);
3674 }
3675
3676 ExtValue lowerScalarUserAssignment(mlir::func::FuncOp userAssignment,
3677 const Fortran::lower::SomeExpr &lhs,
3678 const Fortran::lower::SomeExpr &rhs) {
3679 mlir::Location loc = getLoc();
3680 if (rhs.Rank() > 0)
3681 TODO(loc, "user-defined elemental assigment from expression with rank")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "3681" ": not yet implemented: ") + llvm::Twine("user-defined elemental assigment from expression with rank"
), false); } while (false)
;
3682 // 1) Lower the rhs expression with array_fetch op(s).
3683 IterationSpace iters;
3684 iters.setElement(genarr(rhs)(iters));
3685 fir::ExtendedValue elementalExv = iters.elementExv();
3686 // 2) Lower the lhs expression to an array_modify.
3687 semant = ConstituentSemantics::CustomCopyInCopyOut;
3688 auto lexv = genarr(lhs)(iters);
3689 bool isIllFormedLHS = false;
3690 // 3) Insert the call
3691 if (auto modifyOp = mlir::dyn_cast<fir::ArrayModifyOp>(
3692 fir::getBase(lexv).getDefiningOp())) {
3693 mlir::Value oldInnerArg = modifyOp.getSequence();
3694 std::size_t offset = explicitSpace->argPosition(oldInnerArg);
3695 explicitSpace->setInnerArg(offset, fir::getBase(lexv));
3696 auto lhsLoad = explicitSpace->getLhsLoad(0);
3697 assert(lhsLoad.has_value())(static_cast <bool> (lhsLoad.has_value()) ? void (0) : __assert_fail
("lhsLoad.has_value()", "flang/lib/Lower/ConvertExpr.cpp", 3697
, __extension__ __PRETTY_FUNCTION__))
;
3698 fir::ExtendedValue exv =
3699 arrayModifyToExv(builder, loc, *lhsLoad, modifyOp.getResult(0));
3700 genScalarUserDefinedAssignmentCall(builder, loc, userAssignment, exv,
3701 elementalExv);
3702 } else {
3703 // LHS is ill formed, it is a scalar with no references to FORALL
3704 // subscripts, so there is actually no array assignment here. The user
3705 // code is probably bad, but still insert user assignment call since it
3706 // was not rejected by semantics (a warning was emitted).
3707 isIllFormedLHS = true;
3708 genScalarUserDefinedAssignmentCall(builder, getLoc(), userAssignment,
3709 lexv, elementalExv);
3710 }
3711 // 4) Finalize the inner context.
3712 explicitSpace->finalizeContext();
3713 // 5). Thread the array value updated forward.
3714 if (!isIllFormedLHS) {
3715 finalizeElementCtx();
3716 builder.create<fir::ResultOp>(getLoc(), fir::getBase(lexv));
3717 }
3718 return lexv;
3719 }
3720
3721private:
3722 void determineShapeOfDest(const fir::ExtendedValue &lhs) {
3723 destShape = fir::factory::getExtents(getLoc(), builder, lhs);
3724 }
3725
3726 void determineShapeOfDest(const Fortran::lower::SomeExpr &lhs) {
3727 if (!destShape.empty())
3728 return;
3729 if (explicitSpaceIsActive() && determineShapeWithSlice(lhs))
3730 return;
3731 mlir::Type idxTy = builder.getIndexType();
3732 mlir::Location loc = getLoc();
3733 if (std::optional<Fortran::evaluate::ConstantSubscripts> constantShape =
3734 Fortran::evaluate::GetConstantExtents(converter.getFoldingContext(),
3735 lhs))
3736 for (Fortran::common::ConstantSubscript extent : *constantShape)
3737 destShape.push_back(builder.createIntegerConstant(loc, idxTy, extent));
3738 }
3739
3740 bool genShapeFromDataRef(const Fortran::semantics::Symbol &x) {
3741 return false;
3742 }
3743 bool genShapeFromDataRef(const Fortran::evaluate::CoarrayRef &) {
3744 TODO(getLoc(), "coarray ref")do { fir::emitFatalError(getLoc(), llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "3744" ": not yet implemented: ") + llvm::Twine("coarray ref"
), false); } while (false)
;
3745 return false;
3746 }
3747 bool genShapeFromDataRef(const Fortran::evaluate::Component &x) {
3748 return x.base().Rank() > 0 ? genShapeFromDataRef(x.base()) : false;
3749 }
3750 bool genShapeFromDataRef(const Fortran::evaluate::ArrayRef &x) {
3751 if (x.Rank() == 0)
3752 return false;
3753 if (x.base().Rank() > 0)
3754 if (genShapeFromDataRef(x.base()))
3755 return true;
3756 // x has rank and x.base did not produce a shape.
3757 ExtValue exv = x.base().IsSymbol() ? asScalarRef(getFirstSym(x.base()))
3758 : asScalarRef(x.base().GetComponent());
3759 mlir::Location loc = getLoc();
3760 mlir::IndexType idxTy = builder.getIndexType();
3761 llvm::SmallVector<mlir::Value> definedShape =
3762 fir::factory::getExtents(loc, builder, exv);
3763 mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
3764 for (auto ss : llvm::enumerate(x.subscript())) {
3765 std::visit(Fortran::common::visitors{
3766 [&](const Fortran::evaluate::Triplet &trip) {
3767 // For a subscript of triple notation, we compute the
3768 // range of this dimension of the iteration space.
3769 auto lo = [&]() {
3770 if (auto optLo = trip.lower())
3771 return fir::getBase(asScalar(*optLo));
3772 return getLBound(exv, ss.index(), one);
3773 }();
3774 auto hi = [&]() {
3775 if (auto optHi = trip.upper())
3776 return fir::getBase(asScalar(*optHi));
3777 return getUBound(exv, ss.index(), one);
3778 }();
3779 auto step = builder.createConvert(
3780 loc, idxTy, fir::getBase(asScalar(trip.stride())));
3781 auto extent = builder.genExtentFromTriplet(loc, lo, hi,
3782 step, idxTy);
3783 destShape.push_back(extent);
3784 },
3785 [&](auto) {}},
3786 ss.value().u);
3787 }
3788 return true;
3789 }
3790 bool genShapeFromDataRef(const Fortran::evaluate::NamedEntity &x) {
3791 if (x.IsSymbol())
3792 return genShapeFromDataRef(getFirstSym(x));
3793 return genShapeFromDataRef(x.GetComponent());
3794 }
3795 bool genShapeFromDataRef(const Fortran::evaluate::DataRef &x) {
3796 return std::visit([&](const auto &v) { return genShapeFromDataRef(v); },
3797 x.u);
3798 }
3799
3800 /// When in an explicit space, the ranked component must be evaluated to
3801 /// determine the actual number of iterations when slicing triples are
3802 /// present. Lower these expressions here.
3803 bool determineShapeWithSlice(const Fortran::lower::SomeExpr &lhs) {
3804 LLVM_DEBUG(Fortran::lower::DumpEvaluateExpr::dump(do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { Fortran::lower::DumpEvaluateExpr::dump
( llvm::dbgs() << "determine shape of:\n", lhs); } } while
(false)
3805 llvm::dbgs() << "determine shape of:\n", lhs))do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { Fortran::lower::DumpEvaluateExpr::dump
( llvm::dbgs() << "determine shape of:\n", lhs); } } while
(false)
;
3806 // FIXME: We may not want to use ExtractDataRef here since it doesn't deal
3807 // with substrings, etc.
3808 std::optional<Fortran::evaluate::DataRef> dref =
3809 Fortran::evaluate::ExtractDataRef(lhs);
3810 return dref.has_value() ? genShapeFromDataRef(*dref) : false;
3811 }
3812
3813 /// CHARACTER and derived type elements are treated as memory references. The
3814 /// numeric types are treated as values.
3815 static mlir::Type adjustedArraySubtype(mlir::Type ty,
3816 mlir::ValueRange indices) {
3817 mlir::Type pathTy = fir::applyPathToType(ty, indices);
3818 assert(pathTy && "indices failed to apply to type")(static_cast <bool> (pathTy && "indices failed to apply to type"
) ? void (0) : __assert_fail ("pathTy && \"indices failed to apply to type\""
, "flang/lib/Lower/ConvertExpr.cpp", 3818, __extension__ __PRETTY_FUNCTION__
))
;
3819 return adjustedArrayElementType(pathTy);
3820 }
3821
3822 /// Lower rhs of an array expression.
3823 ExtValue lowerArrayExpression(const Fortran::lower::SomeExpr &exp) {
3824 mlir::Type resTy = converter.genType(exp);
3825
3826 if (fir::isPolymorphicType(resTy) &&
3827 Fortran::evaluate::HasVectorSubscript(exp))
3828 TODO(getLoc(),do { fir::emitFatalError(getLoc(), llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "3829" ": not yet implemented: ") + llvm::Twine("polymorphic array expression lowering with vector subscript"
), false); } while (false)
3829 "polymorphic array expression lowering with vector subscript")do { fir::emitFatalError(getLoc(), llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "3829" ": not yet implemented: ") + llvm::Twine("polymorphic array expression lowering with vector subscript"
), false); } while (false)
;
3830
3831 return std::visit(
3832 [&](const auto &e) { return lowerArrayExpression(genarr(e), resTy); },
3833 exp.u);
3834 }
3835 ExtValue lowerArrayExpression(const ExtValue &exv) {
3836 assert(!explicitSpace)(static_cast <bool> (!explicitSpace) ? void (0) : __assert_fail
("!explicitSpace", "flang/lib/Lower/ConvertExpr.cpp", 3836, __extension__
__PRETTY_FUNCTION__))
;
3837 mlir::Type resTy = fir::unwrapPassByRefType(fir::getBase(exv).getType());
3838 return lowerArrayExpression(genarr(exv), resTy);
3839 }
3840
3841 void populateBounds(llvm::SmallVectorImpl<mlir::Value> &bounds,
3842 const Fortran::evaluate::Substring *substring) {
3843 if (!substring)
3844 return;
3845 bounds.push_back(fir::getBase(asScalar(substring->lower())));
3846 if (auto upper = substring->upper())
3847 bounds.push_back(fir::getBase(asScalar(*upper)));
3848 }
3849
3850 /// Convert the original value, \p origVal, to type \p eleTy. When in a
3851 /// pointer assignment context, generate an appropriate `fir.rebox` for
3852 /// dealing with any bounds parameters on the pointer assignment.
3853 mlir::Value convertElementForUpdate(mlir::Location loc, mlir::Type eleTy,
3854 mlir::Value origVal) {
3855 if (auto origEleTy = fir::dyn_cast_ptrEleTy(origVal.getType()))
3856 if (origEleTy.isa<fir::BaseBoxType>()) {
3857 // If origVal is a box variable, load it so it is in the value domain.
3858 origVal = builder.create<fir::LoadOp>(loc, origVal);
3859 }
3860 if (origVal.getType().isa<fir::BoxType>() && !eleTy.isa<fir::BoxType>()) {
3861 if (isPointerAssignment())
3862 TODO(loc, "lhs of pointer assignment returned unexpected value")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "3862" ": not yet implemented: ") + llvm::Twine("lhs of pointer assignment returned unexpected value"
), false); } while (false)
;
3863 TODO(loc, "invalid box conversion in elemental computation")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "3863" ": not yet implemented: ") + llvm::Twine("invalid box conversion in elemental computation"
), false); } while (false)
;
3864 }
3865 if (isPointerAssignment() && eleTy.isa<fir::BoxType>() &&
3866 !origVal.getType().isa<fir::BoxType>()) {
3867 // This is a pointer assignment and the rhs is a raw reference to a TARGET
3868 // in memory. Embox the reference so it can be stored to the boxed
3869 // POINTER variable.
3870 assert(fir::isa_ref_type(origVal.getType()))(static_cast <bool> (fir::isa_ref_type(origVal.getType(
))) ? void (0) : __assert_fail ("fir::isa_ref_type(origVal.getType())"
, "flang/lib/Lower/ConvertExpr.cpp", 3870, __extension__ __PRETTY_FUNCTION__
))
;
3871 if (auto eleTy = fir::dyn_cast_ptrEleTy(origVal.getType());
3872 fir::hasDynamicSize(eleTy))
3873 TODO(loc, "TARGET of pointer assignment with runtime size/shape")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "3873" ": not yet implemented: ") + llvm::Twine("TARGET of pointer assignment with runtime size/shape"
), false); } while (false)
;
3874 auto memrefTy = fir::boxMemRefType(eleTy.cast<fir::BoxType>());
3875 auto castTo = builder.createConvert(loc, memrefTy, origVal);
3876 origVal = builder.create<fir::EmboxOp>(loc, eleTy, castTo);
3877 }
3878 mlir::Value val = builder.createConvert(loc, eleTy, origVal);
3879 if (isBoundsSpec()) {
3880 assert(lbounds.has_value())(static_cast <bool> (lbounds.has_value()) ? void (0) : __assert_fail
("lbounds.has_value()", "flang/lib/Lower/ConvertExpr.cpp", 3880
, __extension__ __PRETTY_FUNCTION__))
;
3881 auto lbs = *lbounds;
3882 if (lbs.size() > 0) {
3883 // Rebox the value with user-specified shift.
3884 auto shiftTy = fir::ShiftType::get(eleTy.getContext(), lbs.size());
3885 mlir::Value shiftOp = builder.create<fir::ShiftOp>(loc, shiftTy, lbs);
3886 val = builder.create<fir::ReboxOp>(loc, eleTy, val, shiftOp,
3887 mlir::Value{});
3888 }
3889 } else if (isBoundsRemap()) {
3890 assert(lbounds.has_value())(static_cast <bool> (lbounds.has_value()) ? void (0) : __assert_fail
("lbounds.has_value()", "flang/lib/Lower/ConvertExpr.cpp", 3890
, __extension__ __PRETTY_FUNCTION__))
;
3891 auto lbs = *lbounds;
3892 if (lbs.size() > 0) {
3893 // Rebox the value with user-specified shift and shape.
3894 assert(ubounds.has_value())(static_cast <bool> (ubounds.has_value()) ? void (0) : __assert_fail
("ubounds.has_value()", "flang/lib/Lower/ConvertExpr.cpp", 3894
, __extension__ __PRETTY_FUNCTION__))
;
3895 auto shapeShiftArgs = flatZip(lbs, *ubounds);
3896 auto shapeTy = fir::ShapeShiftType::get(eleTy.getContext(), lbs.size());
3897 mlir::Value shapeShift =
3898 builder.create<fir::ShapeShiftOp>(loc, shapeTy, shapeShiftArgs);
3899 val = builder.create<fir::ReboxOp>(loc, eleTy, val, shapeShift,
3900 mlir::Value{});
3901 }
3902 }
3903 return val;
3904 }
3905
3906 /// Default store to destination implementation.
3907 /// This implements the default case, which is to assign the value in
3908 /// `iters.element` into the destination array, `iters.innerArgument`. Handles
3909 /// by value and by reference assignment.
3910 CC defaultStoreToDestination(const Fortran::evaluate::Substring *substring) {
3911 return [=](IterSpace iterSpace) -> ExtValue {
3912 mlir::Location loc = getLoc();
3913 mlir::Value innerArg = iterSpace.innerArgument();
3914 fir::ExtendedValue exv = iterSpace.elementExv();
3915 mlir::Type arrTy = innerArg.getType();
3916 mlir::Type eleTy = fir::applyPathToType(arrTy, iterSpace.iterVec());
3917 if (isAdjustedArrayElementType(eleTy)) {
3918 // The elemental update is in the memref domain. Under this semantics,
3919 // we must always copy the computed new element from its location in
3920 // memory into the destination array.
3921 mlir::Type resRefTy = builder.getRefType(eleTy);
3922 // Get a reference to the array element to be amended.
3923 auto arrayOp = builder.create<fir::ArrayAccessOp>(
3924 loc, resRefTy, innerArg, iterSpace.iterVec(),
3925 fir::factory::getTypeParams(loc, builder, destination));
3926 if (auto charTy = eleTy.dyn_cast<fir::CharacterType>()) {
3927 llvm::SmallVector<mlir::Value> substringBounds;
3928 populateBounds(substringBounds, substring);
3929 mlir::Value dstLen = fir::factory::genLenOfCharacter(
3930 builder, loc, destination, iterSpace.iterVec(), substringBounds);
3931 fir::ArrayAmendOp amend = createCharArrayAmend(
3932 loc, builder, arrayOp, dstLen, exv, innerArg, substringBounds);
3933 return abstractArrayExtValue(amend, dstLen);
3934 }
3935 if (fir::isa_derived(eleTy)) {
3936 fir::ArrayAmendOp amend = createDerivedArrayAmend(
3937 loc, destination, builder, arrayOp, exv, eleTy, innerArg);
3938 return abstractArrayExtValue(amend /*FIXME: typeparams?*/);
3939 }
3940 assert(eleTy.isa<fir::SequenceType>() && "must be an array")(static_cast <bool> (eleTy.isa<fir::SequenceType>
() && "must be an array") ? void (0) : __assert_fail (
"eleTy.isa<fir::SequenceType>() && \"must be an array\""
, "flang/lib/Lower/ConvertExpr.cpp", 3940, __extension__ __PRETTY_FUNCTION__
))
;
3941 TODO(loc, "array (as element) assignment")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "3941" ": not yet implemented: ") + llvm::Twine("array (as element) assignment"
), false); } while (false)
;
3942 }
3943 // By value semantics. The element is being assigned by value.
3944 auto ele = convertElementForUpdate(loc, eleTy, fir::getBase(exv));
3945 auto update = builder.create<fir::ArrayUpdateOp>(
3946 loc, arrTy, innerArg, ele, iterSpace.iterVec(),
3947 destination.getTypeparams());
3948 return abstractArrayExtValue(update);
3949 };
3950 }
3951
3952 /// For an elemental array expression.
3953 /// 1. Lower the scalars and array loads.
3954 /// 2. Create the iteration space.
3955 /// 3. Create the element-by-element computation in the loop.
3956 /// 4. Return the resulting array value.
3957 /// If no destination was set in the array context, a temporary of
3958 /// \p resultTy will be created to hold the evaluated expression.
3959 /// Otherwise, \p resultTy is ignored and the expression is evaluated
3960 /// in the destination. \p f is a continuation built from an
3961 /// evaluate::Expr or an ExtendedValue.
3962 ExtValue lowerArrayExpression(CC f, mlir::Type resultTy) {
3963 mlir::Location loc = getLoc();
3964 auto [iterSpace, insPt] = genIterSpace(resultTy);
3965 auto exv = f(iterSpace);
3966 iterSpace.setElement(std::move(exv));
3967 auto lambda = ccStoreToDest
3968 ? *ccStoreToDest
3969 : defaultStoreToDestination(/*substring=*/nullptr);
3970 mlir::Value updVal = fir::getBase(lambda(iterSpace));
3971 finalizeElementCtx();
3972 builder.create<fir::ResultOp>(loc, updVal);
3973 builder.restoreInsertionPoint(insPt);
3974 return abstractArrayExtValue(iterSpace.outerResult());
3975 }
3976
3977 /// Compute the shape of a slice.
3978 llvm::SmallVector<mlir::Value> computeSliceShape(mlir::Value slice) {
3979 llvm::SmallVector<mlir::Value> slicedShape;
3980 auto slOp = mlir::cast<fir::SliceOp>(slice.getDefiningOp());
3981 mlir::Operation::operand_range triples = slOp.getTriples();
3982 mlir::IndexType idxTy = builder.getIndexType();
3983 mlir::Location loc = getLoc();
3984 for (unsigned i = 0, end = triples.size(); i < end; i += 3) {
3985 if (!mlir::isa_and_nonnull<fir::UndefOp>(
3986 triples[i + 1].getDefiningOp())) {
3987 // (..., lb:ub:step, ...) case: extent = max((ub-lb+step)/step, 0)
3988 // See Fortran 2018 9.5.3.3.2 section for more details.
3989 mlir::Value res = builder.genExtentFromTriplet(
3990 loc, triples[i], triples[i + 1], triples[i + 2], idxTy);
3991 slicedShape.emplace_back(res);
3992 } else {
3993 // do nothing. `..., i, ...` case, so dimension is dropped.
3994 }
3995 }
3996 return slicedShape;
3997 }
3998
3999 /// Get the shape from an ArrayOperand. The shape of the array is adjusted if
4000 /// the array was sliced.
4001 llvm::SmallVector<mlir::Value> getShape(ArrayOperand array) {
4002 if (array.slice)
4003 return computeSliceShape(array.slice);
4004 if (array.memref.getType().isa<fir::BaseBoxType>())
4005 return fir::factory::readExtents(builder, getLoc(),
4006 fir::BoxValue{array.memref});
4007 return fir::factory::getExtents(array.shape);
4008 }
4009
4010 /// Get the shape from an ArrayLoad.
4011 llvm::SmallVector<mlir::Value> getShape(fir::ArrayLoadOp arrayLoad) {
4012 return getShape(ArrayOperand{arrayLoad.getMemref(), arrayLoad.getShape(),
4013 arrayLoad.getSlice()});
4014 }
4015
4016 /// Returns the first array operand that may not be absent. If all
4017 /// array operands may be absent, return the first one.
4018 const ArrayOperand &getInducingShapeArrayOperand() const {
4019 assert(!arrayOperands.empty())(static_cast <bool> (!arrayOperands.empty()) ? void (0)
: __assert_fail ("!arrayOperands.empty()", "flang/lib/Lower/ConvertExpr.cpp"
, 4019, __extension__ __PRETTY_FUNCTION__))
;
4020 for (const ArrayOperand &op : arrayOperands)
4021 if (!op.mayBeAbsent)
4022 return op;
4023 // If all arrays operand appears in optional position, then none of them
4024 // is allowed to be absent as per 15.5.2.12 point 3. (6). Just pick the
4025 // first operands.
4026 // TODO: There is an opportunity to add a runtime check here that
4027 // this array is present as required.
4028 return arrayOperands[0];
4029 }
4030
4031 /// Generate the shape of the iteration space over the array expression. The
4032 /// iteration space may be implicit, explicit, or both. If it is implied it is
4033 /// based on the destination and operand array loads, or an optional
4034 /// Fortran::evaluate::Shape from the front end. If the shape is explicit,
4035 /// this returns any implicit shape component, if it exists.
4036 llvm::SmallVector<mlir::Value> genIterationShape() {
4037 // Use the precomputed destination shape.
4038 if (!destShape.empty())
4039 return destShape;
4040 // Otherwise, use the destination's shape.
4041 if (destination)
4042 return getShape(destination);
4043 // Otherwise, use the first ArrayLoad operand shape.
4044 if (!arrayOperands.empty())
4045 return getShape(getInducingShapeArrayOperand());
4046 // Otherwise, in elemental context, try to find the passed object and
4047 // retrieve the iteration shape from it.
4048 if (loweredProcRef && loweredProcRef->IsElemental()) {
4049 const std::optional<Fortran::evaluate::ActualArgument> passArg =
4050 extractPassedArgFromProcRef(*loweredProcRef, converter);
4051 if (passArg) {
4052 ExtValue exv = asScalarRef(*passArg->UnwrapExpr());
4053 fir::FirOpBuilder *builder = &converter.getFirOpBuilder();
4054 auto extents = fir::factory::getExtents(getLoc(), *builder, exv);
4055 if (extents.size() == 0)
4056 TODO(getLoc(), "getting shape from polymorphic array in elemental "do { fir::emitFatalError(getLoc(), llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "4057" ": not yet implemented: ") + llvm::Twine("getting shape from polymorphic array in elemental "
"procedure reference"), false); } while (false)
4057 "procedure reference")do { fir::emitFatalError(getLoc(), llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "4057" ": not yet implemented: ") + llvm::Twine("getting shape from polymorphic array in elemental "
"procedure reference"), false); } while (false)
;
4058 return extents;
4059 }
4060 }
4061 fir::emitFatalError(getLoc(),
4062 "failed to compute the array expression shape");
4063 }
4064
4065 bool explicitSpaceIsActive() const {
4066 return explicitSpace && explicitSpace->isActive();
4067 }
4068
4069 bool implicitSpaceHasMasks() const {
4070 return implicitSpace && !implicitSpace->empty();
4071 }
4072
4073 CC genMaskAccess(mlir::Value tmp, mlir::Value shape) {
4074 mlir::Location loc = getLoc();
4075 return [=, builder = &converter.getFirOpBuilder()](IterSpace iters) {
4076 mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(tmp.getType());
4077 auto eleTy = arrTy.cast<fir::SequenceType>().getEleTy();
4078 mlir::Type eleRefTy = builder->getRefType(eleTy);
4079 mlir::IntegerType i1Ty = builder->getI1Type();
4080 // Adjust indices for any shift of the origin of the array.
4081 llvm::SmallVector<mlir::Value> indices = fir::factory::originateIndices(
4082 loc, *builder, tmp.getType(), shape, iters.iterVec());
4083 auto addr =
4084 builder->create<fir::ArrayCoorOp>(loc, eleRefTy, tmp, shape,
4085 /*slice=*/mlir::Value{}, indices,
4086 /*typeParams=*/std::nullopt);
4087 auto load = builder->create<fir::LoadOp>(loc, addr);
4088 return builder->createConvert(loc, i1Ty, load);
4089 };
4090 }
4091
4092 /// Construct the incremental instantiations of the ragged array structure.
4093 /// Rebind the lazy buffer variable, etc. as we go.
4094 template <bool withAllocation = false>
4095 mlir::Value prepareRaggedArrays(Fortran::lower::FrontEndExpr expr) {
4096 assert(explicitSpaceIsActive())(static_cast <bool> (explicitSpaceIsActive()) ? void (0
) : __assert_fail ("explicitSpaceIsActive()", "flang/lib/Lower/ConvertExpr.cpp"
, 4096, __extension__ __PRETTY_FUNCTION__))
;
4097 mlir::Location loc = getLoc();
4098 mlir::TupleType raggedTy = fir::factory::getRaggedArrayHeaderType(builder);
4099 llvm::SmallVector<llvm::SmallVector<fir::DoLoopOp>> loopStack =
4100 explicitSpace->getLoopStack();
4101 const std::size_t depth = loopStack.size();
4102 mlir::IntegerType i64Ty = builder.getIntegerType(64);
4103 [[maybe_unused]] mlir::Value byteSize =
4104 builder.createIntegerConstant(loc, i64Ty, 1);
4105 mlir::Value header = implicitSpace->lookupMaskHeader(expr);
4106 for (std::remove_const_t<decltype(depth)> i = 0; i < depth; ++i) {
4107 auto insPt = builder.saveInsertionPoint();
4108 if (i < depth - 1)
4109 builder.setInsertionPoint(loopStack[i + 1][0]);
4110
4111 // Compute and gather the extents.
4112 llvm::SmallVector<mlir::Value> extents;
4113 for (auto doLoop : loopStack[i])
4114 extents.push_back(builder.genExtentFromTriplet(
4115 loc, doLoop.getLowerBound(), doLoop.getUpperBound(),
4116 doLoop.getStep(), i64Ty));
4117 if constexpr (withAllocation) {
4118 fir::runtime::genRaggedArrayAllocate(
4119 loc, builder, header, /*asHeader=*/true, byteSize, extents);
4120 }
4121
4122 // Compute the dynamic position into the header.
4123 llvm::SmallVector<mlir::Value> offsets;
4124 for (auto doLoop : loopStack[i]) {
4125 auto m = builder.create<mlir::arith::SubIOp>(
4126 loc, doLoop.getInductionVar(), doLoop.getLowerBound());
4127 auto n = builder.create<mlir::arith::DivSIOp>(loc, m, doLoop.getStep());
4128 mlir::Value one = builder.createIntegerConstant(loc, n.getType(), 1);
4129 offsets.push_back(builder.create<mlir::arith::AddIOp>(loc, n, one));
4130 }
4131 mlir::IntegerType i32Ty = builder.getIntegerType(32);
4132 mlir::Value uno = builder.createIntegerConstant(loc, i32Ty, 1);
4133 mlir::Type coorTy = builder.getRefType(raggedTy.getType(1));
4134 auto hdOff = builder.create<fir::CoordinateOp>(loc, coorTy, header, uno);
4135 auto toTy = fir::SequenceType::get(raggedTy, offsets.size());
4136 mlir::Type toRefTy = builder.getRefType(toTy);
4137 auto ldHdr = builder.create<fir::LoadOp>(loc, hdOff);
4138 mlir::Value hdArr = builder.createConvert(loc, toRefTy, ldHdr);
4139 auto shapeOp = builder.genShape(loc, extents);
4140 header = builder.create<fir::ArrayCoorOp>(
4141 loc, builder.getRefType(raggedTy), hdArr, shapeOp,
4142 /*slice=*/mlir::Value{}, offsets,
4143 /*typeparams=*/mlir::ValueRange{});
4144 auto hdrVar = builder.create<fir::CoordinateOp>(loc, coorTy, header, uno);
4145 auto inVar = builder.create<fir::LoadOp>(loc, hdrVar);
4146 mlir::Value two = builder.createIntegerConstant(loc, i32Ty, 2);
4147 mlir::Type coorTy2 = builder.getRefType(raggedTy.getType(2));
4148 auto hdrSh = builder.create<fir::CoordinateOp>(loc, coorTy2, header, two);
4149 auto shapePtr = builder.create<fir::LoadOp>(loc, hdrSh);
4150 // Replace the binding.
4151 implicitSpace->rebind(expr, genMaskAccess(inVar, shapePtr));
4152 if (i < depth - 1)
4153 builder.restoreInsertionPoint(insPt);
4154 }
4155 return header;
4156 }
4157
4158 /// Lower mask expressions with implied iteration spaces from the variants of
4159 /// WHERE syntax. Since it is legal for mask expressions to have side-effects
4160 /// and modify values that will be used for the lhs, rhs, or both of
4161 /// subsequent assignments, the mask must be evaluated before the assignment
4162 /// is processed.
4163 /// Mask expressions are array expressions too.
4164 void genMasks() {
4165 // Lower the mask expressions, if any.
4166 if (implicitSpaceHasMasks()) {
4167 mlir::Location loc = getLoc();
4168 // Mask expressions are array expressions too.
4169 for (const auto *e : implicitSpace->getExprs())
4170 if (e && !implicitSpace->isLowered(e)) {
4171 if (mlir::Value var = implicitSpace->lookupMaskVariable(e)) {
4172 // Allocate the mask buffer lazily.
4173 assert(explicitSpaceIsActive())(static_cast <bool> (explicitSpaceIsActive()) ? void (0
) : __assert_fail ("explicitSpaceIsActive()", "flang/lib/Lower/ConvertExpr.cpp"
, 4173, __extension__ __PRETTY_FUNCTION__))
;
4174 mlir::Value header =
4175 prepareRaggedArrays</*withAllocations=*/true>(e);
4176 Fortran::lower::createLazyArrayTempValue(converter, *e, header,
4177 symMap, stmtCtx);
4178 // Close the explicit loops.
4179 builder.create<fir::ResultOp>(loc, explicitSpace->getInnerArgs());
4180 builder.setInsertionPointAfter(explicitSpace->getOuterLoop());
4181 // Open a new copy of the explicit loop nest.
4182 explicitSpace->genLoopNest();
4183 continue;
4184 }
4185 fir::ExtendedValue tmp = Fortran::lower::createSomeArrayTempValue(
4186 converter, *e, symMap, stmtCtx);
4187 mlir::Value shape = builder.createShape(loc, tmp);
4188 implicitSpace->bind(e, genMaskAccess(fir::getBase(tmp), shape));
4189 }
4190
4191 // Set buffer from the header.
4192 for (const auto *e : implicitSpace->getExprs()) {
4193 if (!e)
4194 continue;
4195 if (implicitSpace->lookupMaskVariable(e)) {
4196 // Index into the ragged buffer to retrieve cached results.
4197 const int rank = e->Rank();
4198 assert(destShape.empty() ||(static_cast <bool> (destShape.empty() || static_cast<
std::size_t>(rank) == destShape.size()) ? void (0) : __assert_fail
("destShape.empty() || static_cast<std::size_t>(rank) == destShape.size()"
, "flang/lib/Lower/ConvertExpr.cpp", 4199, __extension__ __PRETTY_FUNCTION__
))
4199 static_cast<std::size_t>(rank) == destShape.size())(static_cast <bool> (destShape.empty() || static_cast<
std::size_t>(rank) == destShape.size()) ? void (0) : __assert_fail
("destShape.empty() || static_cast<std::size_t>(rank) == destShape.size()"
, "flang/lib/Lower/ConvertExpr.cpp", 4199, __extension__ __PRETTY_FUNCTION__
))
;
4200 mlir::Value header = prepareRaggedArrays(e);
4201 mlir::TupleType raggedTy =
4202 fir::factory::getRaggedArrayHeaderType(builder);
4203 mlir::IntegerType i32Ty = builder.getIntegerType(32);
4204 mlir::Value one = builder.createIntegerConstant(loc, i32Ty, 1);
4205 auto coor1 = builder.create<fir::CoordinateOp>(
4206 loc, builder.getRefType(raggedTy.getType(1)), header, one);
4207 auto db = builder.create<fir::LoadOp>(loc, coor1);
4208 mlir::Type eleTy =
4209 fir::unwrapSequenceType(fir::unwrapRefType(db.getType()));
4210 mlir::Type buffTy =
4211 builder.getRefType(fir::SequenceType::get(eleTy, rank));
4212 // Address of ragged buffer data.
4213 mlir::Value buff = builder.createConvert(loc, buffTy, db);
4214
4215 mlir::Value two = builder.createIntegerConstant(loc, i32Ty, 2);
4216 auto coor2 = builder.create<fir::CoordinateOp>(
4217 loc, builder.getRefType(raggedTy.getType(2)), header, two);
4218 auto shBuff = builder.create<fir::LoadOp>(loc, coor2);
4219 mlir::IntegerType i64Ty = builder.getIntegerType(64);
4220 mlir::IndexType idxTy = builder.getIndexType();
4221 llvm::SmallVector<mlir::Value> extents;
4222 for (std::remove_const_t<decltype(rank)> i = 0; i < rank; ++i) {
4223 mlir::Value off = builder.createIntegerConstant(loc, i32Ty, i);
4224 auto coor = builder.create<fir::CoordinateOp>(
4225 loc, builder.getRefType(i64Ty), shBuff, off);
4226 auto ldExt = builder.create<fir::LoadOp>(loc, coor);
4227 extents.push_back(builder.createConvert(loc, idxTy, ldExt));
4228 }
4229 if (destShape.empty())
4230 destShape = extents;
4231 // Construct shape of buffer.
4232 mlir::Value shapeOp = builder.genShape(loc, extents);
4233
4234 // Replace binding with the local result.
4235 implicitSpace->rebind(e, genMaskAccess(buff, shapeOp));
4236 }
4237 }
4238 }
4239 }
4240
4241 // FIXME: should take multiple inner arguments.
4242 std::pair<IterationSpace, mlir::OpBuilder::InsertPoint>
4243 genImplicitLoops(mlir::ValueRange shape, mlir::Value innerArg) {
4244 mlir::Location loc = getLoc();
4245 mlir::IndexType idxTy = builder.getIndexType();
4246 mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
4247 mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0);
4248 llvm::SmallVector<mlir::Value> loopUppers;
4249
4250 // Convert any implied shape to closed interval form. The fir.do_loop will
4251 // run from 0 to `extent - 1` inclusive.
4252 for (auto extent : shape)
4253 loopUppers.push_back(
4254 builder.create<mlir::arith::SubIOp>(loc, extent, one));
4255
4256 // Iteration space is created with outermost columns, innermost rows
4257 llvm::SmallVector<fir::DoLoopOp> loops;
4258
4259 const std::size_t loopDepth = loopUppers.size();
4260 llvm::SmallVector<mlir::Value> ivars;
4261
4262 for (auto i : llvm::enumerate(llvm::reverse(loopUppers))) {
4263 if (i.index() > 0) {
4264 assert(!loops.empty())(static_cast <bool> (!loops.empty()) ? void (0) : __assert_fail
("!loops.empty()", "flang/lib/Lower/ConvertExpr.cpp", 4264, __extension__
__PRETTY_FUNCTION__))
;
4265 builder.setInsertionPointToStart(loops.back().getBody());
4266 }
4267 fir::DoLoopOp loop;
4268 if (innerArg) {
4269 loop = builder.create<fir::DoLoopOp>(
4270 loc, zero, i.value(), one, isUnordered(),
4271 /*finalCount=*/false, mlir::ValueRange{innerArg});
4272 innerArg = loop.getRegionIterArgs().front();
4273 if (explicitSpaceIsActive())
4274 explicitSpace->setInnerArg(0, innerArg);
4275 } else {
4276 loop = builder.create<fir::DoLoopOp>(loc, zero, i.value(), one,
4277 isUnordered(),
4278 /*finalCount=*/false);
4279 }
4280 ivars.push_back(loop.getInductionVar());
4281 loops.push_back(loop);
4282 }
4283
4284 if (innerArg)
4285 for (std::remove_const_t<decltype(loopDepth)> i = 0; i + 1 < loopDepth;
4286 ++i) {
4287 builder.setInsertionPointToEnd(loops[i].getBody());
4288 builder.create<fir::ResultOp>(loc, loops[i + 1].getResult(0));
4289 }
4290
4291 // Move insertion point to the start of the innermost loop in the nest.
4292 builder.setInsertionPointToStart(loops.back().getBody());
4293 // Set `afterLoopNest` to just after the entire loop nest.
4294 auto currPt = builder.saveInsertionPoint();
4295 builder.setInsertionPointAfter(loops[0]);
4296 auto afterLoopNest = builder.saveInsertionPoint();
4297 builder.restoreInsertionPoint(currPt);
4298
4299 // Put the implicit loop variables in row to column order to match FIR's
4300 // Ops. (The loops were constructed from outermost column to innermost
4301 // row.)
4302 mlir::Value outerRes;
4303 if (loops[0].getNumResults() != 0)
4304 outerRes = loops[0].getResult(0);
4305 return {IterationSpace(innerArg, outerRes, llvm::reverse(ivars)),
4306 afterLoopNest};
4307 }
4308
4309 /// Build the iteration space into which the array expression will be lowered.
4310 /// The resultType is used to create a temporary, if needed.
4311 std::pair<IterationSpace, mlir::OpBuilder::InsertPoint>
4312 genIterSpace(mlir::Type resultType) {
4313 mlir::Location loc = getLoc();
4314 llvm::SmallVector<mlir::Value> shape = genIterationShape();
4315 if (!destination) {
4316 // Allocate storage for the result if it is not already provided.
4317 destination = createAndLoadSomeArrayTemp(resultType, shape);
4318 }
4319
4320 // Generate the lazy mask allocation, if one was given.
4321 if (ccPrelude)
4322 (*ccPrelude)(shape);
4323
4324 // Now handle the implicit loops.
4325 mlir::Value inner = explicitSpaceIsActive()
4326 ? explicitSpace->getInnerArgs().front()
4327 : destination.getResult();
4328 auto [iters, afterLoopNest] = genImplicitLoops(shape, inner);
4329 mlir::Value innerArg = iters.innerArgument();
4330
4331 // Generate the mask conditional structure, if there are masks. Unlike the
4332 // explicit masks, which are interleaved, these mask expression appear in
4333 // the innermost loop.
4334 if (implicitSpaceHasMasks()) {
4335 // Recover the cached condition from the mask buffer.
4336 auto genCond = [&](Fortran::lower::FrontEndExpr e, IterSpace iters) {
4337 return implicitSpace->getBoundClosure(e)(iters);
4338 };
4339
4340 // Handle the negated conditions in topological order of the WHERE
4341 // clauses. See 10.2.3.2p4 as to why this control structure is produced.
4342 for (llvm::SmallVector<Fortran::lower::FrontEndExpr> maskExprs :
4343 implicitSpace->getMasks()) {
4344 const std::size_t size = maskExprs.size() - 1;
4345 auto genFalseBlock = [&](const auto *e, auto &&cond) {
4346 auto ifOp = builder.create<fir::IfOp>(
4347 loc, mlir::TypeRange{innerArg.getType()}, fir::getBase(cond),
4348 /*withElseRegion=*/true);
4349 builder.create<fir::ResultOp>(loc, ifOp.getResult(0));
4350 builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
4351 builder.create<fir::ResultOp>(loc, innerArg);
4352 builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
4353 };
4354 auto genTrueBlock = [&](const auto *e, auto &&cond) {
4355 auto ifOp = builder.create<fir::IfOp>(
4356 loc, mlir::TypeRange{innerArg.getType()}, fir::getBase(cond),
4357 /*withElseRegion=*/true);
4358 builder.create<fir::ResultOp>(loc, ifOp.getResult(0));
4359 builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
4360 builder.create<fir::ResultOp>(loc, innerArg);
4361 builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
4362 };
4363 for (std::remove_const_t<decltype(size)> i = 0; i < size; ++i)
4364 if (const auto *e = maskExprs[i])
4365 genFalseBlock(e, genCond(e, iters));
4366
4367 // The last condition is either non-negated or unconditionally negated.
4368 if (const auto *e = maskExprs[size])
4369 genTrueBlock(e, genCond(e, iters));
4370 }
4371 }
4372
4373 // We're ready to lower the body (an assignment statement) for this context
4374 // of loop nests at this point.
4375 return {iters, afterLoopNest};
4376 }
4377
4378 fir::ArrayLoadOp
4379 createAndLoadSomeArrayTemp(mlir::Type type,
4380 llvm::ArrayRef<mlir::Value> shape) {
4381 mlir::Location loc = getLoc();
4382 if (fir::isPolymorphicType(type))
4383 TODO(loc, "polymorphic array temporary")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "4383" ": not yet implemented: ") + llvm::Twine("polymorphic array temporary"
), false); } while (false)
;
4384 if (ccLoadDest)
4385 return (*ccLoadDest)(shape);
4386 auto seqTy = type.dyn_cast<fir::SequenceType>();
4387 assert(seqTy && "must be an array")(static_cast <bool> (seqTy && "must be an array"
) ? void (0) : __assert_fail ("seqTy && \"must be an array\""
, "flang/lib/Lower/ConvertExpr.cpp", 4387, __extension__ __PRETTY_FUNCTION__
))
;
4388 // TODO: Need to thread the LEN parameters here. For character, they may
4389 // differ from the operands length (e.g concatenation). So the array loads
4390 // type parameters are not enough.
4391 if (auto charTy = seqTy.getEleTy().dyn_cast<fir::CharacterType>())
4392 if (charTy.hasDynamicLen())
4393 TODO(loc, "character array expression temp with dynamic length")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "4393" ": not yet implemented: ") + llvm::Twine("character array expression temp with dynamic length"
), false); } while (false)
;
4394 if (auto recTy = seqTy.getEleTy().dyn_cast<fir::RecordType>())
4395 if (recTy.getNumLenParams() > 0)
4396 TODO(loc, "derived type array expression temp with LEN parameters")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "4396" ": not yet implemented: ") + llvm::Twine("derived type array expression temp with LEN parameters"
), false); } while (false)
;
4397 if (mlir::Type eleTy = fir::unwrapSequenceType(type);
4398 fir::isRecordWithAllocatableMember(eleTy))
4399 TODO(loc, "creating an array temp where the element type has "do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "4400" ": not yet implemented: ") + llvm::Twine("creating an array temp where the element type has "
"allocatable members"), false); } while (false)
4400 "allocatable members")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "4400" ": not yet implemented: ") + llvm::Twine("creating an array temp where the element type has "
"allocatable members"), false); } while (false)
;
4401 mlir::Value temp = !seqTy.hasDynamicExtents()
4402 ? builder.create<fir::AllocMemOp>(loc, type)
4403 : builder.create<fir::AllocMemOp>(
4404 loc, type, ".array.expr", std::nullopt, shape);
4405 fir::FirOpBuilder *bldr = &converter.getFirOpBuilder();
4406 stmtCtx.attachCleanup(
4407 [bldr, loc, temp]() { bldr->create<fir::FreeMemOp>(loc, temp); });
4408 mlir::Value shapeOp = genShapeOp(shape);
4409 return builder.create<fir::ArrayLoadOp>(loc, seqTy, temp, shapeOp,
4410 /*slice=*/mlir::Value{},
4411 std::nullopt);
4412 }
4413
4414 static fir::ShapeOp genShapeOp(mlir::Location loc, fir::FirOpBuilder &builder,
4415 llvm::ArrayRef<mlir::Value> shape) {
4416 mlir::IndexType idxTy = builder.getIndexType();
4417 llvm::SmallVector<mlir::Value> idxShape;
4418 for (auto s : shape)
4419 idxShape.push_back(builder.createConvert(loc, idxTy, s));
4420 return builder.create<fir::ShapeOp>(loc, idxShape);
4421 }
4422
4423 fir::ShapeOp genShapeOp(llvm::ArrayRef<mlir::Value> shape) {
4424 return genShapeOp(getLoc(), builder, shape);
4425 }
4426
4427 //===--------------------------------------------------------------------===//
4428 // Expression traversal and lowering.
4429 //===--------------------------------------------------------------------===//
4430
4431 /// Lower the expression, \p x, in a scalar context.
4432 template <typename A>
4433 ExtValue asScalar(const A &x) {
4434 return ScalarExprLowering{getLoc(), converter, symMap, stmtCtx}.genval(x);
4435 }
4436
4437 /// Lower the expression, \p x, in a scalar context. If this is an explicit
4438 /// space, the expression may be scalar and refer to an array. We want to
4439 /// raise the array access to array operations in FIR to analyze potential
4440 /// conflicts even when the result is a scalar element.
4441 template <typename A>
4442 ExtValue asScalarArray(const A &x) {
4443 return explicitSpaceIsActive() && !isPointerAssignment()
4444 ? genarr(x)(IterationSpace{})
4445 : asScalar(x);
4446 }
4447
4448 /// Lower the expression in a scalar context to a memory reference.
4449 template <typename A>
4450 ExtValue asScalarRef(const A &x) {
4451 return ScalarExprLowering{getLoc(), converter, symMap, stmtCtx}.gen(x);
4452 }
4453
4454 /// Lower an expression without dereferencing any indirection that may be
4455 /// a nullptr (because this is an absent optional or unallocated/disassociated
4456 /// descriptor). The returned expression cannot be addressed directly, it is
4457 /// meant to inquire about its status before addressing the related entity.
4458 template <typename A>
4459 ExtValue asInquired(const A &x) {
4460 return ScalarExprLowering{getLoc(), converter, symMap, stmtCtx}
4461 .lowerIntrinsicArgumentAsInquired(x);
4462 }
4463
4464 /// Some temporaries are allocated on an element-by-element basis during the
4465 /// array expression evaluation. Collect the cleanups here so the resources
4466 /// can be freed before the next loop iteration, avoiding memory leaks. etc.
4467 Fortran::lower::StatementContext &getElementCtx() {
4468 if (!elementCtx) {
4469 stmtCtx.pushScope();
4470 elementCtx = true;
4471 }
4472 return stmtCtx;
4473 }
4474
4475 /// If there were temporaries created for this element evaluation, finalize
4476 /// and deallocate the resources now. This should be done just prior the the
4477 /// fir::ResultOp at the end of the innermost loop.
4478 void finalizeElementCtx() {
4479 if (elementCtx) {
4480 stmtCtx.finalizeAndPop();
4481 elementCtx = false;
4482 }
4483 }
4484
4485 /// Lower an elemental function array argument. This ensures array
4486 /// sub-expressions that are not variables and must be passed by address
4487 /// are lowered by value and placed in memory.
4488 template <typename A>
4489 CC genElementalArgument(const A &x) {
4490 // Ensure the returned element is in memory if this is what was requested.
4491 if ((semant == ConstituentSemantics::RefOpaque ||
4492 semant == ConstituentSemantics::DataAddr ||
4493 semant == ConstituentSemantics::ByValueArg)) {
4494 if (!Fortran::evaluate::IsVariable(x)) {
4495 PushSemantics(ConstituentSemantics::DataValue)[[maybe_unused]] auto pushSemanticsLocalVariable__LINE__ = Fortran
::common::ScopedSet(semant, ConstituentSemantics::DataValue);
;
4496 CC cc = genarr(x);
4497 mlir::Location loc = getLoc();
4498 if (isParenthesizedVariable(x)) {
4499 // Parenthesised variables are lowered to a reference to the variable
4500 // storage. When passing it as an argument, a copy must be passed.
4501 return [=](IterSpace iters) -> ExtValue {
4502 return createInMemoryScalarCopy(builder, loc, cc(iters));
4503 };
4504 }
4505 mlir::Type storageType =
4506 fir::unwrapSequenceType(converter.genType(toEvExpr(x)));
4507 return [=](IterSpace iters) -> ExtValue {
4508 return placeScalarValueInMemory(builder, loc, cc(iters), storageType);
4509 };
4510 }
4511 }
4512 return genarr(x);
4513 }
4514
4515 // A reference to a Fortran elemental intrinsic or intrinsic module procedure.
4516 CC genElementalIntrinsicProcRef(
4517 const Fortran::evaluate::ProcedureRef &procRef,
4518 std::optional<mlir::Type> retTy,
4519 std::optional<const Fortran::evaluate::SpecificIntrinsic> intrinsic =
4520 std::nullopt) {
4521
4522 llvm::SmallVector<CC> operands;
4523 std::string name =
4524 intrinsic ? intrinsic->name
4525 : procRef.proc().GetSymbol()->GetUltimate().name().ToString();
4526 const fir::IntrinsicArgumentLoweringRules *argLowering =
4527 fir::getIntrinsicArgumentLowering(name);
4528 mlir::Location loc = getLoc();
4529 if (intrinsic && Fortran::lower::intrinsicRequiresCustomOptionalHandling(
4530 procRef, *intrinsic, converter)) {
4531 using CcPairT = std::pair<CC, std::optional<mlir::Value>>;
4532 llvm::SmallVector<CcPairT> operands;
4533 auto prepareOptionalArg = [&](const Fortran::lower::SomeExpr &expr) {
4534 if (expr.Rank() == 0) {
4535 ExtValue optionalArg = this->asInquired(expr);
4536 mlir::Value isPresent =
4537 genActualIsPresentTest(builder, loc, optionalArg);
4538 operands.emplace_back(
4539 [=](IterSpace iters) -> ExtValue {
4540 return genLoad(builder, loc, optionalArg);
4541 },
4542 isPresent);
4543 } else {
4544 auto [cc, isPresent, _] = this->genOptionalArrayFetch(expr);
4545 operands.emplace_back(cc, isPresent);
4546 }
4547 };
4548 auto prepareOtherArg = [&](const Fortran::lower::SomeExpr &expr,
4549 fir::LowerIntrinsicArgAs lowerAs) {
4550 assert(lowerAs == fir::LowerIntrinsicArgAs::Value &&(static_cast <bool> (lowerAs == fir::LowerIntrinsicArgAs
::Value && "expect value arguments for elemental intrinsic"
) ? void (0) : __assert_fail ("lowerAs == fir::LowerIntrinsicArgAs::Value && \"expect value arguments for elemental intrinsic\""
, "flang/lib/Lower/ConvertExpr.cpp", 4551, __extension__ __PRETTY_FUNCTION__
))
4551 "expect value arguments for elemental intrinsic")(static_cast <bool> (lowerAs == fir::LowerIntrinsicArgAs
::Value && "expect value arguments for elemental intrinsic"
) ? void (0) : __assert_fail ("lowerAs == fir::LowerIntrinsicArgAs::Value && \"expect value arguments for elemental intrinsic\""
, "flang/lib/Lower/ConvertExpr.cpp", 4551, __extension__ __PRETTY_FUNCTION__
))
;
4552 PushSemantics(ConstituentSemantics::RefTransparent)[[maybe_unused]] auto pushSemanticsLocalVariable__LINE__ = Fortran
::common::ScopedSet(semant, ConstituentSemantics::RefTransparent
);
;
4553 operands.emplace_back(genElementalArgument(expr), std::nullopt);
4554 };
4555 Fortran::lower::prepareCustomIntrinsicArgument(
4556 procRef, *intrinsic, retTy, prepareOptionalArg, prepareOtherArg,
4557 converter);
4558
4559 fir::FirOpBuilder *bldr = &converter.getFirOpBuilder();
4560 return [=](IterSpace iters) -> ExtValue {
4561 auto getArgument = [&](std::size_t i, bool) -> ExtValue {
4562 return operands[i].first(iters);
4563 };
4564 auto isPresent = [&](std::size_t i) -> std::optional<mlir::Value> {
4565 return operands[i].second;
4566 };
4567 return Fortran::lower::lowerCustomIntrinsic(
4568 *bldr, loc, name, retTy, isPresent, getArgument, operands.size(),
4569 getElementCtx());
4570 };
4571 }
4572 /// Otherwise, pre-lower arguments and use intrinsic lowering utility.
4573 for (const auto &arg : llvm::enumerate(procRef.arguments())) {
4574 const auto *expr =
4575 Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
4576 if (!expr) {
4577 // Absent optional.
4578 operands.emplace_back([=](IterSpace) { return mlir::Value{}; });
4579 } else if (!argLowering) {
4580 // No argument lowering instruction, lower by value.
4581 PushSemantics(ConstituentSemantics::RefTransparent)[[maybe_unused]] auto pushSemanticsLocalVariable__LINE__ = Fortran
::common::ScopedSet(semant, ConstituentSemantics::RefTransparent
);
;
4582 operands.emplace_back(genElementalArgument(*expr));
4583 } else {
4584 // Ad-hoc argument lowering handling.
4585 fir::ArgLoweringRule argRules =
4586 fir::lowerIntrinsicArgumentAs(*argLowering, arg.index());
4587 if (argRules.handleDynamicOptional &&
4588 Fortran::evaluate::MayBePassedAsAbsentOptional(
4589 *expr, converter.getFoldingContext())) {
4590 // Currently, there is not elemental intrinsic that requires lowering
4591 // a potentially absent argument to something else than a value (apart
4592 // from character MAX/MIN that are handled elsewhere.)
4593 if (argRules.lowerAs != fir::LowerIntrinsicArgAs::Value)
4594 TODO(loc, "non trivial optional elemental intrinsic array "do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "4595" ": not yet implemented: ") + llvm::Twine("non trivial optional elemental intrinsic array "
"argument"), false); } while (false)
4595 "argument")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "4595" ": not yet implemented: ") + llvm::Twine("non trivial optional elemental intrinsic array "
"argument"), false); } while (false)
;
4596 PushSemantics(ConstituentSemantics::RefTransparent)[[maybe_unused]] auto pushSemanticsLocalVariable__LINE__ = Fortran
::common::ScopedSet(semant, ConstituentSemantics::RefTransparent
);
;
4597 operands.emplace_back(genarrForwardOptionalArgumentToCall(*expr));
4598 continue;
4599 }
4600 switch (argRules.lowerAs) {
4601 case fir::LowerIntrinsicArgAs::Value: {
4602 PushSemantics(ConstituentSemantics::RefTransparent)[[maybe_unused]] auto pushSemanticsLocalVariable__LINE__ = Fortran
::common::ScopedSet(semant, ConstituentSemantics::RefTransparent
);
;
4603 operands.emplace_back(genElementalArgument(*expr));
4604 } break;
4605 case fir::LowerIntrinsicArgAs::Addr: {
4606 // Note: assume does not have Fortran VALUE attribute semantics.
4607 PushSemantics(ConstituentSemantics::RefOpaque)[[maybe_unused]] auto pushSemanticsLocalVariable__LINE__ = Fortran
::common::ScopedSet(semant, ConstituentSemantics::RefOpaque);
;
4608 operands.emplace_back(genElementalArgument(*expr));
4609 } break;
4610 case fir::LowerIntrinsicArgAs::Box: {
4611 PushSemantics(ConstituentSemantics::RefOpaque)[[maybe_unused]] auto pushSemanticsLocalVariable__LINE__ = Fortran
::common::ScopedSet(semant, ConstituentSemantics::RefOpaque);
;
4612 auto lambda = genElementalArgument(*expr);
4613 operands.emplace_back([=](IterSpace iters) {
4614 return builder.createBox(loc, lambda(iters));
4615 });
4616 } break;
4617 case fir::LowerIntrinsicArgAs::Inquired:
4618 TODO(loc, "intrinsic function with inquired argument")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "4618" ": not yet implemented: ") + llvm::Twine("intrinsic function with inquired argument"
), false); } while (false)
;
4619 break;
4620 }
4621 }
4622 }
4623
4624 // Let the intrinsic library lower the intrinsic procedure call
4625 return [=](IterSpace iters) {
4626 llvm::SmallVector<ExtValue> args;
4627 for (const auto &cc : operands)
4628 args.push_back(cc(iters));
4629 return Fortran::lower::genIntrinsicCall(builder, loc, name, retTy, args,
4630 getElementCtx());
4631 };
4632 }
4633
4634 /// Lower a procedure reference to a user-defined elemental procedure.
4635 CC genElementalUserDefinedProcRef(
4636 const Fortran::evaluate::ProcedureRef &procRef,
4637 std::optional<mlir::Type> retTy) {
4638 using PassBy = Fortran::lower::CallerInterface::PassEntityBy;
4639
4640 // 10.1.4 p5. Impure elemental procedures must be called in element order.
4641 if (const Fortran::semantics::Symbol *procSym = procRef.proc().GetSymbol())
4642 if (!Fortran::semantics::IsPureProcedure(*procSym))
4643 setUnordered(false);
4644
4645 Fortran::lower::CallerInterface caller(procRef, converter);
4646 llvm::SmallVector<CC> operands;
4647 operands.reserve(caller.getPassedArguments().size());
4648 mlir::Location loc = getLoc();
4649 mlir::FunctionType callSiteType = caller.genFunctionType();
4650 for (const Fortran::lower::CallInterface<
4651 Fortran::lower::CallerInterface>::PassedEntity &arg :
4652 caller.getPassedArguments()) {
4653 // 15.8.3 p1. Elemental procedure with intent(out)/intent(inout)
4654 // arguments must be called in element order.
4655 if (arg.mayBeModifiedByCall())
4656 setUnordered(false);
4657 const auto *actual = arg.entity;
4658 mlir::Type argTy = callSiteType.getInput(arg.firArgument);
4659 if (!actual) {
4660 // Optional dummy argument for which there is no actual argument.
4661 auto absent = builder.create<fir::AbsentOp>(loc, argTy);
4662 operands.emplace_back([=](IterSpace) { return absent; });
4663 continue;
4664 }
4665 const auto *expr = actual->UnwrapExpr();
4666 if (!expr)
4667 TODO(loc, "assumed type actual argument")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "4667" ": not yet implemented: ") + llvm::Twine("assumed type actual argument"
), false); } while (false)
;
4668
4669 LLVM_DEBUG(expr->AsFortran(llvm::dbgs()do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { expr->AsFortran(llvm::dbgs() <<
"argument: " << arg.firArgument << " = [") <<
"]\n"; } } while (false)
4670 << "argument: " << arg.firArgument << " = [")do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { expr->AsFortran(llvm::dbgs() <<
"argument: " << arg.firArgument << " = [") <<
"]\n"; } } while (false)
4671 << "]\n")do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { expr->AsFortran(llvm::dbgs() <<
"argument: " << arg.firArgument << " = [") <<
"]\n"; } } while (false)
;
4672 if (arg.isOptional() && Fortran::evaluate::MayBePassedAsAbsentOptional(
4673 *expr, converter.getFoldingContext()))
4674 TODO(loc,do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "4675" ": not yet implemented: ") + llvm::Twine("passing dynamically optional argument to elemental procedures"
), false); } while (false)
4675 "passing dynamically optional argument to elemental procedures")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "4675" ": not yet implemented: ") + llvm::Twine("passing dynamically optional argument to elemental procedures"
), false); } while (false)
;
4676 switch (arg.passBy) {
4677 case PassBy::Value: {
4678 // True pass-by-value semantics.
4679 PushSemantics(ConstituentSemantics::RefTransparent)[[maybe_unused]] auto pushSemanticsLocalVariable__LINE__ = Fortran
::common::ScopedSet(semant, ConstituentSemantics::RefTransparent
);
;
4680 operands.emplace_back(genElementalArgument(*expr));
4681 } break;
4682 case PassBy::BaseAddressValueAttribute: {
4683 // VALUE attribute or pass-by-reference to a copy semantics. (byval*)
4684 if (isArray(*expr)) {
4685 PushSemantics(ConstituentSemantics::ByValueArg)[[maybe_unused]] auto pushSemanticsLocalVariable__LINE__ = Fortran
::common::ScopedSet(semant, ConstituentSemantics::ByValueArg)
;
;
4686 operands.emplace_back(genElementalArgument(*expr));
4687 } else {
4688 // Store scalar value in a temp to fulfill VALUE attribute.
4689 mlir::Value val = fir::getBase(asScalar(*expr));
4690 mlir::Value temp = builder.createTemporary(
4691 loc, val.getType(),
4692 llvm::ArrayRef<mlir::NamedAttribute>{
4693 Fortran::lower::getAdaptToByRefAttr(builder)});
4694 builder.create<fir::StoreOp>(loc, val, temp);
4695 operands.emplace_back(
4696 [=](IterSpace iters) -> ExtValue { return temp; });
4697 }
4698 } break;
4699 case PassBy::BaseAddress: {
4700 if (isArray(*expr)) {
4701 PushSemantics(ConstituentSemantics::RefOpaque)[[maybe_unused]] auto pushSemanticsLocalVariable__LINE__ = Fortran
::common::ScopedSet(semant, ConstituentSemantics::RefOpaque);
;
4702 operands.emplace_back(genElementalArgument(*expr));
4703 } else {
4704 ExtValue exv = asScalarRef(*expr);
4705 operands.emplace_back([=](IterSpace iters) { return exv; });
4706 }
4707 } break;
4708 case PassBy::CharBoxValueAttribute: {
4709 if (isArray(*expr)) {
4710 PushSemantics(ConstituentSemantics::DataValue)[[maybe_unused]] auto pushSemanticsLocalVariable__LINE__ = Fortran
::common::ScopedSet(semant, ConstituentSemantics::DataValue);
;
4711 auto lambda = genElementalArgument(*expr);
4712 operands.emplace_back([=](IterSpace iters) {
4713 return fir::factory::CharacterExprHelper{builder, loc}
4714 .createTempFrom(lambda(iters));
4715 });
4716 } else {
4717 fir::factory::CharacterExprHelper helper(builder, loc);
4718 fir::CharBoxValue argVal = helper.createTempFrom(asScalarRef(*expr));
4719 operands.emplace_back(
4720 [=](IterSpace iters) -> ExtValue { return argVal; });
4721 }
4722 } break;
4723 case PassBy::BoxChar: {
4724 PushSemantics(ConstituentSemantics::RefOpaque)[[maybe_unused]] auto pushSemanticsLocalVariable__LINE__ = Fortran
::common::ScopedSet(semant, ConstituentSemantics::RefOpaque);
;
4725 operands.emplace_back(genElementalArgument(*expr));
4726 } break;
4727 case PassBy::AddressAndLength:
4728 // PassBy::AddressAndLength is only used for character results. Results
4729 // are not handled here.
4730 fir::emitFatalError(
4731 loc, "unexpected PassBy::AddressAndLength in elemental call");
4732 break;
4733 case PassBy::CharProcTuple: {
4734 ExtValue argRef = asScalarRef(*expr);
4735 mlir::Value tuple = createBoxProcCharTuple(
4736 converter, argTy, fir::getBase(argRef), fir::getLen(argRef));
4737 operands.emplace_back(
4738 [=](IterSpace iters) -> ExtValue { return tuple; });
4739 } break;
4740 case PassBy::Box:
4741 case PassBy::MutableBox:
4742 // Handle polymorphic passed object.
4743 if (fir::isPolymorphicType(argTy)) {
4744 if (isArray(*expr)) {
4745 ExtValue exv = asScalarRef(*expr);
4746 mlir::Value sourceBox;
4747 if (fir::isPolymorphicType(fir::getBase(exv).getType()))
4748 sourceBox = fir::getBase(exv);
4749 mlir::Type baseTy =
4750 fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(exv).getType());
4751 mlir::Type innerTy = fir::unwrapSequenceType(baseTy);
4752 operands.emplace_back([=](IterSpace iters) -> ExtValue {
4753 mlir::Value coord = builder.create<fir::CoordinateOp>(
4754 loc, fir::ReferenceType::get(innerTy), fir::getBase(exv),
4755 iters.iterVec());
4756 mlir::Value empty;
4757 mlir::ValueRange emptyRange;
4758 return builder.create<fir::EmboxOp>(
4759 loc, fir::ClassType::get(innerTy), coord, empty, empty,
4760 emptyRange, sourceBox);
4761 });
4762 } else {
4763 ExtValue exv = asScalarRef(*expr);
4764 if (fir::getBase(exv).getType().isa<fir::BaseBoxType>()) {
4765 operands.emplace_back(
4766 [=](IterSpace iters) -> ExtValue { return exv; });
4767 } else {
4768 mlir::Type baseTy =
4769 fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(exv).getType());
4770 operands.emplace_back([=](IterSpace iters) -> ExtValue {
4771 mlir::Value empty;
4772 mlir::ValueRange emptyRange;
4773 return builder.create<fir::EmboxOp>(
4774 loc, fir::ClassType::get(baseTy), fir::getBase(exv), empty,
4775 empty, emptyRange);
4776 });
4777 }
4778 }
4779 break;
4780 }
4781 // See C15100 and C15101
4782 fir::emitFatalError(loc, "cannot be POINTER, ALLOCATABLE");
4783 }
4784 }
4785
4786 if (caller.getIfIndirectCallSymbol())
4787 fir::emitFatalError(loc, "cannot be indirect call");
4788
4789 // The lambda is mutable so that `caller` copy can be modified inside it.
4790 return [=,
4791 caller = std::move(caller)](IterSpace iters) mutable -> ExtValue {
4792 for (const auto &[cc, argIface] :
4793 llvm::zip(operands, caller.getPassedArguments())) {
4794 auto exv = cc(iters);
4795 auto arg = exv.match(
4796 [&](const fir::CharBoxValue &cb) -> mlir::Value {
4797 return fir::factory::CharacterExprHelper{builder, loc}
4798 .createEmbox(cb);
4799 },
4800 [&](const auto &) { return fir::getBase(exv); });
4801 caller.placeInput(argIface, arg);
4802 }
4803 return Fortran::lower::genCallOpAndResult(
4804 loc, converter, symMap, getElementCtx(), caller, callSiteType, retTy);
4805 };
4806 }
4807
4808 /// Lower TRANSPOSE call without using runtime TRANSPOSE.
4809 /// Return continuation for generating the TRANSPOSE result.
4810 /// The continuation just swaps the iteration space before
4811 /// invoking continuation for the argument.
4812 CC genTransposeProcRef(const Fortran::evaluate::ProcedureRef &procRef) {
4813 assert(procRef.arguments().size() == 1 &&(static_cast <bool> (procRef.arguments().size() == 1 &&
"TRANSPOSE must have one argument.") ? void (0) : __assert_fail
("procRef.arguments().size() == 1 && \"TRANSPOSE must have one argument.\""
, "flang/lib/Lower/ConvertExpr.cpp", 4814, __extension__ __PRETTY_FUNCTION__
))
4814 "TRANSPOSE must have one argument.")(static_cast <bool> (procRef.arguments().size() == 1 &&
"TRANSPOSE must have one argument.") ? void (0) : __assert_fail
("procRef.arguments().size() == 1 && \"TRANSPOSE must have one argument.\""
, "flang/lib/Lower/ConvertExpr.cpp", 4814, __extension__ __PRETTY_FUNCTION__
))
;
4815 const auto *argExpr = procRef.arguments()[0].value().UnwrapExpr();
4816 assert(argExpr)(static_cast <bool> (argExpr) ? void (0) : __assert_fail
("argExpr", "flang/lib/Lower/ConvertExpr.cpp", 4816, __extension__
__PRETTY_FUNCTION__))
;
4817
4818 llvm::SmallVector<mlir::Value> savedDestShape = destShape;
4819 assert((destShape.empty() || destShape.size() == 2) &&(static_cast <bool> ((destShape.empty() || destShape.size
() == 2) && "TRANSPOSE destination must have rank 2."
) ? void (0) : __assert_fail ("(destShape.empty() || destShape.size() == 2) && \"TRANSPOSE destination must have rank 2.\""
, "flang/lib/Lower/ConvertExpr.cpp", 4820, __extension__ __PRETTY_FUNCTION__
))
4820 "TRANSPOSE destination must have rank 2.")(static_cast <bool> ((destShape.empty() || destShape.size
() == 2) && "TRANSPOSE destination must have rank 2."
) ? void (0) : __assert_fail ("(destShape.empty() || destShape.size() == 2) && \"TRANSPOSE destination must have rank 2.\""
, "flang/lib/Lower/ConvertExpr.cpp", 4820, __extension__ __PRETTY_FUNCTION__
))
;
4821
4822 if (!savedDestShape.empty())
4823 std::swap(destShape[0], destShape[1]);
4824
4825 PushSemantics(ConstituentSemantics::RefTransparent)[[maybe_unused]] auto pushSemanticsLocalVariable__LINE__ = Fortran
::common::ScopedSet(semant, ConstituentSemantics::RefTransparent
);
;
4826 llvm::SmallVector<CC> operands{genElementalArgument(*argExpr)};
4827
4828 if (!savedDestShape.empty()) {
4829 // If destShape was set before transpose lowering, then
4830 // restore it. Otherwise, ...
4831 destShape = savedDestShape;
4832 } else if (!destShape.empty()) {
4833 // ... if destShape has been set from the argument lowering,
4834 // then reverse it.
4835 assert(destShape.size() == 2 &&(static_cast <bool> (destShape.size() == 2 && "TRANSPOSE destination must have rank 2."
) ? void (0) : __assert_fail ("destShape.size() == 2 && \"TRANSPOSE destination must have rank 2.\""
, "flang/lib/Lower/ConvertExpr.cpp", 4836, __extension__ __PRETTY_FUNCTION__
))
4836 "TRANSPOSE destination must have rank 2.")(static_cast <bool> (destShape.size() == 2 && "TRANSPOSE destination must have rank 2."
) ? void (0) : __assert_fail ("destShape.size() == 2 && \"TRANSPOSE destination must have rank 2.\""
, "flang/lib/Lower/ConvertExpr.cpp", 4836, __extension__ __PRETTY_FUNCTION__
))
;
4837 std::swap(destShape[0], destShape[1]);
4838 }
4839
4840 return [=](IterSpace iters) {
4841 assert(iters.iterVec().size() == 2 &&(static_cast <bool> (iters.iterVec().size() == 2 &&
"TRANSPOSE expects 2D iterations space.") ? void (0) : __assert_fail
("iters.iterVec().size() == 2 && \"TRANSPOSE expects 2D iterations space.\""
, "flang/lib/Lower/ConvertExpr.cpp", 4842, __extension__ __PRETTY_FUNCTION__
))
4842 "TRANSPOSE expects 2D iterations space.")(static_cast <bool> (iters.iterVec().size() == 2 &&
"TRANSPOSE expects 2D iterations space.") ? void (0) : __assert_fail
("iters.iterVec().size() == 2 && \"TRANSPOSE expects 2D iterations space.\""
, "flang/lib/Lower/ConvertExpr.cpp", 4842, __extension__ __PRETTY_FUNCTION__
))
;
4843 IterationSpace newIters(iters, {iters.iterValue(1), iters.iterValue(0)});
4844 return operands.front()(newIters);
4845 };
4846 }
4847
4848 /// Generate a procedure reference. This code is shared for both functions and
4849 /// subroutines, the difference being reflected by `retTy`.
4850 CC genProcRef(const Fortran::evaluate::ProcedureRef &procRef,
4851 std::optional<mlir::Type> retTy) {
4852 mlir::Location loc = getLoc();
4853 setLoweredProcRef(&procRef);
4854
4855 if (isOptimizableTranspose(procRef, converter))
4856 return genTransposeProcRef(procRef);
4857
4858 if (procRef.IsElemental()) {
4859 if (const Fortran::evaluate::SpecificIntrinsic *intrin =
4860 procRef.proc().GetSpecificIntrinsic()) {
4861 // All elemental intrinsic functions are pure and cannot modify their
4862 // arguments. The only elemental subroutine, MVBITS has an Intent(inout)
4863 // argument. So for this last one, loops must be in element order
4864 // according to 15.8.3 p1.
4865 if (!retTy)
4866 setUnordered(false);
4867
4868 // Elemental intrinsic call.
4869 // The intrinsic procedure is called once per element of the array.
4870 return genElementalIntrinsicProcRef(procRef, retTy, *intrin);
4871 }
4872 if (Fortran::lower::isIntrinsicModuleProcRef(procRef))
4873 return genElementalIntrinsicProcRef(procRef, retTy);
4874 if (ScalarExprLowering::isStatementFunctionCall(procRef))
4875 fir::emitFatalError(loc, "statement function cannot be elemental");
4876
4877 // Elemental call.
4878 // The procedure is called once per element of the array argument(s).
4879 return genElementalUserDefinedProcRef(procRef, retTy);
4880 }
4881
4882 // Transformational call.
4883 // The procedure is called once and produces a value of rank > 0.
4884 if (const Fortran::evaluate::SpecificIntrinsic *intrinsic =
4885 procRef.proc().GetSpecificIntrinsic()) {
4886 if (explicitSpaceIsActive() && procRef.Rank() == 0) {
4887 // Elide any implicit loop iters.
4888 return [=, &procRef](IterSpace) {
4889 return ScalarExprLowering{loc, converter, symMap, stmtCtx}
4890 .genIntrinsicRef(procRef, retTy, *intrinsic);
4891 };
4892 }
4893 return genarr(
4894 ScalarExprLowering{loc, converter, symMap, stmtCtx}.genIntrinsicRef(
4895 procRef, retTy, *intrinsic));
4896 }
4897
4898 const bool isPtrAssn = isPointerAssignment();
4899 if (explicitSpaceIsActive() && procRef.Rank() == 0) {
4900 // Elide any implicit loop iters.
4901 return [=, &procRef](IterSpace) {
4902 ScalarExprLowering sel(loc, converter, symMap, stmtCtx);
4903 return isPtrAssn ? sel.genRawProcedureRef(procRef, retTy)
4904 : sel.genProcedureRef(procRef, retTy);
4905 };
4906 }
4907 // In the default case, the call can be hoisted out of the loop nest. Apply
4908 // the iterations to the result, which may be an array value.
4909 ScalarExprLowering sel(loc, converter, symMap, stmtCtx);
4910 auto exv = isPtrAssn ? sel.genRawProcedureRef(procRef, retTy)
4911 : sel.genProcedureRef(procRef, retTy);
4912 return genarr(exv);
4913 }
4914
4915 CC genarr(const Fortran::evaluate::ProcedureDesignator &) {
4916 TODO(getLoc(), "procedure designator")do { fir::emitFatalError(getLoc(), llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "4916" ": not yet implemented: ") + llvm::Twine("procedure designator"
), false); } while (false)
;
4917 }
4918 CC genarr(const Fortran::evaluate::ProcedureRef &x) {
4919 if (x.hasAlternateReturns())
4920 fir::emitFatalError(getLoc(),
4921 "array procedure reference with alt-return");
4922 return genProcRef(x, std::nullopt);
4923 }
4924 template <typename A>
4925 CC genScalarAndForwardValue(const A &x) {
4926 ExtValue result = asScalar(x);
4927 return [=](IterSpace) { return result; };
4928 }
4929 template <typename A, typename = std::enable_if_t<Fortran::common::HasMember<
4930 A, Fortran::evaluate::TypelessExpression>>>
4931 CC genarr(const A &x) {
4932 return genScalarAndForwardValue(x);
4933 }
4934
4935 template <typename A>
4936 CC genarr(const Fortran::evaluate::Expr<A> &x) {
4937 LLVM_DEBUG(Fortran::lower::DumpEvaluateExpr::dump(llvm::dbgs(), x))do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { Fortran::lower::DumpEvaluateExpr::dump
(llvm::dbgs(), x); } } while (false)
;
4938 if (isArray(x) || (explicitSpaceIsActive() && isLeftHandSide()) ||
4939 isElementalProcWithArrayArgs(x))
4940 return std::visit([&](const auto &e) { return genarr(e); }, x.u);
4941 if (explicitSpaceIsActive()) {
4942 assert(!isArray(x) && !isLeftHandSide())(static_cast <bool> (!isArray(x) && !isLeftHandSide
()) ? void (0) : __assert_fail ("!isArray(x) && !isLeftHandSide()"
, "flang/lib/Lower/ConvertExpr.cpp", 4942, __extension__ __PRETTY_FUNCTION__
))
;
4943 auto cc = std::visit([&](const auto &e) { return genarr(e); }, x.u);
4944 auto result = cc(IterationSpace{});
4945 return [=](IterSpace) { return result; };
4946 }
4947 return genScalarAndForwardValue(x);
4948 }
4949
4950 // Converting a value of memory bound type requires creating a temp and
4951 // copying the value.
4952 static ExtValue convertAdjustedType(fir::FirOpBuilder &builder,
4953 mlir::Location loc, mlir::Type toType,
4954 const ExtValue &exv) {
4955 return exv.match(
4956 [&](const fir::CharBoxValue &cb) -> ExtValue {
4957 mlir::Value len = cb.getLen();
4958 auto mem =
4959 builder.create<fir::AllocaOp>(loc, toType, mlir::ValueRange{len});
4960 fir::CharBoxValue result(mem, len);
4961 fir::factory::CharacterExprHelper{builder, loc}.createAssign(
4962 ExtValue{result}, exv);
4963 return result;
4964 },
4965 [&](const auto &) -> ExtValue {
4966 fir::emitFatalError(loc, "convert on adjusted extended value");
4967 });
4968 }
4969 template <Fortran::common::TypeCategory TC1, int KIND,
4970 Fortran::common::TypeCategory TC2>
4971 CC genarr(const Fortran::evaluate::Convert<Fortran::evaluate::Type<TC1, KIND>,
4972 TC2> &x) {
4973 mlir::Location loc = getLoc();
4974 auto lambda = genarr(x.left());
4975 mlir::Type ty = converter.genType(TC1, KIND);
4976 return [=](IterSpace iters) -> ExtValue {
4977 auto exv = lambda(iters);
4978 mlir::Value val = fir::getBase(exv);
4979 auto valTy = val.getType();
4980 if (elementTypeWasAdjusted(valTy) &&
4981 !(fir::isa_ref_type(valTy) && fir::isa_integer(ty)))
4982 return convertAdjustedType(builder, loc, ty, exv);
4983 return builder.createConvert(loc, ty, val);
4984 };
4985 }
4986
4987 template <int KIND>
4988 CC genarr(const Fortran::evaluate::ComplexComponent<KIND> &x) {
4989 mlir::Location loc = getLoc();
4990 auto lambda = genarr(x.left());
4991 bool isImagPart = x.isImaginaryPart;
4992 return [=](IterSpace iters) -> ExtValue {
4993 mlir::Value lhs = fir::getBase(lambda(iters));
4994 return fir::factory::Complex{builder, loc}.extractComplexPart(lhs,
4995 isImagPart);
4996 };
4997 }
4998
4999 template <typename T>
5000 CC genarr(const Fortran::evaluate::Parentheses<T> &x) {
5001 mlir::Location loc = getLoc();
5002 if (isReferentiallyOpaque()) {
5003 // Context is a call argument in, for example, an elemental procedure
5004 // call. TODO: all array arguments should use array_load, array_access,
5005 // array_amend, and INTENT(OUT), INTENT(INOUT) arguments should have
5006 // array_merge_store ops.
5007 TODO(loc, "parentheses on argument in elemental call")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "5007" ": not yet implemented: ") + llvm::Twine("parentheses on argument in elemental call"
), false); } while (false)
;
5008 }
5009 auto f = genarr(x.left());
5010 return [=](IterSpace iters) -> ExtValue {
5011 auto val = f(iters);
5012 mlir::Value base = fir::getBase(val);
5013 auto newBase =
5014 builder.create<fir::NoReassocOp>(loc, base.getType(), base);
5015 return fir::substBase(val, newBase);
5016 };
5017 }
5018 template <int KIND>
5019 CC genarr(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
5020 Fortran::common::TypeCategory::Integer, KIND>> &x) {
5021 mlir::Location loc = getLoc();
5022 auto f = genarr(x.left());
5023 return [=](IterSpace iters) -> ExtValue {
5024 mlir::Value val = fir::getBase(f(iters));
5025 mlir::Type ty =
5026 converter.genType(Fortran::common::TypeCategory::Integer, KIND);
5027 mlir::Value zero = builder.createIntegerConstant(loc, ty, 0);
5028 return builder.create<mlir::arith::SubIOp>(loc, zero, val);
5029 };
5030 }
5031 template <int KIND>
5032 CC genarr(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
5033 Fortran::common::TypeCategory::Real, KIND>> &x) {
5034 mlir::Location loc = getLoc();
5035 auto f = genarr(x.left());
5036 return [=](IterSpace iters) -> ExtValue {
5037 return builder.create<mlir::arith::NegFOp>(loc, fir::getBase(f(iters)));
5038 };
5039 }
5040 template <int KIND>
5041 CC genarr(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
5042 Fortran::common::TypeCategory::Complex, KIND>> &x) {
5043 mlir::Location loc = getLoc();
5044 auto f = genarr(x.left());
5045 return [=](IterSpace iters) -> ExtValue {
5046 return builder.create<fir::NegcOp>(loc, fir::getBase(f(iters)));
5047 };
5048 }
5049
5050 //===--------------------------------------------------------------------===//
5051 // Binary elemental ops
5052 //===--------------------------------------------------------------------===//
5053
5054 template <typename OP, typename A>
5055 CC createBinaryOp(const A &evEx) {
5056 mlir::Location loc = getLoc();
5057 auto lambda = genarr(evEx.left());
5058 auto rf = genarr(evEx.right());
5059 return [=](IterSpace iters) -> ExtValue {
5060 mlir::Value left = fir::getBase(lambda(iters));
5061 mlir::Value right = fir::getBase(rf(iters));
5062 return builder.create<OP>(loc, left, right);
5063 };
5064 }
5065
5066#undef GENBIN
5067#define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp)template <int KIND> CC genarr(const Fortran::evaluate::
GenBinEvOp<Fortran::evaluate::Type< Fortran::common::TypeCategory
::GenBinTyCat, KIND>> &x) { return createBinaryOp<
GenBinFirOp>(x); }
\
5068 template <int KIND> \
5069 CC genarr(const Fortran::evaluate::GenBinEvOp<Fortran::evaluate::Type< \
5070 Fortran::common::TypeCategory::GenBinTyCat, KIND>> &x) { \
5071 return createBinaryOp<GenBinFirOp>(x); \
5072 }
5073
5074 GENBIN(Add, Integer, mlir::arith::AddIOp)template <int KIND> CC genarr(const Fortran::evaluate::
Add<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Integer, KIND>> &x) { return createBinaryOp<mlir
::arith::AddIOp>(x); }
5075 GENBIN(Add, Real, mlir::arith::AddFOp)template <int KIND> CC genarr(const Fortran::evaluate::
Add<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Real, KIND>> &x) { return createBinaryOp<mlir::
arith::AddFOp>(x); }
5076 GENBIN(Add, Complex, fir::AddcOp)template <int KIND> CC genarr(const Fortran::evaluate::
Add<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Complex, KIND>> &x) { return createBinaryOp<fir
::AddcOp>(x); }
5077 GENBIN(Subtract, Integer, mlir::arith::SubIOp)template <int KIND> CC genarr(const Fortran::evaluate::
Subtract<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Integer, KIND>> &x) { return createBinaryOp<mlir
::arith::SubIOp>(x); }
5078 GENBIN(Subtract, Real, mlir::arith::SubFOp)template <int KIND> CC genarr(const Fortran::evaluate::
Subtract<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Real, KIND>> &x) { return createBinaryOp<mlir::
arith::SubFOp>(x); }
5079 GENBIN(Subtract, Complex, fir::SubcOp)template <int KIND> CC genarr(const Fortran::evaluate::
Subtract<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Complex, KIND>> &x) { return createBinaryOp<fir
::SubcOp>(x); }
5080 GENBIN(Multiply, Integer, mlir::arith::MulIOp)template <int KIND> CC genarr(const Fortran::evaluate::
Multiply<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Integer, KIND>> &x) { return createBinaryOp<mlir
::arith::MulIOp>(x); }
5081 GENBIN(Multiply, Real, mlir::arith::MulFOp)template <int KIND> CC genarr(const Fortran::evaluate::
Multiply<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Real, KIND>> &x) { return createBinaryOp<mlir::
arith::MulFOp>(x); }
5082 GENBIN(Multiply, Complex, fir::MulcOp)template <int KIND> CC genarr(const Fortran::evaluate::
Multiply<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Complex, KIND>> &x) { return createBinaryOp<fir
::MulcOp>(x); }
5083 GENBIN(Divide, Integer, mlir::arith::DivSIOp)template <int KIND> CC genarr(const Fortran::evaluate::
Divide<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Integer, KIND>> &x) { return createBinaryOp<mlir
::arith::DivSIOp>(x); }
5084 GENBIN(Divide, Real, mlir::arith::DivFOp)template <int KIND> CC genarr(const Fortran::evaluate::
Divide<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Real, KIND>> &x) { return createBinaryOp<mlir::
arith::DivFOp>(x); }
5085 GENBIN(Divide, Complex, fir::DivcOp)template <int KIND> CC genarr(const Fortran::evaluate::
Divide<Fortran::evaluate::Type< Fortran::common::TypeCategory
::Complex, KIND>> &x) { return createBinaryOp<fir
::DivcOp>(x); }
5086
5087 template <Fortran::common::TypeCategory TC, int KIND>
5088 CC genarr(
5089 const Fortran::evaluate::Power<Fortran::evaluate::Type<TC, KIND>> &x) {
5090 mlir::Location loc = getLoc();
5091 mlir::Type ty = converter.genType(TC, KIND);
5092 auto lf = genarr(x.left());
5093 auto rf = genarr(x.right());
5094 return [=](IterSpace iters) -> ExtValue {
5095 mlir::Value lhs = fir::getBase(lf(iters));
5096 mlir::Value rhs = fir::getBase(rf(iters));
5097 return fir::genPow(builder, loc, ty, lhs, rhs);
5098 };
5099 }
5100 template <Fortran::common::TypeCategory TC, int KIND>
5101 CC genarr(
5102 const Fortran::evaluate::Extremum<Fortran::evaluate::Type<TC, KIND>> &x) {
5103 mlir::Location loc = getLoc();
5104 auto lf = genarr(x.left());
5105 auto rf = genarr(x.right());
5106 switch (x.ordering) {
5107 case Fortran::evaluate::Ordering::Greater:
5108 return [=](IterSpace iters) -> ExtValue {
5109 mlir::Value lhs = fir::getBase(lf(iters));
5110 mlir::Value rhs = fir::getBase(rf(iters));
5111 return fir::genMax(builder, loc, llvm::ArrayRef<mlir::Value>{lhs, rhs});
5112 };
5113 case Fortran::evaluate::Ordering::Less:
5114 return [=](IterSpace iters) -> ExtValue {
5115 mlir::Value lhs = fir::getBase(lf(iters));
5116 mlir::Value rhs = fir::getBase(rf(iters));
5117 return fir::genMin(builder, loc, llvm::ArrayRef<mlir::Value>{lhs, rhs});
5118 };
5119 case Fortran::evaluate::Ordering::Equal:
5120 llvm_unreachable("Equal is not a valid ordering in this context")::llvm::llvm_unreachable_internal("Equal is not a valid ordering in this context"
, "flang/lib/Lower/ConvertExpr.cpp", 5120)
;
5121 }
5122 llvm_unreachable("unknown ordering")::llvm::llvm_unreachable_internal("unknown ordering", "flang/lib/Lower/ConvertExpr.cpp"
, 5122)
;
5123 }
5124 template <Fortran::common::TypeCategory TC, int KIND>
5125 CC genarr(
5126 const Fortran::evaluate::RealToIntPower<Fortran::evaluate::Type<TC, KIND>>
5127 &x) {
5128 mlir::Location loc = getLoc();
5129 auto ty = converter.genType(TC, KIND);
5130 auto lf = genarr(x.left());
5131 auto rf = genarr(x.right());
5132 return [=](IterSpace iters) {
5133 mlir::Value lhs = fir::getBase(lf(iters));
5134 mlir::Value rhs = fir::getBase(rf(iters));
5135 return fir::genPow(builder, loc, ty, lhs, rhs);
5136 };
5137 }
5138 template <int KIND>
5139 CC genarr(const Fortran::evaluate::ComplexConstructor<KIND> &x) {
5140 mlir::Location loc = getLoc();
5141 auto lf = genarr(x.left());
5142 auto rf = genarr(x.right());
5143 return [=](IterSpace iters) -> ExtValue {
5144 mlir::Value lhs = fir::getBase(lf(iters));
5145 mlir::Value rhs = fir::getBase(rf(iters));
5146 return fir::factory::Complex{builder, loc}.createComplex(KIND, lhs, rhs);
5147 };
5148 }
5149
5150 /// Fortran's concatenation operator `//`.
5151 template <int KIND>
5152 CC genarr(const Fortran::evaluate::Concat<KIND> &x) {
5153 mlir::Location loc = getLoc();
5154 auto lf = genarr(x.left());
5155 auto rf = genarr(x.right());
5156 return [=](IterSpace iters) -> ExtValue {
5157 auto lhs = lf(iters);
5158 auto rhs = rf(iters);
5159 const fir::CharBoxValue *lchr = lhs.getCharBox();
5160 const fir::CharBoxValue *rchr = rhs.getCharBox();
5161 if (lchr && rchr) {
5162 return fir::factory::CharacterExprHelper{builder, loc}
5163 .createConcatenate(*lchr, *rchr);
5164 }
5165 TODO(loc, "concat on unexpected extended values")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "5165" ": not yet implemented: ") + llvm::Twine("concat on unexpected extended values"
), false); } while (false)
;
5166 return mlir::Value{};
5167 };
5168 }
5169
5170 template <int KIND>
5171 CC genarr(const Fortran::evaluate::SetLength<KIND> &x) {
5172 auto lf = genarr(x.left());
5173 mlir::Value rhs = fir::getBase(asScalar(x.right()));
5174 fir::CharBoxValue temp =
5175 fir::factory::CharacterExprHelper(builder, getLoc())
5176 .createCharacterTemp(
5177 fir::CharacterType::getUnknownLen(builder.getContext(), KIND),
5178 rhs);
5179 return [=](IterSpace iters) -> ExtValue {
5180 fir::factory::CharacterExprHelper(builder, getLoc())
5181 .createAssign(temp, lf(iters));
5182 return temp;
5183 };
5184 }
5185
5186 template <typename T>
5187 CC genarr(const Fortran::evaluate::Constant<T> &x) {
5188 if (x.Rank() == 0)
5189 return genScalarAndForwardValue(x);
5190 return genarr(Fortran::lower::convertConstant(
5191 converter, getLoc(), x,
5192 /*outlineBigConstantsInReadOnlyMemory=*/true));
5193 }
5194
5195 //===--------------------------------------------------------------------===//
5196 // A vector subscript expression may be wrapped with a cast to INTEGER*8.
5197 // Get rid of it here so the vector can be loaded. Add it back when
5198 // generating the elemental evaluation (inside the loop nest).
5199
5200 static Fortran::lower::SomeExpr
5201 ignoreEvConvert(const Fortran::evaluate::Expr<Fortran::evaluate::Type<
5202 Fortran::common::TypeCategory::Integer, 8>> &x) {
5203 return std::visit([&](const auto &v) { return ignoreEvConvert(v); }, x.u);
5204 }
5205 template <Fortran::common::TypeCategory FROM>
5206 static Fortran::lower::SomeExpr ignoreEvConvert(
5207 const Fortran::evaluate::Convert<
5208 Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer, 8>,
5209 FROM> &x) {
5210 return toEvExpr(x.left());
5211 }
5212 template <typename A>
5213 static Fortran::lower::SomeExpr ignoreEvConvert(const A &x) {
5214 return toEvExpr(x);
5215 }
5216
5217 //===--------------------------------------------------------------------===//
5218 // Get the `Se::Symbol*` for the subscript expression, `x`. This symbol can
5219 // be used to determine the lbound, ubound of the vector.
5220
5221 template <typename A>
5222 static const Fortran::semantics::Symbol *
5223 extractSubscriptSymbol(const Fortran::evaluate::Expr<A> &x) {
5224 return std::visit([&](const auto &v) { return extractSubscriptSymbol(v); },
5225 x.u);
5226 }
5227 template <typename A>
5228 static const Fortran::semantics::Symbol *
5229 extractSubscriptSymbol(const Fortran::evaluate::Designator<A> &x) {
5230 return Fortran::evaluate::UnwrapWholeSymbolDataRef(x);
5231 }
5232 template <typename A>
5233 static const Fortran::semantics::Symbol *extractSubscriptSymbol(const A &x) {
5234 return nullptr;
5235 }
5236
5237 //===--------------------------------------------------------------------===//
5238
5239 /// Get the declared lower bound value of the array `x` in dimension `dim`.
5240 /// The argument `one` must be an ssa-value for the constant 1.
5241 mlir::Value getLBound(const ExtValue &x, unsigned dim, mlir::Value one) {
5242 return fir::factory::readLowerBound(builder, getLoc(), x, dim, one);
5243 }
5244
5245 /// Get the declared upper bound value of the array `x` in dimension `dim`.
5246 /// The argument `one` must be an ssa-value for the constant 1.
5247 mlir::Value getUBound(const ExtValue &x, unsigned dim, mlir::Value one) {
5248 mlir::Location loc = getLoc();
5249 mlir::Value lb = getLBound(x, dim, one);
5250 mlir::Value extent = fir::factory::readExtent(builder, loc, x, dim);
5251 auto add = builder.create<mlir::arith::AddIOp>(loc, lb, extent);
5252 return builder.create<mlir::arith::SubIOp>(loc, add, one);
5253 }
5254
5255 /// Return the extent of the boxed array `x` in dimesion `dim`.
5256 mlir::Value getExtent(const ExtValue &x, unsigned dim) {
5257 return fir::factory::readExtent(builder, getLoc(), x, dim);
5258 }
5259
5260 template <typename A>
5261 ExtValue genArrayBase(const A &base) {
5262 ScalarExprLowering sel{getLoc(), converter, symMap, stmtCtx};
5263 return base.IsSymbol() ? sel.gen(getFirstSym(base))
5264 : sel.gen(base.GetComponent());
5265 }
5266
5267 template <typename A>
5268 bool hasEvArrayRef(const A &x) {
5269 struct HasEvArrayRefHelper
5270 : public Fortran::evaluate::AnyTraverse<HasEvArrayRefHelper> {
5271 HasEvArrayRefHelper()
5272 : Fortran::evaluate::AnyTraverse<HasEvArrayRefHelper>(*this) {}
5273 using Fortran::evaluate::AnyTraverse<HasEvArrayRefHelper>::operator();
5274 bool operator()(const Fortran::evaluate::ArrayRef &) const {
5275 return true;
5276 }
5277 } helper;
5278 return helper(x);
5279 }
5280
5281 CC genVectorSubscriptArrayFetch(const Fortran::lower::SomeExpr &expr,
5282 std::size_t dim) {
5283 PushSemantics(ConstituentSemantics::RefTransparent)[[maybe_unused]] auto pushSemanticsLocalVariable__LINE__ = Fortran
::common::ScopedSet(semant, ConstituentSemantics::RefTransparent
);
;
5284 auto saved = Fortran::common::ScopedSet(explicitSpace, nullptr);
5285 llvm::SmallVector<mlir::Value> savedDestShape = destShape;
5286 destShape.clear();
5287 auto result = genarr(expr);
5288 if (destShape.empty())
5289 TODO(getLoc(), "expected vector to have an extent")do { fir::emitFatalError(getLoc(), llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "5289" ": not yet implemented: ") + llvm::Twine("expected vector to have an extent"
), false); } while (false)
;
5290 assert(destShape.size() == 1 && "vector has rank > 1")(static_cast <bool> (destShape.size() == 1 && "vector has rank > 1"
) ? void (0) : __assert_fail ("destShape.size() == 1 && \"vector has rank > 1\""
, "flang/lib/Lower/ConvertExpr.cpp", 5290, __extension__ __PRETTY_FUNCTION__
))
;
5291 if (destShape[0] != savedDestShape[dim]) {
5292 // Not the same, so choose the smaller value.
5293 mlir::Location loc = getLoc();
5294 auto cmp = builder.create<mlir::arith::CmpIOp>(
5295 loc, mlir::arith::CmpIPredicate::sgt, destShape[0],
5296 savedDestShape[dim]);
5297 auto sel = builder.create<mlir::arith::SelectOp>(
5298 loc, cmp, savedDestShape[dim], destShape[0]);
5299 savedDestShape[dim] = sel;
5300 destShape = savedDestShape;
5301 }
5302 return result;
5303 }
5304
5305 /// Generate an access by vector subscript using the index in the iteration
5306 /// vector at `dim`.
5307 mlir::Value genAccessByVector(mlir::Location loc, CC genArrFetch,
5308 IterSpace iters, std::size_t dim) {
5309 IterationSpace vecIters(iters,
5310 llvm::ArrayRef<mlir::Value>{iters.iterValue(dim)});
5311 fir::ExtendedValue fetch = genArrFetch(vecIters);
5312 mlir::IndexType idxTy = builder.getIndexType();
5313 return builder.createConvert(loc, idxTy, fir::getBase(fetch));
5314 }
5315
5316 /// When we have an array reference, the expressions specified in each
5317 /// dimension may be slice operations (e.g. `i:j:k`), vectors, or simple
5318 /// (loop-invarianet) scalar expressions. This returns the base entity, the
5319 /// resulting type, and a continuation to adjust the default iteration space.
5320 void genSliceIndices(ComponentPath &cmptData, const ExtValue &arrayExv,
5321 const Fortran::evaluate::ArrayRef &x, bool atBase) {
5322 mlir::Location loc = getLoc();
5323 mlir::IndexType idxTy = builder.getIndexType();
5324 mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
5325 llvm::SmallVector<mlir::Value> &trips = cmptData.trips;
5326 LLVM_DEBUG(llvm::dbgs() << "array: " << arrayExv << '\n')do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { llvm::dbgs() << "array: " <<
arrayExv << '\n'; } } while (false)
;
5327 auto &pc = cmptData.pc;
5328 const bool useTripsForSlice = !explicitSpaceIsActive();
5329 const bool createDestShape = destShape.empty();
5330 bool useSlice = false;
5331 std::size_t shapeIndex = 0;
5332 for (auto sub : llvm::enumerate(x.subscript())) {
5333 const std::size_t subsIndex = sub.index();
5334 std::visit(
5335 Fortran::common::visitors{
5336 [&](const Fortran::evaluate::Triplet &t) {
5337 mlir::Value lowerBound;
5338 if (auto optLo = t.lower())
5339 lowerBound = fir::getBase(asScalarArray(*optLo));
5340 else
5341 lowerBound = getLBound(arrayExv, subsIndex, one);
5342 lowerBound = builder.createConvert(loc, idxTy, lowerBound);
5343 mlir::Value stride = fir::getBase(asScalarArray(t.stride()));
5344 stride = builder.createConvert(loc, idxTy, stride);
5345 if (useTripsForSlice || createDestShape) {
5346 // Generate a slice operation for the triplet. The first and
5347 // second position of the triplet may be omitted, and the
5348 // declared lbound and/or ubound expression values,
5349 // respectively, should be used instead.
5350 trips.push_back(lowerBound);
5351 mlir::Value upperBound;
5352 if (auto optUp = t.upper())
5353 upperBound = fir::getBase(asScalarArray(*optUp));
5354 else
5355 upperBound = getUBound(arrayExv, subsIndex, one);
5356 upperBound = builder.createConvert(loc, idxTy, upperBound);
5357 trips.push_back(upperBound);
5358 trips.push_back(stride);
5359 if (createDestShape) {
5360 auto extent = builder.genExtentFromTriplet(
5361 loc, lowerBound, upperBound, stride, idxTy);
5362 destShape.push_back(extent);
5363 }
5364 useSlice = true;
5365 }
5366 if (!useTripsForSlice) {
5367 auto currentPC = pc;
5368 pc = [=](IterSpace iters) {
5369 IterationSpace newIters = currentPC(iters);
5370 mlir::Value impliedIter = newIters.iterValue(subsIndex);
5371 // FIXME: must use the lower bound of this component.
5372 auto arrLowerBound =
5373 atBase ? getLBound(arrayExv, subsIndex, one) : one;
5374 auto initial = builder.create<mlir::arith::SubIOp>(
5375 loc, lowerBound, arrLowerBound);
5376 auto prod = builder.create<mlir::arith::MulIOp>(
5377 loc, impliedIter, stride);
5378 auto result =
5379 builder.create<mlir::arith::AddIOp>(loc, initial, prod);
5380 newIters.setIndexValue(subsIndex, result);
5381 return newIters;
5382 };
5383 }
5384 shapeIndex++;
5385 },
5386 [&](const Fortran::evaluate::IndirectSubscriptIntegerExpr &ie) {
5387 const auto &e = ie.value(); // dereference
5388 if (isArray(e)) {
5389 // This is a vector subscript. Use the index values as read
5390 // from a vector to determine the temporary array value.
5391 // Note: 9.5.3.3.3(3) specifies undefined behavior for
5392 // multiple updates to any specific array element through a
5393 // vector subscript with replicated values.
5394 assert(!isBoxValue() &&(static_cast <bool> (!isBoxValue() && "fir.box cannot be created with vector subscripts"
) ? void (0) : __assert_fail ("!isBoxValue() && \"fir.box cannot be created with vector subscripts\""
, "flang/lib/Lower/ConvertExpr.cpp", 5395, __extension__ __PRETTY_FUNCTION__
))
5395 "fir.box cannot be created with vector subscripts")(static_cast <bool> (!isBoxValue() && "fir.box cannot be created with vector subscripts"
) ? void (0) : __assert_fail ("!isBoxValue() && \"fir.box cannot be created with vector subscripts\""
, "flang/lib/Lower/ConvertExpr.cpp", 5395, __extension__ __PRETTY_FUNCTION__
))
;
5396 // TODO: Avoid creating a new evaluate::Expr here
5397 auto arrExpr = ignoreEvConvert(e);
5398 if (createDestShape) {
5399 destShape.push_back(fir::factory::getExtentAtDimension(
5400 loc, builder, arrayExv, subsIndex));
5401 }
5402 auto genArrFetch =
5403 genVectorSubscriptArrayFetch(arrExpr, shapeIndex);
5404 auto currentPC = pc;
5405 pc = [=](IterSpace iters) {
5406 IterationSpace newIters = currentPC(iters);
5407 auto val = genAccessByVector(loc, genArrFetch, newIters,
5408 subsIndex);
5409 // Value read from vector subscript array and normalized
5410 // using the base array's lower bound value.
5411 mlir::Value lb = fir::factory::readLowerBound(
5412 builder, loc, arrayExv, subsIndex, one);
5413 auto origin = builder.create<mlir::arith::SubIOp>(
5414 loc, idxTy, val, lb);
5415 newIters.setIndexValue(subsIndex, origin);
5416 return newIters;
5417 };
5418 if (useTripsForSlice) {
5419 LLVM_ATTRIBUTE_UNUSED__attribute__((__unused__)) auto vectorSubscriptShape =
5420 getShape(arrayOperands.back());
5421 auto undef = builder.create<fir::UndefOp>(loc, idxTy);
5422 trips.push_back(undef);
5423 trips.push_back(undef);
5424 trips.push_back(undef);
5425 }
5426 shapeIndex++;
5427 } else {
5428 // This is a regular scalar subscript.
5429 if (useTripsForSlice) {
5430 // A regular scalar index, which does not yield an array
5431 // section. Use a degenerate slice operation
5432 // `(e:undef:undef)` in this dimension as a placeholder.
5433 // This does not necessarily change the rank of the original
5434 // array, so the iteration space must also be extended to
5435 // include this expression in this dimension to adjust to
5436 // the array's declared rank.
5437 mlir::Value v = fir::getBase(asScalarArray(e));
5438 trips.push_back(v);
5439 auto undef = builder.create<fir::UndefOp>(loc, idxTy);
5440 trips.push_back(undef);
5441 trips.push_back(undef);
5442 auto currentPC = pc;
5443 // Cast `e` to index type.
5444 mlir::Value iv = builder.createConvert(loc, idxTy, v);
5445 // Normalize `e` by subtracting the declared lbound.
5446 mlir::Value lb = fir::factory::readLowerBound(
5447 builder, loc, arrayExv, subsIndex, one);
5448 mlir::Value ivAdj =
5449 builder.create<mlir::arith::SubIOp>(loc, idxTy, iv, lb);
5450 // Add lbound adjusted value of `e` to the iteration vector
5451 // (except when creating a box because the iteration vector
5452 // is empty).
5453 if (!isBoxValue())
5454 pc = [=](IterSpace iters) {
5455 IterationSpace newIters = currentPC(iters);
5456 newIters.insertIndexValue(subsIndex, ivAdj);
5457 return newIters;
5458 };
5459 } else {
5460 auto currentPC = pc;
5461 mlir::Value newValue = fir::getBase(asScalarArray(e));
5462 mlir::Value result =
5463 builder.createConvert(loc, idxTy, newValue);
5464 mlir::Value lb = fir::factory::readLowerBound(
5465 builder, loc, arrayExv, subsIndex, one);
5466 result = builder.create<mlir::arith::SubIOp>(loc, idxTy,
5467 result, lb);
5468 pc = [=](IterSpace iters) {
5469 IterationSpace newIters = currentPC(iters);
5470 newIters.insertIndexValue(subsIndex, result);
5471 return newIters;
5472 };
5473 }
5474 }
5475 }},
5476 sub.value().u);
5477 }
5478 if (!useSlice)
5479 trips.clear();
5480 }
5481
5482 static mlir::Type unwrapBoxEleTy(mlir::Type ty) {
5483 if (auto boxTy = ty.dyn_cast<fir::BaseBoxType>())
5484 return fir::unwrapRefType(boxTy.getEleTy());
5485 return ty;
5486 }
5487
5488 llvm::SmallVector<mlir::Value> getShape(mlir::Type ty) {
5489 llvm::SmallVector<mlir::Value> result;
5490 ty = unwrapBoxEleTy(ty);
5491 mlir::Location loc = getLoc();
5492 mlir::IndexType idxTy = builder.getIndexType();
5493 for (auto extent : ty.cast<fir::SequenceType>().getShape()) {
5494 auto v = extent == fir::SequenceType::getUnknownExtent()
5495 ? builder.create<fir::UndefOp>(loc, idxTy).getResult()
5496 : builder.createIntegerConstant(loc, idxTy, extent);
5497 result.push_back(v);
5498 }
5499 return result;
5500 }
5501
5502 CC genarr(const Fortran::semantics::SymbolRef &sym,
5503 ComponentPath &components) {
5504 return genarr(sym.get(), components);
5505 }
5506
5507 ExtValue abstractArrayExtValue(mlir::Value val, mlir::Value len = {}) {
5508 return convertToArrayBoxValue(getLoc(), builder, val, len);
5509 }
5510
5511 CC genarr(const ExtValue &extMemref) {
5512 ComponentPath dummy(/*isImplicit=*/true);
5513 return genarr(extMemref, dummy);
5514 }
5515
5516 // If the slice values are given then use them. Otherwise, generate triples
5517 // that cover the entire shape specified by \p shapeVal.
5518 inline llvm::SmallVector<mlir::Value>
5519 padSlice(llvm::ArrayRef<mlir::Value> triples, mlir::Value shapeVal) {
5520 llvm::SmallVector<mlir::Value> result;
5521 mlir::Location loc = getLoc();
5522 if (triples.size()) {
5523 result.assign(triples.begin(), triples.end());
5524 } else {
5525 auto one = builder.createIntegerConstant(loc, builder.getIndexType(), 1);
5526 if (!shapeVal) {
5527 TODO(loc, "shape must be recovered from box")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "5527" ": not yet implemented: ") + llvm::Twine("shape must be recovered from box"
), false); } while (false)
;
5528 } else if (auto shapeOp = mlir::dyn_cast_or_null<fir::ShapeOp>(
5529 shapeVal.getDefiningOp())) {
5530 for (auto ext : shapeOp.getExtents()) {
5531 result.push_back(one);
5532 result.push_back(ext);
5533 result.push_back(one);
5534 }
5535 } else if (auto shapeShift = mlir::dyn_cast_or_null<fir::ShapeShiftOp>(
5536 shapeVal.getDefiningOp())) {
5537 for (auto [lb, ext] :
5538 llvm::zip(shapeShift.getOrigins(), shapeShift.getExtents())) {
5539 result.push_back(lb);
5540 result.push_back(ext);
5541 result.push_back(one);
5542 }
5543 } else {
5544 TODO(loc, "shape must be recovered from box")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "5544" ": not yet implemented: ") + llvm::Twine("shape must be recovered from box"
), false); } while (false)
;
5545 }
5546 }
5547 return result;
5548 }
5549
5550 /// Base case of generating an array reference,
5551 CC genarr(const ExtValue &extMemref, ComponentPath &components) {
5552 mlir::Location loc = getLoc();
5553 mlir::Value memref = fir::getBase(extMemref);
5554 mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(memref.getType());
5555 assert(arrTy.isa<fir::SequenceType>() && "memory ref must be an array")(static_cast <bool> (arrTy.isa<fir::SequenceType>
() && "memory ref must be an array") ? void (0) : __assert_fail
("arrTy.isa<fir::SequenceType>() && \"memory ref must be an array\""
, "flang/lib/Lower/ConvertExpr.cpp", 5555, __extension__ __PRETTY_FUNCTION__
))
;
5556 mlir::Value shape = builder.createShape(loc, extMemref);
5557 mlir::Value slice;
5558 if (components.isSlice()) {
5559 if (isBoxValue() && components.substring) {
5560 // Append the substring operator to emboxing Op as it will become an
5561 // interior adjustment (add offset, adjust LEN) to the CHARACTER value
5562 // being referenced in the descriptor.
5563 llvm::SmallVector<mlir::Value> substringBounds;
5564 populateBounds(substringBounds, components.substring);
5565 // Convert to (offset, size)
5566 mlir::Type iTy = substringBounds[0].getType();
5567 if (substringBounds.size() != 2) {
5568 fir::CharacterType charTy =
5569 fir::factory::CharacterExprHelper::getCharType(arrTy);
5570 if (charTy.hasConstantLen()) {
5571 mlir::IndexType idxTy = builder.getIndexType();
5572 fir::CharacterType::LenType charLen = charTy.getLen();
5573 mlir::Value lenValue =
5574 builder.createIntegerConstant(loc, idxTy, charLen);
5575 substringBounds.push_back(lenValue);
5576 } else {
5577 llvm::SmallVector<mlir::Value> typeparams =
5578 fir::getTypeParams(extMemref);
5579 substringBounds.push_back(typeparams.back());
5580 }
5581 }
5582 // Convert the lower bound to 0-based substring.
5583 mlir::Value one =
5584 builder.createIntegerConstant(loc, substringBounds[0].getType(), 1);
5585 substringBounds[0] =
5586 builder.create<mlir::arith::SubIOp>(loc, substringBounds[0], one);
5587 // Convert the upper bound to a length.
5588 mlir::Value cast = builder.createConvert(loc, iTy, substringBounds[1]);
5589 mlir::Value zero = builder.createIntegerConstant(loc, iTy, 0);
5590 auto size =
5591 builder.create<mlir::arith::SubIOp>(loc, cast, substringBounds[0]);
5592 auto cmp = builder.create<mlir::arith::CmpIOp>(
5593 loc, mlir::arith::CmpIPredicate::sgt, size, zero);
5594 // size = MAX(upper - (lower - 1), 0)
5595 substringBounds[1] =
5596 builder.create<mlir::arith::SelectOp>(loc, cmp, size, zero);
5597 slice = builder.create<fir::SliceOp>(
5598 loc, padSlice(components.trips, shape), components.suffixComponents,
5599 substringBounds);
5600 } else {
5601 slice = builder.createSlice(loc, extMemref, components.trips,
5602 components.suffixComponents);
5603 }
5604 if (components.hasComponents()) {
5605 auto seqTy = arrTy.cast<fir::SequenceType>();
5606 mlir::Type eleTy =
5607 fir::applyPathToType(seqTy.getEleTy(), components.suffixComponents);
5608 if (!eleTy)
5609 fir::emitFatalError(loc, "slicing path is ill-formed");
5610 if (auto realTy = eleTy.dyn_cast<fir::RealType>())
5611 eleTy = Fortran::lower::convertReal(realTy.getContext(),
5612 realTy.getFKind());
5613
5614 // create the type of the projected array.
5615 arrTy = fir::SequenceType::get(seqTy.getShape(), eleTy);
5616 LLVM_DEBUG(llvm::dbgs()do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { llvm::dbgs() << "type of array projection from component slicing: "
<< eleTy << ", " << arrTy << '\n'; }
} while (false)
5617 << "type of array projection from component slicing: "do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { llvm::dbgs() << "type of array projection from component slicing: "
<< eleTy << ", " << arrTy << '\n'; }
} while (false)
5618 << eleTy << ", " << arrTy << '\n')do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { llvm::dbgs() << "type of array projection from component slicing: "
<< eleTy << ", " << arrTy << '\n'; }
} while (false)
;
5619 }
5620 }
5621 arrayOperands.push_back(ArrayOperand{memref, shape, slice});
5622 if (destShape.empty())
5623 destShape = getShape(arrayOperands.back());
5624 if (isBoxValue()) {
5625 // Semantics are a reference to a boxed array.
5626 // This case just requires that an embox operation be created to box the
5627 // value. The value of the box is forwarded in the continuation.
5628 mlir::Type reduceTy = reduceRank(arrTy, slice);
5629 mlir::Type boxTy = fir::BoxType::get(reduceTy);
5630 if (memref.getType().isa<fir::ClassType>() && !components.hasComponents())
5631 boxTy = fir::ClassType::get(reduceTy);
5632 if (components.substring) {
5633 // Adjust char length to substring size.
5634 fir::CharacterType charTy =
5635 fir::factory::CharacterExprHelper::getCharType(reduceTy);
5636 auto seqTy = reduceTy.cast<fir::SequenceType>();
5637 // TODO: Use a constant for fir.char LEN if we can compute it.
5638 boxTy = fir::BoxType::get(
5639 fir::SequenceType::get(fir::CharacterType::getUnknownLen(
5640 builder.getContext(), charTy.getFKind()),
5641 seqTy.getDimension()));
5642 }
5643 llvm::SmallVector<mlir::Value> lbounds;
5644 llvm::SmallVector<mlir::Value> nonDeferredLenParams;
5645 if (!slice) {
5646 lbounds =
5647 fir::factory::getNonDefaultLowerBounds(builder, loc, extMemref);
5648 nonDeferredLenParams = fir::factory::getNonDeferredLenParams(extMemref);
5649 }
5650 mlir::Value embox =
5651 memref.getType().isa<fir::BaseBoxType>()
5652 ? builder.create<fir::ReboxOp>(loc, boxTy, memref, shape, slice)
5653 .getResult()
5654 : builder
5655 .create<fir::EmboxOp>(loc, boxTy, memref, shape, slice,
5656 fir::getTypeParams(extMemref))
5657 .getResult();
5658 return [=](IterSpace) -> ExtValue {
5659 return fir::BoxValue(embox, lbounds, nonDeferredLenParams);
5660 };
5661 }
5662 auto eleTy = arrTy.cast<fir::SequenceType>().getEleTy();
5663 if (isReferentiallyOpaque()) {
5664 // Semantics are an opaque reference to an array.
5665 // This case forwards a continuation that will generate the address
5666 // arithmetic to the array element. This does not have copy-in/copy-out
5667 // semantics. No attempt to copy the array value will be made during the
5668 // interpretation of the Fortran statement.
5669 mlir::Type refEleTy = builder.getRefType(eleTy);
5670 return [=](IterSpace iters) -> ExtValue {
5671 // ArrayCoorOp does not expect zero based indices.
5672 llvm::SmallVector<mlir::Value> indices = fir::factory::originateIndices(
5673 loc, builder, memref.getType(), shape, iters.iterVec());
5674 mlir::Value coor = builder.create<fir::ArrayCoorOp>(
5675 loc, refEleTy, memref, shape, slice, indices,
5676 fir::getTypeParams(extMemref));
5677 if (auto charTy = eleTy.dyn_cast<fir::CharacterType>()) {
5678 llvm::SmallVector<mlir::Value> substringBounds;
5679 populateBounds(substringBounds, components.substring);
5680 if (!substringBounds.empty()) {
5681 mlir::Value dstLen = fir::factory::genLenOfCharacter(
5682 builder, loc, arrTy.cast<fir::SequenceType>(), memref,
5683 fir::getTypeParams(extMemref), iters.iterVec(),
5684 substringBounds);
5685 fir::CharBoxValue dstChar(coor, dstLen);
5686 return fir::factory::CharacterExprHelper{builder, loc}
5687 .createSubstring(dstChar, substringBounds);
5688 }
5689 }
5690 return fir::factory::arraySectionElementToExtendedValue(
5691 builder, loc, extMemref, coor, slice);
5692 };
5693 }
5694 auto arrLoad = builder.create<fir::ArrayLoadOp>(
5695 loc, arrTy, memref, shape, slice, fir::getTypeParams(extMemref));
5696 mlir::Value arrLd = arrLoad.getResult();
5697 if (isProjectedCopyInCopyOut()) {
5698 // Semantics are projected copy-in copy-out.
5699 // The backing store of the destination of an array expression may be
5700 // partially modified. These updates are recorded in FIR by forwarding a
5701 // continuation that generates an `array_update` Op. The destination is
5702 // always loaded at the beginning of the statement and merged at the
5703 // end.
5704 destination = arrLoad;
5705 auto lambda = ccStoreToDest
5706 ? *ccStoreToDest
5707 : defaultStoreToDestination(components.substring);
5708 return [=](IterSpace iters) -> ExtValue { return lambda(iters); };
5709 }
5710 if (isCustomCopyInCopyOut()) {
5711 // Create an array_modify to get the LHS element address and indicate
5712 // the assignment, the actual assignment must be implemented in
5713 // ccStoreToDest.
5714 destination = arrLoad;
5715 return [=](IterSpace iters) -> ExtValue {
5716 mlir::Value innerArg = iters.innerArgument();
5717 mlir::Type resTy = innerArg.getType();
5718 mlir::Type eleTy = fir::applyPathToType(resTy, iters.iterVec());
5719 mlir::Type refEleTy =
5720 fir::isa_ref_type(eleTy) ? eleTy : builder.getRefType(eleTy);
5721 auto arrModify = builder.create<fir::ArrayModifyOp>(
5722 loc, mlir::TypeRange{refEleTy, resTy}, innerArg, iters.iterVec(),
5723 destination.getTypeparams());
5724 return abstractArrayExtValue(arrModify.getResult(1));
5725 };
5726 }
5727 if (isCopyInCopyOut()) {
5728 // Semantics are copy-in copy-out.
5729 // The continuation simply forwards the result of the `array_load` Op,
5730 // which is the value of the array as it was when loaded. All data
5731 // references with rank > 0 in an array expression typically have
5732 // copy-in copy-out semantics.
5733 return [=](IterSpace) -> ExtValue { return arrLd; };
5734 }
5735 llvm::SmallVector<mlir::Value> arrLdTypeParams =
5736 fir::factory::getTypeParams(loc, builder, arrLoad);
5737 if (isValueAttribute()) {
5738 // Semantics are value attribute.
5739 // Here the continuation will `array_fetch` a value from an array and
5740 // then store that value in a temporary. One can thus imitate pass by
5741 // value even when the call is pass by reference.
5742 return [=](IterSpace iters) -> ExtValue {
5743 mlir::Value base;
5744 mlir::Type eleTy = fir::applyPathToType(arrTy, iters.iterVec());
5745 if (isAdjustedArrayElementType(eleTy)) {
5746 mlir::Type eleRefTy = builder.getRefType(eleTy);
5747 base = builder.create<fir::ArrayAccessOp>(
5748 loc, eleRefTy, arrLd, iters.iterVec(), arrLdTypeParams);
5749 } else {
5750 base = builder.create<fir::ArrayFetchOp>(
5751 loc, eleTy, arrLd, iters.iterVec(), arrLdTypeParams);
5752 }
5753 mlir::Value temp = builder.createTemporary(
5754 loc, base.getType(),
5755 llvm::ArrayRef<mlir::NamedAttribute>{
5756 Fortran::lower::getAdaptToByRefAttr(builder)});
5757 builder.create<fir::StoreOp>(loc, base, temp);
5758 return fir::factory::arraySectionElementToExtendedValue(
5759 builder, loc, extMemref, temp, slice);
5760 };
5761 }
5762 // In the default case, the array reference forwards an `array_fetch` or
5763 // `array_access` Op in the continuation.
5764 return [=](IterSpace iters) -> ExtValue {
5765 mlir::Type eleTy = fir::applyPathToType(arrTy, iters.iterVec());
5766 if (isAdjustedArrayElementType(eleTy)) {
5767 mlir::Type eleRefTy = builder.getRefType(eleTy);
5768 mlir::Value arrayOp = builder.create<fir::ArrayAccessOp>(
5769 loc, eleRefTy, arrLd, iters.iterVec(), arrLdTypeParams);
5770 if (auto charTy = eleTy.dyn_cast<fir::CharacterType>()) {
5771 llvm::SmallVector<mlir::Value> substringBounds;
5772 populateBounds(substringBounds, components.substring);
5773 if (!substringBounds.empty()) {
5774 mlir::Value dstLen = fir::factory::genLenOfCharacter(
5775 builder, loc, arrLoad, iters.iterVec(), substringBounds);
5776 fir::CharBoxValue dstChar(arrayOp, dstLen);
5777 return fir::factory::CharacterExprHelper{builder, loc}
5778 .createSubstring(dstChar, substringBounds);
5779 }
5780 }
5781 return fir::factory::arraySectionElementToExtendedValue(
5782 builder, loc, extMemref, arrayOp, slice);
5783 }
5784 auto arrFetch = builder.create<fir::ArrayFetchOp>(
5785 loc, eleTy, arrLd, iters.iterVec(), arrLdTypeParams);
5786 return fir::factory::arraySectionElementToExtendedValue(
5787 builder, loc, extMemref, arrFetch, slice);
5788 };
5789 }
5790
5791 std::tuple<CC, mlir::Value, mlir::Type>
5792 genOptionalArrayFetch(const Fortran::lower::SomeExpr &expr) {
5793 assert(expr.Rank() > 0 && "expr must be an array")(static_cast <bool> (expr.Rank() > 0 && "expr must be an array"
) ? void (0) : __assert_fail ("expr.Rank() > 0 && \"expr must be an array\""
, "flang/lib/Lower/ConvertExpr.cpp", 5793, __extension__ __PRETTY_FUNCTION__
))
;
5794 mlir::Location loc = getLoc();
5795 ExtValue optionalArg = asInquired(expr);
5796 mlir::Value isPresent = genActualIsPresentTest(builder, loc, optionalArg);
5797 // Generate an array load and access to an array that may be an absent
5798 // optional or an unallocated optional.
5799 mlir::Value base = getBase(optionalArg);
5800 const bool hasOptionalAttr =
5801 fir::valueHasFirAttribute(base, fir::getOptionalAttrName());
5802 mlir::Type baseType = fir::unwrapRefType(base.getType());
5803 const bool isBox = baseType.isa<fir::BoxType>();
5804 const bool isAllocOrPtr = Fortran::evaluate::IsAllocatableOrPointerObject(
5805 expr, converter.getFoldingContext());
5806 mlir::Type arrType = fir::unwrapPassByRefType(baseType);
5807 mlir::Type eleType = fir::unwrapSequenceType(arrType);
5808 ExtValue exv = optionalArg;
5809 if (hasOptionalAttr && isBox && !isAllocOrPtr) {
5810 // Elemental argument cannot be allocatable or pointers (C15100).
5811 // Hence, per 15.5.2.12 3 (8) and (9), the provided Allocatable and
5812 // Pointer optional arrays cannot be absent. The only kind of entities
5813 // that can get here are optional assumed shape and polymorphic entities.
5814 exv = absentBoxToUnallocatedBox(builder, loc, exv, isPresent);
5815 }
5816 // All the properties can be read from any fir.box but the read values may
5817 // be undefined and should only be used inside a fir.if (canBeRead) region.
5818 if (const auto *mutableBox = exv.getBoxOf<fir::MutableBoxValue>())
5819 exv = fir::factory::genMutableBoxRead(builder, loc, *mutableBox);
5820
5821 mlir::Value memref = fir::getBase(exv);
5822 mlir::Value shape = builder.createShape(loc, exv);
5823 mlir::Value noSlice;
5824 auto arrLoad = builder.create<fir::ArrayLoadOp>(
5825 loc, arrType, memref, shape, noSlice, fir::getTypeParams(exv));
5826 mlir::Operation::operand_range arrLdTypeParams = arrLoad.getTypeparams();
5827 mlir::Value arrLd = arrLoad.getResult();
5828 // Mark the load to tell later passes it is unsafe to use this array_load
5829 // shape unconditionally.
5830 arrLoad->setAttr(fir::getOptionalAttrName(), builder.getUnitAttr());
5831
5832 // Place the array as optional on the arrayOperands stack so that its
5833 // shape will only be used as a fallback to induce the implicit loop nest
5834 // (that is if there is no non optional array arguments).
5835 arrayOperands.push_back(
5836 ArrayOperand{memref, shape, noSlice, /*mayBeAbsent=*/true});
5837
5838 // By value semantics.
5839 auto cc = [=](IterSpace iters) -> ExtValue {
5840 auto arrFetch = builder.create<fir::ArrayFetchOp>(
5841 loc, eleType, arrLd, iters.iterVec(), arrLdTypeParams);
5842 return fir::factory::arraySectionElementToExtendedValue(
5843 builder, loc, exv, arrFetch, noSlice);
5844 };
5845 return {cc, isPresent, eleType};
5846 }
5847
5848 /// Generate a continuation to pass \p expr to an OPTIONAL argument of an
5849 /// elemental procedure. This is meant to handle the cases where \p expr might
5850 /// be dynamically absent (i.e. when it is a POINTER, an ALLOCATABLE or an
5851 /// OPTIONAL variable). If p\ expr is guaranteed to be present genarr() can
5852 /// directly be called instead.
5853 CC genarrForwardOptionalArgumentToCall(const Fortran::lower::SomeExpr &expr) {
5854 mlir::Location loc = getLoc();
5855 // Only by-value numerical and logical so far.
5856 if (semant != ConstituentSemantics::RefTransparent)
5857 TODO(loc, "optional arguments in user defined elemental procedures")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "5857" ": not yet implemented: ") + llvm::Twine("optional arguments in user defined elemental procedures"
), false); } while (false)
;
5858
5859 // Handle scalar argument case (the if-then-else is generated outside of the
5860 // implicit loop nest).
5861 if (expr.Rank() == 0) {
5862 ExtValue optionalArg = asInquired(expr);
5863 mlir::Value isPresent = genActualIsPresentTest(builder, loc, optionalArg);
5864 mlir::Value elementValue =
5865 fir::getBase(genOptionalValue(builder, loc, optionalArg, isPresent));
5866 return [=](IterSpace iters) -> ExtValue { return elementValue; };
5867 }
5868
5869 CC cc;
5870 mlir::Value isPresent;
5871 mlir::Type eleType;
5872 std::tie(cc, isPresent, eleType) = genOptionalArrayFetch(expr);
5873 return [=](IterSpace iters) -> ExtValue {
5874 mlir::Value elementValue =
5875 builder
5876 .genIfOp(loc, {eleType}, isPresent,
5877 /*withElseRegion=*/true)
5878 .genThen([&]() {
5879 builder.create<fir::ResultOp>(loc, fir::getBase(cc(iters)));
5880 })
5881 .genElse([&]() {
5882 mlir::Value zero =
5883 fir::factory::createZeroValue(builder, loc, eleType);
5884 builder.create<fir::ResultOp>(loc, zero);
5885 })
5886 .getResults()[0];
5887 return elementValue;
5888 };
5889 }
5890
5891 /// Reduce the rank of a array to be boxed based on the slice's operands.
5892 static mlir::Type reduceRank(mlir::Type arrTy, mlir::Value slice) {
5893 if (slice) {
5894 auto slOp = mlir::dyn_cast<fir::SliceOp>(slice.getDefiningOp());
5895 assert(slOp && "expected slice op")(static_cast <bool> (slOp && "expected slice op"
) ? void (0) : __assert_fail ("slOp && \"expected slice op\""
, "flang/lib/Lower/ConvertExpr.cpp", 5895, __extension__ __PRETTY_FUNCTION__
))
;
5896 auto seqTy = arrTy.dyn_cast<fir::SequenceType>();
5897 assert(seqTy && "expected array type")(static_cast <bool> (seqTy && "expected array type"
) ? void (0) : __assert_fail ("seqTy && \"expected array type\""
, "flang/lib/Lower/ConvertExpr.cpp", 5897, __extension__ __PRETTY_FUNCTION__
))
;
5898 mlir::Operation::operand_range triples = slOp.getTriples();
5899 fir::SequenceType::Shape shape;
5900 // reduce the rank for each invariant dimension
5901 for (unsigned i = 1, end = triples.size(); i < end; i += 3) {
5902 if (auto extent = fir::factory::getExtentFromTriplet(
5903 triples[i - 1], triples[i], triples[i + 1]))
5904 shape.push_back(*extent);
5905 else if (!mlir::isa_and_nonnull<fir::UndefOp>(
5906 triples[i].getDefiningOp()))
5907 shape.push_back(fir::SequenceType::getUnknownExtent());
5908 }
5909 return fir::SequenceType::get(shape, seqTy.getEleTy());
5910 }
5911 // not sliced, so no change in rank
5912 return arrTy;
5913 }
5914
5915 /// Example: <code>array%RE</code>
5916 CC genarr(const Fortran::evaluate::ComplexPart &x,
5917 ComponentPath &components) {
5918 components.reversePath.push_back(&x);
5919 return genarr(x.complex(), components);
5920 }
5921
5922 template <typename A>
5923 CC genSlicePath(const A &x, ComponentPath &components) {
5924 return genarr(x, components);
5925 }
5926
5927 CC genarr(const Fortran::evaluate::StaticDataObject::Pointer &,
5928 ComponentPath &components) {
5929 TODO(getLoc(), "substring of static object inside FORALL")do { fir::emitFatalError(getLoc(), llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "5929" ": not yet implemented: ") + llvm::Twine("substring of static object inside FORALL"
), false); } while (false)
;
5930 }
5931
5932 /// Substrings (see 9.4.1)
5933 CC genarr(const Fortran::evaluate::Substring &x, ComponentPath &components) {
5934 components.substring = &x;
5935 return std::visit([&](const auto &v) { return genarr(v, components); },
5936 x.parent());
5937 }
5938
5939 template <typename T>
5940 CC genarr(const Fortran::evaluate::FunctionRef<T> &funRef) {
5941 // Note that it's possible that the function being called returns either an
5942 // array or a scalar. In the first case, use the element type of the array.
5943 return genProcRef(
5944 funRef, fir::unwrapSequenceType(converter.genType(toEvExpr(funRef))));
5945 }
5946
5947 //===--------------------------------------------------------------------===//
5948 // Array construction
5949 //===--------------------------------------------------------------------===//
5950
5951 /// Target agnostic computation of the size of an element in the array.
5952 /// Returns the size in bytes with type `index` or a null Value if the element
5953 /// size is not constant.
5954 mlir::Value computeElementSize(const ExtValue &exv, mlir::Type eleTy,
5955 mlir::Type resTy) {
5956 mlir::Location loc = getLoc();
5957 mlir::IndexType idxTy = builder.getIndexType();
5958 mlir::Value multiplier = builder.createIntegerConstant(loc, idxTy, 1);
5959 if (fir::hasDynamicSize(eleTy)) {
5960 if (auto charTy = eleTy.dyn_cast<fir::CharacterType>()) {
5961 // Array of char with dynamic LEN parameter. Downcast to an array
5962 // of singleton char, and scale by the len type parameter from
5963 // `exv`.
5964 exv.match(
5965 [&](const fir::CharBoxValue &cb) { multiplier = cb.getLen(); },
5966 [&](const fir::CharArrayBoxValue &cb) { multiplier = cb.getLen(); },
5967 [&](const fir::BoxValue &box) {
5968 multiplier = fir::factory::CharacterExprHelper(builder, loc)
5969 .readLengthFromBox(box.getAddr());
5970 },
5971 [&](const fir::MutableBoxValue &box) {
5972 multiplier = fir::factory::CharacterExprHelper(builder, loc)
5973 .readLengthFromBox(box.getAddr());
5974 },
5975 [&](const auto &) {
5976 fir::emitFatalError(loc,
5977 "array constructor element has unknown size");
5978 });
5979 fir::CharacterType newEleTy = fir::CharacterType::getSingleton(
5980 eleTy.getContext(), charTy.getFKind());
5981 if (auto seqTy = resTy.dyn_cast<fir::SequenceType>()) {
5982 assert(eleTy == seqTy.getEleTy())(static_cast <bool> (eleTy == seqTy.getEleTy()) ? void (
0) : __assert_fail ("eleTy == seqTy.getEleTy()", "flang/lib/Lower/ConvertExpr.cpp"
, 5982, __extension__ __PRETTY_FUNCTION__))
;
5983 resTy = fir::SequenceType::get(seqTy.getShape(), newEleTy);
5984 }
5985 eleTy = newEleTy;
5986 } else {
5987 TODO(loc, "dynamic sized type")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "5987" ": not yet implemented: ") + llvm::Twine("dynamic sized type"
), false); } while (false)
;
5988 }
5989 }
5990 mlir::Type eleRefTy = builder.getRefType(eleTy);
5991 mlir::Type resRefTy = builder.getRefType(resTy);
5992 mlir::Value nullPtr = builder.createNullConstant(loc, resRefTy);
5993 auto offset = builder.create<fir::CoordinateOp>(
5994 loc, eleRefTy, nullPtr, mlir::ValueRange{multiplier});
5995 return builder.createConvert(loc, idxTy, offset);
5996 }
5997
5998 /// Get the function signature of the LLVM memcpy intrinsic.
5999 mlir::FunctionType memcpyType() {
6000 return fir::factory::getLlvmMemcpy(builder).getFunctionType();
6001 }
6002
6003 /// Create a call to the LLVM memcpy intrinsic.
6004 void createCallMemcpy(llvm::ArrayRef<mlir::Value> args) {
6005 mlir::Location loc = getLoc();
6006 mlir::func::FuncOp memcpyFunc = fir::factory::getLlvmMemcpy(builder);
6007 mlir::SymbolRefAttr funcSymAttr =
6008 builder.getSymbolRefAttr(memcpyFunc.getName());
6009 mlir::FunctionType funcTy = memcpyFunc.getFunctionType();
6010 builder.create<fir::CallOp>(loc, funcTy.getResults(), funcSymAttr, args);
6011 }
6012
6013 // Construct code to check for a buffer overrun and realloc the buffer when
6014 // space is depleted. This is done between each item in the ac-value-list.
6015 mlir::Value growBuffer(mlir::Value mem, mlir::Value needed,
6016 mlir::Value bufferSize, mlir::Value buffSize,
6017 mlir::Value eleSz) {
6018 mlir::Location loc = getLoc();
6019 mlir::func::FuncOp reallocFunc = fir::factory::getRealloc(builder);
6020 auto cond = builder.create<mlir::arith::CmpIOp>(
6021 loc, mlir::arith::CmpIPredicate::sle, bufferSize, needed);
6022 auto ifOp = builder.create<fir::IfOp>(loc, mem.getType(), cond,
6023 /*withElseRegion=*/true);
6024 auto insPt = builder.saveInsertionPoint();
6025 builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
6026 // Not enough space, resize the buffer.
6027 mlir::IndexType idxTy = builder.getIndexType();
6028 mlir::Value two = builder.createIntegerConstant(loc, idxTy, 2);
6029 auto newSz = builder.create<mlir::arith::MulIOp>(loc, needed, two);
6030 builder.create<fir::StoreOp>(loc, newSz, buffSize);
6031 mlir::Value byteSz = builder.create<mlir::arith::MulIOp>(loc, newSz, eleSz);
6032 mlir::SymbolRefAttr funcSymAttr =
6033 builder.getSymbolRefAttr(reallocFunc.getName());
6034 mlir::FunctionType funcTy = reallocFunc.getFunctionType();
6035 auto newMem = builder.create<fir::CallOp>(
6036 loc, funcTy.getResults(), funcSymAttr,
6037 llvm::ArrayRef<mlir::Value>{
6038 builder.createConvert(loc, funcTy.getInputs()[0], mem),
6039 builder.createConvert(loc, funcTy.getInputs()[1], byteSz)});
6040 mlir::Value castNewMem =
6041 builder.createConvert(loc, mem.getType(), newMem.getResult(0));
6042 builder.create<fir::ResultOp>(loc, castNewMem);
6043 builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
6044 // Otherwise, just forward the buffer.
6045 builder.create<fir::ResultOp>(loc, mem);
6046 builder.restoreInsertionPoint(insPt);
6047 return ifOp.getResult(0);
6048 }
6049
6050 /// Copy the next value (or vector of values) into the array being
6051 /// constructed.
6052 mlir::Value copyNextArrayCtorSection(const ExtValue &exv, mlir::Value buffPos,
6053 mlir::Value buffSize, mlir::Value mem,
6054 mlir::Value eleSz, mlir::Type eleTy,
6055 mlir::Type eleRefTy, mlir::Type resTy) {
6056 mlir::Location loc = getLoc();
6057 auto off = builder.create<fir::LoadOp>(loc, buffPos);
6058 auto limit = builder.create<fir::LoadOp>(loc, buffSize);
6059 mlir::IndexType idxTy = builder.getIndexType();
6060 mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
6061
6062 if (fir::isRecordWithAllocatableMember(eleTy))
6063 TODO(loc, "deep copy on allocatable members")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "6063" ": not yet implemented: ") + llvm::Twine("deep copy on allocatable members"
), false); } while (false)
;
6064
6065 if (!eleSz) {
6066 // Compute the element size at runtime.
6067 assert(fir::hasDynamicSize(eleTy))(static_cast <bool> (fir::hasDynamicSize(eleTy)) ? void
(0) : __assert_fail ("fir::hasDynamicSize(eleTy)", "flang/lib/Lower/ConvertExpr.cpp"
, 6067, __extension__ __PRETTY_FUNCTION__))
;
6068 if (auto charTy = eleTy.dyn_cast<fir::CharacterType>()) {
6069 auto charBytes =
6070 builder.getKindMap().getCharacterBitsize(charTy.getFKind()) / 8;
6071 mlir::Value bytes =
6072 builder.createIntegerConstant(loc, idxTy, charBytes);
6073 mlir::Value length = fir::getLen(exv);
6074 if (!length)
6075 fir::emitFatalError(loc, "result is not boxed character");
6076 eleSz = builder.create<mlir::arith::MulIOp>(loc, bytes, length);
6077 } else {
6078 TODO(loc, "PDT size")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "6078" ": not yet implemented: ") + llvm::Twine("PDT size"
), false); } while (false)
;
6079 // Will call the PDT's size function with the type parameters.
6080 }
6081 }
6082
6083 // Compute the coordinate using `fir.coordinate_of`, or, if the type has
6084 // dynamic size, generating the pointer arithmetic.
6085 auto computeCoordinate = [&](mlir::Value buff, mlir::Value off) {
6086 mlir::Type refTy = eleRefTy;
6087 if (fir::hasDynamicSize(eleTy)) {
6088 if (auto charTy = eleTy.dyn_cast<fir::CharacterType>()) {
6089 // Scale a simple pointer using dynamic length and offset values.
6090 auto chTy = fir::CharacterType::getSingleton(charTy.getContext(),
6091 charTy.getFKind());
6092 refTy = builder.getRefType(chTy);
6093 mlir::Type toTy = builder.getRefType(builder.getVarLenSeqTy(chTy));
6094 buff = builder.createConvert(loc, toTy, buff);
6095 off = builder.create<mlir::arith::MulIOp>(loc, off, eleSz);
6096 } else {
6097 TODO(loc, "PDT offset")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "6097" ": not yet implemented: ") + llvm::Twine("PDT offset"
), false); } while (false)
;
6098 }
6099 }
6100 auto coor = builder.create<fir::CoordinateOp>(loc, refTy, buff,
6101 mlir::ValueRange{off});
6102 return builder.createConvert(loc, eleRefTy, coor);
6103 };
6104
6105 // Lambda to lower an abstract array box value.
6106 auto doAbstractArray = [&](const auto &v) {
6107 // Compute the array size.
6108 mlir::Value arrSz = one;
6109 for (auto ext : v.getExtents())
6110 arrSz = builder.create<mlir::arith::MulIOp>(loc, arrSz, ext);
6111
6112 // Grow the buffer as needed.
6113 auto endOff = builder.create<mlir::arith::AddIOp>(loc, off, arrSz);
6114 mem = growBuffer(mem, endOff, limit, buffSize, eleSz);
6115
6116 // Copy the elements to the buffer.
6117 mlir::Value byteSz =
6118 builder.create<mlir::arith::MulIOp>(loc, arrSz, eleSz);
6119 auto buff = builder.createConvert(loc, fir::HeapType::get(resTy), mem);
6120 mlir::Value buffi = computeCoordinate(buff, off);
6121 llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
6122 builder, loc, memcpyType(), buffi, v.getAddr(), byteSz,
6123 /*volatile=*/builder.createBool(loc, false));
6124 createCallMemcpy(args);
6125
6126 // Save the incremented buffer position.
6127 builder.create<fir::StoreOp>(loc, endOff, buffPos);
6128 };
6129
6130 // Copy a trivial scalar value into the buffer.
6131 auto doTrivialScalar = [&](const ExtValue &v, mlir::Value len = {}) {
6132 // Increment the buffer position.
6133 auto plusOne = builder.create<mlir::arith::AddIOp>(loc, off, one);
6134
6135 // Grow the buffer as needed.
6136 mem = growBuffer(mem, plusOne, limit, buffSize, eleSz);
6137
6138 // Store the element in the buffer.
6139 mlir::Value buff =
6140 builder.createConvert(loc, fir::HeapType::get(resTy), mem);
6141 auto buffi = builder.create<fir::CoordinateOp>(loc, eleRefTy, buff,
6142 mlir::ValueRange{off});
6143 fir::factory::genScalarAssignment(
6144 builder, loc,
6145 [&]() -> ExtValue {
6146 if (len)
6147 return fir::CharBoxValue(buffi, len);
6148 return buffi;
6149 }(),
6150 v);
6151 builder.create<fir::StoreOp>(loc, plusOne, buffPos);
6152 };
6153
6154 // Copy the value.
6155 exv.match(
6156 [&](mlir::Value) { doTrivialScalar(exv); },
6157 [&](const fir::CharBoxValue &v) {
6158 auto buffer = v.getBuffer();
6159 if (fir::isa_char(buffer.getType())) {
6160 doTrivialScalar(exv, eleSz);
6161 } else {
6162 // Increment the buffer position.
6163 auto plusOne = builder.create<mlir::arith::AddIOp>(loc, off, one);
6164
6165 // Grow the buffer as needed.
6166 mem = growBuffer(mem, plusOne, limit, buffSize, eleSz);
6167
6168 // Store the element in the buffer.
6169 mlir::Value buff =
6170 builder.createConvert(loc, fir::HeapType::get(resTy), mem);
6171 mlir::Value buffi = computeCoordinate(buff, off);
6172 llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
6173 builder, loc, memcpyType(), buffi, v.getAddr(), eleSz,
6174 /*volatile=*/builder.createBool(loc, false));
6175 createCallMemcpy(args);
6176
6177 builder.create<fir::StoreOp>(loc, plusOne, buffPos);
6178 }
6179 },
6180 [&](const fir::ArrayBoxValue &v) { doAbstractArray(v); },
6181 [&](const fir::CharArrayBoxValue &v) { doAbstractArray(v); },
6182 [&](const auto &) {
6183 TODO(loc, "unhandled array constructor expression")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "6183" ": not yet implemented: ") + llvm::Twine("unhandled array constructor expression"
), false); } while (false)
;
6184 });
6185 return mem;
6186 }
6187
6188 // Lower the expr cases in an ac-value-list.
6189 template <typename A>
6190 std::pair<ExtValue, bool>
6191 genArrayCtorInitializer(const Fortran::evaluate::Expr<A> &x, mlir::Type,
6192 mlir::Value, mlir::Value, mlir::Value,
6193 Fortran::lower::StatementContext &stmtCtx) {
6194 if (isArray(x))
6195 return {lowerNewArrayExpression(converter, symMap, stmtCtx, toEvExpr(x)),
6196 /*needCopy=*/true};
6197 return {asScalar(x), /*needCopy=*/true};
6198 }
6199
6200 // Lower an ac-implied-do in an ac-value-list.
6201 template <typename A>
6202 std::pair<ExtValue, bool>
6203 genArrayCtorInitializer(const Fortran::evaluate::ImpliedDo<A> &x,
6204 mlir::Type resTy, mlir::Value mem,
6205 mlir::Value buffPos, mlir::Value buffSize,
6206 Fortran::lower::StatementContext &) {
6207 mlir::Location loc = getLoc();
6208 mlir::IndexType idxTy = builder.getIndexType();
6209 mlir::Value lo =
6210 builder.createConvert(loc, idxTy, fir::getBase(asScalar(x.lower())));
6211 mlir::Value up =
6212 builder.createConvert(loc, idxTy, fir::getBase(asScalar(x.upper())));
6213 mlir::Value step =
6214 builder.createConvert(loc, idxTy, fir::getBase(asScalar(x.stride())));
6215 auto seqTy = resTy.template cast<fir::SequenceType>();
6216 mlir::Type eleTy = fir::unwrapSequenceType(seqTy);
6217 auto loop =
6218 builder.create<fir::DoLoopOp>(loc, lo, up, step, /*unordered=*/false,
6219 /*finalCount=*/false, mem);
6220 // create a new binding for x.name(), to ac-do-variable, to the iteration
6221 // value.
6222 symMap.pushImpliedDoBinding(toStringRef(x.name()), loop.getInductionVar());
6223 auto insPt = builder.saveInsertionPoint();
6224 builder.setInsertionPointToStart(loop.getBody());
6225 // Thread mem inside the loop via loop argument.
6226 mem = loop.getRegionIterArgs()[0];
6227
6228 mlir::Type eleRefTy = builder.getRefType(eleTy);
6229
6230 // Any temps created in the loop body must be freed inside the loop body.
6231 stmtCtx.pushScope();
6232 std::optional<mlir::Value> charLen;
6233 for (const Fortran::evaluate::ArrayConstructorValue<A> &acv : x.values()) {
6234 auto [exv, copyNeeded] = std::visit(
6235 [&](const auto &v) {
6236 return genArrayCtorInitializer(v, resTy, mem, buffPos, buffSize,
6237 stmtCtx);
6238 },
6239 acv.u);
6240 mlir::Value eleSz = computeElementSize(exv, eleTy, resTy);
6241 mem = copyNeeded ? copyNextArrayCtorSection(exv, buffPos, buffSize, mem,
6242 eleSz, eleTy, eleRefTy, resTy)
6243 : fir::getBase(exv);
6244 if (fir::isa_char(seqTy.getEleTy()) && !charLen) {
6245 charLen = builder.createTemporary(loc, builder.getI64Type());
6246 mlir::Value castLen =
6247 builder.createConvert(loc, builder.getI64Type(), fir::getLen(exv));
6248 assert(charLen.has_value())(static_cast <bool> (charLen.has_value()) ? void (0) : __assert_fail
("charLen.has_value()", "flang/lib/Lower/ConvertExpr.cpp", 6248
, __extension__ __PRETTY_FUNCTION__))
;
6249 builder.create<fir::StoreOp>(loc, castLen, *charLen);
6250 }
6251 }
6252 stmtCtx.finalizeAndPop();
6253
6254 builder.create<fir::ResultOp>(loc, mem);
6255 builder.restoreInsertionPoint(insPt);
6256 mem = loop.getResult(0);
6257 symMap.popImpliedDoBinding();
6258 llvm::SmallVector<mlir::Value> extents = {
6259 builder.create<fir::LoadOp>(loc, buffPos).getResult()};
6260
6261 // Convert to extended value.
6262 if (fir::isa_char(seqTy.getEleTy())) {
6263 assert(charLen.has_value())(static_cast <bool> (charLen.has_value()) ? void (0) : __assert_fail
("charLen.has_value()", "flang/lib/Lower/ConvertExpr.cpp", 6263
, __extension__ __PRETTY_FUNCTION__))
;
6264 auto len = builder.create<fir::LoadOp>(loc, *charLen);
6265 return {fir::CharArrayBoxValue{mem, len, extents}, /*needCopy=*/false};
6266 }
6267 return {fir::ArrayBoxValue{mem, extents}, /*needCopy=*/false};
6268 }
6269
6270 // To simplify the handling and interaction between the various cases, array
6271 // constructors are always lowered to the incremental construction code
6272 // pattern, even if the extent of the array value is constant. After the
6273 // MemToReg pass and constant folding, the optimizer should be able to
6274 // determine that all the buffer overrun tests are false when the
6275 // incremental construction wasn't actually required.
6276 template <typename A>
6277 CC genarr(const Fortran::evaluate::ArrayConstructor<A> &x) {
6278 mlir::Location loc = getLoc();
6279 auto evExpr = toEvExpr(x);
6280 mlir::Type resTy = translateSomeExprToFIRType(converter, evExpr);
6281 mlir::IndexType idxTy = builder.getIndexType();
6282 auto seqTy = resTy.template cast<fir::SequenceType>();
6283 mlir::Type eleTy = fir::unwrapSequenceType(resTy);
6284 mlir::Value buffSize = builder.createTemporary(loc, idxTy, ".buff.size");
6285 mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0);
6286 mlir::Value buffPos = builder.createTemporary(loc, idxTy, ".buff.pos");
6287 builder.create<fir::StoreOp>(loc, zero, buffPos);
6288 // Allocate space for the array to be constructed.
6289 mlir::Value mem;
6290 if (fir::hasDynamicSize(resTy)) {
6291 if (fir::hasDynamicSize(eleTy)) {
6292 // The size of each element may depend on a general expression. Defer
6293 // creating the buffer until after the expression is evaluated.
6294 mem = builder.createNullConstant(loc, builder.getRefType(eleTy));
6295 builder.create<fir::StoreOp>(loc, zero, buffSize);
6296 } else {
6297 mlir::Value initBuffSz =
6298 builder.createIntegerConstant(loc, idxTy, clInitialBufferSize);
6299 mem = builder.create<fir::AllocMemOp>(
6300 loc, eleTy, /*typeparams=*/std::nullopt, initBuffSz);
6301 builder.create<fir::StoreOp>(loc, initBuffSz, buffSize);
6302 }
6303 } else {
6304 mem = builder.create<fir::AllocMemOp>(loc, resTy);
6305 int64_t buffSz = 1;
6306 for (auto extent : seqTy.getShape())
6307 buffSz *= extent;
6308 mlir::Value initBuffSz =
6309 builder.createIntegerConstant(loc, idxTy, buffSz);
6310 builder.create<fir::StoreOp>(loc, initBuffSz, buffSize);
6311 }
6312 // Compute size of element
6313 mlir::Type eleRefTy = builder.getRefType(eleTy);
6314
6315 // Populate the buffer with the elements, growing as necessary.
6316 std::optional<mlir::Value> charLen;
6317 for (const auto &expr : x) {
6318 auto [exv, copyNeeded] = std::visit(
6319 [&](const auto &e) {
6320 return genArrayCtorInitializer(e, resTy, mem, buffPos, buffSize,
6321 stmtCtx);
6322 },
6323 expr.u);
6324 mlir::Value eleSz = computeElementSize(exv, eleTy, resTy);
6325 mem = copyNeeded ? copyNextArrayCtorSection(exv, buffPos, buffSize, mem,
6326 eleSz, eleTy, eleRefTy, resTy)
6327 : fir::getBase(exv);
6328 if (fir::isa_char(seqTy.getEleTy()) && !charLen) {
6329 charLen = builder.createTemporary(loc, builder.getI64Type());
6330 mlir::Value castLen =
6331 builder.createConvert(loc, builder.getI64Type(), fir::getLen(exv));
6332 builder.create<fir::StoreOp>(loc, castLen, *charLen);
6333 }
6334 }
6335 mem = builder.createConvert(loc, fir::HeapType::get(resTy), mem);
6336 llvm::SmallVector<mlir::Value> extents = {
6337 builder.create<fir::LoadOp>(loc, buffPos)};
6338
6339 // Cleanup the temporary.
6340 fir::FirOpBuilder *bldr = &converter.getFirOpBuilder();
6341 stmtCtx.attachCleanup(
6342 [bldr, loc, mem]() { bldr->create<fir::FreeMemOp>(loc, mem); });
6343
6344 // Return the continuation.
6345 if (fir::isa_char(seqTy.getEleTy())) {
6346 if (charLen) {
6347 auto len = builder.create<fir::LoadOp>(loc, *charLen);
6348 return genarr(fir::CharArrayBoxValue{mem, len, extents});
6349 }
6350 return genarr(fir::CharArrayBoxValue{mem, zero, extents});
6351 }
6352 return genarr(fir::ArrayBoxValue{mem, extents});
6353 }
6354
6355 CC genarr(const Fortran::evaluate::ImpliedDoIndex &) {
6356 fir::emitFatalError(getLoc(), "implied do index cannot have rank > 0");
6357 }
6358 CC genarr(const Fortran::evaluate::TypeParamInquiry &x) {
6359 TODO(getLoc(), "array expr type parameter inquiry")do { fir::emitFatalError(getLoc(), llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "6359" ": not yet implemented: ") + llvm::Twine("array expr type parameter inquiry"
), false); } while (false)
;
6360 return [](IterSpace iters) -> ExtValue { return mlir::Value{}; };
6361 }
6362 CC genarr(const Fortran::evaluate::DescriptorInquiry &x) {
6363 TODO(getLoc(), "array expr descriptor inquiry")do { fir::emitFatalError(getLoc(), llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "6363" ": not yet implemented: ") + llvm::Twine("array expr descriptor inquiry"
), false); } while (false)
;
6364 return [](IterSpace iters) -> ExtValue { return mlir::Value{}; };
6365 }
6366 CC genarr(const Fortran::evaluate::StructureConstructor &x) {
6367 TODO(getLoc(), "structure constructor")do { fir::emitFatalError(getLoc(), llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "6367" ": not yet implemented: ") + llvm::Twine("structure constructor"
), false); } while (false)
;
6368 return [](IterSpace iters) -> ExtValue { return mlir::Value{}; };
6369 }
6370
6371 //===--------------------------------------------------------------------===//
6372 // LOCICAL operators (.NOT., .AND., .EQV., etc.)
6373 //===--------------------------------------------------------------------===//
6374
6375 template <int KIND>
6376 CC genarr(const Fortran::evaluate::Not<KIND> &x) {
6377 mlir::Location loc = getLoc();
6378 mlir::IntegerType i1Ty = builder.getI1Type();
6379 auto lambda = genarr(x.left());
6380 mlir::Value truth = builder.createBool(loc, true);
6381 return [=](IterSpace iters) -> ExtValue {
6382 mlir::Value logical = fir::getBase(lambda(iters));
6383 mlir::Value val = builder.createConvert(loc, i1Ty, logical);
6384 return builder.create<mlir::arith::XOrIOp>(loc, val, truth);
6385 };
6386 }
6387 template <typename OP, typename A>
6388 CC createBinaryBoolOp(const A &x) {
6389 mlir::Location loc = getLoc();
6390 mlir::IntegerType i1Ty = builder.getI1Type();
6391 auto lf = genarr(x.left());
6392 auto rf = genarr(x.right());
6393 return [=](IterSpace iters) -> ExtValue {
6394 mlir::Value left = fir::getBase(lf(iters));
6395 mlir::Value right = fir::getBase(rf(iters));
6396 mlir::Value lhs = builder.createConvert(loc, i1Ty, left);
6397 mlir::Value rhs = builder.createConvert(loc, i1Ty, right);
6398 return builder.create<OP>(loc, lhs, rhs);
6399 };
6400 }
6401 template <typename OP, typename A>
6402 CC createCompareBoolOp(mlir::arith::CmpIPredicate pred, const A &x) {
6403 mlir::Location loc = getLoc();
6404 mlir::IntegerType i1Ty = builder.getI1Type();
6405 auto lf = genarr(x.left());
6406 auto rf = genarr(x.right());
6407 return [=](IterSpace iters) -> ExtValue {
6408 mlir::Value left = fir::getBase(lf(iters));
6409 mlir::Value right = fir::getBase(rf(iters));
6410 mlir::Value lhs = builder.createConvert(loc, i1Ty, left);
6411 mlir::Value rhs = builder.createConvert(loc, i1Ty, right);
6412 return builder.create<OP>(loc, pred, lhs, rhs);
6413 };
6414 }
6415 template <int KIND>
6416 CC genarr(const Fortran::evaluate::LogicalOperation<KIND> &x) {
6417 switch (x.logicalOperator) {
6418 case Fortran::evaluate::LogicalOperator::And:
6419 return createBinaryBoolOp<mlir::arith::AndIOp>(x);
6420 case Fortran::evaluate::LogicalOperator::Or:
6421 return createBinaryBoolOp<mlir::arith::OrIOp>(x);
6422 case Fortran::evaluate::LogicalOperator::Eqv:
6423 return createCompareBoolOp<mlir::arith::CmpIOp>(
6424 mlir::arith::CmpIPredicate::eq, x);
6425 case Fortran::evaluate::LogicalOperator::Neqv:
6426 return createCompareBoolOp<mlir::arith::CmpIOp>(
6427 mlir::arith::CmpIPredicate::ne, x);
6428 case Fortran::evaluate::LogicalOperator::Not:
6429 llvm_unreachable(".NOT. handled elsewhere")::llvm::llvm_unreachable_internal(".NOT. handled elsewhere", "flang/lib/Lower/ConvertExpr.cpp"
, 6429)
;
6430 }
6431 llvm_unreachable("unhandled case")::llvm::llvm_unreachable_internal("unhandled case", "flang/lib/Lower/ConvertExpr.cpp"
, 6431)
;
6432 }
6433
6434 //===--------------------------------------------------------------------===//
6435 // Relational operators (<, <=, ==, etc.)
6436 //===--------------------------------------------------------------------===//
6437
6438 template <typename OP, typename PRED, typename A>
6439 CC createCompareOp(PRED pred, const A &x) {
6440 mlir::Location loc = getLoc();
6441 auto lf = genarr(x.left());
6442 auto rf = genarr(x.right());
6443 return [=](IterSpace iters) -> ExtValue {
6444 mlir::Value lhs = fir::getBase(lf(iters));
6445 mlir::Value rhs = fir::getBase(rf(iters));
6446 return builder.create<OP>(loc, pred, lhs, rhs);
6447 };
6448 }
6449 template <typename A>
6450 CC createCompareCharOp(mlir::arith::CmpIPredicate pred, const A &x) {
6451 mlir::Location loc = getLoc();
6452 auto lf = genarr(x.left());
6453 auto rf = genarr(x.right());
6454 return [=](IterSpace iters) -> ExtValue {
6455 auto lhs = lf(iters);
6456 auto rhs = rf(iters);
6457 return fir::runtime::genCharCompare(builder, loc, pred, lhs, rhs);
6458 };
6459 }
6460 template <int KIND>
6461 CC genarr(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
6462 Fortran::common::TypeCategory::Integer, KIND>> &x) {
6463 return createCompareOp<mlir::arith::CmpIOp>(translateRelational(x.opr), x);
6464 }
6465 template <int KIND>
6466 CC genarr(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
6467 Fortran::common::TypeCategory::Character, KIND>> &x) {
6468 return createCompareCharOp(translateRelational(x.opr), x);
6469 }
6470 template <int KIND>
6471 CC genarr(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
6472 Fortran::common::TypeCategory::Real, KIND>> &x) {
6473 return createCompareOp<mlir::arith::CmpFOp>(translateFloatRelational(x.opr),
6474 x);
6475 }
6476 template <int KIND>
6477 CC genarr(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
6478 Fortran::common::TypeCategory::Complex, KIND>> &x) {
6479 return createCompareOp<fir::CmpcOp>(translateFloatRelational(x.opr), x);
6480 }
6481 CC genarr(
6482 const Fortran::evaluate::Relational<Fortran::evaluate::SomeType> &r) {
6483 return std::visit([&](const auto &x) { return genarr(x); }, r.u);
6484 }
6485
6486 template <typename A>
6487 CC genarr(const Fortran::evaluate::Designator<A> &des) {
6488 ComponentPath components(des.Rank() > 0);
6489 return std::visit([&](const auto &x) { return genarr(x, components); },
1
Calling 'ArrayExprLowering::genarr'
6490 des.u);
6491 }
6492
6493 /// Is the path component rank > 0?
6494 static bool ranked(const PathComponent &x) {
6495 return std::visit(Fortran::common::visitors{
6496 [](const ImplicitSubscripts &) { return false; },
6497 [](const auto *v) { return v->Rank() > 0; }},
6498 x);
6499 }
6500
6501 void extendComponent(Fortran::lower::ComponentPath &component,
6502 mlir::Type coorTy, mlir::ValueRange vals) {
6503 auto *bldr = &converter.getFirOpBuilder();
6504 llvm::SmallVector<mlir::Value> offsets(vals.begin(), vals.end());
6505 auto currentFunc = component.getExtendCoorRef();
6506 auto loc = getLoc();
6507 auto newCoorRef = [bldr, coorTy, offsets, currentFunc,
6508 loc](mlir::Value val) -> mlir::Value {
6509 return bldr->create<fir::CoordinateOp>(loc, bldr->getRefType(coorTy),
6510 currentFunc(val), offsets);
6511 };
6512 component.extendCoorRef = newCoorRef;
6513 }
6514
6515 //===-------------------------------------------------------------------===//
6516 // Array data references in an explicit iteration space.
6517 //
6518 // Use the base array that was loaded before the loop nest.
6519 //===-------------------------------------------------------------------===//
6520
6521 /// Lower the path (`revPath`, in reverse) to be appended to an array_fetch or
6522 /// array_update op. \p ty is the initial type of the array
6523 /// (reference). Returns the type of the element after application of the
6524 /// path in \p components.
6525 ///
6526 /// TODO: This needs to deal with array's with initial bounds other than 1.
6527 /// TODO: Thread type parameters correctly.
6528 mlir::Type lowerPath(const ExtValue &arrayExv, ComponentPath &components) {
6529 mlir::Location loc = getLoc();
6530 mlir::Type ty = fir::getBase(arrayExv).getType();
6531 auto &revPath = components.reversePath;
6532 ty = fir::unwrapPassByRefType(ty);
6533 bool prefix = true;
6534 bool deref = false;
6535 auto addComponentList = [&](mlir::Type ty, mlir::ValueRange vals) {
6536 if (deref) {
6537 extendComponent(components, ty, vals);
6538 } else if (prefix) {
6539 for (auto v : vals)
6540 components.prefixComponents.push_back(v);
6541 } else {
6542 for (auto v : vals)
6543 components.suffixComponents.push_back(v);
6544 }
6545 };
6546 mlir::IndexType idxTy = builder.getIndexType();
6547 mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
6548 bool atBase = true;
6549 auto saveSemant = semant;
6550 if (isProjectedCopyInCopyOut())
6551 semant = ConstituentSemantics::RefTransparent;
6552 unsigned index = 0;
6553 for (const auto &v : llvm::reverse(revPath)) {
6554 std::visit(
6555 Fortran::common::visitors{
6556 [&](const ImplicitSubscripts &) {
6557 prefix = false;
6558 ty = fir::unwrapSequenceType(ty);
6559 },
6560 [&](const Fortran::evaluate::ComplexPart *x) {
6561 assert(!prefix && "complex part must be at end")(static_cast <bool> (!prefix && "complex part must be at end"
) ? void (0) : __assert_fail ("!prefix && \"complex part must be at end\""
, "flang/lib/Lower/ConvertExpr.cpp", 6561, __extension__ __PRETTY_FUNCTION__
))
;
6562 mlir::Value offset = builder.createIntegerConstant(
6563 loc, builder.getI32Type(),
6564 x->part() == Fortran::evaluate::ComplexPart::Part::RE ? 0
6565 : 1);
6566 components.suffixComponents.push_back(offset);
6567 ty = fir::applyPathToType(ty, mlir::ValueRange{offset});
6568 },
6569 [&](const Fortran::evaluate::ArrayRef *x) {
6570 if (Fortran::lower::isRankedArrayAccess(*x)) {
6571 genSliceIndices(components, arrayExv, *x, atBase);
6572 ty = fir::unwrapSeqOrBoxedSeqType(ty);
6573 } else {
6574 // Array access where the expressions are scalar and cannot
6575 // depend upon the implied iteration space.
6576 unsigned ssIndex = 0u;
6577 llvm::SmallVector<mlir::Value> componentsToAdd;
6578 for (const auto &ss : x->subscript()) {
6579 std::visit(
6580 Fortran::common::visitors{
6581 [&](const Fortran::evaluate::
6582 IndirectSubscriptIntegerExpr &ie) {
6583 const auto &e = ie.value();
6584 if (isArray(e))
6585 fir::emitFatalError(
6586 loc,
6587 "multiple components along single path "
6588 "generating array subexpressions");
6589 // Lower scalar index expression, append it to
6590 // subs.
6591 mlir::Value subscriptVal =
6592 fir::getBase(asScalarArray(e));
6593 // arrayExv is the base array. It needs to reflect
6594 // the current array component instead.
6595 // FIXME: must use lower bound of this component,
6596 // not just the constant 1.
6597 mlir::Value lb =
6598 atBase ? fir::factory::readLowerBound(
6599 builder, loc, arrayExv, ssIndex,
6600 one)
6601 : one;
6602 mlir::Value val = builder.createConvert(
6603 loc, idxTy, subscriptVal);
6604 mlir::Value ivAdj =
6605 builder.create<mlir::arith::SubIOp>(
6606 loc, idxTy, val, lb);
6607 componentsToAdd.push_back(
6608 builder.createConvert(loc, idxTy, ivAdj));
6609 },
6610 [&](const auto &) {
6611 fir::emitFatalError(
6612 loc, "multiple components along single path "
6613 "generating array subexpressions");
6614 }},
6615 ss.u);
6616 ssIndex++;
6617 }
6618 ty = fir::unwrapSeqOrBoxedSeqType(ty);
6619 addComponentList(ty, componentsToAdd);
6620 }
6621 },
6622 [&](const Fortran::evaluate::Component *x) {
6623 auto fieldTy = fir::FieldType::get(builder.getContext());
6624 llvm::StringRef name = toStringRef(getLastSym(*x).name());
6625 if (auto recTy = ty.dyn_cast<fir::RecordType>()) {
6626 ty = recTy.getType(name);
6627 auto fld = builder.create<fir::FieldIndexOp>(
6628 loc, fieldTy, name, recTy, fir::getTypeParams(arrayExv));
6629 addComponentList(ty, {fld});
6630 if (index != revPath.size() - 1 || !isPointerAssignment()) {
6631 // Need an intermediate dereference if the boxed value
6632 // appears in the middle of the component path or if it is
6633 // on the right and this is not a pointer assignment.
6634 if (auto boxTy = ty.dyn_cast<fir::BaseBoxType>()) {
6635 auto currentFunc = components.getExtendCoorRef();
6636 auto loc = getLoc();
6637 auto *bldr = &converter.getFirOpBuilder();
6638 auto newCoorRef = [=](mlir::Value val) -> mlir::Value {
6639 return bldr->create<fir::LoadOp>(loc, currentFunc(val));
6640 };
6641 components.extendCoorRef = newCoorRef;
6642 deref = true;
6643 }
6644 }
6645 } else if (auto boxTy = ty.dyn_cast<fir::BaseBoxType>()) {
6646 ty = fir::unwrapRefType(boxTy.getEleTy());
6647 auto recTy = ty.cast<fir::RecordType>();
6648 ty = recTy.getType(name);
6649 auto fld = builder.create<fir::FieldIndexOp>(
6650 loc, fieldTy, name, recTy, fir::getTypeParams(arrayExv));
6651 extendComponent(components, ty, {fld});
6652 } else {
6653 TODO(loc, "other component type")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "6653" ": not yet implemented: ") + llvm::Twine("other component type"
), false); } while (false)
;
6654 }
6655 }},
6656 v);
6657 atBase = false;
6658 ++index;
6659 }
6660 semant = saveSemant;
6661 ty = fir::unwrapSequenceType(ty);
6662 components.applied = true;
6663 return ty;
6664 }
6665
6666 llvm::SmallVector<mlir::Value> genSubstringBounds(ComponentPath &components) {
6667 llvm::SmallVector<mlir::Value> result;
6668 if (components.substring)
6669 populateBounds(result, components.substring);
6670 return result;
6671 }
6672
6673 CC applyPathToArrayLoad(fir::ArrayLoadOp load, ComponentPath &components) {
6674 mlir::Location loc = getLoc();
6675 auto revPath = components.reversePath;
6676 fir::ExtendedValue arrayExv =
6677 arrayLoadExtValue(builder, loc, load, {}, load);
6678 mlir::Type eleTy = lowerPath(arrayExv, components);
6679 auto currentPC = components.pc;
6680 auto pc = [=, prefix = components.prefixComponents,
6681 suffix = components.suffixComponents](IterSpace iters) {
6682 // Add path prefix and suffix.
6683 return IterationSpace(currentPC(iters), prefix, suffix);
6684 };
6685 components.resetPC();
6686 llvm::SmallVector<mlir::Value> substringBounds =
6687 genSubstringBounds(components);
6688 if (isProjectedCopyInCopyOut()) {
6689 destination = load;
6690 auto lambda = [=, esp = this->explicitSpace](IterSpace iters) mutable {
6691 mlir::Value innerArg = esp->findArgumentOfLoad(load);
6692 if (isAdjustedArrayElementType(eleTy)) {
6693 mlir::Type eleRefTy = builder.getRefType(eleTy);
6694 auto arrayOp = builder.create<fir::ArrayAccessOp>(
6695 loc, eleRefTy, innerArg, iters.iterVec(),
6696 fir::factory::getTypeParams(loc, builder, load));
6697 if (auto charTy = eleTy.dyn_cast<fir::CharacterType>()) {
6698 mlir::Value dstLen = fir::factory::genLenOfCharacter(
6699 builder, loc, load, iters.iterVec(), substringBounds);
6700 fir::ArrayAmendOp amend = createCharArrayAmend(
6701 loc, builder, arrayOp, dstLen, iters.elementExv(), innerArg,
6702 substringBounds);
6703 return arrayLoadExtValue(builder, loc, load, iters.iterVec(), amend,
6704 dstLen);
6705 }
6706 if (fir::isa_derived(eleTy)) {
6707 fir::ArrayAmendOp amend =
6708 createDerivedArrayAmend(loc, load, builder, arrayOp,
6709 iters.elementExv(), eleTy, innerArg);
6710 return arrayLoadExtValue(builder, loc, load, iters.iterVec(),
6711 amend);
6712 }
6713 assert(eleTy.isa<fir::SequenceType>())(static_cast <bool> (eleTy.isa<fir::SequenceType>
()) ? void (0) : __assert_fail ("eleTy.isa<fir::SequenceType>()"
, "flang/lib/Lower/ConvertExpr.cpp", 6713, __extension__ __PRETTY_FUNCTION__
))
;
6714 TODO(loc, "array (as element) assignment")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "6714" ": not yet implemented: ") + llvm::Twine("array (as element) assignment"
), false); } while (false)
;
6715 }
6716 if (components.hasExtendCoorRef()) {
6717 auto eleBoxTy =
6718 fir::applyPathToType(innerArg.getType(), iters.iterVec());
6719 if (!eleBoxTy || !eleBoxTy.isa<fir::BoxType>())
6720 TODO(loc, "assignment in a FORALL involving a designator with a "do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "6721" ": not yet implemented: ") + llvm::Twine("assignment in a FORALL involving a designator with a "
"POINTER or ALLOCATABLE component part-ref"), false); } while
(false)
6721 "POINTER or ALLOCATABLE component part-ref")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "6721" ": not yet implemented: ") + llvm::Twine("assignment in a FORALL involving a designator with a "
"POINTER or ALLOCATABLE component part-ref"), false); } while
(false)
;
6722 auto arrayOp = builder.create<fir::ArrayAccessOp>(
6723 loc, builder.getRefType(eleBoxTy), innerArg, iters.iterVec(),
6724 fir::factory::getTypeParams(loc, builder, load));
6725 mlir::Value addr = components.getExtendCoorRef()(arrayOp);
6726 components.resetExtendCoorRef();
6727 // When the lhs is a boxed value and the context is not a pointer
6728 // assignment, then insert the dereference of the box before any
6729 // conversion and store.
6730 if (!isPointerAssignment()) {
6731 if (auto boxTy = eleTy.dyn_cast<fir::BaseBoxType>()) {
6732 eleTy = fir::boxMemRefType(boxTy);
6733 addr = builder.create<fir::BoxAddrOp>(loc, eleTy, addr);
6734 eleTy = fir::unwrapRefType(eleTy);
6735 }
6736 }
6737 auto ele = convertElementForUpdate(loc, eleTy, iters.getElement());
6738 builder.create<fir::StoreOp>(loc, ele, addr);
6739 auto amend = builder.create<fir::ArrayAmendOp>(
6740 loc, innerArg.getType(), innerArg, arrayOp);
6741 return arrayLoadExtValue(builder, loc, load, iters.iterVec(), amend);
6742 }
6743 auto ele = convertElementForUpdate(loc, eleTy, iters.getElement());
6744 auto update = builder.create<fir::ArrayUpdateOp>(
6745 loc, innerArg.getType(), innerArg, ele, iters.iterVec(),
6746 fir::factory::getTypeParams(loc, builder, load));
6747 return arrayLoadExtValue(builder, loc, load, iters.iterVec(), update);
6748 };
6749 return [=](IterSpace iters) mutable { return lambda(pc(iters)); };
6750 }
6751 if (isCustomCopyInCopyOut()) {
6752 // Create an array_modify to get the LHS element address and indicate
6753 // the assignment, and create the call to the user defined assignment.
6754 destination = load;
6755 auto lambda = [=](IterSpace iters) mutable {
6756 mlir::Value innerArg = explicitSpace->findArgumentOfLoad(load);
6757 mlir::Type refEleTy =
6758 fir::isa_ref_type(eleTy) ? eleTy : builder.getRefType(eleTy);
6759 auto arrModify = builder.create<fir::ArrayModifyOp>(
6760 loc, mlir::TypeRange{refEleTy, innerArg.getType()}, innerArg,
6761 iters.iterVec(), load.getTypeparams());
6762 return arrayLoadExtValue(builder, loc, load, iters.iterVec(),
6763 arrModify.getResult(1));
6764 };
6765 return [=](IterSpace iters) mutable { return lambda(pc(iters)); };
6766 }
6767 auto lambda = [=, semant = this->semant](IterSpace iters) mutable {
6768 if (semant == ConstituentSemantics::RefOpaque ||
6769 isAdjustedArrayElementType(eleTy)) {
6770 mlir::Type resTy = builder.getRefType(eleTy);
6771 // Use array element reference semantics.
6772 auto access = builder.create<fir::ArrayAccessOp>(
6773 loc, resTy, load, iters.iterVec(),
6774 fir::factory::getTypeParams(loc, builder, load));
6775 mlir::Value newBase = access;
6776 if (fir::isa_char(eleTy)) {
6777 mlir::Value dstLen = fir::factory::genLenOfCharacter(
6778 builder, loc, load, iters.iterVec(), substringBounds);
6779 if (!substringBounds.empty()) {
6780 fir::CharBoxValue charDst{access, dstLen};
6781 fir::factory::CharacterExprHelper helper{builder, loc};
6782 charDst = helper.createSubstring(charDst, substringBounds);
6783 newBase = charDst.getAddr();
6784 }
6785 return arrayLoadExtValue(builder, loc, load, iters.iterVec(), newBase,
6786 dstLen);
6787 }
6788 return arrayLoadExtValue(builder, loc, load, iters.iterVec(), newBase);
6789 }
6790 if (components.hasExtendCoorRef()) {
6791 auto eleBoxTy = fir::applyPathToType(load.getType(), iters.iterVec());
6792 if (!eleBoxTy || !eleBoxTy.isa<fir::BoxType>())
6793 TODO(loc, "assignment in a FORALL involving a designator with a "do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "6794" ": not yet implemented: ") + llvm::Twine("assignment in a FORALL involving a designator with a "
"POINTER or ALLOCATABLE component part-ref"), false); } while
(false)
6794 "POINTER or ALLOCATABLE component part-ref")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "6794" ": not yet implemented: ") + llvm::Twine("assignment in a FORALL involving a designator with a "
"POINTER or ALLOCATABLE component part-ref"), false); } while
(false)
;
6795 auto access = builder.create<fir::ArrayAccessOp>(
6796 loc, builder.getRefType(eleBoxTy), load, iters.iterVec(),
6797 fir::factory::getTypeParams(loc, builder, load));
6798 mlir::Value addr = components.getExtendCoorRef()(access);
6799 components.resetExtendCoorRef();
6800 return arrayLoadExtValue(builder, loc, load, iters.iterVec(), addr);
6801 }
6802 if (isPointerAssignment()) {
6803 auto eleTy = fir::applyPathToType(load.getType(), iters.iterVec());
6804 if (!eleTy.isa<fir::BoxType>()) {
6805 // Rhs is a regular expression that will need to be boxed before
6806 // assigning to the boxed variable.
6807 auto typeParams = fir::factory::getTypeParams(loc, builder, load);
6808 auto access = builder.create<fir::ArrayAccessOp>(
6809 loc, builder.getRefType(eleTy), load, iters.iterVec(),
6810 typeParams);
6811 auto addr = components.getExtendCoorRef()(access);
6812 components.resetExtendCoorRef();
6813 auto ptrEleTy = fir::PointerType::get(eleTy);
6814 auto ptrAddr = builder.createConvert(loc, ptrEleTy, addr);
6815 auto boxTy = fir::BoxType::get(ptrEleTy);
6816 // FIXME: The typeparams to the load may be different than those of
6817 // the subobject.
6818 if (components.hasExtendCoorRef())
6819 TODO(loc, "need to adjust typeparameter(s) to reflect the final "do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "6820" ": not yet implemented: ") + llvm::Twine("need to adjust typeparameter(s) to reflect the final "
"component"), false); } while (false)
6820 "component")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "6820" ": not yet implemented: ") + llvm::Twine("need to adjust typeparameter(s) to reflect the final "
"component"), false); } while (false)
;
6821 mlir::Value embox =
6822 builder.create<fir::EmboxOp>(loc, boxTy, ptrAddr,
6823 /*shape=*/mlir::Value{},
6824 /*slice=*/mlir::Value{}, typeParams);
6825 return arrayLoadExtValue(builder, loc, load, iters.iterVec(), embox);
6826 }
6827 }
6828 auto fetch = builder.create<fir::ArrayFetchOp>(
6829 loc, eleTy, load, iters.iterVec(), load.getTypeparams());
6830 return arrayLoadExtValue(builder, loc, load, iters.iterVec(), fetch);
6831 };
6832 return [=](IterSpace iters) mutable { return lambda(pc(iters)); };
6833 }
6834
6835 template <typename A>
6836 CC genImplicitArrayAccess(const A &x, ComponentPath &components) {
6837 components.reversePath.push_back(ImplicitSubscripts{});
6838 ExtValue exv = asScalarRef(x);
6839 lowerPath(exv, components);
6840 auto lambda = genarr(exv, components);
6841 return [=](IterSpace iters) { return lambda(components.pc(iters)); };
12
Calling constructor for 'function<fir::ExtendedValue (const Fortran::lower::IterationSpace &)>'
19
Returning from constructor for 'function<fir::ExtendedValue (const Fortran::lower::IterationSpace &)>'
6842 }
6843 CC genImplicitArrayAccess(const Fortran::evaluate::NamedEntity &x,
6844 ComponentPath &components) {
6845 if (x.IsSymbol())
6846 return genImplicitArrayAccess(getFirstSym(x), components);
6847 return genImplicitArrayAccess(x.GetComponent(), components);
6848 }
6849
6850 template <typename A>
6851 CC genAsScalar(const A &x) {
6852 mlir::Location loc = getLoc();
6853 if (isProjectedCopyInCopyOut()) {
6854 return [=, &x, builder = &converter.getFirOpBuilder()](
6855 IterSpace iters) -> ExtValue {
6856 ExtValue exv = asScalarRef(x);
6857 mlir::Value addr = fir::getBase(exv);
6858 mlir::Type eleTy = fir::unwrapRefType(addr.getType());
6859 if (isAdjustedArrayElementType(eleTy)) {
6860 if (fir::isa_char(eleTy)) {
6861 fir::factory::CharacterExprHelper{*builder, loc}.createAssign(
6862 exv, iters.elementExv());
6863 } else if (fir::isa_derived(eleTy)) {
6864 TODO(loc, "assignment of derived type")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "6864" ": not yet implemented: ") + llvm::Twine("assignment of derived type"
), false); } while (false)
;
6865 } else {
6866 fir::emitFatalError(loc, "array type not expected in scalar");
6867 }
6868 } else {
6869 auto eleVal = convertElementForUpdate(loc, eleTy, iters.getElement());
6870 builder->create<fir::StoreOp>(loc, eleVal, addr);
6871 }
6872 return exv;
6873 };
6874 }
6875 return [=, &x](IterSpace) { return asScalar(x); };
6876 }
6877
6878 bool tailIsPointerInPointerAssignment(const Fortran::semantics::Symbol &x,
6879 ComponentPath &components) {
6880 return isPointerAssignment() && Fortran::semantics::IsPointer(x) &&
6881 !components.hasComponents();
6882 }
6883 bool tailIsPointerInPointerAssignment(const Fortran::evaluate::Component &x,
6884 ComponentPath &components) {
6885 return tailIsPointerInPointerAssignment(getLastSym(x), components);
6886 }
6887
6888 CC genarr(const Fortran::semantics::Symbol &x, ComponentPath &components) {
6889 if (explicitSpaceIsActive()) {
6890 if (x.Rank() > 0 && !tailIsPointerInPointerAssignment(x, components))
6891 components.reversePath.push_back(ImplicitSubscripts{});
6892 if (fir::ArrayLoadOp load = explicitSpace->findBinding(&x))
6893 return applyPathToArrayLoad(load, components);
6894 } else {
6895 return genImplicitArrayAccess(x, components);
6896 }
6897 if (pathIsEmpty(components))
6898 return components.substring ? genAsScalar(*components.substring)
6899 : genAsScalar(x);
6900 mlir::Location loc = getLoc();
6901 return [=](IterSpace) -> ExtValue {
6902 fir::emitFatalError(loc, "reached symbol with path");
6903 };
6904 }
6905
6906 /// Lower a component path with or without rank.
6907 /// Example: <code>array%baz%qux%waldo</code>
6908 CC genarr(const Fortran::evaluate::Component &x, ComponentPath &components) {
6909 if (explicitSpaceIsActive()) {
8
Taking false branch
6910 if (x.base().Rank() == 0 && x.Rank() > 0 &&
6911 !tailIsPointerInPointerAssignment(x, components))
6912 components.reversePath.push_back(ImplicitSubscripts{});
6913 if (fir::ArrayLoadOp load = explicitSpace->findBinding(&x))
6914 return applyPathToArrayLoad(load, components);
6915 } else {
6916 if (x.base().Rank() == 0)
9
Assuming the condition is true
10
Taking true branch
6917 return genImplicitArrayAccess(x, components);
11
Calling 'ArrayExprLowering::genImplicitArrayAccess'
20
Returned allocated memory
6918 }
6919 bool atEnd = pathIsEmpty(components);
6920 if (!getLastSym(x).test(Fortran::semantics::Symbol::Flag::ParentComp))
6921 // Skip parent components; their components are placed directly in the
6922 // object.
6923 components.reversePath.push_back(&x);
6924 auto result = genarr(x.base(), components);
6925 if (components.applied)
6926 return result;
6927 if (atEnd)
6928 return genAsScalar(x);
6929 mlir::Location loc = getLoc();
6930 return [=](IterSpace) -> ExtValue {
6931 fir::emitFatalError(loc, "reached component with path");
6932 };
6933 }
6934
6935 /// Array reference with subscripts. If this has rank > 0, this is a form
6936 /// of an array section (slice).
6937 ///
6938 /// There are two "slicing" primitives that may be applied on a dimension by
6939 /// dimension basis: (1) triple notation and (2) vector addressing. Since
6940 /// dimensions can be selectively sliced, some dimensions may contain
6941 /// regular scalar expressions and those dimensions do not participate in
6942 /// the array expression evaluation.
6943 CC genarr(const Fortran::evaluate::ArrayRef &x, ComponentPath &components) {
6944 if (explicitSpaceIsActive()) {
2
Taking false branch
6945 if (Fortran::lower::isRankedArrayAccess(x))
6946 components.reversePath.push_back(ImplicitSubscripts{});
6947 if (fir::ArrayLoadOp load = explicitSpace->findBinding(&x)) {
6948 components.reversePath.push_back(&x);
6949 return applyPathToArrayLoad(load, components);
6950 }
6951 } else {
6952 if (Fortran::lower::isRankedArrayAccess(x)) {
3
Assuming the condition is false
4
Taking false branch
6953 components.reversePath.push_back(&x);
6954 return genImplicitArrayAccess(x.base(), components);
6955 }
6956 }
6957 bool atEnd = pathIsEmpty(components);
6958 components.reversePath.push_back(&x);
6959 auto result = genarr(x.base(), components);
5
Calling 'ArrayExprLowering::genarr'
6960 if (components.applied)
6961 return result;
6962 mlir::Location loc = getLoc();
6963 if (atEnd) {
6964 if (x.Rank() == 0)
6965 return genAsScalar(x);
6966 fir::emitFatalError(loc, "expected scalar");
6967 }
6968 return [=](IterSpace) -> ExtValue {
6969 fir::emitFatalError(loc, "reached arrayref with path");
6970 };
6971 }
6972
6973 CC genarr(const Fortran::evaluate::CoarrayRef &x, ComponentPath &components) {
6974 TODO(getLoc(), "coarray reference")do { fir::emitFatalError(getLoc(), llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "6974" ": not yet implemented: ") + llvm::Twine("coarray reference"
), false); } while (false)
;
6975 }
6976
6977 CC genarr(const Fortran::evaluate::NamedEntity &x,
6978 ComponentPath &components) {
6979 return x.IsSymbol() ? genarr(getFirstSym(x), components)
6
'?' condition is false
6980 : genarr(x.GetComponent(), components);
7
Calling 'ArrayExprLowering::genarr'
21
Returned allocated memory
6981 }
22
Potential memory leak
6982
6983 CC genarr(const Fortran::evaluate::DataRef &x, ComponentPath &components) {
6984 return std::visit([&](const auto &v) { return genarr(v, components); },
6985 x.u);
6986 }
6987
6988 bool pathIsEmpty(const ComponentPath &components) {
6989 return components.reversePath.empty();
6990 }
6991
6992 explicit ArrayExprLowering(Fortran::lower::AbstractConverter &converter,
6993 Fortran::lower::StatementContext &stmtCtx,
6994 Fortran::lower::SymMap &symMap)
6995 : converter{converter}, builder{converter.getFirOpBuilder()},
6996 stmtCtx{stmtCtx}, symMap{symMap} {}
6997
6998 explicit ArrayExprLowering(Fortran::lower::AbstractConverter &converter,
6999 Fortran::lower::StatementContext &stmtCtx,
7000 Fortran::lower::SymMap &symMap,
7001 ConstituentSemantics sem)
7002 : converter{converter}, builder{converter.getFirOpBuilder()},
7003 stmtCtx{stmtCtx}, symMap{symMap}, semant{sem} {}
7004
7005 explicit ArrayExprLowering(Fortran::lower::AbstractConverter &converter,
7006 Fortran::lower::StatementContext &stmtCtx,
7007 Fortran::lower::SymMap &symMap,
7008 ConstituentSemantics sem,
7009 Fortran::lower::ExplicitIterSpace *expSpace,
7010 Fortran::lower::ImplicitIterSpace *impSpace)
7011 : converter{converter}, builder{converter.getFirOpBuilder()},
7012 stmtCtx{stmtCtx}, symMap{symMap},
7013 explicitSpace((expSpace && expSpace->isActive()) ? expSpace : nullptr),
7014 implicitSpace((impSpace && !impSpace->empty()) ? impSpace : nullptr),
7015 semant{sem} {
7016 // Generate any mask expressions, as necessary. This is the compute step
7017 // that creates the effective masks. See 10.2.3.2 in particular.
7018 genMasks();
7019 }
7020
7021 mlir::Location getLoc() { return converter.getCurrentLocation(); }
7022
7023 /// Array appears in a lhs context such that it is assigned after the rhs is
7024 /// fully evaluated.
7025 inline bool isCopyInCopyOut() {
7026 return semant == ConstituentSemantics::CopyInCopyOut;
7027 }
7028
7029 /// Array appears in a lhs (or temp) context such that a projected,
7030 /// discontiguous subspace of the array is assigned after the rhs is fully
7031 /// evaluated. That is, the rhs array value is merged into a section of the
7032 /// lhs array.
7033 inline bool isProjectedCopyInCopyOut() {
7034 return semant == ConstituentSemantics::ProjectedCopyInCopyOut;
7035 }
7036
7037 // ???: Do we still need this?
7038 inline bool isCustomCopyInCopyOut() {
7039 return semant == ConstituentSemantics::CustomCopyInCopyOut;
7040 }
7041
7042 /// Are we lowering in a left-hand side context?
7043 inline bool isLeftHandSide() {
7044 return isCopyInCopyOut() || isProjectedCopyInCopyOut() ||
7045 isCustomCopyInCopyOut();
7046 }
7047
7048 /// Array appears in a context where it must be boxed.
7049 inline bool isBoxValue() { return semant == ConstituentSemantics::BoxValue; }
7050
7051 /// Array appears in a context where differences in the memory reference can
7052 /// be observable in the computational results. For example, an array
7053 /// element is passed to an impure procedure.
7054 inline bool isReferentiallyOpaque() {
7055 return semant == ConstituentSemantics::RefOpaque;
7056 }
7057
7058 /// Array appears in a context where it is passed as a VALUE argument.
7059 inline bool isValueAttribute() {
7060 return semant == ConstituentSemantics::ByValueArg;
7061 }
7062
7063 /// Can the loops over the expression be unordered?
7064 inline bool isUnordered() const { return unordered; }
7065
7066 void setUnordered(bool b) { unordered = b; }
7067
7068 inline bool isPointerAssignment() const { return lbounds.has_value(); }
7069
7070 inline bool isBoundsSpec() const {
7071 return isPointerAssignment() && !ubounds.has_value();
7072 }
7073
7074 inline bool isBoundsRemap() const {
7075 return isPointerAssignment() && ubounds.has_value();
7076 }
7077
7078 void setPointerAssignmentBounds(
7079 const llvm::SmallVector<mlir::Value> &lbs,
7080 std::optional<llvm::SmallVector<mlir::Value>> ubs) {
7081 lbounds = lbs;
7082 ubounds = ubs;
7083 }
7084
7085 void setLoweredProcRef(const Fortran::evaluate::ProcedureRef *procRef) {
7086 loweredProcRef = procRef;
7087 }
7088
7089 Fortran::lower::AbstractConverter &converter;
7090 fir::FirOpBuilder &builder;
7091 Fortran::lower::StatementContext &stmtCtx;
7092 bool elementCtx = false;
7093 Fortran::lower::SymMap &symMap;
7094 /// The continuation to generate code to update the destination.
7095 std::optional<CC> ccStoreToDest;
7096 std::optional<std::function<void(llvm::ArrayRef<mlir::Value>)>> ccPrelude;
7097 std::optional<std::function<fir::ArrayLoadOp(llvm::ArrayRef<mlir::Value>)>>
7098 ccLoadDest;
7099 /// The destination is the loaded array into which the results will be
7100 /// merged.
7101 fir::ArrayLoadOp destination;
7102 /// The shape of the destination.
7103 llvm::SmallVector<mlir::Value> destShape;
7104 /// List of arrays in the expression that have been loaded.
7105 llvm::SmallVector<ArrayOperand> arrayOperands;
7106 /// If there is a user-defined iteration space, explicitShape will hold the
7107 /// information from the front end.
7108 Fortran::lower::ExplicitIterSpace *explicitSpace = nullptr;
7109 Fortran::lower::ImplicitIterSpace *implicitSpace = nullptr;
7110 ConstituentSemantics semant = ConstituentSemantics::RefTransparent;
7111 /// `lbounds`, `ubounds` are used in POINTER value assignments, which may only
7112 /// occur in an explicit iteration space.
7113 std::optional<llvm::SmallVector<mlir::Value>> lbounds;
7114 std::optional<llvm::SmallVector<mlir::Value>> ubounds;
7115 // Can the array expression be evaluated in any order?
7116 // Will be set to false if any of the expression parts prevent this.
7117 bool unordered = true;
7118 // ProcedureRef currently being lowered. Used to retrieve the iteration shape
7119 // in elemental context with passed object.
7120 const Fortran::evaluate::ProcedureRef *loweredProcRef = nullptr;
7121};
7122} // namespace
7123
7124fir::ExtendedValue Fortran::lower::createSomeExtendedExpression(
7125 mlir::Location loc, Fortran::lower::AbstractConverter &converter,
7126 const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
7127 Fortran::lower::StatementContext &stmtCtx) {
7128 LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "expr: ") << '\n')do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { expr.AsFortran(llvm::dbgs() << "expr: "
) << '\n'; } } while (false)
;
7129 return ScalarExprLowering{loc, converter, symMap, stmtCtx}.genval(expr);
7130}
7131
7132fir::ExtendedValue Fortran::lower::createSomeInitializerExpression(
7133 mlir::Location loc, Fortran::lower::AbstractConverter &converter,
7134 const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
7135 Fortran::lower::StatementContext &stmtCtx) {
7136 LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "expr: ") << '\n')do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { expr.AsFortran(llvm::dbgs() << "expr: "
) << '\n'; } } while (false)
;
7137 return ScalarExprLowering{loc, converter, symMap, stmtCtx,
7138 /*inInitializer=*/true}
7139 .genval(expr);
7140}
7141
7142fir::ExtendedValue Fortran::lower::createSomeExtendedAddress(
7143 mlir::Location loc, Fortran::lower::AbstractConverter &converter,
7144 const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
7145 Fortran::lower::StatementContext &stmtCtx) {
7146 LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "address: ") << '\n')do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { expr.AsFortran(llvm::dbgs() << "address: "
) << '\n'; } } while (false)
;
7147 return ScalarExprLowering(loc, converter, symMap, stmtCtx).gen(expr);
7148}
7149
7150fir::ExtendedValue Fortran::lower::createInitializerAddress(
7151 mlir::Location loc, Fortran::lower::AbstractConverter &converter,
7152 const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
7153 Fortran::lower::StatementContext &stmtCtx) {
7154 LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "address: ") << '\n')do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { expr.AsFortran(llvm::dbgs() << "address: "
) << '\n'; } } while (false)
;
7155 return ScalarExprLowering(loc, converter, symMap, stmtCtx,
7156 /*inInitializer=*/true)
7157 .gen(expr);
7158}
7159
7160void Fortran::lower::createSomeArrayAssignment(
7161 Fortran::lower::AbstractConverter &converter,
7162 const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
7163 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
7164 LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "onto array: ") << '\n';do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { lhs.AsFortran(llvm::dbgs() << "onto array: "
) << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: "
) << '\n';; } } while (false)
7165 rhs.AsFortran(llvm::dbgs() << "assign expression: ") << '\n';)do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { lhs.AsFortran(llvm::dbgs() << "onto array: "
) << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: "
) << '\n';; } } while (false)
;
7166 ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs);
7167}
7168
7169void Fortran::lower::createSomeArrayAssignment(
7170 Fortran::lower::AbstractConverter &converter, const fir::ExtendedValue &lhs,
7171 const Fortran::lower::SomeExpr &rhs, Fortran::lower::SymMap &symMap,
7172 Fortran::lower::StatementContext &stmtCtx) {
7173 LLVM_DEBUG(llvm::dbgs() << "onto array: " << lhs << '\n';do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { llvm::dbgs() << "onto array: " <<
lhs << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: "
) << '\n';; } } while (false)
7174 rhs.AsFortran(llvm::dbgs() << "assign expression: ") << '\n';)do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { llvm::dbgs() << "onto array: " <<
lhs << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: "
) << '\n';; } } while (false)
;
7175 ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs);
7176}
7177void Fortran::lower::createSomeArrayAssignment(
7178 Fortran::lower::AbstractConverter &converter, const fir::ExtendedValue &lhs,
7179 const fir::ExtendedValue &rhs, Fortran::lower::SymMap &symMap,
7180 Fortran::lower::StatementContext &stmtCtx) {
7181 LLVM_DEBUG(llvm::dbgs() << "onto array: " << lhs << '\n';do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { llvm::dbgs() << "onto array: " <<
lhs << '\n'; llvm::dbgs() << "assign expression: "
<< rhs << '\n';; } } while (false)
7182 llvm::dbgs() << "assign expression: " << rhs << '\n';)do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { llvm::dbgs() << "onto array: " <<
lhs << '\n'; llvm::dbgs() << "assign expression: "
<< rhs << '\n';; } } while (false)
;
7183 ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs);
7184}
7185
7186void Fortran::lower::createAnyMaskedArrayAssignment(
7187 Fortran::lower::AbstractConverter &converter,
7188 const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
7189 Fortran::lower::ExplicitIterSpace &explicitSpace,
7190 Fortran::lower::ImplicitIterSpace &implicitSpace,
7191 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
7192 LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "onto array: ") << '\n';do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { lhs.AsFortran(llvm::dbgs() << "onto array: "
) << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: "
) << " given the explicit iteration space:\n" << explicitSpace
<< "\n and implied mask conditions:\n" << implicitSpace
<< '\n';; } } while (false)
7193 rhs.AsFortran(llvm::dbgs() << "assign expression: ")do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { lhs.AsFortran(llvm::dbgs() << "onto array: "
) << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: "
) << " given the explicit iteration space:\n" << explicitSpace
<< "\n and implied mask conditions:\n" << implicitSpace
<< '\n';; } } while (false)
7194 << " given the explicit iteration space:\n"do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { lhs.AsFortran(llvm::dbgs() << "onto array: "
) << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: "
) << " given the explicit iteration space:\n" << explicitSpace
<< "\n and implied mask conditions:\n" << implicitSpace
<< '\n';; } } while (false)
7195 << explicitSpace << "\n and implied mask conditions:\n"do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { lhs.AsFortran(llvm::dbgs() << "onto array: "
) << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: "
) << " given the explicit iteration space:\n" << explicitSpace
<< "\n and implied mask conditions:\n" << implicitSpace
<< '\n';; } } while (false)
7196 << implicitSpace << '\n';)do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { lhs.AsFortran(llvm::dbgs() << "onto array: "
) << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: "
) << " given the explicit iteration space:\n" << explicitSpace
<< "\n and implied mask conditions:\n" << implicitSpace
<< '\n';; } } while (false)
;
7197 ArrayExprLowering::lowerAnyMaskedArrayAssignment(
7198 converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace);
7199}
7200
7201void Fortran::lower::createAllocatableArrayAssignment(
7202 Fortran::lower::AbstractConverter &converter,
7203 const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
7204 Fortran::lower::ExplicitIterSpace &explicitSpace,
7205 Fortran::lower::ImplicitIterSpace &implicitSpace,
7206 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
7207 LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "defining array: ") << '\n';do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { lhs.AsFortran(llvm::dbgs() << "defining array: "
) << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: "
) << " given the explicit iteration space:\n" << explicitSpace
<< "\n and implied mask conditions:\n" << implicitSpace
<< '\n';; } } while (false)
7208 rhs.AsFortran(llvm::dbgs() << "assign expression: ")do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { lhs.AsFortran(llvm::dbgs() << "defining array: "
) << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: "
) << " given the explicit iteration space:\n" << explicitSpace
<< "\n and implied mask conditions:\n" << implicitSpace
<< '\n';; } } while (false)
7209 << " given the explicit iteration space:\n"do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { lhs.AsFortran(llvm::dbgs() << "defining array: "
) << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: "
) << " given the explicit iteration space:\n" << explicitSpace
<< "\n and implied mask conditions:\n" << implicitSpace
<< '\n';; } } while (false)
7210 << explicitSpace << "\n and implied mask conditions:\n"do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { lhs.AsFortran(llvm::dbgs() << "defining array: "
) << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: "
) << " given the explicit iteration space:\n" << explicitSpace
<< "\n and implied mask conditions:\n" << implicitSpace
<< '\n';; } } while (false)
7211 << implicitSpace << '\n';)do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { lhs.AsFortran(llvm::dbgs() << "defining array: "
) << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: "
) << " given the explicit iteration space:\n" << explicitSpace
<< "\n and implied mask conditions:\n" << implicitSpace
<< '\n';; } } while (false)
;
7212 ArrayExprLowering::lowerAllocatableArrayAssignment(
7213 converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace);
7214}
7215
7216void Fortran::lower::createArrayOfPointerAssignment(
7217 Fortran::lower::AbstractConverter &converter,
7218 const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
7219 Fortran::lower::ExplicitIterSpace &explicitSpace,
7220 Fortran::lower::ImplicitIterSpace &implicitSpace,
7221 const llvm::SmallVector<mlir::Value> &lbounds,
7222 std::optional<llvm::SmallVector<mlir::Value>> ubounds,
7223 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
7224 LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "defining pointer: ") << '\n';do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { lhs.AsFortran(llvm::dbgs() << "defining pointer: "
) << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: "
) << " given the explicit iteration space:\n" << explicitSpace
<< "\n and implied mask conditions:\n" << implicitSpace
<< '\n';; } } while (false)
7225 rhs.AsFortran(llvm::dbgs() << "assign expression: ")do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { lhs.AsFortran(llvm::dbgs() << "defining pointer: "
) << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: "
) << " given the explicit iteration space:\n" << explicitSpace
<< "\n and implied mask conditions:\n" << implicitSpace
<< '\n';; } } while (false)
7226 << " given the explicit iteration space:\n"do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { lhs.AsFortran(llvm::dbgs() << "defining pointer: "
) << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: "
) << " given the explicit iteration space:\n" << explicitSpace
<< "\n and implied mask conditions:\n" << implicitSpace
<< '\n';; } } while (false)
7227 << explicitSpace << "\n and implied mask conditions:\n"do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { lhs.AsFortran(llvm::dbgs() << "defining pointer: "
) << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: "
) << " given the explicit iteration space:\n" << explicitSpace
<< "\n and implied mask conditions:\n" << implicitSpace
<< '\n';; } } while (false)
7228 << implicitSpace << '\n';)do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { lhs.AsFortran(llvm::dbgs() << "defining pointer: "
) << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: "
) << " given the explicit iteration space:\n" << explicitSpace
<< "\n and implied mask conditions:\n" << implicitSpace
<< '\n';; } } while (false)
;
7229 assert(explicitSpace.isActive() && "must be in FORALL construct")(static_cast <bool> (explicitSpace.isActive() &&
"must be in FORALL construct") ? void (0) : __assert_fail ("explicitSpace.isActive() && \"must be in FORALL construct\""
, "flang/lib/Lower/ConvertExpr.cpp", 7229, __extension__ __PRETTY_FUNCTION__
))
;
7230 ArrayExprLowering::lowerArrayOfPointerAssignment(
7231 converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace,
7232 lbounds, ubounds);
7233}
7234
7235fir::ExtendedValue Fortran::lower::createSomeArrayTempValue(
7236 Fortran::lower::AbstractConverter &converter,
7237 const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
7238 Fortran::lower::StatementContext &stmtCtx) {
7239 LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "array value: ") << '\n')do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { expr.AsFortran(llvm::dbgs() << "array value: "
) << '\n'; } } while (false)
;
7240 return ArrayExprLowering::lowerNewArrayExpression(converter, symMap, stmtCtx,
7241 expr);
7242}
7243
7244void Fortran::lower::createLazyArrayTempValue(
7245 Fortran::lower::AbstractConverter &converter,
7246 const Fortran::lower::SomeExpr &expr, mlir::Value raggedHeader,
7247 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
7248 LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "array value: ") << '\n')do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { expr.AsFortran(llvm::dbgs() << "array value: "
) << '\n'; } } while (false)
;
7249 ArrayExprLowering::lowerLazyArrayExpression(converter, symMap, stmtCtx, expr,
7250 raggedHeader);
7251}
7252
7253fir::ExtendedValue
7254Fortran::lower::createSomeArrayBox(Fortran::lower::AbstractConverter &converter,
7255 const Fortran::lower::SomeExpr &expr,
7256 Fortran::lower::SymMap &symMap,
7257 Fortran::lower::StatementContext &stmtCtx) {
7258 LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "box designator: ") << '\n')do { if (::llvm::DebugFlag && ::llvm::isCurrentDebugType
("flang-lower-expr")) { expr.AsFortran(llvm::dbgs() << "box designator: "
) << '\n'; } } while (false)
;
7259 return ArrayExprLowering::lowerBoxedArrayExpression(converter, symMap,
7260 stmtCtx, expr);
7261}
7262
7263fir::MutableBoxValue Fortran::lower::createMutableBox(
7264 mlir::Location loc, Fortran::lower::AbstractConverter &converter,
7265 const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap) {
7266 // MutableBox lowering StatementContext does not need to be propagated
7267 // to the caller because the result value is a variable, not a temporary
7268 // expression. The StatementContext clean-up can occur before using the
7269 // resulting MutableBoxValue. Variables of all other types are handled in the
7270 // bridge.
7271 Fortran::lower::StatementContext dummyStmtCtx;
7272 return ScalarExprLowering{loc, converter, symMap, dummyStmtCtx}
7273 .genMutableBoxValue(expr);
7274}
7275
7276bool Fortran::lower::isParentComponent(const Fortran::lower::SomeExpr &expr) {
7277 if (const Fortran::semantics::Symbol * symbol{GetLastSymbol(expr)}) {
7278 if (symbol->test(Fortran::semantics::Symbol::Flag::ParentComp))
7279 return true;
7280 }
7281 return false;
7282}
7283
7284// Handling special case where the last component is referring to the
7285// parent component.
7286//
7287// TYPE t
7288// integer :: a
7289// END TYPE
7290// TYPE, EXTENDS(t) :: t2
7291// integer :: b
7292// END TYPE
7293// TYPE(t2) :: y(2)
7294// TYPE(t2) :: a
7295// y(:)%t ! just need to update the box with a slice pointing to the first
7296// ! component of `t`.
7297// a%t ! simple conversion to TYPE(t).
7298fir::ExtendedValue Fortran::lower::updateBoxForParentComponent(
7299 Fortran::lower::AbstractConverter &converter, fir::ExtendedValue box,
7300 const Fortran::lower::SomeExpr &expr) {
7301 mlir::Location loc = converter.getCurrentLocation();
7302 auto &builder = converter.getFirOpBuilder();
7303 mlir::Value boxBase = fir::getBase(box);
7304 mlir::Operation *op = boxBase.getDefiningOp();
7305 mlir::Type actualTy = converter.genType(expr);
7306
7307 if (op) {
7308 if (auto embox = mlir::dyn_cast<fir::EmboxOp>(op)) {
7309 auto newBox = builder.create<fir::EmboxOp>(
7310 loc, fir::BoxType::get(actualTy), embox.getMemref(), embox.getShape(),
7311 embox.getSlice(), embox.getTypeparams());
7312 return fir::substBase(box, newBox);
7313 }
7314 if (auto rebox = mlir::dyn_cast<fir::ReboxOp>(op)) {
7315 auto newBox = builder.create<fir::ReboxOp>(
7316 loc, fir::BoxType::get(actualTy), rebox.getBox(), rebox.getShape(),
7317 rebox.getSlice());
7318 return fir::substBase(box, newBox);
7319 }
7320 }
7321
7322 mlir::Value empty;
7323 mlir::ValueRange emptyRange;
7324 return builder.create<fir::ReboxOp>(loc, fir::BoxType::get(actualTy), boxBase,
7325 /*shape=*/empty,
7326 /*slice=*/empty);
7327}
7328
7329fir::ExtendedValue Fortran::lower::createBoxValue(
7330 mlir::Location loc, Fortran::lower::AbstractConverter &converter,
7331 const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
7332 Fortran::lower::StatementContext &stmtCtx) {
7333 if (expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) &&
7334 !Fortran::evaluate::HasVectorSubscript(expr)) {
7335 fir::ExtendedValue result =
7336 Fortran::lower::createSomeArrayBox(converter, expr, symMap, stmtCtx);
7337 if (isParentComponent(expr))
7338 result = updateBoxForParentComponent(converter, result, expr);
7339 return result;
7340 }
7341 fir::ExtendedValue addr = Fortran::lower::createSomeExtendedAddress(
7342 loc, converter, expr, symMap, stmtCtx);
7343 fir::ExtendedValue result = fir::BoxValue(
7344 converter.getFirOpBuilder().createBox(loc, addr, addr.isPolymorphic()));
7345 if (isParentComponent(expr))
7346 result = updateBoxForParentComponent(converter, result, expr);
7347 return result;
7348}
7349
7350mlir::Value Fortran::lower::createSubroutineCall(
7351 AbstractConverter &converter, const evaluate::ProcedureRef &call,
7352 ExplicitIterSpace &explicitIterSpace, ImplicitIterSpace &implicitIterSpace,
7353 SymMap &symMap, StatementContext &stmtCtx, bool isUserDefAssignment) {
7354 mlir::Location loc = converter.getCurrentLocation();
7355
7356 if (isUserDefAssignment) {
7357 assert(call.arguments().size() == 2)(static_cast <bool> (call.arguments().size() == 2) ? void
(0) : __assert_fail ("call.arguments().size() == 2", "flang/lib/Lower/ConvertExpr.cpp"
, 7357, __extension__ __PRETTY_FUNCTION__))
;
7358 const auto *lhs = call.arguments()[0].value().UnwrapExpr();
7359 const auto *rhs = call.arguments()[1].value().UnwrapExpr();
7360 assert(lhs && rhs &&(static_cast <bool> (lhs && rhs && "user defined assignment arguments must be expressions"
) ? void (0) : __assert_fail ("lhs && rhs && \"user defined assignment arguments must be expressions\""
, "flang/lib/Lower/ConvertExpr.cpp", 7361, __extension__ __PRETTY_FUNCTION__
))
7361 "user defined assignment arguments must be expressions")(static_cast <bool> (lhs && rhs && "user defined assignment arguments must be expressions"
) ? void (0) : __assert_fail ("lhs && rhs && \"user defined assignment arguments must be expressions\""
, "flang/lib/Lower/ConvertExpr.cpp", 7361, __extension__ __PRETTY_FUNCTION__
))
;
7362 if (call.IsElemental() && lhs->Rank() > 0) {
7363 // Elemental user defined assignment has special requirements to deal with
7364 // LHS/RHS overlaps. See 10.2.1.5 p2.
7365 ArrayExprLowering::lowerElementalUserAssignment(
7366 converter, symMap, stmtCtx, explicitIterSpace, implicitIterSpace,
7367 call);
7368 } else if (explicitIterSpace.isActive() && lhs->Rank() == 0) {
7369 // Scalar defined assignment (elemental or not) in a FORALL context.
7370 mlir::func::FuncOp func =
7371 Fortran::lower::CallerInterface(call, converter).getFuncOp();
7372 ArrayExprLowering::lowerScalarUserAssignment(
7373 converter, symMap, stmtCtx, explicitIterSpace, func, *lhs, *rhs);
7374 } else if (explicitIterSpace.isActive()) {
7375 // TODO: need to array fetch/modify sub-arrays?
7376 TODO(loc, "non elemental user defined array assignment inside FORALL")do { fir::emitFatalError(loc, llvm::Twine("flang/lib/Lower/ConvertExpr.cpp"
":" "7376" ": not yet implemented: ") + llvm::Twine("non elemental user defined array assignment inside FORALL"
), false); } while (false)
;
7377 } else {
7378 if (!implicitIterSpace.empty())
7379 fir::emitFatalError(
7380 loc,
7381 "C1032: user defined assignment inside WHERE must be elemental");
7382 // Non elemental user defined assignment outside of FORALL and WHERE.
7383 // FIXME: The non elemental user defined assignment case with array
7384 // arguments must be take into account potential overlap. So far the front
7385 // end does not add parentheses around the RHS argument in the call as it
7386 // should according to 15.4.3.4.3 p2.
7387 Fortran::lower::createSomeExtendedExpression(
7388 loc, converter, toEvExpr(call), symMap, stmtCtx);
7389 }
7390 return {};
7391 }
7392
7393 assert(implicitIterSpace.empty() && !explicitIterSpace.isActive() &&(static_cast <bool> (implicitIterSpace.empty() &&
!explicitIterSpace.isActive() && "subroutine calls are not allowed inside WHERE and FORALL"
) ? void (0) : __assert_fail ("implicitIterSpace.empty() && !explicitIterSpace.isActive() && \"subroutine calls are not allowed inside WHERE and FORALL\""
, "flang/lib/Lower/ConvertExpr.cpp", 7394, __extension__ __PRETTY_FUNCTION__
))
7394 "subroutine calls are not allowed inside WHERE and FORALL")(static_cast <bool> (implicitIterSpace.empty() &&
!explicitIterSpace.isActive() && "subroutine calls are not allowed inside WHERE and FORALL"
) ? void (0) : __assert_fail ("implicitIterSpace.empty() && !explicitIterSpace.isActive() && \"subroutine calls are not allowed inside WHERE and FORALL\""
, "flang/lib/Lower/ConvertExpr.cpp", 7394, __extension__ __PRETTY_FUNCTION__
))
;
7395
7396 if (isElementalProcWithArrayArgs(call)) {
7397 ArrayExprLowering::lowerElementalSubroutine(converter, symMap, stmtCtx,
7398 toEvExpr(call));
7399 return {};
7400 }
7401 // Simple subroutine call, with potential alternate return.
7402 auto res = Fortran::lower::createSomeExtendedExpression(
7403 loc, converter, toEvExpr(call), symMap, stmtCtx);
7404 return fir::getBase(res);
7405}
7406
7407template <typename A>
7408fir::ArrayLoadOp genArrayLoad(mlir::Location loc,
7409 Fortran::lower::AbstractConverter &converter,
7410 fir::FirOpBuilder &builder, const A *x,
7411 Fortran::lower::SymMap &symMap,
7412 Fortran::lower::StatementContext &stmtCtx) {
7413 auto exv = ScalarExprLowering{loc, converter, symMap, stmtCtx}.gen(*x);
7414 mlir::Value addr = fir::getBase(exv);
7415 mlir::Value shapeOp = builder.createShape(loc, exv);
7416 mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(addr.getType());
7417 return builder.create<fir::ArrayLoadOp>(loc, arrTy, addr, shapeOp,
7418 /*slice=*/mlir::Value{},
7419 fir::getTypeParams(exv));
7420}
7421template <>
7422fir::ArrayLoadOp
7423genArrayLoad(mlir::Location loc, Fortran::lower::AbstractConverter &converter,
7424 fir::FirOpBuilder &builder, const Fortran::evaluate::ArrayRef *x,
7425 Fortran::lower::SymMap &symMap,
7426 Fortran::lower::StatementContext &stmtCtx) {
7427 if (x->base().IsSymbol())
7428 return genArrayLoad(loc, converter, builder, &getLastSym(x->base()), symMap,
7429 stmtCtx);
7430 return genArrayLoad(loc, converter, builder, &x->base().GetComponent(),
7431 symMap, stmtCtx);
7432}
7433
7434void Fortran::lower::createArrayLoads(
7435 Fortran::lower::AbstractConverter &converter,
7436 Fortran::lower::ExplicitIterSpace &esp, Fortran::lower::SymMap &symMap) {
7437 std::size_t counter = esp.getCounter();
7438 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
7439 mlir::Location loc = converter.getCurrentLocation();
7440 Fortran::lower::StatementContext &stmtCtx = esp.stmtContext();
7441 // Gen the fir.array_load ops.
7442 auto genLoad = [&](const auto *x) -> fir::ArrayLoadOp {
7443 return genArrayLoad(loc, converter, builder, x, symMap, stmtCtx);
7444 };
7445 if (esp.lhsBases[counter]) {
7446 auto &base = *esp.lhsBases[counter];
7447 auto load = std::visit(genLoad, base);
7448 esp.initialArgs.push_back(load);
7449 esp.resetInnerArgs();
7450 esp.bindLoad(base, load);
7451 }
7452 for (const auto &base : esp.rhsBases[counter])
7453 esp.bindLoad(base, std::visit(genLoad, base));
7454}
7455
7456void Fortran::lower::createArrayMergeStores(
7457 Fortran::lower::AbstractConverter &converter,
7458 Fortran::lower::ExplicitIterSpace &esp) {
7459 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
7460 mlir::Location loc = converter.getCurrentLocation();
7461 builder.setInsertionPointAfter(esp.getOuterLoop());
7462 // Gen the fir.array_merge_store ops for all LHS arrays.
7463 for (auto i : llvm::enumerate(esp.getOuterLoop().getResults()))
7464 if (std::optional<fir::ArrayLoadOp> ldOpt = esp.getLhsLoad(i.index())) {
7465 fir::ArrayLoadOp load = *ldOpt;
7466 builder.create<fir::ArrayMergeStoreOp>(loc, load, i.value(),
7467 load.getMemref(), load.getSlice(),
7468 load.getTypeparams());
7469 }
7470 if (esp.loopCleanup) {
7471 (*esp.loopCleanup)(builder);
7472 esp.loopCleanup = std::nullopt;
7473 }
7474 esp.initialArgs.clear();
7475 esp.innerArgs.clear();
7476 esp.outerLoop = std::nullopt;
7477 esp.resetBindings();
7478 esp.incrementCounter();
7479}

/usr/lib/gcc/x86_64-linux-gnu/10/../../../../include/c++/10/bits/std_function.h

1// Implementation of std::function -*- C++ -*-
2
3// Copyright (C) 2004-2020 Free Software Foundation, Inc.
4//
5// This file is part of the GNU ISO C++ Library. This library is free
6// software; you can redistribute it and/or modify it under the
7// terms of the GNU General Public License as published by the
8// Free Software Foundation; either version 3, or (at your option)
9// any later version.
10
11// This library is distributed in the hope that it will be useful,
12// but WITHOUT ANY WARRANTY; without even the implied warranty of
13// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14// GNU General Public License for more details.
15
16// Under Section 7 of GPL version 3, you are granted additional
17// permissions described in the GCC Runtime Library Exception, version
18// 3.1, as published by the Free Software Foundation.
19
20// You should have received a copy of the GNU General Public License and
21// a copy of the GCC Runtime Library Exception along with this program;
22// see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
23// <http://www.gnu.org/licenses/>.
24
25/** @file include/bits/std_function.h
26 * This is an internal header file, included by other library headers.
27 * Do not attempt to use it directly. @headername{functional}
28 */
29
30#ifndef _GLIBCXX_STD_FUNCTION_H1
31#define _GLIBCXX_STD_FUNCTION_H1 1
32
33#pragma GCC system_header
34
35#if __cplusplus201703L < 201103L
36# include <bits/c++0x_warning.h>
37#else
38
39#if __cpp_rtti199711L
40# include <typeinfo>
41#endif
42#include <bits/stl_function.h>
43#include <bits/invoke.h>
44#include <bits/refwrap.h>
45#include <bits/functexcept.h>
46
47namespace std _GLIBCXX_VISIBILITY(default)__attribute__ ((__visibility__ ("default")))
48{
49_GLIBCXX_BEGIN_NAMESPACE_VERSION
50
51 /**
52 * @brief Exception class thrown when class template function's
53 * operator() is called with an empty target.
54 * @ingroup exceptions
55 */
56 class bad_function_call : public std::exception
57 {
58 public:
59 virtual ~bad_function_call() noexcept;
60
61 const char* what() const noexcept;
62 };
63
64 /**
65 * Trait identifying "location-invariant" types, meaning that the
66 * address of the object (or any of its members) will not escape.
67 * Trivially copyable types are location-invariant and users can
68 * specialize this trait for other types.
69 */
70 template<typename _Tp>
71 struct __is_location_invariant
72 : is_trivially_copyable<_Tp>::type
73 { };
74
75 class _Undefined_class;
76
77 union _Nocopy_types
78 {
79 void* _M_object;
80 const void* _M_const_object;
81 void (*_M_function_pointer)();
82 void (_Undefined_class::*_M_member_pointer)();
83 };
84
85 union [[gnu::may_alias]] _Any_data
86 {
87 void* _M_access() { return &_M_pod_data[0]; }
88 const void* _M_access() const { return &_M_pod_data[0]; }
89
90 template<typename _Tp>
91 _Tp&
92 _M_access()
93 { return *static_cast<_Tp*>(_M_access()); }
94
95 template<typename _Tp>
96 const _Tp&
97 _M_access() const
98 { return *static_cast<const _Tp*>(_M_access()); }
99
100 _Nocopy_types _M_unused;
101 char _M_pod_data[sizeof(_Nocopy_types)];
102 };
103
104 enum _Manager_operation
105 {
106 __get_type_info,
107 __get_functor_ptr,
108 __clone_functor,
109 __destroy_functor
110 };
111
112 template<typename _Signature>
113 class function;
114
115 /// Base class of all polymorphic function object wrappers.
116 class _Function_base
117 {
118 public:
119 static const size_t _M_max_size = sizeof(_Nocopy_types);
120 static const size_t _M_max_align = __alignof__(_Nocopy_types);
121
122 template<typename _Functor>
123 class _Base_manager
124 {
125 protected:
126 static const bool __stored_locally =
127 (__is_location_invariant<_Functor>::value
128 && sizeof(_Functor) <= _M_max_size
129 && __alignof__(_Functor) <= _M_max_align
130 && (_M_max_align % __alignof__(_Functor) == 0));
131
132 typedef integral_constant<bool, __stored_locally> _Local_storage;
133
134 // Retrieve a pointer to the function object
135 static _Functor*
136 _M_get_pointer(const _Any_data& __source)
137 {
138 if _GLIBCXX17_CONSTEXPRconstexpr (__stored_locally)
139 {
140 const _Functor& __f = __source._M_access<_Functor>();
141 return const_cast<_Functor*>(std::__addressof(__f));
142 }
143 else // have stored a pointer
144 return __source._M_access<_Functor*>();
145 }
146
147 // Clone a location-invariant function object that fits within
148 // an _Any_data structure.
149 static void
150 _M_clone(_Any_data& __dest, const _Any_data& __source, true_type)
151 {
152 ::new (__dest._M_access()) _Functor(__source._M_access<_Functor>());
153 }
154
155 // Clone a function object that is not location-invariant or
156 // that cannot fit into an _Any_data structure.
157 static void
158 _M_clone(_Any_data& __dest, const _Any_data& __source, false_type)
159 {
160 __dest._M_access<_Functor*>() =
161 new _Functor(*__source._M_access<const _Functor*>());
162 }
163
164 // Destroying a location-invariant object may still require
165 // destruction.
166 static void
167 _M_destroy(_Any_data& __victim, true_type)
168 {
169 __victim._M_access<_Functor>().~_Functor();
170 }
171
172 // Destroying an object located on the heap.
173 static void
174 _M_destroy(_Any_data& __victim, false_type)
175 {
176 delete __victim._M_access<_Functor*>();
177 }
178
179 public:
180 static bool
181 _M_manager(_Any_data& __dest, const _Any_data& __source,
182 _Manager_operation __op)
183 {
184 switch (__op)
185 {
186#if __cpp_rtti199711L
187 case __get_type_info:
188 __dest._M_access<const type_info*>() = &typeid(_Functor);
189 break;
190#endif
191 case __get_functor_ptr:
192 __dest._M_access<_Functor*>() = _M_get_pointer(__source);
193 break;
194
195 case __clone_functor:
196 _M_clone(__dest, __source, _Local_storage());
197 break;
198
199 case __destroy_functor:
200 _M_destroy(__dest, _Local_storage());
201 break;
202 }
203 return false;
204 }
205
206 static void
207 _M_init_functor(_Any_data& __functor, _Functor&& __f)
208 { _M_init_functor(__functor, std::move(__f), _Local_storage()); }
15
Calling '_Base_manager::_M_init_functor'
17
Returned allocated memory
209
210 template<typename _Signature>
211 static bool
212 _M_not_empty_function(const function<_Signature>& __f)
213 { return static_cast<bool>(__f); }
214
215 template<typename _Tp>
216 static bool
217 _M_not_empty_function(_Tp* __fp)
218 { return __fp != nullptr; }
219
220 template<typename _Class, typename _Tp>
221 static bool
222 _M_not_empty_function(_Tp _Class::* __mp)
223 { return __mp != nullptr; }
224
225 template<typename _Tp>
226 static bool
227 _M_not_empty_function(const _Tp&)
228 { return true; }
229
230 private:
231 static void
232 _M_init_functor(_Any_data& __functor, _Functor&& __f, true_type)
233 { ::new (__functor._M_access()) _Functor(std::move(__f)); }
234
235 static void
236 _M_init_functor(_Any_data& __functor, _Functor&& __f, false_type)
237 { __functor._M_access<_Functor*>() = new _Functor(std::move(__f)); }
16
Memory is allocated
238 };
239
240 _Function_base() : _M_manager(nullptr) { }
241
242 ~_Function_base()
243 {
244 if (_M_manager)
245 _M_manager(_M_functor, _M_functor, __destroy_functor);
246 }
247
248 bool _M_empty() const { return !_M_manager; }
249
250 typedef bool (*_Manager_type)(_Any_data&, const _Any_data&,
251 _Manager_operation);
252
253 _Any_data _M_functor;
254 _Manager_type _M_manager;
255 };
256
257 template<typename _Signature, typename _Functor>
258 class _Function_handler;
259
260 template<typename _Res, typename _Functor, typename... _ArgTypes>
261 class _Function_handler<_Res(_ArgTypes...), _Functor>
262 : public _Function_base::_Base_manager<_Functor>
263 {
264 typedef _Function_base::_Base_manager<_Functor> _Base;
265
266 public:
267 static bool
268 _M_manager(_Any_data& __dest, const _Any_data& __source,
269 _Manager_operation __op)
270 {
271 switch (__op)
272 {
273#if __cpp_rtti199711L
274 case __get_type_info:
275 __dest._M_access<const type_info*>() = &typeid(_Functor);
276 break;
277#endif
278 case __get_functor_ptr:
279 __dest._M_access<_Functor*>() = _Base::_M_get_pointer(__source);
280 break;
281
282 default:
283 _Base::_M_manager(__dest, __source, __op);
284 }
285 return false;
286 }
287
288 static _Res
289 _M_invoke(const _Any_data& __functor, _ArgTypes&&... __args)
290 {
291 return std::__invoke_r<_Res>(*_Base::_M_get_pointer(__functor),
292 std::forward<_ArgTypes>(__args)...);
293 }
294 };
295
296 /**
297 * @brief Primary class template for std::function.
298 * @ingroup functors
299 *
300 * Polymorphic function wrapper.
301 */
302 template<typename _Res, typename... _ArgTypes>
303 class function<_Res(_ArgTypes...)>
304 : public _Maybe_unary_or_binary_function<_Res, _ArgTypes...>,
305 private _Function_base
306 {
307 template<typename _Func,
308 typename _Res2 = __invoke_result<_Func&, _ArgTypes...>>
309 struct _Callable
310 : __is_invocable_impl<_Res2, _Res>::type
311 { };
312
313 // Used so the return type convertibility checks aren't done when
314 // performing overload resolution for copy construction/assignment.
315 template<typename _Tp>
316 struct _Callable<function, _Tp> : false_type { };
317
318 template<typename _Cond, typename _Tp>
319 using _Requires = typename enable_if<_Cond::value, _Tp>::type;
320
321 public:
322 typedef _Res result_type;
323
324 // [3.7.2.1] construct/copy/destroy
325
326 /**
327 * @brief Default construct creates an empty function call wrapper.
328 * @post @c !(bool)*this
329 */
330 function() noexcept
331 : _Function_base() { }
332
333 /**
334 * @brief Creates an empty function call wrapper.
335 * @post @c !(bool)*this
336 */
337 function(nullptr_t) noexcept
338 : _Function_base() { }
339
340 /**
341 * @brief %Function copy constructor.
342 * @param __x A %function object with identical call signature.
343 * @post @c bool(*this) == bool(__x)
344 *
345 * The newly-created %function contains a copy of the target of @a
346 * __x (if it has one).
347 */
348 function(const function& __x);
349
350 /**
351 * @brief %Function move constructor.
352 * @param __x A %function object rvalue with identical call signature.
353 *
354 * The newly-created %function contains the target of @a __x
355 * (if it has one).
356 */
357 function(function&& __x) noexcept : _Function_base()
358 {
359 __x.swap(*this);
360 }
361
362 /**
363 * @brief Builds a %function that targets a copy of the incoming
364 * function object.
365 * @param __f A %function object that is callable with parameters of
366 * type @c T1, @c T2, ..., @c TN and returns a value convertible
367 * to @c Res.
368 *
369 * The newly-created %function object will target a copy of
370 * @a __f. If @a __f is @c reference_wrapper<F>, then this function
371 * object will contain a reference to the function object @c
372 * __f.get(). If @a __f is a NULL function pointer or NULL
373 * pointer-to-member, the newly-created object will be empty.
374 *
375 * If @a __f is a non-NULL function pointer or an object of type @c
376 * reference_wrapper<F>, this function will not throw.
377 */
378 template<typename _Functor,
379 typename = _Requires<__not_<is_same<_Functor, function>>, void>,
380 typename = _Requires<_Callable<_Functor>, void>>
381 function(_Functor);
382
383 /**
384 * @brief %Function assignment operator.
385 * @param __x A %function with identical call signature.
386 * @post @c (bool)*this == (bool)x
387 * @returns @c *this
388 *
389 * The target of @a __x is copied to @c *this. If @a __x has no
390 * target, then @c *this will be empty.
391 *
392 * If @a __x targets a function pointer or a reference to a function
393 * object, then this operation will not throw an %exception.
394 */
395 function&
396 operator=(const function& __x)
397 {
398 function(__x).swap(*this);
399 return *this;
400 }
401
402 /**
403 * @brief %Function move-assignment operator.
404 * @param __x A %function rvalue with identical call signature.
405 * @returns @c *this
406 *
407 * The target of @a __x is moved to @c *this. If @a __x has no
408 * target, then @c *this will be empty.
409 *
410 * If @a __x targets a function pointer or a reference to a function
411 * object, then this operation will not throw an %exception.
412 */
413 function&
414 operator=(function&& __x) noexcept
415 {
416 function(std::move(__x)).swap(*this);
417 return *this;
418 }
419
420 /**
421 * @brief %Function assignment to zero.
422 * @post @c !(bool)*this
423 * @returns @c *this
424 *
425 * The target of @c *this is deallocated, leaving it empty.
426 */
427 function&
428 operator=(nullptr_t) noexcept
429 {
430 if (_M_manager)
431 {
432 _M_manager(_M_functor, _M_functor, __destroy_functor);
433 _M_manager = nullptr;
434 _M_invoker = nullptr;
435 }
436 return *this;
437 }
438
439 /**
440 * @brief %Function assignment to a new target.
441 * @param __f A %function object that is callable with parameters of
442 * type @c T1, @c T2, ..., @c TN and returns a value convertible
443 * to @c Res.
444 * @return @c *this
445 *
446 * This %function object wrapper will target a copy of @a
447 * __f. If @a __f is @c reference_wrapper<F>, then this function
448 * object will contain a reference to the function object @c
449 * __f.get(). If @a __f is a NULL function pointer or NULL
450 * pointer-to-member, @c this object will be empty.
451 *
452 * If @a __f is a non-NULL function pointer or an object of type @c
453 * reference_wrapper<F>, this function will not throw.
454 */
455 template<typename _Functor>
456 _Requires<_Callable<typename decay<_Functor>::type>, function&>
457 operator=(_Functor&& __f)
458 {
459 function(std::forward<_Functor>(__f)).swap(*this);
460 return *this;
461 }
462
463 /// @overload
464 template<typename _Functor>
465 function&
466 operator=(reference_wrapper<_Functor> __f) noexcept
467 {
468 function(__f).swap(*this);
469 return *this;
470 }
471
472 // [3.7.2.2] function modifiers
473
474 /**
475 * @brief Swap the targets of two %function objects.
476 * @param __x A %function with identical call signature.
477 *
478 * Swap the targets of @c this function object and @a __f. This
479 * function will not throw an %exception.
480 */
481 void swap(function& __x) noexcept
482 {
483 std::swap(_M_functor, __x._M_functor);
484 std::swap(_M_manager, __x._M_manager);
485 std::swap(_M_invoker, __x._M_invoker);
486 }
487
488 // [3.7.2.3] function capacity
489
490 /**
491 * @brief Determine if the %function wrapper has a target.
492 *
493 * @return @c true when this %function object contains a target,
494 * or @c false when it is empty.
495 *
496 * This function will not throw an %exception.
497 */
498 explicit operator bool() const noexcept
499 { return !_M_empty(); }
500
501 // [3.7.2.4] function invocation
502
503 /**
504 * @brief Invokes the function targeted by @c *this.
505 * @returns the result of the target.
506 * @throws bad_function_call when @c !(bool)*this
507 *
508 * The function call operator invokes the target function object
509 * stored by @c this.
510 */
511 _Res operator()(_ArgTypes... __args) const;
512
513#if __cpp_rtti199711L
514 // [3.7.2.5] function target access
515 /**
516 * @brief Determine the type of the target of this function object
517 * wrapper.
518 *
519 * @returns the type identifier of the target function object, or
520 * @c typeid(void) if @c !(bool)*this.
521 *
522 * This function will not throw an %exception.
523 */
524 const type_info& target_type() const noexcept;
525
526 /**
527 * @brief Access the stored target function object.
528 *
529 * @return Returns a pointer to the stored target function object,
530 * if @c typeid(_Functor).equals(target_type()); otherwise, a NULL
531 * pointer.
532 *
533 * This function does not throw exceptions.
534 *
535 * @{
536 */
537 template<typename _Functor> _Functor* target() noexcept;
538
539 template<typename _Functor> const _Functor* target() const noexcept;
540 // @}
541#endif
542
543 private:
544 using _Invoker_type = _Res (*)(const _Any_data&, _ArgTypes&&...);
545 _Invoker_type _M_invoker;
546 };
547
548#if __cpp_deduction_guides201703L >= 201606
549 template<typename>
550 struct __function_guide_helper
551 { };
552
553 template<typename _Res, typename _Tp, bool _Nx, typename... _Args>
554 struct __function_guide_helper<
555 _Res (_Tp::*) (_Args...) noexcept(_Nx)
556 >
557 { using type = _Res(_Args...); };
558
559 template<typename _Res, typename _Tp, bool _Nx, typename... _Args>
560 struct __function_guide_helper<
561 _Res (_Tp::*) (_Args...) & noexcept(_Nx)
562 >
563 { using type = _Res(_Args...); };
564
565 template<typename _Res, typename _Tp, bool _Nx, typename... _Args>
566 struct __function_guide_helper<
567 _Res (_Tp::*) (_Args...) const noexcept(_Nx)
568 >
569 { using type = _Res(_Args...); };
570
571 template<typename _Res, typename _Tp, bool _Nx, typename... _Args>
572 struct __function_guide_helper<
573 _Res (_Tp::*) (_Args...) const & noexcept(_Nx)
574 >
575 { using type = _Res(_Args...); };
576
577 template<typename _Res, typename... _ArgTypes>
578 function(_Res(*)(_ArgTypes...)) -> function<_Res(_ArgTypes...)>;
579
580 template<typename _Functor, typename _Signature = typename
581 __function_guide_helper<decltype(&_Functor::operator())>::type>
582 function(_Functor) -> function<_Signature>;
583#endif
584
585 // Out-of-line member definitions.
586 template<typename _Res, typename... _ArgTypes>
587 function<_Res(_ArgTypes...)>::
588 function(const function& __x)
589 : _Function_base()
590 {
591 if (static_cast<bool>(__x))
592 {
593 __x._M_manager(_M_functor, __x._M_functor, __clone_functor);
594 _M_invoker = __x._M_invoker;
595 _M_manager = __x._M_manager;
596 }
597 }
598
599 template<typename _Res, typename... _ArgTypes>
600 template<typename _Functor, typename, typename>
601 function<_Res(_ArgTypes...)>::
602 function(_Functor __f)
603 : _Function_base()
604 {
605 typedef _Function_handler<_Res(_ArgTypes...), _Functor> _My_handler;
606
607 if (_My_handler::_M_not_empty_function(__f))
13
Taking true branch
608 {
609 _My_handler::_M_init_functor(_M_functor, std::move(__f));
14
Calling '_Base_manager::_M_init_functor'
18
Returned allocated memory
610 _M_invoker = &_My_handler::_M_invoke;
611 _M_manager = &_My_handler::_M_manager;
612 }
613 }
614
615 template<typename _Res, typename... _ArgTypes>
616 _Res
617 function<_Res(_ArgTypes...)>::
618 operator()(_ArgTypes... __args) const
619 {
620 if (_M_empty())
621 __throw_bad_function_call();
622 return _M_invoker(_M_functor, std::forward<_ArgTypes>(__args)...);
623 }
624
625#if __cpp_rtti199711L
626 template<typename _Res, typename... _ArgTypes>
627 const type_info&
628 function<_Res(_ArgTypes...)>::
629 target_type() const noexcept
630 {
631 if (_M_manager)
632 {
633 _Any_data __typeinfo_result;
634 _M_manager(__typeinfo_result, _M_functor, __get_type_info);
635 return *__typeinfo_result._M_access<const type_info*>();
636 }
637 else
638 return typeid(void);
639 }
640
641 template<typename _Res, typename... _ArgTypes>
642 template<typename _Functor>
643 _Functor*
644 function<_Res(_ArgTypes...)>::
645 target() noexcept
646 {
647 const function* __const_this = this;
648 const _Functor* __func = __const_this->template target<_Functor>();
649 return const_cast<_Functor*>(__func);
650 }
651
652 template<typename _Res, typename... _ArgTypes>
653 template<typename _Functor>
654 const _Functor*
655 function<_Res(_ArgTypes...)>::
656 target() const noexcept
657 {
658 if (typeid(_Functor) == target_type() && _M_manager)
659 {
660 _Any_data __ptr;
661 _M_manager(__ptr, _M_functor, __get_functor_ptr);
662 return __ptr._M_access<const _Functor*>();
663 }
664 else
665 return nullptr;
666 }
667#endif
668
669 // [20.7.15.2.6] null pointer comparisons
670
671 /**
672 * @brief Compares a polymorphic function object wrapper against 0
673 * (the NULL pointer).
674 * @returns @c true if the wrapper has no target, @c false otherwise
675 *
676 * This function will not throw an %exception.
677 */
678 template<typename _Res, typename... _Args>
679 inline bool
680 operator==(const function<_Res(_Args...)>& __f, nullptr_t) noexcept
681 { return !static_cast<bool>(__f); }
682
683#if __cpp_impl_three_way_comparison < 201907L
684 /// @overload
685 template<typename _Res, typename... _Args>
686 inline bool
687 operator==(nullptr_t, const function<_Res(_Args...)>& __f) noexcept
688 { return !static_cast<bool>(__f); }
689
690 /**
691 * @brief Compares a polymorphic function object wrapper against 0
692 * (the NULL pointer).
693 * @returns @c false if the wrapper has no target, @c true otherwise
694 *
695 * This function will not throw an %exception.
696 */
697 template<typename _Res, typename... _Args>
698 inline bool
699 operator!=(const function<_Res(_Args...)>& __f, nullptr_t) noexcept
700 { return static_cast<bool>(__f); }
701
702 /// @overload
703 template<typename _Res, typename... _Args>
704 inline bool
705 operator!=(nullptr_t, const function<_Res(_Args...)>& __f) noexcept
706 { return static_cast<bool>(__f); }
707#endif
708
709 // [20.7.15.2.7] specialized algorithms
710
711 /**
712 * @brief Swap the targets of two polymorphic function object wrappers.
713 *
714 * This function will not throw an %exception.
715 */
716 // _GLIBCXX_RESOLVE_LIB_DEFECTS
717 // 2062. Effect contradictions w/o no-throw guarantee of std::function swaps
718 template<typename _Res, typename... _Args>
719 inline void
720 swap(function<_Res(_Args...)>& __x, function<_Res(_Args...)>& __y) noexcept
721 { __x.swap(__y); }
722
723#if __cplusplus201703L >= 201703L
724 namespace __detail::__variant
725 {
726 template<typename> struct _Never_valueless_alt; // see <variant>
727
728 // Provide the strong exception-safety guarantee when emplacing a
729 // function into a variant.
730 template<typename _Signature>
731 struct _Never_valueless_alt<std::function<_Signature>>
732 : std::true_type
733 { };
734 } // namespace __detail::__variant
735#endif // C++17
736
737_GLIBCXX_END_NAMESPACE_VERSION
738} // namespace std
739
740#endif // C++11
741#endif // _GLIBCXX_STD_FUNCTION_H