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/unwrap.h"
15#include "flang/Evaluate/fold.h"
16#include "flang/Evaluate/real.h"
17#include "flang/Evaluate/traverse.h"
18#include "flang/Lower/Allocatable.h"
19#include "flang/Lower/Bridge.h"
20#include "flang/Lower/BuiltinModules.h"
21#include "flang/Lower/CallInterface.h"
22#include "flang/Lower/Coarray.h"
23#include "flang/Lower/ComponentPath.h"
24#include "flang/Lower/ConvertCall.h"
25#include "flang/Lower/ConvertConstant.h"
26#include "flang/Lower/ConvertProcedureDesignator.h"
27#include "flang/Lower/ConvertType.h"
28#include "flang/Lower/ConvertVariable.h"
29#include "flang/Lower/CustomIntrinsicCall.h"
30#include "flang/Lower/Mangler.h"
31#include "flang/Lower/Runtime.h"
32#include "flang/Lower/Support/Utils.h"
33#include "flang/Optimizer/Builder/Character.h"
34#include "flang/Optimizer/Builder/Complex.h"
35#include "flang/Optimizer/Builder/Factory.h"
36#include "flang/Optimizer/Builder/IntrinsicCall.h"
37#include "flang/Optimizer/Builder/Runtime/Assign.h"
38#include "flang/Optimizer/Builder/Runtime/Character.h"
39#include "flang/Optimizer/Builder/Runtime/Derived.h"
40#include "flang/Optimizer/Builder/Runtime/Inquiry.h"
41#include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
42#include "flang/Optimizer/Builder/Runtime/Ragged.h"
43#include "flang/Optimizer/Builder/Todo.h"
44#include "flang/Optimizer/Dialect/FIRAttr.h"
45#include "flang/Optimizer/Dialect/FIRDialect.h"
46#include "flang/Optimizer/Dialect/FIROpsSupport.h"
47#include "flang/Optimizer/Support/FatalError.h"
48#include "flang/Runtime/support.h"
49#include "flang/Semantics/dump-expr.h"
50#include "flang/Semantics/expression.h"
51#include "flang/Semantics/symbol.h"
52#include "flang/Semantics/tools.h"
53#include "flang/Semantics/type.h"
54#include "flang/Support/default-kinds.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"
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(Val: 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(Val: 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(Val: 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(Val: 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
197translateSignedRelational(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");
213}
214
215static mlir::arith::CmpIPredicate
216translateUnsignedRelational(Fortran::common::RelationalOperator rop) {
217 switch (rop) {
218 case Fortran::common::RelationalOperator::LT:
219 return mlir::arith::CmpIPredicate::ult;
220 case Fortran::common::RelationalOperator::LE:
221 return mlir::arith::CmpIPredicate::ule;
222 case Fortran::common::RelationalOperator::EQ:
223 return mlir::arith::CmpIPredicate::eq;
224 case Fortran::common::RelationalOperator::NE:
225 return mlir::arith::CmpIPredicate::ne;
226 case Fortran::common::RelationalOperator::GT:
227 return mlir::arith::CmpIPredicate::ugt;
228 case Fortran::common::RelationalOperator::GE:
229 return mlir::arith::CmpIPredicate::uge;
230 }
231 llvm_unreachable("unhandled UNSIGNED relational operator");
232}
233
234/// Convert parser's REAL relational operators to MLIR.
235/// The choice of order (O prefix) vs unorder (U prefix) follows Fortran 2018
236/// requirements in the IEEE context (table 17.1 of F2018). This choice is
237/// also applied in other contexts because it is easier and in line with
238/// other Fortran compilers.
239/// FIXME: The signaling/quiet aspect of the table 17.1 requirement is not
240/// fully enforced. FIR and LLVM `fcmp` instructions do not give any guarantee
241/// whether the comparison will signal or not in case of quiet NaN argument.
242static mlir::arith::CmpFPredicate
243translateFloatRelational(Fortran::common::RelationalOperator rop) {
244 switch (rop) {
245 case Fortran::common::RelationalOperator::LT:
246 return mlir::arith::CmpFPredicate::OLT;
247 case Fortran::common::RelationalOperator::LE:
248 return mlir::arith::CmpFPredicate::OLE;
249 case Fortran::common::RelationalOperator::EQ:
250 return mlir::arith::CmpFPredicate::OEQ;
251 case Fortran::common::RelationalOperator::NE:
252 return mlir::arith::CmpFPredicate::UNE;
253 case Fortran::common::RelationalOperator::GT:
254 return mlir::arith::CmpFPredicate::OGT;
255 case Fortran::common::RelationalOperator::GE:
256 return mlir::arith::CmpFPredicate::OGE;
257 }
258 llvm_unreachable("unhandled REAL relational operator");
259}
260
261static mlir::Value genActualIsPresentTest(fir::FirOpBuilder &builder,
262 mlir::Location loc,
263 fir::ExtendedValue actual) {
264 if (const auto *ptrOrAlloc = actual.getBoxOf<fir::MutableBoxValue>())
265 return fir::factory::genIsAllocatedOrAssociatedTest(builder, loc,
266 *ptrOrAlloc);
267 // Optional case (not that optional allocatable/pointer cannot be absent
268 // when passed to CMPLX as per 15.5.2.12 point 3 (7) and (8)). It is
269 // therefore possible to catch them in the `then` case above.
270 return builder.create<fir::IsPresentOp>(loc, builder.getI1Type(),
271 fir::getBase(actual));
272}
273
274/// Convert the array_load, `load`, to an extended value. If `path` is not
275/// empty, then traverse through the components designated. The base value is
276/// `newBase`. This does not accept an array_load with a slice operand.
277static fir::ExtendedValue
278arrayLoadExtValue(fir::FirOpBuilder &builder, mlir::Location loc,
279 fir::ArrayLoadOp load, llvm::ArrayRef<mlir::Value> path,
280 mlir::Value newBase, mlir::Value newLen = {}) {
281 // Recover the extended value from the load.
282 if (load.getSlice())
283 fir::emitFatalError(loc, "array_load with slice is not allowed");
284 mlir::Type arrTy = load.getType();
285 if (!path.empty()) {
286 mlir::Type ty = fir::applyPathToType(arrTy, path);
287 if (!ty)
288 fir::emitFatalError(loc, "path does not apply to type");
289 if (!mlir::isa<fir::SequenceType>(ty)) {
290 if (fir::isa_char(ty)) {
291 mlir::Value len = newLen;
292 if (!len)
293 len = fir::factory::CharacterExprHelper{builder, loc}.getLength(
294 load.getMemref());
295 if (!len) {
296 assert(load.getTypeparams().size() == 1 &&
297 "length must be in array_load");
298 len = load.getTypeparams()[0];
299 }
300 return fir::CharBoxValue{newBase, len};
301 }
302 return newBase;
303 }
304 arrTy = mlir::cast<fir::SequenceType>(ty);
305 }
306
307 auto arrayToExtendedValue =
308 [&](const llvm::SmallVector<mlir::Value> &extents,
309 const llvm::SmallVector<mlir::Value> &origins) -> fir::ExtendedValue {
310 mlir::Type eleTy = fir::unwrapSequenceType(arrTy);
311 if (fir::isa_char(eleTy)) {
312 mlir::Value len = newLen;
313 if (!len)
314 len = fir::factory::CharacterExprHelper{builder, loc}.getLength(
315 load.getMemref());
316 if (!len) {
317 assert(load.getTypeparams().size() == 1 &&
318 "length must be in array_load");
319 len = load.getTypeparams()[0];
320 }
321 return fir::CharArrayBoxValue(newBase, len, extents, origins);
322 }
323 return fir::ArrayBoxValue(newBase, extents, origins);
324 };
325 // Use the shape op, if there is one.
326 mlir::Value shapeVal = load.getShape();
327 if (shapeVal) {
328 if (!mlir::isa<fir::ShiftOp>(shapeVal.getDefiningOp())) {
329 auto extents = fir::factory::getExtents(shapeVal);
330 auto origins = fir::factory::getOrigins(shapeVal);
331 return arrayToExtendedValue(extents, origins);
332 }
333 if (!fir::isa_box_type(load.getMemref().getType()))
334 fir::emitFatalError(loc, "shift op is invalid in this context");
335 }
336
337 // If we're dealing with the array_load op (not a subobject) and the load does
338 // not have any type parameters, then read the extents from the original box.
339 // The origin may be either from the box or a shift operation. Create and
340 // return the array extended value.
341 if (path.empty() && load.getTypeparams().empty()) {
342 auto oldBox = load.getMemref();
343 fir::ExtendedValue exv = fir::factory::readBoxValue(builder, loc, oldBox);
344 auto extents = fir::factory::getExtents(loc, builder, exv);
345 auto origins = fir::factory::getNonDefaultLowerBounds(builder, loc, exv);
346 if (shapeVal) {
347 // shapeVal is a ShiftOp and load.memref() is a boxed value.
348 newBase = builder.create<fir::ReboxOp>(loc, oldBox.getType(), oldBox,
349 shapeVal, /*slice=*/mlir::Value{});
350 origins = fir::factory::getOrigins(shapeVal);
351 }
352 return fir::substBase(arrayToExtendedValue(extents, origins), newBase);
353 }
354 TODO(loc, "path to a POINTER, ALLOCATABLE, or other component that requires "
355 "dereferencing; generating the type parameters is a hard "
356 "requirement for correctness.");
357}
358
359/// Place \p exv in memory if it is not already a memory reference. If
360/// \p forceValueType is provided, the value is first casted to the provided
361/// type before being stored (this is mainly intended for logicals whose value
362/// may be `i1` but needed to be stored as Fortran logicals).
363static fir::ExtendedValue
364placeScalarValueInMemory(fir::FirOpBuilder &builder, mlir::Location loc,
365 const fir::ExtendedValue &exv,
366 mlir::Type storageType) {
367 mlir::Value valBase = fir::getBase(exv);
368 if (fir::conformsWithPassByRef(valBase.getType()))
369 return exv;
370
371 assert(!fir::hasDynamicSize(storageType) &&
372 "only expect statically sized scalars to be by value");
373
374 // Since `a` is not itself a valid referent, determine its value and
375 // create a temporary location at the beginning of the function for
376 // referencing.
377 mlir::Value val = builder.createConvert(loc, storageType, valBase);
378 mlir::Value temp = builder.createTemporary(
379 loc, storageType,
380 llvm::ArrayRef<mlir::NamedAttribute>{fir::getAdaptToByRefAttr(builder)});
381 builder.create<fir::StoreOp>(loc, val, temp);
382 return fir::substBase(exv, temp);
383}
384
385// Copy a copy of scalar \p exv in a new temporary.
386static fir::ExtendedValue
387createInMemoryScalarCopy(fir::FirOpBuilder &builder, mlir::Location loc,
388 const fir::ExtendedValue &exv) {
389 assert(exv.rank() == 0 && "input to scalar memory copy must be a scalar");
390 if (exv.getCharBox() != nullptr)
391 return fir::factory::CharacterExprHelper{builder, loc}.createTempFrom(exv);
392 if (fir::isDerivedWithLenParameters(exv))
393 TODO(loc, "copy derived type with length parameters");
394 mlir::Type type = fir::unwrapPassByRefType(fir::getBase(exv).getType());
395 fir::ExtendedValue temp = builder.createTemporary(loc, type);
396 fir::factory::genScalarAssignment(builder, loc, temp, exv);
397 return temp;
398}
399
400// An expression with non-zero rank is an array expression.
401template <typename A>
402static bool isArray(const A &x) {
403 return x.Rank() != 0;
404}
405
406/// Is this a variable wrapped in parentheses?
407template <typename A>
408static bool isParenthesizedVariable(const A &) {
409 return false;
410}
411template <typename T>
412static bool isParenthesizedVariable(const Fortran::evaluate::Expr<T> &expr) {
413 using ExprVariant = decltype(Fortran::evaluate::Expr<T>::u);
414 using Parentheses = Fortran::evaluate::Parentheses<T>;
415 if constexpr (Fortran::common::HasMember<Parentheses, ExprVariant>) {
416 if (const auto *parentheses = std::get_if<Parentheses>(&expr.u))
417 return Fortran::evaluate::IsVariable(parentheses->left());
418 return false;
419 } else {
420 return Fortran::common::visit(
421 [&](const auto &x) { return isParenthesizedVariable(x); }, expr.u);
422 }
423}
424
425/// Generate a load of a value from an address. Beware that this will lose
426/// any dynamic type information for polymorphic entities (note that unlimited
427/// polymorphic cannot be loaded and must not be provided here).
428static fir::ExtendedValue genLoad(fir::FirOpBuilder &builder,
429 mlir::Location loc,
430 const fir::ExtendedValue &addr) {
431 return addr.match(
432 [](const fir::CharBoxValue &box) -> fir::ExtendedValue { return box; },
433 [&](const fir::PolymorphicValue &p) -> fir::ExtendedValue {
434 if (mlir::isa<fir::RecordType>(
435 fir::unwrapRefType(fir::getBase(p).getType())))
436 return p;
437 mlir::Value load = builder.create<fir::LoadOp>(loc, fir::getBase(p));
438 return fir::PolymorphicValue(load, p.getSourceBox());
439 },
440 [&](const fir::UnboxedValue &v) -> fir::ExtendedValue {
441 if (mlir::isa<fir::RecordType>(
442 fir::unwrapRefType(fir::getBase(v).getType())))
443 return v;
444 return builder.create<fir::LoadOp>(loc, fir::getBase(v));
445 },
446 [&](const fir::MutableBoxValue &box) -> fir::ExtendedValue {
447 return genLoad(builder, loc,
448 fir::factory::genMutableBoxRead(builder, loc, box));
449 },
450 [&](const fir::BoxValue &box) -> fir::ExtendedValue {
451 return genLoad(builder, loc,
452 fir::factory::readBoxValue(builder, loc, box));
453 },
454 [&](const auto &) -> fir::ExtendedValue {
455 fir::emitFatalError(
456 loc, "attempting to load whole array or procedure address");
457 });
458}
459
460/// Create an optional dummy argument value from entity \p exv that may be
461/// absent. This can only be called with numerical or logical scalar \p exv.
462/// If \p exv is considered absent according to 15.5.2.12 point 1., the returned
463/// value is zero (or false), otherwise it is the value of \p exv.
464static fir::ExtendedValue genOptionalValue(fir::FirOpBuilder &builder,
465 mlir::Location loc,
466 const fir::ExtendedValue &exv,
467 mlir::Value isPresent) {
468 mlir::Type eleType = fir::getBaseTypeOf(exv);
469 assert(exv.rank() == 0 && fir::isa_trivial(eleType) &&
470 "must be a numerical or logical scalar");
471 return builder
472 .genIfOp(loc, {eleType}, isPresent,
473 /*withElseRegion=*/true)
474 .genThen([&]() {
475 mlir::Value val = fir::getBase(genLoad(builder, loc, exv));
476 builder.create<fir::ResultOp>(loc, val);
477 })
478 .genElse([&]() {
479 mlir::Value zero = fir::factory::createZeroValue(builder, loc, eleType);
480 builder.create<fir::ResultOp>(loc, zero);
481 })
482 .getResults()[0];
483}
484
485/// Create an optional dummy argument address from entity \p exv that may be
486/// absent. If \p exv is considered absent according to 15.5.2.12 point 1., the
487/// returned value is a null pointer, otherwise it is the address of \p exv.
488static fir::ExtendedValue genOptionalAddr(fir::FirOpBuilder &builder,
489 mlir::Location loc,
490 const fir::ExtendedValue &exv,
491 mlir::Value isPresent) {
492 // If it is an exv pointer/allocatable, then it cannot be absent
493 // because it is passed to a non-pointer/non-allocatable.
494 if (const auto *box = exv.getBoxOf<fir::MutableBoxValue>())
495 return fir::factory::genMutableBoxRead(builder, loc, *box);
496 // If this is not a POINTER or ALLOCATABLE, then it is already an OPTIONAL
497 // address and can be passed directly.
498 return exv;
499}
500
501/// Create an optional dummy argument address from entity \p exv that may be
502/// absent. If \p exv is considered absent according to 15.5.2.12 point 1., the
503/// returned value is an absent fir.box, otherwise it is a fir.box describing \p
504/// exv.
505static fir::ExtendedValue genOptionalBox(fir::FirOpBuilder &builder,
506 mlir::Location loc,
507 const fir::ExtendedValue &exv,
508 mlir::Value isPresent) {
509 // Non allocatable/pointer optional box -> simply forward
510 if (exv.getBoxOf<fir::BoxValue>())
511 return exv;
512
513 fir::ExtendedValue newExv = exv;
514 // Optional allocatable/pointer -> Cannot be absent, but need to translate
515 // unallocated/diassociated into absent fir.box.
516 if (const auto *box = exv.getBoxOf<fir::MutableBoxValue>())
517 newExv = fir::factory::genMutableBoxRead(builder, loc, *box);
518
519 // createBox will not do create any invalid memory dereferences if exv is
520 // absent. The created fir.box will not be usable, but the SelectOp below
521 // ensures it won't be.
522 mlir::Value box = builder.createBox(loc, newExv);
523 mlir::Type boxType = box.getType();
524 auto absent = builder.create<fir::AbsentOp>(loc, boxType);
525 auto boxOrAbsent = builder.create<mlir::arith::SelectOp>(
526 loc, boxType, isPresent, box, absent);
527 return fir::BoxValue(boxOrAbsent);
528}
529
530/// Is this a call to an elemental procedure with at least one array argument?
531static bool
532isElementalProcWithArrayArgs(const Fortran::evaluate::ProcedureRef &procRef) {
533 if (procRef.IsElemental())
534 for (const std::optional<Fortran::evaluate::ActualArgument> &arg :
535 procRef.arguments())
536 if (arg && arg->Rank() != 0)
537 return true;
538 return false;
539}
540template <typename T>
541static bool isElementalProcWithArrayArgs(const Fortran::evaluate::Expr<T> &) {
542 return false;
543}
544template <>
545bool isElementalProcWithArrayArgs(const Fortran::lower::SomeExpr &x) {
546 if (const auto *procRef = std::get_if<Fortran::evaluate::ProcedureRef>(&x.u))
547 return isElementalProcWithArrayArgs(*procRef);
548 return false;
549}
550
551/// \p argTy must be a tuple (pair) of boxproc and integral types. Convert the
552/// \p funcAddr argument to a boxproc value, with the host-association as
553/// required. Call the factory function to finish creating the tuple value.
554static mlir::Value
555createBoxProcCharTuple(Fortran::lower::AbstractConverter &converter,
556 mlir::Type argTy, mlir::Value funcAddr,
557 mlir::Value charLen) {
558 auto boxTy = mlir::cast<fir::BoxProcType>(
559 mlir::cast<mlir::TupleType>(argTy).getType(0));
560 mlir::Location loc = converter.getCurrentLocation();
561 auto &builder = converter.getFirOpBuilder();
562
563 // While character procedure arguments are expected here, Fortran allows
564 // actual arguments of other types to be passed instead.
565 // To support this, we cast any reference to the expected type or extract
566 // procedures from their boxes if needed.
567 mlir::Type fromTy = funcAddr.getType();
568 mlir::Type toTy = boxTy.getEleTy();
569 if (fir::isa_ref_type(fromTy))
570 funcAddr = builder.createConvert(loc, toTy, funcAddr);
571 else if (mlir::isa<fir::BoxProcType>(fromTy))
572 funcAddr = builder.create<fir::BoxAddrOp>(loc, toTy, funcAddr);
573
574 auto boxProc = [&]() -> mlir::Value {
575 if (auto host = Fortran::lower::argumentHostAssocs(converter, funcAddr))
576 return builder.create<fir::EmboxProcOp>(
577 loc, boxTy, llvm::ArrayRef<mlir::Value>{funcAddr, host});
578 return builder.create<fir::EmboxProcOp>(loc, boxTy, funcAddr);
579 }();
580 return fir::factory::createCharacterProcedureTuple(builder, loc, argTy,
581 boxProc, charLen);
582}
583
584/// Given an optional fir.box, returns an fir.box that is the original one if
585/// it is present and it otherwise an unallocated box.
586/// Absent fir.box are implemented as a null pointer descriptor. Generated
587/// code may need to unconditionally read a fir.box that can be absent.
588/// This helper allows creating a fir.box that can be read in all cases
589/// outside of a fir.if (isPresent) region. However, the usages of the value
590/// read from such box should still only be done in a fir.if(isPresent).
591static fir::ExtendedValue
592absentBoxToUnallocatedBox(fir::FirOpBuilder &builder, mlir::Location loc,
593 const fir::ExtendedValue &exv,
594 mlir::Value isPresent) {
595 mlir::Value box = fir::getBase(exv);
596 mlir::Type boxType = box.getType();
597 assert(mlir::isa<fir::BoxType>(boxType) && "argument must be a fir.box");
598 mlir::Value emptyBox =
599 fir::factory::createUnallocatedBox(builder, loc, boxType, std::nullopt);
600 auto safeToReadBox =
601 builder.create<mlir::arith::SelectOp>(loc, isPresent, box, emptyBox);
602 return fir::substBase(exv, safeToReadBox);
603}
604
605// Helper to get the ultimate first symbol. This works around the fact that
606// symbol resolution in the front end doesn't always resolve a symbol to its
607// ultimate symbol but may leave placeholder indirections for use and host
608// associations.
609template <typename A>
610const Fortran::semantics::Symbol &getFirstSym(const A &obj) {
611 const Fortran::semantics::Symbol &sym = obj.GetFirstSymbol();
612 return sym.HasLocalLocality() ? sym : sym.GetUltimate();
613}
614
615// Helper to get the ultimate last symbol.
616template <typename A>
617const Fortran::semantics::Symbol &getLastSym(const A &obj) {
618 const Fortran::semantics::Symbol &sym = obj.GetLastSymbol();
619 return sym.HasLocalLocality() ? sym : sym.GetUltimate();
620}
621
622// Return true if TRANSPOSE should be lowered without a runtime call.
623static bool
624isTransposeOptEnabled(const Fortran::lower::AbstractConverter &converter) {
625 return optimizeTranspose &&
626 converter.getLoweringOptions().getOptimizeTranspose();
627}
628
629// A set of visitors to detect if the given expression
630// is a TRANSPOSE call that should be lowered without using
631// runtime TRANSPOSE implementation.
632template <typename T>
633static bool isOptimizableTranspose(const T &,
634 const Fortran::lower::AbstractConverter &) {
635 return false;
636}
637
638static bool
639isOptimizableTranspose(const Fortran::evaluate::ProcedureRef &procRef,
640 const Fortran::lower::AbstractConverter &converter) {
641 const Fortran::evaluate::SpecificIntrinsic *intrin =
642 procRef.proc().GetSpecificIntrinsic();
643 if (isTransposeOptEnabled(converter) && intrin &&
644 intrin->name == "transpose") {
645 const std::optional<Fortran::evaluate::ActualArgument> matrix =
646 procRef.arguments().at(0);
647 return !(matrix && matrix->GetType() && matrix->GetType()->IsPolymorphic());
648 }
649 return false;
650}
651
652template <typename T>
653static bool
654isOptimizableTranspose(const Fortran::evaluate::FunctionRef<T> &funcRef,
655 const Fortran::lower::AbstractConverter &converter) {
656 return isOptimizableTranspose(
657 static_cast<const Fortran::evaluate::ProcedureRef &>(funcRef), converter);
658}
659
660template <typename T>
661static bool
662isOptimizableTranspose(Fortran::evaluate::Expr<T> expr,
663 const Fortran::lower::AbstractConverter &converter) {
664 // If optimizeTranspose is not enabled, return false right away.
665 if (!isTransposeOptEnabled(converter))
666 return false;
667
668 return Fortran::common::visit(
669 [&](const auto &e) { return isOptimizableTranspose(e, converter); },
670 expr.u);
671}
672
673namespace {
674
675/// Lowering of Fortran::evaluate::Expr<T> expressions
676class ScalarExprLowering {
677public:
678 using ExtValue = fir::ExtendedValue;
679
680 explicit ScalarExprLowering(mlir::Location loc,
681 Fortran::lower::AbstractConverter &converter,
682 Fortran::lower::SymMap &symMap,
683 Fortran::lower::StatementContext &stmtCtx,
684 bool inInitializer = false)
685 : location{loc}, converter{converter},
686 builder{converter.getFirOpBuilder()}, stmtCtx{stmtCtx}, symMap{symMap},
687 inInitializer{inInitializer} {}
688
689 ExtValue genExtAddr(const Fortran::lower::SomeExpr &expr) {
690 return gen(expr);
691 }
692
693 /// Lower `expr` to be passed as a fir.box argument. Do not create a temp
694 /// for the expr if it is a variable that can be described as a fir.box.
695 ExtValue genBoxArg(const Fortran::lower::SomeExpr &expr) {
696 bool saveUseBoxArg = useBoxArg;
697 useBoxArg = true;
698 ExtValue result = gen(expr);
699 useBoxArg = saveUseBoxArg;
700 return result;
701 }
702
703 ExtValue genExtValue(const Fortran::lower::SomeExpr &expr) {
704 return genval(expr);
705 }
706
707 /// Lower an expression that is a pointer or an allocatable to a
708 /// MutableBoxValue.
709 fir::MutableBoxValue
710 genMutableBoxValue(const Fortran::lower::SomeExpr &expr) {
711 // Pointers and allocatables can only be:
712 // - a simple designator "x"
713 // - a component designator "a%b(i,j)%x"
714 // - a function reference "foo()"
715 // - result of NULL() or NULL(MOLD) intrinsic.
716 // NULL() requires some context to be lowered, so it is not handled
717 // here and must be lowered according to the context where it appears.
718 ExtValue exv = Fortran::common::visit(
719 [&](const auto &x) { return genMutableBoxValueImpl(x); }, expr.u);
720 const fir::MutableBoxValue *mutableBox =
721 exv.getBoxOf<fir::MutableBoxValue>();
722 if (!mutableBox)
723 fir::emitFatalError(getLoc(), "expr was not lowered to MutableBoxValue");
724 return *mutableBox;
725 }
726
727 template <typename T>
728 ExtValue genMutableBoxValueImpl(const T &) {
729 // NULL() case should not be handled here.
730 fir::emitFatalError(getLoc(), "NULL() must be lowered in its context");
731 }
732
733 /// A `NULL()` in a position where a mutable box is expected has the same
734 /// semantics as an absent optional box value. Note: this code should
735 /// be depreciated because the rank information is not known here. A
736 /// scalar fir.box is created: it should not be cast to an array box type
737 /// later, but there is no way to enforce that here.
738 ExtValue genMutableBoxValueImpl(const Fortran::evaluate::NullPointer &) {
739 mlir::Location loc = getLoc();
740 mlir::Type noneTy = mlir::NoneType::get(builder.getContext());
741 mlir::Type polyRefTy = fir::PointerType::get(noneTy);
742 mlir::Type boxType = fir::BoxType::get(polyRefTy);
743 mlir::Value tempBox =
744 fir::factory::genNullBoxStorage(builder, loc, boxType);
745 return fir::MutableBoxValue(tempBox,
746 /*lenParameters=*/mlir::ValueRange{},
747 /*mutableProperties=*/{});
748 }
749
750 template <typename T>
751 ExtValue
752 genMutableBoxValueImpl(const Fortran::evaluate::FunctionRef<T> &funRef) {
753 return genRawProcedureRef(funRef, converter.genType(toEvExpr(funRef)));
754 }
755
756 template <typename T>
757 ExtValue
758 genMutableBoxValueImpl(const Fortran::evaluate::Designator<T> &designator) {
759 return Fortran::common::visit(
760 Fortran::common::visitors{
761 [&](const Fortran::evaluate::SymbolRef &sym) -> ExtValue {
762 return converter.getSymbolExtendedValue(*sym, &symMap);
763 },
764 [&](const Fortran::evaluate::Component &comp) -> ExtValue {
765 return genComponent(comp);
766 },
767 [&](const auto &) -> ExtValue {
768 fir::emitFatalError(getLoc(),
769 "not an allocatable or pointer designator");
770 }},
771 designator.u);
772 }
773
774 template <typename T>
775 ExtValue genMutableBoxValueImpl(const Fortran::evaluate::Expr<T> &expr) {
776 return Fortran::common::visit(
777 [&](const auto &x) { return genMutableBoxValueImpl(x); }, expr.u);
778 }
779
780 mlir::Location getLoc() { return location; }
781
782 template <typename A>
783 mlir::Value genunbox(const A &expr) {
784 ExtValue e = genval(expr);
785 if (const fir::UnboxedValue *r = e.getUnboxed())
786 return *r;
787 fir::emitFatalError(getLoc(), "unboxed expression expected");
788 }
789
790 /// Generate an integral constant of `value`
791 template <int KIND>
792 mlir::Value genIntegerConstant(mlir::MLIRContext *context,
793 std::int64_t value) {
794 mlir::Type type =
795 converter.genType(Fortran::common::TypeCategory::Integer, KIND);
796 return builder.createIntegerConstant(getLoc(), type, value);
797 }
798
799 /// Generate a logical/boolean constant of `value`
800 mlir::Value genBoolConstant(bool value) {
801 return builder.createBool(getLoc(), value);
802 }
803
804 mlir::Type getSomeKindInteger() { return builder.getIndexType(); }
805
806 mlir::func::FuncOp getFunction(llvm::StringRef name,
807 mlir::FunctionType funTy) {
808 if (mlir::func::FuncOp func = builder.getNamedFunction(name))
809 return func;
810 return builder.createFunction(getLoc(), name, funTy);
811 }
812
813 template <typename OpTy>
814 mlir::Value createCompareOp(mlir::arith::CmpIPredicate pred,
815 const ExtValue &left, const ExtValue &right,
816 std::optional<int> unsignedKind = std::nullopt) {
817 if (const fir::UnboxedValue *lhs = left.getUnboxed()) {
818 if (const fir::UnboxedValue *rhs = right.getUnboxed()) {
819 auto loc = getLoc();
820 if (unsignedKind) {
821 mlir::Type signlessType = converter.genType(
822 Fortran::common::TypeCategory::Integer, *unsignedKind);
823 mlir::Value lhsSL = builder.createConvert(loc, signlessType, *lhs);
824 mlir::Value rhsSL = builder.createConvert(loc, signlessType, *rhs);
825 return builder.create<OpTy>(loc, pred, lhsSL, rhsSL);
826 }
827 return builder.create<OpTy>(loc, pred, *lhs, *rhs);
828 }
829 }
830 fir::emitFatalError(getLoc(), "array compare should be handled in genarr");
831 }
832 template <typename OpTy, typename A>
833 mlir::Value createCompareOp(const A &ex, mlir::arith::CmpIPredicate pred,
834 std::optional<int> unsignedKind = std::nullopt) {
835 ExtValue left = genval(ex.left());
836 return createCompareOp<OpTy>(pred, left, genval(ex.right()), unsignedKind);
837 }
838
839 template <typename OpTy>
840 mlir::Value createFltCmpOp(mlir::arith::CmpFPredicate pred,
841 const ExtValue &left, const ExtValue &right) {
842 if (const fir::UnboxedValue *lhs = left.getUnboxed())
843 if (const fir::UnboxedValue *rhs = right.getUnboxed())
844 return builder.create<OpTy>(getLoc(), pred, *lhs, *rhs);
845 fir::emitFatalError(getLoc(), "array compare should be handled in genarr");
846 }
847 template <typename OpTy, typename A>
848 mlir::Value createFltCmpOp(const A &ex, mlir::arith::CmpFPredicate pred) {
849 ExtValue left = genval(ex.left());
850 return createFltCmpOp<OpTy>(pred, left, genval(ex.right()));
851 }
852
853 /// Create a call to the runtime to compare two CHARACTER values.
854 /// Precondition: This assumes that the two values have `fir.boxchar` type.
855 mlir::Value createCharCompare(mlir::arith::CmpIPredicate pred,
856 const ExtValue &left, const ExtValue &right) {
857 return fir::runtime::genCharCompare(builder, getLoc(), pred, left, right);
858 }
859
860 template <typename A>
861 mlir::Value createCharCompare(const A &ex, mlir::arith::CmpIPredicate pred) {
862 ExtValue left = genval(ex.left());
863 return createCharCompare(pred, left, genval(ex.right()));
864 }
865
866 /// Returns a reference to a symbol or its box/boxChar descriptor if it has
867 /// one.
868 ExtValue gen(Fortran::semantics::SymbolRef sym) {
869 fir::ExtendedValue exv = converter.getSymbolExtendedValue(sym, &symMap);
870 if (const auto *box = exv.getBoxOf<fir::MutableBoxValue>())
871 return fir::factory::genMutableBoxRead(builder, getLoc(), *box);
872 return exv;
873 }
874
875 ExtValue genLoad(const ExtValue &exv) {
876 return ::genLoad(builder, getLoc(), exv);
877 }
878
879 ExtValue genval(Fortran::semantics::SymbolRef sym) {
880 mlir::Location loc = getLoc();
881 ExtValue var = gen(sym);
882 if (const fir::UnboxedValue *s = var.getUnboxed()) {
883 if (fir::isa_ref_type(s->getType())) {
884 // A function with multiple entry points returning different types
885 // tags all result variables with one of the largest types to allow
886 // them to share the same storage. A reference to a result variable
887 // of one of the other types requires conversion to the actual type.
888 fir::UnboxedValue addr = *s;
889 if (Fortran::semantics::IsFunctionResult(sym)) {
890 mlir::Type resultType = converter.genType(*sym);
891 if (addr.getType() != resultType)
892 addr = builder.createConvert(loc, builder.getRefType(resultType),
893 addr);
894 } else if (sym->test(Fortran::semantics::Symbol::Flag::CrayPointee)) {
895 // get the corresponding Cray pointer
896 Fortran::semantics::SymbolRef ptrSym{
897 Fortran::semantics::GetCrayPointer(sym)};
898 ExtValue ptr = gen(ptrSym);
899 mlir::Value ptrVal = fir::getBase(ptr);
900 mlir::Type ptrTy = converter.genType(*ptrSym);
901
902 ExtValue pte = gen(sym);
903 mlir::Value pteVal = fir::getBase(pte);
904
905 mlir::Value cnvrt = Fortran::lower::addCrayPointerInst(
906 loc, builder, ptrVal, ptrTy, pteVal.getType());
907 addr = builder.create<fir::LoadOp>(loc, cnvrt);
908 }
909 return genLoad(addr);
910 }
911 }
912 return var;
913 }
914
915 ExtValue genval(const Fortran::evaluate::BOZLiteralConstant &) {
916 TODO(getLoc(), "BOZ");
917 }
918
919 /// Return indirection to function designated in ProcedureDesignator.
920 /// The type of the function indirection is not guaranteed to match the one
921 /// of the ProcedureDesignator due to Fortran implicit typing rules.
922 ExtValue genval(const Fortran::evaluate::ProcedureDesignator &proc) {
923 return Fortran::lower::convertProcedureDesignator(getLoc(), converter, proc,
924 symMap, stmtCtx);
925 }
926 ExtValue genval(const Fortran::evaluate::NullPointer &) {
927 return builder.createNullConstant(getLoc());
928 }
929
930 static bool
931 isDerivedTypeWithLenParameters(const Fortran::semantics::Symbol &sym) {
932 if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType())
933 if (const Fortran::semantics::DerivedTypeSpec *derived =
934 declTy->AsDerived())
935 return Fortran::semantics::CountLenParameters(*derived) > 0;
936 return false;
937 }
938
939 /// A structure constructor is lowered two ways. In an initializer context,
940 /// the entire structure must be constant, so the aggregate value is
941 /// constructed inline. This allows it to be the body of a GlobalOp.
942 /// Otherwise, the structure constructor is in an expression. In that case, a
943 /// temporary object is constructed in the stack frame of the procedure.
944 ExtValue genval(const Fortran::evaluate::StructureConstructor &ctor) {
945 mlir::Location loc = getLoc();
946 if (inInitializer)
947 return Fortran::lower::genInlinedStructureCtorLit(converter, loc, ctor);
948 mlir::Type ty = translateSomeExprToFIRType(converter, toEvExpr(ctor));
949 auto recTy = mlir::cast<fir::RecordType>(ty);
950 auto fieldTy = fir::FieldType::get(ty.getContext());
951 mlir::Value res = builder.createTemporary(loc, recTy);
952 mlir::Value box = builder.createBox(loc, fir::ExtendedValue{res});
953 fir::runtime::genDerivedTypeInitialize(builder, loc, box);
954
955 for (const auto &value : ctor.values()) {
956 const Fortran::semantics::Symbol &sym = *value.first;
957 const Fortran::lower::SomeExpr &expr = value.second.value();
958 if (sym.test(Fortran::semantics::Symbol::Flag::ParentComp)) {
959 ExtValue from = gen(expr);
960 mlir::Type fromTy = fir::unwrapPassByRefType(
961 fir::unwrapRefType(fir::getBase(from).getType()));
962 mlir::Value resCast =
963 builder.createConvert(loc, builder.getRefType(fromTy), res);
964 fir::factory::genRecordAssignment(builder, loc, resCast, from);
965 continue;
966 }
967
968 if (isDerivedTypeWithLenParameters(sym))
969 TODO(loc, "component with length parameters in structure constructor");
970
971 std::string name = converter.getRecordTypeFieldName(sym);
972 // FIXME: type parameters must come from the derived-type-spec
973 mlir::Value field = builder.create<fir::FieldIndexOp>(
974 loc, fieldTy, name, ty,
975 /*typeParams=*/mlir::ValueRange{} /*TODO*/);
976 mlir::Type coorTy = builder.getRefType(recTy.getType(name));
977 auto coor = builder.create<fir::CoordinateOp>(loc, coorTy,
978 fir::getBase(res), field);
979 ExtValue to = fir::factory::componentToExtendedValue(builder, loc, coor);
980 to.match(
981 [&](const fir::UnboxedValue &toPtr) {
982 ExtValue value = genval(expr);
983 fir::factory::genScalarAssignment(builder, loc, to, value);
984 },
985 [&](const fir::CharBoxValue &) {
986 ExtValue value = genval(expr);
987 fir::factory::genScalarAssignment(builder, loc, to, value);
988 },
989 [&](const fir::ArrayBoxValue &) {
990 Fortran::lower::createSomeArrayAssignment(converter, to, expr,
991 symMap, stmtCtx);
992 },
993 [&](const fir::CharArrayBoxValue &) {
994 Fortran::lower::createSomeArrayAssignment(converter, to, expr,
995 symMap, stmtCtx);
996 },
997 [&](const fir::BoxValue &toBox) {
998 fir::emitFatalError(loc, "derived type components must not be "
999 "represented by fir::BoxValue");
1000 },
1001 [&](const fir::PolymorphicValue &) {
1002 TODO(loc, "polymorphic component in derived type assignment");
1003 },
1004 [&](const fir::MutableBoxValue &toBox) {
1005 if (toBox.isPointer()) {
1006 Fortran::lower::associateMutableBox(converter, loc, toBox, expr,
1007 /*lbounds=*/std::nullopt,
1008 stmtCtx);
1009 return;
1010 }
1011 // For allocatable components, a deep copy is needed.
1012 TODO(loc, "allocatable components in derived type assignment");
1013 },
1014 [&](const fir::ProcBoxValue &toBox) {
1015 TODO(loc, "procedure pointer component in derived type assignment");
1016 });
1017 }
1018 return res;
1019 }
1020
1021 /// Lowering of an <i>ac-do-variable</i>, which is not a Symbol.
1022 ExtValue genval(const Fortran::evaluate::ImpliedDoIndex &var) {
1023 mlir::Value value = converter.impliedDoBinding(toStringRef(var.name));
1024 // The index value generated by the implied-do has Index type,
1025 // while computations based on it inside the loop body are using
1026 // the original data type. So we need to cast it appropriately.
1027 mlir::Type varTy = converter.genType(toEvExpr(var));
1028 return builder.createConvert(getLoc(), varTy, value);
1029 }
1030
1031 ExtValue genval(const Fortran::evaluate::DescriptorInquiry &desc) {
1032 ExtValue exv = desc.base().IsSymbol() ? gen(getLastSym(desc.base()))
1033 : gen(desc.base().GetComponent());
1034 mlir::IndexType idxTy = builder.getIndexType();
1035 mlir::Location loc = getLoc();
1036 auto castResult = [&](mlir::Value v) {
1037 using ResTy = Fortran::evaluate::DescriptorInquiry::Result;
1038 return builder.createConvert(
1039 loc, converter.genType(ResTy::category, ResTy::kind), v);
1040 };
1041 switch (desc.field()) {
1042 case Fortran::evaluate::DescriptorInquiry::Field::Len:
1043 return castResult(fir::factory::readCharLen(builder, loc, exv));
1044 case Fortran::evaluate::DescriptorInquiry::Field::LowerBound:
1045 return castResult(fir::factory::readLowerBound(
1046 builder, loc, exv, desc.dimension(),
1047 builder.createIntegerConstant(loc, idxTy, 1)));
1048 case Fortran::evaluate::DescriptorInquiry::Field::Extent:
1049 return castResult(
1050 fir::factory::readExtent(builder, loc, exv, desc.dimension()));
1051 case Fortran::evaluate::DescriptorInquiry::Field::Rank:
1052 TODO(loc, "rank inquiry on assumed rank");
1053 case Fortran::evaluate::DescriptorInquiry::Field::Stride:
1054 // So far the front end does not generate this inquiry.
1055 TODO(loc, "stride inquiry");
1056 }
1057 llvm_unreachable("unknown descriptor inquiry");
1058 }
1059
1060 ExtValue genval(const Fortran::evaluate::TypeParamInquiry &) {
1061 TODO(getLoc(), "type parameter inquiry");
1062 }
1063
1064 mlir::Value extractComplexPart(mlir::Value cplx, bool isImagPart) {
1065 return fir::factory::Complex{builder, getLoc()}.extractComplexPart(
1066 cplx, isImagPart);
1067 }
1068
1069 template <int KIND>
1070 ExtValue genval(const Fortran::evaluate::ComplexComponent<KIND> &part) {
1071 return extractComplexPart(genunbox(part.left()), part.isImaginaryPart);
1072 }
1073
1074 template <int KIND>
1075 ExtValue genval(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
1076 Fortran::common::TypeCategory::Integer, KIND>> &op) {
1077 mlir::Value input = genunbox(op.left());
1078 // Like LLVM, integer negation is the binary op "0 - value"
1079 mlir::Value zero = genIntegerConstant<KIND>(builder.getContext(), 0);
1080 return builder.create<mlir::arith::SubIOp>(getLoc(), zero, input);
1081 }
1082 template <int KIND>
1083 ExtValue genval(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
1084 Fortran::common::TypeCategory::Unsigned, KIND>> &op) {
1085 auto loc = getLoc();
1086 mlir::Type signlessType =
1087 converter.genType(Fortran::common::TypeCategory::Integer, KIND);
1088 mlir::Value input = genunbox(op.left());
1089 mlir::Value signless = builder.createConvert(loc, signlessType, input);
1090 mlir::Value zero = genIntegerConstant<KIND>(builder.getContext(), 0);
1091 mlir::Value neg = builder.create<mlir::arith::SubIOp>(loc, zero, signless);
1092 return builder.createConvert(loc, input.getType(), neg);
1093 }
1094 template <int KIND>
1095 ExtValue genval(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
1096 Fortran::common::TypeCategory::Real, KIND>> &op) {
1097 return builder.create<mlir::arith::NegFOp>(getLoc(), genunbox(op.left()));
1098 }
1099 template <int KIND>
1100 ExtValue genval(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
1101 Fortran::common::TypeCategory::Complex, KIND>> &op) {
1102 return builder.create<fir::NegcOp>(getLoc(), genunbox(op.left()));
1103 }
1104
1105 template <typename OpTy>
1106 mlir::Value createBinaryOp(const ExtValue &left, const ExtValue &right) {
1107 assert(fir::isUnboxedValue(left) && fir::isUnboxedValue(right));
1108 mlir::Value lhs = fir::getBase(left);
1109 mlir::Value rhs = fir::getBase(right);
1110 assert(lhs.getType() == rhs.getType() && "types must be the same");
1111 return builder.createUnsigned<OpTy>(getLoc(), lhs.getType(), lhs, rhs);
1112 }
1113
1114 template <typename OpTy, typename A>
1115 mlir::Value createBinaryOp(const A &ex) {
1116 ExtValue left = genval(ex.left());
1117 return createBinaryOp<OpTy>(left, genval(ex.right()));
1118 }
1119
1120#undef GENBIN
1121#define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp) \
1122 template <int KIND> \
1123 ExtValue genval(const Fortran::evaluate::GenBinEvOp<Fortran::evaluate::Type< \
1124 Fortran::common::TypeCategory::GenBinTyCat, KIND>> &x) { \
1125 return createBinaryOp<GenBinFirOp>(x); \
1126 }
1127
1128 GENBIN(Add, Integer, mlir::arith::AddIOp)
1129 GENBIN(Add, Unsigned, mlir::arith::AddIOp)
1130 GENBIN(Add, Real, mlir::arith::AddFOp)
1131 GENBIN(Add, Complex, fir::AddcOp)
1132 GENBIN(Subtract, Integer, mlir::arith::SubIOp)
1133 GENBIN(Subtract, Unsigned, mlir::arith::SubIOp)
1134 GENBIN(Subtract, Real, mlir::arith::SubFOp)
1135 GENBIN(Subtract, Complex, fir::SubcOp)
1136 GENBIN(Multiply, Integer, mlir::arith::MulIOp)
1137 GENBIN(Multiply, Unsigned, mlir::arith::MulIOp)
1138 GENBIN(Multiply, Real, mlir::arith::MulFOp)
1139 GENBIN(Multiply, Complex, fir::MulcOp)
1140 GENBIN(Divide, Integer, mlir::arith::DivSIOp)
1141 GENBIN(Divide, Unsigned, mlir::arith::DivUIOp)
1142 GENBIN(Divide, Real, mlir::arith::DivFOp)
1143
1144 template <int KIND>
1145 ExtValue genval(const Fortran::evaluate::Divide<Fortran::evaluate::Type<
1146 Fortran::common::TypeCategory::Complex, KIND>> &op) {
1147 mlir::Type ty =
1148 converter.genType(Fortran::common::TypeCategory::Complex, KIND);
1149 mlir::Value lhs = genunbox(op.left());
1150 mlir::Value rhs = genunbox(op.right());
1151 return fir::genDivC(builder, getLoc(), ty, lhs, rhs);
1152 }
1153
1154 template <Fortran::common::TypeCategory TC, int KIND>
1155 ExtValue genval(
1156 const Fortran::evaluate::Power<Fortran::evaluate::Type<TC, KIND>> &op) {
1157 mlir::Type ty = converter.genType(TC, KIND);
1158 mlir::Value lhs = genunbox(op.left());
1159 mlir::Value rhs = genunbox(op.right());
1160 return fir::genPow(builder, getLoc(), ty, lhs, rhs);
1161 }
1162
1163 template <Fortran::common::TypeCategory TC, int KIND>
1164 ExtValue genval(
1165 const Fortran::evaluate::RealToIntPower<Fortran::evaluate::Type<TC, KIND>>
1166 &op) {
1167 mlir::Type ty = converter.genType(TC, KIND);
1168 mlir::Value lhs = genunbox(op.left());
1169 mlir::Value rhs = genunbox(op.right());
1170 return fir::genPow(builder, getLoc(), ty, lhs, rhs);
1171 }
1172
1173 template <int KIND>
1174 ExtValue genval(const Fortran::evaluate::ComplexConstructor<KIND> &op) {
1175 mlir::Value realPartValue = genunbox(op.left());
1176 return fir::factory::Complex{builder, getLoc()}.createComplex(
1177 realPartValue, genunbox(op.right()));
1178 }
1179
1180 template <int KIND>
1181 ExtValue genval(const Fortran::evaluate::Concat<KIND> &op) {
1182 ExtValue lhs = genval(op.left());
1183 ExtValue rhs = genval(op.right());
1184 const fir::CharBoxValue *lhsChar = lhs.getCharBox();
1185 const fir::CharBoxValue *rhsChar = rhs.getCharBox();
1186 if (lhsChar && rhsChar)
1187 return fir::factory::CharacterExprHelper{builder, getLoc()}
1188 .createConcatenate(*lhsChar, *rhsChar);
1189 TODO(getLoc(), "character array concatenate");
1190 }
1191
1192 /// MIN and MAX operations
1193 template <Fortran::common::TypeCategory TC, int KIND>
1194 ExtValue
1195 genval(const Fortran::evaluate::Extremum<Fortran::evaluate::Type<TC, KIND>>
1196 &op) {
1197 mlir::Value lhs = genunbox(op.left());
1198 mlir::Value rhs = genunbox(op.right());
1199 switch (op.ordering) {
1200 case Fortran::evaluate::Ordering::Greater:
1201 return fir::genMax(builder, getLoc(),
1202 llvm::ArrayRef<mlir::Value>{lhs, rhs});
1203 case Fortran::evaluate::Ordering::Less:
1204 return fir::genMin(builder, getLoc(),
1205 llvm::ArrayRef<mlir::Value>{lhs, rhs});
1206 case Fortran::evaluate::Ordering::Equal:
1207 llvm_unreachable("Equal is not a valid ordering in this context");
1208 }
1209 llvm_unreachable("unknown ordering");
1210 }
1211
1212 // Change the dynamic length information without actually changing the
1213 // underlying character storage.
1214 fir::ExtendedValue
1215 replaceScalarCharacterLength(const fir::ExtendedValue &scalarChar,
1216 mlir::Value newLenValue) {
1217 mlir::Location loc = getLoc();
1218 const fir::CharBoxValue *charBox = scalarChar.getCharBox();
1219 if (!charBox)
1220 fir::emitFatalError(loc, "expected scalar character");
1221 mlir::Value charAddr = charBox->getAddr();
1222 auto charType = mlir::cast<fir::CharacterType>(
1223 fir::unwrapPassByRefType(charAddr.getType()));
1224 if (charType.hasConstantLen()) {
1225 // Erase previous constant length from the base type.
1226 fir::CharacterType::LenType newLen = fir::CharacterType::unknownLen();
1227 mlir::Type newCharTy = fir::CharacterType::get(
1228 builder.getContext(), charType.getFKind(), newLen);
1229 mlir::Type newType = fir::ReferenceType::get(newCharTy);
1230 charAddr = builder.createConvert(loc, newType, charAddr);
1231 return fir::CharBoxValue{charAddr, newLenValue};
1232 }
1233 return fir::CharBoxValue{charAddr, newLenValue};
1234 }
1235
1236 template <int KIND>
1237 ExtValue genval(const Fortran::evaluate::SetLength<KIND> &x) {
1238 mlir::Value newLenValue = genunbox(x.right());
1239 fir::ExtendedValue lhs = gen(x.left());
1240 fir::factory::CharacterExprHelper charHelper(builder, getLoc());
1241 fir::CharBoxValue temp = charHelper.createCharacterTemp(
1242 charHelper.getCharacterType(fir::getBase(lhs).getType()), newLenValue);
1243 charHelper.createAssign(temp, lhs);
1244 return fir::ExtendedValue{temp};
1245 }
1246
1247 template <int KIND>
1248 ExtValue genval(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
1249 Fortran::common::TypeCategory::Integer, KIND>> &op) {
1250 return createCompareOp<mlir::arith::CmpIOp>(
1251 op, translateSignedRelational(op.opr));
1252 }
1253 template <int KIND>
1254 ExtValue genval(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
1255 Fortran::common::TypeCategory::Unsigned, KIND>> &op) {
1256 return createCompareOp<mlir::arith::CmpIOp>(
1257 op, translateUnsignedRelational(op.opr), KIND);
1258 }
1259 template <int KIND>
1260 ExtValue genval(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
1261 Fortran::common::TypeCategory::Real, KIND>> &op) {
1262 return createFltCmpOp<mlir::arith::CmpFOp>(
1263 op, translateFloatRelational(op.opr));
1264 }
1265 template <int KIND>
1266 ExtValue genval(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
1267 Fortran::common::TypeCategory::Complex, KIND>> &op) {
1268 return createFltCmpOp<fir::CmpcOp>(op, translateFloatRelational(op.opr));
1269 }
1270 template <int KIND>
1271 ExtValue genval(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
1272 Fortran::common::TypeCategory::Character, KIND>> &op) {
1273 return createCharCompare(op, translateSignedRelational(op.opr));
1274 }
1275
1276 ExtValue
1277 genval(const Fortran::evaluate::Relational<Fortran::evaluate::SomeType> &op) {
1278 return Fortran::common::visit([&](const auto &x) { return genval(x); },
1279 op.u);
1280 }
1281
1282 template <Fortran::common::TypeCategory TC1, int KIND,
1283 Fortran::common::TypeCategory TC2>
1284 ExtValue
1285 genval(const Fortran::evaluate::Convert<Fortran::evaluate::Type<TC1, KIND>,
1286 TC2> &convert) {
1287 mlir::Type ty = converter.genType(TC1, KIND);
1288 auto fromExpr = genval(convert.left());
1289 auto loc = getLoc();
1290 return fromExpr.match(
1291 [&](const fir::CharBoxValue &boxchar) -> ExtValue {
1292 if constexpr (TC1 == Fortran::common::TypeCategory::Character &&
1293 TC2 == TC1) {
1294 return fir::factory::convertCharacterKind(builder, loc, boxchar,
1295 KIND);
1296 } else {
1297 fir::emitFatalError(
1298 loc, "unsupported evaluate::Convert between CHARACTER type "
1299 "category and non-CHARACTER category");
1300 }
1301 },
1302 [&](const fir::UnboxedValue &value) -> ExtValue {
1303 return builder.convertWithSemantics(loc, ty, value);
1304 },
1305 [&](auto &) -> ExtValue {
1306 fir::emitFatalError(loc, "unsupported evaluate::Convert");
1307 });
1308 }
1309
1310 template <typename A>
1311 ExtValue genval(const Fortran::evaluate::Parentheses<A> &op) {
1312 ExtValue input = genval(op.left());
1313 mlir::Value base = fir::getBase(input);
1314 mlir::Value newBase =
1315 builder.create<fir::NoReassocOp>(getLoc(), base.getType(), base);
1316 return fir::substBase(input, newBase);
1317 }
1318
1319 template <int KIND>
1320 ExtValue genval(const Fortran::evaluate::Not<KIND> &op) {
1321 mlir::Value logical = genunbox(op.left());
1322 mlir::Value one = genBoolConstant(true);
1323 mlir::Value val =
1324 builder.createConvert(getLoc(), builder.getI1Type(), logical);
1325 return builder.create<mlir::arith::XOrIOp>(getLoc(), val, one);
1326 }
1327
1328 template <int KIND>
1329 ExtValue genval(const Fortran::evaluate::LogicalOperation<KIND> &op) {
1330 mlir::IntegerType i1Type = builder.getI1Type();
1331 mlir::Value slhs = genunbox(op.left());
1332 mlir::Value srhs = genunbox(op.right());
1333 mlir::Value lhs = builder.createConvert(getLoc(), i1Type, slhs);
1334 mlir::Value rhs = builder.createConvert(getLoc(), i1Type, srhs);
1335 switch (op.logicalOperator) {
1336 case Fortran::evaluate::LogicalOperator::And:
1337 return createBinaryOp<mlir::arith::AndIOp>(lhs, rhs);
1338 case Fortran::evaluate::LogicalOperator::Or:
1339 return createBinaryOp<mlir::arith::OrIOp>(lhs, rhs);
1340 case Fortran::evaluate::LogicalOperator::Eqv:
1341 return createCompareOp<mlir::arith::CmpIOp>(
1342 mlir::arith::CmpIPredicate::eq, lhs, rhs);
1343 case Fortran::evaluate::LogicalOperator::Neqv:
1344 return createCompareOp<mlir::arith::CmpIOp>(
1345 mlir::arith::CmpIPredicate::ne, lhs, rhs);
1346 case Fortran::evaluate::LogicalOperator::Not:
1347 // lib/evaluate expression for .NOT. is Fortran::evaluate::Not<KIND>.
1348 llvm_unreachable(".NOT. is not a binary operator");
1349 }
1350 llvm_unreachable("unhandled logical operation");
1351 }
1352
1353 template <Fortran::common::TypeCategory TC, int KIND>
1354 ExtValue
1355 genval(const Fortran::evaluate::Constant<Fortran::evaluate::Type<TC, KIND>>
1356 &con) {
1357 return Fortran::lower::convertConstant(
1358 converter, getLoc(), con,
1359 /*outlineBigConstantsInReadOnlyMemory=*/!inInitializer);
1360 }
1361
1362 fir::ExtendedValue genval(
1363 const Fortran::evaluate::Constant<Fortran::evaluate::SomeDerived> &con) {
1364 if (auto ctor = con.GetScalarValue())
1365 return genval(*ctor);
1366 return Fortran::lower::convertConstant(
1367 converter, getLoc(), con,
1368 /*outlineBigConstantsInReadOnlyMemory=*/false);
1369 }
1370
1371 template <typename A>
1372 ExtValue genval(const Fortran::evaluate::ArrayConstructor<A> &) {
1373 fir::emitFatalError(getLoc(), "array constructor: should not reach here");
1374 }
1375
1376 ExtValue gen(const Fortran::evaluate::ComplexPart &x) {
1377 mlir::Location loc = getLoc();
1378 auto idxTy = builder.getI32Type();
1379 ExtValue exv = gen(x.complex());
1380 mlir::Value base = fir::getBase(exv);
1381 fir::factory::Complex helper{builder, loc};
1382 mlir::Type eleTy =
1383 helper.getComplexPartType(fir::dyn_cast_ptrEleTy(base.getType()));
1384 mlir::Value offset = builder.createIntegerConstant(
1385 loc, idxTy,
1386 x.part() == Fortran::evaluate::ComplexPart::Part::RE ? 0 : 1);
1387 mlir::Value result = builder.create<fir::CoordinateOp>(
1388 loc, builder.getRefType(eleTy), base, mlir::ValueRange{offset});
1389 return {result};
1390 }
1391 ExtValue genval(const Fortran::evaluate::ComplexPart &x) {
1392 return genLoad(gen(x));
1393 }
1394
1395 /// Reference to a substring.
1396 ExtValue gen(const Fortran::evaluate::Substring &s) {
1397 // Get base string
1398 auto baseString = Fortran::common::visit(
1399 Fortran::common::visitors{
1400 [&](const Fortran::evaluate::DataRef &x) { return gen(x); },
1401 [&](const Fortran::evaluate::StaticDataObject::Pointer &p)
1402 -> ExtValue {
1403 if (std::optional<std::string> str = p->AsString())
1404 return fir::factory::createStringLiteral(builder, getLoc(),
1405 *str);
1406 // TODO: convert StaticDataObject to Constant<T> and use normal
1407 // constant path. Beware that StaticDataObject data() takes into
1408 // account build machine endianness.
1409 TODO(getLoc(),
1410 "StaticDataObject::Pointer substring with kind > 1");
1411 },
1412 },
1413 s.parent());
1414 llvm::SmallVector<mlir::Value> bounds;
1415 mlir::Value lower = genunbox(s.lower());
1416 bounds.push_back(lower);
1417 if (Fortran::evaluate::MaybeExtentExpr upperBound = s.upper()) {
1418 mlir::Value upper = genunbox(*upperBound);
1419 bounds.push_back(upper);
1420 }
1421 fir::factory::CharacterExprHelper charHelper{builder, getLoc()};
1422 return baseString.match(
1423 [&](const fir::CharBoxValue &x) -> ExtValue {
1424 return charHelper.createSubstring(x, bounds);
1425 },
1426 [&](const fir::CharArrayBoxValue &) -> ExtValue {
1427 fir::emitFatalError(
1428 getLoc(),
1429 "array substring should be handled in array expression");
1430 },
1431 [&](const auto &) -> ExtValue {
1432 fir::emitFatalError(getLoc(), "substring base is not a CharBox");
1433 });
1434 }
1435
1436 /// The value of a substring.
1437 ExtValue genval(const Fortran::evaluate::Substring &ss) {
1438 // FIXME: why is the value of a substring being lowered the same as the
1439 // address of a substring?
1440 return gen(ss);
1441 }
1442
1443 ExtValue genval(const Fortran::evaluate::Subscript &subs) {
1444 if (auto *s = std::get_if<Fortran::evaluate::IndirectSubscriptIntegerExpr>(
1445 &subs.u)) {
1446 if (s->value().Rank() > 0)
1447 fir::emitFatalError(getLoc(), "vector subscript is not scalar");
1448 return {genval(s->value())};
1449 }
1450 fir::emitFatalError(getLoc(), "subscript triple notation is not scalar");
1451 }
1452 ExtValue genSubscript(const Fortran::evaluate::Subscript &subs) {
1453 return genval(subs);
1454 }
1455
1456 ExtValue gen(const Fortran::evaluate::DataRef &dref) {
1457 return Fortran::common::visit([&](const auto &x) { return gen(x); },
1458 dref.u);
1459 }
1460 ExtValue genval(const Fortran::evaluate::DataRef &dref) {
1461 return Fortran::common::visit([&](const auto &x) { return genval(x); },
1462 dref.u);
1463 }
1464
1465 // Helper function to turn the Component structure into a list of nested
1466 // components, ordered from largest/leftmost to smallest/rightmost:
1467 // - where only the smallest/rightmost item may be allocatable or a pointer
1468 // (nested allocatable/pointer components require nested coordinate_of ops)
1469 // - that does not contain any parent components
1470 // (the front end places parent components directly in the object)
1471 // Return the object used as the base coordinate for the component chain.
1472 static Fortran::evaluate::DataRef const *
1473 reverseComponents(const Fortran::evaluate::Component &cmpt,
1474 std::list<const Fortran::evaluate::Component *> &list) {
1475 if (!getLastSym(cmpt).test(Fortran::semantics::Symbol::Flag::ParentComp))
1476 list.push_front(&cmpt);
1477 return Fortran::common::visit(
1478 Fortran::common::visitors{
1479 [&](const Fortran::evaluate::Component &x) {
1480 if (Fortran::semantics::IsAllocatableOrPointer(getLastSym(x)))
1481 return &cmpt.base();
1482 return reverseComponents(x, list);
1483 },
1484 [&](auto &) { return &cmpt.base(); },
1485 },
1486 cmpt.base().u);
1487 }
1488
1489 // Return the coordinate of the component reference
1490 ExtValue genComponent(const Fortran::evaluate::Component &cmpt) {
1491 std::list<const Fortran::evaluate::Component *> list;
1492 const Fortran::evaluate::DataRef *base = reverseComponents(cmpt, list);
1493 llvm::SmallVector<mlir::Value> coorArgs;
1494 ExtValue obj = gen(*base);
1495 mlir::Type ty = fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(obj).getType());
1496 mlir::Location loc = getLoc();
1497 auto fldTy = fir::FieldType::get(&converter.getMLIRContext());
1498 // FIXME: need to thread the LEN type parameters here.
1499 for (const Fortran::evaluate::Component *field : list) {
1500 auto recTy = mlir::cast<fir::RecordType>(ty);
1501 const Fortran::semantics::Symbol &sym = getLastSym(*field);
1502 std::string name = converter.getRecordTypeFieldName(sym);
1503 coorArgs.push_back(builder.create<fir::FieldIndexOp>(
1504 loc, fldTy, name, recTy, fir::getTypeParams(obj)));
1505 ty = recTy.getType(name);
1506 }
1507 // If parent component is referred then it has no coordinate argument.
1508 if (coorArgs.size() == 0)
1509 return obj;
1510 ty = builder.getRefType(ty);
1511 return fir::factory::componentToExtendedValue(
1512 builder, loc,
1513 builder.create<fir::CoordinateOp>(loc, ty, fir::getBase(obj),
1514 coorArgs));
1515 }
1516
1517 ExtValue gen(const Fortran::evaluate::Component &cmpt) {
1518 // Components may be pointer or allocatable. In the gen() path, the mutable
1519 // aspect is lost to simplify handling on the client side. To retain the
1520 // mutable aspect, genMutableBoxValue should be used.
1521 return genComponent(cmpt).match(
1522 [&](const fir::MutableBoxValue &mutableBox) {
1523 return fir::factory::genMutableBoxRead(builder, getLoc(), mutableBox);
1524 },
1525 [](auto &box) -> ExtValue { return box; });
1526 }
1527
1528 ExtValue genval(const Fortran::evaluate::Component &cmpt) {
1529 return genLoad(gen(cmpt));
1530 }
1531
1532 // Determine the result type after removing `dims` dimensions from the array
1533 // type `arrTy`
1534 mlir::Type genSubType(mlir::Type arrTy, unsigned dims) {
1535 mlir::Type unwrapTy = fir::dyn_cast_ptrOrBoxEleTy(arrTy);
1536 assert(unwrapTy && "must be a pointer or box type");
1537 auto seqTy = mlir::cast<fir::SequenceType>(unwrapTy);
1538 llvm::ArrayRef<int64_t> shape = seqTy.getShape();
1539 assert(shape.size() > 0 && "removing columns for sequence sans shape");
1540 assert(dims <= shape.size() && "removing more columns than exist");
1541 fir::SequenceType::Shape newBnds;
1542 // follow Fortran semantics and remove columns (from right)
1543 std::size_t e = shape.size() - dims;
1544 for (decltype(e) i = 0; i < e; ++i)
1545 newBnds.push_back(shape[i]);
1546 if (!newBnds.empty())
1547 return fir::SequenceType::get(newBnds, seqTy.getEleTy());
1548 return seqTy.getEleTy();
1549 }
1550
1551 // Generate the code for a Bound value.
1552 ExtValue genval(const Fortran::semantics::Bound &bound) {
1553 if (bound.isExplicit()) {
1554 Fortran::semantics::MaybeSubscriptIntExpr sub = bound.GetExplicit();
1555 if (sub.has_value())
1556 return genval(*sub);
1557 return genIntegerConstant<8>(builder.getContext(), 1);
1558 }
1559 TODO(getLoc(), "non explicit semantics::Bound implementation");
1560 }
1561
1562 static bool isSlice(const Fortran::evaluate::ArrayRef &aref) {
1563 for (const Fortran::evaluate::Subscript &sub : aref.subscript())
1564 if (std::holds_alternative<Fortran::evaluate::Triplet>(sub.u))
1565 return true;
1566 return false;
1567 }
1568
1569 /// Lower an ArrayRef to a fir.coordinate_of given its lowered base.
1570 ExtValue genCoordinateOp(const ExtValue &array,
1571 const Fortran::evaluate::ArrayRef &aref) {
1572 mlir::Location loc = getLoc();
1573 // References to array of rank > 1 with non constant shape that are not
1574 // fir.box must be collapsed into an offset computation in lowering already.
1575 // The same is needed with dynamic length character arrays of all ranks.
1576 mlir::Type baseType =
1577 fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(array).getType());
1578 if ((array.rank() > 1 && fir::hasDynamicSize(baseType)) ||
1579 fir::characterWithDynamicLen(fir::unwrapSequenceType(baseType)))
1580 if (!array.getBoxOf<fir::BoxValue>())
1581 return genOffsetAndCoordinateOp(array, aref);
1582 // Generate a fir.coordinate_of with zero based array indexes.
1583 llvm::SmallVector<mlir::Value> args;
1584 for (const auto &subsc : llvm::enumerate(aref.subscript())) {
1585 ExtValue subVal = genSubscript(subsc.value());
1586 assert(fir::isUnboxedValue(subVal) && "subscript must be simple scalar");
1587 mlir::Value val = fir::getBase(subVal);
1588 mlir::Type ty = val.getType();
1589 mlir::Value lb = getLBound(array, subsc.index(), ty);
1590 args.push_back(builder.create<mlir::arith::SubIOp>(loc, ty, val, lb));
1591 }
1592 mlir::Value base = fir::getBase(array);
1593
1594 auto baseSym = getFirstSym(aref);
1595 if (baseSym.test(Fortran::semantics::Symbol::Flag::CrayPointee)) {
1596 // get the corresponding Cray pointer
1597 Fortran::semantics::SymbolRef ptrSym{
1598 Fortran::semantics::GetCrayPointer(baseSym)};
1599 fir::ExtendedValue ptr = gen(ptrSym);
1600 mlir::Value ptrVal = fir::getBase(ptr);
1601 mlir::Type ptrTy = ptrVal.getType();
1602
1603 mlir::Value cnvrt = Fortran::lower::addCrayPointerInst(
1604 loc, builder, ptrVal, ptrTy, base.getType());
1605 base = builder.create<fir::LoadOp>(loc, cnvrt);
1606 }
1607
1608 mlir::Type eleTy = fir::dyn_cast_ptrOrBoxEleTy(base.getType());
1609 if (auto classTy = mlir::dyn_cast<fir::ClassType>(eleTy))
1610 eleTy = classTy.getEleTy();
1611 auto seqTy = mlir::cast<fir::SequenceType>(eleTy);
1612 assert(args.size() == seqTy.getDimension());
1613 mlir::Type ty = builder.getRefType(seqTy.getEleTy());
1614 auto addr = builder.create<fir::CoordinateOp>(loc, ty, base, args);
1615 return fir::factory::arrayElementToExtendedValue(builder, loc, array, addr);
1616 }
1617
1618 /// Lower an ArrayRef to a fir.coordinate_of using an element offset instead
1619 /// of array indexes.
1620 /// This generates offset computation from the indexes and length parameters,
1621 /// and use the offset to access the element with a fir.coordinate_of. This
1622 /// must only be used if it is not possible to generate a normal
1623 /// fir.coordinate_of using array indexes (i.e. when the shape information is
1624 /// unavailable in the IR).
1625 ExtValue genOffsetAndCoordinateOp(const ExtValue &array,
1626 const Fortran::evaluate::ArrayRef &aref) {
1627 mlir::Location loc = getLoc();
1628 mlir::Value addr = fir::getBase(array);
1629 mlir::Type arrTy = fir::dyn_cast_ptrEleTy(addr.getType());
1630 auto eleTy = mlir::cast<fir::SequenceType>(arrTy).getElementType();
1631 mlir::Type seqTy = builder.getRefType(builder.getVarLenSeqTy(eleTy));
1632 mlir::Type refTy = builder.getRefType(eleTy);
1633 mlir::Value base = builder.createConvert(loc, seqTy, addr);
1634 mlir::IndexType idxTy = builder.getIndexType();
1635 mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
1636 mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0);
1637 auto getLB = [&](const auto &arr, unsigned dim) -> mlir::Value {
1638 return arr.getLBounds().empty() ? one : arr.getLBounds()[dim];
1639 };
1640 auto genFullDim = [&](const auto &arr, mlir::Value delta) -> mlir::Value {
1641 mlir::Value total = zero;
1642 assert(arr.getExtents().size() == aref.subscript().size());
1643 delta = builder.createConvert(loc, idxTy, delta);
1644 unsigned dim = 0;
1645 for (auto [ext, sub] : llvm::zip(arr.getExtents(), aref.subscript())) {
1646 ExtValue subVal = genSubscript(sub);
1647 assert(fir::isUnboxedValue(subVal));
1648 mlir::Value val =
1649 builder.createConvert(loc, idxTy, fir::getBase(subVal));
1650 mlir::Value lb = builder.createConvert(loc, idxTy, getLB(arr, dim));
1651 mlir::Value diff = builder.create<mlir::arith::SubIOp>(loc, val, lb);
1652 mlir::Value prod =
1653 builder.create<mlir::arith::MulIOp>(loc, delta, diff);
1654 total = builder.create<mlir::arith::AddIOp>(loc, prod, total);
1655 if (ext)
1656 delta = builder.create<mlir::arith::MulIOp>(loc, delta, ext);
1657 ++dim;
1658 }
1659 mlir::Type origRefTy = refTy;
1660 if (fir::factory::CharacterExprHelper::isCharacterScalar(refTy)) {
1661 fir::CharacterType chTy =
1662 fir::factory::CharacterExprHelper::getCharacterType(refTy);
1663 if (fir::characterWithDynamicLen(chTy)) {
1664 mlir::MLIRContext *ctx = builder.getContext();
1665 fir::KindTy kind =
1666 fir::factory::CharacterExprHelper::getCharacterKind(chTy);
1667 fir::CharacterType singleTy =
1668 fir::CharacterType::getSingleton(ctx, kind);
1669 refTy = builder.getRefType(singleTy);
1670 mlir::Type seqRefTy =
1671 builder.getRefType(builder.getVarLenSeqTy(singleTy));
1672 base = builder.createConvert(loc, seqRefTy, base);
1673 }
1674 }
1675 auto coor = builder.create<fir::CoordinateOp>(
1676 loc, refTy, base, llvm::ArrayRef<mlir::Value>{total});
1677 // Convert to expected, original type after address arithmetic.
1678 return builder.createConvert(loc, origRefTy, coor);
1679 };
1680 return array.match(
1681 [&](const fir::ArrayBoxValue &arr) -> ExtValue {
1682 // FIXME: this check can be removed when slicing is implemented
1683 if (isSlice(aref))
1684 fir::emitFatalError(
1685 getLoc(),
1686 "slice should be handled in array expression context");
1687 return genFullDim(arr, one);
1688 },
1689 [&](const fir::CharArrayBoxValue &arr) -> ExtValue {
1690 mlir::Value delta = arr.getLen();
1691 // If the length is known in the type, fir.coordinate_of will
1692 // already take the length into account.
1693 if (fir::factory::CharacterExprHelper::hasConstantLengthInType(arr))
1694 delta = one;
1695 return fir::CharBoxValue(genFullDim(arr, delta), arr.getLen());
1696 },
1697 [&](const fir::BoxValue &arr) -> ExtValue {
1698 // CoordinateOp for BoxValue is not generated here. The dimensions
1699 // must be kept in the fir.coordinate_op so that potential fir.box
1700 // strides can be applied by codegen.
1701 fir::emitFatalError(
1702 loc, "internal: BoxValue in dim-collapsed fir.coordinate_of");
1703 },
1704 [&](const auto &) -> ExtValue {
1705 fir::emitFatalError(loc, "internal: array processing failed");
1706 });
1707 }
1708
1709 /// Lower an ArrayRef to a fir.array_coor.
1710 ExtValue genArrayCoorOp(const ExtValue &exv,
1711 const Fortran::evaluate::ArrayRef &aref) {
1712 mlir::Location loc = getLoc();
1713 mlir::Value addr = fir::getBase(exv);
1714 mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(addr.getType());
1715 mlir::Type eleTy = mlir::cast<fir::SequenceType>(arrTy).getElementType();
1716 mlir::Type refTy = builder.getRefType(eleTy);
1717 mlir::IndexType idxTy = builder.getIndexType();
1718 llvm::SmallVector<mlir::Value> arrayCoorArgs;
1719 // The ArrayRef is expected to be scalar here, arrays are handled in array
1720 // expression lowering. So no vector subscript or triplet is expected here.
1721 for (const auto &sub : aref.subscript()) {
1722 ExtValue subVal = genSubscript(sub);
1723 assert(fir::isUnboxedValue(subVal));
1724 arrayCoorArgs.push_back(
1725 builder.createConvert(loc, idxTy, fir::getBase(subVal)));
1726 }
1727 mlir::Value shape = builder.createShape(loc, exv);
1728 mlir::Value elementAddr = builder.create<fir::ArrayCoorOp>(
1729 loc, refTy, addr, shape, /*slice=*/mlir::Value{}, arrayCoorArgs,
1730 fir::getTypeParams(exv));
1731 return fir::factory::arrayElementToExtendedValue(builder, loc, exv,
1732 elementAddr);
1733 }
1734
1735 /// Return the coordinate of the array reference.
1736 ExtValue gen(const Fortran::evaluate::ArrayRef &aref) {
1737 ExtValue base = aref.base().IsSymbol() ? gen(getFirstSym(aref.base()))
1738 : gen(aref.base().GetComponent());
1739 // Check for command-line override to use array_coor op.
1740 if (generateArrayCoordinate)
1741 return genArrayCoorOp(base, aref);
1742 // Otherwise, use coordinate_of op.
1743 return genCoordinateOp(base, aref);
1744 }
1745
1746 /// Return lower bounds of \p box in dimension \p dim. The returned value
1747 /// has type \ty.
1748 mlir::Value getLBound(const ExtValue &box, unsigned dim, mlir::Type ty) {
1749 assert(box.rank() > 0 && "must be an array");
1750 mlir::Location loc = getLoc();
1751 mlir::Value one = builder.createIntegerConstant(loc, ty, 1);
1752 mlir::Value lb = fir::factory::readLowerBound(builder, loc, box, dim, one);
1753 return builder.createConvert(loc, ty, lb);
1754 }
1755
1756 ExtValue genval(const Fortran::evaluate::ArrayRef &aref) {
1757 return genLoad(gen(aref));
1758 }
1759
1760 ExtValue gen(const Fortran::evaluate::CoarrayRef &coref) {
1761 return Fortran::lower::CoarrayExprHelper{converter, getLoc(), symMap}
1762 .genAddr(coref);
1763 }
1764
1765 ExtValue genval(const Fortran::evaluate::CoarrayRef &coref) {
1766 return Fortran::lower::CoarrayExprHelper{converter, getLoc(), symMap}
1767 .genValue(coref);
1768 }
1769
1770 template <typename A>
1771 ExtValue gen(const Fortran::evaluate::Designator<A> &des) {
1772 return Fortran::common::visit([&](const auto &x) { return gen(x); }, des.u);
1773 }
1774 template <typename A>
1775 ExtValue genval(const Fortran::evaluate::Designator<A> &des) {
1776 return Fortran::common::visit([&](const auto &x) { return genval(x); },
1777 des.u);
1778 }
1779
1780 mlir::Type genType(const Fortran::evaluate::DynamicType &dt) {
1781 if (dt.category() != Fortran::common::TypeCategory::Derived)
1782 return converter.genType(dt.category(), dt.kind());
1783 if (dt.IsUnlimitedPolymorphic())
1784 return mlir::NoneType::get(&converter.getMLIRContext());
1785 return converter.genType(dt.GetDerivedTypeSpec());
1786 }
1787
1788 /// Lower a function reference
1789 template <typename A>
1790 ExtValue genFunctionRef(const Fortran::evaluate::FunctionRef<A> &funcRef) {
1791 if (!funcRef.GetType().has_value())
1792 fir::emitFatalError(getLoc(), "a function must have a type");
1793 mlir::Type resTy = genType(*funcRef.GetType());
1794 return genProcedureRef(funcRef, {resTy});
1795 }
1796
1797 /// Lower function call `funcRef` and return a reference to the resultant
1798 /// value. This is required for lowering expressions such as `f1(f2(v))`.
1799 template <typename A>
1800 ExtValue gen(const Fortran::evaluate::FunctionRef<A> &funcRef) {
1801 ExtValue retVal = genFunctionRef(funcRef);
1802 mlir::Type resultType = converter.genType(toEvExpr(funcRef));
1803 return placeScalarValueInMemory(builder, getLoc(), retVal, resultType);
1804 }
1805
1806 /// Helper to lower intrinsic arguments for inquiry intrinsic.
1807 ExtValue
1808 lowerIntrinsicArgumentAsInquired(const Fortran::lower::SomeExpr &expr) {
1809 if (Fortran::evaluate::IsAllocatableOrPointerObject(expr))
1810 return genMutableBoxValue(expr);
1811 /// Do not create temps for array sections whose properties only need to be
1812 /// inquired: create a descriptor that will be inquired.
1813 if (Fortran::evaluate::IsVariable(expr) && isArray(expr) &&
1814 !Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr))
1815 return lowerIntrinsicArgumentAsBox(expr);
1816 return gen(expr);
1817 }
1818
1819 /// Helper to lower intrinsic arguments to a fir::BoxValue.
1820 /// It preserves all the non default lower bounds/non deferred length
1821 /// parameter information.
1822 ExtValue lowerIntrinsicArgumentAsBox(const Fortran::lower::SomeExpr &expr) {
1823 mlir::Location loc = getLoc();
1824 ExtValue exv = genBoxArg(expr);
1825 auto exvTy = fir::getBase(exv).getType();
1826 if (mlir::isa<mlir::FunctionType>(exvTy)) {
1827 auto boxProcTy =
1828 builder.getBoxProcType(mlir::cast<mlir::FunctionType>(exvTy));
1829 return builder.create<fir::EmboxProcOp>(loc, boxProcTy,
1830 fir::getBase(exv));
1831 }
1832 mlir::Value box = builder.createBox(loc, exv, exv.isPolymorphic());
1833 if (Fortran::lower::isParentComponent(expr)) {
1834 fir::ExtendedValue newExv =
1835 Fortran::lower::updateBoxForParentComponent(converter, box, expr);
1836 box = fir::getBase(newExv);
1837 }
1838 return fir::BoxValue(
1839 box, fir::factory::getNonDefaultLowerBounds(builder, loc, exv),
1840 fir::factory::getNonDeferredLenParams(exv));
1841 }
1842
1843 /// Generate a call to a Fortran intrinsic or intrinsic module procedure.
1844 ExtValue genIntrinsicRef(
1845 const Fortran::evaluate::ProcedureRef &procRef,
1846 std::optional<mlir::Type> resultType,
1847 std::optional<const Fortran::evaluate::SpecificIntrinsic> intrinsic =
1848 std::nullopt) {
1849 llvm::SmallVector<ExtValue> operands;
1850
1851 std::string name =
1852 intrinsic ? intrinsic->name
1853 : procRef.proc().GetSymbol()->GetUltimate().name().ToString();
1854 mlir::Location loc = getLoc();
1855 if (intrinsic && Fortran::lower::intrinsicRequiresCustomOptionalHandling(
1856 procRef, *intrinsic, converter)) {
1857 using ExvAndPresence = std::pair<ExtValue, std::optional<mlir::Value>>;
1858 llvm::SmallVector<ExvAndPresence, 4> operands;
1859 auto prepareOptionalArg = [&](const Fortran::lower::SomeExpr &expr) {
1860 ExtValue optionalArg = lowerIntrinsicArgumentAsInquired(expr);
1861 mlir::Value isPresent =
1862 genActualIsPresentTest(builder, loc, optionalArg);
1863 operands.emplace_back(optionalArg, isPresent);
1864 };
1865 auto prepareOtherArg = [&](const Fortran::lower::SomeExpr &expr,
1866 fir::LowerIntrinsicArgAs lowerAs) {
1867 switch (lowerAs) {
1868 case fir::LowerIntrinsicArgAs::Value:
1869 operands.emplace_back(genval(expr), std::nullopt);
1870 return;
1871 case fir::LowerIntrinsicArgAs::Addr:
1872 operands.emplace_back(gen(expr), std::nullopt);
1873 return;
1874 case fir::LowerIntrinsicArgAs::Box:
1875 operands.emplace_back(lowerIntrinsicArgumentAsBox(expr),
1876 std::nullopt);
1877 return;
1878 case fir::LowerIntrinsicArgAs::Inquired:
1879 operands.emplace_back(lowerIntrinsicArgumentAsInquired(expr),
1880 std::nullopt);
1881 return;
1882 }
1883 };
1884 Fortran::lower::prepareCustomIntrinsicArgument(
1885 procRef, *intrinsic, resultType, prepareOptionalArg, prepareOtherArg,
1886 converter);
1887
1888 auto getArgument = [&](std::size_t i, bool loadArg) -> ExtValue {
1889 if (loadArg && fir::conformsWithPassByRef(
1890 fir::getBase(operands[i].first).getType()))
1891 return genLoad(operands[i].first);
1892 return operands[i].first;
1893 };
1894 auto isPresent = [&](std::size_t i) -> std::optional<mlir::Value> {
1895 return operands[i].second;
1896 };
1897 return Fortran::lower::lowerCustomIntrinsic(
1898 builder, loc, name, resultType, isPresent, getArgument,
1899 operands.size(), stmtCtx);
1900 }
1901
1902 const fir::IntrinsicArgumentLoweringRules *argLowering =
1903 fir::getIntrinsicArgumentLowering(name);
1904 for (const auto &arg : llvm::enumerate(procRef.arguments())) {
1905 auto *expr =
1906 Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
1907
1908 if (!expr && arg.value() && arg.value()->GetAssumedTypeDummy()) {
1909 // Assumed type optional.
1910 const Fortran::evaluate::Symbol *assumedTypeSym =
1911 arg.value()->GetAssumedTypeDummy();
1912 auto symBox = symMap.lookupSymbol(*assumedTypeSym);
1913 ExtValue exv =
1914 converter.getSymbolExtendedValue(*assumedTypeSym, &symMap);
1915 if (argLowering) {
1916 fir::ArgLoweringRule argRules =
1917 fir::lowerIntrinsicArgumentAs(*argLowering, arg.index());
1918 // Note: usages of TYPE(*) is limited by C710 but C_LOC and
1919 // IS_CONTIGUOUS may require an assumed size TYPE(*) to be passed to
1920 // the intrinsic library utility as a fir.box.
1921 if (argRules.lowerAs == fir::LowerIntrinsicArgAs::Box &&
1922 !mlir::isa<fir::BaseBoxType>(fir::getBase(exv).getType())) {
1923 operands.emplace_back(
1924 fir::factory::createBoxValue(builder, loc, exv));
1925 continue;
1926 }
1927 }
1928 operands.emplace_back(std::move(exv));
1929 continue;
1930 }
1931 if (!expr) {
1932 // Absent optional.
1933 operands.emplace_back(fir::getAbsentIntrinsicArgument());
1934 continue;
1935 }
1936 if (!argLowering) {
1937 // No argument lowering instruction, lower by value.
1938 operands.emplace_back(genval(*expr));
1939 continue;
1940 }
1941 // Ad-hoc argument lowering handling.
1942 fir::ArgLoweringRule argRules =
1943 fir::lowerIntrinsicArgumentAs(*argLowering, arg.index());
1944 if (argRules.handleDynamicOptional &&
1945 Fortran::evaluate::MayBePassedAsAbsentOptional(*expr)) {
1946 ExtValue optional = lowerIntrinsicArgumentAsInquired(*expr);
1947 mlir::Value isPresent = genActualIsPresentTest(builder, loc, optional);
1948 switch (argRules.lowerAs) {
1949 case fir::LowerIntrinsicArgAs::Value:
1950 operands.emplace_back(
1951 genOptionalValue(builder, loc, optional, isPresent));
1952 continue;
1953 case fir::LowerIntrinsicArgAs::Addr:
1954 operands.emplace_back(
1955 genOptionalAddr(builder, loc, optional, isPresent));
1956 continue;
1957 case fir::LowerIntrinsicArgAs::Box:
1958 operands.emplace_back(
1959 genOptionalBox(builder, loc, optional, isPresent));
1960 continue;
1961 case fir::LowerIntrinsicArgAs::Inquired:
1962 operands.emplace_back(optional);
1963 continue;
1964 }
1965 llvm_unreachable("bad switch");
1966 }
1967 switch (argRules.lowerAs) {
1968 case fir::LowerIntrinsicArgAs::Value:
1969 operands.emplace_back(genval(*expr));
1970 continue;
1971 case fir::LowerIntrinsicArgAs::Addr:
1972 operands.emplace_back(gen(*expr));
1973 continue;
1974 case fir::LowerIntrinsicArgAs::Box:
1975 operands.emplace_back(lowerIntrinsicArgumentAsBox(*expr));
1976 continue;
1977 case fir::LowerIntrinsicArgAs::Inquired:
1978 operands.emplace_back(lowerIntrinsicArgumentAsInquired(*expr));
1979 continue;
1980 }
1981 llvm_unreachable("bad switch");
1982 }
1983 // Let the intrinsic library lower the intrinsic procedure call
1984 return Fortran::lower::genIntrinsicCall(builder, getLoc(), name, resultType,
1985 operands, stmtCtx, &converter);
1986 }
1987
1988 /// helper to detect statement functions
1989 static bool
1990 isStatementFunctionCall(const Fortran::evaluate::ProcedureRef &procRef) {
1991 if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())
1992 if (const auto *details =
1993 symbol->detailsIf<Fortran::semantics::SubprogramDetails>())
1994 return details->stmtFunction().has_value();
1995 return false;
1996 }
1997
1998 /// Generate Statement function calls
1999 ExtValue genStmtFunctionRef(const Fortran::evaluate::ProcedureRef &procRef) {
2000 const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol();
2001 assert(symbol && "expected symbol in ProcedureRef of statement functions");
2002 const auto &details = symbol->get<Fortran::semantics::SubprogramDetails>();
2003
2004 // Statement functions have their own scope, we just need to associate
2005 // the dummy symbols to argument expressions. They are no
2006 // optional/alternate return arguments. Statement functions cannot be
2007 // recursive (directly or indirectly) so it is safe to add dummy symbols to
2008 // the local map here.
2009 symMap.pushScope();
2010 for (auto [arg, bind] :
2011 llvm::zip(details.dummyArgs(), procRef.arguments())) {
2012 assert(arg && "alternate return in statement function");
2013 assert(bind && "optional argument in statement function");
2014 const auto *expr = bind->UnwrapExpr();
2015 // TODO: assumed type in statement function, that surprisingly seems
2016 // allowed, probably because nobody thought of restricting this usage.
2017 // gfortran/ifort compiles this.
2018 assert(expr && "assumed type used as statement function argument");
2019 // As per Fortran 2018 C1580, statement function arguments can only be
2020 // scalars, so just pass the box with the address. The only care is to
2021 // to use the dummy character explicit length if any instead of the
2022 // actual argument length (that can be bigger).
2023 if (const Fortran::semantics::DeclTypeSpec *type = arg->GetType())
2024 if (type->category() == Fortran::semantics::DeclTypeSpec::Character)
2025 if (const Fortran::semantics::MaybeIntExpr &lenExpr =
2026 type->characterTypeSpec().length().GetExplicit()) {
2027 mlir::Value len = fir::getBase(genval(*lenExpr));
2028 // F2018 7.4.4.2 point 5.
2029 len = fir::factory::genMaxWithZero(builder, getLoc(), len);
2030 symMap.addSymbol(*arg,
2031 replaceScalarCharacterLength(gen(*expr), len));
2032 continue;
2033 }
2034 symMap.addSymbol(*arg, gen(*expr));
2035 }
2036
2037 // Explicitly map statement function host associated symbols to their
2038 // parent scope lowered symbol box.
2039 for (const Fortran::semantics::SymbolRef &sym :
2040 Fortran::evaluate::CollectSymbols(*details.stmtFunction()))
2041 if (const auto *details =
2042 sym->detailsIf<Fortran::semantics::HostAssocDetails>())
2043 if (!symMap.lookupSymbol(*sym))
2044 symMap.addSymbol(*sym, gen(details->symbol()));
2045
2046 ExtValue result = genval(details.stmtFunction().value());
2047 LLVM_DEBUG(llvm::dbgs() << "stmt-function: " << result << '\n');
2048 symMap.popScope();
2049 return result;
2050 }
2051
2052 /// Create a contiguous temporary array with the same shape,
2053 /// length parameters and type as mold. It is up to the caller to deallocate
2054 /// the temporary.
2055 ExtValue genArrayTempFromMold(const ExtValue &mold,
2056 llvm::StringRef tempName) {
2057 mlir::Type type = fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(mold).getType());
2058 assert(type && "expected descriptor or memory type");
2059 mlir::Location loc = getLoc();
2060 llvm::SmallVector<mlir::Value> extents =
2061 fir::factory::getExtents(loc, builder, mold);
2062 llvm::SmallVector<mlir::Value> allocMemTypeParams =
2063 fir::getTypeParams(mold);
2064 mlir::Value charLen;
2065 mlir::Type elementType = fir::unwrapSequenceType(type);
2066 if (auto charType = mlir::dyn_cast<fir::CharacterType>(elementType)) {
2067 charLen = allocMemTypeParams.empty()
2068 ? fir::factory::readCharLen(builder, loc, mold)
2069 : allocMemTypeParams[0];
2070 if (charType.hasDynamicLen() && allocMemTypeParams.empty())
2071 allocMemTypeParams.push_back(charLen);
2072 } else if (fir::hasDynamicSize(elementType)) {
2073 TODO(loc, "creating temporary for derived type with length parameters");
2074 }
2075
2076 mlir::Value temp = builder.create<fir::AllocMemOp>(
2077 loc, type, tempName, allocMemTypeParams, extents);
2078 if (mlir::isa<fir::CharacterType>(fir::unwrapSequenceType(type)))
2079 return fir::CharArrayBoxValue{temp, charLen, extents};
2080 return fir::ArrayBoxValue{temp, extents};
2081 }
2082
2083 /// Copy \p source array into \p dest array. Both arrays must be
2084 /// conforming, but neither array must be contiguous.
2085 void genArrayCopy(ExtValue dest, ExtValue source) {
2086 return createSomeArrayAssignment(converter, dest, source, symMap, stmtCtx);
2087 }
2088
2089 /// Lower a non-elemental procedure reference and read allocatable and pointer
2090 /// results into normal values.
2091 ExtValue genProcedureRef(const Fortran::evaluate::ProcedureRef &procRef,
2092 std::optional<mlir::Type> resultType) {
2093 ExtValue res = genRawProcedureRef(procRef, resultType);
2094 // In most contexts, pointers and allocatable do not appear as allocatable
2095 // or pointer variable on the caller side (see 8.5.3 note 1 for
2096 // allocatables). The few context where this can happen must call
2097 // genRawProcedureRef directly.
2098 if (const auto *box = res.getBoxOf<fir::MutableBoxValue>())
2099 return fir::factory::genMutableBoxRead(builder, getLoc(), *box);
2100 return res;
2101 }
2102
2103 /// Like genExtAddr, but ensure the address returned is a temporary even if \p
2104 /// expr is variable inside parentheses.
2105 ExtValue genTempExtAddr(const Fortran::lower::SomeExpr &expr) {
2106 // In general, genExtAddr might not create a temp for variable inside
2107 // parentheses to avoid creating array temporary in sub-expressions. It only
2108 // ensures the sub-expression is not re-associated with other parts of the
2109 // expression. In the call semantics, there is a difference between expr and
2110 // variable (see R1524). For expressions, a variable storage must not be
2111 // argument associated since it could be modified inside the call, or the
2112 // variable could also be modified by other means during the call.
2113 if (!isParenthesizedVariable(expr))
2114 return genExtAddr(expr);
2115 if (expr.Rank() > 0)
2116 return asArray(expr);
2117 mlir::Location loc = getLoc();
2118 return genExtValue(expr).match(
2119 [&](const fir::CharBoxValue &boxChar) -> ExtValue {
2120 return fir::factory::CharacterExprHelper{builder, loc}.createTempFrom(
2121 boxChar);
2122 },
2123 [&](const fir::UnboxedValue &v) -> ExtValue {
2124 mlir::Type type = v.getType();
2125 mlir::Value value = v;
2126 if (fir::isa_ref_type(type))
2127 value = builder.create<fir::LoadOp>(loc, value);
2128 mlir::Value temp = builder.createTemporary(loc, value.getType());
2129 builder.create<fir::StoreOp>(loc, value, temp);
2130 return temp;
2131 },
2132 [&](const fir::BoxValue &x) -> ExtValue {
2133 // Derived type scalar that may be polymorphic.
2134 if (fir::isPolymorphicType(fir::getBase(x).getType()))
2135 TODO(loc, "polymorphic array temporary");
2136 assert(!x.hasRank() && x.isDerived());
2137 if (x.isDerivedWithLenParameters())
2138 fir::emitFatalError(
2139 loc, "making temps for derived type with length parameters");
2140 // TODO: polymorphic aspects should be kept but for now the temp
2141 // created always has the declared type.
2142 mlir::Value var =
2143 fir::getBase(fir::factory::readBoxValue(builder, loc, x));
2144 auto value = builder.create<fir::LoadOp>(loc, var);
2145 mlir::Value temp = builder.createTemporary(loc, value.getType());
2146 builder.create<fir::StoreOp>(loc, value, temp);
2147 return temp;
2148 },
2149 [&](const fir::PolymorphicValue &p) -> ExtValue {
2150 TODO(loc, "creating polymorphic temporary");
2151 },
2152 [&](const auto &) -> ExtValue {
2153 fir::emitFatalError(loc, "expr is not a scalar value");
2154 });
2155 }
2156
2157 /// Helper structure to track potential copy-in of non contiguous variable
2158 /// argument into a contiguous temp. It is used to deallocate the temp that
2159 /// may have been created as well as to the copy-out from the temp to the
2160 /// variable after the call.
2161 struct CopyOutPair {
2162 ExtValue var;
2163 ExtValue temp;
2164 // Flag to indicate if the argument may have been modified by the
2165 // callee, in which case it must be copied-out to the variable.
2166 bool argMayBeModifiedByCall;
2167 // Optional boolean value that, if present and false, prevents
2168 // the copy-out and temp deallocation.
2169 std::optional<mlir::Value> restrictCopyAndFreeAtRuntime;
2170 };
2171 using CopyOutPairs = llvm::SmallVector<CopyOutPair, 4>;
2172
2173 /// Helper to read any fir::BoxValue into other fir::ExtendedValue categories
2174 /// not based on fir.box.
2175 /// This will lose any non contiguous stride information and dynamic type and
2176 /// should only be called if \p exv is known to be contiguous or if its base
2177 /// address will be replaced by a contiguous one. If \p exv is not a
2178 /// fir::BoxValue, this is a no-op.
2179 ExtValue readIfBoxValue(const ExtValue &exv) {
2180 if (const auto *box = exv.getBoxOf<fir::BoxValue>())
2181 return fir::factory::readBoxValue(builder, getLoc(), *box);
2182 return exv;
2183 }
2184
2185 /// Generate a contiguous temp to pass \p actualArg as argument \p arg. The
2186 /// creation of the temp and copy-in can be made conditional at runtime by
2187 /// providing a runtime boolean flag \p restrictCopyAtRuntime (in which case
2188 /// the temp and copy will only be made if the value is true at runtime).
2189 ExtValue genCopyIn(const ExtValue &actualArg,
2190 const Fortran::lower::CallerInterface::PassedEntity &arg,
2191 CopyOutPairs &copyOutPairs,
2192 std::optional<mlir::Value> restrictCopyAtRuntime,
2193 bool byValue) {
2194 const bool doCopyOut = !byValue && arg.mayBeModifiedByCall();
2195 llvm::StringRef tempName = byValue ? ".copy" : ".copyinout";
2196 mlir::Location loc = getLoc();
2197 bool isActualArgBox = fir::isa_box_type(fir::getBase(actualArg).getType());
2198 mlir::Value isContiguousResult;
2199 mlir::Type addrType = fir::HeapType::get(
2200 fir::unwrapPassByRefType(fir::getBase(actualArg).getType()));
2201
2202 if (isActualArgBox) {
2203 // Check at runtime if the argument is contiguous so no copy is needed.
2204 isContiguousResult =
2205 fir::runtime::genIsContiguous(builder, loc, fir::getBase(actualArg));
2206 }
2207
2208 auto doCopyIn = [&]() -> ExtValue {
2209 ExtValue temp = genArrayTempFromMold(actualArg, tempName);
2210 if (!arg.mayBeReadByCall() &&
2211 // INTENT(OUT) dummy argument finalization, automatically
2212 // done when the procedure is invoked, may imply reading
2213 // the argument value in the finalization routine.
2214 // So we need to make a copy, if finalization may occur.
2215 // TODO: do we have to avoid the copying for an actual
2216 // argument of type that does not require finalization?
2217 !arg.mayRequireIntentoutFinalization() &&
2218 // ALLOCATABLE dummy argument may require finalization.
2219 // If it has to be automatically deallocated at the end
2220 // of the procedure invocation (9.7.3.2 p. 2),
2221 // then the finalization may happen if the actual argument
2222 // is allocated (7.5.6.3 p. 2).
2223 !arg.hasAllocatableAttribute()) {
2224 // We have to initialize the temp if it may have components
2225 // that need initialization. If there are no components
2226 // requiring initialization, then the call is a no-op.
2227 if (mlir::isa<fir::RecordType>(getElementTypeOf(temp))) {
2228 mlir::Value tempBox = fir::getBase(builder.createBox(loc, temp));
2229 fir::runtime::genDerivedTypeInitialize(builder, loc, tempBox);
2230 }
2231 return temp;
2232 }
2233 if (!isActualArgBox || inlineCopyInOutForBoxes) {
2234 genArrayCopy(temp, actualArg);
2235 return temp;
2236 }
2237
2238 // Generate AssignTemporary() call to copy data from the actualArg
2239 // to a temporary. AssignTemporary() will initialize the temporary,
2240 // if needed, before doing the assignment, which is required
2241 // since the temporary's components (if any) are uninitialized
2242 // at this point.
2243 mlir::Value destBox = fir::getBase(builder.createBox(loc, temp));
2244 mlir::Value boxRef = builder.createTemporary(loc, destBox.getType());
2245 builder.create<fir::StoreOp>(loc, destBox, boxRef);
2246 fir::runtime::genAssignTemporary(builder, loc, boxRef,
2247 fir::getBase(actualArg));
2248 return temp;
2249 };
2250
2251 auto noCopy = [&]() {
2252 mlir::Value box = fir::getBase(actualArg);
2253 mlir::Value boxAddr = builder.create<fir::BoxAddrOp>(loc, addrType, box);
2254 builder.create<fir::ResultOp>(loc, boxAddr);
2255 };
2256
2257 auto combinedCondition = [&]() {
2258 if (isActualArgBox) {
2259 mlir::Value zero =
2260 builder.createIntegerConstant(loc, builder.getI1Type(), 0);
2261 mlir::Value notContiguous = builder.create<mlir::arith::CmpIOp>(
2262 loc, mlir::arith::CmpIPredicate::eq, isContiguousResult, zero);
2263 if (!restrictCopyAtRuntime) {
2264 restrictCopyAtRuntime = notContiguous;
2265 } else {
2266 mlir::Value cond = builder.create<mlir::arith::AndIOp>(
2267 loc, *restrictCopyAtRuntime, notContiguous);
2268 restrictCopyAtRuntime = cond;
2269 }
2270 }
2271 };
2272
2273 if (!restrictCopyAtRuntime) {
2274 if (isActualArgBox) {
2275 // isContiguousResult = genIsContiguousCall();
2276 mlir::Value addr =
2277 builder
2278 .genIfOp(loc, {addrType}, isContiguousResult,
2279 /*withElseRegion=*/true)
2280 .genThen([&]() { noCopy(); })
2281 .genElse([&] {
2282 ExtValue temp = doCopyIn();
2283 builder.create<fir::ResultOp>(loc, fir::getBase(temp));
2284 })
2285 .getResults()[0];
2286 fir::ExtendedValue temp =
2287 fir::substBase(readIfBoxValue(actualArg), addr);
2288 combinedCondition();
2289 copyOutPairs.emplace_back(
2290 Args: CopyOutPair{actualArg, temp, doCopyOut, restrictCopyAtRuntime});
2291 return temp;
2292 }
2293
2294 ExtValue temp = doCopyIn();
2295 copyOutPairs.emplace_back(Args: CopyOutPair{actualArg, temp, doCopyOut, {}});
2296 return temp;
2297 }
2298
2299 // Otherwise, need to be careful to only copy-in if allowed at runtime.
2300 mlir::Value addr =
2301 builder
2302 .genIfOp(loc, {addrType}, *restrictCopyAtRuntime,
2303 /*withElseRegion=*/true)
2304 .genThen([&]() {
2305 if (isActualArgBox) {
2306 // isContiguousResult = genIsContiguousCall();
2307 // Avoid copyin if the argument is contiguous at runtime.
2308 mlir::Value addr1 =
2309 builder
2310 .genIfOp(loc, {addrType}, isContiguousResult,
2311 /*withElseRegion=*/true)
2312 .genThen([&]() { noCopy(); })
2313 .genElse([&]() {
2314 ExtValue temp = doCopyIn();
2315 builder.create<fir::ResultOp>(loc,
2316 fir::getBase(temp));
2317 })
2318 .getResults()[0];
2319 builder.create<fir::ResultOp>(loc, addr1);
2320 } else {
2321 ExtValue temp = doCopyIn();
2322 builder.create<fir::ResultOp>(loc, fir::getBase(temp));
2323 }
2324 })
2325 .genElse([&]() {
2326 mlir::Value nullPtr = builder.createNullConstant(loc, addrType);
2327 builder.create<fir::ResultOp>(loc, nullPtr);
2328 })
2329 .getResults()[0];
2330 // Associate the temp address with actualArg lengths and extents if a
2331 // temporary is generated. Otherwise the same address is associated.
2332 fir::ExtendedValue temp = fir::substBase(readIfBoxValue(actualArg), addr);
2333 combinedCondition();
2334 copyOutPairs.emplace_back(
2335 Args: CopyOutPair{actualArg, temp, doCopyOut, restrictCopyAtRuntime});
2336 return temp;
2337 }
2338
2339 /// Generate copy-out if needed and free the temporary for an argument that
2340 /// has been copied-in into a contiguous temp.
2341 void genCopyOut(const CopyOutPair &copyOutPair) {
2342 mlir::Location loc = getLoc();
2343 bool isActualArgBox =
2344 fir::isa_box_type(fir::getBase(copyOutPair.var).getType());
2345 auto doCopyOut = [&]() {
2346 if (!isActualArgBox || inlineCopyInOutForBoxes) {
2347 if (copyOutPair.argMayBeModifiedByCall)
2348 genArrayCopy(copyOutPair.var, copyOutPair.temp);
2349 if (mlir::isa<fir::RecordType>(
2350 fir::getElementTypeOf(copyOutPair.temp))) {
2351 // Destroy components of the temporary (if any).
2352 // If there are no components requiring destruction, then the call
2353 // is a no-op.
2354 mlir::Value tempBox =
2355 fir::getBase(builder.createBox(loc, copyOutPair.temp));
2356 fir::runtime::genDerivedTypeDestroyWithoutFinalization(builder, loc,
2357 tempBox);
2358 }
2359 // Deallocate the top-level entity of the temporary.
2360 builder.create<fir::FreeMemOp>(loc, fir::getBase(copyOutPair.temp));
2361 return;
2362 }
2363 // Generate CopyOutAssign() call to copy data from the temporary
2364 // to the actualArg. Note that in case the actual argument
2365 // is ALLOCATABLE/POINTER the CopyOutAssign() implementation
2366 // should not engage its reallocation, because the temporary
2367 // is rank, shape and type compatible with it.
2368 // Moreover, CopyOutAssign() guarantees that there will be no
2369 // finalization for the LHS even if it is of a derived type
2370 // with finalization.
2371
2372 // Create allocatable descriptor for the temp so that the runtime may
2373 // deallocate it.
2374 mlir::Value srcBox =
2375 fir::getBase(builder.createBox(loc, copyOutPair.temp));
2376 mlir::Type allocBoxTy =
2377 mlir::cast<fir::BaseBoxType>(srcBox.getType())
2378 .getBoxTypeWithNewAttr(fir::BaseBoxType::Attribute::Allocatable);
2379 srcBox = builder.create<fir::ReboxOp>(loc, allocBoxTy, srcBox,
2380 /*shift=*/mlir::Value{},
2381 /*slice=*/mlir::Value{});
2382 mlir::Value srcBoxRef = builder.createTemporary(loc, srcBox.getType());
2383 builder.create<fir::StoreOp>(loc, srcBox, srcBoxRef);
2384 // Create descriptor pointer to variable descriptor if copy out is needed,
2385 // and nullptr otherwise.
2386 mlir::Value destBoxRef;
2387 if (copyOutPair.argMayBeModifiedByCall) {
2388 mlir::Value destBox =
2389 fir::getBase(builder.createBox(loc, copyOutPair.var));
2390 destBoxRef = builder.createTemporary(loc, destBox.getType());
2391 builder.create<fir::StoreOp>(loc, destBox, destBoxRef);
2392 } else {
2393 destBoxRef = builder.create<fir::ZeroOp>(loc, srcBoxRef.getType());
2394 }
2395 fir::runtime::genCopyOutAssign(builder, loc, destBoxRef, srcBoxRef);
2396 };
2397
2398 if (!copyOutPair.restrictCopyAndFreeAtRuntime)
2399 doCopyOut();
2400 else
2401 builder.genIfThen(loc, *copyOutPair.restrictCopyAndFreeAtRuntime)
2402 .genThen([&]() { doCopyOut(); })
2403 .end();
2404 }
2405
2406 /// Lower a designator to a variable that may be absent at runtime into an
2407 /// ExtendedValue where all the properties (base address, shape and length
2408 /// parameters) can be safely read (set to zero if not present). It also
2409 /// returns a boolean mlir::Value telling if the variable is present at
2410 /// runtime.
2411 /// This is useful to later be able to do conditional copy-in/copy-out
2412 /// or to retrieve the base address without having to deal with the case
2413 /// where the actual may be an absent fir.box.
2414 std::pair<ExtValue, mlir::Value>
2415 prepareActualThatMayBeAbsent(const Fortran::lower::SomeExpr &expr) {
2416 mlir::Location loc = getLoc();
2417 if (Fortran::evaluate::IsAllocatableOrPointerObject(expr)) {
2418 // Fortran 2018 15.5.2.12 point 1: If unallocated/disassociated,
2419 // it is as if the argument was absent. The main care here is to
2420 // not do a copy-in/copy-out because the temp address, even though
2421 // pointing to a null size storage, would not be a nullptr and
2422 // therefore the argument would not be considered absent on the
2423 // callee side. Note: if wholeSymbol is optional, it cannot be
2424 // absent as per 15.5.2.12 point 7. and 8. We rely on this to
2425 // un-conditionally read the allocatable/pointer descriptor here.
2426 fir::MutableBoxValue mutableBox = genMutableBoxValue(expr);
2427 mlir::Value isPresent = fir::factory::genIsAllocatedOrAssociatedTest(
2428 builder, loc, mutableBox);
2429 fir::ExtendedValue actualArg =
2430 fir::factory::genMutableBoxRead(builder, loc, mutableBox);
2431 return {actualArg, isPresent};
2432 }
2433 // Absent descriptor cannot be read. To avoid any issue in
2434 // copy-in/copy-out, and when retrieving the address/length
2435 // create an descriptor pointing to a null address here if the
2436 // fir.box is absent.
2437 ExtValue actualArg = gen(expr);
2438 mlir::Value actualArgBase = fir::getBase(actualArg);
2439 mlir::Value isPresent = builder.create<fir::IsPresentOp>(
2440 loc, builder.getI1Type(), actualArgBase);
2441 if (!mlir::isa<fir::BoxType>(actualArgBase.getType()))
2442 return {actualArg, isPresent};
2443 ExtValue safeToReadBox =
2444 absentBoxToUnallocatedBox(builder, loc, actualArg, isPresent);
2445 return {safeToReadBox, isPresent};
2446 }
2447
2448 /// Create a temp on the stack for scalar actual arguments that may be absent
2449 /// at runtime, but must be passed via a temp if they are presents.
2450 fir::ExtendedValue
2451 createScalarTempForArgThatMayBeAbsent(ExtValue actualArg,
2452 mlir::Value isPresent) {
2453 mlir::Location loc = getLoc();
2454 mlir::Type type = fir::unwrapRefType(fir::getBase(actualArg).getType());
2455 if (fir::isDerivedWithLenParameters(actualArg))
2456 TODO(loc, "parametrized derived type optional scalar argument copy-in");
2457 if (const fir::CharBoxValue *charBox = actualArg.getCharBox()) {
2458 mlir::Value len = charBox->getLen();
2459 mlir::Value zero = builder.createIntegerConstant(loc, len.getType(), 0);
2460 len = builder.create<mlir::arith::SelectOp>(loc, isPresent, len, zero);
2461 mlir::Value temp =
2462 builder.createTemporary(loc, type, /*name=*/{},
2463 /*shape=*/{}, mlir::ValueRange{len},
2464 llvm::ArrayRef<mlir::NamedAttribute>{
2465 fir::getAdaptToByRefAttr(builder)});
2466 return fir::CharBoxValue{temp, len};
2467 }
2468 assert((fir::isa_trivial(type) || mlir::isa<fir::RecordType>(type)) &&
2469 "must be simple scalar");
2470 return builder.createTemporary(loc, type,
2471 llvm::ArrayRef<mlir::NamedAttribute>{
2472 fir::getAdaptToByRefAttr(builder)});
2473 }
2474
2475 template <typename A>
2476 bool isCharacterType(const A &exp) {
2477 if (auto type = exp.GetType())
2478 return type->category() == Fortran::common::TypeCategory::Character;
2479 return false;
2480 }
2481
2482 /// Lower an actual argument that must be passed via an address.
2483 /// This generates of the copy-in/copy-out if the actual is not contiguous, or
2484 /// the creation of the temp if the actual is a variable and \p byValue is
2485 /// true. It handles the cases where the actual may be absent, and all of the
2486 /// copying has to be conditional at runtime.
2487 /// If the actual argument may be dynamically absent, return an additional
2488 /// boolean mlir::Value that if true means that the actual argument is
2489 /// present.
2490 std::pair<ExtValue, std::optional<mlir::Value>>
2491 prepareActualToBaseAddressLike(
2492 const Fortran::lower::SomeExpr &expr,
2493 const Fortran::lower::CallerInterface::PassedEntity &arg,
2494 CopyOutPairs &copyOutPairs, bool byValue) {
2495 mlir::Location loc = getLoc();
2496 const bool isArray = expr.Rank() > 0;
2497 const bool actualArgIsVariable = Fortran::evaluate::IsVariable(expr);
2498 // It must be possible to modify VALUE arguments on the callee side, even
2499 // if the actual argument is a literal or named constant. Hence, the
2500 // address of static storage must not be passed in that case, and a copy
2501 // must be made even if this is not a variable.
2502 // Note: isArray should be used here, but genBoxArg already creates copies
2503 // for it, so do not duplicate the copy until genBoxArg behavior is changed.
2504 const bool isStaticConstantByValue =
2505 byValue && Fortran::evaluate::IsActuallyConstant(expr) &&
2506 (isCharacterType(expr));
2507 const bool variableNeedsCopy =
2508 actualArgIsVariable &&
2509 (byValue || (isArray && !Fortran::evaluate::IsSimplyContiguous(
2510 expr, converter.getFoldingContext())));
2511 const bool needsCopy = isStaticConstantByValue || variableNeedsCopy;
2512 auto [argAddr, isPresent] =
2513 [&]() -> std::pair<ExtValue, std::optional<mlir::Value>> {
2514 if (!actualArgIsVariable && !needsCopy)
2515 // Actual argument is not a variable. Make sure a variable address is
2516 // not passed.
2517 return {genTempExtAddr(expr), std::nullopt};
2518 ExtValue baseAddr;
2519 if (arg.isOptional() &&
2520 Fortran::evaluate::MayBePassedAsAbsentOptional(expr)) {
2521 auto [actualArgBind, isPresent] = prepareActualThatMayBeAbsent(expr);
2522 const ExtValue &actualArg = actualArgBind;
2523 if (!needsCopy)
2524 return {actualArg, isPresent};
2525
2526 if (isArray)
2527 return {genCopyIn(actualArg, arg, copyOutPairs, isPresent, byValue),
2528 isPresent};
2529 // Scalars, create a temp, and use it conditionally at runtime if
2530 // the argument is present.
2531 ExtValue temp =
2532 createScalarTempForArgThatMayBeAbsent(actualArg, isPresent);
2533 mlir::Type tempAddrTy = fir::getBase(temp).getType();
2534 mlir::Value selectAddr =
2535 builder
2536 .genIfOp(loc, {tempAddrTy}, isPresent,
2537 /*withElseRegion=*/true)
2538 .genThen([&]() {
2539 fir::factory::genScalarAssignment(builder, loc, temp,
2540 actualArg);
2541 builder.create<fir::ResultOp>(loc, fir::getBase(temp));
2542 })
2543 .genElse([&]() {
2544 mlir::Value absent =
2545 builder.create<fir::AbsentOp>(loc, tempAddrTy);
2546 builder.create<fir::ResultOp>(loc, absent);
2547 })
2548 .getResults()[0];
2549 return {fir::substBase(temp, selectAddr), isPresent};
2550 }
2551 // Actual cannot be absent, the actual argument can safely be
2552 // copied-in/copied-out without any care if needed.
2553 if (isArray) {
2554 ExtValue box = genBoxArg(expr);
2555 if (needsCopy)
2556 return {genCopyIn(box, arg, copyOutPairs,
2557 /*restrictCopyAtRuntime=*/std::nullopt, byValue),
2558 std::nullopt};
2559 // Contiguous: just use the box we created above!
2560 // This gets "unboxed" below, if needed.
2561 return {box, std::nullopt};
2562 }
2563 // Actual argument is a non-optional, non-pointer, non-allocatable
2564 // scalar.
2565 ExtValue actualArg = genExtAddr(expr);
2566 if (needsCopy)
2567 return {createInMemoryScalarCopy(builder, loc, actualArg),
2568 std::nullopt};
2569 return {actualArg, std::nullopt};
2570 }();
2571 // Scalar and contiguous expressions may be lowered to a fir.box,
2572 // either to account for potential polymorphism, or because lowering
2573 // did not account for some contiguity hints.
2574 // Here, polymorphism does not matter (an entity of the declared type
2575 // is passed, not one of the dynamic type), and the expr is known to
2576 // be simply contiguous, so it is safe to unbox it and pass the
2577 // address without making a copy.
2578 return {readIfBoxValue(argAddr), isPresent};
2579 }
2580
2581 /// Lower a non-elemental procedure reference.
2582 ExtValue genRawProcedureRef(const Fortran::evaluate::ProcedureRef &procRef,
2583 std::optional<mlir::Type> resultType) {
2584 mlir::Location loc = getLoc();
2585 if (isElementalProcWithArrayArgs(procRef))
2586 fir::emitFatalError(loc, "trying to lower elemental procedure with array "
2587 "arguments as normal procedure");
2588
2589 if (const Fortran::evaluate::SpecificIntrinsic *intrinsic =
2590 procRef.proc().GetSpecificIntrinsic())
2591 return genIntrinsicRef(procRef, resultType, *intrinsic);
2592
2593 if (Fortran::lower::isIntrinsicModuleProcRef(procRef) &&
2594 !Fortran::semantics::IsBindCProcedure(*procRef.proc().GetSymbol()))
2595 return genIntrinsicRef(procRef, resultType);
2596
2597 if (isStatementFunctionCall(procRef))
2598 return genStmtFunctionRef(procRef);
2599
2600 Fortran::lower::CallerInterface caller(procRef, converter);
2601 using PassBy = Fortran::lower::CallerInterface::PassEntityBy;
2602
2603 llvm::SmallVector<fir::MutableBoxValue> mutableModifiedByCall;
2604 // List of <var, temp> where temp must be copied into var after the call.
2605 CopyOutPairs copyOutPairs;
2606
2607 mlir::FunctionType callSiteType = caller.genFunctionType();
2608
2609 // Lower the actual arguments and map the lowered values to the dummy
2610 // arguments.
2611 for (const Fortran::lower::CallInterface<
2612 Fortran::lower::CallerInterface>::PassedEntity &arg :
2613 caller.getPassedArguments()) {
2614 const auto *actual = arg.entity;
2615 mlir::Type argTy = callSiteType.getInput(arg.firArgument);
2616 if (!actual) {
2617 // Optional dummy argument for which there is no actual argument.
2618 caller.placeInput(arg, builder.genAbsentOp(loc, argTy));
2619 continue;
2620 }
2621 const auto *expr = actual->UnwrapExpr();
2622 if (!expr)
2623 TODO(loc, "assumed type actual argument");
2624
2625 if (arg.passBy == PassBy::Value) {
2626 ExtValue argVal = genval(*expr);
2627 if (!fir::isUnboxedValue(argVal))
2628 fir::emitFatalError(
2629 loc, "internal error: passing non trivial value by value");
2630 caller.placeInput(arg, fir::getBase(argVal));
2631 continue;
2632 }
2633
2634 if (arg.passBy == PassBy::MutableBox) {
2635 if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
2636 *expr)) {
2637 // If expr is NULL(), the mutableBox created must be a deallocated
2638 // pointer with the dummy argument characteristics (see table 16.5
2639 // in Fortran 2018 standard).
2640 // No length parameters are set for the created box because any non
2641 // deferred type parameters of the dummy will be evaluated on the
2642 // callee side, and it is illegal to use NULL without a MOLD if any
2643 // dummy length parameters are assumed.
2644 mlir::Type boxTy = fir::dyn_cast_ptrEleTy(argTy);
2645 assert(boxTy && mlir::isa<fir::BaseBoxType>(boxTy) &&
2646 "must be a fir.box type");
2647 mlir::Value boxStorage = builder.createTemporary(loc, boxTy);
2648 mlir::Value nullBox = fir::factory::createUnallocatedBox(
2649 builder, loc, boxTy, /*nonDeferredParams=*/{});
2650 builder.create<fir::StoreOp>(loc, nullBox, boxStorage);
2651 caller.placeInput(arg, boxStorage);
2652 continue;
2653 }
2654 if (fir::isPointerType(argTy) &&
2655 !Fortran::evaluate::IsObjectPointer(*expr)) {
2656 // Passing a non POINTER actual argument to a POINTER dummy argument.
2657 // Create a pointer of the dummy argument type and assign the actual
2658 // argument to it.
2659 mlir::Value irBox =
2660 builder.createTemporary(loc, fir::unwrapRefType(argTy));
2661 // Non deferred parameters will be evaluated on the callee side.
2662 fir::MutableBoxValue pointer(irBox,
2663 /*nonDeferredParams=*/mlir::ValueRange{},
2664 /*mutableProperties=*/{});
2665 Fortran::lower::associateMutableBox(converter, loc, pointer, *expr,
2666 /*lbounds=*/std::nullopt,
2667 stmtCtx);
2668 caller.placeInput(arg, irBox);
2669 continue;
2670 }
2671 // Passing a POINTER to a POINTER, or an ALLOCATABLE to an ALLOCATABLE.
2672 fir::MutableBoxValue mutableBox = genMutableBoxValue(*expr);
2673 if (fir::isAllocatableType(argTy) && arg.isIntentOut() &&
2674 Fortran::semantics::IsBindCProcedure(*procRef.proc().GetSymbol()))
2675 Fortran::lower::genDeallocateIfAllocated(converter, mutableBox, loc);
2676 mlir::Value irBox =
2677 fir::factory::getMutableIRBox(builder, loc, mutableBox);
2678 caller.placeInput(arg, irBox);
2679 if (arg.mayBeModifiedByCall())
2680 mutableModifiedByCall.emplace_back(std::move(mutableBox));
2681 continue;
2682 }
2683 if (arg.passBy == PassBy::BaseAddress || arg.passBy == PassBy::BoxChar ||
2684 arg.passBy == PassBy::BaseAddressValueAttribute ||
2685 arg.passBy == PassBy::CharBoxValueAttribute) {
2686 const bool byValue = arg.passBy == PassBy::BaseAddressValueAttribute ||
2687 arg.passBy == PassBy::CharBoxValueAttribute;
2688 ExtValue argAddr =
2689 prepareActualToBaseAddressLike(*expr, arg, copyOutPairs, byValue)
2690 .first;
2691 if (arg.passBy == PassBy::BaseAddress ||
2692 arg.passBy == PassBy::BaseAddressValueAttribute) {
2693 caller.placeInput(arg, fir::getBase(argAddr));
2694 } else {
2695 assert(arg.passBy == PassBy::BoxChar ||
2696 arg.passBy == PassBy::CharBoxValueAttribute);
2697 auto helper = fir::factory::CharacterExprHelper{builder, loc};
2698 auto boxChar = argAddr.match(
2699 [&](const fir::CharBoxValue &x) -> mlir::Value {
2700 // If a character procedure was passed instead, handle the
2701 // mismatch.
2702 auto funcTy =
2703 mlir::dyn_cast<mlir::FunctionType>(x.getAddr().getType());
2704 if (funcTy && funcTy.getNumResults() == 1 &&
2705 mlir::isa<fir::BoxCharType>(funcTy.getResult(0))) {
2706 auto boxTy =
2707 mlir::cast<fir::BoxCharType>(funcTy.getResult(0));
2708 mlir::Value ref = builder.createConvertWithVolatileCast(
2709 loc, builder.getRefType(boxTy.getEleTy()), x.getAddr());
2710 auto len = builder.create<fir::UndefOp>(
2711 loc, builder.getCharacterLengthType());
2712 return builder.create<fir::EmboxCharOp>(loc, boxTy, ref, len);
2713 }
2714 return helper.createEmbox(x);
2715 },
2716 [&](const fir::CharArrayBoxValue &x) {
2717 return helper.createEmbox(x);
2718 },
2719 [&](const auto &x) -> mlir::Value {
2720 // Fortran allows an actual argument of a completely different
2721 // type to be passed to a procedure expecting a CHARACTER in the
2722 // dummy argument position. When this happens, the data pointer
2723 // argument is simply assumed to point to CHARACTER data and the
2724 // LEN argument used is garbage. Simulate this behavior by
2725 // free-casting the base address to be a !fir.char reference and
2726 // setting the LEN argument to undefined. What could go wrong?
2727 auto dataPtr = fir::getBase(x);
2728 assert(!mlir::isa<fir::BoxType>(dataPtr.getType()));
2729 return builder.convertWithSemantics(
2730 loc, argTy, dataPtr,
2731 /*allowCharacterConversion=*/true);
2732 });
2733 caller.placeInput(arg, boxChar);
2734 }
2735 } else if (arg.passBy == PassBy::Box) {
2736 if (arg.mustBeMadeContiguous() &&
2737 !Fortran::evaluate::IsSimplyContiguous(
2738 *expr, converter.getFoldingContext())) {
2739 // If the expression is a PDT, or a polymorphic entity, or an assumed
2740 // rank, it cannot currently be safely handled by
2741 // prepareActualToBaseAddressLike that is intended to prepare
2742 // arguments that can be passed as simple base address.
2743 if (auto dynamicType = expr->GetType())
2744 if (dynamicType->IsPolymorphic())
2745 TODO(loc, "passing a polymorphic entity to an OPTIONAL "
2746 "CONTIGUOUS argument");
2747 if (fir::isRecordWithTypeParameters(
2748 fir::unwrapSequenceType(fir::unwrapPassByRefType(argTy))))
2749 TODO(loc, "passing to an OPTIONAL CONTIGUOUS derived type argument "
2750 "with length parameters");
2751 if (Fortran::evaluate::IsAssumedRank(*expr))
2752 TODO(loc, "passing an assumed rank entity to an OPTIONAL "
2753 "CONTIGUOUS argument");
2754 // Assumed shape VALUE are currently TODO in the call interface
2755 // lowering.
2756 const bool byValue = false;
2757 auto [argAddr, isPresentValue] =
2758 prepareActualToBaseAddressLike(*expr, arg, copyOutPairs, byValue);
2759 mlir::Value box = builder.createBox(loc, argAddr);
2760 if (isPresentValue) {
2761 mlir::Value convertedBox = builder.createConvert(loc, argTy, box);
2762 auto absent = builder.create<fir::AbsentOp>(loc, argTy);
2763 caller.placeInput(arg,
2764 builder.create<mlir::arith::SelectOp>(
2765 loc, *isPresentValue, convertedBox, absent));
2766 } else {
2767 caller.placeInput(arg, builder.createBox(loc, argAddr));
2768 }
2769
2770 } else if (arg.isOptional() &&
2771 Fortran::evaluate::IsAllocatableOrPointerObject(*expr)) {
2772 // Before lowering to an address, handle the allocatable/pointer
2773 // actual argument to optional fir.box dummy. It is legal to pass
2774 // unallocated/disassociated entity to an optional. In this case, an
2775 // absent fir.box must be created instead of a fir.box with a null
2776 // value (Fortran 2018 15.5.2.12 point 1).
2777 //
2778 // Note that passing an absent allocatable to a non-allocatable
2779 // optional dummy argument is illegal (15.5.2.12 point 3 (8)). So
2780 // nothing has to be done to generate an absent argument in this case,
2781 // and it is OK to unconditionally read the mutable box here.
2782 fir::MutableBoxValue mutableBox = genMutableBoxValue(*expr);
2783 mlir::Value isAllocated =
2784 fir::factory::genIsAllocatedOrAssociatedTest(builder, loc,
2785 mutableBox);
2786 auto absent = builder.create<fir::AbsentOp>(loc, argTy);
2787 /// For now, assume it is not OK to pass the allocatable/pointer
2788 /// descriptor to a non pointer/allocatable dummy. That is a strict
2789 /// interpretation of 18.3.6 point 4 that stipulates the descriptor
2790 /// has the dummy attributes in BIND(C) contexts.
2791 mlir::Value box = builder.createBox(
2792 loc, fir::factory::genMutableBoxRead(builder, loc, mutableBox));
2793
2794 // NULL() passed as argument is passed as a !fir.box<none>. Since
2795 // select op requires the same type for its two argument, convert
2796 // !fir.box<none> to !fir.class<none> when the argument is
2797 // polymorphic.
2798 if (fir::isBoxNone(box.getType()) && fir::isPolymorphicType(argTy)) {
2799 box = builder.createConvert(
2800 loc,
2801 fir::ClassType::get(mlir::NoneType::get(builder.getContext())),
2802 box);
2803 } else if (mlir::isa<fir::BoxType>(box.getType()) &&
2804 fir::isPolymorphicType(argTy)) {
2805 box = builder.create<fir::ReboxOp>(loc, argTy, box, mlir::Value{},
2806 /*slice=*/mlir::Value{});
2807 }
2808
2809 // Need the box types to be exactly similar for the selectOp.
2810 mlir::Value convertedBox = builder.createConvert(loc, argTy, box);
2811 caller.placeInput(arg, builder.create<mlir::arith::SelectOp>(
2812 loc, isAllocated, convertedBox, absent));
2813 } else {
2814 auto dynamicType = expr->GetType();
2815 mlir::Value box;
2816
2817 // Special case when an intrinsic scalar variable is passed to a
2818 // function expecting an optional unlimited polymorphic dummy
2819 // argument.
2820 // The presence test needs to be performed before emboxing otherwise
2821 // the program will crash.
2822 if (dynamicType->category() !=
2823 Fortran::common::TypeCategory::Derived &&
2824 expr->Rank() == 0 && fir::isUnlimitedPolymorphicType(argTy) &&
2825 arg.isOptional()) {
2826 ExtValue opt = lowerIntrinsicArgumentAsInquired(*expr);
2827 mlir::Value isPresent = genActualIsPresentTest(builder, loc, opt);
2828 box =
2829 builder
2830 .genIfOp(loc, {argTy}, isPresent, /*withElseRegion=*/true)
2831 .genThen([&]() {
2832 auto boxed = builder.createBox(
2833 loc, genBoxArg(*expr), fir::isPolymorphicType(argTy));
2834 builder.create<fir::ResultOp>(loc, boxed);
2835 })
2836 .genElse([&]() {
2837 auto absent =
2838 builder.create<fir::AbsentOp>(loc, argTy).getResult();
2839 builder.create<fir::ResultOp>(loc, absent);
2840 })
2841 .getResults()[0];
2842 } else {
2843 // Make sure a variable address is only passed if the expression is
2844 // actually a variable.
2845 box = Fortran::evaluate::IsVariable(*expr)
2846 ? builder.createBox(loc, genBoxArg(*expr),
2847 fir::isPolymorphicType(argTy),
2848 fir::isAssumedType(argTy))
2849 : builder.createBox(getLoc(), genTempExtAddr(*expr),
2850 fir::isPolymorphicType(argTy),
2851 fir::isAssumedType(argTy));
2852 if (mlir::isa<fir::BoxType>(box.getType()) &&
2853 fir::isPolymorphicType(argTy) && !fir::isAssumedType(argTy)) {
2854 mlir::Type actualTy = argTy;
2855 if (Fortran::lower::isParentComponent(*expr))
2856 actualTy = fir::BoxType::get(converter.genType(*expr));
2857 // Rebox can only be performed on a present argument.
2858 if (arg.isOptional()) {
2859 mlir::Value isPresent =
2860 genActualIsPresentTest(builder, loc, box);
2861 box = builder
2862 .genIfOp(loc, {actualTy}, isPresent,
2863 /*withElseRegion=*/true)
2864 .genThen([&]() {
2865 auto rebox =
2866 builder
2867 .create<fir::ReboxOp>(
2868 loc, actualTy, box, mlir::Value{},
2869 /*slice=*/mlir::Value{})
2870 .getResult();
2871 builder.create<fir::ResultOp>(loc, rebox);
2872 })
2873 .genElse([&]() {
2874 auto absent =
2875 builder.create<fir::AbsentOp>(loc, actualTy)
2876 .getResult();
2877 builder.create<fir::ResultOp>(loc, absent);
2878 })
2879 .getResults()[0];
2880 } else {
2881 box = builder.create<fir::ReboxOp>(loc, actualTy, box,
2882 mlir::Value{},
2883 /*slice=*/mlir::Value{});
2884 }
2885 } else if (Fortran::lower::isParentComponent(*expr)) {
2886 fir::ExtendedValue newExv =
2887 Fortran::lower::updateBoxForParentComponent(converter, box,
2888 *expr);
2889 box = fir::getBase(newExv);
2890 }
2891 }
2892 caller.placeInput(arg, box);
2893 }
2894 } else if (arg.passBy == PassBy::AddressAndLength) {
2895 ExtValue argRef = genExtAddr(*expr);
2896 caller.placeAddressAndLengthInput(arg, fir::getBase(argRef),
2897 fir::getLen(argRef));
2898 } else if (arg.passBy == PassBy::CharProcTuple) {
2899 ExtValue argRef = genExtAddr(*expr);
2900 mlir::Value tuple = createBoxProcCharTuple(
2901 converter, argTy, fir::getBase(argRef), fir::getLen(argRef));
2902 caller.placeInput(arg, tuple);
2903 } else {
2904 TODO(loc, "pass by value in non elemental function call");
2905 }
2906 }
2907
2908 auto loweredResult =
2909 Fortran::lower::genCallOpAndResult(loc, converter, symMap, stmtCtx,
2910 caller, callSiteType, resultType)
2911 .first;
2912 auto &result = std::get<ExtValue>(loweredResult);
2913
2914 // Sync pointers and allocatables that may have been modified during the
2915 // call.
2916 for (const auto &mutableBox : mutableModifiedByCall)
2917 fir::factory::syncMutableBoxFromIRBox(builder, loc, mutableBox);
2918 // Handle case where result was passed as argument
2919
2920 // Copy-out temps that were created for non contiguous variable arguments if
2921 // needed.
2922 for (const auto &copyOutPair : copyOutPairs)
2923 genCopyOut(copyOutPair);
2924
2925 return result;
2926 }
2927
2928 template <typename A>
2929 ExtValue genval(const Fortran::evaluate::FunctionRef<A> &funcRef) {
2930 ExtValue result = genFunctionRef(funcRef);
2931 if (result.rank() == 0 && fir::isa_ref_type(fir::getBase(result).getType()))
2932 return genLoad(result);
2933 return result;
2934 }
2935
2936 ExtValue genval(const Fortran::evaluate::ProcedureRef &procRef) {
2937 std::optional<mlir::Type> resTy;
2938 if (procRef.hasAlternateReturns())
2939 resTy = builder.getIndexType();
2940 return genProcedureRef(procRef, resTy);
2941 }
2942
2943 template <typename A>
2944 bool isScalar(const A &x) {
2945 return x.Rank() == 0;
2946 }
2947
2948 /// Helper to detect Transformational function reference.
2949 template <typename T>
2950 bool isTransformationalRef(const T &) {
2951 return false;
2952 }
2953 template <typename T>
2954 bool isTransformationalRef(const Fortran::evaluate::FunctionRef<T> &funcRef) {
2955 return !funcRef.IsElemental() && funcRef.Rank();
2956 }
2957 template <typename T>
2958 bool isTransformationalRef(Fortran::evaluate::Expr<T> expr) {
2959 return Fortran::common::visit(
2960 [&](const auto &e) { return isTransformationalRef(e); }, expr.u);
2961 }
2962
2963 template <typename A>
2964 ExtValue asArray(const A &x) {
2965 return Fortran::lower::createSomeArrayTempValue(converter, toEvExpr(x),
2966 symMap, stmtCtx);
2967 }
2968
2969 /// Lower an array value as an argument. This argument can be passed as a box
2970 /// value, so it may be possible to avoid making a temporary.
2971 template <typename A>
2972 ExtValue asArrayArg(const Fortran::evaluate::Expr<A> &x) {
2973 return Fortran::common::visit(
2974 [&](const auto &e) { return asArrayArg(e, x); }, x.u);
2975 }
2976 template <typename A, typename B>
2977 ExtValue asArrayArg(const Fortran::evaluate::Expr<A> &x, const B &y) {
2978 return Fortran::common::visit(
2979 [&](const auto &e) { return asArrayArg(e, y); }, x.u);
2980 }
2981 template <typename A, typename B>
2982 ExtValue asArrayArg(const Fortran::evaluate::Designator<A> &, const B &x) {
2983 // Designator is being passed as an argument to a procedure. Lower the
2984 // expression to a boxed value.
2985 auto someExpr = toEvExpr(x);
2986 return Fortran::lower::createBoxValue(getLoc(), converter, someExpr, symMap,
2987 stmtCtx);
2988 }
2989 template <typename A, typename B>
2990 ExtValue asArrayArg(const A &, const B &x) {
2991 // If the expression to pass as an argument is not a designator, then create
2992 // an array temp.
2993 return asArray(x);
2994 }
2995
2996 template <typename A>
2997 mlir::Value getIfOverridenExpr(const Fortran::evaluate::Expr<A> &x) {
2998 if (const Fortran::lower::ExprToValueMap *map =
2999 converter.getExprOverrides()) {
3000 Fortran::lower::SomeExpr someExpr = toEvExpr(x);
3001 if (auto match = map->find(&someExpr); match != map->end())
3002 return match->second;
3003 }
3004 return mlir::Value{};
3005 }
3006
3007 template <typename A>
3008 ExtValue gen(const Fortran::evaluate::Expr<A> &x) {
3009 if (mlir::Value val = getIfOverridenExpr(x))
3010 return val;
3011 // Whole array symbols or components, and results of transformational
3012 // functions already have a storage and the scalar expression lowering path
3013 // is used to not create a new temporary storage.
3014 if (isScalar(x) ||
3015 Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(x) ||
3016 (isTransformationalRef(x) && !isOptimizableTranspose(x, converter)))
3017 return Fortran::common::visit([&](const auto &e) { return genref(e); },
3018 x.u);
3019 if (useBoxArg)
3020 return asArrayArg(x);
3021 return asArray(x);
3022 }
3023 template <typename A>
3024 ExtValue genval(const Fortran::evaluate::Expr<A> &x) {
3025 if (mlir::Value val = getIfOverridenExpr(x))
3026 return val;
3027 if (isScalar(x) || Fortran::evaluate::UnwrapWholeSymbolDataRef(x) ||
3028 inInitializer)
3029 return Fortran::common::visit([&](const auto &e) { return genval(e); },
3030 x.u);
3031 return asArray(x);
3032 }
3033
3034 template <int KIND>
3035 ExtValue genval(const Fortran::evaluate::Expr<Fortran::evaluate::Type<
3036 Fortran::common::TypeCategory::Logical, KIND>> &exp) {
3037 if (mlir::Value val = getIfOverridenExpr(exp))
3038 return val;
3039 return Fortran::common::visit([&](const auto &e) { return genval(e); },
3040 exp.u);
3041 }
3042
3043 using RefSet =
3044 std::tuple<Fortran::evaluate::ComplexPart, Fortran::evaluate::Substring,
3045 Fortran::evaluate::DataRef, Fortran::evaluate::Component,
3046 Fortran::evaluate::ArrayRef, Fortran::evaluate::CoarrayRef,
3047 Fortran::semantics::SymbolRef>;
3048 template <typename A>
3049 static constexpr bool inRefSet = Fortran::common::HasMember<A, RefSet>;
3050
3051 template <typename A, typename = std::enable_if_t<inRefSet<A>>>
3052 ExtValue genref(const A &a) {
3053 return gen(a);
3054 }
3055 template <typename A>
3056 ExtValue genref(const A &a) {
3057 if (inInitializer) {
3058 // Initialization expressions can never allocate memory.
3059 return genval(a);
3060 }
3061 mlir::Type storageType = converter.genType(toEvExpr(a));
3062 return placeScalarValueInMemory(builder, getLoc(), genval(a), storageType);
3063 }
3064
3065 template <typename A, template <typename> typename T,
3066 typename B = std::decay_t<T<A>>,
3067 std::enable_if_t<
3068 std::is_same_v<B, Fortran::evaluate::Expr<A>> ||
3069 std::is_same_v<B, Fortran::evaluate::Designator<A>> ||
3070 std::is_same_v<B, Fortran::evaluate::FunctionRef<A>>,
3071 bool> = true>
3072 ExtValue genref(const T<A> &x) {
3073 return gen(x);
3074 }
3075
3076private:
3077 mlir::Location location;
3078 Fortran::lower::AbstractConverter &converter;
3079 fir::FirOpBuilder &builder;
3080 Fortran::lower::StatementContext &stmtCtx;
3081 Fortran::lower::SymMap &symMap;
3082 bool inInitializer = false;
3083 bool useBoxArg = false; // expression lowered as argument
3084};
3085} // namespace
3086
3087#define CONCAT(x, y) CONCAT2(x, y)
3088#define CONCAT2(x, y) x##y
3089
3090// Helper for changing the semantics in a given context. Preserves the current
3091// semantics which is resumed when the "push" goes out of scope.
3092#define PushSemantics(PushVal) \
3093 [[maybe_unused]] auto CONCAT(pushSemanticsLocalVariable, __LINE__) = \
3094 Fortran::common::ScopedSet(semant, PushVal);
3095
3096static bool isAdjustedArrayElementType(mlir::Type t) {
3097 return fir::isa_char(t) || fir::isa_derived(t) ||
3098 mlir::isa<fir::SequenceType>(t);
3099}
3100static bool elementTypeWasAdjusted(mlir::Type t) {
3101 if (auto ty = mlir::dyn_cast<fir::ReferenceType>(t))
3102 return isAdjustedArrayElementType(ty.getEleTy());
3103 return false;
3104}
3105static mlir::Type adjustedArrayElementType(mlir::Type t) {
3106 return isAdjustedArrayElementType(t) ? fir::ReferenceType::get(t) : t;
3107}
3108
3109/// Helper to generate calls to scalar user defined assignment procedures.
3110static void genScalarUserDefinedAssignmentCall(fir::FirOpBuilder &builder,
3111 mlir::Location loc,
3112 mlir::func::FuncOp func,
3113 const fir::ExtendedValue &lhs,
3114 const fir::ExtendedValue &rhs) {
3115 auto prepareUserDefinedArg =
3116 [](fir::FirOpBuilder &builder, mlir::Location loc,
3117 const fir::ExtendedValue &value, mlir::Type argType) -> mlir::Value {
3118 if (mlir::isa<fir::BoxCharType>(argType)) {
3119 const fir::CharBoxValue *charBox = value.getCharBox();
3120 assert(charBox && "argument type mismatch in elemental user assignment");
3121 return fir::factory::CharacterExprHelper{builder, loc}.createEmbox(
3122 *charBox);
3123 }
3124 if (mlir::isa<fir::BaseBoxType>(argType)) {
3125 mlir::Value box =
3126 builder.createBox(loc, value, mlir::isa<fir::ClassType>(argType));
3127 return builder.createConvert(loc, argType, box);
3128 }
3129 // Simple pass by address.
3130 mlir::Type argBaseType = fir::unwrapRefType(argType);
3131 assert(!fir::hasDynamicSize(argBaseType));
3132 mlir::Value from = fir::getBase(value);
3133 if (argBaseType != fir::unwrapRefType(from.getType())) {
3134 // With logicals, it is possible that from is i1 here.
3135 if (fir::isa_ref_type(from.getType()))
3136 from = builder.create<fir::LoadOp>(loc, from);
3137 from = builder.createConvert(loc, argBaseType, from);
3138 }
3139 if (!fir::isa_ref_type(from.getType())) {
3140 mlir::Value temp = builder.createTemporary(loc, argBaseType);
3141 builder.create<fir::StoreOp>(loc, from, temp);
3142 from = temp;
3143 }
3144 return builder.createConvert(loc, argType, from);
3145 };
3146 assert(func.getNumArguments() == 2);
3147 mlir::Type lhsType = func.getFunctionType().getInput(0);
3148 mlir::Type rhsType = func.getFunctionType().getInput(1);
3149 mlir::Value lhsArg = prepareUserDefinedArg(builder, loc, lhs, lhsType);
3150 mlir::Value rhsArg = prepareUserDefinedArg(builder, loc, rhs, rhsType);
3151 builder.create<fir::CallOp>(loc, func, mlir::ValueRange{lhsArg, rhsArg});
3152}
3153
3154/// Convert the result of a fir.array_modify to an ExtendedValue given the
3155/// related fir.array_load.
3156static fir::ExtendedValue arrayModifyToExv(fir::FirOpBuilder &builder,
3157 mlir::Location loc,
3158 fir::ArrayLoadOp load,
3159 mlir::Value elementAddr) {
3160 mlir::Type eleTy = fir::unwrapPassByRefType(elementAddr.getType());
3161 if (fir::isa_char(eleTy)) {
3162 auto len = fir::factory::CharacterExprHelper{builder, loc}.getLength(
3163 load.getMemref());
3164 if (!len) {
3165 assert(load.getTypeparams().size() == 1 &&
3166 "length must be in array_load");
3167 len = load.getTypeparams()[0];
3168 }
3169 return fir::CharBoxValue{elementAddr, len};
3170 }
3171 return elementAddr;
3172}
3173
3174//===----------------------------------------------------------------------===//
3175//
3176// Lowering of scalar expressions in an explicit iteration space context.
3177//
3178//===----------------------------------------------------------------------===//
3179
3180// Shared code for creating a copy of a derived type element. This function is
3181// called from a continuation.
3182inline static fir::ArrayAmendOp
3183createDerivedArrayAmend(mlir::Location loc, fir::ArrayLoadOp destLoad,
3184 fir::FirOpBuilder &builder, fir::ArrayAccessOp destAcc,
3185 const fir::ExtendedValue &elementExv, mlir::Type eleTy,
3186 mlir::Value innerArg) {
3187 if (destLoad.getTypeparams().empty()) {
3188 fir::factory::genRecordAssignment(builder, loc, destAcc, elementExv);
3189 } else {
3190 auto boxTy = fir::BoxType::get(eleTy);
3191 auto toBox = builder.create<fir::EmboxOp>(loc, boxTy, destAcc.getResult(),
3192 mlir::Value{}, mlir::Value{},
3193 destLoad.getTypeparams());
3194 auto fromBox = builder.create<fir::EmboxOp>(
3195 loc, boxTy, fir::getBase(elementExv), mlir::Value{}, mlir::Value{},
3196 destLoad.getTypeparams());
3197 fir::factory::genRecordAssignment(builder, loc, fir::BoxValue(toBox),
3198 fir::BoxValue(fromBox));
3199 }
3200 return builder.create<fir::ArrayAmendOp>(loc, innerArg.getType(), innerArg,
3201 destAcc);
3202}
3203
3204inline static fir::ArrayAmendOp
3205createCharArrayAmend(mlir::Location loc, fir::FirOpBuilder &builder,
3206 fir::ArrayAccessOp dstOp, mlir::Value &dstLen,
3207 const fir::ExtendedValue &srcExv, mlir::Value innerArg,
3208 llvm::ArrayRef<mlir::Value> bounds) {
3209 fir::CharBoxValue dstChar(dstOp, dstLen);
3210 fir::factory::CharacterExprHelper helper{builder, loc};
3211 if (!bounds.empty()) {
3212 dstChar = helper.createSubstring(dstChar, bounds);
3213 fir::factory::genCharacterCopy(fir::getBase(srcExv), fir::getLen(srcExv),
3214 dstChar.getAddr(), dstChar.getLen(), builder,
3215 loc);
3216 // Update the LEN to the substring's LEN.
3217 dstLen = dstChar.getLen();
3218 }
3219 // For a CHARACTER, we generate the element assignment loops inline.
3220 helper.createAssign(fir::ExtendedValue{dstChar}, srcExv);
3221 // Mark this array element as amended.
3222 mlir::Type ty = innerArg.getType();
3223 auto amend = builder.create<fir::ArrayAmendOp>(loc, ty, innerArg, dstOp);
3224 return amend;
3225}
3226
3227/// Build an ExtendedValue from a fir.array<?x...?xT> without actually setting
3228/// the actual extents and lengths. This is only to allow their propagation as
3229/// ExtendedValue without triggering verifier failures when propagating
3230/// character/arrays as unboxed values. Only the base of the resulting
3231/// ExtendedValue should be used, it is undefined to use the length or extents
3232/// of the extended value returned,
3233inline static fir::ExtendedValue
3234convertToArrayBoxValue(mlir::Location loc, fir::FirOpBuilder &builder,
3235 mlir::Value val, mlir::Value len) {
3236 mlir::Type ty = fir::unwrapRefType(val.getType());
3237 mlir::IndexType idxTy = builder.getIndexType();
3238 auto seqTy = mlir::cast<fir::SequenceType>(ty);
3239 auto undef = builder.create<fir::UndefOp>(loc, idxTy);
3240 llvm::SmallVector<mlir::Value> extents(seqTy.getDimension(), undef);
3241 if (fir::isa_char(seqTy.getEleTy()))
3242 return fir::CharArrayBoxValue(val, len ? len : undef, extents);
3243 return fir::ArrayBoxValue(val, extents);
3244}
3245
3246//===----------------------------------------------------------------------===//
3247//
3248// Lowering of array expressions.
3249//
3250//===----------------------------------------------------------------------===//
3251
3252namespace {
3253class ArrayExprLowering {
3254 using ExtValue = fir::ExtendedValue;
3255
3256 /// Structure to keep track of lowered array operands in the
3257 /// array expression. Useful to later deduce the shape of the
3258 /// array expression.
3259 struct ArrayOperand {
3260 /// Array base (can be a fir.box).
3261 mlir::Value memref;
3262 /// ShapeOp, ShapeShiftOp or ShiftOp
3263 mlir::Value shape;
3264 /// SliceOp
3265 mlir::Value slice;
3266 /// Can this operand be absent ?
3267 bool mayBeAbsent = false;
3268 };
3269
3270 using ImplicitSubscripts = Fortran::lower::details::ImplicitSubscripts;
3271 using PathComponent = Fortran::lower::PathComponent;
3272
3273 /// Active iteration space.
3274 using IterationSpace = Fortran::lower::IterationSpace;
3275 using IterSpace = const Fortran::lower::IterationSpace &;
3276
3277 /// Current continuation. Function that will generate IR for a single
3278 /// iteration of the pending iterative loop structure.
3279 using CC = Fortran::lower::GenerateElementalArrayFunc;
3280
3281 /// Projection continuation. Function that will project one iteration space
3282 /// into another.
3283 using PC = std::function<IterationSpace(IterSpace)>;
3284 using ArrayBaseTy =
3285 std::variant<std::monostate, const Fortran::evaluate::ArrayRef *,
3286 const Fortran::evaluate::DataRef *>;
3287 using ComponentPath = Fortran::lower::ComponentPath;
3288
3289public:
3290 //===--------------------------------------------------------------------===//
3291 // Regular array assignment
3292 //===--------------------------------------------------------------------===//
3293
3294 /// Entry point for array assignments. Both the left-hand and right-hand sides
3295 /// can either be ExtendedValue or evaluate::Expr.
3296 template <typename TL, typename TR>
3297 static void lowerArrayAssignment(Fortran::lower::AbstractConverter &converter,
3298 Fortran::lower::SymMap &symMap,
3299 Fortran::lower::StatementContext &stmtCtx,
3300 const TL &lhs, const TR &rhs) {
3301 ArrayExprLowering ael(converter, stmtCtx, symMap,
3302 ConstituentSemantics::CopyInCopyOut);
3303 ael.lowerArrayAssignment(lhs, rhs);
3304 }
3305
3306 template <typename TL, typename TR>
3307 void lowerArrayAssignment(const TL &lhs, const TR &rhs) {
3308 mlir::Location loc = getLoc();
3309 /// Here the target subspace is not necessarily contiguous. The ArrayUpdate
3310 /// continuation is implicitly returned in `ccStoreToDest` and the ArrayLoad
3311 /// in `destination`.
3312 PushSemantics(ConstituentSemantics::ProjectedCopyInCopyOut);
3313 ccStoreToDest = genarr(lhs);
3314 determineShapeOfDest(lhs);
3315 semant = ConstituentSemantics::RefTransparent;
3316 ExtValue exv = lowerArrayExpression(rhs);
3317 if (explicitSpaceIsActive()) {
3318 explicitSpace->finalizeContext();
3319 builder.create<fir::ResultOp>(loc, fir::getBase(exv));
3320 } else {
3321 builder.create<fir::ArrayMergeStoreOp>(
3322 loc, destination, fir::getBase(exv), destination.getMemref(),
3323 destination.getSlice(), destination.getTypeparams());
3324 }
3325 }
3326
3327 //===--------------------------------------------------------------------===//
3328 // WHERE array assignment, FORALL assignment, and FORALL+WHERE array
3329 // assignment
3330 //===--------------------------------------------------------------------===//
3331
3332 /// Entry point for array assignment when the iteration space is explicitly
3333 /// defined (Fortran's FORALL) with or without masks, and/or the implied
3334 /// iteration space involves masks (Fortran's WHERE). Both contexts (explicit
3335 /// space and implicit space with masks) may be present.
3336 static void lowerAnyMaskedArrayAssignment(
3337 Fortran::lower::AbstractConverter &converter,
3338 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
3339 const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
3340 Fortran::lower::ExplicitIterSpace &explicitSpace,
3341 Fortran::lower::ImplicitIterSpace &implicitSpace) {
3342 if (explicitSpace.isActive() && lhs.Rank() == 0) {
3343 // Scalar assignment expression in a FORALL context.
3344 ArrayExprLowering ael(converter, stmtCtx, symMap,
3345 ConstituentSemantics::RefTransparent,
3346 &explicitSpace, &implicitSpace);
3347 ael.lowerScalarAssignment(lhs, rhs);
3348 return;
3349 }
3350 // Array assignment expression in a FORALL and/or WHERE context.
3351 ArrayExprLowering ael(converter, stmtCtx, symMap,
3352 ConstituentSemantics::CopyInCopyOut, &explicitSpace,
3353 &implicitSpace);
3354 ael.lowerArrayAssignment(lhs, rhs);
3355 }
3356
3357 //===--------------------------------------------------------------------===//
3358 // Array assignment to array of pointer box values.
3359 //===--------------------------------------------------------------------===//
3360
3361 /// Entry point for assignment to pointer in an array of pointers.
3362 static void lowerArrayOfPointerAssignment(
3363 Fortran::lower::AbstractConverter &converter,
3364 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
3365 const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
3366 Fortran::lower::ExplicitIterSpace &explicitSpace,
3367 Fortran::lower::ImplicitIterSpace &implicitSpace,
3368 const llvm::SmallVector<mlir::Value> &lbounds,
3369 std::optional<llvm::SmallVector<mlir::Value>> ubounds) {
3370 ArrayExprLowering ael(converter, stmtCtx, symMap,
3371 ConstituentSemantics::CopyInCopyOut, &explicitSpace,
3372 &implicitSpace);
3373 ael.lowerArrayOfPointerAssignment(lhs, rhs, lbounds, ubounds);
3374 }
3375
3376 /// Scalar pointer assignment in an explicit iteration space.
3377 ///
3378 /// Pointers may be bound to targets in a FORALL context. This is a scalar
3379 /// assignment in the sense there is never an implied iteration space, even if
3380 /// the pointer is to a target with non-zero rank. Since the pointer
3381 /// assignment must appear in a FORALL construct, correctness may require that
3382 /// the array of pointers follow copy-in/copy-out semantics. The pointer
3383 /// assignment may include a bounds-spec (lower bounds), a bounds-remapping
3384 /// (lower and upper bounds), or neither.
3385 void lowerArrayOfPointerAssignment(
3386 const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
3387 const llvm::SmallVector<mlir::Value> &lbounds,
3388 std::optional<llvm::SmallVector<mlir::Value>> ubounds) {
3389 setPointerAssignmentBounds(lbounds, ubounds);
3390 if (rhs.Rank() == 0 ||
3391 (Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(rhs) &&
3392 Fortran::evaluate::IsAllocatableOrPointerObject(rhs))) {
3393 lowerScalarAssignment(lhs, rhs);
3394 return;
3395 }
3396 TODO(getLoc(),
3397 "auto boxing of a ranked expression on RHS for pointer assignment");
3398 }
3399
3400 //===--------------------------------------------------------------------===//
3401 // Array assignment to allocatable array
3402 //===--------------------------------------------------------------------===//
3403
3404 /// Entry point for assignment to allocatable array.
3405 static void lowerAllocatableArrayAssignment(
3406 Fortran::lower::AbstractConverter &converter,
3407 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
3408 const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
3409 Fortran::lower::ExplicitIterSpace &explicitSpace,
3410 Fortran::lower::ImplicitIterSpace &implicitSpace) {
3411 ArrayExprLowering ael(converter, stmtCtx, symMap,
3412 ConstituentSemantics::CopyInCopyOut, &explicitSpace,
3413 &implicitSpace);
3414 ael.lowerAllocatableArrayAssignment(lhs, rhs);
3415 }
3416
3417 /// Lower an assignment to allocatable array, where the LHS array
3418 /// is represented with \p lhs extended value produced in different
3419 /// branches created in genReallocIfNeeded(). The RHS lowering
3420 /// is provided via \p rhsCC continuation.
3421 void lowerAllocatableArrayAssignment(ExtValue lhs, CC rhsCC) {
3422 mlir::Location loc = getLoc();
3423 // Check if the initial destShape is null, which means
3424 // it has not been computed from rhs (e.g. rhs is scalar).
3425 bool destShapeIsEmpty = destShape.empty();
3426 // Create ArrayLoad for the mutable box and save it into `destination`.
3427 PushSemantics(ConstituentSemantics::ProjectedCopyInCopyOut);
3428 ccStoreToDest = genarr(lhs);
3429 // destShape is either non-null on entry to this function,
3430 // or has been just set by lhs lowering.
3431 assert(!destShape.empty() && "destShape must have been set.");
3432 // Finish lowering the loop nest.
3433 assert(destination && "destination must have been set");
3434 ExtValue exv = lowerArrayExpression(rhsCC, destination.getType());
3435 if (!explicitSpaceIsActive())
3436 builder.create<fir::ArrayMergeStoreOp>(
3437 loc, destination, fir::getBase(exv), destination.getMemref(),
3438 destination.getSlice(), destination.getTypeparams());
3439 // destShape may originally be null, if rhs did not define a shape.
3440 // In this case the destShape is computed from lhs, and we may have
3441 // multiple different lhs values for different branches created
3442 // in genReallocIfNeeded(). We cannot reuse destShape computed
3443 // in different branches, so we have to reset it,
3444 // so that it is recomputed for the next branch FIR generation.
3445 if (destShapeIsEmpty)
3446 destShape.clear();
3447 }
3448
3449 /// Assignment to allocatable array.
3450 ///
3451 /// The semantics are reverse that of a "regular" array assignment. The rhs
3452 /// defines the iteration space of the computation and the lhs is
3453 /// resized/reallocated to fit if necessary.
3454 void lowerAllocatableArrayAssignment(const Fortran::lower::SomeExpr &lhs,
3455 const Fortran::lower::SomeExpr &rhs) {
3456 // With assignment to allocatable, we want to lower the rhs first and use
3457 // its shape to determine if we need to reallocate, etc.
3458 mlir::Location loc = getLoc();
3459 // FIXME: If the lhs is in an explicit iteration space, the assignment may
3460 // be to an array of allocatable arrays rather than a single allocatable
3461 // array.
3462 if (explicitSpaceIsActive() && lhs.Rank() > 0)
3463 TODO(loc, "assignment to whole allocatable array inside FORALL");
3464
3465 fir::MutableBoxValue mutableBox =
3466 Fortran::lower::createMutableBox(loc, converter, lhs, symMap);
3467 if (rhs.Rank() > 0)
3468 determineShapeOfDest(rhs);
3469 auto rhsCC = [&]() {
3470 PushSemantics(ConstituentSemantics::RefTransparent);
3471 return genarr(rhs);
3472 }();
3473
3474 llvm::SmallVector<mlir::Value> lengthParams;
3475 // Currently no safe way to gather length from rhs (at least for
3476 // character, it cannot be taken from array_loads since it may be
3477 // changed by concatenations).
3478 if ((mutableBox.isCharacter() && !mutableBox.hasNonDeferredLenParams()) ||
3479 mutableBox.isDerivedWithLenParameters())
3480 TODO(loc, "gather rhs LEN parameters in assignment to allocatable");
3481
3482 // The allocatable must take lower bounds from the expr if it is
3483 // reallocated and the right hand side is not a scalar.
3484 const bool takeLboundsIfRealloc = rhs.Rank() > 0;
3485 llvm::SmallVector<mlir::Value> lbounds;
3486 // When the reallocated LHS takes its lower bounds from the RHS,
3487 // they will be non default only if the RHS is a whole array
3488 // variable. Otherwise, lbounds is left empty and default lower bounds
3489 // will be used.
3490 if (takeLboundsIfRealloc &&
3491 Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(rhs)) {
3492 assert(arrayOperands.size() == 1 &&
3493 "lbounds can only come from one array");
3494 auto lbs = fir::factory::getOrigins(arrayOperands[0].shape);
3495 lbounds.append(lbs.begin(), lbs.end());
3496 }
3497 auto assignToStorage = [&](fir::ExtendedValue newLhs) {
3498 // The lambda will be called repeatedly by genReallocIfNeeded().
3499 lowerAllocatableArrayAssignment(newLhs, rhsCC);
3500 };
3501 fir::factory::MutableBoxReallocation realloc =
3502 fir::factory::genReallocIfNeeded(builder, loc, mutableBox, destShape,
3503 lengthParams, assignToStorage);
3504 if (explicitSpaceIsActive()) {
3505 explicitSpace->finalizeContext();
3506 builder.create<fir::ResultOp>(loc, fir::getBase(realloc.newValue));
3507 }
3508 fir::factory::finalizeRealloc(builder, loc, mutableBox, lbounds,
3509 takeLboundsIfRealloc, realloc);
3510 }
3511
3512 /// Entry point for when an array expression appears in a context where the
3513 /// result must be boxed. (BoxValue semantics.)
3514 static ExtValue
3515 lowerBoxedArrayExpression(Fortran::lower::AbstractConverter &converter,
3516 Fortran::lower::SymMap &symMap,
3517 Fortran::lower::StatementContext &stmtCtx,
3518 const Fortran::lower::SomeExpr &expr) {
3519 ArrayExprLowering ael{converter, stmtCtx, symMap,
3520 ConstituentSemantics::BoxValue};
3521 return ael.lowerBoxedArrayExpr(expr);
3522 }
3523
3524 ExtValue lowerBoxedArrayExpr(const Fortran::lower::SomeExpr &exp) {
3525 PushSemantics(ConstituentSemantics::BoxValue);
3526 return Fortran::common::visit(
3527 [&](const auto &e) {
3528 auto f = genarr(e);
3529 ExtValue exv = f(IterationSpace{});
3530 if (mlir::isa<fir::BaseBoxType>(fir::getBase(exv).getType()))
3531 return exv;
3532 fir::emitFatalError(getLoc(), "array must be emboxed");
3533 },
3534 exp.u);
3535 }
3536
3537 /// Entry point into lowering an expression with rank. This entry point is for
3538 /// lowering a rhs expression, for example. (RefTransparent semantics.)
3539 static ExtValue
3540 lowerNewArrayExpression(Fortran::lower::AbstractConverter &converter,
3541 Fortran::lower::SymMap &symMap,
3542 Fortran::lower::StatementContext &stmtCtx,
3543 const Fortran::lower::SomeExpr &expr) {
3544 ArrayExprLowering ael{converter, stmtCtx, symMap};
3545 ael.determineShapeOfDest(expr);
3546 ExtValue loopRes = ael.lowerArrayExpression(expr);
3547 fir::ArrayLoadOp dest = ael.destination;
3548 mlir::Value tempRes = dest.getMemref();
3549 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
3550 mlir::Location loc = converter.getCurrentLocation();
3551 builder.create<fir::ArrayMergeStoreOp>(loc, dest, fir::getBase(loopRes),
3552 tempRes, dest.getSlice(),
3553 dest.getTypeparams());
3554
3555 auto arrTy = mlir::cast<fir::SequenceType>(
3556 fir::dyn_cast_ptrEleTy(tempRes.getType()));
3557 if (auto charTy = mlir::dyn_cast<fir::CharacterType>(arrTy.getEleTy())) {
3558 if (fir::characterWithDynamicLen(charTy))
3559 TODO(loc, "CHARACTER does not have constant LEN");
3560 mlir::Value len = builder.createIntegerConstant(
3561 loc, builder.getCharacterLengthType(), charTy.getLen());
3562 return fir::CharArrayBoxValue(tempRes, len, dest.getExtents());
3563 }
3564 return fir::ArrayBoxValue(tempRes, dest.getExtents());
3565 }
3566
3567 static void lowerLazyArrayExpression(
3568 Fortran::lower::AbstractConverter &converter,
3569 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
3570 const Fortran::lower::SomeExpr &expr, mlir::Value raggedHeader) {
3571 ArrayExprLowering ael(converter, stmtCtx, symMap);
3572 ael.lowerLazyArrayExpression(expr, raggedHeader);
3573 }
3574
3575 /// Lower the expression \p expr into a buffer that is created on demand. The
3576 /// variable containing the pointer to the buffer is \p var and the variable
3577 /// containing the shape of the buffer is \p shapeBuffer.
3578 void lowerLazyArrayExpression(const Fortran::lower::SomeExpr &expr,
3579 mlir::Value header) {
3580 mlir::Location loc = getLoc();
3581 mlir::TupleType hdrTy = fir::factory::getRaggedArrayHeaderType(builder);
3582 mlir::IntegerType i32Ty = builder.getIntegerType(32);
3583
3584 // Once the loop extents have been computed, which may require being inside
3585 // some explicit loops, lazily allocate the expression on the heap. The
3586 // following continuation creates the buffer as needed.
3587 ccPrelude = [=](llvm::ArrayRef<mlir::Value> shape) {
3588 mlir::IntegerType i64Ty = builder.getIntegerType(64);
3589 mlir::Value byteSize = builder.createIntegerConstant(loc, i64Ty, 1);
3590 fir::runtime::genRaggedArrayAllocate(
3591 loc, builder, header, /*asHeaders=*/false, byteSize, shape);
3592 };
3593
3594 // Create a dummy array_load before the loop. We're storing to a lazy
3595 // temporary, so there will be no conflict and no copy-in. TODO: skip this
3596 // as there isn't any necessity for it.
3597 ccLoadDest = [=](llvm::ArrayRef<mlir::Value> shape) -> fir::ArrayLoadOp {
3598 mlir::Value one = builder.createIntegerConstant(loc, i32Ty, 1);
3599 auto var = builder.create<fir::CoordinateOp>(
3600 loc, builder.getRefType(hdrTy.getType(1)), header, one);
3601 auto load = builder.create<fir::LoadOp>(loc, var);
3602 mlir::Type eleTy =
3603 fir::unwrapSequenceType(fir::unwrapRefType(load.getType()));
3604 auto seqTy = fir::SequenceType::get(eleTy, shape.size());
3605 mlir::Value castTo =
3606 builder.createConvert(loc, fir::HeapType::get(seqTy), load);
3607 mlir::Value shapeOp = builder.genShape(loc, shape);
3608 return builder.create<fir::ArrayLoadOp>(
3609 loc, seqTy, castTo, shapeOp, /*slice=*/mlir::Value{}, std::nullopt);
3610 };
3611 // Custom lowering of the element store to deal with the extra indirection
3612 // to the lazy allocated buffer.
3613 ccStoreToDest = [=](IterSpace iters) {
3614 mlir::Value one = builder.createIntegerConstant(loc, i32Ty, 1);
3615 auto var = builder.create<fir::CoordinateOp>(
3616 loc, builder.getRefType(hdrTy.getType(1)), header, one);
3617 auto load = builder.create<fir::LoadOp>(loc, var);
3618 mlir::Type eleTy =
3619 fir::unwrapSequenceType(fir::unwrapRefType(load.getType()));
3620 auto seqTy = fir::SequenceType::get(eleTy, iters.iterVec().size());
3621 auto toTy = fir::HeapType::get(seqTy);
3622 mlir::Value castTo = builder.createConvert(loc, toTy, load);
3623 mlir::Value shape = builder.genShape(loc, genIterationShape());
3624 llvm::SmallVector<mlir::Value> indices = fir::factory::originateIndices(
3625 loc, builder, castTo.getType(), shape, iters.iterVec());
3626 auto eleAddr = builder.create<fir::ArrayCoorOp>(
3627 loc, builder.getRefType(eleTy), castTo, shape,
3628 /*slice=*/mlir::Value{}, indices, destination.getTypeparams());
3629 mlir::Value eleVal =
3630 builder.createConvert(loc, eleTy, iters.getElement());
3631 builder.create<fir::StoreOp>(loc, eleVal, eleAddr);
3632 return iters.innerArgument();
3633 };
3634
3635 // Lower the array expression now. Clean-up any temps that may have
3636 // been generated when lowering `expr` right after the lowered value
3637 // was stored to the ragged array temporary. The local temps will not
3638 // be needed afterwards.
3639 stmtCtx.pushScope();
3640 [[maybe_unused]] ExtValue loopRes = lowerArrayExpression(expr);
3641 stmtCtx.finalizeAndPop();
3642 assert(fir::getBase(loopRes));
3643 }
3644
3645 static void
3646 lowerElementalUserAssignment(Fortran::lower::AbstractConverter &converter,
3647 Fortran::lower::SymMap &symMap,
3648 Fortran::lower::StatementContext &stmtCtx,
3649 Fortran::lower::ExplicitIterSpace &explicitSpace,
3650 Fortran::lower::ImplicitIterSpace &implicitSpace,
3651 const Fortran::evaluate::ProcedureRef &procRef) {
3652 ArrayExprLowering ael(converter, stmtCtx, symMap,
3653 ConstituentSemantics::CustomCopyInCopyOut,
3654 &explicitSpace, &implicitSpace);
3655 assert(procRef.arguments().size() == 2);
3656 const auto *lhs = procRef.arguments()[0].value().UnwrapExpr();
3657 const auto *rhs = procRef.arguments()[1].value().UnwrapExpr();
3658 assert(lhs && rhs &&
3659 "user defined assignment arguments must be expressions");
3660 mlir::func::FuncOp func =
3661 Fortran::lower::CallerInterface(procRef, converter).getFuncOp();
3662 ael.lowerElementalUserAssignment(func, *lhs, *rhs);
3663 }
3664
3665 void lowerElementalUserAssignment(mlir::func::FuncOp userAssignment,
3666 const Fortran::lower::SomeExpr &lhs,
3667 const Fortran::lower::SomeExpr &rhs) {
3668 mlir::Location loc = getLoc();
3669 PushSemantics(ConstituentSemantics::CustomCopyInCopyOut);
3670 auto genArrayModify = genarr(lhs);
3671 ccStoreToDest = [=](IterSpace iters) -> ExtValue {
3672 auto modifiedArray = genArrayModify(iters);
3673 auto arrayModify = mlir::dyn_cast_or_null<fir::ArrayModifyOp>(
3674 fir::getBase(modifiedArray).getDefiningOp());
3675 assert(arrayModify && "must be created by ArrayModifyOp");
3676 fir::ExtendedValue lhs =
3677 arrayModifyToExv(builder, loc, destination, arrayModify.getResult(0));
3678 genScalarUserDefinedAssignmentCall(builder, loc, userAssignment, lhs,
3679 iters.elementExv());
3680 return modifiedArray;
3681 };
3682 determineShapeOfDest(lhs);
3683 semant = ConstituentSemantics::RefTransparent;
3684 auto exv = lowerArrayExpression(rhs);
3685 if (explicitSpaceIsActive()) {
3686 explicitSpace->finalizeContext();
3687 builder.create<fir::ResultOp>(loc, fir::getBase(exv));
3688 } else {
3689 builder.create<fir::ArrayMergeStoreOp>(
3690 loc, destination, fir::getBase(exv), destination.getMemref(),
3691 destination.getSlice(), destination.getTypeparams());
3692 }
3693 }
3694
3695 /// Lower an elemental subroutine call with at least one array argument.
3696 /// An elemental subroutine is an exception and does not have copy-in/copy-out
3697 /// semantics. See 15.8.3.
3698 /// Do NOT use this for user defined assignments.
3699 static void
3700 lowerElementalSubroutine(Fortran::lower::AbstractConverter &converter,
3701 Fortran::lower::SymMap &symMap,
3702 Fortran::lower::StatementContext &stmtCtx,
3703 const Fortran::lower::SomeExpr &call) {
3704 ArrayExprLowering ael(converter, stmtCtx, symMap,
3705 ConstituentSemantics::RefTransparent);
3706 ael.lowerElementalSubroutine(call);
3707 }
3708
3709 static const std::optional<Fortran::evaluate::ActualArgument>
3710 extractPassedArgFromProcRef(const Fortran::evaluate::ProcedureRef &procRef,
3711 Fortran::lower::AbstractConverter &converter) {
3712 // First look for passed object in actual arguments.
3713 for (const std::optional<Fortran::evaluate::ActualArgument> &arg :
3714 procRef.arguments())
3715 if (arg && arg->isPassedObject())
3716 return arg;
3717
3718 // If passed object is not found by here, it means the call was fully
3719 // resolved to the correct procedure. Look for the pass object in the
3720 // dummy arguments. Pick the first polymorphic one.
3721 Fortran::lower::CallerInterface caller(procRef, converter);
3722 unsigned idx = 0;
3723 for (const auto &arg : caller.characterize().dummyArguments) {
3724 if (const auto *dummy =
3725 std::get_if<Fortran::evaluate::characteristics::DummyDataObject>(
3726 &arg.u))
3727 if (dummy->type.type().IsPolymorphic())
3728 return procRef.arguments()[idx];
3729 ++idx;
3730 }
3731 return std::nullopt;
3732 }
3733
3734 // TODO: See the comment in genarr(const Fortran::lower::Parentheses<T>&).
3735 // This is skipping generation of copy-in/copy-out code for analysis that is
3736 // required when arguments are in parentheses.
3737 void lowerElementalSubroutine(const Fortran::lower::SomeExpr &call) {
3738 if (const auto *procRef =
3739 std::get_if<Fortran::evaluate::ProcedureRef>(&call.u))
3740 setLoweredProcRef(procRef);
3741 auto f = genarr(call);
3742 llvm::SmallVector<mlir::Value> shape = genIterationShape();
3743 auto [iterSpace, insPt] = genImplicitLoops(shape, /*innerArg=*/{});
3744 f(iterSpace);
3745 finalizeElementCtx();
3746 builder.restoreInsertionPoint(insPt);
3747 }
3748
3749 ExtValue lowerScalarAssignment(const Fortran::lower::SomeExpr &lhs,
3750 const Fortran::lower::SomeExpr &rhs) {
3751 PushSemantics(ConstituentSemantics::RefTransparent);
3752 // 1) Lower the rhs expression with array_fetch op(s).
3753 IterationSpace iters;
3754 iters.setElement(genarr(rhs)(iters));
3755 // 2) Lower the lhs expression to an array_update.
3756 semant = ConstituentSemantics::ProjectedCopyInCopyOut;
3757 auto lexv = genarr(lhs)(iters);
3758 // 3) Finalize the inner context.
3759 explicitSpace->finalizeContext();
3760 // 4) Thread the array value updated forward. Note: the lhs might be
3761 // ill-formed (performing scalar assignment in an array context),
3762 // in which case there is no array to thread.
3763 auto loc = getLoc();
3764 auto createResult = [&](auto op) {
3765 mlir::Value oldInnerArg = op.getSequence();
3766 std::size_t offset = explicitSpace->argPosition(oldInnerArg);
3767 explicitSpace->setInnerArg(offset, fir::getBase(lexv));
3768 finalizeElementCtx();
3769 builder.create<fir::ResultOp>(loc, fir::getBase(lexv));
3770 };
3771 if (mlir::Operation *defOp = fir::getBase(lexv).getDefiningOp()) {
3772 llvm::TypeSwitch<mlir::Operation *>(defOp)
3773 .Case([&](fir::ArrayUpdateOp op) { createResult(op); })
3774 .Case([&](fir::ArrayAmendOp op) { createResult(op); })
3775 .Case([&](fir::ArrayModifyOp op) { createResult(op); })
3776 .Default([&](mlir::Operation *) { finalizeElementCtx(); });
3777 } else {
3778 // `lhs` isn't from a `fir.array_load`, so there is no array modifications
3779 // to thread through the iteration space.
3780 finalizeElementCtx();
3781 }
3782 return lexv;
3783 }
3784
3785 static ExtValue lowerScalarUserAssignment(
3786 Fortran::lower::AbstractConverter &converter,
3787 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
3788 Fortran::lower::ExplicitIterSpace &explicitIterSpace,
3789 mlir::func::FuncOp userAssignmentFunction,
3790 const Fortran::lower::SomeExpr &lhs,
3791 const Fortran::lower::SomeExpr &rhs) {
3792 Fortran::lower::ImplicitIterSpace implicit;
3793 ArrayExprLowering ael(converter, stmtCtx, symMap,
3794 ConstituentSemantics::RefTransparent,
3795 &explicitIterSpace, &implicit);
3796 return ael.lowerScalarUserAssignment(userAssignmentFunction, lhs, rhs);
3797 }
3798
3799 ExtValue lowerScalarUserAssignment(mlir::func::FuncOp userAssignment,
3800 const Fortran::lower::SomeExpr &lhs,
3801 const Fortran::lower::SomeExpr &rhs) {
3802 mlir::Location loc = getLoc();
3803 if (rhs.Rank() > 0)
3804 TODO(loc, "user-defined elemental assigment from expression with rank");
3805 // 1) Lower the rhs expression with array_fetch op(s).
3806 IterationSpace iters;
3807 iters.setElement(genarr(rhs)(iters));
3808 fir::ExtendedValue elementalExv = iters.elementExv();
3809 // 2) Lower the lhs expression to an array_modify.
3810 semant = ConstituentSemantics::CustomCopyInCopyOut;
3811 auto lexv = genarr(lhs)(iters);
3812 bool isIllFormedLHS = false;
3813 // 3) Insert the call
3814 if (auto modifyOp = mlir::dyn_cast<fir::ArrayModifyOp>(
3815 fir::getBase(lexv).getDefiningOp())) {
3816 mlir::Value oldInnerArg = modifyOp.getSequence();
3817 std::size_t offset = explicitSpace->argPosition(oldInnerArg);
3818 explicitSpace->setInnerArg(offset, fir::getBase(lexv));
3819 auto lhsLoad = explicitSpace->getLhsLoad(0);
3820 assert(lhsLoad.has_value());
3821 fir::ExtendedValue exv =
3822 arrayModifyToExv(builder, loc, *lhsLoad, modifyOp.getResult(0));
3823 genScalarUserDefinedAssignmentCall(builder, loc, userAssignment, exv,
3824 elementalExv);
3825 } else {
3826 // LHS is ill formed, it is a scalar with no references to FORALL
3827 // subscripts, so there is actually no array assignment here. The user
3828 // code is probably bad, but still insert user assignment call since it
3829 // was not rejected by semantics (a warning was emitted).
3830 isIllFormedLHS = true;
3831 genScalarUserDefinedAssignmentCall(builder, getLoc(), userAssignment,
3832 lexv, elementalExv);
3833 }
3834 // 4) Finalize the inner context.
3835 explicitSpace->finalizeContext();
3836 // 5). Thread the array value updated forward.
3837 if (!isIllFormedLHS) {
3838 finalizeElementCtx();
3839 builder.create<fir::ResultOp>(getLoc(), fir::getBase(lexv));
3840 }
3841 return lexv;
3842 }
3843
3844private:
3845 void determineShapeOfDest(const fir::ExtendedValue &lhs) {
3846 destShape = fir::factory::getExtents(getLoc(), builder, lhs);
3847 }
3848
3849 void determineShapeOfDest(const Fortran::lower::SomeExpr &lhs) {
3850 if (!destShape.empty())
3851 return;
3852 if (explicitSpaceIsActive() && determineShapeWithSlice(lhs))
3853 return;
3854 mlir::Type idxTy = builder.getIndexType();
3855 mlir::Location loc = getLoc();
3856 if (std::optional<Fortran::evaluate::ConstantSubscripts> constantShape =
3857 Fortran::evaluate::GetConstantExtents(converter.getFoldingContext(),
3858 lhs))
3859 for (Fortran::common::ConstantSubscript extent : *constantShape)
3860 destShape.push_back(builder.createIntegerConstant(loc, idxTy, extent));
3861 }
3862
3863 bool genShapeFromDataRef(const Fortran::semantics::Symbol &x) {
3864 return false;
3865 }
3866 bool genShapeFromDataRef(const Fortran::evaluate::CoarrayRef &) {
3867 TODO(getLoc(), "coarray: reference to a coarray in an expression");
3868 return false;
3869 }
3870 bool genShapeFromDataRef(const Fortran::evaluate::Component &x) {
3871 return x.base().Rank() > 0 ? genShapeFromDataRef(x.base()) : false;
3872 }
3873 bool genShapeFromDataRef(const Fortran::evaluate::ArrayRef &x) {
3874 if (x.Rank() == 0)
3875 return false;
3876 if (x.base().Rank() > 0)
3877 if (genShapeFromDataRef(x.base()))
3878 return true;
3879 // x has rank and x.base did not produce a shape.
3880 ExtValue exv = x.base().IsSymbol() ? asScalarRef(getFirstSym(x.base()))
3881 : asScalarRef(x.base().GetComponent());
3882 mlir::Location loc = getLoc();
3883 mlir::IndexType idxTy = builder.getIndexType();
3884 llvm::SmallVector<mlir::Value> definedShape =
3885 fir::factory::getExtents(loc, builder, exv);
3886 mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
3887 for (auto ss : llvm::enumerate(x.subscript())) {
3888 Fortran::common::visit(
3889 Fortran::common::visitors{
3890 [&](const Fortran::evaluate::Triplet &trip) {
3891 // For a subscript of triple notation, we compute the
3892 // range of this dimension of the iteration space.
3893 auto lo = [&]() {
3894 if (auto optLo = trip.lower())
3895 return fir::getBase(asScalar(*optLo));
3896 return getLBound(exv, ss.index(), one);
3897 }();
3898 auto hi = [&]() {
3899 if (auto optHi = trip.upper())
3900 return fir::getBase(asScalar(*optHi));
3901 return getUBound(exv, ss.index(), one);
3902 }();
3903 auto step = builder.createConvert(
3904 loc, idxTy, fir::getBase(asScalar(trip.stride())));
3905 auto extent =
3906 builder.genExtentFromTriplet(loc, lo, hi, step, idxTy);
3907 destShape.push_back(extent);
3908 },
3909 [&](auto) {}},
3910 ss.value().u);
3911 }
3912 return true;
3913 }
3914 bool genShapeFromDataRef(const Fortran::evaluate::NamedEntity &x) {
3915 if (x.IsSymbol())
3916 return genShapeFromDataRef(getFirstSym(x));
3917 return genShapeFromDataRef(x.GetComponent());
3918 }
3919 bool genShapeFromDataRef(const Fortran::evaluate::DataRef &x) {
3920 return Fortran::common::visit(
3921 [&](const auto &v) { return genShapeFromDataRef(v); }, x.u);
3922 }
3923
3924 /// When in an explicit space, the ranked component must be evaluated to
3925 /// determine the actual number of iterations when slicing triples are
3926 /// present. Lower these expressions here.
3927 bool determineShapeWithSlice(const Fortran::lower::SomeExpr &lhs) {
3928 LLVM_DEBUG(Fortran::semantics::DumpEvaluateExpr::Dump(
3929 llvm::dbgs() << "determine shape of:\n", lhs));
3930 // FIXME: We may not want to use ExtractDataRef here since it doesn't deal
3931 // with substrings, etc.
3932 std::optional<Fortran::evaluate::DataRef> dref =
3933 Fortran::evaluate::ExtractDataRef(lhs);
3934 return dref.has_value() ? genShapeFromDataRef(*dref) : false;
3935 }
3936
3937 /// CHARACTER and derived type elements are treated as memory references. The
3938 /// numeric types are treated as values.
3939 static mlir::Type adjustedArraySubtype(mlir::Type ty,
3940 mlir::ValueRange indices) {
3941 mlir::Type pathTy = fir::applyPathToType(ty, indices);
3942 assert(pathTy && "indices failed to apply to type");
3943 return adjustedArrayElementType(pathTy);
3944 }
3945
3946 /// Lower rhs of an array expression.
3947 ExtValue lowerArrayExpression(const Fortran::lower::SomeExpr &exp) {
3948 mlir::Type resTy = converter.genType(exp);
3949
3950 if (fir::isPolymorphicType(resTy) &&
3951 Fortran::evaluate::HasVectorSubscript(exp))
3952 TODO(getLoc(),
3953 "polymorphic array expression lowering with vector subscript");
3954
3955 return Fortran::common::visit(
3956 [&](const auto &e) { return lowerArrayExpression(genarr(e), resTy); },
3957 exp.u);
3958 }
3959 ExtValue lowerArrayExpression(const ExtValue &exv) {
3960 assert(!explicitSpace);
3961 mlir::Type resTy = fir::unwrapPassByRefType(fir::getBase(exv).getType());
3962 return lowerArrayExpression(genarr(exv), resTy);
3963 }
3964
3965 void populateBounds(llvm::SmallVectorImpl<mlir::Value> &bounds,
3966 const Fortran::evaluate::Substring *substring) {
3967 if (!substring)
3968 return;
3969 bounds.push_back(fir::getBase(asScalar(substring->lower())));
3970 if (auto upper = substring->upper())
3971 bounds.push_back(fir::getBase(asScalar(*upper)));
3972 }
3973
3974 /// Convert the original value, \p origVal, to type \p eleTy. When in a
3975 /// pointer assignment context, generate an appropriate `fir.rebox` for
3976 /// dealing with any bounds parameters on the pointer assignment.
3977 mlir::Value convertElementForUpdate(mlir::Location loc, mlir::Type eleTy,
3978 mlir::Value origVal) {
3979 if (auto origEleTy = fir::dyn_cast_ptrEleTy(origVal.getType()))
3980 if (mlir::isa<fir::BaseBoxType>(origEleTy)) {
3981 // If origVal is a box variable, load it so it is in the value domain.
3982 origVal = builder.create<fir::LoadOp>(loc, origVal);
3983 }
3984 if (mlir::isa<fir::BoxType>(origVal.getType()) &&
3985 !mlir::isa<fir::BoxType>(eleTy)) {
3986 if (isPointerAssignment())
3987 TODO(loc, "lhs of pointer assignment returned unexpected value");
3988 TODO(loc, "invalid box conversion in elemental computation");
3989 }
3990 if (isPointerAssignment() && mlir::isa<fir::BoxType>(eleTy) &&
3991 !mlir::isa<fir::BoxType>(origVal.getType())) {
3992 // This is a pointer assignment and the rhs is a raw reference to a TARGET
3993 // in memory. Embox the reference so it can be stored to the boxed
3994 // POINTER variable.
3995 assert(fir::isa_ref_type(origVal.getType()));
3996 if (auto eleTy = fir::dyn_cast_ptrEleTy(origVal.getType());
3997 fir::hasDynamicSize(eleTy))
3998 TODO(loc, "TARGET of pointer assignment with runtime size/shape");
3999 auto memrefTy = fir::boxMemRefType(mlir::cast<fir::BoxType>(eleTy));
4000 auto castTo = builder.createConvert(loc, memrefTy, origVal);
4001 origVal = builder.create<fir::EmboxOp>(loc, eleTy, castTo);
4002 }
4003 mlir::Value val = builder.convertWithSemantics(loc, eleTy, origVal);
4004 if (isBoundsSpec()) {
4005 assert(lbounds.has_value());
4006 auto lbs = *lbounds;
4007 if (lbs.size() > 0) {
4008 // Rebox the value with user-specified shift.
4009 auto shiftTy = fir::ShiftType::get(eleTy.getContext(), lbs.size());
4010 mlir::Value shiftOp = builder.create<fir::ShiftOp>(loc, shiftTy, lbs);
4011 val = builder.create<fir::ReboxOp>(loc, eleTy, val, shiftOp,
4012 mlir::Value{});
4013 }
4014 } else if (isBoundsRemap()) {
4015 assert(lbounds.has_value());
4016 auto lbs = *lbounds;
4017 if (lbs.size() > 0) {
4018 // Rebox the value with user-specified shift and shape.
4019 assert(ubounds.has_value());
4020 auto shapeShiftArgs = flatZip(lbs, *ubounds);
4021 auto shapeTy = fir::ShapeShiftType::get(eleTy.getContext(), lbs.size());
4022 mlir::Value shapeShift =
4023 builder.create<fir::ShapeShiftOp>(loc, shapeTy, shapeShiftArgs);
4024 val = builder.create<fir::ReboxOp>(loc, eleTy, val, shapeShift,
4025 mlir::Value{});
4026 }
4027 }
4028 return val;
4029 }
4030
4031 /// Default store to destination implementation.
4032 /// This implements the default case, which is to assign the value in
4033 /// `iters.element` into the destination array, `iters.innerArgument`. Handles
4034 /// by value and by reference assignment.
4035 CC defaultStoreToDestination(const Fortran::evaluate::Substring *substring) {
4036 return [=](IterSpace iterSpace) -> ExtValue {
4037 mlir::Location loc = getLoc();
4038 mlir::Value innerArg = iterSpace.innerArgument();
4039 fir::ExtendedValue exv = iterSpace.elementExv();
4040 mlir::Type arrTy = innerArg.getType();
4041 mlir::Type eleTy = fir::applyPathToType(arrTy, iterSpace.iterVec());
4042 if (isAdjustedArrayElementType(eleTy)) {
4043 // The elemental update is in the memref domain. Under this semantics,
4044 // we must always copy the computed new element from its location in
4045 // memory into the destination array.
4046 mlir::Type resRefTy = builder.getRefType(eleTy);
4047 // Get a reference to the array element to be amended.
4048 auto arrayOp = builder.create<fir::ArrayAccessOp>(
4049 loc, resRefTy, innerArg, iterSpace.iterVec(),
4050 fir::factory::getTypeParams(loc, builder, destination));
4051 if (auto charTy = mlir::dyn_cast<fir::CharacterType>(eleTy)) {
4052 llvm::SmallVector<mlir::Value> substringBounds;
4053 populateBounds(substringBounds, substring);
4054 mlir::Value dstLen = fir::factory::genLenOfCharacter(
4055 builder, loc, destination, iterSpace.iterVec(), substringBounds);
4056 fir::ArrayAmendOp amend = createCharArrayAmend(
4057 loc, builder, arrayOp, dstLen, exv, innerArg, substringBounds);
4058 return abstractArrayExtValue(amend, dstLen);
4059 }
4060 if (fir::isa_derived(eleTy)) {
4061 fir::ArrayAmendOp amend = createDerivedArrayAmend(
4062 loc, destination, builder, arrayOp, exv, eleTy, innerArg);
4063 return abstractArrayExtValue(amend /*FIXME: typeparams?*/);
4064 }
4065 assert(mlir::isa<fir::SequenceType>(eleTy) && "must be an array");
4066 TODO(loc, "array (as element) assignment");
4067 }
4068 // By value semantics. The element is being assigned by value.
4069 auto ele = convertElementForUpdate(loc, eleTy, fir::getBase(exv));
4070 auto update = builder.create<fir::ArrayUpdateOp>(
4071 loc, arrTy, innerArg, ele, iterSpace.iterVec(),
4072 destination.getTypeparams());
4073 return abstractArrayExtValue(update);
4074 };
4075 }
4076
4077 /// For an elemental array expression.
4078 /// 1. Lower the scalars and array loads.
4079 /// 2. Create the iteration space.
4080 /// 3. Create the element-by-element computation in the loop.
4081 /// 4. Return the resulting array value.
4082 /// If no destination was set in the array context, a temporary of
4083 /// \p resultTy will be created to hold the evaluated expression.
4084 /// Otherwise, \p resultTy is ignored and the expression is evaluated
4085 /// in the destination. \p f is a continuation built from an
4086 /// evaluate::Expr or an ExtendedValue.
4087 ExtValue lowerArrayExpression(CC f, mlir::Type resultTy) {
4088 mlir::Location loc = getLoc();
4089 auto [iterSpace, insPt] = genIterSpace(resultTy);
4090 auto exv = f(iterSpace);
4091 iterSpace.setElement(std::move(exv));
4092 auto lambda = ccStoreToDest
4093 ? *ccStoreToDest
4094 : defaultStoreToDestination(/*substring=*/nullptr);
4095 mlir::Value updVal = fir::getBase(lambda(iterSpace));
4096 finalizeElementCtx();
4097 builder.create<fir::ResultOp>(loc, updVal);
4098 builder.restoreInsertionPoint(insPt);
4099 return abstractArrayExtValue(iterSpace.outerResult());
4100 }
4101
4102 /// Compute the shape of a slice.
4103 llvm::SmallVector<mlir::Value> computeSliceShape(mlir::Value slice) {
4104 llvm::SmallVector<mlir::Value> slicedShape;
4105 auto slOp = mlir::cast<fir::SliceOp>(slice.getDefiningOp());
4106 mlir::Operation::operand_range triples = slOp.getTriples();
4107 mlir::IndexType idxTy = builder.getIndexType();
4108 mlir::Location loc = getLoc();
4109 for (unsigned i = 0, end = triples.size(); i < end; i += 3) {
4110 if (!mlir::isa_and_nonnull<fir::UndefOp>(
4111 triples[i + 1].getDefiningOp())) {
4112 // (..., lb:ub:step, ...) case: extent = max((ub-lb+step)/step, 0)
4113 // See Fortran 2018 9.5.3.3.2 section for more details.
4114 mlir::Value res = builder.genExtentFromTriplet(
4115 loc, triples[i], triples[i + 1], triples[i + 2], idxTy);
4116 slicedShape.emplace_back(res);
4117 } else {
4118 // do nothing. `..., i, ...` case, so dimension is dropped.
4119 }
4120 }
4121 return slicedShape;
4122 }
4123
4124 /// Get the shape from an ArrayOperand. The shape of the array is adjusted if
4125 /// the array was sliced.
4126 llvm::SmallVector<mlir::Value> getShape(ArrayOperand array) {
4127 if (array.slice)
4128 return computeSliceShape(array.slice);
4129 if (mlir::isa<fir::BaseBoxType>(array.memref.getType()))
4130 return fir::factory::readExtents(builder, getLoc(),
4131 fir::BoxValue{array.memref});
4132 return fir::factory::getExtents(array.shape);
4133 }
4134
4135 /// Get the shape from an ArrayLoad.
4136 llvm::SmallVector<mlir::Value> getShape(fir::ArrayLoadOp arrayLoad) {
4137 return getShape(ArrayOperand{arrayLoad.getMemref(), arrayLoad.getShape(),
4138 arrayLoad.getSlice()});
4139 }
4140
4141 /// Returns the first array operand that may not be absent. If all
4142 /// array operands may be absent, return the first one.
4143 const ArrayOperand &getInducingShapeArrayOperand() const {
4144 assert(!arrayOperands.empty());
4145 for (const ArrayOperand &op : arrayOperands)
4146 if (!op.mayBeAbsent)
4147 return op;
4148 // If all arrays operand appears in optional position, then none of them
4149 // is allowed to be absent as per 15.5.2.12 point 3. (6). Just pick the
4150 // first operands.
4151 // TODO: There is an opportunity to add a runtime check here that
4152 // this array is present as required.
4153 return arrayOperands[0];
4154 }
4155
4156 /// Generate the shape of the iteration space over the array expression. The
4157 /// iteration space may be implicit, explicit, or both. If it is implied it is
4158 /// based on the destination and operand array loads, or an optional
4159 /// Fortran::evaluate::Shape from the front end. If the shape is explicit,
4160 /// this returns any implicit shape component, if it exists.
4161 llvm::SmallVector<mlir::Value> genIterationShape() {
4162 // Use the precomputed destination shape.
4163 if (!destShape.empty())
4164 return destShape;
4165 // Otherwise, use the destination's shape.
4166 if (destination)
4167 return getShape(destination);
4168 // Otherwise, use the first ArrayLoad operand shape.
4169 if (!arrayOperands.empty())
4170 return getShape(getInducingShapeArrayOperand());
4171 // Otherwise, in elemental context, try to find the passed object and
4172 // retrieve the iteration shape from it.
4173 if (loweredProcRef && loweredProcRef->IsElemental()) {
4174 const std::optional<Fortran::evaluate::ActualArgument> passArg =
4175 extractPassedArgFromProcRef(*loweredProcRef, converter);
4176 if (passArg) {
4177 ExtValue exv = asScalarRef(*passArg->UnwrapExpr());
4178 fir::FirOpBuilder *builder = &converter.getFirOpBuilder();
4179 auto extents = fir::factory::getExtents(getLoc(), *builder, exv);
4180 if (extents.size() == 0)
4181 TODO(getLoc(), "getting shape from polymorphic array in elemental "
4182 "procedure reference");
4183 return extents;
4184 }
4185 }
4186 fir::emitFatalError(getLoc(),
4187 "failed to compute the array expression shape");
4188 }
4189
4190 bool explicitSpaceIsActive() const {
4191 return explicitSpace && explicitSpace->isActive();
4192 }
4193
4194 bool implicitSpaceHasMasks() const {
4195 return implicitSpace && !implicitSpace->empty();
4196 }
4197
4198 CC genMaskAccess(mlir::Value tmp, mlir::Value shape) {
4199 mlir::Location loc = getLoc();
4200 return [=, builder = &converter.getFirOpBuilder()](IterSpace iters) {
4201 mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(tmp.getType());
4202 auto eleTy = mlir::cast<fir::SequenceType>(arrTy).getElementType();
4203 mlir::Type eleRefTy = builder->getRefType(eleTy);
4204 mlir::IntegerType i1Ty = builder->getI1Type();
4205 // Adjust indices for any shift of the origin of the array.
4206 llvm::SmallVector<mlir::Value> indices = fir::factory::originateIndices(
4207 loc, *builder, tmp.getType(), shape, iters.iterVec());
4208 auto addr =
4209 builder->create<fir::ArrayCoorOp>(loc, eleRefTy, tmp, shape,
4210 /*slice=*/mlir::Value{}, indices,
4211 /*typeParams=*/std::nullopt);
4212 auto load = builder->create<fir::LoadOp>(loc, addr);
4213 return builder->createConvert(loc, i1Ty, load);
4214 };
4215 }
4216
4217 /// Construct the incremental instantiations of the ragged array structure.
4218 /// Rebind the lazy buffer variable, etc. as we go.
4219 template <bool withAllocation = false>
4220 mlir::Value prepareRaggedArrays(Fortran::lower::FrontEndExpr expr) {
4221 assert(explicitSpaceIsActive());
4222 mlir::Location loc = getLoc();
4223 mlir::TupleType raggedTy = fir::factory::getRaggedArrayHeaderType(builder);
4224 llvm::SmallVector<llvm::SmallVector<fir::DoLoopOp>> loopStack =
4225 explicitSpace->getLoopStack();
4226 const std::size_t depth = loopStack.size();
4227 mlir::IntegerType i64Ty = builder.getIntegerType(64);
4228 [[maybe_unused]] mlir::Value byteSize =
4229 builder.createIntegerConstant(loc, i64Ty, 1);
4230 mlir::Value header = implicitSpace->lookupMaskHeader(expr);
4231 for (std::remove_const_t<decltype(depth)> i = 0; i < depth; ++i) {
4232 auto insPt = builder.saveInsertionPoint();
4233 if (i < depth - 1)
4234 builder.setInsertionPoint(loopStack[i + 1][0]);
4235
4236 // Compute and gather the extents.
4237 llvm::SmallVector<mlir::Value> extents;
4238 for (auto doLoop : loopStack[i])
4239 extents.push_back(builder.genExtentFromTriplet(
4240 loc, doLoop.getLowerBound(), doLoop.getUpperBound(),
4241 doLoop.getStep(), i64Ty));
4242 if constexpr (withAllocation) {
4243 fir::runtime::genRaggedArrayAllocate(
4244 loc, builder, header, /*asHeader=*/true, byteSize, extents);
4245 }
4246
4247 // Compute the dynamic position into the header.
4248 llvm::SmallVector<mlir::Value> offsets;
4249 for (auto doLoop : loopStack[i]) {
4250 auto m = builder.create<mlir::arith::SubIOp>(
4251 loc, doLoop.getInductionVar(), doLoop.getLowerBound());
4252 auto n = builder.create<mlir::arith::DivSIOp>(loc, m, doLoop.getStep());
4253 mlir::Value one = builder.createIntegerConstant(loc, n.getType(), 1);
4254 offsets.push_back(builder.create<mlir::arith::AddIOp>(loc, n, one));
4255 }
4256 mlir::IntegerType i32Ty = builder.getIntegerType(32);
4257 mlir::Value uno = builder.createIntegerConstant(loc, i32Ty, 1);
4258 mlir::Type coorTy = builder.getRefType(raggedTy.getType(1));
4259 auto hdOff = builder.create<fir::CoordinateOp>(loc, coorTy, header, uno);
4260 auto toTy = fir::SequenceType::get(raggedTy, offsets.size());
4261 mlir::Type toRefTy = builder.getRefType(toTy);
4262 auto ldHdr = builder.create<fir::LoadOp>(loc, hdOff);
4263 mlir::Value hdArr = builder.createConvert(loc, toRefTy, ldHdr);
4264 auto shapeOp = builder.genShape(loc, extents);
4265 header = builder.create<fir::ArrayCoorOp>(
4266 loc, builder.getRefType(raggedTy), hdArr, shapeOp,
4267 /*slice=*/mlir::Value{}, offsets,
4268 /*typeparams=*/mlir::ValueRange{});
4269 auto hdrVar = builder.create<fir::CoordinateOp>(loc, coorTy, header, uno);
4270 auto inVar = builder.create<fir::LoadOp>(loc, hdrVar);
4271 mlir::Value two = builder.createIntegerConstant(loc, i32Ty, 2);
4272 mlir::Type coorTy2 = builder.getRefType(raggedTy.getType(2));
4273 auto hdrSh = builder.create<fir::CoordinateOp>(loc, coorTy2, header, two);
4274 auto shapePtr = builder.create<fir::LoadOp>(loc, hdrSh);
4275 // Replace the binding.
4276 implicitSpace->rebind(expr, genMaskAccess(inVar, shapePtr));
4277 if (i < depth - 1)
4278 builder.restoreInsertionPoint(insPt);
4279 }
4280 return header;
4281 }
4282
4283 /// Lower mask expressions with implied iteration spaces from the variants of
4284 /// WHERE syntax. Since it is legal for mask expressions to have side-effects
4285 /// and modify values that will be used for the lhs, rhs, or both of
4286 /// subsequent assignments, the mask must be evaluated before the assignment
4287 /// is processed.
4288 /// Mask expressions are array expressions too.
4289 void genMasks() {
4290 // Lower the mask expressions, if any.
4291 if (implicitSpaceHasMasks()) {
4292 mlir::Location loc = getLoc();
4293 // Mask expressions are array expressions too.
4294 for (const auto *e : implicitSpace->getExprs())
4295 if (e && !implicitSpace->isLowered(e)) {
4296 if (mlir::Value var = implicitSpace->lookupMaskVariable(e)) {
4297 // Allocate the mask buffer lazily.
4298 assert(explicitSpaceIsActive());
4299 mlir::Value header =
4300 prepareRaggedArrays</*withAllocations=*/true>(e);
4301 Fortran::lower::createLazyArrayTempValue(converter, *e, header,
4302 symMap, stmtCtx);
4303 // Close the explicit loops.
4304 builder.create<fir::ResultOp>(loc, explicitSpace->getInnerArgs());
4305 builder.setInsertionPointAfter(explicitSpace->getOuterLoop());
4306 // Open a new copy of the explicit loop nest.
4307 explicitSpace->genLoopNest();
4308 continue;
4309 }
4310 fir::ExtendedValue tmp = Fortran::lower::createSomeArrayTempValue(
4311 converter, *e, symMap, stmtCtx);
4312 mlir::Value shape = builder.createShape(loc, tmp);
4313 implicitSpace->bind(e, genMaskAccess(fir::getBase(tmp), shape));
4314 }
4315
4316 // Set buffer from the header.
4317 for (const auto *e : implicitSpace->getExprs()) {
4318 if (!e)
4319 continue;
4320 if (implicitSpace->lookupMaskVariable(e)) {
4321 // Index into the ragged buffer to retrieve cached results.
4322 const int rank = e->Rank();
4323 assert(destShape.empty() ||
4324 static_cast<std::size_t>(rank) == destShape.size());
4325 mlir::Value header = prepareRaggedArrays(e);
4326 mlir::TupleType raggedTy =
4327 fir::factory::getRaggedArrayHeaderType(builder);
4328 mlir::IntegerType i32Ty = builder.getIntegerType(32);
4329 mlir::Value one = builder.createIntegerConstant(loc, i32Ty, 1);
4330 auto coor1 = builder.create<fir::CoordinateOp>(
4331 loc, builder.getRefType(raggedTy.getType(1)), header, one);
4332 auto db = builder.create<fir::LoadOp>(loc, coor1);
4333 mlir::Type eleTy =
4334 fir::unwrapSequenceType(fir::unwrapRefType(db.getType()));
4335 mlir::Type buffTy =
4336 builder.getRefType(fir::SequenceType::get(eleTy, rank));
4337 // Address of ragged buffer data.
4338 mlir::Value buff = builder.createConvert(loc, buffTy, db);
4339
4340 mlir::Value two = builder.createIntegerConstant(loc, i32Ty, 2);
4341 auto coor2 = builder.create<fir::CoordinateOp>(
4342 loc, builder.getRefType(raggedTy.getType(2)), header, two);
4343 auto shBuff = builder.create<fir::LoadOp>(loc, coor2);
4344 mlir::IntegerType i64Ty = builder.getIntegerType(64);
4345 mlir::IndexType idxTy = builder.getIndexType();
4346 llvm::SmallVector<mlir::Value> extents;
4347 for (std::remove_const_t<decltype(rank)> i = 0; i < rank; ++i) {
4348 mlir::Value off = builder.createIntegerConstant(loc, i32Ty, i);
4349 auto coor = builder.create<fir::CoordinateOp>(
4350 loc, builder.getRefType(i64Ty), shBuff, off);
4351 auto ldExt = builder.create<fir::LoadOp>(loc, coor);
4352 extents.push_back(builder.createConvert(loc, idxTy, ldExt));
4353 }
4354 if (destShape.empty())
4355 destShape = extents;
4356 // Construct shape of buffer.
4357 mlir::Value shapeOp = builder.genShape(loc, extents);
4358
4359 // Replace binding with the local result.
4360 implicitSpace->rebind(e, genMaskAccess(buff, shapeOp));
4361 }
4362 }
4363 }
4364 }
4365
4366 // FIXME: should take multiple inner arguments.
4367 std::pair<IterationSpace, mlir::OpBuilder::InsertPoint>
4368 genImplicitLoops(mlir::ValueRange shape, mlir::Value innerArg) {
4369 mlir::Location loc = getLoc();
4370 mlir::IndexType idxTy = builder.getIndexType();
4371 mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
4372 mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0);
4373 llvm::SmallVector<mlir::Value> loopUppers;
4374
4375 // Convert any implied shape to closed interval form. The fir.do_loop will
4376 // run from 0 to `extent - 1` inclusive.
4377 for (auto extent : shape)
4378 loopUppers.push_back(
4379 builder.create<mlir::arith::SubIOp>(loc, extent, one));
4380
4381 // Iteration space is created with outermost columns, innermost rows
4382 llvm::SmallVector<fir::DoLoopOp> loops;
4383
4384 const std::size_t loopDepth = loopUppers.size();
4385 llvm::SmallVector<mlir::Value> ivars;
4386
4387 for (auto i : llvm::enumerate(llvm::reverse(loopUppers))) {
4388 if (i.index() > 0) {
4389 assert(!loops.empty());
4390 builder.setInsertionPointToStart(loops.back().getBody());
4391 }
4392 fir::DoLoopOp loop;
4393 if (innerArg) {
4394 loop = builder.create<fir::DoLoopOp>(
4395 loc, zero, i.value(), one, isUnordered(),
4396 /*finalCount=*/false, mlir::ValueRange{innerArg});
4397 innerArg = loop.getRegionIterArgs().front();
4398 if (explicitSpaceIsActive())
4399 explicitSpace->setInnerArg(0, innerArg);
4400 } else {
4401 loop = builder.create<fir::DoLoopOp>(loc, zero, i.value(), one,
4402 isUnordered(),
4403 /*finalCount=*/false);
4404 }
4405 ivars.push_back(loop.getInductionVar());
4406 loops.push_back(loop);
4407 }
4408
4409 if (innerArg)
4410 for (std::remove_const_t<decltype(loopDepth)> i = 0; i + 1 < loopDepth;
4411 ++i) {
4412 builder.setInsertionPointToEnd(loops[i].getBody());
4413 builder.create<fir::ResultOp>(loc, loops[i + 1].getResult(0));
4414 }
4415
4416 // Move insertion point to the start of the innermost loop in the nest.
4417 builder.setInsertionPointToStart(loops.back().getBody());
4418 // Set `afterLoopNest` to just after the entire loop nest.
4419 auto currPt = builder.saveInsertionPoint();
4420 builder.setInsertionPointAfter(loops[0]);
4421 auto afterLoopNest = builder.saveInsertionPoint();
4422 builder.restoreInsertionPoint(currPt);
4423
4424 // Put the implicit loop variables in row to column order to match FIR's
4425 // Ops. (The loops were constructed from outermost column to innermost
4426 // row.)
4427 mlir::Value outerRes;
4428 if (loops[0].getNumResults() != 0)
4429 outerRes = loops[0].getResult(0);
4430 return {IterationSpace(innerArg, outerRes, llvm::reverse(ivars)),
4431 afterLoopNest};
4432 }
4433
4434 /// Build the iteration space into which the array expression will be lowered.
4435 /// The resultType is used to create a temporary, if needed.
4436 std::pair<IterationSpace, mlir::OpBuilder::InsertPoint>
4437 genIterSpace(mlir::Type resultType) {
4438 mlir::Location loc = getLoc();
4439 llvm::SmallVector<mlir::Value> shape = genIterationShape();
4440 if (!destination) {
4441 // Allocate storage for the result if it is not already provided.
4442 destination = createAndLoadSomeArrayTemp(resultType, shape);
4443 }
4444
4445 // Generate the lazy mask allocation, if one was given.
4446 if (ccPrelude)
4447 (*ccPrelude)(shape);
4448
4449 // Now handle the implicit loops.
4450 mlir::Value inner = explicitSpaceIsActive()
4451 ? explicitSpace->getInnerArgs().front()
4452 : destination.getResult();
4453 auto [iters, afterLoopNest] = genImplicitLoops(shape, inner);
4454 mlir::Value innerArg = iters.innerArgument();
4455
4456 // Generate the mask conditional structure, if there are masks. Unlike the
4457 // explicit masks, which are interleaved, these mask expression appear in
4458 // the innermost loop.
4459 if (implicitSpaceHasMasks()) {
4460 // Recover the cached condition from the mask buffer.
4461 auto genCond = [&](Fortran::lower::FrontEndExpr e, IterSpace iters) {
4462 return implicitSpace->getBoundClosure(e)(iters);
4463 };
4464
4465 // Handle the negated conditions in topological order of the WHERE
4466 // clauses. See 10.2.3.2p4 as to why this control structure is produced.
4467 for (llvm::SmallVector<Fortran::lower::FrontEndExpr> maskExprs :
4468 implicitSpace->getMasks()) {
4469 const std::size_t size = maskExprs.size() - 1;
4470 auto genFalseBlock = [&](const auto *e, auto &&cond) {
4471 auto ifOp = builder.create<fir::IfOp>(
4472 loc, mlir::TypeRange{innerArg.getType()}, fir::getBase(cond),
4473 /*withElseRegion=*/true);
4474 builder.create<fir::ResultOp>(loc, ifOp.getResult(0));
4475 builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
4476 builder.create<fir::ResultOp>(loc, innerArg);
4477 builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
4478 };
4479 auto genTrueBlock = [&](const auto *e, auto &&cond) {
4480 auto ifOp = builder.create<fir::IfOp>(
4481 loc, mlir::TypeRange{innerArg.getType()}, fir::getBase(cond),
4482 /*withElseRegion=*/true);
4483 builder.create<fir::ResultOp>(loc, ifOp.getResult(0));
4484 builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
4485 builder.create<fir::ResultOp>(loc, innerArg);
4486 builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
4487 };
4488 for (std::remove_const_t<decltype(size)> i = 0; i < size; ++i)
4489 if (const auto *e = maskExprs[i])
4490 genFalseBlock(e, genCond(e, iters));
4491
4492 // The last condition is either non-negated or unconditionally negated.
4493 if (const auto *e = maskExprs[size])
4494 genTrueBlock(e, genCond(e, iters));
4495 }
4496 }
4497
4498 // We're ready to lower the body (an assignment statement) for this context
4499 // of loop nests at this point.
4500 return {iters, afterLoopNest};
4501 }
4502
4503 fir::ArrayLoadOp
4504 createAndLoadSomeArrayTemp(mlir::Type type,
4505 llvm::ArrayRef<mlir::Value> shape) {
4506 mlir::Location loc = getLoc();
4507 if (fir::isPolymorphicType(type))
4508 TODO(loc, "polymorphic array temporary");
4509 if (ccLoadDest)
4510 return (*ccLoadDest)(shape);
4511 auto seqTy = mlir::dyn_cast<fir::SequenceType>(type);
4512 assert(seqTy && "must be an array");
4513 // TODO: Need to thread the LEN parameters here. For character, they may
4514 // differ from the operands length (e.g concatenation). So the array loads
4515 // type parameters are not enough.
4516 if (auto charTy = mlir::dyn_cast<fir::CharacterType>(seqTy.getEleTy()))
4517 if (charTy.hasDynamicLen())
4518 TODO(loc, "character array expression temp with dynamic length");
4519 if (auto recTy = mlir::dyn_cast<fir::RecordType>(seqTy.getEleTy()))
4520 if (recTy.getNumLenParams() > 0)
4521 TODO(loc, "derived type array expression temp with LEN parameters");
4522 if (mlir::Type eleTy = fir::unwrapSequenceType(type);
4523 fir::isRecordWithAllocatableMember(eleTy))
4524 TODO(loc, "creating an array temp where the element type has "
4525 "allocatable members");
4526 mlir::Value temp = !seqTy.hasDynamicExtents()
4527 ? builder.create<fir::AllocMemOp>(loc, type)
4528 : builder.create<fir::AllocMemOp>(
4529 loc, type, ".array.expr", std::nullopt, shape);
4530 fir::FirOpBuilder *bldr = &converter.getFirOpBuilder();
4531 stmtCtx.attachCleanup(
4532 [bldr, loc, temp]() { bldr->create<fir::FreeMemOp>(loc, temp); });
4533 mlir::Value shapeOp = genShapeOp(shape);
4534 return builder.create<fir::ArrayLoadOp>(loc, seqTy, temp, shapeOp,
4535 /*slice=*/mlir::Value{},
4536 std::nullopt);
4537 }
4538
4539 static fir::ShapeOp genShapeOp(mlir::Location loc, fir::FirOpBuilder &builder,
4540 llvm::ArrayRef<mlir::Value> shape) {
4541 mlir::IndexType idxTy = builder.getIndexType();
4542 llvm::SmallVector<mlir::Value> idxShape;
4543 for (auto s : shape)
4544 idxShape.push_back(builder.createConvert(loc, idxTy, s));
4545 return builder.create<fir::ShapeOp>(loc, idxShape);
4546 }
4547
4548 fir::ShapeOp genShapeOp(llvm::ArrayRef<mlir::Value> shape) {
4549 return genShapeOp(getLoc(), builder, shape);
4550 }
4551
4552 //===--------------------------------------------------------------------===//
4553 // Expression traversal and lowering.
4554 //===--------------------------------------------------------------------===//
4555
4556 /// Lower the expression, \p x, in a scalar context.
4557 template <typename A>
4558 ExtValue asScalar(const A &x) {
4559 return ScalarExprLowering{getLoc(), converter, symMap, stmtCtx}.genval(x);
4560 }
4561
4562 /// Lower the expression, \p x, in a scalar context. If this is an explicit
4563 /// space, the expression may be scalar and refer to an array. We want to
4564 /// raise the array access to array operations in FIR to analyze potential
4565 /// conflicts even when the result is a scalar element.
4566 template <typename A>
4567 ExtValue asScalarArray(const A &x) {
4568 return explicitSpaceIsActive() && !isPointerAssignment()
4569 ? genarr(x)(IterationSpace{})
4570 : asScalar(x);
4571 }
4572
4573 /// Lower the expression in a scalar context to a memory reference.
4574 template <typename A>
4575 ExtValue asScalarRef(const A &x) {
4576 return ScalarExprLowering{getLoc(), converter, symMap, stmtCtx}.gen(x);
4577 }
4578
4579 /// Lower an expression without dereferencing any indirection that may be
4580 /// a nullptr (because this is an absent optional or unallocated/disassociated
4581 /// descriptor). The returned expression cannot be addressed directly, it is
4582 /// meant to inquire about its status before addressing the related entity.
4583 template <typename A>
4584 ExtValue asInquired(const A &x) {
4585 return ScalarExprLowering{getLoc(), converter, symMap, stmtCtx}
4586 .lowerIntrinsicArgumentAsInquired(x);
4587 }
4588
4589 /// Some temporaries are allocated on an element-by-element basis during the
4590 /// array expression evaluation. Collect the cleanups here so the resources
4591 /// can be freed before the next loop iteration, avoiding memory leaks. etc.
4592 Fortran::lower::StatementContext &getElementCtx() {
4593 if (!elementCtx) {
4594 stmtCtx.pushScope();
4595 elementCtx = true;
4596 }
4597 return stmtCtx;
4598 }
4599
4600 /// If there were temporaries created for this element evaluation, finalize
4601 /// and deallocate the resources now. This should be done just prior to the
4602 /// fir::ResultOp at the end of the innermost loop.
4603 void finalizeElementCtx() {
4604 if (elementCtx) {
4605 stmtCtx.finalizeAndPop();
4606 elementCtx = false;
4607 }
4608 }
4609
4610 /// Lower an elemental function array argument. This ensures array
4611 /// sub-expressions that are not variables and must be passed by address
4612 /// are lowered by value and placed in memory.
4613 template <typename A>
4614 CC genElementalArgument(const A &x) {
4615 // Ensure the returned element is in memory if this is what was requested.
4616 if ((semant == ConstituentSemantics::RefOpaque ||
4617 semant == ConstituentSemantics::DataAddr ||
4618 semant == ConstituentSemantics::ByValueArg)) {
4619 if (!Fortran::evaluate::IsVariable(x)) {
4620 PushSemantics(ConstituentSemantics::DataValue);
4621 CC cc = genarr(x);
4622 mlir::Location loc = getLoc();
4623 if (isParenthesizedVariable(x)) {
4624 // Parenthesised variables are lowered to a reference to the variable
4625 // storage. When passing it as an argument, a copy must be passed.
4626 return [=](IterSpace iters) -> ExtValue {
4627 return createInMemoryScalarCopy(builder, loc, cc(iters));
4628 };
4629 }
4630 mlir::Type storageType =
4631 fir::unwrapSequenceType(converter.genType(toEvExpr(x)));
4632 return [=](IterSpace iters) -> ExtValue {
4633 return placeScalarValueInMemory(builder, loc, cc(iters), storageType);
4634 };
4635 } else if (isArray(x)) {
4636 // An array reference is needed, but the indices used in its path must
4637 // still be retrieved by value.
4638 assert(!nextPathSemant && "Next path semantics already set!");
4639 nextPathSemant = ConstituentSemantics::RefTransparent;
4640 CC cc = genarr(x);
4641 assert(!nextPathSemant && "Next path semantics wasn't used!");
4642 return cc;
4643 }
4644 }
4645 return genarr(x);
4646 }
4647
4648 // A reference to a Fortran elemental intrinsic or intrinsic module procedure.
4649 CC genElementalIntrinsicProcRef(
4650 const Fortran::evaluate::ProcedureRef &procRef,
4651 std::optional<mlir::Type> retTy,
4652 std::optional<const Fortran::evaluate::SpecificIntrinsic> intrinsic =
4653 std::nullopt) {
4654
4655 llvm::SmallVector<CC> operands;
4656 std::string name =
4657 intrinsic ? intrinsic->name
4658 : procRef.proc().GetSymbol()->GetUltimate().name().ToString();
4659 const fir::IntrinsicArgumentLoweringRules *argLowering =
4660 fir::getIntrinsicArgumentLowering(name);
4661 mlir::Location loc = getLoc();
4662 if (intrinsic && Fortran::lower::intrinsicRequiresCustomOptionalHandling(
4663 procRef, *intrinsic, converter)) {
4664 using CcPairT = std::pair<CC, std::optional<mlir::Value>>;
4665 llvm::SmallVector<CcPairT> operands;
4666 auto prepareOptionalArg = [&](const Fortran::lower::SomeExpr &expr) {
4667 if (expr.Rank() == 0) {
4668 ExtValue optionalArg = this->asInquired(expr);
4669 mlir::Value isPresent =
4670 genActualIsPresentTest(builder, loc, optionalArg);
4671 operands.emplace_back(
4672 [=](IterSpace iters) -> ExtValue {
4673 return genLoad(builder, loc, optionalArg);
4674 },
4675 isPresent);
4676 } else {
4677 auto [cc, isPresent, _] = this->genOptionalArrayFetch(expr);
4678 operands.emplace_back(cc, isPresent);
4679 }
4680 };
4681 auto prepareOtherArg = [&](const Fortran::lower::SomeExpr &expr,
4682 fir::LowerIntrinsicArgAs lowerAs) {
4683 assert(lowerAs == fir::LowerIntrinsicArgAs::Value &&
4684 "expect value arguments for elemental intrinsic");
4685 PushSemantics(ConstituentSemantics::RefTransparent);
4686 operands.emplace_back(genElementalArgument(expr), std::nullopt);
4687 };
4688 Fortran::lower::prepareCustomIntrinsicArgument(
4689 procRef, *intrinsic, retTy, prepareOptionalArg, prepareOtherArg,
4690 converter);
4691
4692 fir::FirOpBuilder *bldr = &converter.getFirOpBuilder();
4693 return [=](IterSpace iters) -> ExtValue {
4694 auto getArgument = [&](std::size_t i, bool) -> ExtValue {
4695 return operands[i].first(iters);
4696 };
4697 auto isPresent = [&](std::size_t i) -> std::optional<mlir::Value> {
4698 return operands[i].second;
4699 };
4700 return Fortran::lower::lowerCustomIntrinsic(
4701 *bldr, loc, name, retTy, isPresent, getArgument, operands.size(),
4702 getElementCtx());
4703 };
4704 }
4705 /// Otherwise, pre-lower arguments and use intrinsic lowering utility.
4706 for (const auto &arg : llvm::enumerate(procRef.arguments())) {
4707 const auto *expr =
4708 Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
4709 if (!expr) {
4710 // Absent optional.
4711 operands.emplace_back([=](IterSpace) { return mlir::Value{}; });
4712 } else if (!argLowering) {
4713 // No argument lowering instruction, lower by value.
4714 PushSemantics(ConstituentSemantics::RefTransparent);
4715 operands.emplace_back(genElementalArgument(*expr));
4716 } else {
4717 // Ad-hoc argument lowering handling.
4718 fir::ArgLoweringRule argRules =
4719 fir::lowerIntrinsicArgumentAs(*argLowering, arg.index());
4720 if (argRules.handleDynamicOptional &&
4721 Fortran::evaluate::MayBePassedAsAbsentOptional(*expr)) {
4722 // Currently, there is not elemental intrinsic that requires lowering
4723 // a potentially absent argument to something else than a value (apart
4724 // from character MAX/MIN that are handled elsewhere.)
4725 if (argRules.lowerAs != fir::LowerIntrinsicArgAs::Value)
4726 TODO(loc, "non trivial optional elemental intrinsic array "
4727 "argument");
4728 PushSemantics(ConstituentSemantics::RefTransparent);
4729 operands.emplace_back(genarrForwardOptionalArgumentToCall(*expr));
4730 continue;
4731 }
4732 switch (argRules.lowerAs) {
4733 case fir::LowerIntrinsicArgAs::Value: {
4734 PushSemantics(ConstituentSemantics::RefTransparent);
4735 operands.emplace_back(genElementalArgument(*expr));
4736 } break;
4737 case fir::LowerIntrinsicArgAs::Addr: {
4738 // Note: assume does not have Fortran VALUE attribute semantics.
4739 PushSemantics(ConstituentSemantics::RefOpaque);
4740 operands.emplace_back(genElementalArgument(*expr));
4741 } break;
4742 case fir::LowerIntrinsicArgAs::Box: {
4743 PushSemantics(ConstituentSemantics::RefOpaque);
4744 auto lambda = genElementalArgument(*expr);
4745 operands.emplace_back([=](IterSpace iters) {
4746 return builder.createBox(loc, lambda(iters));
4747 });
4748 } break;
4749 case fir::LowerIntrinsicArgAs::Inquired:
4750 TODO(loc, "intrinsic function with inquired argument");
4751 break;
4752 }
4753 }
4754 }
4755
4756 // Let the intrinsic library lower the intrinsic procedure call
4757 return [=](IterSpace iters) {
4758 llvm::SmallVector<ExtValue> args;
4759 for (const auto &cc : operands)
4760 args.push_back(cc(iters));
4761 return Fortran::lower::genIntrinsicCall(builder, loc, name, retTy, args,
4762 getElementCtx());
4763 };
4764 }
4765
4766 /// Lower a procedure reference to a user-defined elemental procedure.
4767 CC genElementalUserDefinedProcRef(
4768 const Fortran::evaluate::ProcedureRef &procRef,
4769 std::optional<mlir::Type> retTy) {
4770 using PassBy = Fortran::lower::CallerInterface::PassEntityBy;
4771
4772 // 10.1.4 p5. Impure elemental procedures must be called in element order.
4773 if (const Fortran::semantics::Symbol *procSym = procRef.proc().GetSymbol())
4774 if (!Fortran::semantics::IsPureProcedure(*procSym))
4775 setUnordered(false);
4776
4777 Fortran::lower::CallerInterface caller(procRef, converter);
4778 llvm::SmallVector<CC> operands;
4779 operands.reserve(caller.getPassedArguments().size());
4780 mlir::Location loc = getLoc();
4781 mlir::FunctionType callSiteType = caller.genFunctionType();
4782 for (const Fortran::lower::CallInterface<
4783 Fortran::lower::CallerInterface>::PassedEntity &arg :
4784 caller.getPassedArguments()) {
4785 // 15.8.3 p1. Elemental procedure with intent(out)/intent(inout)
4786 // arguments must be called in element order.
4787 if (arg.mayBeModifiedByCall())
4788 setUnordered(false);
4789 const auto *actual = arg.entity;
4790 mlir::Type argTy = callSiteType.getInput(arg.firArgument);
4791 if (!actual) {
4792 // Optional dummy argument for which there is no actual argument.
4793 auto absent = builder.create<fir::AbsentOp>(loc, argTy);
4794 operands.emplace_back([=](IterSpace) { return absent; });
4795 continue;
4796 }
4797 const auto *expr = actual->UnwrapExpr();
4798 if (!expr)
4799 TODO(loc, "assumed type actual argument");
4800
4801 LLVM_DEBUG(expr->AsFortran(llvm::dbgs()
4802 << "argument: " << arg.firArgument << " = [")
4803 << "]\n");
4804 if (arg.isOptional() &&
4805 Fortran::evaluate::MayBePassedAsAbsentOptional(*expr))
4806 TODO(loc,
4807 "passing dynamically optional argument to elemental procedures");
4808 switch (arg.passBy) {
4809 case PassBy::Value: {
4810 // True pass-by-value semantics.
4811 PushSemantics(ConstituentSemantics::RefTransparent);
4812 operands.emplace_back(genElementalArgument(*expr));
4813 } break;
4814 case PassBy::BaseAddressValueAttribute: {
4815 // VALUE attribute or pass-by-reference to a copy semantics. (byval*)
4816 if (isArray(*expr)) {
4817 PushSemantics(ConstituentSemantics::ByValueArg);
4818 operands.emplace_back(genElementalArgument(*expr));
4819 } else {
4820 // Store scalar value in a temp to fulfill VALUE attribute.
4821 mlir::Value val = fir::getBase(asScalar(*expr));
4822 mlir::Value temp =
4823 builder.createTemporary(loc, val.getType(),
4824 llvm::ArrayRef<mlir::NamedAttribute>{
4825 fir::getAdaptToByRefAttr(builder)});
4826 builder.create<fir::StoreOp>(loc, val, temp);
4827 operands.emplace_back(
4828 [=](IterSpace iters) -> ExtValue { return temp; });
4829 }
4830 } break;
4831 case PassBy::BaseAddress: {
4832 if (isArray(*expr)) {
4833 PushSemantics(ConstituentSemantics::RefOpaque);
4834 operands.emplace_back(genElementalArgument(*expr));
4835 } else {
4836 ExtValue exv = asScalarRef(*expr);
4837 operands.emplace_back([=](IterSpace iters) { return exv; });
4838 }
4839 } break;
4840 case PassBy::CharBoxValueAttribute: {
4841 if (isArray(*expr)) {
4842 PushSemantics(ConstituentSemantics::DataValue);
4843 auto lambda = genElementalArgument(*expr);
4844 operands.emplace_back([=](IterSpace iters) {
4845 return fir::factory::CharacterExprHelper{builder, loc}
4846 .createTempFrom(lambda(iters));
4847 });
4848 } else {
4849 fir::factory::CharacterExprHelper helper(builder, loc);
4850 fir::CharBoxValue argVal = helper.createTempFrom(asScalarRef(*expr));
4851 operands.emplace_back(
4852 [=](IterSpace iters) -> ExtValue { return argVal; });
4853 }
4854 } break;
4855 case PassBy::BoxChar: {
4856 PushSemantics(ConstituentSemantics::RefOpaque);
4857 operands.emplace_back(genElementalArgument(*expr));
4858 } break;
4859 case PassBy::AddressAndLength:
4860 // PassBy::AddressAndLength is only used for character results. Results
4861 // are not handled here.
4862 fir::emitFatalError(
4863 loc, "unexpected PassBy::AddressAndLength in elemental call");
4864 break;
4865 case PassBy::CharProcTuple: {
4866 ExtValue argRef = asScalarRef(*expr);
4867 mlir::Value tuple = createBoxProcCharTuple(
4868 converter, argTy, fir::getBase(argRef), fir::getLen(argRef));
4869 operands.emplace_back(
4870 [=](IterSpace iters) -> ExtValue { return tuple; });
4871 } break;
4872 case PassBy::Box:
4873 case PassBy::MutableBox:
4874 // Handle polymorphic passed object.
4875 if (fir::isPolymorphicType(argTy)) {
4876 if (isArray(*expr)) {
4877 ExtValue exv = asScalarRef(*expr);
4878 mlir::Value sourceBox;
4879 if (fir::isPolymorphicType(fir::getBase(exv).getType()))
4880 sourceBox = fir::getBase(exv);
4881 mlir::Type baseTy =
4882 fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(exv).getType());
4883 mlir::Type innerTy = fir::unwrapSequenceType(baseTy);
4884 operands.emplace_back([=](IterSpace iters) -> ExtValue {
4885 mlir::Value coord = builder.create<fir::CoordinateOp>(
4886 loc, fir::ReferenceType::get(innerTy), fir::getBase(exv),
4887 iters.iterVec());
4888 mlir::Value empty;
4889 mlir::ValueRange emptyRange;
4890 return builder.create<fir::EmboxOp>(
4891 loc, fir::ClassType::get(innerTy), coord, empty, empty,
4892 emptyRange, sourceBox);
4893 });
4894 } else {
4895 ExtValue exv = asScalarRef(*expr);
4896 if (mlir::isa<fir::BaseBoxType>(fir::getBase(exv).getType())) {
4897 operands.emplace_back(
4898 [=](IterSpace iters) -> ExtValue { return exv; });
4899 } else {
4900 mlir::Type baseTy =
4901 fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(exv).getType());
4902 operands.emplace_back([=](IterSpace iters) -> ExtValue {
4903 mlir::Value empty;
4904 mlir::ValueRange emptyRange;
4905 return builder.create<fir::EmboxOp>(
4906 loc, fir::ClassType::get(baseTy), fir::getBase(exv), empty,
4907 empty, emptyRange);
4908 });
4909 }
4910 }
4911 break;
4912 }
4913 // See C15100 and C15101
4914 fir::emitFatalError(loc, "cannot be POINTER, ALLOCATABLE");
4915 case PassBy::BoxProcRef:
4916 // Procedure pointer: no action here.
4917 break;
4918 }
4919 }
4920
4921 if (caller.getIfIndirectCall())
4922 fir::emitFatalError(loc, "cannot be indirect call");
4923
4924 // The lambda is mutable so that `caller` copy can be modified inside it.
4925 return [=,
4926 caller = std::move(caller)](IterSpace iters) mutable -> ExtValue {
4927 for (const auto &[cc, argIface] :
4928 llvm::zip(operands, caller.getPassedArguments())) {
4929 auto exv = cc(iters);
4930 auto arg = exv.match(
4931 [&](const fir::CharBoxValue &cb) -> mlir::Value {
4932 return fir::factory::CharacterExprHelper{builder, loc}
4933 .createEmbox(cb);
4934 },
4935 [&](const auto &) { return fir::getBase(exv); });
4936 caller.placeInput(argIface, arg);
4937 }
4938 Fortran::lower::LoweredResult res =
4939 Fortran::lower::genCallOpAndResult(loc, converter, symMap,
4940 getElementCtx(), caller,
4941 callSiteType, retTy)
4942 .first;
4943 return std::get<ExtValue>(res);
4944 };
4945 }
4946
4947 /// Lower TRANSPOSE call without using runtime TRANSPOSE.
4948 /// Return continuation for generating the TRANSPOSE result.
4949 /// The continuation just swaps the iteration space before
4950 /// invoking continuation for the argument.
4951 CC genTransposeProcRef(const Fortran::evaluate::ProcedureRef &procRef) {
4952 assert(procRef.arguments().size() == 1 &&
4953 "TRANSPOSE must have one argument.");
4954 const auto *argExpr = procRef.arguments()[0].value().UnwrapExpr();
4955 assert(argExpr);
4956
4957 llvm::SmallVector<mlir::Value> savedDestShape = destShape;
4958 assert((destShape.empty() || destShape.size() == 2) &&
4959 "TRANSPOSE destination must have rank 2.");
4960
4961 if (!savedDestShape.empty())
4962 std::swap(destShape[0], destShape[1]);
4963
4964 PushSemantics(ConstituentSemantics::RefTransparent);
4965 llvm::SmallVector<CC> operands{genElementalArgument(*argExpr)};
4966
4967 if (!savedDestShape.empty()) {
4968 // If destShape was set before transpose lowering, then
4969 // restore it. Otherwise, ...
4970 destShape = savedDestShape;
4971 } else if (!destShape.empty()) {
4972 // ... if destShape has been set from the argument lowering,
4973 // then reverse it.
4974 assert(destShape.size() == 2 &&
4975 "TRANSPOSE destination must have rank 2.");
4976 std::swap(destShape[0], destShape[1]);
4977 }
4978
4979 return [=](IterSpace iters) {
4980 assert(iters.iterVec().size() == 2 &&
4981 "TRANSPOSE expects 2D iterations space.");
4982 IterationSpace newIters(iters, {iters.iterValue(1), iters.iterValue(0)});
4983 return operands.front()(newIters);
4984 };
4985 }
4986
4987 /// Generate a procedure reference. This code is shared for both functions and
4988 /// subroutines, the difference being reflected by `retTy`.
4989 CC genProcRef(const Fortran::evaluate::ProcedureRef &procRef,
4990 std::optional<mlir::Type> retTy) {
4991 mlir::Location loc = getLoc();
4992 setLoweredProcRef(&procRef);
4993
4994 if (isOptimizableTranspose(procRef, converter))
4995 return genTransposeProcRef(procRef);
4996
4997 if (procRef.IsElemental()) {
4998 if (const Fortran::evaluate::SpecificIntrinsic *intrin =
4999 procRef.proc().GetSpecificIntrinsic()) {
5000 // All elemental intrinsic functions are pure and cannot modify their
5001 // arguments. The only elemental subroutine, MVBITS has an Intent(inout)
5002 // argument. So for this last one, loops must be in element order
5003 // according to 15.8.3 p1.
5004 if (!retTy)
5005 setUnordered(false);
5006
5007 // Elemental intrinsic call.
5008 // The intrinsic procedure is called once per element of the array.
5009 return genElementalIntrinsicProcRef(procRef, retTy, *intrin);
5010 }
5011 if (Fortran::lower::isIntrinsicModuleProcRef(procRef))
5012 return genElementalIntrinsicProcRef(procRef, retTy);
5013 if (ScalarExprLowering::isStatementFunctionCall(procRef))
5014 fir::emitFatalError(loc, "statement function cannot be elemental");
5015
5016 // Elemental call.
5017 // The procedure is called once per element of the array argument(s).
5018 return genElementalUserDefinedProcRef(procRef, retTy);
5019 }
5020
5021 // Transformational call.
5022 // The procedure is called once and produces a value of rank > 0.
5023 if (const Fortran::evaluate::SpecificIntrinsic *intrinsic =
5024 procRef.proc().GetSpecificIntrinsic()) {
5025 if (explicitSpaceIsActive() && procRef.Rank() == 0) {
5026 // Elide any implicit loop iters.
5027 return [=, &procRef](IterSpace) {
5028 return ScalarExprLowering{loc, converter, symMap, stmtCtx}
5029 .genIntrinsicRef(procRef, retTy, *intrinsic);
5030 };
5031 }
5032 return genarr(
5033 ScalarExprLowering{loc, converter, symMap, stmtCtx}.genIntrinsicRef(
5034 procRef, retTy, *intrinsic));
5035 }
5036
5037 const bool isPtrAssn = isPointerAssignment();
5038 if (explicitSpaceIsActive() && procRef.Rank() == 0) {
5039 // Elide any implicit loop iters.
5040 return [=, &procRef](IterSpace) {
5041 ScalarExprLowering sel(loc, converter, symMap, stmtCtx);
5042 return isPtrAssn ? sel.genRawProcedureRef(procRef, retTy)
5043 : sel.genProcedureRef(procRef, retTy);
5044 };
5045 }
5046 // In the default case, the call can be hoisted out of the loop nest. Apply
5047 // the iterations to the result, which may be an array value.
5048 ScalarExprLowering sel(loc, converter, symMap, stmtCtx);
5049 auto exv = isPtrAssn ? sel.genRawProcedureRef(procRef, retTy)
5050 : sel.genProcedureRef(procRef, retTy);
5051 return genarr(exv);
5052 }
5053
5054 CC genarr(const Fortran::evaluate::ProcedureDesignator &) {
5055 TODO(getLoc(), "procedure designator");
5056 }
5057 CC genarr(const Fortran::evaluate::ProcedureRef &x) {
5058 if (x.hasAlternateReturns())
5059 fir::emitFatalError(getLoc(),
5060 "array procedure reference with alt-return");
5061 return genProcRef(x, std::nullopt);
5062 }
5063 template <typename A>
5064 CC genScalarAndForwardValue(const A &x) {
5065 ExtValue result = asScalar(x);
5066 return [=](IterSpace) { return result; };
5067 }
5068 template <typename A, typename = std::enable_if_t<Fortran::common::HasMember<
5069 A, Fortran::evaluate::TypelessExpression>>>
5070 CC genarr(const A &x) {
5071 return genScalarAndForwardValue(x);
5072 }
5073
5074 template <typename A>
5075 CC genarr(const Fortran::evaluate::Expr<A> &x) {
5076 LLVM_DEBUG(Fortran::semantics::DumpEvaluateExpr::Dump(llvm::dbgs(), x));
5077 if (isArray(x) || (explicitSpaceIsActive() && isLeftHandSide()) ||
5078 isElementalProcWithArrayArgs(x))
5079 return Fortran::common::visit([&](const auto &e) { return genarr(e); },
5080 x.u);
5081 if (explicitSpaceIsActive()) {
5082 assert(!isArray(x) && !isLeftHandSide());
5083 auto cc =
5084 Fortran::common::visit([&](const auto &e) { return genarr(e); }, x.u);
5085 auto result = cc(IterationSpace{});
5086 return [=](IterSpace) { return result; };
5087 }
5088 return genScalarAndForwardValue(x);
5089 }
5090
5091 // Converting a value of memory bound type requires creating a temp and
5092 // copying the value.
5093 static ExtValue convertAdjustedType(fir::FirOpBuilder &builder,
5094 mlir::Location loc, mlir::Type toType,
5095 const ExtValue &exv) {
5096 return exv.match(
5097 [&](const fir::CharBoxValue &cb) -> ExtValue {
5098 mlir::Value len = cb.getLen();
5099 auto mem =
5100 builder.create<fir::AllocaOp>(loc, toType, mlir::ValueRange{len});
5101 fir::CharBoxValue result(mem, len);
5102 fir::factory::CharacterExprHelper{builder, loc}.createAssign(
5103 ExtValue{result}, exv);
5104 return result;
5105 },
5106 [&](const auto &) -> ExtValue {
5107 fir::emitFatalError(loc, "convert on adjusted extended value");
5108 });
5109 }
5110 template <Fortran::common::TypeCategory TC1, int KIND,
5111 Fortran::common::TypeCategory TC2>
5112 CC genarr(const Fortran::evaluate::Convert<Fortran::evaluate::Type<TC1, KIND>,
5113 TC2> &x) {
5114 mlir::Location loc = getLoc();
5115 auto lambda = genarr(x.left());
5116 mlir::Type ty = converter.genType(TC1, KIND);
5117 return [=](IterSpace iters) -> ExtValue {
5118 auto exv = lambda(iters);
5119 mlir::Value val = fir::getBase(exv);
5120 auto valTy = val.getType();
5121 if (elementTypeWasAdjusted(valTy) &&
5122 !(fir::isa_ref_type(valTy) && fir::isa_integer(ty)))
5123 return convertAdjustedType(builder, loc, ty, exv);
5124 return builder.createConvert(loc, ty, val);
5125 };
5126 }
5127
5128 template <int KIND>
5129 CC genarr(const Fortran::evaluate::ComplexComponent<KIND> &x) {
5130 mlir::Location loc = getLoc();
5131 auto lambda = genarr(x.left());
5132 bool isImagPart = x.isImaginaryPart;
5133 return [=](IterSpace iters) -> ExtValue {
5134 mlir::Value lhs = fir::getBase(lambda(iters));
5135 return fir::factory::Complex{builder, loc}.extractComplexPart(lhs,
5136 isImagPart);
5137 };
5138 }
5139
5140 template <typename T>
5141 CC genarr(const Fortran::evaluate::Parentheses<T> &x) {
5142 mlir::Location loc = getLoc();
5143 if (isReferentiallyOpaque()) {
5144 // Context is a call argument in, for example, an elemental procedure
5145 // call. TODO: all array arguments should use array_load, array_access,
5146 // array_amend, and INTENT(OUT), INTENT(INOUT) arguments should have
5147 // array_merge_store ops.
5148 TODO(loc, "parentheses on argument in elemental call");
5149 }
5150 auto f = genarr(x.left());
5151 return [=](IterSpace iters) -> ExtValue {
5152 auto val = f(iters);
5153 mlir::Value base = fir::getBase(val);
5154 auto newBase =
5155 builder.create<fir::NoReassocOp>(loc, base.getType(), base);
5156 return fir::substBase(val, newBase);
5157 };
5158 }
5159 template <Fortran::common::TypeCategory CAT, int KIND>
5160 CC genarrIntNeg(
5161 const Fortran::evaluate::Expr<Fortran::evaluate::Type<CAT, KIND>> &left) {
5162 mlir::Location loc = getLoc();
5163 auto f = genarr(left);
5164 return [=](IterSpace iters) -> ExtValue {
5165 mlir::Value val = fir::getBase(f(iters));
5166 mlir::Type ty =
5167 converter.genType(Fortran::common::TypeCategory::Integer, KIND);
5168 mlir::Value zero = builder.createIntegerConstant(loc, ty, 0);
5169 if constexpr (CAT == Fortran::common::TypeCategory::Unsigned) {
5170 mlir::Value signless = builder.createConvert(loc, ty, val);
5171 mlir::Value neg =
5172 builder.create<mlir::arith::SubIOp>(loc, zero, signless);
5173 return builder.createConvert(loc, val.getType(), neg);
5174 }
5175 return builder.create<mlir::arith::SubIOp>(loc, zero, val);
5176 };
5177 }
5178 template <int KIND>
5179 CC genarr(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
5180 Fortran::common::TypeCategory::Integer, KIND>> &x) {
5181 return genarrIntNeg(x.left());
5182 }
5183 template <int KIND>
5184 CC genarr(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
5185 Fortran::common::TypeCategory::Unsigned, KIND>> &x) {
5186 return genarrIntNeg(x.left());
5187 }
5188 template <int KIND>
5189 CC genarr(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
5190 Fortran::common::TypeCategory::Real, KIND>> &x) {
5191 mlir::Location loc = getLoc();
5192 auto f = genarr(x.left());
5193 return [=](IterSpace iters) -> ExtValue {
5194 return builder.create<mlir::arith::NegFOp>(loc, fir::getBase(f(iters)));
5195 };
5196 }
5197 template <int KIND>
5198 CC genarr(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
5199 Fortran::common::TypeCategory::Complex, KIND>> &x) {
5200 mlir::Location loc = getLoc();
5201 auto f = genarr(x.left());
5202 return [=](IterSpace iters) -> ExtValue {
5203 return builder.create<fir::NegcOp>(loc, fir::getBase(f(iters)));
5204 };
5205 }
5206
5207 //===--------------------------------------------------------------------===//
5208 // Binary elemental ops
5209 //===--------------------------------------------------------------------===//
5210
5211 template <typename OP, typename A>
5212 CC createBinaryOp(const A &evEx) {
5213 mlir::Location loc = getLoc();
5214 auto lambda = genarr(evEx.left());
5215 auto rf = genarr(evEx.right());
5216 return [=](IterSpace iters) -> ExtValue {
5217 mlir::Value left = fir::getBase(lambda(iters));
5218 mlir::Value right = fir::getBase(rf(iters));
5219 assert(left.getType() == right.getType() && "types must be the same");
5220 return builder.createUnsigned<OP>(loc, left.getType(), left, right);
5221 };
5222 }
5223
5224#undef GENBIN
5225#define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp) \
5226 template <int KIND> \
5227 CC genarr(const Fortran::evaluate::GenBinEvOp<Fortran::evaluate::Type< \
5228 Fortran::common::TypeCategory::GenBinTyCat, KIND>> &x) { \
5229 return createBinaryOp<GenBinFirOp>(x); \
5230 }
5231
5232 GENBIN(Add, Integer, mlir::arith::AddIOp)
5233 GENBIN(Add, Unsigned, mlir::arith::AddIOp)
5234 GENBIN(Add, Real, mlir::arith::AddFOp)
5235 GENBIN(Add, Complex, fir::AddcOp)
5236 GENBIN(Subtract, Integer, mlir::arith::SubIOp)
5237 GENBIN(Subtract, Unsigned, mlir::arith::SubIOp)
5238 GENBIN(Subtract, Real, mlir::arith::SubFOp)
5239 GENBIN(Subtract, Complex, fir::SubcOp)
5240 GENBIN(Multiply, Integer, mlir::arith::MulIOp)
5241 GENBIN(Multiply, Unsigned, mlir::arith::MulIOp)
5242 GENBIN(Multiply, Real, mlir::arith::MulFOp)
5243 GENBIN(Multiply, Complex, fir::MulcOp)
5244 GENBIN(Divide, Integer, mlir::arith::DivSIOp)
5245 GENBIN(Divide, Unsigned, mlir::arith::DivUIOp)
5246 GENBIN(Divide, Real, mlir::arith::DivFOp)
5247
5248 template <int KIND>
5249 CC genarr(const Fortran::evaluate::Divide<Fortran::evaluate::Type<
5250 Fortran::common::TypeCategory::Complex, KIND>> &x) {
5251 mlir::Location loc = getLoc();
5252 mlir::Type ty =
5253 converter.genType(Fortran::common::TypeCategory::Complex, KIND);
5254 auto lf = genarr(x.left());
5255 auto rf = genarr(x.right());
5256 return [=](IterSpace iters) -> ExtValue {
5257 mlir::Value lhs = fir::getBase(lf(iters));
5258 mlir::Value rhs = fir::getBase(rf(iters));
5259 return fir::genDivC(builder, loc, ty, lhs, rhs);
5260 };
5261 }
5262
5263 template <Fortran::common::TypeCategory TC, int KIND>
5264 CC genarr(
5265 const Fortran::evaluate::Power<Fortran::evaluate::Type<TC, KIND>> &x) {
5266 mlir::Location loc = getLoc();
5267 mlir::Type ty = converter.genType(TC, KIND);
5268 auto lf = genarr(x.left());
5269 auto rf = genarr(x.right());
5270 return [=](IterSpace iters) -> ExtValue {
5271 mlir::Value lhs = fir::getBase(lf(iters));
5272 mlir::Value rhs = fir::getBase(rf(iters));
5273 return fir::genPow(builder, loc, ty, lhs, rhs);
5274 };
5275 }
5276 template <Fortran::common::TypeCategory TC, int KIND>
5277 CC genarr(
5278 const Fortran::evaluate::Extremum<Fortran::evaluate::Type<TC, KIND>> &x) {
5279 mlir::Location loc = getLoc();
5280 auto lf = genarr(x.left());
5281 auto rf = genarr(x.right());
5282 switch (x.ordering) {
5283 case Fortran::evaluate::Ordering::Greater:
5284 return [=](IterSpace iters) -> ExtValue {
5285 mlir::Value lhs = fir::getBase(lf(iters));
5286 mlir::Value rhs = fir::getBase(rf(iters));
5287 return fir::genMax(builder, loc, llvm::ArrayRef<mlir::Value>{lhs, rhs});
5288 };
5289 case Fortran::evaluate::Ordering::Less:
5290 return [=](IterSpace iters) -> ExtValue {
5291 mlir::Value lhs = fir::getBase(lf(iters));
5292 mlir::Value rhs = fir::getBase(rf(iters));
5293 return fir::genMin(builder, loc, llvm::ArrayRef<mlir::Value>{lhs, rhs});
5294 };
5295 case Fortran::evaluate::Ordering::Equal:
5296 llvm_unreachable("Equal is not a valid ordering in this context");
5297 }
5298 llvm_unreachable("unknown ordering");
5299 }
5300 template <Fortran::common::TypeCategory TC, int KIND>
5301 CC genarr(
5302 const Fortran::evaluate::RealToIntPower<Fortran::evaluate::Type<TC, KIND>>
5303 &x) {
5304 mlir::Location loc = getLoc();
5305 auto ty = converter.genType(TC, KIND);
5306 auto lf = genarr(x.left());
5307 auto rf = genarr(x.right());
5308 return [=](IterSpace iters) {
5309 mlir::Value lhs = fir::getBase(lf(iters));
5310 mlir::Value rhs = fir::getBase(rf(iters));
5311 return fir::genPow(builder, loc, ty, lhs, rhs);
5312 };
5313 }
5314 template <int KIND>
5315 CC genarr(const Fortran::evaluate::ComplexConstructor<KIND> &x) {
5316 mlir::Location loc = getLoc();
5317 auto lf = genarr(x.left());
5318 auto rf = genarr(x.right());
5319 return [=](IterSpace iters) -> ExtValue {
5320 mlir::Value lhs = fir::getBase(lf(iters));
5321 mlir::Value rhs = fir::getBase(rf(iters));
5322 return fir::factory::Complex{builder, loc}.createComplex(lhs, rhs);
5323 };
5324 }
5325
5326 /// Fortran's concatenation operator `//`.
5327 template <int KIND>
5328 CC genarr(const Fortran::evaluate::Concat<KIND> &x) {
5329 mlir::Location loc = getLoc();
5330 auto lf = genarr(x.left());
5331 auto rf = genarr(x.right());
5332 return [=](IterSpace iters) -> ExtValue {
5333 auto lhs = lf(iters);
5334 auto rhs = rf(iters);
5335 const fir::CharBoxValue *lchr = lhs.getCharBox();
5336 const fir::CharBoxValue *rchr = rhs.getCharBox();
5337 if (lchr && rchr) {
5338 return fir::factory::CharacterExprHelper{builder, loc}
5339 .createConcatenate(*lchr, *rchr);
5340 }
5341 TODO(loc, "concat on unexpected extended values");
5342 return mlir::Value{};
5343 };
5344 }
5345
5346 template <int KIND>
5347 CC genarr(const Fortran::evaluate::SetLength<KIND> &x) {
5348 auto lf = genarr(x.left());
5349 mlir::Value rhs = fir::getBase(asScalar(x.right()));
5350 fir::CharBoxValue temp =
5351 fir::factory::CharacterExprHelper(builder, getLoc())
5352 .createCharacterTemp(
5353 fir::CharacterType::getUnknownLen(builder.getContext(), KIND),
5354 rhs);
5355 return [=](IterSpace iters) -> ExtValue {
5356 fir::factory::CharacterExprHelper(builder, getLoc())
5357 .createAssign(temp, lf(iters));
5358 return temp;
5359 };
5360 }
5361
5362 template <typename T>
5363 CC genarr(const Fortran::evaluate::Constant<T> &x) {
5364 if (x.Rank() == 0)
5365 return genScalarAndForwardValue(x);
5366 return genarr(Fortran::lower::convertConstant(
5367 converter, getLoc(), x,
5368 /*outlineBigConstantsInReadOnlyMemory=*/true));
5369 }
5370
5371 //===--------------------------------------------------------------------===//
5372 // A vector subscript expression may be wrapped with a cast to INTEGER*8.
5373 // Get rid of it here so the vector can be loaded. Add it back when
5374 // generating the elemental evaluation (inside the loop nest).
5375
5376 static Fortran::lower::SomeExpr
5377 ignoreEvConvert(const Fortran::evaluate::Expr<Fortran::evaluate::Type<
5378 Fortran::common::TypeCategory::Integer, 8>> &x) {
5379 return Fortran::common::visit(
5380 [&](const auto &v) { return ignoreEvConvert(v); }, x.u);
5381 }
5382 template <Fortran::common::TypeCategory FROM>
5383 static Fortran::lower::SomeExpr ignoreEvConvert(
5384 const Fortran::evaluate::Convert<
5385 Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer, 8>,
5386 FROM> &x) {
5387 return toEvExpr(x.left());
5388 }
5389 template <typename A>
5390 static Fortran::lower::SomeExpr ignoreEvConvert(const A &x) {
5391 return toEvExpr(x);
5392 }
5393
5394 //===--------------------------------------------------------------------===//
5395 // Get the `Se::Symbol*` for the subscript expression, `x`. This symbol can
5396 // be used to determine the lbound, ubound of the vector.
5397
5398 template <typename A>
5399 static const Fortran::semantics::Symbol *
5400 extractSubscriptSymbol(const Fortran::evaluate::Expr<A> &x) {
5401 return Fortran::common::visit(
5402 [&](const auto &v) { return extractSubscriptSymbol(v); }, x.u);
5403 }
5404 template <typename A>
5405 static const Fortran::semantics::Symbol *
5406 extractSubscriptSymbol(const Fortran::evaluate::Designator<A> &x) {
5407 return Fortran::evaluate::UnwrapWholeSymbolDataRef(x);
5408 }
5409 template <typename A>
5410 static const Fortran::semantics::Symbol *extractSubscriptSymbol(const A &x) {
5411 return nullptr;
5412 }
5413
5414 //===--------------------------------------------------------------------===//
5415
5416 /// Get the declared lower bound value of the array `x` in dimension `dim`.
5417 /// The argument `one` must be an ssa-value for the constant 1.
5418 mlir::Value getLBound(const ExtValue &x, unsigned dim, mlir::Value one) {
5419 return fir::factory::readLowerBound(builder, getLoc(), x, dim, one);
5420 }
5421
5422 /// Get the declared upper bound value of the array `x` in dimension `dim`.
5423 /// The argument `one` must be an ssa-value for the constant 1.
5424 mlir::Value getUBound(const ExtValue &x, unsigned dim, mlir::Value one) {
5425 mlir::Location loc = getLoc();
5426 mlir::Value lb = getLBound(x, dim, one);
5427 mlir::Value extent = fir::factory::readExtent(builder, loc, x, dim);
5428 auto add = builder.create<mlir::arith::AddIOp>(loc, lb, extent);
5429 return builder.create<mlir::arith::SubIOp>(loc, add, one);
5430 }
5431
5432 /// Return the extent of the boxed array `x` in dimesion `dim`.
5433 mlir::Value getExtent(const ExtValue &x, unsigned dim) {
5434 return fir::factory::readExtent(builder, getLoc(), x, dim);
5435 }
5436
5437 template <typename A>
5438 ExtValue genArrayBase(const A &base) {
5439 ScalarExprLowering sel{getLoc(), converter, symMap, stmtCtx};
5440 return base.IsSymbol() ? sel.gen(getFirstSym(base))
5441 : sel.gen(base.GetComponent());
5442 }
5443
5444 template <typename A>
5445 bool hasEvArrayRef(const A &x) {
5446 struct HasEvArrayRefHelper
5447 : public Fortran::evaluate::AnyTraverse<HasEvArrayRefHelper> {
5448 HasEvArrayRefHelper()
5449 : Fortran::evaluate::AnyTraverse<HasEvArrayRefHelper>(*this) {}
5450 using Fortran::evaluate::AnyTraverse<HasEvArrayRefHelper>::operator();
5451 bool operator()(const Fortran::evaluate::ArrayRef &) const {
5452 return true;
5453 }
5454 } helper;
5455 return helper(x);
5456 }
5457
5458 CC genVectorSubscriptArrayFetch(const Fortran::lower::SomeExpr &expr,
5459 std::size_t dim) {
5460 PushSemantics(ConstituentSemantics::RefTransparent);
5461 auto saved = Fortran::common::ScopedSet(explicitSpace, nullptr);
5462 llvm::SmallVector<mlir::Value> savedDestShape = destShape;
5463 destShape.clear();
5464 auto result = genarr(expr);
5465 if (destShape.empty())
5466 TODO(getLoc(), "expected vector to have an extent");
5467 assert(destShape.size() == 1 && "vector has rank > 1");
5468 if (destShape[0] != savedDestShape[dim]) {
5469 // Not the same, so choose the smaller value.
5470 mlir::Location loc = getLoc();
5471 auto cmp = builder.create<mlir::arith::CmpIOp>(
5472 loc, mlir::arith::CmpIPredicate::sgt, destShape[0],
5473 savedDestShape[dim]);
5474 auto sel = builder.create<mlir::arith::SelectOp>(
5475 loc, cmp, savedDestShape[dim], destShape[0]);
5476 savedDestShape[dim] = sel;
5477 destShape = savedDestShape;
5478 }
5479 return result;
5480 }
5481
5482 /// Generate an access by vector subscript using the index in the iteration
5483 /// vector at `dim`.
5484 mlir::Value genAccessByVector(mlir::Location loc, CC genArrFetch,
5485 IterSpace iters, std::size_t dim) {
5486 IterationSpace vecIters(iters,
5487 llvm::ArrayRef<mlir::Value>{iters.iterValue(dim)});
5488 fir::ExtendedValue fetch = genArrFetch(vecIters);
5489 mlir::IndexType idxTy = builder.getIndexType();
5490 return builder.createConvert(loc, idxTy, fir::getBase(fetch));
5491 }
5492
5493 /// When we have an array reference, the expressions specified in each
5494 /// dimension may be slice operations (e.g. `i:j:k`), vectors, or simple
5495 /// (loop-invarianet) scalar expressions. This returns the base entity, the
5496 /// resulting type, and a continuation to adjust the default iteration space.
5497 void genSliceIndices(ComponentPath &cmptData, const ExtValue &arrayExv,
5498 const Fortran::evaluate::ArrayRef &x, bool atBase) {
5499 mlir::Location loc = getLoc();
5500 mlir::IndexType idxTy = builder.getIndexType();
5501 mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
5502 llvm::SmallVector<mlir::Value> &trips = cmptData.trips;
5503 LLVM_DEBUG(llvm::dbgs() << "array: " << arrayExv << '\n');
5504 auto &pc = cmptData.pc;
5505 const bool useTripsForSlice = !explicitSpaceIsActive();
5506 const bool createDestShape = destShape.empty();
5507 bool useSlice = false;
5508 std::size_t shapeIndex = 0;
5509 for (auto sub : llvm::enumerate(x.subscript())) {
5510 const std::size_t subsIndex = sub.index();
5511 Fortran::common::visit(
5512 Fortran::common::visitors{
5513 [&](const Fortran::evaluate::Triplet &t) {
5514 mlir::Value lowerBound;
5515 if (auto optLo = t.lower())
5516 lowerBound = fir::getBase(asScalarArray(*optLo));
5517 else
5518 lowerBound = getLBound(arrayExv, subsIndex, one);
5519 lowerBound = builder.createConvert(loc, idxTy, lowerBound);
5520 mlir::Value stride = fir::getBase(asScalarArray(t.stride()));
5521 stride = builder.createConvert(loc, idxTy, stride);
5522 if (useTripsForSlice || createDestShape) {
5523 // Generate a slice operation for the triplet. The first and
5524 // second position of the triplet may be omitted, and the
5525 // declared lbound and/or ubound expression values,
5526 // respectively, should be used instead.
5527 trips.push_back(lowerBound);
5528 mlir::Value upperBound;
5529 if (auto optUp = t.upper())
5530 upperBound = fir::getBase(asScalarArray(*optUp));
5531 else
5532 upperBound = getUBound(arrayExv, subsIndex, one);
5533 upperBound = builder.createConvert(loc, idxTy, upperBound);
5534 trips.push_back(upperBound);
5535 trips.push_back(stride);
5536 if (createDestShape) {
5537 auto extent = builder.genExtentFromTriplet(
5538 loc, lowerBound, upperBound, stride, idxTy);
5539 destShape.push_back(extent);
5540 }
5541 useSlice = true;
5542 }
5543 if (!useTripsForSlice) {
5544 auto currentPC = pc;
5545 pc = [=](IterSpace iters) {
5546 IterationSpace newIters = currentPC(iters);
5547 mlir::Value impliedIter = newIters.iterValue(subsIndex);
5548 // FIXME: must use the lower bound of this component.
5549 auto arrLowerBound =
5550 atBase ? getLBound(arrayExv, subsIndex, one) : one;
5551 auto initial = builder.create<mlir::arith::SubIOp>(
5552 loc, lowerBound, arrLowerBound);
5553 auto prod = builder.create<mlir::arith::MulIOp>(
5554 loc, impliedIter, stride);
5555 auto result =
5556 builder.create<mlir::arith::AddIOp>(loc, initial, prod);
5557 newIters.setIndexValue(subsIndex, result);
5558 return newIters;
5559 };
5560 }
5561 shapeIndex++;
5562 },
5563 [&](const Fortran::evaluate::IndirectSubscriptIntegerExpr &ie) {
5564 const auto &e = ie.value(); // dereference
5565 if (isArray(e)) {
5566 // This is a vector subscript. Use the index values as read
5567 // from a vector to determine the temporary array value.
5568 // Note: 9.5.3.3.3(3) specifies undefined behavior for
5569 // multiple updates to any specific array element through a
5570 // vector subscript with replicated values.
5571 assert(!isBoxValue() &&
5572 "fir.box cannot be created with vector subscripts");
5573 // TODO: Avoid creating a new evaluate::Expr here
5574 auto arrExpr = ignoreEvConvert(e);
5575 if (createDestShape) {
5576 destShape.push_back(fir::factory::getExtentAtDimension(
5577 loc, builder, arrayExv, subsIndex));
5578 }
5579 auto genArrFetch =
5580 genVectorSubscriptArrayFetch(arrExpr, shapeIndex);
5581 auto currentPC = pc;
5582 pc = [=](IterSpace iters) {
5583 IterationSpace newIters = currentPC(iters);
5584 auto val = genAccessByVector(loc, genArrFetch, newIters,
5585 subsIndex);
5586 // Value read from vector subscript array and normalized
5587 // using the base array's lower bound value.
5588 mlir::Value lb = fir::factory::readLowerBound(
5589 builder, loc, arrayExv, subsIndex, one);
5590 auto origin = builder.create<mlir::arith::SubIOp>(
5591 loc, idxTy, val, lb);
5592 newIters.setIndexValue(subsIndex, origin);
5593 return newIters;
5594 };
5595 if (useTripsForSlice) {
5596 LLVM_ATTRIBUTE_UNUSED auto vectorSubscriptShape =
5597 getShape(arrayOperands.back());
5598 auto undef = builder.create<fir::UndefOp>(loc, idxTy);
5599 trips.push_back(undef);
5600 trips.push_back(undef);
5601 trips.push_back(undef);
5602 }
5603 shapeIndex++;
5604 } else {
5605 // This is a regular scalar subscript.
5606 if (useTripsForSlice) {
5607 // A regular scalar index, which does not yield an array
5608 // section. Use a degenerate slice operation
5609 // `(e:undef:undef)` in this dimension as a placeholder.
5610 // This does not necessarily change the rank of the original
5611 // array, so the iteration space must also be extended to
5612 // include this expression in this dimension to adjust to
5613 // the array's declared rank.
5614 mlir::Value v = fir::getBase(asScalarArray(e));
5615 trips.push_back(v);
5616 auto undef = builder.create<fir::UndefOp>(loc, idxTy);
5617 trips.push_back(undef);
5618 trips.push_back(undef);
5619 auto currentPC = pc;
5620 // Cast `e` to index type.
5621 mlir::Value iv = builder.createConvert(loc, idxTy, v);
5622 // Normalize `e` by subtracting the declared lbound.
5623 mlir::Value lb = fir::factory::readLowerBound(
5624 builder, loc, arrayExv, subsIndex, one);
5625 mlir::Value ivAdj =
5626 builder.create<mlir::arith::SubIOp>(loc, idxTy, iv, lb);
5627 // Add lbound adjusted value of `e` to the iteration vector
5628 // (except when creating a box because the iteration vector
5629 // is empty).
5630 if (!isBoxValue())
5631 pc = [=](IterSpace iters) {
5632 IterationSpace newIters = currentPC(iters);
5633 newIters.insertIndexValue(subsIndex, ivAdj);
5634 return newIters;
5635 };
5636 } else {
5637 auto currentPC = pc;
5638 mlir::Value newValue = fir::getBase(asScalarArray(e));
5639 mlir::Value result =
5640 builder.createConvert(loc, idxTy, newValue);
5641 mlir::Value lb = fir::factory::readLowerBound(
5642 builder, loc, arrayExv, subsIndex, one);
5643 result = builder.create<mlir::arith::SubIOp>(loc, idxTy,
5644 result, lb);
5645 pc = [=](IterSpace iters) {
5646 IterationSpace newIters = currentPC(iters);
5647 newIters.insertIndexValue(subsIndex, result);
5648 return newIters;
5649 };
5650 }
5651 }
5652 }},
5653 sub.value().u);
5654 }
5655 if (!useSlice)
5656 trips.clear();
5657 }
5658
5659 static mlir::Type unwrapBoxEleTy(mlir::Type ty) {
5660 if (auto boxTy = mlir::dyn_cast<fir::BaseBoxType>(ty))
5661 return fir::unwrapRefType(boxTy.getEleTy());
5662 return ty;
5663 }
5664
5665 llvm::SmallVector<mlir::Value> getShape(mlir::Type ty) {
5666 llvm::SmallVector<mlir::Value> result;
5667 ty = unwrapBoxEleTy(ty);
5668 mlir::Location loc = getLoc();
5669 mlir::IndexType idxTy = builder.getIndexType();
5670 auto seqType = mlir::cast<fir::SequenceType>(ty);
5671 for (auto extent : seqType.getShape()) {
5672 auto v = extent == fir::SequenceType::getUnknownExtent()
5673 ? builder.create<fir::UndefOp>(loc, idxTy).getResult()
5674 : builder.createIntegerConstant(loc, idxTy, extent);
5675 result.push_back(v);
5676 }
5677 return result;
5678 }
5679
5680 CC genarr(const Fortran::semantics::SymbolRef &sym,
5681 ComponentPath &components) {
5682 return genarr(sym.get(), components);
5683 }
5684
5685 ExtValue abstractArrayExtValue(mlir::Value val, mlir::Value len = {}) {
5686 return convertToArrayBoxValue(getLoc(), builder, val, len);
5687 }
5688
5689 CC genarr(const ExtValue &extMemref) {
5690 ComponentPath dummy(/*isImplicit=*/true);
5691 return genarr(extMemref, dummy);
5692 }
5693
5694 // If the slice values are given then use them. Otherwise, generate triples
5695 // that cover the entire shape specified by \p shapeVal.
5696 inline llvm::SmallVector<mlir::Value>
5697 padSlice(llvm::ArrayRef<mlir::Value> triples, mlir::Value shapeVal) {
5698 llvm::SmallVector<mlir::Value> result;
5699 mlir::Location loc = getLoc();
5700 if (triples.size()) {
5701 result.assign(triples.begin(), triples.end());
5702 } else {
5703 auto one = builder.createIntegerConstant(loc, builder.getIndexType(), 1);
5704 if (!shapeVal) {
5705 TODO(loc, "shape must be recovered from box");
5706 } else if (auto shapeOp = mlir::dyn_cast_or_null<fir::ShapeOp>(
5707 shapeVal.getDefiningOp())) {
5708 for (auto ext : shapeOp.getExtents()) {
5709 result.push_back(one);
5710 result.push_back(ext);
5711 result.push_back(one);
5712 }
5713 } else if (auto shapeShift = mlir::dyn_cast_or_null<fir::ShapeShiftOp>(
5714 shapeVal.getDefiningOp())) {
5715 for (auto [lb, ext] :
5716 llvm::zip(shapeShift.getOrigins(), shapeShift.getExtents())) {
5717 result.push_back(lb);
5718 result.push_back(ext);
5719 result.push_back(one);
5720 }
5721 } else {
5722 TODO(loc, "shape must be recovered from box");
5723 }
5724 }
5725 return result;
5726 }
5727
5728 /// Base case of generating an array reference,
5729 CC genarr(const ExtValue &extMemref, ComponentPath &components,
5730 mlir::Value CrayPtr = nullptr) {
5731 mlir::Location loc = getLoc();
5732 mlir::Value memref = fir::getBase(extMemref);
5733 mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(memref.getType());
5734 assert(mlir::isa<fir::SequenceType>(arrTy) &&
5735 "memory ref must be an array");
5736 mlir::Value shape = builder.createShape(loc, extMemref);
5737 mlir::Value slice;
5738 if (components.isSlice()) {
5739 if (isBoxValue() && components.substring) {
5740 // Append the substring operator to emboxing Op as it will become an
5741 // interior adjustment (add offset, adjust LEN) to the CHARACTER value
5742 // being referenced in the descriptor.
5743 llvm::SmallVector<mlir::Value> substringBounds;
5744 populateBounds(substringBounds, components.substring);
5745 // Convert to (offset, size)
5746 mlir::Type iTy = substringBounds[0].getType();
5747 if (substringBounds.size() != 2) {
5748 fir::CharacterType charTy =
5749 fir::factory::CharacterExprHelper::getCharType(arrTy);
5750 if (charTy.hasConstantLen()) {
5751 mlir::IndexType idxTy = builder.getIndexType();
5752 fir::CharacterType::LenType charLen = charTy.getLen();
5753 mlir::Value lenValue =
5754 builder.createIntegerConstant(loc, idxTy, charLen);
5755 substringBounds.push_back(lenValue);
5756 } else {
5757 llvm::SmallVector<mlir::Value> typeparams =
5758 fir::getTypeParams(extMemref);
5759 substringBounds.push_back(typeparams.back());
5760 }
5761 }
5762 // Convert the lower bound to 0-based substring.
5763 mlir::Value one =
5764 builder.createIntegerConstant(loc, substringBounds[0].getType(), 1);
5765 substringBounds[0] =
5766 builder.create<mlir::arith::SubIOp>(loc, substringBounds[0], one);
5767 // Convert the upper bound to a length.
5768 mlir::Value cast = builder.createConvert(loc, iTy, substringBounds[1]);
5769 mlir::Value zero = builder.createIntegerConstant(loc, iTy, 0);
5770 auto size =
5771 builder.create<mlir::arith::SubIOp>(loc, cast, substringBounds[0]);
5772 auto cmp = builder.create<mlir::arith::CmpIOp>(
5773 loc, mlir::arith::CmpIPredicate::sgt, size, zero);
5774 // size = MAX(upper - (lower - 1), 0)
5775 substringBounds[1] =
5776 builder.create<mlir::arith::SelectOp>(loc, cmp, size, zero);
5777 slice = builder.create<fir::SliceOp>(
5778 loc, padSlice(components.trips, shape), components.suffixComponents,
5779 substringBounds);
5780 } else {
5781 slice = builder.createSlice(loc, extMemref, components.trips,
5782 components.suffixComponents);
5783 }
5784 if (components.hasComponents()) {
5785 auto seqTy = mlir::cast<fir::SequenceType>(arrTy);
5786 mlir::Type eleTy =
5787 fir::applyPathToType(seqTy.getEleTy(), components.suffixComponents);
5788 if (!eleTy)
5789 fir::emitFatalError(loc, "slicing path is ill-formed");
5790 // create the type of the projected array.
5791 arrTy = fir::SequenceType::get(seqTy.getShape(), eleTy);
5792 LLVM_DEBUG(llvm::dbgs()
5793 << "type of array projection from component slicing: "
5794 << eleTy << ", " << arrTy << '\n');
5795 }
5796 }
5797 arrayOperands.push_back(ArrayOperand{memref, shape, slice});
5798 if (destShape.empty())
5799 destShape = getShape(arrayOperands.back());
5800 if (isBoxValue()) {
5801 // Semantics are a reference to a boxed array.
5802 // This case just requires that an embox operation be created to box the
5803 // value. The value of the box is forwarded in the continuation.
5804 mlir::Type reduceTy = reduceRank(arrTy, slice);
5805 mlir::Type boxTy = fir::BoxType::get(reduceTy);
5806 if (mlir::isa<fir::ClassType>(memref.getType()) &&
5807 !components.hasComponents())
5808 boxTy = fir::ClassType::get(reduceTy);
5809 if (components.substring) {
5810 // Adjust char length to substring size.
5811 fir::CharacterType charTy =
5812 fir::factory::CharacterExprHelper::getCharType(reduceTy);
5813 auto seqTy = mlir::cast<fir::SequenceType>(reduceTy);
5814 // TODO: Use a constant for fir.char LEN if we can compute it.
5815 boxTy = fir::BoxType::get(
5816 fir::SequenceType::get(fir::CharacterType::getUnknownLen(
5817 builder.getContext(), charTy.getFKind()),
5818 seqTy.getDimension()));
5819 }
5820 llvm::SmallVector<mlir::Value> lbounds;
5821 llvm::SmallVector<mlir::Value> nonDeferredLenParams;
5822 if (!slice) {
5823 lbounds =
5824 fir::factory::getNonDefaultLowerBounds(builder, loc, extMemref);
5825 nonDeferredLenParams = fir::factory::getNonDeferredLenParams(extMemref);
5826 }
5827 mlir::Value embox =
5828 mlir::isa<fir::BaseBoxType>(memref.getType())
5829 ? builder.create<fir::ReboxOp>(loc, boxTy, memref, shape, slice)
5830 .getResult()
5831 : builder
5832 .create<fir::EmboxOp>(loc, boxTy, memref, shape, slice,
5833 fir::getTypeParams(extMemref))
5834 .getResult();
5835 return [=](IterSpace) -> ExtValue {
5836 return fir::BoxValue(embox, lbounds, nonDeferredLenParams);
5837 };
5838 }
5839 auto eleTy = mlir::cast<fir::SequenceType>(arrTy).getElementType();
5840 if (isReferentiallyOpaque()) {
5841 // Semantics are an opaque reference to an array.
5842 // This case forwards a continuation that will generate the address
5843 // arithmetic to the array element. This does not have copy-in/copy-out
5844 // semantics. No attempt to copy the array value will be made during the
5845 // interpretation of the Fortran statement.
5846 mlir::Type refEleTy = builder.getRefType(eleTy);
5847 return [=](IterSpace iters) -> ExtValue {
5848 // ArrayCoorOp does not expect zero based indices.
5849 llvm::SmallVector<mlir::Value> indices = fir::factory::originateIndices(
5850 loc, builder, memref.getType(), shape, iters.iterVec());
5851 mlir::Value coor = builder.create<fir::ArrayCoorOp>(
5852 loc, refEleTy, memref, shape, slice, indices,
5853 fir::getTypeParams(extMemref));
5854 if (auto charTy = mlir::dyn_cast<fir::CharacterType>(eleTy)) {
5855 llvm::SmallVector<mlir::Value> substringBounds;
5856 populateBounds(substringBounds, components.substring);
5857 if (!substringBounds.empty()) {
5858 mlir::Value dstLen = fir::factory::genLenOfCharacter(
5859 builder, loc, mlir::cast<fir::SequenceType>(arrTy), memref,
5860 fir::getTypeParams(extMemref), iters.iterVec(),
5861 substringBounds);
5862 fir::CharBoxValue dstChar(coor, dstLen);
5863 return fir::factory::CharacterExprHelper{builder, loc}
5864 .createSubstring(dstChar, substringBounds);
5865 }
5866 }
5867 return fir::factory::arraySectionElementToExtendedValue(
5868 builder, loc, extMemref, coor, slice);
5869 };
5870 }
5871 auto arrLoad = builder.create<fir::ArrayLoadOp>(
5872 loc, arrTy, memref, shape, slice, fir::getTypeParams(extMemref));
5873
5874 if (CrayPtr) {
5875 mlir::Type ptrTy = CrayPtr.getType();
5876 mlir::Value cnvrt = Fortran::lower::addCrayPointerInst(
5877 loc, builder, CrayPtr, ptrTy, memref.getType());
5878 auto addr = builder.create<fir::LoadOp>(loc, cnvrt);
5879 arrLoad = builder.create<fir::ArrayLoadOp>(loc, arrTy, addr, shape, slice,
5880 fir::getTypeParams(extMemref));
5881 }
5882
5883 mlir::Value arrLd = arrLoad.getResult();
5884 if (isProjectedCopyInCopyOut()) {
5885 // Semantics are projected copy-in copy-out.
5886 // The backing store of the destination of an array expression may be
5887 // partially modified. These updates are recorded in FIR by forwarding a
5888 // continuation that generates an `array_update` Op. The destination is
5889 // always loaded at the beginning of the statement and merged at the
5890 // end.
5891 destination = arrLoad;
5892 auto lambda = ccStoreToDest
5893 ? *ccStoreToDest
5894 : defaultStoreToDestination(components.substring);
5895 return [=](IterSpace iters) -> ExtValue { return lambda(iters); };
5896 }
5897 if (isCustomCopyInCopyOut()) {
5898 // Create an array_modify to get the LHS element address and indicate
5899 // the assignment, the actual assignment must be implemented in
5900 // ccStoreToDest.
5901 destination = arrLoad;
5902 return [=](IterSpace iters) -> ExtValue {
5903 mlir::Value innerArg = iters.innerArgument();
5904 mlir::Type resTy = innerArg.getType();
5905 mlir::Type eleTy = fir::applyPathToType(resTy, iters.iterVec());
5906 mlir::Type refEleTy =
5907 fir::isa_ref_type(eleTy) ? eleTy : builder.getRefType(eleTy);
5908 auto arrModify = builder.create<fir::ArrayModifyOp>(
5909 loc, mlir::TypeRange{refEleTy, resTy}, innerArg, iters.iterVec(),
5910 destination.getTypeparams());
5911 return abstractArrayExtValue(arrModify.getResult(1));
5912 };
5913 }
5914 if (isCopyInCopyOut()) {
5915 // Semantics are copy-in copy-out.
5916 // The continuation simply forwards the result of the `array_load` Op,
5917 // which is the value of the array as it was when loaded. All data
5918 // references with rank > 0 in an array expression typically have
5919 // copy-in copy-out semantics.
5920 return [=](IterSpace) -> ExtValue { return arrLd; };
5921 }
5922 llvm::SmallVector<mlir::Value> arrLdTypeParams =
5923 fir::factory::getTypeParams(loc, builder, arrLoad);
5924 if (isValueAttribute()) {
5925 // Semantics are value attribute.
5926 // Here the continuation will `array_fetch` a value from an array and
5927 // then store that value in a temporary. One can thus imitate pass by
5928 // value even when the call is pass by reference.
5929 return [=](IterSpace iters) -> ExtValue {
5930 mlir::Value base;
5931 mlir::Type eleTy = fir::applyPathToType(arrTy, iters.iterVec());
5932 if (isAdjustedArrayElementType(eleTy)) {
5933 mlir::Type eleRefTy = builder.getRefType(eleTy);
5934 base = builder.create<fir::ArrayAccessOp>(
5935 loc, eleRefTy, arrLd, iters.iterVec(), arrLdTypeParams);
5936 } else {
5937 base = builder.create<fir::ArrayFetchOp>(
5938 loc, eleTy, arrLd, iters.iterVec(), arrLdTypeParams);
5939 }
5940 mlir::Value temp =
5941 builder.createTemporary(loc, base.getType(),
5942 llvm::ArrayRef<mlir::NamedAttribute>{
5943 fir::getAdaptToByRefAttr(builder)});
5944 builder.create<fir::StoreOp>(loc, base, temp);
5945 return fir::factory::arraySectionElementToExtendedValue(
5946 builder, loc, extMemref, temp, slice);
5947 };
5948 }
5949 // In the default case, the array reference forwards an `array_fetch` or
5950 // `array_access` Op in the continuation.
5951 return [=](IterSpace iters) -> ExtValue {
5952 mlir::Type eleTy = fir::applyPathToType(arrTy, iters.iterVec());
5953 if (isAdjustedArrayElementType(eleTy)) {
5954 mlir::Type eleRefTy = builder.getRefType(eleTy);
5955 mlir::Value arrayOp = builder.create<fir::ArrayAccessOp>(
5956 loc, eleRefTy, arrLd, iters.iterVec(), arrLdTypeParams);
5957 if (auto charTy = mlir::dyn_cast<fir::CharacterType>(eleTy)) {
5958 llvm::SmallVector<mlir::Value> substringBounds;
5959 populateBounds(substringBounds, components.substring);
5960 if (!substringBounds.empty()) {
5961 mlir::Value dstLen = fir::factory::genLenOfCharacter(
5962 builder, loc, arrLoad, iters.iterVec(), substringBounds);
5963 fir::CharBoxValue dstChar(arrayOp, dstLen);
5964 return fir::factory::CharacterExprHelper{builder, loc}
5965 .createSubstring(dstChar, substringBounds);
5966 }
5967 }
5968 return fir::factory::arraySectionElementToExtendedValue(
5969 builder, loc, extMemref, arrayOp, slice);
5970 }
5971 auto arrFetch = builder.create<fir::ArrayFetchOp>(
5972 loc, eleTy, arrLd, iters.iterVec(), arrLdTypeParams);
5973 return fir::factory::arraySectionElementToExtendedValue(
5974 builder, loc, extMemref, arrFetch, slice);
5975 };
5976 }
5977
5978 std::tuple<CC, mlir::Value, mlir::Type>
5979 genOptionalArrayFetch(const Fortran::lower::SomeExpr &expr) {
5980 assert(expr.Rank() > 0 && "expr must be an array");
5981 mlir::Location loc = getLoc();
5982 ExtValue optionalArg = asInquired(expr);
5983 mlir::Value isPresent = genActualIsPresentTest(builder, loc, optionalArg);
5984 // Generate an array load and access to an array that may be an absent
5985 // optional or an unallocated optional.
5986 mlir::Value base = getBase(optionalArg);
5987 const bool hasOptionalAttr =
5988 fir::valueHasFirAttribute(base, fir::getOptionalAttrName());
5989 mlir::Type baseType = fir::unwrapRefType(base.getType());
5990 const bool isBox = mlir::isa<fir::BoxType>(baseType);
5991 const bool isAllocOrPtr =
5992 Fortran::evaluate::IsAllocatableOrPointerObject(expr);
5993 mlir::Type arrType = fir::unwrapPassByRefType(baseType);
5994 mlir::Type eleType = fir::unwrapSequenceType(arrType);
5995 ExtValue exv = optionalArg;
5996 if (hasOptionalAttr && isBox && !isAllocOrPtr) {
5997 // Elemental argument cannot be allocatable or pointers (C15100).
5998 // Hence, per 15.5.2.12 3 (8) and (9), the provided Allocatable and
5999 // Pointer optional arrays cannot be absent. The only kind of entities
6000 // that can get here are optional assumed shape and polymorphic entities.
6001 exv = absentBoxToUnallocatedBox(builder, loc, exv, isPresent);
6002 }
6003 // All the properties can be read from any fir.box but the read values may
6004 // be undefined and should only be used inside a fir.if (canBeRead) region.
6005 if (const auto *mutableBox = exv.getBoxOf<fir::MutableBoxValue>())
6006 exv = fir::factory::genMutableBoxRead(builder, loc, *mutableBox);
6007
6008 mlir::Value memref = fir::getBase(exv);
6009 mlir::Value shape = builder.createShape(loc, exv);
6010 mlir::Value noSlice;
6011 auto arrLoad = builder.create<fir::ArrayLoadOp>(
6012 loc, arrType, memref, shape, noSlice, fir::getTypeParams(exv));
6013 mlir::Operation::operand_range arrLdTypeParams = arrLoad.getTypeparams();
6014 mlir::Value arrLd = arrLoad.getResult();
6015 // Mark the load to tell later passes it is unsafe to use this array_load
6016 // shape unconditionally.
6017 arrLoad->setAttr(fir::getOptionalAttrName(), builder.getUnitAttr());
6018
6019 // Place the array as optional on the arrayOperands stack so that its
6020 // shape will only be used as a fallback to induce the implicit loop nest
6021 // (that is if there is no non optional array arguments).
6022 arrayOperands.push_back(
6023 ArrayOperand{memref, shape, noSlice, /*mayBeAbsent=*/true});
6024
6025 // By value semantics.
6026 auto cc = [=](IterSpace iters) -> ExtValue {
6027 auto arrFetch = builder.create<fir::ArrayFetchOp>(
6028 loc, eleType, arrLd, iters.iterVec(), arrLdTypeParams);
6029 return fir::factory::arraySectionElementToExtendedValue(
6030 builder, loc, exv, arrFetch, noSlice);
6031 };
6032 return {cc, isPresent, eleType};
6033 }
6034
6035 /// Generate a continuation to pass \p expr to an OPTIONAL argument of an
6036 /// elemental procedure. This is meant to handle the cases where \p expr might
6037 /// be dynamically absent (i.e. when it is a POINTER, an ALLOCATABLE or an
6038 /// OPTIONAL variable). If p\ expr is guaranteed to be present genarr() can
6039 /// directly be called instead.
6040 CC genarrForwardOptionalArgumentToCall(const Fortran::lower::SomeExpr &expr) {
6041 mlir::Location loc = getLoc();
6042 // Only by-value numerical and logical so far.
6043 if (semant != ConstituentSemantics::RefTransparent)
6044 TODO(loc, "optional arguments in user defined elemental procedures");
6045
6046 // Handle scalar argument case (the if-then-else is generated outside of the
6047 // implicit loop nest).
6048 if (expr.Rank() == 0) {
6049 ExtValue optionalArg = asInquired(expr);
6050 mlir::Value isPresent = genActualIsPresentTest(builder, loc, optionalArg);
6051 mlir::Value elementValue =
6052 fir::getBase(genOptionalValue(builder, loc, optionalArg, isPresent));
6053 return [=](IterSpace iters) -> ExtValue { return elementValue; };
6054 }
6055
6056 CC cc;
6057 mlir::Value isPresent;
6058 mlir::Type eleType;
6059 std::tie(cc, isPresent, eleType) = genOptionalArrayFetch(expr);
6060 return [=](IterSpace iters) -> ExtValue {
6061 mlir::Value elementValue =
6062 builder
6063 .genIfOp(loc, {eleType}, isPresent,
6064 /*withElseRegion=*/true)
6065 .genThen([&]() {
6066 builder.create<fir::ResultOp>(loc, fir::getBase(cc(iters)));
6067 })
6068 .genElse([&]() {
6069 mlir::Value zero =
6070 fir::factory::createZeroValue(builder, loc, eleType);
6071 builder.create<fir::ResultOp>(loc, zero);
6072 })
6073 .getResults()[0];
6074 return elementValue;
6075 };
6076 }
6077
6078 /// Reduce the rank of a array to be boxed based on the slice's operands.
6079 static mlir::Type reduceRank(mlir::Type arrTy, mlir::Value slice) {
6080 if (slice) {
6081 auto slOp = mlir::dyn_cast<fir::SliceOp>(slice.getDefiningOp());
6082 assert(slOp && "expected slice op");
6083 auto seqTy = mlir::dyn_cast<fir::SequenceType>(arrTy);
6084 assert(seqTy && "expected array type");
6085 mlir::Operation::operand_range triples = slOp.getTriples();
6086 fir::SequenceType::Shape shape;
6087 // reduce the rank for each invariant dimension
6088 for (unsigned i = 1, end = triples.size(); i < end; i += 3) {
6089 if (auto extent = fir::factory::getExtentFromTriplet(
6090 triples[i - 1], triples[i], triples[i + 1]))
6091 shape.push_back(*extent);
6092 else if (!mlir::isa_and_nonnull<fir::UndefOp>(
6093 triples[i].getDefiningOp()))
6094 shape.push_back(fir::SequenceType::getUnknownExtent());
6095 }
6096 return fir::SequenceType::get(shape, seqTy.getEleTy());
6097 }
6098 // not sliced, so no change in rank
6099 return arrTy;
6100 }
6101
6102 /// Example: <code>array%RE</code>
6103 CC genarr(const Fortran::evaluate::ComplexPart &x,
6104 ComponentPath &components) {
6105 components.reversePath.push_back(&x);
6106 return genarr(x.complex(), components);
6107 }
6108
6109 template <typename A>
6110 CC genSlicePath(const A &x, ComponentPath &components) {
6111 return genarr(x, components);
6112 }
6113
6114 CC genarr(const Fortran::evaluate::StaticDataObject::Pointer &,
6115 ComponentPath &components) {
6116 TODO(getLoc(), "substring of static object inside FORALL");
6117 }
6118
6119 /// Substrings (see 9.4.1)
6120 CC genarr(const Fortran::evaluate::Substring &x, ComponentPath &components) {
6121 components.substring = &x;
6122 return Fortran::common::visit(
6123 [&](const auto &v) { return genarr(v, components); }, x.parent());
6124 }
6125
6126 template <typename T>
6127 CC genarr(const Fortran::evaluate::FunctionRef<T> &funRef) {
6128 // Note that it's possible that the function being called returns either an
6129 // array or a scalar. In the first case, use the element type of the array.
6130 return genProcRef(
6131 funRef, fir::unwrapSequenceType(converter.genType(toEvExpr(funRef))));
6132 }
6133
6134 //===--------------------------------------------------------------------===//
6135 // Array construction
6136 //===--------------------------------------------------------------------===//
6137
6138 /// Target agnostic computation of the size of an element in the array.
6139 /// Returns the size in bytes with type `index` or a null Value if the element
6140 /// size is not constant.
6141 mlir::Value computeElementSize(const ExtValue &exv, mlir::Type eleTy,
6142 mlir::Type resTy) {
6143 mlir::Location loc = getLoc();
6144 mlir::IndexType idxTy = builder.getIndexType();
6145 mlir::Value multiplier = builder.createIntegerConstant(loc, idxTy, 1);
6146 if (fir::hasDynamicSize(eleTy)) {
6147 if (auto charTy = mlir::dyn_cast<fir::CharacterType>(eleTy)) {
6148 // Array of char with dynamic LEN parameter. Downcast to an array
6149 // of singleton char, and scale by the len type parameter from
6150 // `exv`.
6151 exv.match(
6152 [&](const fir::CharBoxValue &cb) { multiplier = cb.getLen(); },
6153 [&](const fir::CharArrayBoxValue &cb) { multiplier = cb.getLen(); },
6154 [&](const fir::BoxValue &box) {
6155 multiplier = fir::factory::CharacterExprHelper(builder, loc)
6156 .readLengthFromBox(box.getAddr());
6157 },
6158 [&](const fir::MutableBoxValue &box) {
6159 multiplier = fir::factory::CharacterExprHelper(builder, loc)
6160 .readLengthFromBox(box.getAddr());
6161 },
6162 [&](const auto &) {
6163 fir::emitFatalError(loc,
6164 "array constructor element has unknown size");
6165 });
6166 fir::CharacterType newEleTy = fir::CharacterType::getSingleton(
6167 eleTy.getContext(), charTy.getFKind());
6168 if (auto seqTy = mlir::dyn_cast<fir::SequenceType>(resTy)) {
6169 assert(eleTy == seqTy.getEleTy());
6170 resTy = fir::SequenceType::get(seqTy.getShape(), newEleTy);
6171 }
6172 eleTy = newEleTy;
6173 } else {
6174 TODO(loc, "dynamic sized type");
6175 }
6176 }
6177 mlir::Type eleRefTy = builder.getRefType(eleTy);
6178 mlir::Type resRefTy = builder.getRefType(resTy);
6179 mlir::Value nullPtr = builder.createNullConstant(loc, resRefTy);
6180 auto offset = builder.create<fir::CoordinateOp>(
6181 loc, eleRefTy, nullPtr, mlir::ValueRange{multiplier});
6182 return builder.createConvert(loc, idxTy, offset);
6183 }
6184
6185 /// Get the function signature of the LLVM memcpy intrinsic.
6186 mlir::FunctionType memcpyType() {
6187 auto ptrTy = mlir::LLVM::LLVMPointerType::get(builder.getContext());
6188 llvm::SmallVector<mlir::Type> args = {ptrTy, ptrTy, builder.getI64Type()};
6189 return mlir::FunctionType::get(builder.getContext(), args, std::nullopt);
6190 }
6191
6192 /// Create a call to the LLVM memcpy intrinsic.
6193 void createCallMemcpy(llvm::ArrayRef<mlir::Value> args, bool isVolatile) {
6194 mlir::Location loc = getLoc();
6195 builder.create<mlir::LLVM::MemcpyOp>(loc, args[0], args[1], args[2],
6196 isVolatile);
6197 }
6198
6199 // Construct code to check for a buffer overrun and realloc the buffer when
6200 // space is depleted. This is done between each item in the ac-value-list.
6201 mlir::Value growBuffer(mlir::Value mem, mlir::Value needed,
6202 mlir::Value bufferSize, mlir::Value buffSize,
6203 mlir::Value eleSz) {
6204 mlir::Location loc = getLoc();
6205 mlir::func::FuncOp reallocFunc = fir::factory::getRealloc(builder);
6206 auto cond = builder.create<mlir::arith::CmpIOp>(
6207 loc, mlir::arith::CmpIPredicate::sle, bufferSize, needed);
6208 auto ifOp = builder.create<fir::IfOp>(loc, mem.getType(), cond,
6209 /*withElseRegion=*/true);
6210 auto insPt = builder.saveInsertionPoint();
6211 builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
6212 // Not enough space, resize the buffer.
6213 mlir::IndexType idxTy = builder.getIndexType();
6214 mlir::Value two = builder.createIntegerConstant(loc, idxTy, 2);
6215 auto newSz = builder.create<mlir::arith::MulIOp>(loc, needed, two);
6216 builder.create<fir::StoreOp>(loc, newSz, buffSize);
6217 mlir::Value byteSz = builder.create<mlir::arith::MulIOp>(loc, newSz, eleSz);
6218 mlir::SymbolRefAttr funcSymAttr =
6219 builder.getSymbolRefAttr(reallocFunc.getName());
6220 mlir::FunctionType funcTy = reallocFunc.getFunctionType();
6221 auto newMem = builder.create<fir::CallOp>(
6222 loc, funcSymAttr, funcTy.getResults(),
6223 llvm::ArrayRef<mlir::Value>{
6224 builder.createConvert(loc, funcTy.getInputs()[0], mem),
6225 builder.createConvert(loc, funcTy.getInputs()[1], byteSz)});
6226 mlir::Value castNewMem =
6227 builder.createConvert(loc, mem.getType(), newMem.getResult(0));
6228 builder.create<fir::ResultOp>(loc, castNewMem);
6229 builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
6230 // Otherwise, just forward the buffer.
6231 builder.create<fir::ResultOp>(loc, mem);
6232 builder.restoreInsertionPoint(insPt);
6233 return ifOp.getResult(0);
6234 }
6235
6236 /// Copy the next value (or vector of values) into the array being
6237 /// constructed.
6238 mlir::Value copyNextArrayCtorSection(const ExtValue &exv, mlir::Value buffPos,
6239 mlir::Value buffSize, mlir::Value mem,
6240 mlir::Value eleSz, mlir::Type eleTy,
6241 mlir::Type eleRefTy, mlir::Type resTy) {
6242 mlir::Location loc = getLoc();
6243 auto off = builder.create<fir::LoadOp>(loc, buffPos);
6244 auto limit = builder.create<fir::LoadOp>(loc, buffSize);
6245 mlir::IndexType idxTy = builder.getIndexType();
6246 mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
6247
6248 if (fir::isRecordWithAllocatableMember(eleTy))
6249 TODO(loc, "deep copy on allocatable members");
6250
6251 if (!eleSz) {
6252 // Compute the element size at runtime.
6253 assert(fir::hasDynamicSize(eleTy));
6254 if (auto charTy = mlir::dyn_cast<fir::CharacterType>(eleTy)) {
6255 auto charBytes =
6256 builder.getKindMap().getCharacterBitsize(charTy.getFKind()) / 8;
6257 mlir::Value bytes =
6258 builder.createIntegerConstant(loc, idxTy, charBytes);
6259 mlir::Value length = fir::getLen(exv);
6260 if (!length)
6261 fir::emitFatalError(loc, "result is not boxed character");
6262 eleSz = builder.create<mlir::arith::MulIOp>(loc, bytes, length);
6263 } else {
6264 TODO(loc, "PDT size");
6265 // Will call the PDT's size function with the type parameters.
6266 }
6267 }
6268
6269 // Compute the coordinate using `fir.coordinate_of`, or, if the type has
6270 // dynamic size, generating the pointer arithmetic.
6271 auto computeCoordinate = [&](mlir::Value buff, mlir::Value off) {
6272 mlir::Type refTy = eleRefTy;
6273 if (fir::hasDynamicSize(eleTy)) {
6274 if (auto charTy = mlir::dyn_cast<fir::CharacterType>(eleTy)) {
6275 // Scale a simple pointer using dynamic length and offset values.
6276 auto chTy = fir::CharacterType::getSingleton(charTy.getContext(),
6277 charTy.getFKind());
6278 refTy = builder.getRefType(chTy);
6279 mlir::Type toTy = builder.getRefType(builder.getVarLenSeqTy(chTy));
6280 buff = builder.createConvert(loc, toTy, buff);
6281 off = builder.create<mlir::arith::MulIOp>(loc, off, eleSz);
6282 } else {
6283 TODO(loc, "PDT offset");
6284 }
6285 }
6286 auto coor = builder.create<fir::CoordinateOp>(loc, refTy, buff,
6287 mlir::ValueRange{off});
6288 return builder.createConvert(loc, eleRefTy, coor);
6289 };
6290
6291 // Lambda to lower an abstract array box value.
6292 auto doAbstractArray = [&](const auto &v) {
6293 // Compute the array size.
6294 mlir::Value arrSz = one;
6295 for (auto ext : v.getExtents())
6296 arrSz = builder.create<mlir::arith::MulIOp>(loc, arrSz, ext);
6297
6298 // Grow the buffer as needed.
6299 auto endOff = builder.create<mlir::arith::AddIOp>(loc, off, arrSz);
6300 mem = growBuffer(mem, endOff, limit, buffSize, eleSz);
6301
6302 // Copy the elements to the buffer.
6303 mlir::Value byteSz =
6304 builder.create<mlir::arith::MulIOp>(loc, arrSz, eleSz);
6305 auto buff = builder.createConvert(loc, fir::HeapType::get(resTy), mem);
6306 mlir::Value buffi = computeCoordinate(buff, off);
6307 llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
6308 builder, loc, memcpyType(), buffi, v.getAddr(), byteSz);
6309 const bool isVolatile = fir::isa_volatile_type(v.getAddr().getType());
6310 createCallMemcpy(args, isVolatile);
6311
6312 // Save the incremented buffer position.
6313 builder.create<fir::StoreOp>(loc, endOff, buffPos);
6314 };
6315
6316 // Copy a trivial scalar value into the buffer.
6317 auto doTrivialScalar = [&](const ExtValue &v, mlir::Value len = {}) {
6318 // Increment the buffer position.
6319 auto plusOne = builder.create<mlir::arith::AddIOp>(loc, off, one);
6320
6321 // Grow the buffer as needed.
6322 mem = growBuffer(mem, plusOne, limit, buffSize, eleSz);
6323
6324 // Store the element in the buffer.
6325 mlir::Value buff =
6326 builder.createConvert(loc, fir::HeapType::get(resTy), mem);
6327 auto buffi = builder.create<fir::CoordinateOp>(loc, eleRefTy, buff,
6328 mlir::ValueRange{off});
6329 fir::factory::genScalarAssignment(
6330 builder, loc,
6331 [&]() -> ExtValue {
6332 if (len)
6333 return fir::CharBoxValue(buffi, len);
6334 return buffi;
6335 }(),
6336 v);
6337 builder.create<fir::StoreOp>(loc, plusOne, buffPos);
6338 };
6339
6340 // Copy the value.
6341 exv.match(
6342 [&](mlir::Value) { doTrivialScalar(exv); },
6343 [&](const fir::CharBoxValue &v) {
6344 auto buffer = v.getBuffer();
6345 if (fir::isa_char(buffer.getType())) {
6346 doTrivialScalar(exv, eleSz);
6347 } else {
6348 // Increment the buffer position.
6349 auto plusOne = builder.create<mlir::arith::AddIOp>(loc, off, one);
6350
6351 // Grow the buffer as needed.
6352 mem = growBuffer(mem, plusOne, limit, buffSize, eleSz);
6353
6354 // Store the element in the buffer.
6355 mlir::Value buff =
6356 builder.createConvert(loc, fir::HeapType::get(resTy), mem);
6357 mlir::Value buffi = computeCoordinate(buff, off);
6358 llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
6359 builder, loc, memcpyType(), buffi, v.getAddr(), eleSz);
6360 const bool isVolatile =
6361 fir::isa_volatile_type(v.getAddr().getType());
6362 createCallMemcpy(args, isVolatile);
6363
6364 builder.create<fir::StoreOp>(loc, plusOne, buffPos);
6365 }
6366 },
6367 [&](const fir::ArrayBoxValue &v) { doAbstractArray(v); },
6368 [&](const fir::CharArrayBoxValue &v) { doAbstractArray(v); },
6369 [&](const auto &) {
6370 TODO(loc, "unhandled array constructor expression");
6371 });
6372 return mem;
6373 }
6374
6375 // Lower the expr cases in an ac-value-list.
6376 template <typename A>
6377 std::pair<ExtValue, bool>
6378 genArrayCtorInitializer(const Fortran::evaluate::Expr<A> &x, mlir::Type,
6379 mlir::Value, mlir::Value, mlir::Value,
6380 Fortran::lower::StatementContext &stmtCtx) {
6381 if (isArray(x))
6382 return {lowerNewArrayExpression(converter, symMap, stmtCtx, toEvExpr(x)),
6383 /*needCopy=*/true};
6384 return {asScalar(x), /*needCopy=*/true};
6385 }
6386
6387 // Lower an ac-implied-do in an ac-value-list.
6388 template <typename A>
6389 std::pair<ExtValue, bool>
6390 genArrayCtorInitializer(const Fortran::evaluate::ImpliedDo<A> &x,
6391 mlir::Type resTy, mlir::Value mem,
6392 mlir::Value buffPos, mlir::Value buffSize,
6393 Fortran::lower::StatementContext &) {
6394 mlir::Location loc = getLoc();
6395 mlir::IndexType idxTy = builder.getIndexType();
6396 mlir::Value lo =
6397 builder.createConvert(loc, idxTy, fir::getBase(asScalar(x.lower())));
6398 mlir::Value up =
6399 builder.createConvert(loc, idxTy, fir::getBase(asScalar(x.upper())));
6400 mlir::Value step =
6401 builder.createConvert(loc, idxTy, fir::getBase(asScalar(x.stride())));
6402 auto seqTy = mlir::cast<fir::SequenceType>(resTy);
6403 mlir::Type eleTy = fir::unwrapSequenceType(seqTy);
6404 auto loop =
6405 builder.create<fir::DoLoopOp>(loc, lo, up, step, /*unordered=*/false,
6406 /*finalCount=*/false, mem);
6407 // create a new binding for x.name(), to ac-do-variable, to the iteration
6408 // value.
6409 symMap.pushImpliedDoBinding(toStringRef(x.name()), loop.getInductionVar());
6410 auto insPt = builder.saveInsertionPoint();
6411 builder.setInsertionPointToStart(loop.getBody());
6412 // Thread mem inside the loop via loop argument.
6413 mem = loop.getRegionIterArgs()[0];
6414
6415 mlir::Type eleRefTy = builder.getRefType(eleTy);
6416
6417 // Any temps created in the loop body must be freed inside the loop body.
6418 stmtCtx.pushScope();
6419 std::optional<mlir::Value> charLen;
6420 for (const Fortran::evaluate::ArrayConstructorValue<A> &acv : x.values()) {
6421 auto [exv, copyNeeded] = Fortran::common::visit(
6422 [&](const auto &v) {
6423 return genArrayCtorInitializer(v, resTy, mem, buffPos, buffSize,
6424 stmtCtx);
6425 },
6426 acv.u);
6427 mlir::Value eleSz = computeElementSize(exv, eleTy, resTy);
6428 mem = copyNeeded ? copyNextArrayCtorSection(exv, buffPos, buffSize, mem,
6429 eleSz, eleTy, eleRefTy, resTy)
6430 : fir::getBase(exv);
6431 if (fir::isa_char(seqTy.getEleTy()) && !charLen) {
6432 charLen = builder.createTemporary(loc, builder.getI64Type());
6433 mlir::Value castLen =
6434 builder.createConvert(loc, builder.getI64Type(), fir::getLen(exv));
6435 assert(charLen.has_value());
6436 builder.create<fir::StoreOp>(loc, castLen, *charLen);
6437 }
6438 }
6439 stmtCtx.finalizeAndPop();
6440
6441 builder.create<fir::ResultOp>(loc, mem);
6442 builder.restoreInsertionPoint(insPt);
6443 mem = loop.getResult(0);
6444 symMap.popImpliedDoBinding();
6445 llvm::SmallVector<mlir::Value> extents = {
6446 builder.create<fir::LoadOp>(loc, buffPos).getResult()};
6447
6448 // Convert to extended value.
6449 if (fir::isa_char(seqTy.getEleTy())) {
6450 assert(charLen.has_value());
6451 auto len = builder.create<fir::LoadOp>(loc, *charLen);
6452 return {fir::CharArrayBoxValue{mem, len, extents}, /*needCopy=*/false};
6453 }
6454 return {fir::ArrayBoxValue{mem, extents}, /*needCopy=*/false};
6455 }
6456
6457 // To simplify the handling and interaction between the various cases, array
6458 // constructors are always lowered to the incremental construction code
6459 // pattern, even if the extent of the array value is constant. After the
6460 // MemToReg pass and constant folding, the optimizer should be able to
6461 // determine that all the buffer overrun tests are false when the
6462 // incremental construction wasn't actually required.
6463 template <typename A>
6464 CC genarr(const Fortran::evaluate::ArrayConstructor<A> &x) {
6465 mlir::Location loc = getLoc();
6466 auto evExpr = toEvExpr(x);
6467 mlir::Type resTy = translateSomeExprToFIRType(converter, evExpr);
6468 mlir::IndexType idxTy = builder.getIndexType();
6469 auto seqTy = mlir::cast<fir::SequenceType>(resTy);
6470 mlir::Type eleTy = fir::unwrapSequenceType(resTy);
6471 mlir::Value buffSize = builder.createTemporary(loc, idxTy, ".buff.size");
6472 mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0);
6473 mlir::Value buffPos = builder.createTemporary(loc, idxTy, ".buff.pos");
6474 builder.create<fir::StoreOp>(loc, zero, buffPos);
6475 // Allocate space for the array to be constructed.
6476 mlir::Value mem;
6477 if (fir::hasDynamicSize(resTy)) {
6478 if (fir::hasDynamicSize(eleTy)) {
6479 // The size of each element may depend on a general expression. Defer
6480 // creating the buffer until after the expression is evaluated.
6481 mem = builder.createNullConstant(loc, builder.getRefType(eleTy));
6482 builder.create<fir::StoreOp>(loc, zero, buffSize);
6483 } else {
6484 mlir::Value initBuffSz =
6485 builder.createIntegerConstant(loc, idxTy, clInitialBufferSize);
6486 mem = builder.create<fir::AllocMemOp>(
6487 loc, eleTy, /*typeparams=*/std::nullopt, initBuffSz);
6488 builder.create<fir::StoreOp>(loc, initBuffSz, buffSize);
6489 }
6490 } else {
6491 mem = builder.create<fir::AllocMemOp>(loc, resTy);
6492 int64_t buffSz = 1;
6493 for (auto extent : seqTy.getShape())
6494 buffSz *= extent;
6495 mlir::Value initBuffSz =
6496 builder.createIntegerConstant(loc, idxTy, buffSz);
6497 builder.create<fir::StoreOp>(loc, initBuffSz, buffSize);
6498 }
6499 // Compute size of element
6500 mlir::Type eleRefTy = builder.getRefType(eleTy);
6501
6502 // Populate the buffer with the elements, growing as necessary.
6503 std::optional<mlir::Value> charLen;
6504 for (const auto &expr : x) {
6505 auto [exv, copyNeeded] = Fortran::common::visit(
6506 [&](const auto &e) {
6507 return genArrayCtorInitializer(e, resTy, mem, buffPos, buffSize,
6508 stmtCtx);
6509 },
6510 expr.u);
6511 mlir::Value eleSz = computeElementSize(exv, eleTy, resTy);
6512 mem = copyNeeded ? copyNextArrayCtorSection(exv, buffPos, buffSize, mem,
6513 eleSz, eleTy, eleRefTy, resTy)
6514 : fir::getBase(exv);
6515 if (fir::isa_char(seqTy.getEleTy()) && !charLen) {
6516 charLen = builder.createTemporary(loc, builder.getI64Type());
6517 mlir::Value castLen =
6518 builder.createConvert(loc, builder.getI64Type(), fir::getLen(exv));
6519 builder.create<fir::StoreOp>(loc, castLen, *charLen);
6520 }
6521 }
6522 mem = builder.createConvert(loc, fir::HeapType::get(resTy), mem);
6523 llvm::SmallVector<mlir::Value> extents = {
6524 builder.create<fir::LoadOp>(loc, buffPos)};
6525
6526 // Cleanup the temporary.
6527 fir::FirOpBuilder *bldr = &converter.getFirOpBuilder();
6528 stmtCtx.attachCleanup(
6529 [bldr, loc, mem]() { bldr->create<fir::FreeMemOp>(loc, mem); });
6530
6531 // Return the continuation.
6532 if (fir::isa_char(seqTy.getEleTy())) {
6533 if (charLen) {
6534 auto len = builder.create<fir::LoadOp>(loc, *charLen);
6535 return genarr(fir::CharArrayBoxValue{mem, len, extents});
6536 }
6537 return genarr(fir::CharArrayBoxValue{mem, zero, extents});
6538 }
6539 return genarr(fir::ArrayBoxValue{mem, extents});
6540 }
6541
6542 CC genarr(const Fortran::evaluate::ImpliedDoIndex &) {
6543 fir::emitFatalError(getLoc(), "implied do index cannot have rank > 0");
6544 }
6545 CC genarr(const Fortran::evaluate::TypeParamInquiry &x) {
6546 TODO(getLoc(), "array expr type parameter inquiry");
6547 return [](IterSpace iters) -> ExtValue { return mlir::Value{}; };
6548 }
6549 CC genarr(const Fortran::evaluate::DescriptorInquiry &x) {
6550 TODO(getLoc(), "array expr descriptor inquiry");
6551 return [](IterSpace iters) -> ExtValue { return mlir::Value{}; };
6552 }
6553 CC genarr(const Fortran::evaluate::StructureConstructor &x) {
6554 TODO(getLoc(), "structure constructor");
6555 return [](IterSpace iters) -> ExtValue { return mlir::Value{}; };
6556 }
6557
6558 //===--------------------------------------------------------------------===//
6559 // LOCICAL operators (.NOT., .AND., .EQV., etc.)
6560 //===--------------------------------------------------------------------===//
6561
6562 template <int KIND>
6563 CC genarr(const Fortran::evaluate::Not<KIND> &x) {
6564 mlir::Location loc = getLoc();
6565 mlir::IntegerType i1Ty = builder.getI1Type();
6566 auto lambda = genarr(x.left());
6567 mlir::Value truth = builder.createBool(loc, true);
6568 return [=](IterSpace iters) -> ExtValue {
6569 mlir::Value logical = fir::getBase(lambda(iters));
6570 mlir::Value val = builder.createConvert(loc, i1Ty, logical);
6571 return builder.create<mlir::arith::XOrIOp>(loc, val, truth);
6572 };
6573 }
6574 template <typename OP, typename A>
6575 CC createBinaryBoolOp(const A &x) {
6576 mlir::Location loc = getLoc();
6577 mlir::IntegerType i1Ty = builder.getI1Type();
6578 auto lf = genarr(x.left());
6579 auto rf = genarr(x.right());
6580 return [=](IterSpace iters) -> ExtValue {
6581 mlir::Value left = fir::getBase(lf(iters));
6582 mlir::Value right = fir::getBase(rf(iters));
6583 mlir::Value lhs = builder.createConvert(loc, i1Ty, left);
6584 mlir::Value rhs = builder.createConvert(loc, i1Ty, right);
6585 return builder.create<OP>(loc, lhs, rhs);
6586 };
6587 }
6588 template <typename OP, typename A>
6589 CC createCompareBoolOp(mlir::arith::CmpIPredicate pred, const A &x) {
6590 mlir::Location loc = getLoc();
6591 mlir::IntegerType i1Ty = builder.getI1Type();
6592 auto lf = genarr(x.left());
6593 auto rf = genarr(x.right());
6594 return [=](IterSpace iters) -> ExtValue {
6595 mlir::Value left = fir::getBase(lf(iters));
6596 mlir::Value right = fir::getBase(rf(iters));
6597 mlir::Value lhs = builder.createConvert(loc, i1Ty, left);
6598 mlir::Value rhs = builder.createConvert(loc, i1Ty, right);
6599 return builder.create<OP>(loc, pred, lhs, rhs);
6600 };
6601 }
6602 template <int KIND>
6603 CC genarr(const Fortran::evaluate::LogicalOperation<KIND> &x) {
6604 switch (x.logicalOperator) {
6605 case Fortran::evaluate::LogicalOperator::And:
6606 return createBinaryBoolOp<mlir::arith::AndIOp>(x);
6607 case Fortran::evaluate::LogicalOperator::Or:
6608 return createBinaryBoolOp<mlir::arith::OrIOp>(x);
6609 case Fortran::evaluate::LogicalOperator::Eqv:
6610 return createCompareBoolOp<mlir::arith::CmpIOp>(
6611 mlir::arith::CmpIPredicate::eq, x);
6612 case Fortran::evaluate::LogicalOperator::Neqv:
6613 return createCompareBoolOp<mlir::arith::CmpIOp>(
6614 mlir::arith::CmpIPredicate::ne, x);
6615 case Fortran::evaluate::LogicalOperator::Not:
6616 llvm_unreachable(".NOT. handled elsewhere");
6617 }
6618 llvm_unreachable("unhandled case");
6619 }
6620
6621 //===--------------------------------------------------------------------===//
6622 // Relational operators (<, <=, ==, etc.)
6623 //===--------------------------------------------------------------------===//
6624
6625 template <typename OP, typename PRED, typename A>
6626 CC createCompareOp(PRED pred, const A &x,
6627 std::optional<int> unsignedKind = std::nullopt) {
6628 mlir::Location loc = getLoc();
6629 auto lf = genarr(x.left());
6630 auto rf = genarr(x.right());
6631 return [=](IterSpace iters) -> ExtValue {
6632 mlir::Value lhs = fir::getBase(lf(iters));
6633 mlir::Value rhs = fir::getBase(rf(iters));
6634 if (unsignedKind) {
6635 mlir::Type signlessType = converter.genType(
6636 Fortran::common::TypeCategory::Integer, *unsignedKind);
6637 mlir::Value lhsSL = builder.createConvert(loc, signlessType, lhs);
6638 mlir::Value rhsSL = builder.createConvert(loc, signlessType, rhs);
6639 return builder.create<OP>(loc, pred, lhsSL, rhsSL);
6640 }
6641 return builder.create<OP>(loc, pred, lhs, rhs);
6642 };
6643 }
6644 template <typename A>
6645 CC createCompareCharOp(mlir::arith::CmpIPredicate pred, const A &x) {
6646 mlir::Location loc = getLoc();
6647 auto lf = genarr(x.left());
6648 auto rf = genarr(x.right());
6649 return [=](IterSpace iters) -> ExtValue {
6650 auto lhs = lf(iters);
6651 auto rhs = rf(iters);
6652 return fir::runtime::genCharCompare(builder, loc, pred, lhs, rhs);
6653 };
6654 }
6655 template <int KIND>
6656 CC genarr(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
6657 Fortran::common::TypeCategory::Integer, KIND>> &x) {
6658 return createCompareOp<mlir::arith::CmpIOp>(
6659 translateSignedRelational(x.opr), x);
6660 }
6661 template <int KIND>
6662 CC genarr(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
6663 Fortran::common::TypeCategory::Unsigned, KIND>> &x) {
6664 return createCompareOp<mlir::arith::CmpIOp>(
6665 translateUnsignedRelational(x.opr), x, KIND);
6666 }
6667 template <int KIND>
6668 CC genarr(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
6669 Fortran::common::TypeCategory::Character, KIND>> &x) {
6670 return createCompareCharOp(translateSignedRelational(x.opr), x);
6671 }
6672 template <int KIND>
6673 CC genarr(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
6674 Fortran::common::TypeCategory::Real, KIND>> &x) {
6675 return createCompareOp<mlir::arith::CmpFOp>(translateFloatRelational(x.opr),
6676 x);
6677 }
6678 template <int KIND>
6679 CC genarr(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
6680 Fortran::common::TypeCategory::Complex, KIND>> &x) {
6681 return createCompareOp<fir::CmpcOp>(translateFloatRelational(x.opr), x);
6682 }
6683 CC genarr(
6684 const Fortran::evaluate::Relational<Fortran::evaluate::SomeType> &r) {
6685 return Fortran::common::visit([&](const auto &x) { return genarr(x); },
6686 r.u);
6687 }
6688
6689 template <typename A>
6690 CC genarr(const Fortran::evaluate::Designator<A> &des) {
6691 ComponentPath components(des.Rank() > 0);
6692 return Fortran::common::visit(
6693 [&](const auto &x) { return genarr(x, components); }, des.u);
6694 }
6695
6696 /// Is the path component rank > 0?
6697 static bool ranked(const PathComponent &x) {
6698 return Fortran::common::visit(
6699 Fortran::common::visitors{
6700 [](const ImplicitSubscripts &) { return false; },
6701 [](const auto *v) { return v->Rank() > 0; }},
6702 x);
6703 }
6704
6705 void extendComponent(Fortran::lower::ComponentPath &component,
6706 mlir::Type coorTy, mlir::ValueRange vals) {
6707 auto *bldr = &converter.getFirOpBuilder();
6708 llvm::SmallVector<mlir::Value> offsets(vals.begin(), vals.end());
6709 auto currentFunc = component.getExtendCoorRef();
6710 auto loc = getLoc();
6711 auto newCoorRef = [bldr, coorTy, offsets, currentFunc,
6712 loc](mlir::Value val) -> mlir::Value {
6713 return bldr->create<fir::CoordinateOp>(loc, bldr->getRefType(coorTy),
6714 currentFunc(val), offsets);
6715 };
6716 component.extendCoorRef = newCoorRef;
6717 }
6718
6719 //===-------------------------------------------------------------------===//
6720 // Array data references in an explicit iteration space.
6721 //
6722 // Use the base array that was loaded before the loop nest.
6723 //===-------------------------------------------------------------------===//
6724
6725 /// Lower the path (`revPath`, in reverse) to be appended to an array_fetch or
6726 /// array_update op. \p ty is the initial type of the array
6727 /// (reference). Returns the type of the element after application of the
6728 /// path in \p components.
6729 ///
6730 /// TODO: This needs to deal with array's with initial bounds other than 1.
6731 /// TODO: Thread type parameters correctly.
6732 mlir::Type lowerPath(const ExtValue &arrayExv, ComponentPath &components) {
6733 mlir::Location loc = getLoc();
6734 mlir::Type ty = fir::getBase(arrayExv).getType();
6735 auto &revPath = components.reversePath;
6736 ty = fir::unwrapPassByRefType(ty);
6737 bool prefix = true;
6738 bool deref = false;
6739 auto addComponentList = [&](mlir::Type ty, mlir::ValueRange vals) {
6740 if (deref) {
6741 extendComponent(components, ty, vals);
6742 } else if (prefix) {
6743 for (auto v : vals)
6744 components.prefixComponents.push_back(v);
6745 } else {
6746 for (auto v : vals)
6747 components.suffixComponents.push_back(v);
6748 }
6749 };
6750 mlir::IndexType idxTy = builder.getIndexType();
6751 mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
6752 bool atBase = true;
6753 PushSemantics(isProjectedCopyInCopyOut()
6754 ? ConstituentSemantics::RefTransparent
6755 : nextPathSemantics());
6756 unsigned index = 0;
6757 for (const auto &v : llvm::reverse(revPath)) {
6758 Fortran::common::visit(
6759 Fortran::common::visitors{
6760 [&](const ImplicitSubscripts &) {
6761 prefix = false;
6762 ty = fir::unwrapSequenceType(ty);
6763 },
6764 [&](const Fortran::evaluate::ComplexPart *x) {
6765 assert(!prefix && "complex part must be at end");
6766 mlir::Value offset = builder.createIntegerConstant(
6767 loc, builder.getI32Type(),
6768 x->part() == Fortran::evaluate::ComplexPart::Part::RE ? 0
6769 : 1);
6770 components.suffixComponents.push_back(offset);
6771 ty = fir::applyPathToType(ty, mlir::ValueRange{offset});
6772 },
6773 [&](const Fortran::evaluate::ArrayRef *x) {
6774 if (Fortran::lower::isRankedArrayAccess(*x)) {
6775 genSliceIndices(components, arrayExv, *x, atBase);
6776 ty = fir::unwrapSeqOrBoxedSeqType(ty);
6777 } else {
6778 // Array access where the expressions are scalar and cannot
6779 // depend upon the implied iteration space.
6780 unsigned ssIndex = 0u;
6781 llvm::SmallVector<mlir::Value> componentsToAdd;
6782 for (const auto &ss : x->subscript()) {
6783 Fortran::common::visit(
6784 Fortran::common::visitors{
6785 [&](const Fortran::evaluate::
6786 IndirectSubscriptIntegerExpr &ie) {
6787 const auto &e = ie.value();
6788 if (isArray(e))
6789 fir::emitFatalError(
6790 loc,
6791 "multiple components along single path "
6792 "generating array subexpressions");
6793 // Lower scalar index expression, append it to
6794 // subs.
6795 mlir::Value subscriptVal =
6796 fir::getBase(asScalarArray(e));
6797 // arrayExv is the base array. It needs to reflect
6798 // the current array component instead.
6799 // FIXME: must use lower bound of this component,
6800 // not just the constant 1.
6801 mlir::Value lb =
6802 atBase ? fir::factory::readLowerBound(
6803 builder, loc, arrayExv, ssIndex,
6804 one)
6805 : one;
6806 mlir::Value val = builder.createConvert(
6807 loc, idxTy, subscriptVal);
6808 mlir::Value ivAdj =
6809 builder.create<mlir::arith::SubIOp>(
6810 loc, idxTy, val, lb);
6811 componentsToAdd.push_back(
6812 builder.createConvert(loc, idxTy, ivAdj));
6813 },
6814 [&](const auto &) {
6815 fir::emitFatalError(
6816 loc, "multiple components along single path "
6817 "generating array subexpressions");
6818 }},
6819 ss.u);
6820 ssIndex++;
6821 }
6822 ty = fir::unwrapSeqOrBoxedSeqType(ty);
6823 addComponentList(ty, componentsToAdd);
6824 }
6825 },
6826 [&](const Fortran::evaluate::Component *x) {
6827 auto fieldTy = fir::FieldType::get(builder.getContext());
6828 std::string name =
6829 converter.getRecordTypeFieldName(getLastSym(*x));
6830 if (auto recTy = mlir::dyn_cast<fir::RecordType>(ty)) {
6831 ty = recTy.getType(name);
6832 auto fld = builder.create<fir::FieldIndexOp>(
6833 loc, fieldTy, name, recTy, fir::getTypeParams(arrayExv));
6834 addComponentList(ty, {fld});
6835 if (index != revPath.size() - 1 || !isPointerAssignment()) {
6836 // Need an intermediate dereference if the boxed value
6837 // appears in the middle of the component path or if it is
6838 // on the right and this is not a pointer assignment.
6839 if (auto boxTy = mlir::dyn_cast<fir::BaseBoxType>(ty)) {
6840 auto currentFunc = components.getExtendCoorRef();
6841 auto loc = getLoc();
6842 auto *bldr = &converter.getFirOpBuilder();
6843 auto newCoorRef = [=](mlir::Value val) -> mlir::Value {
6844 return bldr->create<fir::LoadOp>(loc, currentFunc(val));
6845 };
6846 components.extendCoorRef = newCoorRef;
6847 deref = true;
6848 }
6849 }
6850 } else if (auto boxTy = mlir::dyn_cast<fir::BaseBoxType>(ty)) {
6851 ty = fir::unwrapRefType(boxTy.getEleTy());
6852 auto recTy = mlir::cast<fir::RecordType>(ty);
6853 ty = recTy.getType(name);
6854 auto fld = builder.create<fir::FieldIndexOp>(
6855 loc, fieldTy, name, recTy, fir::getTypeParams(arrayExv));
6856 extendComponent(components, ty, {fld});
6857 } else {
6858 TODO(loc, "other component type");
6859 }
6860 }},
6861 v);
6862 atBase = false;
6863 ++index;
6864 }
6865 ty = fir::unwrapSequenceType(ty);
6866 components.applied = true;
6867 return ty;
6868 }
6869
6870 llvm::SmallVector<mlir::Value> genSubstringBounds(ComponentPath &components) {
6871 llvm::SmallVector<mlir::Value> result;
6872 if (components.substring)
6873 populateBounds(result, components.substring);
6874 return result;
6875 }
6876
6877 CC applyPathToArrayLoad(fir::ArrayLoadOp load, ComponentPath &components) {
6878 mlir::Location loc = getLoc();
6879 auto revPath = components.reversePath;
6880 fir::ExtendedValue arrayExv =
6881 arrayLoadExtValue(builder, loc, load, {}, load);
6882 mlir::Type eleTy = lowerPath(arrayExv, components);
6883 auto currentPC = components.pc;
6884 auto pc = [=, prefix = components.prefixComponents,
6885 suffix = components.suffixComponents](IterSpace iters) {
6886 // Add path prefix and suffix.
6887 return IterationSpace(currentPC(iters), prefix, suffix);
6888 };
6889 components.resetPC();
6890 llvm::SmallVector<mlir::Value> substringBounds =
6891 genSubstringBounds(components);
6892 if (isProjectedCopyInCopyOut()) {
6893 destination = load;
6894 auto lambda = [=, esp = this->explicitSpace](IterSpace iters) mutable {
6895 mlir::Value innerArg = esp->findArgumentOfLoad(load);
6896 if (isAdjustedArrayElementType(eleTy)) {
6897 mlir::Type eleRefTy = builder.getRefType(eleTy);
6898 auto arrayOp = builder.create<fir::ArrayAccessOp>(
6899 loc, eleRefTy, innerArg, iters.iterVec(),
6900 fir::factory::getTypeParams(loc, builder, load));
6901 if (auto charTy = mlir::dyn_cast<fir::CharacterType>(eleTy)) {
6902 mlir::Value dstLen = fir::factory::genLenOfCharacter(
6903 builder, loc, load, iters.iterVec(), substringBounds);
6904 fir::ArrayAmendOp amend = createCharArrayAmend(
6905 loc, builder, arrayOp, dstLen, iters.elementExv(), innerArg,
6906 substringBounds);
6907 return arrayLoadExtValue(builder, loc, load, iters.iterVec(), amend,
6908 dstLen);
6909 }
6910 if (fir::isa_derived(eleTy)) {
6911 fir::ArrayAmendOp amend =
6912 createDerivedArrayAmend(loc, load, builder, arrayOp,
6913 iters.elementExv(), eleTy, innerArg);
6914 return arrayLoadExtValue(builder, loc, load, iters.iterVec(),
6915 amend);
6916 }
6917 assert(mlir::isa<fir::SequenceType>(eleTy));
6918 TODO(loc, "array (as element) assignment");
6919 }
6920 if (components.hasExtendCoorRef()) {
6921 auto eleBoxTy =
6922 fir::applyPathToType(innerArg.getType(), iters.iterVec());
6923 if (!eleBoxTy || !mlir::isa<fir::BoxType>(eleBoxTy))
6924 TODO(loc, "assignment in a FORALL involving a designator with a "
6925 "POINTER or ALLOCATABLE component part-ref");
6926 auto arrayOp = builder.create<fir::ArrayAccessOp>(
6927 loc, builder.getRefType(eleBoxTy), innerArg, iters.iterVec(),
6928 fir::factory::getTypeParams(loc, builder, load));
6929 mlir::Value addr = components.getExtendCoorRef()(arrayOp);
6930 components.resetExtendCoorRef();
6931 // When the lhs is a boxed value and the context is not a pointer
6932 // assignment, then insert the dereference of the box before any
6933 // conversion and store.
6934 if (!isPointerAssignment()) {
6935 if (auto boxTy = mlir::dyn_cast<fir::BaseBoxType>(eleTy)) {
6936 eleTy = fir::boxMemRefType(boxTy);
6937 addr = builder.create<fir::BoxAddrOp>(loc, eleTy, addr);
6938 eleTy = fir::unwrapRefType(eleTy);
6939 }
6940 }
6941 auto ele = convertElementForUpdate(loc, eleTy, iters.getElement());
6942 builder.create<fir::StoreOp>(loc, ele, addr);
6943 auto amend = builder.create<fir::ArrayAmendOp>(
6944 loc, innerArg.getType(), innerArg, arrayOp);
6945 return arrayLoadExtValue(builder, loc, load, iters.iterVec(), amend);
6946 }
6947 auto ele = convertElementForUpdate(loc, eleTy, iters.getElement());
6948 auto update = builder.create<fir::ArrayUpdateOp>(
6949 loc, innerArg.getType(), innerArg, ele, iters.iterVec(),
6950 fir::factory::getTypeParams(loc, builder, load));
6951 return arrayLoadExtValue(builder, loc, load, iters.iterVec(), update);
6952 };
6953 return [=](IterSpace iters) mutable { return lambda(pc(iters)); };
6954 }
6955 if (isCustomCopyInCopyOut()) {
6956 // Create an array_modify to get the LHS element address and indicate
6957 // the assignment, and create the call to the user defined assignment.
6958 destination = load;
6959 auto lambda = [=](IterSpace iters) mutable {
6960 mlir::Value innerArg = explicitSpace->findArgumentOfLoad(load);
6961 mlir::Type refEleTy =
6962 fir::isa_ref_type(eleTy) ? eleTy : builder.getRefType(eleTy);
6963 auto arrModify = builder.create<fir::ArrayModifyOp>(
6964 loc, mlir::TypeRange{refEleTy, innerArg.getType()}, innerArg,
6965 iters.iterVec(), load.getTypeparams());
6966 return arrayLoadExtValue(builder, loc, load, iters.iterVec(),
6967 arrModify.getResult(1));
6968 };
6969 return [=](IterSpace iters) mutable { return lambda(pc(iters)); };
6970 }
6971 auto lambda = [=, semant = this->semant](IterSpace iters) mutable {
6972 if (semant == ConstituentSemantics::RefOpaque ||
6973 isAdjustedArrayElementType(eleTy)) {
6974 mlir::Type resTy = builder.getRefType(eleTy);
6975 // Use array element reference semantics.
6976 auto access = builder.create<fir::ArrayAccessOp>(
6977 loc, resTy, load, iters.iterVec(),
6978 fir::factory::getTypeParams(loc, builder, load));
6979 mlir::Value newBase = access;
6980 if (fir::isa_char(eleTy)) {
6981 mlir::Value dstLen = fir::factory::genLenOfCharacter(
6982 builder, loc, load, iters.iterVec(), substringBounds);
6983 if (!substringBounds.empty()) {
6984 fir::CharBoxValue charDst{access, dstLen};
6985 fir::factory::CharacterExprHelper helper{builder, loc};
6986 charDst = helper.createSubstring(charDst, substringBounds);
6987 newBase = charDst.getAddr();
6988 }
6989 return arrayLoadExtValue(builder, loc, load, iters.iterVec(), newBase,
6990 dstLen);
6991 }
6992 return arrayLoadExtValue(builder, loc, load, iters.iterVec(), newBase);
6993 }
6994 if (components.hasExtendCoorRef()) {
6995 auto eleBoxTy = fir::applyPathToType(load.getType(), iters.iterVec());
6996 if (!eleBoxTy || !mlir::isa<fir::BoxType>(eleBoxTy))
6997 TODO(loc, "assignment in a FORALL involving a designator with a "
6998 "POINTER or ALLOCATABLE component part-ref");
6999 auto access = builder.create<fir::ArrayAccessOp>(
7000 loc, builder.getRefType(eleBoxTy), load, iters.iterVec(),
7001 fir::factory::getTypeParams(loc, builder, load));
7002 mlir::Value addr = components.getExtendCoorRef()(access);
7003 components.resetExtendCoorRef();
7004 return arrayLoadExtValue(builder, loc, load, iters.iterVec(), addr);
7005 }
7006 if (isPointerAssignment()) {
7007 auto eleTy = fir::applyPathToType(load.getType(), iters.iterVec());
7008 if (!mlir::isa<fir::BoxType>(eleTy)) {
7009 // Rhs is a regular expression that will need to be boxed before
7010 // assigning to the boxed variable.
7011 auto typeParams = fir::factory::getTypeParams(loc, builder, load);
7012 auto access = builder.create<fir::ArrayAccessOp>(
7013 loc, builder.getRefType(eleTy), load, iters.iterVec(),
7014 typeParams);
7015 auto addr = components.getExtendCoorRef()(access);
7016 components.resetExtendCoorRef();
7017 auto ptrEleTy = fir::PointerType::get(eleTy);
7018 auto ptrAddr = builder.createConvert(loc, ptrEleTy, addr);
7019 auto boxTy = fir::BoxType::get(
7020 ptrEleTy, fir::isa_volatile_type(addr.getType()));
7021 // FIXME: The typeparams to the load may be different than those of
7022 // the subobject.
7023 if (components.hasExtendCoorRef())
7024 TODO(loc, "need to adjust typeparameter(s) to reflect the final "
7025 "component");
7026 mlir::Value embox =
7027 builder.create<fir::EmboxOp>(loc, boxTy, ptrAddr,
7028 /*shape=*/mlir::Value{},
7029 /*slice=*/mlir::Value{}, typeParams);
7030 return arrayLoadExtValue(builder, loc, load, iters.iterVec(), embox);
7031 }
7032 }
7033 auto fetch = builder.create<fir::ArrayFetchOp>(
7034 loc, eleTy, load, iters.iterVec(), load.getTypeparams());
7035 return arrayLoadExtValue(builder, loc, load, iters.iterVec(), fetch);
7036 };
7037 return [=](IterSpace iters) mutable { return lambda(pc(iters)); };
7038 }
7039
7040 template <typename A>
7041 CC genImplicitArrayAccess(const A &x, ComponentPath &components) {
7042 components.reversePath.push_back(ImplicitSubscripts{});
7043 ExtValue exv = asScalarRef(x);
7044 lowerPath(exv, components);
7045 auto lambda = genarr(exv, components);
7046 return [=](IterSpace iters) { return lambda(components.pc(iters)); };
7047 }
7048 CC genImplicitArrayAccess(const Fortran::evaluate::NamedEntity &x,
7049 ComponentPath &components) {
7050 if (x.IsSymbol())
7051 return genImplicitArrayAccess(getFirstSym(x), components);
7052 return genImplicitArrayAccess(x.GetComponent(), components);
7053 }
7054
7055 CC genImplicitArrayAccess(const Fortran::semantics::Symbol &x,
7056 ComponentPath &components) {
7057 mlir::Value ptrVal = nullptr;
7058 if (x.test(Fortran::semantics::Symbol::Flag::CrayPointee)) {
7059 Fortran::semantics::SymbolRef ptrSym{
7060 Fortran::semantics::GetCrayPointer(x)};
7061 ExtValue ptr = converter.getSymbolExtendedValue(ptrSym);
7062 ptrVal = fir::getBase(ptr);
7063 }
7064 components.reversePath.push_back(ImplicitSubscripts{});
7065 ExtValue exv = asScalarRef(x);
7066 lowerPath(exv, components);
7067 auto lambda = genarr(exv, components, ptrVal);
7068 return [=](IterSpace iters) { return lambda(components.pc(iters)); };
7069 }
7070
7071 template <typename A>
7072 CC genAsScalar(const A &x) {
7073 mlir::Location loc = getLoc();
7074 if (isProjectedCopyInCopyOut()) {
7075 return [=, &x, builder = &converter.getFirOpBuilder()](
7076 IterSpace iters) -> ExtValue {
7077 ExtValue exv = asScalarRef(x);
7078 mlir::Value addr = fir::getBase(exv);
7079 mlir::Type eleTy = fir::unwrapRefType(addr.getType());
7080 if (isAdjustedArrayElementType(eleTy)) {
7081 if (fir::isa_char(eleTy)) {
7082 fir::factory::CharacterExprHelper{*builder, loc}.createAssign(
7083 exv, iters.elementExv());
7084 } else if (fir::isa_derived(eleTy)) {
7085 TODO(loc, "assignment of derived type");
7086 } else {
7087 fir::emitFatalError(loc, "array type not expected in scalar");
7088 }
7089 } else {
7090 auto eleVal = convertElementForUpdate(loc, eleTy, iters.getElement());
7091 builder->create<fir::StoreOp>(loc, eleVal, addr);
7092 }
7093 return exv;
7094 };
7095 }
7096 return [=, &x](IterSpace) { return asScalar(x); };
7097 }
7098
7099 bool tailIsPointerInPointerAssignment(const Fortran::semantics::Symbol &x,
7100 ComponentPath &components) {
7101 return isPointerAssignment() && Fortran::semantics::IsPointer(x) &&
7102 !components.hasComponents();
7103 }
7104 bool tailIsPointerInPointerAssignment(const Fortran::evaluate::Component &x,
7105 ComponentPath &components) {
7106 return tailIsPointerInPointerAssignment(getLastSym(x), components);
7107 }
7108
7109 CC genarr(const Fortran::semantics::Symbol &x, ComponentPath &components) {
7110 if (explicitSpaceIsActive()) {
7111 if (x.Rank() > 0 && !tailIsPointerInPointerAssignment(x, components))
7112 components.reversePath.push_back(ImplicitSubscripts{});
7113 if (fir::ArrayLoadOp load = explicitSpace->findBinding(&x))
7114 return applyPathToArrayLoad(load, components);
7115 } else {
7116 return genImplicitArrayAccess(x, components);
7117 }
7118 if (pathIsEmpty(components))
7119 return components.substring ? genAsScalar(*components.substring)
7120 : genAsScalar(x);
7121 mlir::Location loc = getLoc();
7122 return [=](IterSpace) -> ExtValue {
7123 fir::emitFatalError(loc, "reached symbol with path");
7124 };
7125 }
7126
7127 /// Lower a component path with or without rank.
7128 /// Example: <code>array%baz%qux%waldo</code>
7129 CC genarr(const Fortran::evaluate::Component &x, ComponentPath &components) {
7130 if (explicitSpaceIsActive()) {
7131 if (x.base().Rank() == 0 && x.Rank() > 0 &&
7132 !tailIsPointerInPointerAssignment(x, components))
7133 components.reversePath.push_back(ImplicitSubscripts{});
7134 if (fir::ArrayLoadOp load = explicitSpace->findBinding(&x))
7135 return applyPathToArrayLoad(load, components);
7136 } else {
7137 if (x.base().Rank() == 0)
7138 return genImplicitArrayAccess(x, components);
7139 }
7140 bool atEnd = pathIsEmpty(components);
7141 if (!getLastSym(x).test(Fortran::semantics::Symbol::Flag::ParentComp))
7142 // Skip parent components; their components are placed directly in the
7143 // object.
7144 components.reversePath.push_back(&x);
7145 auto result = genarr(x.base(), components);
7146 if (components.applied)
7147 return result;
7148 if (atEnd)
7149 return genAsScalar(x);
7150 mlir::Location loc = getLoc();
7151 return [=](IterSpace) -> ExtValue {
7152 fir::emitFatalError(loc, "reached component with path");
7153 };
7154 }
7155
7156 /// Array reference with subscripts. If this has rank > 0, this is a form
7157 /// of an array section (slice).
7158 ///
7159 /// There are two "slicing" primitives that may be applied on a dimension by
7160 /// dimension basis: (1) triple notation and (2) vector addressing. Since
7161 /// dimensions can be selectively sliced, some dimensions may contain
7162 /// regular scalar expressions and those dimensions do not participate in
7163 /// the array expression evaluation.
7164 CC genarr(const Fortran::evaluate::ArrayRef &x, ComponentPath &components) {
7165 if (explicitSpaceIsActive()) {
7166 if (Fortran::lower::isRankedArrayAccess(x))
7167 components.reversePath.push_back(ImplicitSubscripts{});
7168 if (fir::ArrayLoadOp load = explicitSpace->findBinding(&x)) {
7169 components.reversePath.push_back(&x);
7170 return applyPathToArrayLoad(load, components);
7171 }
7172 } else {
7173 if (Fortran::lower::isRankedArrayAccess(x)) {
7174 components.reversePath.push_back(&x);
7175 return genImplicitArrayAccess(x.base(), components);
7176 }
7177 }
7178 bool atEnd = pathIsEmpty(components);
7179 components.reversePath.push_back(&x);
7180 auto result = genarr(x.base(), components);
7181 if (components.applied)
7182 return result;
7183 mlir::Location loc = getLoc();
7184 if (atEnd) {
7185 if (x.Rank() == 0)
7186 return genAsScalar(x);
7187 fir::emitFatalError(loc, "expected scalar");
7188 }
7189 return [=](IterSpace) -> ExtValue {
7190 fir::emitFatalError(loc, "reached arrayref with path");
7191 };
7192 }
7193
7194 CC genarr(const Fortran::evaluate::CoarrayRef &x, ComponentPath &components) {
7195 TODO(getLoc(), "coarray: reference to a coarray in an expression");
7196 }
7197
7198 CC genarr(const Fortran::evaluate::NamedEntity &x,
7199 ComponentPath &components) {
7200 return x.IsSymbol() ? genarr(getFirstSym(x), components)
7201 : genarr(x.GetComponent(), components);
7202 }
7203
7204 CC genarr(const Fortran::evaluate::DataRef &x, ComponentPath &components) {
7205 return Fortran::common::visit(
7206 [&](const auto &v) { return genarr(v, components); }, x.u);
7207 }
7208
7209 bool pathIsEmpty(const ComponentPath &components) {
7210 return components.reversePath.empty();
7211 }
7212
7213 explicit ArrayExprLowering(Fortran::lower::AbstractConverter &converter,
7214 Fortran::lower::StatementContext &stmtCtx,
7215 Fortran::lower::SymMap &symMap)
7216 : converter{converter}, builder{converter.getFirOpBuilder()},
7217 stmtCtx{stmtCtx}, symMap{symMap} {}
7218
7219 explicit ArrayExprLowering(Fortran::lower::AbstractConverter &converter,
7220 Fortran::lower::StatementContext &stmtCtx,
7221 Fortran::lower::SymMap &symMap,
7222 ConstituentSemantics sem)
7223 : converter{converter}, builder{converter.getFirOpBuilder()},
7224 stmtCtx{stmtCtx}, symMap{symMap}, semant{sem} {}
7225
7226 explicit ArrayExprLowering(Fortran::lower::AbstractConverter &converter,
7227 Fortran::lower::StatementContext &stmtCtx,
7228 Fortran::lower::SymMap &symMap,
7229 ConstituentSemantics sem,
7230 Fortran::lower::ExplicitIterSpace *expSpace,
7231 Fortran::lower::ImplicitIterSpace *impSpace)
7232 : converter{converter}, builder{converter.getFirOpBuilder()},
7233 stmtCtx{stmtCtx}, symMap{symMap},
7234 explicitSpace((expSpace && expSpace->isActive()) ? expSpace : nullptr),
7235 implicitSpace((impSpace && !impSpace->empty()) ? impSpace : nullptr),
7236 semant{sem} {
7237 // Generate any mask expressions, as necessary. This is the compute step
7238 // that creates the effective masks. See 10.2.3.2 in particular.
7239 genMasks();
7240 }
7241
7242 mlir::Location getLoc() { return converter.getCurrentLocation(); }
7243
7244 /// Array appears in a lhs context such that it is assigned after the rhs is
7245 /// fully evaluated.
7246 inline bool isCopyInCopyOut() {
7247 return semant == ConstituentSemantics::CopyInCopyOut;
7248 }
7249
7250 /// Array appears in a lhs (or temp) context such that a projected,
7251 /// discontiguous subspace of the array is assigned after the rhs is fully
7252 /// evaluated. That is, the rhs array value is merged into a section of the
7253 /// lhs array.
7254 inline bool isProjectedCopyInCopyOut() {
7255 return semant == ConstituentSemantics::ProjectedCopyInCopyOut;
7256 }
7257
7258 // ???: Do we still need this?
7259 inline bool isCustomCopyInCopyOut() {
7260 return semant == ConstituentSemantics::CustomCopyInCopyOut;
7261 }
7262
7263 /// Are we lowering in a left-hand side context?
7264 inline bool isLeftHandSide() {
7265 return isCopyInCopyOut() || isProjectedCopyInCopyOut() ||
7266 isCustomCopyInCopyOut();
7267 }
7268
7269 /// Array appears in a context where it must be boxed.
7270 inline bool isBoxValue() { return semant == ConstituentSemantics::BoxValue; }
7271
7272 /// Array appears in a context where differences in the memory reference can
7273 /// be observable in the computational results. For example, an array
7274 /// element is passed to an impure procedure.
7275 inline bool isReferentiallyOpaque() {
7276 return semant == ConstituentSemantics::RefOpaque;
7277 }
7278
7279 /// Array appears in a context where it is passed as a VALUE argument.
7280 inline bool isValueAttribute() {
7281 return semant == ConstituentSemantics::ByValueArg;
7282 }
7283
7284 /// Semantics to use when lowering the next array path.
7285 /// If no value was set, the path uses the same semantics as the array.
7286 inline ConstituentSemantics nextPathSemantics() {
7287 if (nextPathSemant) {
7288 ConstituentSemantics sema = nextPathSemant.value();
7289 nextPathSemant.reset();
7290 return sema;
7291 }
7292
7293 return semant;
7294 }
7295
7296 /// Can the loops over the expression be unordered?
7297 inline bool isUnordered() const { return unordered; }
7298
7299 void setUnordered(bool b) { unordered = b; }
7300
7301 inline bool isPointerAssignment() const { return lbounds.has_value(); }
7302
7303 inline bool isBoundsSpec() const {
7304 return isPointerAssignment() && !ubounds.has_value();
7305 }
7306
7307 inline bool isBoundsRemap() const {
7308 return isPointerAssignment() && ubounds.has_value();
7309 }
7310
7311 void setPointerAssignmentBounds(
7312 const llvm::SmallVector<mlir::Value> &lbs,
7313 std::optional<llvm::SmallVector<mlir::Value>> ubs) {
7314 lbounds = lbs;
7315 ubounds = ubs;
7316 }
7317
7318 void setLoweredProcRef(const Fortran::evaluate::ProcedureRef *procRef) {
7319 loweredProcRef = procRef;
7320 }
7321
7322 Fortran::lower::AbstractConverter &converter;
7323 fir::FirOpBuilder &builder;
7324 Fortran::lower::StatementContext &stmtCtx;
7325 bool elementCtx = false;
7326 Fortran::lower::SymMap &symMap;
7327 /// The continuation to generate code to update the destination.
7328 std::optional<CC> ccStoreToDest;
7329 std::optional<std::function<void(llvm::ArrayRef<mlir::Value>)>> ccPrelude;
7330 std::optional<std::function<fir::ArrayLoadOp(llvm::ArrayRef<mlir::Value>)>>
7331 ccLoadDest;
7332 /// The destination is the loaded array into which the results will be
7333 /// merged.
7334 fir::ArrayLoadOp destination;
7335 /// The shape of the destination.
7336 llvm::SmallVector<mlir::Value> destShape;
7337 /// List of arrays in the expression that have been loaded.
7338 llvm::SmallVector<ArrayOperand> arrayOperands;
7339 /// If there is a user-defined iteration space, explicitShape will hold the
7340 /// information from the front end.
7341 Fortran::lower::ExplicitIterSpace *explicitSpace = nullptr;
7342 Fortran::lower::ImplicitIterSpace *implicitSpace = nullptr;
7343 ConstituentSemantics semant = ConstituentSemantics::RefTransparent;
7344 std::optional<ConstituentSemantics> nextPathSemant;
7345 /// `lbounds`, `ubounds` are used in POINTER value assignments, which may only
7346 /// occur in an explicit iteration space.
7347 std::optional<llvm::SmallVector<mlir::Value>> lbounds;
7348 std::optional<llvm::SmallVector<mlir::Value>> ubounds;
7349 // Can the array expression be evaluated in any order?
7350 // Will be set to false if any of the expression parts prevent this.
7351 bool unordered = true;
7352 // ProcedureRef currently being lowered. Used to retrieve the iteration shape
7353 // in elemental context with passed object.
7354 const Fortran::evaluate::ProcedureRef *loweredProcRef = nullptr;
7355};
7356} // namespace
7357
7358fir::ExtendedValue Fortran::lower::createSomeExtendedExpression(
7359 mlir::Location loc, Fortran::lower::AbstractConverter &converter,
7360 const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
7361 Fortran::lower::StatementContext &stmtCtx) {
7362 LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "expr: ") << '\n');
7363 return ScalarExprLowering{loc, converter, symMap, stmtCtx}.genval(expr);
7364}
7365
7366fir::ExtendedValue Fortran::lower::createSomeInitializerExpression(
7367 mlir::Location loc, Fortran::lower::AbstractConverter &converter,
7368 const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
7369 Fortran::lower::StatementContext &stmtCtx) {
7370 LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "expr: ") << '\n');
7371 return ScalarExprLowering{loc, converter, symMap, stmtCtx,
7372 /*inInitializer=*/true}
7373 .genval(expr);
7374}
7375
7376fir::ExtendedValue Fortran::lower::createSomeExtendedAddress(
7377 mlir::Location loc, Fortran::lower::AbstractConverter &converter,
7378 const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
7379 Fortran::lower::StatementContext &stmtCtx) {
7380 LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "address: ") << '\n');
7381 return ScalarExprLowering(loc, converter, symMap, stmtCtx).gen(expr);
7382}
7383
7384fir::ExtendedValue Fortran::lower::createInitializerAddress(
7385 mlir::Location loc, Fortran::lower::AbstractConverter &converter,
7386 const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
7387 Fortran::lower::StatementContext &stmtCtx) {
7388 LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "address: ") << '\n');
7389 return ScalarExprLowering(loc, converter, symMap, stmtCtx,
7390 /*inInitializer=*/true)
7391 .gen(expr);
7392}
7393
7394void Fortran::lower::createSomeArrayAssignment(
7395 Fortran::lower::AbstractConverter &converter,
7396 const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
7397 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
7398 LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "onto array: ") << '\n';
7399 rhs.AsFortran(llvm::dbgs() << "assign expression: ") << '\n';);
7400 ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs);
7401}
7402
7403void Fortran::lower::createSomeArrayAssignment(
7404 Fortran::lower::AbstractConverter &converter, const fir::ExtendedValue &lhs,
7405 const Fortran::lower::SomeExpr &rhs, Fortran::lower::SymMap &symMap,
7406 Fortran::lower::StatementContext &stmtCtx) {
7407 LLVM_DEBUG(llvm::dbgs() << "onto array: " << lhs << '\n';
7408 rhs.AsFortran(llvm::dbgs() << "assign expression: ") << '\n';);
7409 ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs);
7410}
7411void Fortran::lower::createSomeArrayAssignment(
7412 Fortran::lower::AbstractConverter &converter, const fir::ExtendedValue &lhs,
7413 const fir::ExtendedValue &rhs, Fortran::lower::SymMap &symMap,
7414 Fortran::lower::StatementContext &stmtCtx) {
7415 LLVM_DEBUG(llvm::dbgs() << "onto array: " << lhs << '\n';
7416 llvm::dbgs() << "assign expression: " << rhs << '\n';);
7417 ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs);
7418}
7419
7420void Fortran::lower::createAnyMaskedArrayAssignment(
7421 Fortran::lower::AbstractConverter &converter,
7422 const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
7423 Fortran::lower::ExplicitIterSpace &explicitSpace,
7424 Fortran::lower::ImplicitIterSpace &implicitSpace,
7425 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
7426 LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "onto array: ") << '\n';
7427 rhs.AsFortran(llvm::dbgs() << "assign expression: ")
7428 << " given the explicit iteration space:\n"
7429 << explicitSpace << "\n and implied mask conditions:\n"
7430 << implicitSpace << '\n';);
7431 ArrayExprLowering::lowerAnyMaskedArrayAssignment(
7432 converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace);
7433}
7434
7435void Fortran::lower::createAllocatableArrayAssignment(
7436 Fortran::lower::AbstractConverter &converter,
7437 const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
7438 Fortran::lower::ExplicitIterSpace &explicitSpace,
7439 Fortran::lower::ImplicitIterSpace &implicitSpace,
7440 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
7441 LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "defining array: ") << '\n';
7442 rhs.AsFortran(llvm::dbgs() << "assign expression: ")
7443 << " given the explicit iteration space:\n"
7444 << explicitSpace << "\n and implied mask conditions:\n"
7445 << implicitSpace << '\n';);
7446 ArrayExprLowering::lowerAllocatableArrayAssignment(
7447 converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace);
7448}
7449
7450void Fortran::lower::createArrayOfPointerAssignment(
7451 Fortran::lower::AbstractConverter &converter,
7452 const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
7453 Fortran::lower::ExplicitIterSpace &explicitSpace,
7454 Fortran::lower::ImplicitIterSpace &implicitSpace,
7455 const llvm::SmallVector<mlir::Value> &lbounds,
7456 std::optional<llvm::SmallVector<mlir::Value>> ubounds,
7457 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
7458 LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "defining pointer: ") << '\n';
7459 rhs.AsFortran(llvm::dbgs() << "assign expression: ")
7460 << " given the explicit iteration space:\n"
7461 << explicitSpace << "\n and implied mask conditions:\n"
7462 << implicitSpace << '\n';);
7463 assert(explicitSpace.isActive() && "must be in FORALL construct");
7464 ArrayExprLowering::lowerArrayOfPointerAssignment(
7465 converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace,
7466 lbounds, ubounds);
7467}
7468
7469fir::ExtendedValue Fortran::lower::createSomeArrayTempValue(
7470 Fortran::lower::AbstractConverter &converter,
7471 const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
7472 Fortran::lower::StatementContext &stmtCtx) {
7473 LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "array value: ") << '\n');
7474 return ArrayExprLowering::lowerNewArrayExpression(converter, symMap, stmtCtx,
7475 expr);
7476}
7477
7478void Fortran::lower::createLazyArrayTempValue(
7479 Fortran::lower::AbstractConverter &converter,
7480 const Fortran::lower::SomeExpr &expr, mlir::Value raggedHeader,
7481 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
7482 LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "array value: ") << '\n');
7483 ArrayExprLowering::lowerLazyArrayExpression(converter, symMap, stmtCtx, expr,
7484 raggedHeader);
7485}
7486
7487fir::ExtendedValue
7488Fortran::lower::createSomeArrayBox(Fortran::lower::AbstractConverter &converter,
7489 const Fortran::lower::SomeExpr &expr,
7490 Fortran::lower::SymMap &symMap,
7491 Fortran::lower::StatementContext &stmtCtx) {
7492 LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "box designator: ") << '\n');
7493 return ArrayExprLowering::lowerBoxedArrayExpression(converter, symMap,
7494 stmtCtx, expr);
7495}
7496
7497fir::MutableBoxValue Fortran::lower::createMutableBox(
7498 mlir::Location loc, Fortran::lower::AbstractConverter &converter,
7499 const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap) {
7500 // MutableBox lowering StatementContext does not need to be propagated
7501 // to the caller because the result value is a variable, not a temporary
7502 // expression. The StatementContext clean-up can occur before using the
7503 // resulting MutableBoxValue. Variables of all other types are handled in the
7504 // bridge.
7505 Fortran::lower::StatementContext dummyStmtCtx;
7506 return ScalarExprLowering{loc, converter, symMap, dummyStmtCtx}
7507 .genMutableBoxValue(expr);
7508}
7509
7510bool Fortran::lower::isParentComponent(const Fortran::lower::SomeExpr &expr) {
7511 if (const Fortran::semantics::Symbol * symbol{GetLastSymbol(expr)}) {
7512 if (symbol->test(Fortran::semantics::Symbol::Flag::ParentComp))
7513 return true;
7514 }
7515 return false;
7516}
7517
7518// Handling special case where the last component is referring to the
7519// parent component.
7520//
7521// TYPE t
7522// integer :: a
7523// END TYPE
7524// TYPE, EXTENDS(t) :: t2
7525// integer :: b
7526// END TYPE
7527// TYPE(t2) :: y(2)
7528// TYPE(t2) :: a
7529// y(:)%t ! just need to update the box with a slice pointing to the first
7530// ! component of `t`.
7531// a%t ! simple conversion to TYPE(t).
7532fir::ExtendedValue Fortran::lower::updateBoxForParentComponent(
7533 Fortran::lower::AbstractConverter &converter, fir::ExtendedValue box,
7534 const Fortran::lower::SomeExpr &expr) {
7535 mlir::Location loc = converter.getCurrentLocation();
7536 auto &builder = converter.getFirOpBuilder();
7537 mlir::Value boxBase = fir::getBase(box);
7538 mlir::Operation *op = boxBase.getDefiningOp();
7539 mlir::Type actualTy = converter.genType(expr);
7540
7541 if (op) {
7542 if (auto embox = mlir::dyn_cast<fir::EmboxOp>(op)) {
7543 auto newBox = builder.create<fir::EmboxOp>(
7544 loc, fir::BoxType::get(actualTy), embox.getMemref(), embox.getShape(),
7545 embox.getSlice(), embox.getTypeparams());
7546 return fir::substBase(box, newBox);
7547 }
7548 if (auto rebox = mlir::dyn_cast<fir::ReboxOp>(op)) {
7549 auto newBox = builder.create<fir::ReboxOp>(
7550 loc, fir::BoxType::get(actualTy), rebox.getBox(), rebox.getShape(),
7551 rebox.getSlice());
7552 return fir::substBase(box, newBox);
7553 }
7554 }
7555
7556 mlir::Value empty;
7557 mlir::ValueRange emptyRange;
7558 return builder.create<fir::ReboxOp>(loc, fir::BoxType::get(actualTy), boxBase,
7559 /*shape=*/empty,
7560 /*slice=*/empty);
7561}
7562
7563fir::ExtendedValue Fortran::lower::createBoxValue(
7564 mlir::Location loc, Fortran::lower::AbstractConverter &converter,
7565 const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
7566 Fortran::lower::StatementContext &stmtCtx) {
7567 if (expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) &&
7568 !Fortran::evaluate::HasVectorSubscript(expr)) {
7569 fir::ExtendedValue result =
7570 Fortran::lower::createSomeArrayBox(converter, expr, symMap, stmtCtx);
7571 if (isParentComponent(expr))
7572 result = updateBoxForParentComponent(converter, result, expr);
7573 return result;
7574 }
7575 fir::ExtendedValue addr = Fortran::lower::createSomeExtendedAddress(
7576 loc, converter, expr, symMap, stmtCtx);
7577 fir::ExtendedValue result = fir::BoxValue(
7578 converter.getFirOpBuilder().createBox(loc, addr, addr.isPolymorphic()));
7579 if (isParentComponent(expr))
7580 result = updateBoxForParentComponent(converter, result, expr);
7581 return result;
7582}
7583
7584mlir::Value Fortran::lower::createSubroutineCall(
7585 AbstractConverter &converter, const evaluate::ProcedureRef &call,
7586 ExplicitIterSpace &explicitIterSpace, ImplicitIterSpace &implicitIterSpace,
7587 SymMap &symMap, StatementContext &stmtCtx, bool isUserDefAssignment) {
7588 mlir::Location loc = converter.getCurrentLocation();
7589
7590 if (isUserDefAssignment) {
7591 assert(call.arguments().size() == 2);
7592 const auto *lhs = call.arguments()[0].value().UnwrapExpr();
7593 const auto *rhs = call.arguments()[1].value().UnwrapExpr();
7594 assert(lhs && rhs &&
7595 "user defined assignment arguments must be expressions");
7596 if (call.IsElemental() && lhs->Rank() > 0) {
7597 // Elemental user defined assignment has special requirements to deal with
7598 // LHS/RHS overlaps. See 10.2.1.5 p2.
7599 ArrayExprLowering::lowerElementalUserAssignment(
7600 converter, symMap, stmtCtx, explicitIterSpace, implicitIterSpace,
7601 call);
7602 } else if (explicitIterSpace.isActive() && lhs->Rank() == 0) {
7603 // Scalar defined assignment (elemental or not) in a FORALL context.
7604 mlir::func::FuncOp func =
7605 Fortran::lower::CallerInterface(call, converter).getFuncOp();
7606 ArrayExprLowering::lowerScalarUserAssignment(
7607 converter, symMap, stmtCtx, explicitIterSpace, func, *lhs, *rhs);
7608 } else if (explicitIterSpace.isActive()) {
7609 // TODO: need to array fetch/modify sub-arrays?
7610 TODO(loc, "non elemental user defined array assignment inside FORALL");
7611 } else {
7612 if (!implicitIterSpace.empty())
7613 fir::emitFatalError(
7614 loc,
7615 "C1032: user defined assignment inside WHERE must be elemental");
7616 // Non elemental user defined assignment outside of FORALL and WHERE.
7617 // FIXME: The non elemental user defined assignment case with array
7618 // arguments must be take into account potential overlap. So far the front
7619 // end does not add parentheses around the RHS argument in the call as it
7620 // should according to 15.4.3.4.3 p2.
7621 Fortran::lower::createSomeExtendedExpression(
7622 loc, converter, toEvExpr(call), symMap, stmtCtx);
7623 }
7624 return {};
7625 }
7626
7627 assert(implicitIterSpace.empty() && !explicitIterSpace.isActive() &&
7628 "subroutine calls are not allowed inside WHERE and FORALL");
7629
7630 if (isElementalProcWithArrayArgs(call)) {
7631 ArrayExprLowering::lowerElementalSubroutine(converter, symMap, stmtCtx,
7632 toEvExpr(call));
7633 return {};
7634 }
7635 // Simple subroutine call, with potential alternate return.
7636 auto res = Fortran::lower::createSomeExtendedExpression(
7637 loc, converter, toEvExpr(call), symMap, stmtCtx);
7638 return fir::getBase(res);
7639}
7640
7641template <typename A>
7642fir::ArrayLoadOp genArrayLoad(mlir::Location loc,
7643 Fortran::lower::AbstractConverter &converter,
7644 fir::FirOpBuilder &builder, const A *x,
7645 Fortran::lower::SymMap &symMap,
7646 Fortran::lower::StatementContext &stmtCtx) {
7647 auto exv = ScalarExprLowering{loc, converter, symMap, stmtCtx}.gen(*x);
7648 mlir::Value addr = fir::getBase(exv);
7649 mlir::Value shapeOp = builder.createShape(loc, exv);
7650 mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(addr.getType());
7651 return builder.create<fir::ArrayLoadOp>(loc, arrTy, addr, shapeOp,
7652 /*slice=*/mlir::Value{},
7653 fir::getTypeParams(exv));
7654}
7655template <>
7656fir::ArrayLoadOp
7657genArrayLoad(mlir::Location loc, Fortran::lower::AbstractConverter &converter,
7658 fir::FirOpBuilder &builder, const Fortran::evaluate::ArrayRef *x,
7659 Fortran::lower::SymMap &symMap,
7660 Fortran::lower::StatementContext &stmtCtx) {
7661 if (x->base().IsSymbol())
7662 return genArrayLoad(loc, converter, builder, &getLastSym(x->base()), symMap,
7663 stmtCtx);
7664 return genArrayLoad(loc, converter, builder, &x->base().GetComponent(),
7665 symMap, stmtCtx);
7666}
7667
7668void Fortran::lower::createArrayLoads(
7669 Fortran::lower::AbstractConverter &converter,
7670 Fortran::lower::ExplicitIterSpace &esp, Fortran::lower::SymMap &symMap) {
7671 std::size_t counter = esp.getCounter();
7672 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
7673 mlir::Location loc = converter.getCurrentLocation();
7674 Fortran::lower::StatementContext &stmtCtx = esp.stmtContext();
7675 // Gen the fir.array_load ops.
7676 auto genLoad = [&](const auto *x) -> fir::ArrayLoadOp {
7677 return genArrayLoad(loc, converter, builder, x, symMap, stmtCtx);
7678 };
7679 if (esp.lhsBases[counter]) {
7680 auto &base = *esp.lhsBases[counter];
7681 auto load = Fortran::common::visit(genLoad, base);
7682 esp.initialArgs.push_back(load);
7683 esp.resetInnerArgs();
7684 esp.bindLoad(base, load);
7685 }
7686 for (const auto &base : esp.rhsBases[counter])
7687 esp.bindLoad(base, Fortran::common::visit(genLoad, base));
7688}
7689
7690void Fortran::lower::createArrayMergeStores(
7691 Fortran::lower::AbstractConverter &converter,
7692 Fortran::lower::ExplicitIterSpace &esp) {
7693 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
7694 mlir::Location loc = converter.getCurrentLocation();
7695 builder.setInsertionPointAfter(esp.getOuterLoop());
7696 // Gen the fir.array_merge_store ops for all LHS arrays.
7697 for (auto i : llvm::enumerate(esp.getOuterLoop().getResults()))
7698 if (std::optional<fir::ArrayLoadOp> ldOpt = esp.getLhsLoad(i.index())) {
7699 fir::ArrayLoadOp load = *ldOpt;
7700 builder.create<fir::ArrayMergeStoreOp>(loc, load, i.value(),
7701 load.getMemref(), load.getSlice(),
7702 load.getTypeparams());
7703 }
7704 if (esp.loopCleanup) {
7705 (*esp.loopCleanup)(builder);
7706 esp.loopCleanup = std::nullopt;
7707 }
7708 esp.initialArgs.clear();
7709 esp.innerArgs.clear();
7710 esp.outerLoop = std::nullopt;
7711 esp.resetBindings();
7712 esp.incrementCounter();
7713}
7714
7715mlir::Value Fortran::lower::addCrayPointerInst(mlir::Location loc,
7716 fir::FirOpBuilder &builder,
7717 mlir::Value ptrVal,
7718 mlir::Type ptrTy,
7719 mlir::Type pteTy) {
7720
7721 mlir::Value empty;
7722 mlir::ValueRange emptyRange;
7723 auto boxTy = fir::BoxType::get(ptrTy);
7724 auto box = builder.create<fir::EmboxOp>(loc, boxTy, ptrVal, empty, empty,
7725 emptyRange);
7726 mlir::Value addrof =
7727 (mlir::isa<fir::ReferenceType>(ptrTy))
7728 ? builder.create<fir::BoxAddrOp>(loc, ptrTy, box)
7729 : builder.create<fir::BoxAddrOp>(loc, builder.getRefType(ptrTy), box);
7730
7731 auto refPtrTy =
7732 builder.getRefType(fir::PointerType::get(fir::dyn_cast_ptrEleTy(pteTy)));
7733 return builder.createConvert(loc, refPtrTy, addrof);
7734}
7735

source code of flang/lib/Lower/ConvertExpr.cpp