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