brintos / llvm-project-archived public Read only

1//===-- ConvertCall.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/ConvertCall.h"14#include "flang/Lower/Allocatable.h"15#include "flang/Lower/ConvertExprToHLFIR.h"16#include "flang/Lower/ConvertProcedureDesignator.h"17#include "flang/Lower/ConvertVariable.h"18#include "flang/Lower/CustomIntrinsicCall.h"19#include "flang/Lower/HlfirIntrinsics.h"20#include "flang/Lower/PFTBuilder.h"21#include "flang/Lower/StatementContext.h"22#include "flang/Lower/SymbolMap.h"23#include "flang/Optimizer/Builder/BoxValue.h"24#include "flang/Optimizer/Builder/CUFCommon.h"25#include "flang/Optimizer/Builder/Character.h"26#include "flang/Optimizer/Builder/FIRBuilder.h"27#include "flang/Optimizer/Builder/HLFIRTools.h"28#include "flang/Optimizer/Builder/IntrinsicCall.h"29#include "flang/Optimizer/Builder/LowLevelIntrinsics.h"30#include "flang/Optimizer/Builder/MutableBox.h"31#include "flang/Optimizer/Builder/Runtime/CUDA/Descriptor.h"32#include "flang/Optimizer/Builder/Runtime/Derived.h"33#include "flang/Optimizer/Builder/Todo.h"34#include "flang/Optimizer/Dialect/CUF/CUFOps.h"35#include "flang/Optimizer/Dialect/FIROpsSupport.h"36#include "flang/Optimizer/HLFIR/HLFIROps.h"37#include "mlir/IR/IRMapping.h"38#include "llvm/ADT/TypeSwitch.h"39#include "llvm/Support/CommandLine.h"40#include "llvm/Support/Debug.h"41#include <optional>42 43#define DEBUG_TYPE "flang-lower-expr"44 45static llvm::cl::opt<bool> useHlfirIntrinsicOps(46    "use-hlfir-intrinsic-ops", llvm::cl::init(true),47    llvm::cl::desc("Lower via HLFIR transformational intrinsic operations such "48                   "as hlfir.sum"));49 50static constexpr char tempResultName[] = ".tmp.func_result";51 52/// Helper to package a Value and its properties into an ExtendedValue.53static fir::ExtendedValue toExtendedValue(mlir::Location loc, mlir::Value base,54                                          llvm::ArrayRef<mlir::Value> extents,55                                          llvm::ArrayRef<mlir::Value> lengths) {56  mlir::Type type = base.getType();57  if (mlir::isa<fir::BaseBoxType>(type))58    return fir::BoxValue(base, /*lbounds=*/{}, lengths, extents);59  type = fir::unwrapRefType(type);60  if (mlir::isa<fir::BaseBoxType>(type))61    return fir::MutableBoxValue(base, lengths, /*mutableProperties*/ {});62  if (auto seqTy = mlir::dyn_cast<fir::SequenceType>(type)) {63    if (seqTy.getDimension() != extents.size())64      fir::emitFatalError(loc, "incorrect number of extents for array");65    if (mlir::isa<fir::CharacterType>(seqTy.getEleTy())) {66      if (lengths.empty())67        fir::emitFatalError(loc, "missing length for character");68      assert(lengths.size() == 1);69      return fir::CharArrayBoxValue(base, lengths[0], extents);70    }71    return fir::ArrayBoxValue(base, extents);72  }73  if (mlir::isa<fir::CharacterType>(type)) {74    if (lengths.empty())75      fir::emitFatalError(loc, "missing length for character");76    assert(lengths.size() == 1);77    return fir::CharBoxValue(base, lengths[0]);78  }79  return base;80}81 82/// Lower a type(C_PTR/C_FUNPTR) argument with VALUE attribute into a83/// reference. A C pointer can correspond to a Fortran dummy argument of type84/// C_PTR with the VALUE attribute. (see 18.3.6 note 3).85static mlir::Value genRecordCPtrValueArg(fir::FirOpBuilder &builder,86                                         mlir::Location loc, mlir::Value rec,87                                         mlir::Type ty) {88  mlir::Value cAddr = fir::factory::genCPtrOrCFunptrAddr(builder, loc, rec, ty);89  mlir::Value cVal = fir::LoadOp::create(builder, loc, cAddr);90  return builder.createConvert(loc, cAddr.getType(), cVal);91}92 93// Find the argument that corresponds to the host associations.94// Verify some assumptions about how the signature was built here.95[[maybe_unused]] static unsigned findHostAssocTuplePos(mlir::func::FuncOp fn) {96  // Scan the argument list from last to first as the host associations are97  // appended for now.98  for (unsigned i = fn.getNumArguments(); i > 0; --i)99    if (fn.getArgAttr(i - 1, fir::getHostAssocAttrName())) {100      // Host assoc tuple must be last argument (for now).101      assert(i == fn.getNumArguments() && "tuple must be last");102      return i - 1;103    }104  llvm_unreachable("anyFuncArgsHaveAttr failed");105}106 107mlir::Value108Fortran::lower::argumentHostAssocs(Fortran::lower::AbstractConverter &converter,109                                   mlir::Value arg) {110  if (auto addr = mlir::dyn_cast_or_null<fir::AddrOfOp>(arg.getDefiningOp())) {111    auto &builder = converter.getFirOpBuilder();112    if (auto funcOp = builder.getNamedFunction(addr.getSymbol()))113      if (fir::anyFuncArgsHaveAttr(funcOp, fir::getHostAssocAttrName()))114        return converter.hostAssocTupleValue();115  }116  return {};117}118 119static bool mustCastFuncOpToCopeWithImplicitInterfaceMismatch(120    mlir::Location loc, Fortran::lower::AbstractConverter &converter,121    mlir::FunctionType callSiteType, mlir::FunctionType funcOpType) {122  // Deal with argument number mismatch by making a function pointer so123  // that function type cast can be inserted. Do not emit a warning here124  // because this can happen in legal program if the function is not125  // defined here and it was first passed as an argument without any more126  // information.127  if (callSiteType.getNumResults() != funcOpType.getNumResults() ||128      callSiteType.getNumInputs() != funcOpType.getNumInputs())129    return true;130 131  // Implicit interface result type mismatch are not standard Fortran, but132  // some compilers are not complaining about it.  The front end is not133  // protecting lowering from this currently. Support this with a134  // discouraging warning.135  // Cast the actual function to the current caller implicit type because136  // that is the behavior we would get if we could not see the definition.137  if (callSiteType.getResults() != funcOpType.getResults()) {138    LLVM_DEBUG(mlir::emitWarning(139        loc, "a return type mismatch is not standard compliant and may "140             "lead to undefined behavior."));141    return true;142  }143 144  // In HLFIR, there is little attempt to cope with implicit interface145  // mismatch on the arguments. The argument are always prepared according146  // to the implicit interface. Cast the actual function if any of the147  // argument mismatch cannot be dealt with a simple fir.convert.148  if (converter.getLoweringOptions().getLowerToHighLevelFIR())149    for (auto [actualType, dummyType] :150         llvm::zip(callSiteType.getInputs(), funcOpType.getInputs()))151      if (actualType != dummyType &&152          !fir::ConvertOp::canBeConverted(actualType, dummyType))153        return true;154  return false;155}156 157static mlir::Value readDim3Value(fir::FirOpBuilder &builder, mlir::Location loc,158                                 mlir::Value dim3Addr, llvm::StringRef comp) {159  mlir::Type i32Ty = builder.getI32Type();160  mlir::Type refI32Ty = fir::ReferenceType::get(i32Ty);161  llvm::SmallVector<mlir::Value> lenParams;162 163  mlir::Value designate = hlfir::DesignateOp::create(164      builder, loc, refI32Ty, dim3Addr, /*component=*/comp,165      /*componentShape=*/mlir::Value{}, hlfir::DesignateOp::Subscripts{},166      /*substring=*/mlir::ValueRange{}, /*complexPartAttr=*/std::nullopt,167      mlir::Value{}, lenParams);168 169  return hlfir::loadTrivialScalar(loc, builder, hlfir::Entity{designate});170}171 172static mlir::Value remapActualToDummyDescriptor(173    mlir::Location loc, Fortran::lower::AbstractConverter &converter,174    Fortran::lower::SymMap &symMap,175    const Fortran::lower::CallerInterface::PassedEntity &arg,176    Fortran::lower::CallerInterface &caller, bool isBindcCall) {177  fir::FirOpBuilder &builder = converter.getFirOpBuilder();178  mlir::IndexType idxTy = builder.getIndexType();179  mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0);180  Fortran::lower::StatementContext localStmtCtx;181  auto lowerSpecExpr = [&](const auto &expr,182                           bool isAssumedSizeExtent) -> mlir::Value {183    mlir::Value convertExpr = builder.createConvert(184        loc, idxTy, fir::getBase(converter.genExprValue(expr, localStmtCtx)));185    if (isAssumedSizeExtent)186      return convertExpr;187    return fir::factory::genMaxWithZero(builder, loc, convertExpr);188  };189  bool mapSymbols = caller.mustMapInterfaceSymbolsForDummyArgument(arg);190  if (mapSymbols) {191    symMap.pushScope();192    const Fortran::semantics::Symbol *sym = caller.getDummySymbol(arg);193    assert(sym && "call must have explicit interface to map interface symbols");194    Fortran::lower::mapCallInterfaceSymbolsForDummyArgument(converter, caller,195                                                            symMap, *sym);196  }197  llvm::SmallVector<mlir::Value> extents;198  llvm::SmallVector<mlir::Value> lengths;199  mlir::Type dummyBoxType = caller.getDummyArgumentType(arg);200  mlir::Type dummyBaseType = fir::unwrapPassByRefType(dummyBoxType);201  if (mlir::isa<fir::SequenceType>(dummyBaseType))202    caller.walkDummyArgumentExtents(203        arg, [&](const Fortran::lower::SomeExpr &e, bool isAssumedSizeExtent) {204          extents.emplace_back(lowerSpecExpr(e, isAssumedSizeExtent));205        });206  mlir::Value shape;207  if (!extents.empty()) {208    if (isBindcCall) {209      // Preserve zero lower bounds (see F'2023 18.5.3).210      llvm::SmallVector<mlir::Value> lowerBounds(extents.size(), zero);211      shape = builder.genShape(loc, lowerBounds, extents);212    } else {213      shape = builder.genShape(loc, extents);214    }215  }216 217  hlfir::Entity explicitArgument = hlfir::Entity{caller.getInput(arg)};218  mlir::Type dummyElementType = fir::unwrapSequenceType(dummyBaseType);219  if (auto recType = llvm::dyn_cast<fir::RecordType>(dummyElementType))220    if (recType.getNumLenParams() > 0)221      TODO(loc, "sequence association of length parameterized derived type "222                "dummy arguments");223  if (fir::isa_char(dummyElementType))224    lengths.emplace_back(hlfir::genCharLength(loc, builder, explicitArgument));225  mlir::Value baseAddr =226      hlfir::genVariableRawAddress(loc, builder, explicitArgument);227  baseAddr = builder.createConvert(loc, fir::ReferenceType::get(dummyBaseType),228                                   baseAddr);229  mlir::Value mold;230  if (fir::isPolymorphicType(dummyBoxType))231    mold = explicitArgument;232  mlir::Value remapped =233      fir::EmboxOp::create(builder, loc, dummyBoxType, baseAddr, shape,234                           /*slice=*/mlir::Value{}, lengths, mold);235  if (mapSymbols)236    symMap.popScope();237  return remapped;238}239 240/// Create a descriptor for sequenced associated descriptor that are passed241/// by descriptor. Sequence association (F'2023 15.5.2.12) implies that the242/// dummy shape and rank need to not be the same as the actual argument. This243/// helper creates a descriptor based on the dummy shape and rank (sequence244/// association can only happen with explicit and assumed-size array) so that it245/// is safe to assume the rank of the incoming descriptor inside the callee.246/// This helper must be called once all the actual arguments have been lowered247/// and placed inside "caller". Copy-in/copy-out must already have been248/// generated if needed using the actual argument shape (the dummy shape may be249/// assumed-size).250static void remapActualToDummyDescriptors(251    mlir::Location loc, Fortran::lower::AbstractConverter &converter,252    Fortran::lower::SymMap &symMap,253    const Fortran::lower::PreparedActualArguments &loweredActuals,254    Fortran::lower::CallerInterface &caller, bool isBindcCall) {255  fir::FirOpBuilder &builder = converter.getFirOpBuilder();256  for (auto [preparedActual, arg] :257       llvm::zip(loweredActuals, caller.getPassedArguments())) {258    if (arg.isSequenceAssociatedDescriptor()) {259      if (!preparedActual.value().handleDynamicOptional()) {260        mlir::Value remapped = remapActualToDummyDescriptor(261            loc, converter, symMap, arg, caller, isBindcCall);262        caller.placeInput(arg, remapped);263      } else {264        // Absent optional actual argument descriptor cannot be read and265        // remapped unconditionally.266        mlir::Type dummyType = caller.getDummyArgumentType(arg);267        mlir::Value isPresent = preparedActual.value().getIsPresent();268        auto &argLambdaCapture = arg;269        mlir::Value remapped =270            builder271                .genIfOp(loc, {dummyType}, isPresent,272                         /*withElseRegion=*/true)273                .genThen([&]() {274                  mlir::Value newBox = remapActualToDummyDescriptor(275                      loc, converter, symMap, argLambdaCapture, caller,276                      isBindcCall);277                  fir::ResultOp::create(builder, loc, newBox);278                })279                .genElse([&]() {280                  mlir::Value absent =281                      fir::AbsentOp::create(builder, loc, dummyType);282                  fir::ResultOp::create(builder, loc, absent);283                })284                .getResults()[0];285        caller.placeInput(arg, remapped);286      }287    }288  }289}290 291static void292getResultLengthFromElementalOp(fir::FirOpBuilder &builder,293                               llvm::SmallVectorImpl<mlir::Value> &lengths) {294  auto elemental = llvm::dyn_cast_or_null<hlfir::ElementalOp>(295      builder.getInsertionBlock()->getParentOp());296  if (elemental)297    for (mlir::Value len : elemental.getTypeparams())298      lengths.push_back(len);299}300 301std::pair<Fortran::lower::LoweredResult, bool>302Fortran::lower::genCallOpAndResult(303    mlir::Location loc, Fortran::lower::AbstractConverter &converter,304    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,305    Fortran::lower::CallerInterface &caller, mlir::FunctionType callSiteType,306    std::optional<mlir::Type> resultType, bool isElemental) {307  fir::FirOpBuilder &builder = converter.getFirOpBuilder();308  using PassBy = Fortran::lower::CallerInterface::PassEntityBy;309  bool mustPopSymMap = false;310 311  llvm::SmallVector<mlir::Value> resultLengths;312  if (isElemental)313    getResultLengthFromElementalOp(builder, resultLengths);314  if (caller.mustMapInterfaceSymbolsForResult() && resultLengths.empty()) {315    // Do not map the dummy symbols again inside the loop to compute elemental316    // function result whose length was already computed outside of the loop.317    symMap.pushScope();318    mustPopSymMap = true;319    Fortran::lower::mapCallInterfaceSymbolsForResult(converter, caller, symMap);320  }321  // If this is an indirect call, retrieve the function address. Also retrieve322  // the result length if this is a character function (note that this length323  // will be used only if there is no explicit length in the local interface).324  mlir::Value funcPointer;325  mlir::Value charFuncPointerLength;326  if (const Fortran::evaluate::ProcedureDesignator *procDesignator =327          caller.getIfIndirectCall()) {328    if (mlir::Value passedArg = caller.getIfPassedArg()) {329      // Procedure pointer component call with PASS argument. To avoid330      // "double" lowering of the ComponentRef, semantics only place the331      // ComponentRef in the ActualArguments, not in the ProcedureDesignator (332      // that is only the component symbol).333      // Fetch the passed argument and addresses of its procedure pointer334      // component.335      funcPointer = Fortran::lower::derefPassProcPointerComponent(336          loc, converter, *procDesignator, passedArg, symMap, stmtCtx);337    } else {338      Fortran::lower::SomeExpr expr{*procDesignator};339      fir::ExtendedValue loweredProc =340          converter.genExprAddr(loc, expr, stmtCtx);341      funcPointer = fir::getBase(loweredProc);342      // Dummy procedure may have assumed length, in which case the result343      // length was passed along the dummy procedure.344      // This is not possible with procedure pointer components.345      if (const fir::CharBoxValue *charBox = loweredProc.getCharBox())346        charFuncPointerLength = charBox->getLen();347    }348  }349  const bool isExprCall =350      converter.getLoweringOptions().getLowerToHighLevelFIR() &&351      callSiteType.getNumResults() == 1 &&352      llvm::isa<fir::SequenceType>(callSiteType.getResult(0));353 354  mlir::IndexType idxTy = builder.getIndexType();355  auto lowerSpecExpr = [&](const auto &expr) -> mlir::Value {356    mlir::Value convertExpr = builder.createConvert(357        loc, idxTy, fir::getBase(converter.genExprValue(expr, stmtCtx)));358    return fir::factory::genMaxWithZero(builder, loc, convertExpr);359  };360  mlir::Value arrayResultShape;361  hlfir::EvaluateInMemoryOp evaluateInMemory;362  auto allocatedResult = [&]() -> std::optional<fir::ExtendedValue> {363    llvm::SmallVector<mlir::Value> extents;364    llvm::SmallVector<mlir::Value> lengths;365    if (!caller.callerAllocateResult())366      return {};367    mlir::Type type = caller.getResultStorageType();368    if (mlir::isa<fir::SequenceType>(type))369      caller.walkResultExtents(370          [&](const Fortran::lower::SomeExpr &e, bool isAssumedSizeExtent) {371            assert(!isAssumedSizeExtent && "result cannot be assumed-size");372            extents.emplace_back(lowerSpecExpr(e));373          });374    if (resultLengths.empty()) {375      caller.walkResultLengths(376          [&](const Fortran::lower::SomeExpr &e, bool isAssumedSizeExtent) {377            assert(!isAssumedSizeExtent && "result cannot be assumed-size");378            lengths.emplace_back(lowerSpecExpr(e));379          });380    } else {381      // Use lengths precomputed before elemental loops.382      lengths = resultLengths;383    }384 385    // Result length parameters should not be provided to box storage386    // allocation and save_results, but they are still useful information to387    // keep in the ExtendedValue if non-deferred.388    if (!mlir::isa<fir::BoxType>(type)) {389      if (fir::isa_char(fir::unwrapSequenceType(type)) && lengths.empty()) {390        // Calling an assumed length function. This is only possible if this391        // is a call to a character dummy procedure.392        if (!charFuncPointerLength)393          fir::emitFatalError(loc, "failed to retrieve character function "394                                   "length while calling it");395        lengths.push_back(charFuncPointerLength);396      }397      resultLengths = lengths;398    }399 400    if (!extents.empty())401      arrayResultShape = builder.genShape(loc, extents);402 403    if (isExprCall) {404      mlir::Type exprType = hlfir::getExprType(type);405      evaluateInMemory = hlfir::EvaluateInMemoryOp::create(406          builder, loc, exprType, arrayResultShape, resultLengths);407      builder.setInsertionPointToStart(&evaluateInMemory.getBody().front());408      return toExtendedValue(loc, evaluateInMemory.getMemory(), extents,409                             lengths);410    }411 412    if ((!extents.empty() || !lengths.empty()) && !isElemental) {413      // Note: in the elemental context, the alloca ownership inside the414      // elemental region is implicit, and later pass in lowering (stack415      // reclaim) fir.do_loop will be in charge of emitting any stack416      // save/restore if needed.417      auto *bldr = &converter.getFirOpBuilder();418      mlir::Value sp = bldr->genStackSave(loc);419      stmtCtx.attachCleanup(420          [bldr, loc, sp]() { bldr->genStackRestore(loc, sp); });421    }422    mlir::Value temp =423        builder.createTemporary(loc, type, ".result", extents, resultLengths);424    return toExtendedValue(loc, temp, extents, lengths);425  }();426 427  if (mustPopSymMap)428    symMap.popScope();429 430  // Place allocated result431  if (allocatedResult) {432    if (std::optional<Fortran::lower::CallInterface<433            Fortran::lower::CallerInterface>::PassedEntity>434            resultArg = caller.getPassedResult()) {435      if (resultArg->passBy == PassBy::AddressAndLength)436        caller.placeAddressAndLengthInput(*resultArg,437                                          fir::getBase(*allocatedResult),438                                          fir::getLen(*allocatedResult));439      else if (resultArg->passBy == PassBy::BaseAddress)440        caller.placeInput(*resultArg, fir::getBase(*allocatedResult));441      else442        fir::emitFatalError(443            loc, "only expect character scalar result to be passed by ref");444    }445  }446 447  // In older Fortran, procedure argument types are inferred. This may lead448  // different view of what the function signature is in different locations.449  // Casts are inserted as needed below to accommodate this.450 451  // The mlir::func::FuncOp type prevails, unless it has a different number of452  // arguments which can happen in legal program if it was passed as a dummy453  // procedure argument earlier with no further type information.454  mlir::SymbolRefAttr funcSymbolAttr;455  bool addHostAssociations = false;456  if (!funcPointer) {457    mlir::FunctionType funcOpType = caller.getFuncOp().getFunctionType();458    mlir::SymbolRefAttr symbolAttr =459        builder.getSymbolRefAttr(caller.getMangledName());460    if (callSiteType.getNumResults() == funcOpType.getNumResults() &&461        callSiteType.getNumInputs() + 1 == funcOpType.getNumInputs() &&462        fir::anyFuncArgsHaveAttr(caller.getFuncOp(),463                                 fir::getHostAssocAttrName())) {464      // The number of arguments is off by one, and we're lowering a function465      // with host associations. Modify call to include host associations466      // argument by appending the value at the end of the operands.467      assert(funcOpType.getInput(findHostAssocTuplePos(caller.getFuncOp())) ==468             converter.hostAssocTupleValue().getType());469      addHostAssociations = true;470    }471    // When this is not a call to an internal procedure (where there is a472    // mismatch due to the extra argument, but the interface is otherwise473    // explicit and safe), handle interface mismatch due to F77 implicit474    // interface "abuse" with a function address cast if needed.475    if (!addHostAssociations &&476        mustCastFuncOpToCopeWithImplicitInterfaceMismatch(477            loc, converter, callSiteType, funcOpType))478      funcPointer = fir::AddrOfOp::create(builder, loc, funcOpType, symbolAttr);479    else480      funcSymbolAttr = symbolAttr;481 482    // Issue a warning if the procedure name conflicts with483    // a runtime function name a call to which has been already484    // lowered (implying that the FuncOp has been created).485    // The behavior is undefined in this case.486    if (caller.getFuncOp()->hasAttrOfType<mlir::UnitAttr>(487            fir::FIROpsDialect::getFirRuntimeAttrName()))488      LLVM_DEBUG(mlir::emitWarning(489          loc,490          llvm::Twine("function name '") +491              llvm::Twine(symbolAttr.getLeafReference()) +492              llvm::Twine("' conflicts with a runtime function name used by "493                          "Flang - this may lead to undefined behavior")));494  }495 496  mlir::FunctionType funcType =497      funcPointer ? callSiteType : caller.getFuncOp().getFunctionType();498  llvm::SmallVector<mlir::Value> operands;499  // First operand of indirect call is the function pointer. Cast it to500  // required function type for the call to handle procedures that have a501  // compatible interface in Fortran, but that have different signatures in502  // FIR.503  if (funcPointer) {504    operands.push_back(505        mlir::isa<fir::BoxProcType>(funcPointer.getType())506            ? fir::BoxAddrOp::create(builder, loc, funcType, funcPointer)507            : builder.createConvert(loc, funcType, funcPointer));508  }509 510  // Deal with potential mismatches in arguments types. Passing an array to a511  // scalar argument should for instance be tolerated here.512  for (auto [fst, snd] : llvm::zip(caller.getInputs(), funcType.getInputs())) {513    // When passing arguments to a procedure that can be called by implicit514    // interface, allow any character actual arguments to be passed to dummy515    // arguments of any type and vice versa.516    mlir::Value cast;517    auto *context = builder.getContext();518 519    if (mlir::isa<fir::BoxProcType>(snd) &&520        mlir::isa<mlir::FunctionType>(fst.getType())) {521      mlir::FunctionType funcTy = mlir::FunctionType::get(context, {}, {});522      fir::BoxProcType boxProcTy = builder.getBoxProcType(funcTy);523      if (mlir::Value host = argumentHostAssocs(converter, fst)) {524        cast = fir::EmboxProcOp::create(builder, loc, boxProcTy,525                                        llvm::ArrayRef<mlir::Value>{fst, host});526      } else {527        cast = fir::EmboxProcOp::create(builder, loc, boxProcTy, fst);528      }529    } else {530      mlir::Type fromTy = fir::unwrapRefType(fst.getType());531      if (fir::isa_builtin_cptr_type(fromTy) &&532          Fortran::lower::isCPtrArgByValueType(snd)) {533        cast = genRecordCPtrValueArg(builder, loc, fst, fromTy);534      } else if (fir::isa_derived(snd) && !fir::isa_derived(fst.getType())) {535        // TODO: remove this TODO once the old lowering is gone.536        TODO(loc, "derived type argument passed by value");537      } else {538        // With the lowering to HLFIR, box arguments have already been built539        // according to the attributes, rank, bounds, and type they should have.540        // Do not attempt any reboxing here that could break this.541        bool legacyLowering =542            !converter.getLoweringOptions().getLowerToHighLevelFIR();543        // When dealing with a dummy character argument (fir.boxchar), the544        // effective argument might be a non-character raw pointer. This may545        // happen when calling an implicit interface that was previously called546        // with a character argument, or when calling an explicit interface with547        // an IgnoreTKR dummy character arguments. Allow creating a fir.boxchar548        // from the raw pointer, which requires a non-trivial type conversion.549        const bool allowCharacterConversions = true;550        bool isVolatile = fir::isa_volatile_type(snd);551        cast = builder.createVolatileCast(loc, isVolatile, fst);552        cast = builder.convertWithSemantics(loc, snd, cast,553                                            allowCharacterConversions,554                                            /*allowRebox=*/legacyLowering);555      }556    }557    operands.push_back(cast);558  }559 560  // Add host associations as necessary.561  if (addHostAssociations)562    operands.push_back(converter.hostAssocTupleValue());563 564  mlir::Value callResult;565  unsigned callNumResults;566  fir::FortranProcedureFlagsEnumAttr procAttrs =567      caller.getProcedureAttrs(builder.getContext());568 569  if (converter.getLoweringOptions().getCUDARuntimeCheck()) {570    if (caller.getCallDescription().chevrons().empty() &&571        !cuf::isCUDADeviceContext(builder.getRegion())) {572      for (auto [oper, arg] :573           llvm::zip(operands, caller.getPassedArguments())) {574        if (arg.testTKR(Fortran::common::IgnoreTKR::Contiguous))575          continue;576        if (auto boxTy = mlir::dyn_cast<fir::BaseBoxType>(oper.getType())) {577          const Fortran::semantics::Symbol *sym = caller.getDummySymbol(arg);578          if (sym && Fortran::evaluate::IsCUDADeviceSymbol(*sym))579            fir::runtime::cuda::genDescriptorCheckSection(builder, loc, oper);580        }581      }582    }583  }584 585  if (!caller.getCallDescription().chevrons().empty()) {586    // A call to a CUDA kernel with the chevron syntax.587 588    mlir::Type i32Ty = builder.getI32Type();589    mlir::Value one = builder.createIntegerConstant(loc, i32Ty, 1);590 591    mlir::Value grid_x, grid_y, grid_z;592    if (caller.getCallDescription().chevrons()[0].GetType()->category() ==593        Fortran::common::TypeCategory::Integer) {594      // If grid is an integer, it is converted to dim3(grid,1,1). Since z is595      // not used for the number of thread blocks, it is omitted in the op.596      grid_x = builder.createConvert(597          loc, i32Ty,598          fir::getBase(converter.genExprValue(599              caller.getCallDescription().chevrons()[0], stmtCtx)));600      grid_y = one;601      grid_z = one;602    } else {603      auto dim3Addr = converter.genExprAddr(604          caller.getCallDescription().chevrons()[0], stmtCtx);605      grid_x = readDim3Value(builder, loc, fir::getBase(dim3Addr), "x");606      grid_y = readDim3Value(builder, loc, fir::getBase(dim3Addr), "y");607      grid_z = readDim3Value(builder, loc, fir::getBase(dim3Addr), "z");608    }609 610    mlir::Value block_x, block_y, block_z;611    if (caller.getCallDescription().chevrons()[1].GetType()->category() ==612        Fortran::common::TypeCategory::Integer) {613      // If block is an integer, it is converted to dim3(block,1,1).614      block_x = builder.createConvert(615          loc, i32Ty,616          fir::getBase(converter.genExprValue(617              caller.getCallDescription().chevrons()[1], stmtCtx)));618      block_y = one;619      block_z = one;620    } else {621      auto dim3Addr = converter.genExprAddr(622          caller.getCallDescription().chevrons()[1], stmtCtx);623      block_x = readDim3Value(builder, loc, fir::getBase(dim3Addr), "x");624      block_y = readDim3Value(builder, loc, fir::getBase(dim3Addr), "y");625      block_z = readDim3Value(builder, loc, fir::getBase(dim3Addr), "z");626    }627 628    mlir::Value bytes; // bytes is optional.629    if (caller.getCallDescription().chevrons().size() > 2)630      bytes = builder.createConvert(631          loc, i32Ty,632          fir::getBase(converter.genExprValue(633              caller.getCallDescription().chevrons()[2], stmtCtx)));634 635    mlir::Value stream; // stream is optional.636    if (caller.getCallDescription().chevrons().size() > 3) {637      stream = fir::getBase(converter.genExprAddr(638          caller.getCallDescription().chevrons()[3], stmtCtx));639      if (!fir::unwrapRefType(stream.getType()).isInteger(64)) {640        auto i64Ty = mlir::IntegerType::get(builder.getContext(), 64);641        mlir::Value newStream = builder.createTemporary(loc, i64Ty);642        mlir::Value load = fir::LoadOp::create(builder, loc, stream);643        mlir::Value conv = fir::ConvertOp::create(builder, loc, i64Ty, load);644        fir::StoreOp::create(builder, loc, conv, newStream);645        stream = newStream;646      }647    }648 649    cuf::KernelLaunchOp::create(builder, loc, funcType.getResults(),650                                funcSymbolAttr, grid_x, grid_y, grid_z, block_x,651                                block_y, block_z, bytes, stream, operands,652                                /*arg_attrs=*/nullptr, /*res_attrs=*/nullptr);653    callNumResults = 0;654  } else if (caller.requireDispatchCall()) {655    // Procedure call requiring a dynamic dispatch. Call is created with656    // fir.dispatch.657 658    // Get the raw procedure name. The procedure name is not mangled in the659    // binding table, but there can be a suffix to distinguish bindings of660    // the same name (which happens only when PRIVATE bindings exist in661    // ancestor types in other modules).662    const auto &ultimateSymbol =663        caller.getCallDescription().proc().GetSymbol()->GetUltimate();664    std::string procName = ultimateSymbol.name().ToString();665    if (const auto &binding{666            ultimateSymbol.get<Fortran::semantics::ProcBindingDetails>()};667        binding.numPrivatesNotOverridden() > 0)668      procName += "."s + std::to_string(binding.numPrivatesNotOverridden());669    fir::DispatchOp dispatch;670    if (std::optional<unsigned> passArg = caller.getPassArgIndex()) {671      // PASS, PASS(arg-name)672      // Note that caller.getInputs is used instead of operands to get the673      // passed object because interface mismatch issues may have inserted a674      // cast to the operand with a different declared type, which would break675      // later type bound call resolution in the FIR to FIR pass.676      dispatch = fir::DispatchOp::create(677          builder, loc, funcType.getResults(), builder.getStringAttr(procName),678          caller.getInputs()[*passArg], operands,679          builder.getI32IntegerAttr(*passArg), /*arg_attrs=*/nullptr,680          /*res_attrs=*/nullptr, procAttrs);681    } else {682      // NOPASS683      const Fortran::evaluate::Component *component =684          caller.getCallDescription().proc().GetComponent();685      assert(component && "expect component for type-bound procedure call.");686 687      fir::ExtendedValue dataRefValue = Fortran::lower::convertDataRefToValue(688          loc, converter, component->base(), symMap, stmtCtx);689      mlir::Value passObject = fir::getBase(dataRefValue);690 691      if (fir::isa_ref_type(passObject.getType()))692        passObject = fir::LoadOp::create(builder, loc, passObject);693      dispatch = fir::DispatchOp::create(694          builder, loc, funcType.getResults(), builder.getStringAttr(procName),695          passObject, operands, nullptr, /*arg_attrs=*/nullptr,696          /*res_attrs=*/nullptr, procAttrs);697    }698    callNumResults = dispatch.getNumResults();699    if (callNumResults != 0)700      callResult = dispatch.getResult(0);701  } else {702    // Standard procedure call with fir.call.703    fir::FortranInlineEnumAttr inlineAttr;704 705    if (caller.getCallDescription().hasNoInline())706      inlineAttr = fir::FortranInlineEnumAttr::get(707          builder.getContext(), fir::FortranInlineEnum::no_inline);708    else if (caller.getCallDescription().hasInlineHint())709      inlineAttr = fir::FortranInlineEnumAttr::get(710          builder.getContext(), fir::FortranInlineEnum::inline_hint);711    else if (caller.getCallDescription().hasAlwaysInline())712      inlineAttr = fir::FortranInlineEnumAttr::get(713          builder.getContext(), fir::FortranInlineEnum::always_inline);714    auto call = fir::CallOp::create(715        builder, loc, funcType.getResults(), funcSymbolAttr, operands,716        /*arg_attrs=*/nullptr, /*res_attrs=*/nullptr, procAttrs, inlineAttr,717        /*accessGroups=*/mlir::ArrayAttr{});718 719    callNumResults = call.getNumResults();720    if (callNumResults != 0)721      callResult = call.getResult(0);722  }723 724  std::optional<Fortran::evaluate::DynamicType> retTy =725      caller.getCallDescription().proc().GetType();726  // With HLFIR lowering, isElemental must be set to true727  // if we are producing an elemental call. In this case,728  // the elemental results must not be destroyed, instead,729  // the resulting array result will be finalized/destroyed730  // as needed by hlfir.destroy.731  const bool mustFinalizeResult =732      !isElemental && callSiteType.getNumResults() > 0 &&733      !fir::isPointerType(callSiteType.getResult(0)) && retTy.has_value() &&734      (retTy->category() == Fortran::common::TypeCategory::Derived ||735       retTy->IsPolymorphic() || retTy->IsUnlimitedPolymorphic());736 737  if (caller.mustSaveResult()) {738    assert(allocatedResult.has_value());739    fir::SaveResultOp::create(builder, loc, callResult,740                              fir::getBase(*allocatedResult), arrayResultShape,741                              resultLengths);742  }743 744  if (evaluateInMemory) {745    builder.setInsertionPointAfter(evaluateInMemory);746    mlir::Value expr = evaluateInMemory.getResult();747    fir::FirOpBuilder *bldr = &converter.getFirOpBuilder();748    if (!isElemental)749      stmtCtx.attachCleanup([bldr, loc, expr, mustFinalizeResult]() {750        hlfir::DestroyOp::create(*bldr, loc, expr,751                                 /*finalize=*/mustFinalizeResult);752      });753    return {LoweredResult{hlfir::EntityWithAttributes{expr}},754            mustFinalizeResult};755  }756 757  if (allocatedResult) {758    // The result must be optionally destroyed (if it is of a derived type759    // that may need finalization or deallocation of the components).760    // For an allocatable result we have to free the memory allocated761    // for the top-level entity. Note that the Destroy calls below762    // do not deallocate the top-level entity. The two clean-ups763    // must be pushed in reverse order, so that the final order is:764    //   Destroy(desc)765    //   free(desc->base_addr)766    allocatedResult->match(767        [&](const fir::MutableBoxValue &box) {768          if (box.isAllocatable()) {769            // 9.7.3.2 point 4. Deallocate allocatable results. Note that770            // finalization was done independently by calling771            // genDerivedTypeDestroy above and is not triggered by this inline772            // deallocation.773            fir::FirOpBuilder *bldr = &converter.getFirOpBuilder();774            stmtCtx.attachCleanup([bldr, loc, box]() {775              fir::factory::genFreememIfAllocated(*bldr, loc, box);776            });777          }778        },779        [](const auto &) {});780 781    // 7.5.6.3 point 5. Derived-type finalization for nonpointer function.782    bool resultIsFinalized = false;783    // Check if the derived-type is finalizable if it is a monomorphic784    // derived-type.785    // For polymorphic and unlimited polymorphic enities call the runtime786    // in any cases.787    if (mustFinalizeResult) {788      if (retTy->IsPolymorphic() || retTy->IsUnlimitedPolymorphic()) {789        auto *bldr = &converter.getFirOpBuilder();790        stmtCtx.attachCleanup([bldr, loc, allocatedResult]() {791          fir::runtime::genDerivedTypeDestroy(*bldr, loc,792                                              fir::getBase(*allocatedResult));793        });794        resultIsFinalized = true;795      } else {796        const Fortran::semantics::DerivedTypeSpec &typeSpec =797            retTy->GetDerivedTypeSpec();798        // If the result type may require finalization799        // or have allocatable components, we need to make sure800        // everything is properly finalized/deallocated.801        if (Fortran::semantics::MayRequireFinalization(typeSpec) ||802            // We can use DerivedTypeDestroy even if finalization is not needed.803            hlfir::mayHaveAllocatableComponent(funcType.getResults()[0])) {804          auto *bldr = &converter.getFirOpBuilder();805          stmtCtx.attachCleanup([bldr, loc, allocatedResult]() {806            mlir::Value box = bldr->createBox(loc, *allocatedResult);807            fir::runtime::genDerivedTypeDestroy(*bldr, loc, box);808          });809          resultIsFinalized = true;810        }811      }812    }813    return {LoweredResult{*allocatedResult}, resultIsFinalized};814  }815 816  // subroutine call817  if (!resultType)818    return {LoweredResult{fir::ExtendedValue{mlir::Value{}}},819            /*resultIsFinalized=*/false};820 821  // For now, Fortran return values are implemented with a single MLIR822  // function return value.823  assert(callNumResults == 1 && "Expected exactly one result in FUNCTION call");824  (void)callNumResults;825 826  // Call a BIND(C) function that return a char.827  if (caller.characterize().IsBindC() &&828      mlir::isa<fir::CharacterType>(funcType.getResults()[0])) {829    fir::CharacterType charTy =830        mlir::dyn_cast<fir::CharacterType>(funcType.getResults()[0]);831    mlir::Value len = builder.createIntegerConstant(832        loc, builder.getCharacterLengthType(), charTy.getLen());833    return {834        LoweredResult{fir::ExtendedValue{fir::CharBoxValue{callResult, len}}},835        /*resultIsFinalized=*/false};836  }837 838  return {LoweredResult{fir::ExtendedValue{callResult}},839          /*resultIsFinalized=*/false};840}841 842static hlfir::EntityWithAttributes genStmtFunctionRef(843    mlir::Location loc, Fortran::lower::AbstractConverter &converter,844    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,845    const Fortran::evaluate::ProcedureRef &procRef) {846  const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol();847  assert(symbol && "expected symbol in ProcedureRef of statement functions");848  const auto &details = symbol->get<Fortran::semantics::SubprogramDetails>();849  fir::FirOpBuilder &builder = converter.getFirOpBuilder();850 851  // Statement functions have their own scope, we just need to associate852  // the dummy symbols to argument expressions. There are no853  // optional/alternate return arguments. Statement functions cannot be854  // recursive (directly or indirectly) so it is safe to add dummy symbols to855  // the local map here.856  symMap.pushScope();857  llvm::SmallVector<hlfir::AssociateOp> exprAssociations;858  for (auto [arg, bind] : llvm::zip(details.dummyArgs(), procRef.arguments())) {859    assert(arg && "alternate return in statement function");860    assert(bind && "optional argument in statement function");861    const auto *expr = bind->UnwrapExpr();862    // TODO: assumed type in statement function, that surprisingly seems863    // allowed, probably because nobody thought of restricting this usage.864    // gfortran/ifort compiles this.865    assert(expr && "assumed type used as statement function argument");866    // As per Fortran 2018 C1580, statement function arguments can only be867    // scalars.868    // The only care is to use the dummy character explicit length if any869    // instead of the actual argument length (that can be bigger).870    hlfir::EntityWithAttributes loweredArg = Fortran::lower::convertExprToHLFIR(871        loc, converter, *expr, symMap, stmtCtx);872    fir::FortranVariableOpInterface variableIface = loweredArg.getIfVariable();873    if (!variableIface) {874      // So far only FortranVariableOpInterface can be mapped to symbols.875      // Create an hlfir.associate to create a variable from a potential876      // value argument.877      mlir::Type argType = converter.genType(*arg);878      auto associate = hlfir::genAssociateExpr(879          loc, builder, loweredArg, argType, toStringRef(arg->name()));880      exprAssociations.push_back(associate);881      variableIface = associate;882    }883    const Fortran::semantics::DeclTypeSpec *type = arg->GetType();884    if (type &&885        type->category() == Fortran::semantics::DeclTypeSpec::Character) {886      // Instantiate character as if it was a normal dummy argument so that the887      // statement function dummy character length is applied and dealt with888      // correctly.889      symMap.addSymbol(*arg, variableIface.getBase());890      Fortran::lower::mapSymbolAttributes(converter, *arg, symMap, stmtCtx);891    } else {892      // No need to create an extra hlfir.declare otherwise for893      // numerical and logical scalar dummies.894      symMap.addVariableDefinition(*arg, variableIface);895    }896  }897 898  // Explicitly map statement function host associated symbols to their899  // parent scope lowered symbol box.900  for (const Fortran::semantics::SymbolRef &sym :901       Fortran::evaluate::CollectSymbols(*details.stmtFunction()))902    if (const auto *details =903            sym->detailsIf<Fortran::semantics::HostAssocDetails>())904      converter.copySymbolBinding(details->symbol(), sym);905 906  hlfir::Entity result = Fortran::lower::convertExprToHLFIR(907      loc, converter, details.stmtFunction().value(), symMap, stmtCtx);908  symMap.popScope();909  // The result must not be a variable.910  result = hlfir::loadTrivialScalar(loc, builder, result);911  if (result.isVariable())912    result = hlfir::Entity{hlfir::AsExprOp::create(builder, loc, result)};913  for (auto associate : exprAssociations)914    hlfir::EndAssociateOp::create(builder, loc, associate);915  return hlfir::EntityWithAttributes{result};916}917 918namespace {919// Structure to hold the information about the call and the lowering context.920// This structure is intended to help threading the information921// through the various lowering calls without having to pass every922// required structure one by one.923struct CallContext {924  CallContext(const Fortran::evaluate::ProcedureRef &procRef,925              std::optional<mlir::Type> resultType, mlir::Location loc,926              Fortran::lower::AbstractConverter &converter,927              Fortran::lower::SymMap &symMap,928              Fortran::lower::StatementContext &stmtCtx, bool doCopyIn = true)929      : procRef{procRef}, converter{converter}, symMap{symMap},930        stmtCtx{stmtCtx}, resultType{resultType}, loc{loc}, doCopyIn{doCopyIn} {931  }932 933  fir::FirOpBuilder &getBuilder() { return converter.getFirOpBuilder(); }934 935  std::string getProcedureName() const {936    if (const Fortran::semantics::Symbol *sym = procRef.proc().GetSymbol())937      return sym->GetUltimate().name().ToString();938    return procRef.proc().GetName();939  }940 941  /// Is this a call to an elemental procedure with at least one array argument?942  bool isElementalProcWithArrayArgs() const {943    if (procRef.IsElemental())944      for (const std::optional<Fortran::evaluate::ActualArgument> &arg :945           procRef.arguments())946        if (arg && arg->Rank() != 0)947          return true;948    return false;949  }950 951  /// Is this a statement function reference?952  bool isStatementFunctionCall() const {953    if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())954      if (const auto *details =955              symbol->detailsIf<Fortran::semantics::SubprogramDetails>())956        return details->stmtFunction().has_value();957    return false;958  }959 960  /// Is this a call to a BIND(C) procedure?961  bool isBindcCall() const {962    if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())963      return Fortran::semantics::IsBindCProcedure(*symbol);964    return false;965  }966 967  const Fortran::evaluate::ProcedureRef &procRef;968  Fortran::lower::AbstractConverter &converter;969  Fortran::lower::SymMap &symMap;970  Fortran::lower::StatementContext &stmtCtx;971  std::optional<mlir::Type> resultType;972  mlir::Location loc;973  bool doCopyIn;974};975 976using ExvAndCleanup =977    std::pair<fir::ExtendedValue, std::optional<hlfir::CleanupFunction>>;978} // namespace979 980// Helper to transform a fir::ExtendedValue to an hlfir::EntityWithAttributes.981static hlfir::EntityWithAttributes982extendedValueToHlfirEntity(mlir::Location loc, fir::FirOpBuilder &builder,983                           const fir::ExtendedValue &exv,984                           llvm::StringRef name) {985  mlir::Value firBase = fir::getBase(exv);986  mlir::Type firBaseTy = firBase.getType();987  if (fir::isa_trivial(firBaseTy))988    return hlfir::EntityWithAttributes{firBase};989  if (auto charTy = mlir::dyn_cast<fir::CharacterType>(firBase.getType())) {990    // CHAR() intrinsic and BIND(C) procedures returning CHARACTER(1)991    // are lowered to a fir.char<kind,1> that is not in memory.992    // This tends to cause a lot of bugs because the rest of the993    // infrastructure is mostly tested with characters that are994    // in memory.995    // To avoid having to deal with this special case here and there,996    // place it in memory here. If this turns out to be suboptimal,997    // this could be fixed, but for now llvm opt -O1 is able to get998    // rid of the memory indirection in a = char(b), so there is999    // little incentive to increase the compiler complexity.1000    hlfir::Entity storage{builder.createTemporary(loc, charTy)};1001    fir::StoreOp::create(builder, loc, firBase, storage);1002    auto asExpr = hlfir::AsExprOp::create(1003        builder, loc, storage, /*mustFree=*/builder.createBool(loc, false));1004    return hlfir::EntityWithAttributes{asExpr.getResult()};1005  }1006  return hlfir::genDeclare(loc, builder, exv, name,1007                           fir::FortranVariableFlagsAttr{});1008}1009namespace {1010/// Structure to hold the clean-up related to a dummy argument preparation1011/// that may have to be done after a call (copy-out or temporary deallocation).1012struct CallCleanUp {1013  struct CopyIn {1014    void genCleanUp(mlir::Location loc, fir::FirOpBuilder &builder) {1015      hlfir::CopyOutOp::create(builder, loc, tempBox, wasCopied, copyBackVar);1016    }1017    // address of the descriptor holding the temp if a temp was created.1018    mlir::Value tempBox;1019    // Boolean indicating if a copy was made or not.1020    mlir::Value wasCopied;1021    // copyBackVar may be null if copy back is not needed.1022    mlir::Value copyBackVar;1023  };1024  struct ExprAssociate {1025    void genCleanUp(mlir::Location loc, fir::FirOpBuilder &builder) {1026      hlfir::EndAssociateOp::create(builder, loc, tempVar, mustFree);1027    }1028    mlir::Value tempVar;1029    mlir::Value mustFree;1030  };1031 1032  /// Generate clean-up code.1033  /// If \p postponeAssociates is true, the ExprAssociate clean-up1034  /// is not generated, and instead the corresponding CallCleanUp1035  /// object is returned as the result.1036  std::optional<CallCleanUp> genCleanUp(mlir::Location loc,1037                                        fir::FirOpBuilder &builder,1038                                        bool postponeAssociates) {1039    std::optional<CallCleanUp> postponed;1040    Fortran::common::visit(Fortran::common::visitors{1041                               [&](CopyIn &c) { c.genCleanUp(loc, builder); },1042                               [&](ExprAssociate &c) {1043                                 if (postponeAssociates)1044                                   postponed = CallCleanUp{c};1045                                 else1046                                   c.genCleanUp(loc, builder);1047                               },1048                           },1049                           cleanUp);1050    return postponed;1051  }1052  std::variant<CopyIn, ExprAssociate> cleanUp;1053};1054 1055/// Structure representing a prepared dummy argument.1056/// It holds the value to be passed in the call and any related1057/// clean-ups to be done after the call.1058struct PreparedDummyArgument {1059  void pushCopyInCleanUp(mlir::Value tempBox, mlir::Value wasCopied,1060                         mlir::Value copyBackVar) {1061    cleanups.emplace_back(1062        CallCleanUp{CallCleanUp::CopyIn{tempBox, wasCopied, copyBackVar}});1063  }1064  void pushExprAssociateCleanUp(mlir::Value tempVar, mlir::Value wasCopied) {1065    cleanups.emplace_back(1066        CallCleanUp{CallCleanUp::ExprAssociate{tempVar, wasCopied}});1067  }1068  void pushExprAssociateCleanUp(hlfir::AssociateOp associate) {1069    mlir::Value hlfirBase = associate.getBase();1070    mlir::Value firBase = associate.getFirBase();1071    cleanups.emplace_back(CallCleanUp{CallCleanUp::ExprAssociate{1072        hlfir::mayHaveAllocatableComponent(hlfirBase.getType()) ? hlfirBase1073                                                                : firBase,1074        associate.getMustFreeStrorageFlag()}});1075  }1076 1077  mlir::Value dummy;1078  // NOTE: the clean-ups are executed in reverse order.1079  llvm::SmallVector<CallCleanUp, 2> cleanups;1080};1081 1082/// Structure to help conditionally preparing a dummy argument based1083/// on the actual argument presence.1084/// It helps "wrapping" the dummy and the clean-up information in1085/// an if (present) {...}:1086///1087///  %conditionallyPrepared = fir.if (%present) {1088///    fir.result %preparedDummy1089///  } else {1090///    fir.result %absent1091///  }1092///1093struct ConditionallyPreparedDummy {1094  /// Create ConditionallyPreparedDummy from a preparedDummy that must1095  /// be wrapped in a fir.if.1096  ConditionallyPreparedDummy(PreparedDummyArgument &preparedDummy) {1097    thenResultValues.push_back(preparedDummy.dummy);1098    for (const CallCleanUp &c : preparedDummy.cleanups) {1099      if (const auto *copyInCleanUp =1100              std::get_if<CallCleanUp::CopyIn>(&c.cleanUp)) {1101        thenResultValues.push_back(copyInCleanUp->wasCopied);1102        if (copyInCleanUp->copyBackVar)1103          thenResultValues.push_back(copyInCleanUp->copyBackVar);1104      } else {1105        const auto &exprAssociate =1106            std::get<CallCleanUp::ExprAssociate>(c.cleanUp);1107        thenResultValues.push_back(exprAssociate.tempVar);1108        thenResultValues.push_back(exprAssociate.mustFree);1109      }1110    }1111  }1112 1113  /// Get the result types of the wrapping fir.if that must be created.1114  llvm::SmallVector<mlir::Type> getIfResulTypes() const {1115    llvm::SmallVector<mlir::Type> types;1116    for (mlir::Value res : thenResultValues)1117      types.push_back(res.getType());1118    return types;1119  }1120 1121  /// Generate the "fir.result %preparedDummy" in the then branch of the1122  /// wrapping fir.if.1123  void genThenResult(mlir::Location loc, fir::FirOpBuilder &builder) const {1124    fir::ResultOp::create(builder, loc, thenResultValues);1125  }1126 1127  /// Generate the "fir.result %absent" in the else branch of the1128  /// wrapping fir.if.1129  void genElseResult(mlir::Location loc, fir::FirOpBuilder &builder) const {1130    llvm::SmallVector<mlir::Value> elseResultValues;1131    mlir::Type i1Type = builder.getI1Type();1132    for (mlir::Value res : thenResultValues) {1133      mlir::Type type = res.getType();1134      if (type == i1Type)1135        elseResultValues.push_back(builder.createBool(loc, false));1136      else1137        elseResultValues.push_back(builder.genAbsentOp(loc, type));1138    }1139    fir::ResultOp::create(builder, loc, elseResultValues);1140  }1141 1142  /// Once the fir.if has been created, get the resulting %conditionallyPrepared1143  /// dummy argument.1144  PreparedDummyArgument1145  getPreparedDummy(fir::IfOp ifOp,1146                   const PreparedDummyArgument &unconditionalDummy) {1147    PreparedDummyArgument preparedDummy;1148    preparedDummy.dummy = ifOp.getResults()[0];1149    for (const CallCleanUp &c : unconditionalDummy.cleanups) {1150      if (const auto *copyInCleanUp =1151              std::get_if<CallCleanUp::CopyIn>(&c.cleanUp)) {1152        mlir::Value copyBackVar;1153        if (copyInCleanUp->copyBackVar)1154          copyBackVar = ifOp.getResults().back();1155        // tempBox is an hlfir.copy_in argument created outside of the1156        // fir.if region. It needs not to be threaded as a fir.if result.1157        preparedDummy.pushCopyInCleanUp(copyInCleanUp->tempBox,1158                                        ifOp.getResults()[1], copyBackVar);1159      } else {1160        preparedDummy.pushExprAssociateCleanUp(ifOp.getResults()[1],1161                                               ifOp.getResults()[2]);1162      }1163    }1164    return preparedDummy;1165  }1166 1167  llvm::SmallVector<mlir::Value> thenResultValues;1168};1169} // namespace1170 1171/// Fix-up the fact that it is supported to pass a character procedure1172/// designator to a non character procedure dummy procedure and vice-versa, even1173/// in case of explicit interface. Uglier cases where an object is passed as1174/// procedure designator or vice versa are handled only for implicit interfaces1175/// (refused by semantics with explicit interface), and handled with a funcOp1176/// cast like other implicit interface mismatches.1177static hlfir::Entity fixProcedureDummyMismatch(mlir::Location loc,1178                                               fir::FirOpBuilder &builder,1179                                               hlfir::Entity actual,1180                                               mlir::Type dummyType) {1181  if (mlir::isa<fir::BoxProcType>(actual.getType()) &&1182      fir::isCharacterProcedureTuple(dummyType)) {1183    mlir::Value length =1184        fir::UndefOp::create(builder, loc, builder.getCharacterLengthType());1185    mlir::Value tuple = fir::factory::createCharacterProcedureTuple(1186        builder, loc, dummyType, actual, length);1187    return hlfir::Entity{tuple};1188  }1189  assert(fir::isCharacterProcedureTuple(actual.getType()) &&1190         mlir::isa<fir::BoxProcType>(dummyType) &&1191         "unsupported dummy procedure mismatch with the actual argument");1192  mlir::Value boxProc = fir::factory::extractCharacterProcedureTuple(1193                            builder, loc, actual, /*openBoxProc=*/false)1194                            .first;1195  return hlfir::Entity{boxProc};1196}1197 1198mlir::Value static getZeroLowerBounds(mlir::Location loc,1199                                      fir::FirOpBuilder &builder,1200                                      hlfir::Entity entity) {1201  assert(!entity.isAssumedRank() &&1202         "assumed-rank must use fir.rebox_assumed_rank");1203  if (entity.getRank() < 1)1204    return {};1205  mlir::Value zero =1206      builder.createIntegerConstant(loc, builder.getIndexType(), 0);1207  llvm::SmallVector<mlir::Value> lowerBounds(entity.getRank(), zero);1208  return builder.genShift(loc, lowerBounds);1209}1210 1211static bool isParameterObjectOrSubObject(hlfir::Entity entity) {1212  mlir::Value base = entity;1213  bool foundParameter = false;1214  while (mlir::Operation *op = base ? base.getDefiningOp() : nullptr) {1215    base =1216        llvm::TypeSwitch<mlir::Operation *, mlir::Value>(op)1217            .Case<hlfir::DeclareOp>([&](auto declare) -> mlir::Value {1218              foundParameter |= hlfir::Entity{declare}.isParameter();1219              return foundParameter ? mlir::Value{} : declare.getMemref();1220            })1221            .Case<hlfir::DesignateOp, hlfir::ParentComponentOp, fir::EmboxOp>(1222                [&](auto op) -> mlir::Value { return op.getMemref(); })1223            .Case<fir::ReboxOp>(1224                [&](auto rebox) -> mlir::Value { return rebox.getBox(); })1225            .Case<fir::ConvertOp>(1226                [&](auto convert) -> mlir::Value { return convert.getValue(); })1227            .Default([](mlir::Operation *) -> mlir::Value { return nullptr; });1228  }1229  return foundParameter;1230}1231 1232/// When dummy is not ALLOCATABLE, POINTER and is not passed in register,1233/// prepare the actual argument according to the interface. Do as needed:1234/// - address element if this is an array argument in an elemental call.1235/// - set dynamic type to the dummy type if the dummy is not polymorphic.1236/// - copy-in into contiguous variable if the dummy must be contiguous1237/// - copy into a temporary if the dummy has the VALUE attribute.1238/// - package the prepared dummy as required (fir.box, fir.class,1239///   fir.box_char...).1240/// This function should only be called with an actual that is present.1241/// The optional aspects must be handled by this function user.1242///1243/// Note: while Fortran::lower::CallerInterface::PassedEntity (the type of arg)1244/// is technically a template type, in the prepare*ActualArgument() calls1245/// it resolves to Fortran::evaluate::ActualArgument *1246static PreparedDummyArgument preparePresentUserCallActualArgument(1247    mlir::Location loc, fir::FirOpBuilder &builder,1248    const Fortran::lower::PreparedActualArgument &preparedActual,1249    mlir::Type dummyType,1250    const Fortran::lower::CallerInterface::PassedEntity &arg,1251    CallContext &callContext) {1252 1253  // Step 1: get the actual argument, which includes addressing the1254  // element if this is an array in an elemental call.1255  hlfir::Entity actual = preparedActual.getActual(loc, builder);1256 1257  // Handle procedure arguments (procedure pointers should go through1258  // prepareProcedurePointerActualArgument).1259  if (hlfir::isFortranProcedureValue(dummyType)) {1260    // Procedure pointer or function returns procedure pointer actual to1261    // procedure dummy.1262    if (actual.isProcedurePointer()) {1263      actual = hlfir::derefPointersAndAllocatables(loc, builder, actual);1264      return PreparedDummyArgument{actual, /*cleanups=*/{}};1265    }1266    // Procedure actual to procedure dummy.1267    assert(actual.isProcedure());1268    // Do nothing if this is a procedure argument. It is already a1269    // fir.boxproc/fir.tuple<fir.boxproc, len> as it should.1270    if (!mlir::isa<fir::BoxProcType>(actual.getType()) &&1271        actual.getType() != dummyType)1272      // The actual argument may be a procedure that returns character (a1273      // fir.tuple<fir.boxproc, len>) while the dummy is not. Extract the tuple1274      // in that case.1275      actual = fixProcedureDummyMismatch(loc, builder, actual, dummyType);1276    return PreparedDummyArgument{actual, /*cleanups=*/{}};1277  }1278 1279  const bool ignoreTKRtype = arg.testTKR(Fortran::common::IgnoreTKR::Type);1280  const bool passingPolymorphicToNonPolymorphic =1281      actual.isPolymorphic() && !fir::isPolymorphicType(dummyType) &&1282      !ignoreTKRtype;1283 1284  // When passing a CLASS(T) to TYPE(T), only the "T" part must be1285  // passed. Unless the entity is a scalar passed by raw address, a1286  // new descriptor must be made using the dummy argument type as1287  // dynamic type. This must be done before any copy/copy-in because the1288  // dynamic type matters to determine the contiguity.1289  const bool mustSetDynamicTypeToDummyType =1290      passingPolymorphicToNonPolymorphic &&1291      (actual.isArray() || mlir::isa<fir::BaseBoxType>(dummyType));1292 1293  bool mustDoCopyIn{false};1294  bool mustDoCopyOut{false};1295 1296  if (callContext.doCopyIn) {1297    Fortran::evaluate::FoldingContext &foldingContext{1298        callContext.converter.getFoldingContext()};1299 1300    bool suggestCopyIn = Fortran::evaluate::ActualArgNeedsCopy(1301                             arg.entity, arg.characteristics, foldingContext,1302                             /*forCopyOut=*/false)1303                             .value_or(true);1304    bool suggestCopyOut = Fortran::evaluate::ActualArgNeedsCopy(1305                              arg.entity, arg.characteristics, foldingContext,1306                              /*forCopyOut=*/true)1307                              .value_or(true);1308    mustDoCopyIn = actual.isArray() && suggestCopyIn;1309    mustDoCopyOut = actual.isArray() && suggestCopyOut;1310  }1311 1312  const bool actualIsAssumedRank = actual.isAssumedRank();1313  // Create dummy type with actual argument rank when the dummy is an assumed1314  // rank. That way, all the operation to create dummy descriptors are ranked if1315  // the actual argument is ranked, which allows simple code generation.1316  // Also do the same when the dummy is a sequence associated descriptor1317  // because the actual shape/rank may mismatch with the dummy, and the dummy1318  // may be an assumed-size array, so any descriptor manipulation should use the1319  // actual argument shape information. A descriptor with the dummy shape1320  // information will be created later when all actual arguments are ready.1321  mlir::Type dummyTypeWithActualRank = dummyType;1322  if (auto baseBoxDummy = mlir::dyn_cast<fir::BaseBoxType>(dummyType)) {1323    if (baseBoxDummy.isAssumedRank() ||1324        arg.testTKR(Fortran::common::IgnoreTKR::Rank) ||1325        arg.isSequenceAssociatedDescriptor()) {1326      mlir::Type actualTy =1327          hlfir::getFortranElementOrSequenceType(actual.getType());1328      dummyTypeWithActualRank = baseBoxDummy.getBoxTypeWithNewShape(actualTy);1329    }1330  }1331  // Preserve the actual type in the argument preparation in case IgnoreTKR(t)1332  // is set (descriptors must be created with the actual type in this case, and1333  // copy-in/copy-out should be driven by the contiguity with regard to the1334  // actual type).1335  if (ignoreTKRtype) {1336    if (auto boxCharType =1337            mlir::dyn_cast<fir::BoxCharType>(dummyTypeWithActualRank)) {1338      auto maybeActualCharType =1339          mlir::dyn_cast<fir::CharacterType>(actual.getFortranElementType());1340      if (!maybeActualCharType ||1341          maybeActualCharType.getFKind() != boxCharType.getKind()) {1342        // When passing to a fir.boxchar with ignore(tk), prepare the argument1343        // as if only the raw address must be passed.1344        dummyTypeWithActualRank =1345            fir::ReferenceType::get(actual.getElementOrSequenceType());1346      }1347      // Otherwise, the actual is already a character with the same kind as the1348      // dummy and can be passed normally.1349    } else {1350      dummyTypeWithActualRank = fir::changeElementType(1351          dummyTypeWithActualRank, actual.getFortranElementType(),1352          actual.isPolymorphic());1353    }1354  }1355 1356  PreparedDummyArgument preparedDummy;1357 1358  // Helpers to generate hlfir.copy_in operation and register the related1359  // hlfir.copy_out creation.1360  auto genCopyIn = [&](hlfir::Entity var, bool doCopyOut) -> hlfir::Entity {1361    auto baseBoxTy = mlir::dyn_cast<fir::BaseBoxType>(var.getType());1362    assert(baseBoxTy && "expect non simply contiguous variables to be boxes");1363    // Create allocatable descriptor for the potential temporary.1364    mlir::Type tempBoxType = baseBoxTy.getBoxTypeWithNewAttr(1365        fir::BaseBoxType::Attribute::Allocatable);1366    mlir::Value tempBox = builder.createTemporary(loc, tempBoxType);1367    auto copyIn = hlfir::CopyInOp::create(builder, loc, var, tempBox,1368                                          /*var_is_present=*/mlir::Value{});1369    // Register the copy-out after the call.1370    preparedDummy.pushCopyInCleanUp(copyIn.getTempBox(), copyIn.getWasCopied(),1371                                    doCopyOut ? copyIn.getVar()1372                                              : mlir::Value{});1373    return hlfir::Entity{copyIn.getCopiedIn()};1374  };1375 1376  auto genSetDynamicTypeToDummyType = [&](hlfir::Entity var) -> hlfir::Entity {1377    fir::BaseBoxType boxType = fir::BoxType::get(1378        hlfir::getFortranElementOrSequenceType(dummyTypeWithActualRank));1379    if (actualIsAssumedRank)1380      return hlfir::Entity{fir::ReboxAssumedRankOp::create(1381          builder, loc, boxType, var,1382          fir::LowerBoundModifierAttribute::SetToOnes)};1383    // Use actual shape when creating descriptor with dummy type, the dummy1384    // shape may be unknown in case of sequence association.1385    mlir::Type actualTy =1386        hlfir::getFortranElementOrSequenceType(actual.getType());1387    boxType = boxType.getBoxTypeWithNewShape(actualTy);1388    return hlfir::Entity{fir::ReboxOp::create(builder, loc, boxType, var,1389                                              /*shape=*/mlir::Value{},1390                                              /*slice=*/mlir::Value{})};1391  };1392 1393  // Step 2: prepare the storage for the dummy arguments, ensuring that it1394  // matches the dummy requirements (e.g., must be contiguous or must be1395  // a temporary).1396  hlfir::Entity entity =1397      hlfir::derefPointersAndAllocatables(loc, builder, actual);1398  if (entity.isVariable()) {1399    // Set dynamic type if needed before any copy-in or copy so that the dummy1400    // is contiguous according to the dummy type.1401    if (mustSetDynamicTypeToDummyType)1402      entity = genSetDynamicTypeToDummyType(entity);1403    if (arg.hasValueAttribute() ||1404        // Constant expressions might be lowered as variables with1405        // 'parameter' attribute. Even though the constant expressions1406        // are not definable and explicit assignments to them are not1407        // possible, we have to create a temporary copies when we pass1408        // them down the call stack because of potential compiler1409        // generated writes in copy-out.1410        isParameterObjectOrSubObject(entity)) {1411      // Make a copy in a temporary.1412      auto copy = hlfir::AsExprOp::create(builder, loc, entity);1413      mlir::Type storageType = entity.getType();1414      mlir::NamedAttribute byRefAttr = fir::getAdaptToByRefAttr(builder);1415      hlfir::AssociateOp associate = hlfir::genAssociateExpr(1416          loc, builder, hlfir::Entity{copy}, storageType, "", byRefAttr);1417      entity = hlfir::Entity{associate.getBase()};1418      // Register the temporary destruction after the call.1419      preparedDummy.pushExprAssociateCleanUp(associate);1420    } else if (mustDoCopyIn || mustDoCopyOut) {1421      // Copy-in non contiguous variables.1422      //1423      // TODO: copy-in and copy-out are now determined separately, in order1424      // to allow more fine grained copying. While currently both copy-in1425      // and copy-out are must be done together, these copy operations could1426      // be separated in the future. (This is related to TODO comment below.)1427      //1428      // TODO: for non-finalizable monomorphic derived type actual1429      // arguments associated with INTENT(OUT) dummy arguments1430      // we may avoid doing the copy and only allocate the temporary.1431      // The codegen would do a "mold" allocation instead of "sourced"1432      // allocation for the temp in this case. We can communicate1433      // this to the codegen via some CopyInOp flag.1434      // This is a performance concern.1435      entity = genCopyIn(entity, mustDoCopyOut);1436    }1437  } else {1438    const Fortran::lower::SomeExpr *expr = arg.entity->UnwrapExpr();1439    assert(expr && "expression actual argument cannot be an assumed type");1440    // The actual is an expression value, place it into a temporary1441    // and register the temporary destruction after the call.1442    mlir::Type storageType = callContext.converter.genType(*expr);1443    mlir::NamedAttribute byRefAttr = fir::getAdaptToByRefAttr(builder);1444    hlfir::AssociateOp associate = hlfir::genAssociateExpr(1445        loc, builder, entity, storageType, "", byRefAttr);1446    entity = hlfir::Entity{associate.getBase()};1447    preparedDummy.pushExprAssociateCleanUp(associate);1448    // Rebox the actual argument to the dummy argument's type, and make sure1449    // that we pass a contiguous entity (i.e. make copy-in, if needed).1450    //1451    // TODO: this can probably be optimized by associating the expression with1452    // properly typed temporary, but this needs either a new operation or1453    // making the hlfir.associate more complex.1454    if (mustSetDynamicTypeToDummyType) {1455      entity = genSetDynamicTypeToDummyType(entity);1456      entity = genCopyIn(entity, /*doCopyOut=*/false);1457    }1458  }1459 1460  // Step 3: now that the dummy argument storage has been prepared, package1461  // it according to the interface.1462  mlir::Value addr;1463  if (mlir::isa<fir::BoxCharType>(dummyTypeWithActualRank)) {1464    // Cast the argument to match the volatility of the dummy argument.1465    auto nonVolatileEntity = hlfir::Entity{builder.createVolatileCast(1466        loc, fir::isa_volatile_type(dummyType), entity)};1467    addr = hlfir::genVariableBoxChar(loc, builder, nonVolatileEntity);1468  } else if (mlir::isa<fir::BaseBoxType>(dummyTypeWithActualRank)) {1469    entity = hlfir::genVariableBox(loc, builder, entity);1470    // Ensures the box has the right attributes and that it holds an1471    // addendum if needed.1472    fir::BaseBoxType actualBoxType =1473        mlir::cast<fir::BaseBoxType>(entity.getType());1474    mlir::Type boxEleType = actualBoxType.getEleTy();1475    // For now, assume it is not OK to pass the allocatable/pointer1476    // descriptor to a non pointer/allocatable dummy. That is a strict1477    // interpretation of 18.3.6 point 4 that stipulates the descriptor1478    // has the dummy attributes in BIND(C) contexts.1479    const bool actualBoxHasAllocatableOrPointerFlag =1480        fir::isa_ref_type(boxEleType);1481    // Fortran 2018 18.5.3, pp3: BIND(C) non pointer allocatable descriptors1482    // must have zero lower bounds.1483    bool needsZeroLowerBounds = callContext.isBindcCall() && entity.isArray();1484    // On the callee side, the current code generated for unlimited1485    // polymorphic might unconditionally read the addendum. Intrinsic type1486    // descriptors may not have an addendum, the rebox below will create a1487    // descriptor with an addendum in such case.1488    const bool actualBoxHasAddendum = fir::boxHasAddendum(actualBoxType);1489    const bool needToAddAddendum =1490        fir::isUnlimitedPolymorphicType(dummyTypeWithActualRank) &&1491        !actualBoxHasAddendum;1492    if (needToAddAddendum || actualBoxHasAllocatableOrPointerFlag ||1493        needsZeroLowerBounds) {1494      if (actualIsAssumedRank) {1495        auto lbModifier = needsZeroLowerBounds1496                              ? fir::LowerBoundModifierAttribute::SetToZeroes1497                              : fir::LowerBoundModifierAttribute::SetToOnes;1498        entity = hlfir::Entity{fir::ReboxAssumedRankOp::create(1499            builder, loc, dummyTypeWithActualRank, entity, lbModifier)};1500      } else {1501        mlir::Value shift{};1502        if (needsZeroLowerBounds)1503          shift = getZeroLowerBounds(loc, builder, entity);1504        entity = hlfir::Entity{fir::ReboxOp::create(1505            builder, loc, dummyTypeWithActualRank, entity, /*shape=*/shift,1506            /*slice=*/mlir::Value{})};1507      }1508    }1509    addr = entity;1510  } else {1511    addr = hlfir::genVariableRawAddress(loc, builder, entity);1512  }1513 1514  // If the volatility of the input type does not match the dummy type,1515  // we need to cast the argument.1516  const bool isToTypeVolatile = fir::isa_volatile_type(dummyTypeWithActualRank);1517  addr = builder.createVolatileCast(loc, isToTypeVolatile, addr);1518 1519  // For ranked actual passed to assumed-rank dummy, the cast to assumed-rank1520  // box is inserted when building the fir.call op. Inserting it here would1521  // cause the fir.if results to be assumed-rank in case of OPTIONAL dummy,1522  // causing extra runtime costs due to the unknown runtime size of assumed-rank1523  // descriptors.1524  // For TKR dummy characters, the boxchar creation also happens later when1525  // creating the fir.call .1526  preparedDummy.dummy =1527      builder.createConvert(loc, dummyTypeWithActualRank, addr);1528  return preparedDummy;1529}1530 1531/// When dummy is not ALLOCATABLE, POINTER and is not passed in register,1532/// prepare the actual argument according to the interface, taking care1533/// of any optional aspect.1534static PreparedDummyArgument prepareUserCallActualArgument(1535    mlir::Location loc, fir::FirOpBuilder &builder,1536    const Fortran::lower::PreparedActualArgument &preparedActual,1537    mlir::Type dummyType,1538    const Fortran::lower::CallerInterface::PassedEntity &arg,1539    CallContext &callContext) {1540  if (!preparedActual.handleDynamicOptional())1541    return preparePresentUserCallActualArgument(loc, builder, preparedActual,1542                                                dummyType, arg, callContext);1543 1544  // Conditional dummy argument preparation. The actual may be absent1545  // at runtime, causing any addressing, copy, and packaging to have1546  // undefined behavior.1547  // To simplify the handling of this case, the "normal" dummy preparation1548  // helper is used, except its generated code is wrapped inside a1549  // fir.if(present).1550  mlir::Value isPresent = preparedActual.getIsPresent();1551  mlir::OpBuilder::InsertPoint insertPt = builder.saveInsertionPoint();1552 1553  // Code generated in a preparation block that will become the1554  // "then" block in "if (present) then {} else {}". The reason1555  // for this unusual if/then/else generation is that the number1556  // and types of the if results will depend on how the argument1557  // is prepared, and forecasting that here would be brittle.1558  auto badIfOp = fir::IfOp::create(builder, loc, dummyType, isPresent,1559                                   /*withElseRegion=*/false);1560  mlir::Block *preparationBlock = &badIfOp.getThenRegion().front();1561  builder.setInsertionPointToStart(preparationBlock);1562  PreparedDummyArgument unconditionalDummy =1563      preparePresentUserCallActualArgument(loc, builder, preparedActual,1564                                           dummyType, arg, callContext);1565  builder.restoreInsertionPoint(insertPt);1566 1567  // TODO: when forwarding an optional to an optional of the same kind1568  // (i.e, unconditionalDummy.dummy was not created in preparationBlock),1569  // the if/then/else generation could be skipped to improve the generated1570  // code.1571 1572  // Now that the result types of the ifOp can be deduced, generate1573  // the "real" ifOp (operation result types cannot be changed, so1574  // badIfOp cannot be modified and used here).1575  llvm::SmallVector<mlir::Type> ifOpResultTypes;1576  ConditionallyPreparedDummy conditionalDummy(unconditionalDummy);1577  auto ifOp = fir::IfOp::create(builder, loc,1578                                conditionalDummy.getIfResulTypes(), isPresent,1579                                /*withElseRegion=*/true);1580  // Move "preparationBlock" into the "then" of the new1581  // fir.if operation and create fir.result propagating1582  // unconditionalDummy.1583  preparationBlock->moveBefore(&ifOp.getThenRegion().back());1584  ifOp.getThenRegion().back().erase();1585  builder.setInsertionPointToEnd(&ifOp.getThenRegion().front());1586  conditionalDummy.genThenResult(loc, builder);1587 1588  // Generate "else" branch with returning absent values.1589  builder.setInsertionPointToStart(&ifOp.getElseRegion().front());1590  conditionalDummy.genElseResult(loc, builder);1591 1592  // Build dummy from IfOpResults.1593  builder.setInsertionPointAfter(ifOp);1594  PreparedDummyArgument result =1595      conditionalDummy.getPreparedDummy(ifOp, unconditionalDummy);1596  badIfOp->erase();1597  return result;1598}1599 1600/// Prepare actual argument for a procedure pointer dummy.1601static PreparedDummyArgument prepareProcedurePointerActualArgument(1602    mlir::Location loc, fir::FirOpBuilder &builder,1603    const Fortran::lower::PreparedActualArgument &preparedActual,1604    mlir::Type dummyType,1605    const Fortran::lower::CallerInterface::PassedEntity &arg,1606    CallContext &callContext) {1607 1608  // NULL() actual to procedure pointer dummy1609  if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(1610          *arg.entity) &&1611      fir::isBoxProcAddressType(dummyType)) {1612    auto boxTy{Fortran::lower::getUntypedBoxProcType(builder.getContext())};1613    auto tempBoxProc{builder.createTemporary(loc, boxTy)};1614    hlfir::Entity nullBoxProc(1615        fir::factory::createNullBoxProc(builder, loc, boxTy));1616    fir::StoreOp::create(builder, loc, nullBoxProc, tempBoxProc);1617    return PreparedDummyArgument{tempBoxProc, /*cleanups=*/{}};1618  }1619  hlfir::Entity actual = preparedActual.getActual(loc, builder);1620  if (actual.isProcedurePointer())1621    return PreparedDummyArgument{actual, /*cleanups=*/{}};1622  assert(actual.isProcedure());1623  // Procedure actual to procedure pointer dummy.1624  auto tempBoxProc{builder.createTemporary(loc, actual.getType())};1625  fir::StoreOp::create(builder, loc, actual, tempBoxProc);1626  return PreparedDummyArgument{tempBoxProc, /*cleanups=*/{}};1627}1628 1629/// Prepare arguments of calls to user procedures with actual arguments that1630/// have been pre-lowered but not yet prepared according to the interface.1631void prepareUserCallArguments(1632    Fortran::lower::PreparedActualArguments &loweredActuals,1633    Fortran::lower::CallerInterface &caller, mlir::FunctionType callSiteType,1634    CallContext &callContext, llvm::SmallVector<CallCleanUp> &callCleanUps) {1635  using PassBy = Fortran::lower::CallerInterface::PassEntityBy;1636  mlir::Location loc = callContext.loc;1637  bool mustRemapActualToDummyDescriptors = false;1638  fir::FirOpBuilder &builder = callContext.getBuilder();1639  for (auto [preparedActual, arg] :1640       llvm::zip(loweredActuals, caller.getPassedArguments())) {1641    mlir::Type argTy = callSiteType.getInput(arg.firArgument);1642    if (!preparedActual) {1643      // Optional dummy argument for which there is no actual argument.1644      caller.placeInput(arg, builder.genAbsentOp(loc, argTy));1645      continue;1646    }1647 1648    switch (arg.passBy) {1649    case PassBy::Value: {1650      // True pass-by-value semantics.1651      assert(!preparedActual->handleDynamicOptional() && "cannot be optional");1652      hlfir::Entity actual = preparedActual->getActual(loc, builder);1653      hlfir::Entity value = hlfir::loadTrivialScalar(loc, builder, actual);1654 1655      mlir::Type eleTy = value.getFortranElementType();1656      if (fir::isa_builtin_cptr_type(eleTy)) {1657        // Pass-by-value argument of type(C_PTR/C_FUNPTR).1658        // Load the __address component and pass it by value.1659        if (value.isValue()) {1660          auto associate = hlfir::genAssociateExpr(loc, builder, value, eleTy,1661                                                   "adapt.cptrbyval");1662          value = hlfir::Entity{genRecordCPtrValueArg(1663              builder, loc, associate.getFirBase(), eleTy)};1664          hlfir::EndAssociateOp::create(builder, loc, associate);1665        } else {1666          value =1667              hlfir::Entity{genRecordCPtrValueArg(builder, loc, value, eleTy)};1668        }1669      } else if (fir::isa_derived(value.getFortranElementType()) ||1670                 value.isCharacter()) {1671        // BIND(C), VALUE derived type or character. The value must really1672        // be loaded here.1673        auto [exv, cleanup] = hlfir::convertToValue(loc, builder, value);1674        mlir::Value loadedValue = fir::getBase(exv);1675        // Character actual arguments may have unknown length or a length longer1676        // than one. Cast the memory ref to the dummy type so that the load is1677        // valid and only loads what is needed.1678        if (mlir::Type baseTy = fir::dyn_cast_ptrEleTy(loadedValue.getType()))1679          if (fir::isa_char(baseTy))1680            loadedValue = builder.createConvert(1681                loc, fir::ReferenceType::get(argTy), loadedValue);1682        if (fir::isa_ref_type(loadedValue.getType()))1683          loadedValue = fir::LoadOp::create(builder, loc, loadedValue);1684        caller.placeInput(arg, loadedValue);1685        if (cleanup)1686          (*cleanup)();1687        break;1688      }1689      // For %VAL arguments, we should pass the value directly without1690      // conversion to reference types.1691      caller.placeInput(arg, builder.createConvert(loc, argTy, value));1692 1693    } break;1694    case PassBy::BaseAddressValueAttribute:1695    case PassBy::CharBoxValueAttribute:1696    case PassBy::Box:1697    case PassBy::BaseAddress:1698    case PassBy::BoxChar: {1699      PreparedDummyArgument preparedDummy = prepareUserCallActualArgument(1700          loc, builder, *preparedActual, argTy, arg, callContext);1701      callCleanUps.append(preparedDummy.cleanups.rbegin(),1702                          preparedDummy.cleanups.rend());1703      caller.placeInput(arg, preparedDummy.dummy);1704      if (arg.passBy == PassBy::Box)1705        mustRemapActualToDummyDescriptors |=1706            arg.isSequenceAssociatedDescriptor();1707    } break;1708    case PassBy::BoxProcRef: {1709      PreparedDummyArgument preparedDummy =1710          prepareProcedurePointerActualArgument(loc, builder, *preparedActual,1711                                                argTy, arg, callContext);1712      callCleanUps.append(preparedDummy.cleanups.rbegin(),1713                          preparedDummy.cleanups.rend());1714      caller.placeInput(arg, preparedDummy.dummy);1715    } break;1716    case PassBy::AddressAndLength:1717      // PassBy::AddressAndLength is only used for character results. Results1718      // are not handled here.1719      fir::emitFatalError(1720          loc, "unexpected PassBy::AddressAndLength for actual arguments");1721      break;1722    case PassBy::CharProcTuple: {1723      hlfir::Entity actual = preparedActual->getActual(loc, builder);1724      if (actual.isProcedurePointer())1725        actual = hlfir::derefPointersAndAllocatables(loc, builder, actual);1726      if (!fir::isCharacterProcedureTuple(actual.getType()))1727        actual = fixProcedureDummyMismatch(loc, builder, actual, argTy);1728      caller.placeInput(arg, actual);1729    } break;1730    case PassBy::MutableBox: {1731      const Fortran::lower::SomeExpr *expr = arg.entity->UnwrapExpr();1732      // C709 and C710.1733      assert(expr && "cannot pass TYPE(*) to POINTER or ALLOCATABLE");1734      hlfir::Entity actual = preparedActual->getActual(loc, builder);1735      if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(1736              *expr)) {1737        // If expr is NULL(), the mutableBox created must be a deallocated1738        // pointer with the dummy argument characteristics (see table 16.51739        // in Fortran 2018 standard).1740        // No length parameters are set for the created box because any non1741        // deferred type parameters of the dummy will be evaluated on the1742        // callee side, and it is illegal to use NULL without a MOLD if any1743        // dummy length parameters are assumed.1744        mlir::Type boxTy = fir::dyn_cast_ptrEleTy(argTy);1745        assert(boxTy && mlir::isa<fir::BaseBoxType>(boxTy) &&1746               "must be a fir.box type");1747        mlir::Value boxStorage =1748            fir::factory::genNullBoxStorage(builder, loc, boxTy);1749        caller.placeInput(arg, boxStorage);1750        continue;1751      }1752      if (fir::isPointerType(argTy) &&1753          !Fortran::evaluate::IsObjectPointer(*expr)) {1754        // Passing a non POINTER actual argument to a POINTER dummy argument.1755        // Create a pointer of the dummy argument type and assign the actual1756        // argument to it.1757        auto dataTy = llvm::cast<fir::BaseBoxType>(fir::unwrapRefType(argTy));1758        fir::ExtendedValue actualExv = Fortran::lower::convertToAddress(1759            loc, callContext.converter, actual, callContext.stmtCtx,1760            hlfir::getFortranElementType(dataTy));1761        // If the dummy is an assumed-rank pointer, allocate a pointer1762        // descriptor with the actual argument rank (if it is not assumed-rank1763        // itself).1764        if (dataTy.isAssumedRank()) {1765          dataTy =1766              dataTy.getBoxTypeWithNewShape(fir::getBase(actualExv).getType());1767        }1768        mlir::Value irBox = builder.createTemporary(loc, dataTy);1769        fir::MutableBoxValue ptrBox(irBox,1770                                    /*nonDeferredParams=*/mlir::ValueRange{},1771                                    /*mutableProperties=*/{});1772        fir::factory::associateMutableBox(builder, loc, ptrBox, actualExv,1773                                          /*lbounds=*/{});1774        caller.placeInput(arg, irBox);1775        continue;1776      }1777      // Passing a POINTER to a POINTER, or an ALLOCATABLE to an ALLOCATABLE.1778      assert(actual.isMutableBox() && "actual must be a mutable box");1779      if (fir::isAllocatableType(argTy) && arg.isIntentOut() &&1780          callContext.isBindcCall()) {1781        // INTENT(OUT) allocatables are deallocated on the callee side,1782        // but BIND(C) procedures may be implemented in C, so deallocation is1783        // also done on the caller side (if the procedure is implemented in1784        // Fortran, the deallocation attempt in the callee will be a no-op).1785        auto [exv, cleanup] =1786            hlfir::translateToExtendedValue(loc, builder, actual);1787        const auto *mutableBox = exv.getBoxOf<fir::MutableBoxValue>();1788        assert(mutableBox && !cleanup && "expect allocatable");1789        Fortran::lower::genDeallocateIfAllocated(callContext.converter,1790                                                 *mutableBox, loc);1791      }1792      caller.placeInput(arg, actual);1793    } break;1794    }1795  }1796 1797  // Handle cases where caller must allocate the result or a fir.box for it.1798  if (mustRemapActualToDummyDescriptors)1799    remapActualToDummyDescriptors(loc, callContext.converter,1800                                  callContext.symMap, loweredActuals, caller,1801                                  callContext.isBindcCall());1802}1803 1804/// Lower calls to user procedures with actual arguments that have been1805/// pre-lowered but not yet prepared according to the interface.1806/// This can be called for elemental procedures, but only with scalar1807/// arguments: if there are array arguments, it must be provided with1808/// the array argument elements value and will return the corresponding1809/// scalar result value.1810static std::optional<hlfir::EntityWithAttributes>1811genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,1812            Fortran::lower::CallerInterface &caller,1813            mlir::FunctionType callSiteType, CallContext &callContext) {1814  mlir::Location loc = callContext.loc;1815  llvm::SmallVector<CallCleanUp> callCleanUps;1816  fir::FirOpBuilder &builder = callContext.getBuilder();1817 1818  prepareUserCallArguments(loweredActuals, caller, callSiteType, callContext,1819                           callCleanUps);1820 1821  // Prepare lowered arguments according to the interface1822  // and map the lowered values to the dummy1823  // arguments.1824  auto [loweredResult, resultIsFinalized] = Fortran::lower::genCallOpAndResult(1825      loc, callContext.converter, callContext.symMap, callContext.stmtCtx,1826      caller, callSiteType, callContext.resultType,1827      callContext.isElementalProcWithArrayArgs());1828 1829  // Clean-up associations and copy-in.1830  // The association clean-ups are postponed to the end of the statement1831  // lowering. The copy-in clean-ups may be delayed as well,1832  // but they are done immediately after the call currently.1833  llvm::SmallVector<CallCleanUp> associateCleanups;1834  for (auto cleanUp : callCleanUps) {1835    auto postponed =1836        cleanUp.genCleanUp(loc, builder, /*postponeAssociates=*/true);1837    if (postponed)1838      associateCleanups.push_back(*postponed);1839  }1840 1841  fir::FirOpBuilder *bldr = &builder;1842  callContext.stmtCtx.attachCleanup([=]() {1843    for (auto cleanUp : associateCleanups)1844      (void)cleanUp.genCleanUp(loc, *bldr, /*postponeAssociates=*/false);1845  });1846  if (auto *entity = std::get_if<hlfir::EntityWithAttributes>(&loweredResult))1847    return *entity;1848 1849  auto &result = std::get<fir::ExtendedValue>(loweredResult);1850 1851  // For procedure pointer function result, just return the call.1852  if (callContext.resultType &&1853      mlir::isa<fir::BoxProcType>(*callContext.resultType))1854    return hlfir::EntityWithAttributes(fir::getBase(result));1855 1856  if (!fir::getBase(result))1857    return std::nullopt; // subroutine call.1858 1859  if (fir::isPointerType(fir::getBase(result).getType()))1860    return extendedValueToHlfirEntity(loc, builder, result, tempResultName);1861 1862  if (!resultIsFinalized) {1863    hlfir::Entity resultEntity =1864        extendedValueToHlfirEntity(loc, builder, result, tempResultName);1865    resultEntity = loadTrivialScalar(loc, builder, resultEntity);1866    if (resultEntity.isVariable()) {1867      // If the result has no finalization, it can be moved into an expression.1868      // In such case, the expression should not be freed after its use since1869      // the result is stack allocated or deallocation (for allocatable results)1870      // was already inserted in genCallOpAndResult.1871      auto asExpr =1872          hlfir::AsExprOp::create(builder, loc, resultEntity,1873                                  /*mustFree=*/builder.createBool(loc, false));1874      return hlfir::EntityWithAttributes{asExpr.getResult()};1875    }1876    return hlfir::EntityWithAttributes{resultEntity};1877  }1878  // If the result has finalization, it cannot be moved because use of its1879  // value have been created in the statement context and may be emitted1880  // after the hlfir.expr destroy, so the result is kept as a variable in1881  // HLFIR. This may lead to copies when passing the result to an argument1882  // with VALUE, and this do not convey the fact that the result will not1883  // change, but is correct, and using hlfir.expr without the move would1884  // trigger a copy that may be avoided.1885 1886  // Load allocatable results before emitting the hlfir.declare and drop its1887  // lower bounds: this is not a variable From the Fortran point of view, so1888  // the lower bounds are ones when inquired on the caller side.1889  const auto *allocatable = result.getBoxOf<fir::MutableBoxValue>();1890  fir::ExtendedValue loadedResult =1891      allocatable1892          ? fir::factory::genMutableBoxRead(builder, loc, *allocatable,1893                                            /*mayBePolymorphic=*/true,1894                                            /*preserveLowerBounds=*/false)1895          : result;1896  return extendedValueToHlfirEntity(loc, builder, loadedResult, tempResultName);1897}1898 1899/// Create an optional dummy argument value from an entity that may be1900/// absent. \p actualGetter callback returns hlfir::Entity denoting1901/// the lowered actual argument. \p actualGetter can only return numerical1902/// or logical scalar entity.1903/// If the entity is considered absent according to 15.5.2.12 point 1., the1904/// returned value is zero (or false), otherwise it is the value of the entity.1905/// \p eleType specifies the entity's Fortran element type.1906template <typename T>1907static ExvAndCleanup genOptionalValue(fir::FirOpBuilder &builder,1908                                      mlir::Location loc, mlir::Type eleType,1909                                      T actualGetter, mlir::Value isPresent) {1910  return {builder1911              .genIfOp(loc, {eleType}, isPresent,1912                       /*withElseRegion=*/true)1913              .genThen([&]() {1914                hlfir::Entity entity = actualGetter(loc, builder);1915                assert(eleType == entity.getFortranElementType() &&1916                       "result type mismatch in genOptionalValue");1917                assert(entity.isScalar() && fir::isa_trivial(eleType) &&1918                       "must be a numerical or logical scalar");1919                mlir::Value val =1920                    hlfir::loadTrivialScalar(loc, builder, entity);1921                fir::ResultOp::create(builder, loc, val);1922              })1923              .genElse([&]() {1924                mlir::Value zero =1925                    fir::factory::createZeroValue(builder, loc, eleType);1926                fir::ResultOp::create(builder, loc, zero);1927              })1928              .getResults()[0],1929          std::nullopt};1930}1931 1932/// Create an optional dummy argument address from \p entity that may be1933/// absent. If \p entity is considered absent according to 15.5.2.12 point 1.,1934/// the returned value is a null pointer, otherwise it is the address of \p1935/// entity.1936static ExvAndCleanup genOptionalAddr(fir::FirOpBuilder &builder,1937                                     mlir::Location loc, hlfir::Entity entity,1938                                     mlir::Value isPresent) {1939  auto [exv, cleanup] = hlfir::translateToExtendedValue(loc, builder, entity);1940  // If it is an exv pointer/allocatable, then it cannot be absent1941  // because it is passed to a non-pointer/non-allocatable.1942  if (const auto *box = exv.getBoxOf<fir::MutableBoxValue>())1943    return {fir::factory::genMutableBoxRead(builder, loc, *box), cleanup};1944  // If this is not a POINTER or ALLOCATABLE, then it is already an OPTIONAL1945  // address and can be passed directly.1946  return {exv, cleanup};1947}1948 1949/// Create an optional dummy argument address from \p entity that may be1950/// absent. If \p entity is considered absent according to 15.5.2.12 point 1.,1951/// the returned value is an absent fir.box, otherwise it is a fir.box1952/// describing \p entity.1953static ExvAndCleanup genOptionalBox(fir::FirOpBuilder &builder,1954                                    mlir::Location loc, hlfir::Entity entity,1955                                    mlir::Value isPresent) {1956  auto [exv, cleanup] = hlfir::translateToExtendedValue(loc, builder, entity);1957 1958  // Non allocatable/pointer optional box -> simply forward1959  if (exv.getBoxOf<fir::BoxValue>())1960    return {exv, cleanup};1961 1962  fir::ExtendedValue newExv = exv;1963  // Optional allocatable/pointer -> Cannot be absent, but need to translate1964  // unallocated/diassociated into absent fir.box.1965  if (const auto *box = exv.getBoxOf<fir::MutableBoxValue>())1966    newExv = fir::factory::genMutableBoxRead(builder, loc, *box);1967 1968  // createBox will not do create any invalid memory dereferences if exv is1969  // absent. The created fir.box will not be usable, but the SelectOp below1970  // ensures it won't be.1971  mlir::Value box = builder.createBox(loc, newExv);1972  mlir::Type boxType = box.getType();1973  auto absent = fir::AbsentOp::create(builder, loc, boxType);1974  auto boxOrAbsent = mlir::arith::SelectOp::create(builder, loc, boxType,1975                                                   isPresent, box, absent);1976  return {fir::BoxValue(boxOrAbsent), cleanup};1977}1978 1979/// Lower calls to intrinsic procedures with custom optional handling where the1980/// actual arguments have been pre-lowered1981static std::optional<hlfir::EntityWithAttributes> genCustomIntrinsicRefCore(1982    Fortran::lower::PreparedActualArguments &loweredActuals,1983    const Fortran::evaluate::SpecificIntrinsic *intrinsic,1984    CallContext &callContext) {1985  auto &builder = callContext.getBuilder();1986  const auto &loc = callContext.loc;1987  assert(intrinsic &&1988         Fortran::lower::intrinsicRequiresCustomOptionalHandling(1989             callContext.procRef, *intrinsic, callContext.converter));1990 1991  // helper to get a particular prepared argument1992  auto getArgument = [&](std::size_t i, bool loadArg) -> fir::ExtendedValue {1993    if (!loweredActuals[i])1994      return fir::getAbsentIntrinsicArgument();1995    hlfir::Entity actual = loweredActuals[i]->getActual(loc, builder);1996    if (loadArg && fir::conformsWithPassByRef(actual.getType())) {1997      return hlfir::loadTrivialScalar(loc, builder, actual);1998    }1999    return Fortran::lower::translateToExtendedValue(loc, builder, actual,2000                                                    callContext.stmtCtx);2001  };2002  // helper to get the isPresent flag for a particular prepared argument2003  auto isPresent = [&](std::size_t i) -> std::optional<mlir::Value> {2004    if (!loweredActuals[i])2005      return {builder.createBool(loc, false)};2006    if (loweredActuals[i]->handleDynamicOptional())2007      return {loweredActuals[i]->getIsPresent()};2008    return std::nullopt;2009  };2010 2011  assert(callContext.resultType &&2012         "the elemental intrinsics with custom handling are all functions");2013  // if callContext.resultType is an array then this was originally an elemental2014  // call. What we are lowering here is inside the kernel of the hlfir.elemental2015  // so we should return the scalar type. If the return type is already a scalar2016  // then it should be unchanged here.2017  mlir::Type resTy = hlfir::getFortranElementType(*callContext.resultType);2018  fir::ExtendedValue result = Fortran::lower::lowerCustomIntrinsic(2019      builder, loc, callContext.getProcedureName(), resTy, isPresent,2020      getArgument, loweredActuals.size(), callContext.stmtCtx);2021 2022  return {hlfir::EntityWithAttributes{extendedValueToHlfirEntity(2023      loc, builder, result, ".tmp.custom_intrinsic_result")}};2024}2025 2026/// Lower calls to intrinsic procedures with actual arguments that have been2027/// pre-lowered but have not yet been prepared according to the interface.2028static std::optional<hlfir::EntityWithAttributes>2029genIntrinsicRefCore(Fortran::lower::PreparedActualArguments &loweredActuals,2030                    const Fortran::evaluate::SpecificIntrinsic *intrinsic,2031                    const fir::IntrinsicHandlerEntry &intrinsicEntry,2032                    CallContext &callContext) {2033  auto &converter = callContext.converter;2034  if (intrinsic && Fortran::lower::intrinsicRequiresCustomOptionalHandling(2035                       callContext.procRef, *intrinsic, converter))2036    return genCustomIntrinsicRefCore(loweredActuals, intrinsic, callContext);2037  llvm::SmallVector<fir::ExtendedValue> operands;2038  llvm::SmallVector<hlfir::CleanupFunction> cleanupFns;2039  auto addToCleanups = [&cleanupFns](std::optional<hlfir::CleanupFunction> fn) {2040    if (fn)2041      cleanupFns.emplace_back(std::move(*fn));2042  };2043  auto &stmtCtx = callContext.stmtCtx;2044  fir::FirOpBuilder &builder = callContext.getBuilder();2045  mlir::Location loc = callContext.loc;2046  const fir::IntrinsicArgumentLoweringRules *argLowering =2047      intrinsicEntry.getArgumentLoweringRules();2048  for (auto arg : llvm::enumerate(loweredActuals)) {2049    if (!arg.value()) {2050      operands.emplace_back(fir::getAbsentIntrinsicArgument());2051      continue;2052    }2053    if (!argLowering) {2054      // No argument lowering instruction, lower by value.2055      assert(!arg.value()->handleDynamicOptional() &&2056             "should use genOptionalValue");2057      hlfir::Entity actual = arg.value()->getActual(loc, builder);2058      operands.emplace_back(2059          Fortran::lower::convertToValue(loc, converter, actual, stmtCtx));2060      continue;2061    }2062    // Helper to get the type of the Fortran expression in case it is a2063    // computed value that must be placed in memory (logicals are computed as2064    // i1, but must be placed in memory as fir.logical).2065    auto getActualFortranElementType = [&]() -> mlir::Type {2066      if (const Fortran::lower::SomeExpr *expr =2067              callContext.procRef.UnwrapArgExpr(arg.index())) {2068 2069        mlir::Type type = converter.genType(*expr);2070        return hlfir::getFortranElementType(type);2071      }2072      // TYPE(*): is already in memory anyway. Can return none2073      // here.2074      return builder.getNoneType();2075    };2076    // Ad-hoc argument lowering handling.2077    fir::ArgLoweringRule argRules =2078        fir::lowerIntrinsicArgumentAs(*argLowering, arg.index());2079    if (arg.value()->handleDynamicOptional()) {2080      mlir::Value isPresent = arg.value()->getIsPresent();2081      switch (argRules.lowerAs) {2082      case fir::LowerIntrinsicArgAs::Value: {2083        // In case of elemental call, getActual() may produce2084        // a designator denoting the array element to be passed2085        // to the subprogram. If the actual array is dynamically2086        // optional the designator must be generated under2087        // isPresent check, because the box bounds reads will be2088        // generated in the codegen. These reads are illegal,2089        // if the dynamically optional argument is absent.2090        auto getActualCb = [&](mlir::Location loc,2091                               fir::FirOpBuilder &builder) -> hlfir::Entity {2092          return arg.value()->getActual(loc, builder);2093        };2094        auto [exv, cleanup] =2095            genOptionalValue(builder, loc, getActualFortranElementType(),2096                             getActualCb, isPresent);2097        addToCleanups(std::move(cleanup));2098        operands.emplace_back(exv);2099        continue;2100      }2101      case fir::LowerIntrinsicArgAs::Addr: {2102        hlfir::Entity actual = arg.value()->getActual(loc, builder);2103        auto [exv, cleanup] = genOptionalAddr(builder, loc, actual, isPresent);2104        addToCleanups(std::move(cleanup));2105        operands.emplace_back(exv);2106        continue;2107      }2108      case fir::LowerIntrinsicArgAs::Box: {2109        hlfir::Entity actual = arg.value()->getActual(loc, builder);2110        auto [exv, cleanup] = genOptionalBox(builder, loc, actual, isPresent);2111        addToCleanups(std::move(cleanup));2112        operands.emplace_back(exv);2113        continue;2114      }2115      case fir::LowerIntrinsicArgAs::Inquired: {2116        hlfir::Entity actual = arg.value()->getActual(loc, builder);2117        auto [exv, cleanup] =2118            hlfir::translateToExtendedValue(loc, builder, actual);2119        addToCleanups(std::move(cleanup));2120        operands.emplace_back(exv);2121        continue;2122      }2123      }2124      llvm_unreachable("bad switch");2125    }2126 2127    hlfir::Entity actual = arg.value()->getActual(loc, builder);2128    switch (argRules.lowerAs) {2129    case fir::LowerIntrinsicArgAs::Value:2130      operands.emplace_back(2131          Fortran::lower::convertToValue(loc, converter, actual, stmtCtx));2132      continue;2133    case fir::LowerIntrinsicArgAs::Addr:2134      operands.emplace_back(Fortran::lower::convertToAddress(2135          loc, converter, actual, stmtCtx, getActualFortranElementType()));2136      continue;2137    case fir::LowerIntrinsicArgAs::Box:2138      operands.emplace_back(Fortran::lower::convertToBox(2139          loc, converter, actual, stmtCtx, getActualFortranElementType()));2140      continue;2141    case fir::LowerIntrinsicArgAs::Inquired:2142      if (const Fortran::lower::SomeExpr *expr =2143              callContext.procRef.UnwrapArgExpr(arg.index())) {2144        if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(2145                *expr)) {2146          // NULL() pointer without a MOLD must be passed as a deallocated2147          // pointer (see table 16.5 in Fortran 2018 standard).2148          // !fir.box<!fir.ptr<none>> should always be valid in this context.2149          mlir::Type noneTy = mlir::NoneType::get(builder.getContext());2150          mlir::Type nullPtrTy = fir::PointerType::get(noneTy);2151          mlir::Type boxTy = fir::BoxType::get(nullPtrTy);2152          mlir::Value boxStorage =2153              fir::factory::genNullBoxStorage(builder, loc, boxTy);2154          hlfir::EntityWithAttributes nullBoxEntity =2155              extendedValueToHlfirEntity(loc, builder, boxStorage,2156                                         ".tmp.null_box");2157          operands.emplace_back(Fortran::lower::translateToExtendedValue(2158              loc, builder, nullBoxEntity, stmtCtx));2159          continue;2160        }2161      }2162      // Place hlfir.expr in memory, and unbox fir.boxchar. Other entities2163      // are translated to fir::ExtendedValue without transformation (notably,2164      // pointers/allocatable are not dereferenced).2165      // TODO: once lowering to FIR retires, UBOUND and LBOUND can be simplified2166      // since the fir.box lowered here are now guaranteed to contain the local2167      // lower bounds thanks to the hlfir.declare (the extra rebox can be2168      // removed).2169      operands.emplace_back(Fortran::lower::translateToExtendedValue(2170          loc, builder, actual, stmtCtx));2171      continue;2172    }2173    llvm_unreachable("bad switch");2174  }2175  // genIntrinsicCall needs the scalar type, even if this is a transformational2176  // procedure returning an array.2177  std::optional<mlir::Type> scalarResultType;2178  if (callContext.resultType)2179    scalarResultType = hlfir::getFortranElementType(*callContext.resultType);2180  const std::string intrinsicName = callContext.getProcedureName();2181  // Let the intrinsic library lower the intrinsic procedure call.2182  auto [resultExv, mustBeFreed] = genIntrinsicCall(2183      builder, loc, intrinsicEntry, scalarResultType, operands, &converter);2184  for (const hlfir::CleanupFunction &fn : cleanupFns)2185    fn();2186  if (!fir::getBase(resultExv))2187    return std::nullopt;2188  hlfir::EntityWithAttributes resultEntity = extendedValueToHlfirEntity(2189      loc, builder, resultExv, ".tmp.intrinsic_result");2190  // Move result into memory into an hlfir.expr since they are immutable from2191  // that point, and the result storage is some temp. "Null" is special: it2192  // returns a null pointer variable that should not be transformed into a value2193  // (what matters is the memory address).2194  if (resultEntity.isVariable() && intrinsicName != "null") {2195    assert(!fir::isa_trivial(fir::unwrapRefType(resultEntity.getType())) &&2196           "expect intrinsic scalar results to not be in memory");2197    hlfir::AsExprOp asExpr;2198    // Character/Derived MERGE lowering returns one of its argument address2199    // (this is the only intrinsic implemented in that way so far). The2200    // ownership of this address cannot be taken here since it may not be a2201    // temp.2202    if (intrinsicName == "merge")2203      asExpr = hlfir::AsExprOp::create(builder, loc, resultEntity);2204    else2205      asExpr = hlfir::AsExprOp::create(builder, loc, resultEntity,2206                                       builder.createBool(loc, mustBeFreed));2207    resultEntity = hlfir::EntityWithAttributes{asExpr.getResult()};2208  }2209  return resultEntity;2210}2211 2212/// Lower calls to intrinsic procedures with actual arguments that have been2213/// pre-lowered but have not yet been prepared according to the interface.2214static std::optional<hlfir::EntityWithAttributes> genHLFIRIntrinsicRefCore(2215    Fortran::lower::PreparedActualArguments &loweredActuals,2216    const Fortran::evaluate::SpecificIntrinsic *intrinsic,2217    const fir::IntrinsicHandlerEntry &intrinsicEntry,2218    CallContext &callContext) {2219  // Try lowering transformational intrinsic ops to HLFIR ops if enabled2220  // (transformational always have a result type)2221  if (useHlfirIntrinsicOps && callContext.resultType) {2222    fir::FirOpBuilder &builder = callContext.getBuilder();2223    mlir::Location loc = callContext.loc;2224    const std::string intrinsicName = callContext.getProcedureName();2225    const fir::IntrinsicArgumentLoweringRules *argLowering =2226        intrinsicEntry.getArgumentLoweringRules();2227    mlir::Type resultType =2228        callContext.isElementalProcWithArrayArgs()2229            ? hlfir::getFortranElementType(*callContext.resultType)2230            : *callContext.resultType;2231 2232    std::optional<hlfir::EntityWithAttributes> res =2233        Fortran::lower::lowerHlfirIntrinsic(builder, loc, intrinsicName,2234                                            loweredActuals, argLowering,2235                                            resultType);2236    if (res)2237      return res;2238  }2239 2240  // fallback to calling the intrinsic via fir.call2241  return genIntrinsicRefCore(loweredActuals, intrinsic, intrinsicEntry,2242                             callContext);2243}2244 2245namespace {2246template <typename ElementalCallBuilderImpl>2247class ElementalCallBuilder {2248public:2249  std::optional<hlfir::EntityWithAttributes>2250  genElementalCall(Fortran::lower::PreparedActualArguments &loweredActuals,2251                   bool isImpure, CallContext &callContext) {2252    mlir::Location loc = callContext.loc;2253    fir::FirOpBuilder &builder = callContext.getBuilder();2254    unsigned numArgs = loweredActuals.size();2255    // Step 1: dereference pointers/allocatables and compute elemental shape.2256    mlir::Value shape;2257    Fortran::lower::PreparedActualArgument *optionalWithShape;2258    // 10.1.4 p5. Impure elemental procedures must be called in element order.2259    bool mustBeOrdered = isImpure;2260    for (unsigned i = 0; i < numArgs; ++i) {2261      auto &preparedActual = loweredActuals[i];2262      if (preparedActual) {2263        // Elemental procedure dummy arguments cannot be pointer/allocatables2264        // (C15100), so it is safe to dereference any pointer or allocatable2265        // actual argument now instead of doing this inside the elemental2266        // region.2267        preparedActual->derefPointersAndAllocatables(loc, builder);2268        // Better to load scalars outside of the loop when possible.2269        if (!preparedActual->handleDynamicOptional() &&2270            impl().canLoadActualArgumentBeforeLoop(i))2271          preparedActual->loadTrivialScalar(loc, builder);2272        // TODO: merge shape instead of using the first one.2273        if (!shape && preparedActual->isArray()) {2274          if (preparedActual->handleDynamicOptional())2275            optionalWithShape = &*preparedActual;2276          else2277            shape = preparedActual->genShape(loc, builder);2278        }2279        // 15.8.3 p1. Elemental procedure with intent(out)/intent(inout)2280        // arguments must be called in element order.2281        if (impl().argMayBeModifiedByCall(i))2282          mustBeOrdered = true;2283      }2284    }2285    if (!shape && optionalWithShape) {2286      // If all array operands appear in optional positions, then none of them2287      // is allowed to be absent as per 15.5.2.12 point 3. (6). Just pick the2288      // first operand.2289      shape = optionalWithShape->genShape(loc, builder);2290      // TODO: There is an opportunity to add a runtime check here that2291      // this array is present as required. Also, the optionality of all actual2292      // could be checked and reset given the Fortran requirement.2293      optionalWithShape->resetOptionalAspect();2294    }2295    assert(shape &&2296           "elemental array calls must have at least one array arguments");2297 2298    // Evaluate the actual argument array expressions before the elemental2299    // call of an impure subprogram or a subprogram with intent(out) or2300    // intent(inout) arguments. Note that the scalar arguments are handled2301    // above.2302    if (mustBeOrdered) {2303      for (auto &preparedActual : loweredActuals) {2304        if (preparedActual) {2305          if (hlfir::AssociateOp associate =2306                  preparedActual->associateIfArrayExpr(loc, builder)) {2307            fir::FirOpBuilder *bldr = &builder;2308            callContext.stmtCtx.attachCleanup([=]() {2309              hlfir::EndAssociateOp::create(*bldr, loc, associate);2310            });2311          }2312        }2313      }2314    }2315 2316    // Push a new local scope so that any temps made inside the elemental2317    // iterations are cleaned up inside the iterations.2318    if (!callContext.resultType) {2319      // Subroutine case. Generate call inside loop nest.2320      hlfir::LoopNest loopNest =2321          hlfir::genLoopNest(loc, builder, shape, !mustBeOrdered);2322      mlir::ValueRange oneBasedIndices = loopNest.oneBasedIndices;2323      auto insPt = builder.saveInsertionPoint();2324      builder.setInsertionPointToStart(loopNest.body);2325      callContext.stmtCtx.pushScope();2326      for (auto &preparedActual : loweredActuals)2327        if (preparedActual)2328          preparedActual->setElementalIndices(oneBasedIndices);2329      impl().genElementalKernel(loweredActuals, callContext);2330      callContext.stmtCtx.finalizeAndPop();2331      builder.restoreInsertionPoint(insPt);2332      return std::nullopt;2333    }2334    // Function case: generate call inside hlfir.elemental2335    mlir::Type elementType =2336        hlfir::getFortranElementType(*callContext.resultType);2337    // Get result length parameters.2338    llvm::SmallVector<mlir::Value> typeParams;2339    if (mlir::isa<fir::CharacterType>(elementType) ||2340        fir::isRecordWithTypeParameters(elementType)) {2341      auto charType = mlir::dyn_cast<fir::CharacterType>(elementType);2342      if (charType && charType.hasConstantLen())2343        typeParams.push_back(builder.createIntegerConstant(2344            loc, builder.getIndexType(), charType.getLen()));2345      else if (charType)2346        typeParams.push_back(impl().computeDynamicCharacterResultLength(2347            loweredActuals, callContext));2348      else2349        TODO(2350            loc,2351            "compute elemental PDT function result length parameters in HLFIR");2352    }2353    auto genKernel = [&](mlir::Location l, fir::FirOpBuilder &b,2354                         mlir::ValueRange oneBasedIndices) -> hlfir::Entity {2355      callContext.stmtCtx.pushScope();2356      for (auto &preparedActual : loweredActuals)2357        if (preparedActual)2358          preparedActual->setElementalIndices(oneBasedIndices);2359      auto res = *impl().genElementalKernel(loweredActuals, callContext);2360      callContext.stmtCtx.finalizeAndPop();2361      // Note that an hlfir.destroy is not emitted for the result since it2362      // is still used by the hlfir.yield_element that also marks its last2363      // use.2364      return res;2365    };2366    mlir::Value polymorphicMold;2367    if (fir::isPolymorphicType(*callContext.resultType))2368      polymorphicMold =2369          impl().getPolymorphicResultMold(loweredActuals, callContext);2370    mlir::Value elemental =2371        hlfir::genElementalOp(loc, builder, elementType, shape, typeParams,2372                              genKernel, !mustBeOrdered, polymorphicMold);2373    // If the function result requires finalization, then it has to be done2374    // for the array result of the elemental call. We have to communicate2375    // this via the DestroyOp's attribute.2376    bool mustFinalizeExpr = impl().resultMayRequireFinalization(callContext);2377    fir::FirOpBuilder *bldr = &builder;2378    callContext.stmtCtx.attachCleanup([=]() {2379      hlfir::DestroyOp::create(*bldr, loc, elemental, mustFinalizeExpr);2380    });2381    return hlfir::EntityWithAttributes{elemental};2382  }2383 2384private:2385  ElementalCallBuilderImpl &impl() {2386    return *static_cast<ElementalCallBuilderImpl *>(this);2387  }2388};2389 2390/// Helper for computing elemental function result specification2391/// expressions that depends on dummy symbols. See2392/// computeDynamicCharacterResultLength below.2393static mlir::Value genMockDummyForElementalResultSpecifications(2394    fir::FirOpBuilder &builder, mlir::Location loc, mlir::Type dummyType,2395    Fortran::lower::PreparedActualArgument &preparedActual) {2396  // One is used as the mock address instead of NULL so that PRESENT inquires2397  // work (this is the only valid thing that specification can do with the2398  // address thanks to Fortran 2023 C15121).2399  mlir::Value one =2400      builder.createIntegerConstant(loc, builder.getIntPtrType(), 1);2401  if (auto boxCharType = llvm::dyn_cast<fir::BoxCharType>(dummyType)) {2402    mlir::Value addr = builder.createConvert(2403        loc, fir::ReferenceType::get(boxCharType.getEleTy()), one);2404    mlir::Value len = preparedActual.genCharLength(loc, builder);2405    return fir::EmboxCharOp::create(builder, loc, boxCharType, addr, len);2406  }2407  if (auto box = llvm::dyn_cast<fir::BaseBoxType>(dummyType)) {2408    mlir::Value addr =2409        builder.createConvert(loc, box.getBaseAddressType(), one);2410    llvm::SmallVector<mlir::Value> lenParams;2411    preparedActual.genLengthParameters(loc, builder, lenParams);2412    mlir::Value mold;2413    if (fir::isPolymorphicType(box))2414      mold = preparedActual.getPolymorphicMold(loc);2415    return fir::EmboxOp::create(builder, loc, box, addr,2416                                /*shape=*/mlir::Value{},2417                                /*slice=*/mlir::Value{}, lenParams, mold);2418  }2419  // Values of arguments should not be used in elemental procedure specification2420  // expressions as per C15121, so it makes no sense to have a specification2421  // expression requiring a symbol that is passed by value (there is no good2422  // value to create here).2423  assert(fir::isa_ref_type(dummyType) &&2424         (fir::isa_trivial(fir::unwrapRefType(dummyType)) ||2425          fir::isa_char(fir::unwrapRefType(dummyType))) &&2426         "Only expect symbols inquired in elemental procedure result "2427         "specifications to be passed in memory");2428  return builder.createConvert(loc, dummyType, one);2429}2430 2431class ElementalUserCallBuilder2432    : public ElementalCallBuilder<ElementalUserCallBuilder> {2433public:2434  ElementalUserCallBuilder(Fortran::lower::CallerInterface &caller,2435                           mlir::FunctionType callSiteType)2436      : caller{caller}, callSiteType{callSiteType} {}2437  std::optional<hlfir::Entity>2438  genElementalKernel(Fortran::lower::PreparedActualArguments &loweredActuals,2439                     CallContext &callContext) {2440    return genUserCall(loweredActuals, caller, callSiteType, callContext);2441  }2442 2443  bool argMayBeModifiedByCall(unsigned argIdx) const {2444    assert(argIdx < caller.getPassedArguments().size() && "bad argument index");2445    return caller.getPassedArguments()[argIdx].mayBeModifiedByCall();2446  }2447 2448  bool canLoadActualArgumentBeforeLoop(unsigned argIdx) const {2449    using PassBy = Fortran::lower::CallerInterface::PassEntityBy;2450    const auto &passedArgs{caller.getPassedArguments()};2451    assert(argIdx < passedArgs.size() && "bad argument index");2452    // If the actual argument does not need to be passed via an address,2453    // or will be passed in the address of a temporary copy, it can be loaded2454    // before the elemental loop nest.2455    const auto &arg{passedArgs[argIdx]};2456    return arg.passBy == PassBy::Value ||2457           arg.passBy == PassBy::BaseAddressValueAttribute;2458  }2459 2460  mlir::Value computeDynamicCharacterResultLength(2461      Fortran::lower::PreparedActualArguments &loweredActuals,2462      CallContext &callContext) {2463 2464    fir::FirOpBuilder &builder = callContext.getBuilder();2465    mlir::Location loc = callContext.loc;2466    auto &converter = callContext.converter;2467 2468    // Gather the dummy argument symbols required directly or indirectly to2469    // evaluate the result symbol specification expressions.2470    llvm::SmallPtrSet<const Fortran::semantics::Symbol *, 4>2471        requiredDummySymbols;2472    const Fortran::semantics::Symbol &result = caller.getResultSymbol();2473    for (Fortran::lower::pft::Variable var :2474         Fortran::lower::pft::getDependentVariableList(result))2475      if (var.hasSymbol()) {2476        const Fortran::semantics::Symbol &sym = var.getSymbol();2477        if (Fortran::semantics::IsDummy(sym) && sym.owner() == result.owner())2478          requiredDummySymbols.insert(&sym);2479      }2480 2481    // Prepare mock FIR arguments for each dummy arguments required in the2482    // result specifications. These mock arguments will have the same properties2483    // (dynamic type and type parameters) as the actual arguments, except for2484    // the address. Such mock argument are needed because this evaluation is2485    // happening before the loop for the elemental call (the array result2486    // storage must be allocated before the loops if any is needed, so the2487    // result properties must be known before the loops). So it is not possible2488    // to just pick an element (like the first one) and use that because the2489    // normal argument preparation have effects (vector subscripted actual2490    // argument will require reading the vector subscript and VALUE arguments2491    // preparation involve copies of the data. This could cause segfaults in2492    // case of zero size arrays and is in general pointless extra computation2493    // since the data cannot be used in the specification expression as per2494    // C15121).2495    if (!requiredDummySymbols.empty()) {2496      const Fortran::semantics::SubprogramDetails *iface =2497          caller.getInterfaceDetails();2498      assert(iface && "interface must be explicit when result specification "2499                      "depends upon dummy symbols");2500      for (auto [maybePreparedActual, arg, sym] : llvm::zip(2501               loweredActuals, caller.getPassedArguments(), iface->dummyArgs()))2502        if (requiredDummySymbols.contains(sym)) {2503          mlir::Type dummyType = callSiteType.getInput(arg.firArgument);2504 2505          if (!maybePreparedActual.has_value()) {2506            mlir::Value mockArgValue =2507                fir::AbsentOp::create(builder, loc, dummyType);2508            caller.placeInput(arg, mockArgValue);2509            continue;2510          }2511 2512          Fortran::lower::PreparedActualArgument &preparedActual =2513              maybePreparedActual.value();2514 2515          if (preparedActual.handleDynamicOptional()) {2516            mlir::Value isPresent = preparedActual.getIsPresent();2517            mlir::Value mockArgValue =2518                builder2519                    .genIfOp(loc, {dummyType}, isPresent,2520                             /*withElseRegion=*/true)2521                    .genThen([&]() {2522                      mlir::Value mockArgValue =2523                          genMockDummyForElementalResultSpecifications(2524                              builder, loc, dummyType, preparedActual);2525                      fir::ResultOp::create(builder, loc, mockArgValue);2526                    })2527                    .genElse([&]() {2528                      mlir::Value absent =2529                          fir::AbsentOp::create(builder, loc, dummyType);2530                      fir::ResultOp::create(builder, loc, absent);2531                    })2532                    .getResults()[0];2533            caller.placeInput(arg, mockArgValue);2534          } else {2535            mlir::Value mockArgValue =2536                genMockDummyForElementalResultSpecifications(2537                    builder, loc, dummyType, preparedActual);2538            caller.placeInput(arg, mockArgValue);2539          }2540        }2541    }2542 2543    // Map symbols required by the result specification expressions to SSA2544    // values. This will both finish mapping the mock value created above if2545    // any, and deal with any module/common block variables accessed in the2546    // specification expressions.2547    // Map prepared argument to dummy symbol to be able to lower spec expr.2548    callContext.symMap.pushScope();2549    Fortran::lower::mapCallInterfaceSymbolsForResult(converter, caller,2550                                                     callContext.symMap);2551 2552    // Evaluate the result length expression.2553    mlir::Type idxTy = builder.getIndexType();2554    auto lowerSpecExpr = [&](const auto &expr) -> mlir::Value {2555      mlir::Value convertExpr = builder.createConvert(2556          loc, idxTy,2557          fir::getBase(converter.genExprValue(expr, callContext.stmtCtx)));2558      return fir::factory::genMaxWithZero(builder, loc, convertExpr);2559    };2560 2561    llvm::SmallVector<mlir::Value> lengths;2562    caller.walkResultLengths(2563        [&](const Fortran::lower::SomeExpr &e, bool isAssumedSizeExtent) {2564          assert(!isAssumedSizeExtent && "result cannot be assumed-size");2565          lengths.emplace_back(lowerSpecExpr(e));2566        });2567    callContext.symMap.popScope();2568    assert(lengths.size() == 1 && "expect 1 length parameter for the result");2569    return lengths[0];2570  }2571 2572  mlir::Value getPolymorphicResultMold(2573      Fortran::lower::PreparedActualArguments &loweredActuals,2574      CallContext &callContext) {2575    fir::emitFatalError(callContext.loc,2576                        "elemental function call with polymorphic result");2577    return {};2578  }2579 2580  bool resultMayRequireFinalization(CallContext &callContext) const {2581    std::optional<Fortran::evaluate::DynamicType> retTy =2582        caller.getCallDescription().proc().GetType();2583    if (!retTy)2584      return false;2585 2586    if (retTy->IsPolymorphic() || retTy->IsUnlimitedPolymorphic())2587      fir::emitFatalError(2588          callContext.loc,2589          "elemental function call with [unlimited-]polymorphic result");2590 2591    if (retTy->category() == Fortran::common::TypeCategory::Derived) {2592      const Fortran::semantics::DerivedTypeSpec &typeSpec =2593          retTy->GetDerivedTypeSpec();2594      return Fortran::semantics::IsFinalizable(typeSpec);2595    }2596 2597    return false;2598  }2599 2600private:2601  Fortran::lower::CallerInterface &caller;2602  mlir::FunctionType callSiteType;2603};2604 2605class ElementalIntrinsicCallBuilder2606    : public ElementalCallBuilder<ElementalIntrinsicCallBuilder> {2607public:2608  ElementalIntrinsicCallBuilder(2609      const Fortran::evaluate::SpecificIntrinsic *intrinsic,2610      const fir::IntrinsicHandlerEntry &intrinsicEntry, bool isFunction)2611      : intrinsic{intrinsic}, intrinsicEntry{intrinsicEntry},2612        isFunction{isFunction} {}2613  std::optional<hlfir::Entity>2614  genElementalKernel(Fortran::lower::PreparedActualArguments &loweredActuals,2615                     CallContext &callContext) {2616    return genHLFIRIntrinsicRefCore(loweredActuals, intrinsic, intrinsicEntry,2617                                    callContext);2618  }2619  // Elemental intrinsic functions cannot modify their arguments.2620  bool argMayBeModifiedByCall(int) const { return !isFunction; }2621  bool canLoadActualArgumentBeforeLoop(int) const {2622    // Elemental intrinsic functions never need the actual addresses2623    // of their arguments.2624    return isFunction;2625  }2626 2627  mlir::Value computeDynamicCharacterResultLength(2628      Fortran::lower::PreparedActualArguments &loweredActuals,2629      CallContext &callContext) {2630    if (intrinsic)2631      if (intrinsic->name == "adjustr" || intrinsic->name == "adjustl" ||2632          intrinsic->name == "merge")2633        return loweredActuals[0].value().genCharLength(2634            callContext.loc, callContext.getBuilder());2635    // Character MIN/MAX is the min/max of the arguments length that are2636    // present.2637    TODO(callContext.loc,2638         "compute elemental character min/max function result length in HLFIR");2639  }2640 2641  mlir::Value getPolymorphicResultMold(2642      Fortran::lower::PreparedActualArguments &loweredActuals,2643      CallContext &callContext) {2644    if (!intrinsic)2645      return {};2646 2647    if (intrinsic->name == "merge") {2648      // MERGE seems to be the only elemental function that can produce2649      // polymorphic result. The MERGE's result is polymorphic iff2650      // both TSOURCE and FSOURCE are polymorphic, and they also must have2651      // the same declared and dynamic types. So any of them can be used2652      // for the mold.2653      assert(!loweredActuals.empty());2654      return loweredActuals.front()->getPolymorphicMold(callContext.loc);2655    }2656 2657    return {};2658  }2659 2660  bool resultMayRequireFinalization(2661      [[maybe_unused]] CallContext &callContext) const {2662    // FIXME: need access to the CallerInterface's return type2663    // to check if the result may need finalization (e.g. the result2664    // of MERGE).2665    return false;2666  }2667 2668private:2669  const Fortran::evaluate::SpecificIntrinsic *intrinsic;2670  fir::IntrinsicHandlerEntry intrinsicEntry;2671  const bool isFunction;2672};2673} // namespace2674 2675static std::optional<mlir::Value>2676genIsPresentIfArgMaybeAbsent(mlir::Location loc, hlfir::Entity actual,2677                             const Fortran::lower::SomeExpr &expr,2678                             CallContext &callContext,2679                             bool passAsAllocatableOrPointer) {2680  if (!Fortran::evaluate::MayBePassedAsAbsentOptional(expr))2681    return std::nullopt;2682  fir::FirOpBuilder &builder = callContext.getBuilder();2683  if (!passAsAllocatableOrPointer &&2684      Fortran::evaluate::IsAllocatableOrPointerObject(expr)) {2685    // Passing Allocatable/Pointer to non-pointer/non-allocatable OPTIONAL.2686    // Fortran 2018 15.5.2.12 point 1: If unallocated/disassociated, it is2687    // as if the argument was absent. The main care here is to not do a2688    // copy-in/copy-out because the temp address, even though pointing to a2689    // null size storage, would not be a nullptr and therefore the argument2690    // would not be considered absent on the callee side. Note: if the2691    // allocatable/pointer is also optional, it cannot be absent as per2692    // 15.5.2.12 point 7. and 8. We rely on this to un-conditionally read2693    // the allocatable/pointer descriptor here.2694    mlir::Value addr = genVariableRawAddress(loc, builder, actual);2695    return builder.genIsNotNullAddr(loc, addr);2696  }2697  // TODO: what if passing allocatable target to optional intent(in) pointer?2698  // May fall into the category above if the allocatable is not optional.2699 2700  // Passing an optional to an optional.2701  return fir::IsPresentOp::create(builder, loc, builder.getI1Type(), actual)2702      .getResult();2703}2704 2705// Lower a reference to an elemental intrinsic procedure with array arguments2706// and custom optional handling2707static std::optional<hlfir::EntityWithAttributes>2708genCustomElementalIntrinsicRef(2709    const Fortran::evaluate::SpecificIntrinsic *intrinsic,2710    CallContext &callContext) {2711  assert(callContext.isElementalProcWithArrayArgs() &&2712         "Use genCustomIntrinsicRef for scalar calls");2713  mlir::Location loc = callContext.loc;2714  auto &converter = callContext.converter;2715  Fortran::lower::PreparedActualArguments operands;2716  assert(intrinsic && Fortran::lower::intrinsicRequiresCustomOptionalHandling(2717                          callContext.procRef, *intrinsic, converter));2718 2719  // callback for optional arguments2720  auto prepareOptionalArg = [&](const Fortran::lower::SomeExpr &expr) {2721    hlfir::EntityWithAttributes actual = Fortran::lower::convertExprToHLFIR(2722        loc, converter, expr, callContext.symMap, callContext.stmtCtx);2723    std::optional<mlir::Value> isPresent =2724        genIsPresentIfArgMaybeAbsent(loc, actual, expr, callContext,2725                                     /*passAsAllocatableOrPointer=*/false);2726    operands.emplace_back(2727        Fortran::lower::PreparedActualArgument{actual, isPresent});2728  };2729 2730  // callback for non-optional arguments2731  auto prepareOtherArg = [&](const Fortran::lower::SomeExpr &expr,2732                             fir::LowerIntrinsicArgAs lowerAs) {2733    hlfir::EntityWithAttributes actual = Fortran::lower::convertExprToHLFIR(2734        loc, converter, expr, callContext.symMap, callContext.stmtCtx);2735    operands.emplace_back(Fortran::lower::PreparedActualArgument{2736        actual, /*isPresent=*/std::nullopt});2737  };2738 2739  Fortran::lower::prepareCustomIntrinsicArgument(2740      callContext.procRef, *intrinsic, callContext.resultType,2741      prepareOptionalArg, prepareOtherArg, converter);2742 2743  std::optional<fir::IntrinsicHandlerEntry> intrinsicEntry =2744      fir::lookupIntrinsicHandler(callContext.getBuilder(),2745                                  callContext.getProcedureName(),2746                                  callContext.resultType);2747  assert(intrinsicEntry.has_value() &&2748         "intrinsic with custom handling for OPTIONAL arguments must have "2749         "lowering entries");2750  // All of the custom intrinsic elementals with custom handling are pure2751  // functions2752  return ElementalIntrinsicCallBuilder{intrinsic, *intrinsicEntry,2753                                       /*isFunction=*/true}2754      .genElementalCall(operands, /*isImpure=*/false, callContext);2755}2756 2757// Lower a reference to an intrinsic procedure with custom optional handling2758static std::optional<hlfir::EntityWithAttributes>2759genCustomIntrinsicRef(const Fortran::evaluate::SpecificIntrinsic *intrinsic,2760                      CallContext &callContext) {2761  assert(!callContext.isElementalProcWithArrayArgs() &&2762         "Needs to be run through ElementalIntrinsicCallBuilder first");2763  mlir::Location loc = callContext.loc;2764  fir::FirOpBuilder &builder = callContext.getBuilder();2765  auto &converter = callContext.converter;2766  auto &stmtCtx = callContext.stmtCtx;2767  assert(intrinsic && Fortran::lower::intrinsicRequiresCustomOptionalHandling(2768                          callContext.procRef, *intrinsic, converter));2769  Fortran::lower::PreparedActualArguments loweredActuals;2770 2771  // callback for optional arguments2772  auto prepareOptionalArg = [&](const Fortran::lower::SomeExpr &expr) {2773    hlfir::EntityWithAttributes actual = Fortran::lower::convertExprToHLFIR(2774        loc, converter, expr, callContext.symMap, callContext.stmtCtx);2775    mlir::Value isPresent =2776        genIsPresentIfArgMaybeAbsent(loc, actual, expr, callContext,2777                                     /*passAsAllocatableOrPointer*/ false)2778            .value();2779    loweredActuals.emplace_back(2780        Fortran::lower::PreparedActualArgument{actual, {isPresent}});2781  };2782 2783  // callback for non-optional arguments2784  auto prepareOtherArg = [&](const Fortran::lower::SomeExpr &expr,2785                             fir::LowerIntrinsicArgAs lowerAs) {2786    auto getActualFortranElementType = [&]() -> mlir::Type {2787      return hlfir::getFortranElementType(converter.genType(expr));2788    };2789    hlfir::EntityWithAttributes actual = Fortran::lower::convertExprToHLFIR(2790        loc, converter, expr, callContext.symMap, callContext.stmtCtx);2791    std::optional<fir::ExtendedValue> exv;2792    switch (lowerAs) {2793    case fir::LowerIntrinsicArgAs::Value:2794      exv = Fortran::lower::convertToValue(loc, converter, actual, stmtCtx);2795      break;2796    case fir::LowerIntrinsicArgAs::Addr:2797      exv = Fortran::lower::convertToAddress(loc, converter, actual, stmtCtx,2798                                             getActualFortranElementType());2799      break;2800    case fir::LowerIntrinsicArgAs::Box:2801      exv = Fortran::lower::convertToBox(loc, converter, actual, stmtCtx,2802                                         getActualFortranElementType());2803      break;2804    case fir::LowerIntrinsicArgAs::Inquired:2805      exv = Fortran::lower::translateToExtendedValue(loc, builder, actual,2806                                                     stmtCtx);2807      break;2808    }2809    if (!exv)2810      llvm_unreachable("bad switch");2811    actual = extendedValueToHlfirEntity(loc, builder, exv.value(),2812                                        "tmp.custom_intrinsic_arg");2813    loweredActuals.emplace_back(Fortran::lower::PreparedActualArgument{2814        actual, /*isPresent=*/std::nullopt});2815  };2816 2817  Fortran::lower::prepareCustomIntrinsicArgument(2818      callContext.procRef, *intrinsic, callContext.resultType,2819      prepareOptionalArg, prepareOtherArg, converter);2820 2821  return genCustomIntrinsicRefCore(loweredActuals, intrinsic, callContext);2822}2823 2824/// Lower an intrinsic procedure reference.2825/// \p intrinsic is null if this is an intrinsic module procedure that must be2826/// lowered as if it were an intrinsic module procedure (like C_LOC which is a2827/// procedure from intrinsic module iso_c_binding). Otherwise, \p intrinsic2828/// must not be null.2829 2830static std::optional<hlfir::EntityWithAttributes>2831genIntrinsicRef(const Fortran::evaluate::SpecificIntrinsic *intrinsic,2832                const fir::IntrinsicHandlerEntry &intrinsicEntry,2833                CallContext &callContext) {2834  mlir::Location loc = callContext.loc;2835  Fortran::lower::PreparedActualArguments loweredActuals;2836  const fir::IntrinsicArgumentLoweringRules *argLowering =2837      intrinsicEntry.getArgumentLoweringRules();2838  for (const auto &arg : llvm::enumerate(callContext.procRef.arguments())) {2839 2840    if (!arg.value()) {2841      // Absent optional.2842      loweredActuals.push_back(std::nullopt);2843      continue;2844    }2845    auto *expr =2846        Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());2847    if (!expr) {2848      // TYPE(*) dummy. They are only allowed as argument of a few intrinsics2849      // that do not take optional arguments: see Fortran 2018 standard C710.2850      const Fortran::evaluate::Symbol *assumedTypeSym =2851          arg.value()->GetAssumedTypeDummy();2852      if (!assumedTypeSym)2853        fir::emitFatalError(loc,2854                            "expected assumed-type symbol as actual argument");2855      std::optional<fir::FortranVariableOpInterface> var =2856          callContext.symMap.lookupVariableDefinition(*assumedTypeSym);2857      if (!var)2858        fir::emitFatalError(loc, "assumed-type symbol was not lowered");2859      assert(2860          (!argLowering ||2861           !fir::lowerIntrinsicArgumentAs(*argLowering, arg.index())2862                .handleDynamicOptional) &&2863          "TYPE(*) are not expected to appear as optional intrinsic arguments");2864      loweredActuals.push_back(Fortran::lower::PreparedActualArgument{2865          hlfir::Entity{*var}, /*isPresent=*/std::nullopt});2866      continue;2867    }2868    // arguments of bitwise comparison functions may not have nsw flag2869    // even if -fno-wrapv is enabled2870    mlir::arith::IntegerOverflowFlags iofBackup{};2871    auto isBitwiseComparison = [](const std::string intrinsicName) -> bool {2872      if (intrinsicName == "bge" || intrinsicName == "bgt" ||2873          intrinsicName == "ble" || intrinsicName == "blt")2874        return true;2875      return false;2876    };2877    if (isBitwiseComparison(callContext.getProcedureName())) {2878      iofBackup = callContext.getBuilder().getIntegerOverflowFlags();2879      callContext.getBuilder().setIntegerOverflowFlags(2880          mlir::arith::IntegerOverflowFlags::none);2881    }2882    auto loweredActual = Fortran::lower::convertExprToHLFIR(2883        loc, callContext.converter, *expr, callContext.symMap,2884        callContext.stmtCtx);2885    if (isBitwiseComparison(callContext.getProcedureName()))2886      callContext.getBuilder().setIntegerOverflowFlags(iofBackup);2887 2888    std::optional<mlir::Value> isPresent;2889    if (argLowering) {2890      fir::ArgLoweringRule argRules =2891          fir::lowerIntrinsicArgumentAs(*argLowering, arg.index());2892      if (argRules.handleDynamicOptional)2893        isPresent =2894            genIsPresentIfArgMaybeAbsent(loc, loweredActual, *expr, callContext,2895                                         /*passAsAllocatableOrPointer=*/false);2896    }2897    loweredActuals.push_back(2898        Fortran::lower::PreparedActualArgument{loweredActual, isPresent});2899  }2900 2901  if (callContext.isElementalProcWithArrayArgs()) {2902    // All intrinsic elemental functions are pure.2903    const bool isFunction = callContext.resultType.has_value();2904    return ElementalIntrinsicCallBuilder{intrinsic, intrinsicEntry, isFunction}2905        .genElementalCall(loweredActuals, /*isImpure=*/!isFunction,2906                          callContext);2907  }2908  std::optional<hlfir::EntityWithAttributes> result = genHLFIRIntrinsicRefCore(2909      loweredActuals, intrinsic, intrinsicEntry, callContext);2910  if (result && mlir::isa<hlfir::ExprType>(result->getType())) {2911    fir::FirOpBuilder *bldr = &callContext.getBuilder();2912    callContext.stmtCtx.attachCleanup(2913        [=]() { hlfir::DestroyOp::create(*bldr, loc, *result); });2914  }2915  return result;2916}2917 2918static std::optional<hlfir::EntityWithAttributes>2919genIntrinsicRef(const Fortran::evaluate::SpecificIntrinsic *intrinsic,2920                CallContext &callContext) {2921  mlir::Location loc = callContext.loc;2922  auto &converter = callContext.converter;2923  if (intrinsic && Fortran::lower::intrinsicRequiresCustomOptionalHandling(2924                       callContext.procRef, *intrinsic, converter)) {2925    if (callContext.isElementalProcWithArrayArgs())2926      return genCustomElementalIntrinsicRef(intrinsic, callContext);2927    return genCustomIntrinsicRef(intrinsic, callContext);2928  }2929  std::optional<fir::IntrinsicHandlerEntry> intrinsicEntry =2930      fir::lookupIntrinsicHandler(callContext.getBuilder(),2931                                  callContext.getProcedureName(),2932                                  callContext.resultType);2933  if (!intrinsicEntry)2934    fir::crashOnMissingIntrinsic(loc, callContext.getProcedureName());2935  return genIntrinsicRef(intrinsic, *intrinsicEntry, callContext);2936}2937 2938/// Main entry point to lower procedure references, regardless of what they are.2939static std::optional<hlfir::EntityWithAttributes>2940genProcedureRef(CallContext &callContext) {2941  mlir::Location loc = callContext.loc;2942  fir::FirOpBuilder &builder = callContext.getBuilder();2943  if (auto *intrinsic = callContext.procRef.proc().GetSpecificIntrinsic())2944    return genIntrinsicRef(intrinsic, callContext);2945  // Intercept non BIND(C) module procedure reference that have lowering2946  // handlers defined for there name. Otherwise, lower them as user2947  // procedure calls and expect the implementation to be part of2948  // runtime libraries with the proper name mangling.2949  if (Fortran::lower::isIntrinsicModuleProcRef(callContext.procRef) &&2950      !callContext.isBindcCall())2951    if (std::optional<fir::IntrinsicHandlerEntry> intrinsicEntry =2952            fir::lookupIntrinsicHandler(builder, callContext.getProcedureName(),2953                                        callContext.resultType))2954      return genIntrinsicRef(nullptr, *intrinsicEntry, callContext);2955 2956  if (callContext.isStatementFunctionCall())2957    return genStmtFunctionRef(loc, callContext.converter, callContext.symMap,2958                              callContext.stmtCtx, callContext.procRef);2959 2960  Fortran::lower::CallerInterface caller(callContext.procRef,2961                                         callContext.converter);2962  mlir::FunctionType callSiteType = caller.genFunctionType();2963  const bool isElemental = callContext.isElementalProcWithArrayArgs();2964  Fortran::lower::PreparedActualArguments loweredActuals;2965  // Lower the actual arguments2966  for (const Fortran::lower::CallInterface<2967           Fortran::lower::CallerInterface>::PassedEntity &arg :2968       caller.getPassedArguments())2969    if (const auto *actual = arg.entity) {2970      const auto *expr = actual->UnwrapExpr();2971      if (!expr) {2972        // TYPE(*) actual argument.2973        const Fortran::evaluate::Symbol *assumedTypeSym =2974            actual->GetAssumedTypeDummy();2975        if (!assumedTypeSym)2976          fir::emitFatalError(2977              loc, "expected assumed-type symbol as actual argument");2978        std::optional<fir::FortranVariableOpInterface> var =2979            callContext.symMap.lookupVariableDefinition(*assumedTypeSym);2980        if (!var)2981          fir::emitFatalError(loc, "assumed-type symbol was not lowered");2982        hlfir::Entity actual{*var};2983        std::optional<mlir::Value> isPresent;2984        if (arg.isOptional()) {2985          // Passing an optional TYPE(*) to an optional TYPE(*). Note that2986          // TYPE(*) cannot be ALLOCATABLE/POINTER (C709) so there is no2987          // need to cover the case of passing an ALLOCATABLE/POINTER to an2988          // OPTIONAL.2989          isPresent = fir::IsPresentOp::create(builder, loc,2990                                               builder.getI1Type(), actual)2991                          .getResult();2992        }2993        loweredActuals.push_back(Fortran::lower::PreparedActualArgument{2994            hlfir::Entity{*var}, isPresent});2995        continue;2996      }2997 2998      if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(2999              *expr)) {3000        if ((arg.passBy !=3001             Fortran::lower::CallerInterface::PassEntityBy::MutableBox) &&3002            (arg.passBy !=3003             Fortran::lower::CallerInterface::PassEntityBy::BoxProcRef)) {3004          assert(3005              arg.isOptional() &&3006              "NULL must be passed only to pointer, allocatable, or OPTIONAL");3007          // Trying to lower NULL() outside of any context would lead to3008          // trouble. NULL() here is equivalent to not providing the3009          // actual argument.3010          loweredActuals.emplace_back(std::nullopt);3011          continue;3012        }3013      }3014 3015      if (isElemental && !arg.hasValueAttribute() &&3016          Fortran::evaluate::IsVariable(*expr) &&3017          Fortran::evaluate::HasVectorSubscript(*expr)) {3018        // Vector subscripted arguments are copied in calls, except in elemental3019        // calls without VALUE attribute where Fortran 2018 15.5.2.4 point 213020        // does not apply and the address of each element must be passed.3021        hlfir::ElementalAddrOp elementalAddr =3022            Fortran::lower::convertVectorSubscriptedExprToElementalAddr(3023                loc, callContext.converter, *expr, callContext.symMap,3024                callContext.stmtCtx);3025        loweredActuals.emplace_back(3026            Fortran::lower::PreparedActualArgument{elementalAddr});3027        continue;3028      }3029 3030      auto loweredActual = Fortran::lower::convertExprToHLFIR(3031          loc, callContext.converter, *expr, callContext.symMap,3032          callContext.stmtCtx);3033      std::optional<mlir::Value> isPresent;3034      if (arg.isOptional())3035        isPresent = genIsPresentIfArgMaybeAbsent(3036            loc, loweredActual, *expr, callContext,3037            arg.passBy ==3038                Fortran::lower::CallerInterface::PassEntityBy::MutableBox);3039 3040      loweredActuals.emplace_back(3041          Fortran::lower::PreparedActualArgument{loweredActual, isPresent});3042    } else {3043      // Optional dummy argument for which there is no actual argument.3044      loweredActuals.emplace_back(std::nullopt);3045    }3046  if (isElemental) {3047    bool isImpure = false;3048    if (const Fortran::semantics::Symbol *procSym =3049            callContext.procRef.proc().GetSymbol())3050      isImpure = !Fortran::semantics::IsPureProcedure(*procSym);3051    return ElementalUserCallBuilder{caller, callSiteType}.genElementalCall(3052        loweredActuals, isImpure, callContext);3053  }3054  return genUserCall(loweredActuals, caller, callSiteType, callContext);3055}3056 3057hlfir::Entity Fortran::lower::PreparedActualArgument::getActual(3058    mlir::Location loc, fir::FirOpBuilder &builder) const {3059  if (auto *actualEntity = std::get_if<hlfir::Entity>(&actual)) {3060    if (oneBasedElementalIndices)3061      return hlfir::getElementAt(loc, builder, *actualEntity,3062                                 *oneBasedElementalIndices);3063    return *actualEntity;3064  }3065  assert(oneBasedElementalIndices && "expect elemental context");3066  hlfir::ElementalAddrOp elementalAddr =3067      std::get<hlfir::ElementalAddrOp>(actual);3068  mlir::IRMapping mapper;3069  auto alwaysFalse = [](hlfir::ElementalOp) -> bool { return false; };3070  mlir::Value addr = hlfir::inlineElementalOp(3071      loc, builder, elementalAddr, *oneBasedElementalIndices, mapper,3072      /*mustRecursivelyInline=*/alwaysFalse);3073  assert(elementalAddr.getCleanup().empty() && "no clean-up expected");3074  elementalAddr.erase();3075  return hlfir::Entity{addr};3076}3077 3078bool Fortran::lower::isIntrinsicModuleProcRef(3079    const Fortran::evaluate::ProcedureRef &procRef) {3080  const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol();3081  if (!symbol)3082    return false;3083  const Fortran::semantics::Symbol *module =3084      symbol->GetUltimate().owner().GetSymbol();3085  return module && module->attrs().test(Fortran::semantics::Attr::INTRINSIC);3086}3087 3088static bool isInWhereMaskedExpression(fir::FirOpBuilder &builder) {3089  // The MASK of the outer WHERE is not masked itself.3090  mlir::Operation *op = builder.getRegion().getParentOp();3091  return op && op->getParentOfType<hlfir::WhereOp>();3092}3093 3094std::optional<hlfir::EntityWithAttributes> Fortran::lower::convertCallToHLFIR(3095    mlir::Location loc, Fortran::lower::AbstractConverter &converter,3096    const evaluate::ProcedureRef &procRef, std::optional<mlir::Type> resultType,3097    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {3098  auto &builder = converter.getFirOpBuilder();3099  if (resultType && !procRef.IsElemental() &&3100      isInWhereMaskedExpression(builder) &&3101      !builder.getRegion().getParentOfType<hlfir::ExactlyOnceOp>()) {3102    // Non elemental calls inside a where-assignment-stmt must be executed3103    // exactly once without mask control. Lower them in a special region so that3104    // this can be enforced whenscheduling forall/where expression evaluations.3105    Fortran::lower::StatementContext localStmtCtx;3106    mlir::Type bogusType = builder.getIndexType();3107    auto exactlyOnce = hlfir::ExactlyOnceOp::create(builder, loc, bogusType);3108    mlir::Block *block = builder.createBlock(&exactlyOnce.getBody());3109    builder.setInsertionPointToStart(block);3110    CallContext callContext(procRef, resultType, loc, converter, symMap,3111                            localStmtCtx);3112    std::optional<hlfir::EntityWithAttributes> res =3113        genProcedureRef(callContext);3114    assert(res.has_value() && "must be a function");3115    auto yield = hlfir::YieldOp::create(builder, loc, *res);3116    Fortran::lower::genCleanUpInRegionIfAny(loc, builder, yield.getCleanup(),3117                                            localStmtCtx);3118    builder.setInsertionPointAfter(exactlyOnce);3119    exactlyOnce->getResult(0).setType(res->getType());3120    if (hlfir::isFortranValue(exactlyOnce.getResult()))3121      return hlfir::EntityWithAttributes{exactlyOnce.getResult()};3122    // Create hlfir.declare for the result to satisfy3123    // hlfir::EntityWithAttributes requirements.3124    auto [exv, cleanup] = hlfir::translateToExtendedValue(3125        loc, builder, hlfir::Entity{exactlyOnce});3126    assert(!cleanup && "resut is a variable");3127    return hlfir::genDeclare(loc, builder, exv, ".func.pointer.result",3128                             fir::FortranVariableFlagsAttr{});3129  }3130  CallContext callContext(procRef, resultType, loc, converter, symMap, stmtCtx);3131  return genProcedureRef(callContext);3132}3133 3134void Fortran::lower::convertUserDefinedAssignmentToHLFIR(3135    mlir::Location loc, Fortran::lower::AbstractConverter &converter,3136    const evaluate::ProcedureRef &procRef, hlfir::Entity lhs, hlfir::Entity rhs,3137    Fortran::lower::SymMap &symMap) {3138  Fortran::lower::StatementContext definedAssignmentContext;3139  // For defined assignment, don't use regular copy-in/copy-out mechanism:3140  // defined assignment generates hlfir.region_assign construct, and this3141  // construct automatically handles any copy-in.3142  CallContext callContext(procRef, /*resultType=*/std::nullopt, loc, converter,3143                          symMap, definedAssignmentContext, /*doCopyIn=*/false);3144  Fortran::lower::CallerInterface caller(procRef, converter);3145  mlir::FunctionType callSiteType = caller.genFunctionType();3146  PreparedActualArgument preparedLhs{lhs, /*isPresent=*/std::nullopt};3147  PreparedActualArgument preparedRhs{rhs, /*isPresent=*/std::nullopt};3148  PreparedActualArguments loweredActuals{preparedLhs, preparedRhs};3149  genUserCall(loweredActuals, caller, callSiteType, callContext);3150  return;3151}3152