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