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

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