diff --git a/flang/include/flang/Lower/CallInterface.h b/flang/include/flang/Lower/CallInterface.h index 440ac4e78bb98..5308e3450b23f 100644 --- a/flang/include/flang/Lower/CallInterface.h +++ b/flang/include/flang/Lower/CallInterface.h @@ -153,16 +153,18 @@ class CallInterface { /// PassedEntity is what is provided back to the CallInterface user. /// It describe how the entity is plugged in the interface struct PassedEntity { - /// Is the dummy argument optional ? + /// Is the dummy argument optional? bool isOptional() const; - /// Can the argument be modified by the callee ? + /// Can the argument be modified by the callee? bool mayBeModifiedByCall() const; - /// Can the argument be read by the callee ? + /// Can the argument be read by the callee? bool mayBeReadByCall() const; /// Is the argument INTENT(OUT) bool isIntentOut() const; - /// Does the argument have the CONTIGUOUS attribute or have explicit shape ? + /// Does the argument have the CONTIGUOUS attribute or have explicit shape? bool mustBeMadeContiguous() const; + /// Does the dummy argument have the VALUE attribute? + bool hasValueAttribute() const; /// How entity is passed by. PassEntityBy passBy; /// What is the entity (SymbolRef for callee/ActualArgument* for caller) diff --git a/flang/include/flang/Optimizer/Builder/HLFIRTools.h b/flang/include/flang/Optimizer/Builder/HLFIRTools.h index 20b1f35165290..bbc0595a73913 100644 --- a/flang/include/flang/Optimizer/Builder/HLFIRTools.h +++ b/flang/include/flang/Optimizer/Builder/HLFIRTools.h @@ -246,6 +246,10 @@ mlir::Value genVariableRawAddress(mlir::Location loc, mlir::Value genVariableBoxChar(mlir::Location loc, fir::FirOpBuilder &builder, hlfir::Entity var); +/// Get or create a fir.box or fir.class from a variable. +hlfir::Entity genVariableBox(mlir::Location loc, fir::FirOpBuilder &builder, + hlfir::Entity var); + /// If the entity is a variable, load its value (dereference pointers and /// allocatables if needed). Do nothing if the entity is already a value, and /// only dereference pointers and allocatables if it is not a scalar entity diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp index bc9967f3e64e6..1f72b5c0709e0 100644 --- a/flang/lib/Lower/CallInterface.cpp +++ b/flang/lib/Lower/CallInterface.cpp @@ -1121,12 +1121,7 @@ bool Fortran::lower::CallInterface::PassedEntity::mayBeModifiedByCall() return true; if (characteristics->GetIntent() == Fortran::common::Intent::In) return false; - const auto *dummy = - std::get_if( - &characteristics->u); - return !dummy || - !dummy->attrs.test( - Fortran::evaluate::characteristics::DummyDataObject::Attr::Value); + return !hasValueAttribute(); } template bool Fortran::lower::CallInterface::PassedEntity::mayBeReadByCall() const { @@ -1162,6 +1157,18 @@ bool Fortran::lower::CallInterface::PassedEntity::mustBeMadeContiguous() return dummy->type.Rank() > 0; } +template +bool Fortran::lower::CallInterface::PassedEntity::hasValueAttribute() const { + if (!characteristics) + return false; + const auto *dummy = + std::get_if( + &characteristics->u); + return dummy && + dummy->attrs.test( + Fortran::evaluate::characteristics::DummyDataObject::Attr::Value); +} + template void Fortran::lower::CallInterface::determineInterface( bool isImplicit, diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp index a18c1ec8b7d6c..be37c5f5d86fd 100644 --- a/flang/lib/Lower/ConvertCall.cpp +++ b/flang/lib/Lower/ConvertCall.cpp @@ -560,8 +560,37 @@ struct CallContext { /// was lowered regardless of the interface, and it holds whether or not it /// may be absent at runtime and the dummy is optional. struct PreparedActualArgument { + + PreparedActualArgument(hlfir::Entity actual, + std::optional isPresent) + : actual{actual}, isPresent{isPresent} {} + void setElementalIndices(mlir::ValueRange &indices) { + oneBasedElementalIndices = &indices; + } + hlfir::Entity getActual(mlir::Location loc, + fir::FirOpBuilder &builder) const { + if (oneBasedElementalIndices) + return hlfir::getElementAt(loc, builder, actual, + *oneBasedElementalIndices); + return actual; + } + hlfir::Entity getOriginalActual() const { return actual; } + void setOriginalActual(hlfir::Entity newActual) { actual = newActual; } + bool handleDynamicOptional() const { return isPresent.has_value(); } + mlir::Value getIsPresent() const { + assert(handleDynamicOptional() && "not a dynamic optional"); + return *isPresent; + } + + void resetOptionalAspect() { isPresent = std::nullopt; } + +private: hlfir::Entity actual; - bool handleDynamicOptional; + mlir::ValueRange *oneBasedElementalIndices{nullptr}; + // When the actual may be dynamically optional, "isPresent" + // holds a boolean value indicating the presence of the + // actual argument at runtime. + std::optional isPresent; }; } // namespace @@ -581,6 +610,335 @@ extendedValueToHlfirEntity(mlir::Location loc, fir::FirOpBuilder &builder, return hlfir::genDeclare(loc, builder, exv, name, fir::FortranVariableFlagsAttr{}); } +namespace { +/// Structure to hold the clean-up related to a dummy argument preparation +/// that may have to be done after a call (copy-out or temporary deallocation). +struct CallCleanUp { + struct CopyIn { + void genCleanUp(mlir::Location loc, fir::FirOpBuilder &builder) { + builder.create(loc, copiedIn, wasCopied, copyBackVar); + } + mlir::Value copiedIn; + mlir::Value wasCopied; + // copyBackVar may be null if copy back is not needed. + mlir::Value copyBackVar; + }; + struct ExprAssociate { + void genCleanUp(mlir::Location loc, fir::FirOpBuilder &builder) { + builder.create(loc, tempVar, mustFree); + } + mlir::Value tempVar; + mlir::Value mustFree; + }; + void genCleanUp(mlir::Location loc, fir::FirOpBuilder &builder) { + std::visit([&](auto &c) { c.genCleanUp(loc, builder); }, cleanUp); + } + std::variant cleanUp; +}; + +/// Structure representing a prepared dummy argument. +/// It holds the value to be passed in the call and any related +/// clean-ups to be done after the call. +struct PreparedDummyArgument { + void setCopyInCleanUp(mlir::Value copiedIn, mlir::Value wasCopied, + mlir::Value copyBackVar) { + assert(!maybeCleanUp.has_value() && "clean-up already set"); + maybeCleanUp = + CallCleanUp{CallCleanUp::CopyIn{copiedIn, wasCopied, copyBackVar}}; + } + void setExprAssociateCleanUp(mlir::Value tempVar, mlir::Value wasCopied) { + assert(!maybeCleanUp.has_value() && "clean-up already set"); + maybeCleanUp = CallCleanUp{CallCleanUp::ExprAssociate{tempVar, wasCopied}}; + } + + mlir::Value dummy; + std::optional maybeCleanUp; +}; + +/// Structure to help conditionally preparing a dummy argument based +/// on the actual argument presence. +/// It helps "wrapping" the dummy and the clean-up information in +/// an if (present) {...}: +/// +/// %conditionallyPrepared = fir.if (%present) { +/// fir.result %preparedDummy +/// } else { +/// fir.result %absent +/// } +/// +struct ConditionallyPreparedDummy { + /// Create ConditionallyPreparedDummy from a preparedDummy that must + /// be wrapped in a fir.if. + ConditionallyPreparedDummy(PreparedDummyArgument &preparedDummy) { + thenResultValues.push_back(preparedDummy.dummy); + if (preparedDummy.maybeCleanUp) { + if (const auto *copyInCleanUp = std::get_if( + &preparedDummy.maybeCleanUp->cleanUp)) { + thenResultValues.push_back(copyInCleanUp->copiedIn); + thenResultValues.push_back(copyInCleanUp->wasCopied); + if (copyInCleanUp->copyBackVar) + thenResultValues.push_back(copyInCleanUp->copyBackVar); + } else { + const auto &exprAssociate = std::get( + preparedDummy.maybeCleanUp->cleanUp); + thenResultValues.push_back(exprAssociate.tempVar); + thenResultValues.push_back(exprAssociate.mustFree); + } + } + } + + /// Get the result types of the wrapping fir.if that must be created. + llvm::SmallVector getIfResulTypes() const { + llvm::SmallVector types; + for (mlir::Value res : thenResultValues) + types.push_back(res.getType()); + return types; + } + + /// Generate the "fir.result %preparedDummy" in the then branch of the + /// wrapping fir.if. + void genThenResult(mlir::Location loc, fir::FirOpBuilder &builder) const { + builder.create(loc, thenResultValues); + } + + /// Generate the "fir.result %absent" in the else branch of the + /// wrapping fir.if. + void genElseResult(mlir::Location loc, fir::FirOpBuilder &builder) const { + llvm::SmallVector elseResultValues; + mlir::Type i1Type = builder.getI1Type(); + for (mlir::Value res : thenResultValues) { + mlir::Type type = res.getType(); + if (type == i1Type) + elseResultValues.push_back(builder.createBool(loc, false)); + else + elseResultValues.push_back(builder.create(loc, type)); + } + builder.create(loc, elseResultValues); + } + + /// Once the fir.if has been created, get the resulting %conditionallyPrepared + /// dummy argument. + PreparedDummyArgument + getPreparedDummy(fir::IfOp ifOp, + const PreparedDummyArgument &unconditionalDummy) { + PreparedDummyArgument preparedDummy; + preparedDummy.dummy = ifOp.getResults()[0]; + if (unconditionalDummy.maybeCleanUp) { + if (const auto *copyInCleanUp = std::get_if( + &unconditionalDummy.maybeCleanUp->cleanUp)) { + mlir::Value copyBackVar; + if (copyInCleanUp->copyBackVar) + copyBackVar = ifOp.getResults().back(); + preparedDummy.setCopyInCleanUp(ifOp.getResults()[1], + ifOp.getResults()[2], copyBackVar); + } else { + preparedDummy.setExprAssociateCleanUp(ifOp.getResults()[1], + ifOp.getResults()[2]); + } + } + return preparedDummy; + } + + llvm::SmallVector thenResultValues; +}; +} // namespace + +/// When dummy is not ALLOCATABLE, POINTER and is not passed in register, +/// prepare the actual argument according to the interface. Do as needed: +/// - address element if this is an array argument in an elemental call. +/// - set dynamic type to the dummy type if the dummy is not polymorphic. +/// - copy-in into contiguous variable if the dummy must be contiguous +/// - copy into a temporary if the dummy has the VALUE attribute. +/// - package the prepared dummy as required (fir.box, fir.class, +/// fir.box_char...). +/// This function should only be called with an actual that is present. +/// The optional aspects must be handled by this function user. +static PreparedDummyArgument preparePresentUserCallActualArgument( + mlir::Location loc, fir::FirOpBuilder &builder, + const PreparedActualArgument &preparedActual, mlir::Type dummyType, + const Fortran::lower::CallerInterface::PassedEntity &arg, + const Fortran::lower::SomeExpr &expr, + Fortran::evaluate::FoldingContext &foldingContext) { + + // Step 1: get the actual argument, which includes addressing the + // element if this is an array in an elemental call. + hlfir::Entity actual = preparedActual.getActual(loc, builder); + + const bool passingPolymorphicToNonPolymorphic = + actual.isPolymorphic() && !fir::isPolymorphicType(dummyType); + + // When passing a CLASS(T) to TYPE(T), only the "T" part must be + // passed. Unless the entity is a scalar passed by raw address, a + // new descriptor must be made using the dummy argument type as + // dynamic type. This must be done before any copy/copy-in because the + // dynamic type matters to determine the contiguity. + const bool mustSetDynamicTypeToDummyType = + passingPolymorphicToNonPolymorphic && + (actual.isArray() || dummyType.isa()); + + // The simple contiguity of the actual is "lost" when passing a polymorphic + // to a non polymorphic entity because the dummy dynamic type matters for + // the contiguity. + const bool mustDoCopyInOut = + actual.isArray() && arg.mustBeMadeContiguous() && + (passingPolymorphicToNonPolymorphic || + !Fortran::evaluate::IsSimplyContiguous(expr, foldingContext)); + + // Step 2: prepare the storage for the dummy arguments, ensuring that it + // matches the dummy requirements (e.g., must be contiguous or must be + // a temporary). + PreparedDummyArgument preparedDummy; + hlfir::Entity entity = + hlfir::derefPointersAndAllocatables(loc, builder, actual); + if (entity.isVariable()) { + if (mustSetDynamicTypeToDummyType) { + // Note: this is important to do this before any copy-in or copy so + // that the dummy is contiguous according to the dummy type. + mlir::Type boxType = + fir::BoxType::get(hlfir::getFortranElementOrSequenceType(dummyType)); + entity = hlfir::Entity{builder.create( + loc, boxType, entity, /*shape=*/mlir::Value{}, + /*slice=*/mlir::Value{})}; + } + if (arg.hasValueAttribute()) { + // Make a copy in a temporary. + auto copy = builder.create(loc, entity); + hlfir::AssociateOp associate = hlfir::genAssociateExpr( + loc, builder, hlfir::Entity{copy}, dummyType, "adapt.valuebyref"); + entity = hlfir::Entity{associate.getBase()}; + // Register the temporary destruction after the call. + preparedDummy.setExprAssociateCleanUp( + associate.getFirBase(), associate.getMustFreeStrorageFlag()); + } else if (mustDoCopyInOut) { + // Copy-in non contiguous variables. + assert(entity.getType().isa() && + "expect non simply contiguous variables to be boxes"); + auto copyIn = builder.create( + loc, entity, /*var_is_present=*/mlir::Value{}); + entity = hlfir::Entity{copyIn.getCopiedIn()}; + // Register the copy-out after the call. + preparedDummy.setCopyInCleanUp( + copyIn.getCopiedIn(), copyIn.getWasCopied(), + arg.mayBeModifiedByCall() ? copyIn.getVar() : mlir::Value{}); + } + } else { + // The actual is an expression value, place it into a temporary + // and register the temporary destruction after the call. + if (mustSetDynamicTypeToDummyType) + TODO(loc, "passing polymorphic array expression to non polymorphic " + "contiguous dummy"); + hlfir::AssociateOp associate = hlfir::genAssociateExpr( + loc, builder, entity, dummyType, "adapt.valuebyref"); + entity = hlfir::Entity{associate.getBase()}; + preparedDummy.setExprAssociateCleanUp(associate.getFirBase(), + associate.getMustFreeStrorageFlag()); + } + + // Step 3: now that the dummy argument storage has been prepared, package + // it according to the interface. + mlir::Value addr; + if (dummyType.isa()) { + addr = hlfir::genVariableBoxChar(loc, builder, entity); + } else if (dummyType.isa()) { + entity = hlfir::genVariableBox(loc, builder, entity); + // Ensures the box has the right attributes and that it holds an + // addendum if needed. + mlir::Type boxEleType = + entity.getType().cast().getEleTy(); + // For now, assume it is not OK to pass the allocatable/pointer + // descriptor to a non pointer/allocatable dummy. That is a strict + // interpretation of 18.3.6 point 4 that stipulates the descriptor + // has the dummy attributes in BIND(C) contexts. + const bool actualBoxHasAllocatableOrPointerFlag = + fir::isa_ref_type(boxEleType); + // On the callee side, the current code generated for unlimited + // polymorphic might unconditionally read the addendum. Intrinsic type + // descriptors may not have an addendum, the rebox below will create a + // descriptor with an addendum in such case. + const bool actualBoxHasAddendum = + fir::unwrapRefType(boxEleType).isa(); + const bool needToAddAddendum = + fir::isUnlimitedPolymorphicType(dummyType) && !actualBoxHasAddendum; + if (needToAddAddendum || actualBoxHasAllocatableOrPointerFlag) + entity = hlfir::Entity{builder.create( + loc, dummyType, entity, /*shape=*/mlir::Value{}, + /*slice=*/mlir::Value{})}; + addr = entity; + } else { + addr = hlfir::genVariableRawAddress(loc, builder, entity); + } + preparedDummy.dummy = builder.createConvert(loc, dummyType, addr); + return preparedDummy; +} + +/// When dummy is not ALLOCATABLE, POINTER and is not passed in register, +/// prepare the actual argument according to the interface, taking care +/// of any optional aspect. +static PreparedDummyArgument prepareUserCallActualArgument( + mlir::Location loc, fir::FirOpBuilder &builder, + const PreparedActualArgument &preparedActual, mlir::Type dummyType, + const Fortran::lower::CallerInterface::PassedEntity &arg, + const Fortran::lower::SomeExpr &expr, + Fortran::evaluate::FoldingContext &foldingContext) { + if (!preparedActual.handleDynamicOptional()) + return preparePresentUserCallActualArgument( + loc, builder, preparedActual, dummyType, arg, expr, foldingContext); + + // Conditional dummy argument preparation. The actual may be absent + // at runtime, causing any addressing, copy, and packaging to have + // undefined behavior. + // To simplify the handling of this case, the "normal" dummy preparation + // helper is used, except its generated code is wrapped inside a + // fir.if(present). + mlir::Value isPresent = preparedActual.getIsPresent(); + mlir::OpBuilder::InsertPoint insertPt = builder.saveInsertionPoint(); + + // Code generated in a preparation block that will become the + // "then" block in "if (present) then {} else {}". The reason + // for this unusual if/then/else generation is that the number + // and types of the if results will depend on how the argument + // is prepared, and forecasting that here would be brittle. + auto badIfOp = builder.create(loc, dummyType, isPresent, + /*withElseRegion=*/false); + mlir::Block *preparationBlock = &badIfOp.getThenRegion().front(); + builder.setInsertionPointToStart(preparationBlock); + PreparedDummyArgument unconditionalDummy = + preparePresentUserCallActualArgument( + loc, builder, preparedActual, dummyType, arg, expr, foldingContext); + builder.restoreInsertionPoint(insertPt); + + // TODO: when forwarding an optional to an optional of the same kind + // (i.e, unconditionalDummy.dummy was not created in preparationBlock), + // the if/then/else generation could be skipped to improve the generated + // code. + + // Now that the result types of the ifOp can be deduced, generate + // the "real" ifOp (operation result types cannot be changed, so + // badIfOp cannot be modified and used here). + llvm::SmallVector ifOpResultTypes; + ConditionallyPreparedDummy conditionalDummy(unconditionalDummy); + auto ifOp = builder.create(loc, conditionalDummy.getIfResulTypes(), + isPresent, + /*withElseRegion=*/true); + // Move "preparationBlock" into the "then" of the new + // fir.if operation and create fir.result propagating + // unconditionalDummy. + preparationBlock->moveBefore(&ifOp.getThenRegion().back()); + ifOp.getThenRegion().back().erase(); + builder.setInsertionPointToEnd(&ifOp.getThenRegion().front()); + conditionalDummy.genThenResult(loc, builder); + + // Generate "else" branch with returning absent values. + builder.setInsertionPointToStart(&ifOp.getElseRegion().front()); + conditionalDummy.genElseResult(loc, builder); + + // Build dummy from IfOpResults. + builder.setInsertionPointAfter(ifOp); + PreparedDummyArgument result = + conditionalDummy.getPreparedDummy(ifOp, unconditionalDummy); + badIfOp->erase(); + return result; +} /// Lower calls to user procedures with actual arguments that have been /// pre-lowered but not yet prepared according to the interface. @@ -595,7 +953,7 @@ genUserCall(PreparedActualArguments &loweredActuals, using PassBy = Fortran::lower::CallerInterface::PassEntityBy; mlir::Location loc = callContext.loc; fir::FirOpBuilder &builder = callContext.getBuilder(); - llvm::SmallVector exprAssociations; + llvm::SmallVector callCleanUps; for (auto [preparedActual, arg] : llvm::zip(loweredActuals, caller.getPassedArguments())) { mlir::Type argTy = callSiteType.getInput(arg.firArgument); @@ -604,53 +962,31 @@ genUserCall(PreparedActualArguments &loweredActuals, caller.placeInput(arg, builder.create(loc, argTy)); continue; } - hlfir::Entity actual = preparedActual->actual; const auto *expr = arg.entity->UnwrapExpr(); if (!expr) TODO(loc, "assumed type actual argument"); - if (preparedActual->handleDynamicOptional) - TODO(loc, "passing optional arguments in HLFIR"); - - const bool isSimplyContiguous = - actual.isScalar() || - Fortran::evaluate::IsSimplyContiguous( - *expr, callContext.converter.getFoldingContext()); - switch (arg.passBy) { case PassBy::Value: { // True pass-by-value semantics. + assert(!preparedActual->handleDynamicOptional() && "cannot be optional"); + hlfir::Entity actual = preparedActual->getActual(loc, builder); auto value = hlfir::loadTrivialScalar(loc, builder, actual); if (!value.isValue()) TODO(loc, "Passing CPTR an CFUNCTPTR VALUE in HLFIR"); caller.placeInput(arg, builder.createConvert(loc, argTy, value)); } break; - case PassBy::BaseAddressValueAttribute: { - // VALUE attribute or pass-by-reference to a copy semantics. (byval*) - TODO(loc, "HLFIR PassBy::BaseAddressValueAttribute"); - } break; + case PassBy::BaseAddressValueAttribute: + case PassBy::CharBoxValueAttribute: + case PassBy::Box: case PassBy::BaseAddress: case PassBy::BoxChar: { - hlfir::Entity entity = actual; - if (entity.isVariable()) { - entity = hlfir::derefPointersAndAllocatables(loc, builder, entity); - // Copy-in non contiguous variable - if (!isSimplyContiguous) - TODO(loc, "HLFIR copy-in/copy-out"); - } else { - hlfir::AssociateOp associate = hlfir::genAssociateExpr( - loc, builder, entity, argTy, "adapt.valuebyref"); - exprAssociations.push_back(associate); - entity = hlfir::Entity{associate.getBase()}; - } - mlir::Value addr = - arg.passBy == PassBy::BaseAddress - ? hlfir::genVariableRawAddress(loc, builder, entity) - : hlfir::genVariableBoxChar(loc, builder, entity); - caller.placeInput(arg, builder.createConvert(loc, argTy, addr)); - } break; - case PassBy::CharBoxValueAttribute: { - TODO(loc, "HLFIR PassBy::CharBoxValueAttribute"); + PreparedDummyArgument preparedDummy = prepareUserCallActualArgument( + loc, builder, *preparedActual, argTy, arg, *expr, + callContext.converter.getFoldingContext()); + if (preparedDummy.maybeCleanUp.has_value()) + callCleanUps.emplace_back(std::move(*preparedDummy.maybeCleanUp)); + caller.placeInput(arg, preparedDummy.dummy); } break; case PassBy::AddressAndLength: // PassBy::AddressAndLength is only used for character results. Results @@ -661,10 +997,8 @@ genUserCall(PreparedActualArguments &loweredActuals, case PassBy::CharProcTuple: { TODO(loc, "HLFIR PassBy::CharProcTuple"); } break; - case PassBy::Box: { - TODO(loc, "HLFIR PassBy::Box"); - } break; case PassBy::MutableBox: { + hlfir::Entity actual = preparedActual->getActual(loc, builder); if (Fortran::evaluate::UnwrapExpr( *expr)) { // If expr is NULL(), the mutableBox created must be a deallocated @@ -711,8 +1045,9 @@ genUserCall(PreparedActualArguments &loweredActuals, caller, callSiteType, callContext.resultType); /// Clean-up associations and copy-in. - for (auto associate : exprAssociations) - builder.create(loc, associate); + for (auto cleanUp : callCleanUps) + cleanUp.genCleanUp(loc, builder); + if (!fir::getBase(result)) return std::nullopt; // subroutine call. // TODO: "move" non pointer results into hlfir.expr. @@ -729,15 +1064,16 @@ static hlfir::EntityWithAttributes genIntrinsicRefCore( llvm::SmallVector operands; auto &stmtCtx = callContext.stmtCtx; auto &converter = callContext.converter; + fir::FirOpBuilder &builder = callContext.getBuilder(); mlir::Location loc = callContext.loc; for (auto arg : llvm::enumerate(loweredActuals)) { if (!arg.value()) { operands.emplace_back(Fortran::lower::getAbsentIntrinsicArgument()); continue; } - hlfir::Entity actual = arg.value()->actual; - if (arg.value()->handleDynamicOptional) + if (arg.value()->handleDynamicOptional()) TODO(loc, "intrinsic dynamically optional arguments"); + hlfir::Entity actual = arg.value()->getActual(loc, builder); if (!argLowering) { // No argument lowering instruction, lower by value. operands.emplace_back( @@ -766,7 +1102,6 @@ static hlfir::EntityWithAttributes genIntrinsicRefCore( } llvm_unreachable("bad switch"); } - fir::FirOpBuilder &builder = callContext.getBuilder(); // genIntrinsicCall needs the scalar type, even if this is a transformational // procedure returning an array. std::optional scalarResultType; @@ -808,33 +1143,48 @@ class ElementalCallBuilder { unsigned numArgs = loweredActuals.size(); // Step 1: dereference pointers/allocatables and compute elemental shape. mlir::Value shape; + PreparedActualArgument *optionalWithShape; // 10.1.4 p5. Impure elemental procedures must be called in element order. bool mustBeOrdered = isImpure; for (unsigned i = 0; i < numArgs; ++i) { auto &preparedActual = loweredActuals[i]; if (preparedActual) { - hlfir::Entity &actual = preparedActual->actual; + hlfir::Entity actual = preparedActual->getOriginalActual(); // Elemental procedure dummy arguments cannot be pointer/allocatables // (C15100), so it is safe to dereference any pointer or allocatable // actual argument now instead of doing this inside the elemental // region. actual = hlfir::derefPointersAndAllocatables(loc, builder, actual); // Better to load scalars outside of the loop when possible. - if (!preparedActual->handleDynamicOptional && + if (!preparedActual->handleDynamicOptional() && impl().canLoadActualArgumentBeforeLoop(i)) actual = hlfir::loadTrivialScalar(loc, builder, actual); // TODO: merge shape instead of using the first one. if (!shape && actual.isArray()) { - if (preparedActual->handleDynamicOptional) - TODO(loc, "deal with optional with shapes in HLFIR elemental call"); - shape = hlfir::genShape(loc, builder, actual); + if (preparedActual->handleDynamicOptional()) + optionalWithShape = &*preparedActual; + else + shape = hlfir::genShape(loc, builder, actual); } // 15.8.3 p1. Elemental procedure with intent(out)/intent(inout) // arguments must be called in element order. if (impl().argMayBeModifiedByCall(i)) mustBeOrdered = true; + // Propagates pointer dereferences and scalar loads. + preparedActual->setOriginalActual(actual); } } + if (!shape && optionalWithShape) { + // If all array operands appear in optional positions, then none of them + // is allowed to be absent as per 15.5.2.12 point 3. (6). Just pick the + // first operand. + shape = + hlfir::genShape(loc, builder, optionalWithShape->getOriginalActual()); + // TODO: There is an opportunity to add a runtime check here that + // this array is present as required. Also, the optionality of all actual + // could be checked and reset given the Fortran requirement. + optionalWithShape->resetOptionalAspect(); + } assert(shape && "elemental array calls must have at least one array arguments"); if (mustBeOrdered) @@ -843,15 +1193,15 @@ class ElementalCallBuilder { // iterations are cleaned up inside the iterations. if (!callContext.resultType) { // Subroutine case. Generate call inside loop nest. - auto [innerLoop, oneBasedIndices] = + auto [innerLoop, oneBasedIndicesVector] = hlfir::genLoopNest(loc, builder, shape); + mlir::ValueRange oneBasedIndices = oneBasedIndicesVector; auto insPt = builder.saveInsertionPoint(); builder.setInsertionPointToStart(innerLoop.getBody()); callContext.stmtCtx.pushScope(); for (auto &preparedActual : loweredActuals) if (preparedActual) - preparedActual->actual = hlfir::getElementAt( - loc, builder, preparedActual->actual, oneBasedIndices); + preparedActual->setElementalIndices(oneBasedIndices); impl().genElementalKernel(loweredActuals, callContext); callContext.stmtCtx.finalizeAndPop(); builder.restoreInsertionPoint(insPt); @@ -881,8 +1231,7 @@ class ElementalCallBuilder { callContext.stmtCtx.pushScope(); for (auto &preparedActual : loweredActuals) if (preparedActual) - preparedActual->actual = hlfir::getElementAt( - l, b, preparedActual->actual, oneBasedIndices); + preparedActual->setElementalIndices(oneBasedIndices); auto res = *impl().genElementalKernel(loweredActuals, callContext); callContext.stmtCtx.finalizeAndPop(); // Note that an hlfir.destroy is not emitted for the result since it @@ -972,8 +1321,9 @@ class ElementalIntrinsicCallBuilder CallContext &callContext) { if (intrinsic.name == "adjustr" || intrinsic.name == "adjustl" || intrinsic.name == "merge") - return hlfir::genCharLength(callContext.loc, callContext.getBuilder(), - loweredActuals[0].value().actual); + return hlfir::genCharLength( + callContext.loc, callContext.getBuilder(), + loweredActuals[0].value().getOriginalActual()); // Character MIN/MAX is the min/max of the arguments length that are // present. TODO(callContext.loc, @@ -987,6 +1337,38 @@ class ElementalIntrinsicCallBuilder }; } // namespace +static std::optional +genIsPresentIfArgMaybeAbsent(mlir::Location loc, hlfir::Entity actual, + const Fortran::lower::SomeExpr &expr, + CallContext &callContext, + bool passAsAllocatableOrPointer) { + if (!Fortran::evaluate::MayBePassedAsAbsentOptional( + expr, callContext.converter.getFoldingContext())) + return std::nullopt; + fir::FirOpBuilder &builder = callContext.getBuilder(); + if (!passAsAllocatableOrPointer && + Fortran::evaluate::IsAllocatableOrPointerObject( + expr, callContext.converter.getFoldingContext())) { + // Passing Allocatable/Pointer to non-pointer/non-allocatable OPTIONAL. + // Fortran 2018 15.5.2.12 point 1: If unallocated/disassociated, it is + // as if the argument was absent. The main care here is to not do a + // copy-in/copy-out because the temp address, even though pointing to a + // null size storage, would not be a nullptr and therefore the argument + // would not be considered absent on the callee side. Note: if the + // allocatable/pointer is also optional, it cannot be absent as per + // 15.5.2.12 point 7. and 8. We rely on this to un-conditionally read + // the allocatable/pointer descriptor here. + mlir::Value addr = genVariableRawAddress(loc, builder, actual); + return builder.genIsNotNullAddr(loc, addr); + } + // TODO: what if passing allocatable target to optional intent(in) pointer? + // May fall into the category above if the allocatable is not optional. + + // Passing an optional to an optional. + return builder.create(loc, builder.getI1Type(), actual) + .getResult(); +} + /// Lower an intrinsic procedure reference. static hlfir::EntityWithAttributes genIntrinsicRef(const Fortran::evaluate::SpecificIntrinsic &intrinsic, @@ -1011,16 +1393,16 @@ genIntrinsicRef(const Fortran::evaluate::SpecificIntrinsic &intrinsic, auto loweredActual = Fortran::lower::convertExprToHLFIR( loc, callContext.converter, *expr, callContext.symMap, callContext.stmtCtx); - bool handleDynamicOptional = false; + std::optional isPresent; if (argLowering) { Fortran::lower::ArgLoweringRule argRules = Fortran::lower::lowerIntrinsicArgumentAs(*argLowering, arg.index()); - handleDynamicOptional = argRules.handleDynamicOptional && - Fortran::evaluate::MayBePassedAsAbsentOptional( - *expr, converter.getFoldingContext()); + if (argRules.handleDynamicOptional) + isPresent = + genIsPresentIfArgMaybeAbsent(loc, loweredActual, *expr, callContext, + /*passAsAllocatableOrPointer=*/false); } - loweredActuals.push_back( - PreparedActualArgument{loweredActual, handleDynamicOptional}); + loweredActuals.push_back(PreparedActualArgument{loweredActual, isPresent}); } if (callContext.isElementalProcWithArrayArgs()) { @@ -1064,16 +1446,33 @@ genProcedureRef(CallContext &callContext) { const auto *expr = actual->UnwrapExpr(); if (!expr) TODO(loc, "assumed type actual argument"); + if (Fortran::evaluate::UnwrapExpr( + *expr)) { + if (arg.passBy != + Fortran::lower::CallerInterface::PassEntityBy::MutableBox) { + assert( + arg.isOptional() && + "NULL must be passed only to pointer, allocatable, or OPTIONAL"); + // Trying to lower NULL() outside of any context would lead to + // trouble. NULL() here is equivalent to not providing the + // actual argument. + loweredActuals.emplace_back(std::nullopt); + continue; + } + } - const bool handleDynamicOptional = - arg.isOptional() && - Fortran::evaluate::MayBePassedAsAbsentOptional( - *expr, callContext.converter.getFoldingContext()); auto loweredActual = Fortran::lower::convertExprToHLFIR( loc, callContext.converter, *expr, callContext.symMap, callContext.stmtCtx); + std::optional isPresent; + if (arg.isOptional()) + isPresent = genIsPresentIfArgMaybeAbsent( + loc, loweredActual, *expr, callContext, + arg.passBy == + Fortran::lower::CallerInterface::PassEntityBy::MutableBox); + loweredActuals.emplace_back( - PreparedActualArgument{loweredActual, handleDynamicOptional}); + PreparedActualArgument{loweredActual, isPresent}); } else { // Optional dummy argument for which there is no actual argument. loweredActuals.emplace_back(std::nullopt); diff --git a/flang/lib/Lower/ConvertExprToHLFIR.cpp b/flang/lib/Lower/ConvertExprToHLFIR.cpp index 062d827e59ad1..971d40ef4bc13 100644 --- a/flang/lib/Lower/ConvertExprToHLFIR.cpp +++ b/flang/lib/Lower/ConvertExprToHLFIR.cpp @@ -521,6 +521,8 @@ class HlfirDesignatorBuilder { // Lower the information about the component (type, length parameters and // shape). const Fortran::semantics::Symbol &componentSym = component.GetLastSymbol(); + if (componentSym.test(Fortran::semantics::Symbol::Flag::ParentComp)) + TODO(getLoc(), "Parent component reference in HLFIR"); partInfo.componentName = componentSym.name().ToString(); auto recordType = hlfir::getFortranElementType(baseType).cast(); diff --git a/flang/lib/Optimizer/Builder/HLFIRTools.cpp b/flang/lib/Optimizer/Builder/HLFIRTools.cpp index 146a063ccb10d..0e49445eabcd0 100644 --- a/flang/lib/Optimizer/Builder/HLFIRTools.cpp +++ b/flang/lib/Optimizer/Builder/HLFIRTools.cpp @@ -272,6 +272,29 @@ mlir::Value hlfir::genVariableBoxChar(mlir::Location loc, lengths[0]); } +hlfir::Entity hlfir::genVariableBox(mlir::Location loc, + fir::FirOpBuilder &builder, + hlfir::Entity var) { + assert(var.isVariable() && "must be a variable"); + var = hlfir::derefPointersAndAllocatables(loc, builder, var); + if (var.getType().isa()) + return var; + // Note: if the var is not a fir.box/fir.class at that point, it has default + // lower bounds and is not polymorphic. + mlir::Value shape = + var.isArray() ? hlfir::genShape(loc, builder, var) : mlir::Value{}; + llvm::SmallVector typeParams; + auto maybeCharType = + var.getFortranElementType().dyn_cast(); + if (!maybeCharType || maybeCharType.hasDynamicLen()) + hlfir::genLengthParameters(loc, builder, var, typeParams); + mlir::Type boxType = fir::BoxType::get(var.getElementOrSequenceType()); + auto embox = + builder.create(loc, boxType, var, shape, + /*slice=*/mlir::Value{}, typeParams); + return hlfir::Entity{embox.getResult()}; +} + hlfir::Entity hlfir::loadTrivialScalar(mlir::Location loc, fir::FirOpBuilder &builder, Entity entity) { diff --git a/flang/lib/Optimizer/Dialect/FIROps.cpp b/flang/lib/Optimizer/Dialect/FIROps.cpp index 590a873bb78f8..2af04f869e4b9 100644 --- a/flang/lib/Optimizer/Dialect/FIROps.cpp +++ b/flang/lib/Optimizer/Dialect/FIROps.cpp @@ -604,7 +604,7 @@ void fir::BoxAddrOp::build(mlir::OpBuilder &builder, mlir::OperationState &result, mlir::Value val) { mlir::Type type = llvm::TypeSwitch(val.getType()) - .Case([&](fir::BoxType ty) -> mlir::Type { + .Case([&](fir::BaseBoxType ty) -> mlir::Type { mlir::Type eleTy = ty.getEleTy(); if (fir::isa_ref_type(eleTy)) return eleTy; diff --git a/flang/lib/Optimizer/HLFIR/IR/HLFIROps.cpp b/flang/lib/Optimizer/HLFIR/IR/HLFIROps.cpp index 56cb542bcdcf4..9bf5601ce6523 100644 --- a/flang/lib/Optimizer/HLFIR/IR/HLFIROps.cpp +++ b/flang/lib/Optimizer/HLFIR/IR/HLFIROps.cpp @@ -522,7 +522,8 @@ void hlfir::NullOp::build(mlir::OpBuilder &builder, void hlfir::CopyInOp::build(mlir::OpBuilder &builder, mlir::OperationState &odsState, mlir::Value var, mlir::Value var_is_present) { - return build(builder, odsState, var.getType(), var, var_is_present); + return build(builder, odsState, {var.getType(), builder.getI1Type()}, var, + var_is_present); } #define GET_OP_CLASSES diff --git a/flang/test/Lower/HLFIR/calls-assumed-shape.f90 b/flang/test/Lower/HLFIR/calls-assumed-shape.f90 new file mode 100644 index 0000000000000..9f395c34dee47 --- /dev/null +++ b/flang/test/Lower/HLFIR/calls-assumed-shape.f90 @@ -0,0 +1,116 @@ +! Test lowering of calls involving assumed shape arrays or arrays with +! VALUE attribute. +! RUN: bbc -emit-fir -hlfir -polymorphic-type -o - %s | FileCheck %s + +subroutine test_assumed_to_assumed(x) + interface + subroutine takes_assumed(x) + real :: x(:) + end subroutine + end interface + real :: x(:) + call takes_assumed(x) +end subroutine +! CHECK-LABEL: func.func @_QPtest_assumed_to_assumed( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {uniq_name = "_QFtest_assumed_to_assumedEx"} : (!fir.box>) -> (!fir.box>, !fir.box>) +! CHECK: fir.call @_QPtakes_assumed(%[[VAL_1]]#0) {{.*}} : (!fir.box>) -> () + +subroutine test_ptr_to_assumed(p) + interface + subroutine takes_assumed(x) + real :: x(:) + end subroutine + end interface + real, pointer :: p(:) + call takes_assumed(p) +end subroutine +! CHECK-LABEL: func.func @_QPtest_ptr_to_assumed( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_ptr_to_assumedEp"} : (!fir.ref>>>) -> (!fir.ref>>>, !fir.ref>>>) +! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref>>> +! CHECK: %[[VAL_3:.*]] = fir.rebox %[[VAL_2]] : (!fir.box>>) -> !fir.box> +! CHECK: fir.call @_QPtakes_assumed(%[[VAL_3]]) {{.*}} : (!fir.box>) -> () + +subroutine test_ptr_to_contiguous_assumed(p) + interface + subroutine takes_contiguous_assumed(x) + real, contiguous :: x(:) + end subroutine + end interface + real, pointer :: p(:) + call takes_contiguous_assumed(p) +end subroutine +! CHECK-LABEL: func.func @_QPtest_ptr_to_contiguous_assumed( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_ptr_to_contiguous_assumedEp"} : (!fir.ref>>>) -> (!fir.ref>>>, !fir.ref>>>) +! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref>>> +! CHECK: %[[VAL_3:.*]]:2 = hlfir.copy_in %[[VAL_2]] : (!fir.box>>) -> (!fir.box>>, i1) +! CHECK: %[[VAL_4:.*]] = fir.rebox %[[VAL_3]]#0 : (!fir.box>>) -> !fir.box> +! CHECK: fir.call @_QPtakes_contiguous_assumed(%[[VAL_4]]) {{.*}} : (!fir.box>) -> () +! CHECK: hlfir.copy_out %[[VAL_3]]#0, %[[VAL_3]]#1 to %[[VAL_2]] : (!fir.box>>, i1, !fir.box>>) -> () + +subroutine test_ptr_to_contiguous_assumed_classstar(p) + interface + subroutine takes_contiguous_assumed_classstar(x) + class(*), contiguous :: x(:) + end subroutine + end interface + real, pointer :: p(:) + call takes_contiguous_assumed_classstar(p) +end subroutine +! CHECK-LABEL: func.func @_QPtest_ptr_to_contiguous_assumed_classstar( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_ptr_to_contiguous_assumed_classstarEp"} : (!fir.ref>>>) -> (!fir.ref>>>, !fir.ref>>>) +! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref>>> +! CHECK: %[[VAL_3:.*]]:2 = hlfir.copy_in %[[VAL_2]] : (!fir.box>>) -> (!fir.box>>, i1) +! CHECK: %[[VAL_4:.*]] = fir.rebox %[[VAL_3]]#0 : (!fir.box>>) -> !fir.class> +! CHECK: fir.call @_QPtakes_contiguous_assumed_classstar(%[[VAL_4]]) {{.*}} : (!fir.class>) -> () +! CHECK: hlfir.copy_out %[[VAL_3]]#0, %[[VAL_3]]#1 to %[[VAL_2]] : (!fir.box>>, i1, !fir.box>>) -> () + +subroutine test_ptr_to_assumed_typestar(p) + interface + subroutine takes_assumed_typestar(x) + type(*) :: x(:) + end subroutine + end interface + real, pointer :: p(:) + call takes_assumed_typestar(p) +end subroutine +! CHECK-LABEL: func.func @_QPtest_ptr_to_assumed_typestar( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_ptr_to_assumed_typestarEp"} : (!fir.ref>>>) -> (!fir.ref>>>, !fir.ref>>>) +! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref>>> +! CHECK: %[[VAL_3:.*]] = fir.rebox %[[VAL_2]] : (!fir.box>>) -> !fir.box> +! CHECK: fir.call @_QPtakes_assumed_typestar(%[[VAL_3]]) {{.*}} : (!fir.box>) -> () + +subroutine test_explicit_char_to_box(e) + interface + subroutine takes_assumed_character(x) + character(*) :: x(:) + end subroutine + end interface + character(10) :: e(20) + call takes_assumed_character(e) +end subroutine +! CHECK-LABEL: func.func @_QPtest_explicit_char_to_box( +! CHECK: %[[VAL_1:.*]]:2 = fir.unboxchar %[[VAL_0]] : (!fir.boxchar<1>) -> (!fir.ref>, index) +! CHECK: %[[VAL_2:.*]] = arith.constant 10 : index +! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_1]]#0 : (!fir.ref>) -> !fir.ref>> +! CHECK: %[[VAL_4:.*]] = arith.constant 20 : index +! CHECK: %[[VAL_5:.*]] = fir.shape %[[VAL_4]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_6:.*]]:2 = hlfir.declare %[[VAL_3]](%[[VAL_5:[a-z0-9]*]]) typeparams %[[VAL_2:[a-z0-9]*]] {uniq_name = "_QFtest_explicit_char_to_boxEe"} : (!fir.ref>>, !fir.shape<1>, index) -> (!fir.ref>>, !fir.ref>>) +! CHECK: %[[VAL_7:.*]] = fir.embox %[[VAL_6]]#0(%[[VAL_5]]) : (!fir.ref>>, !fir.shape<1>) -> !fir.box>> +! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (!fir.box>>) -> !fir.box>> +! CHECK: fir.call @_QPtakes_assumed_character(%[[VAL_8]]) {{.*}} : (!fir.box>>) -> () + +subroutine test_explicit_by_val(x) + interface + subroutine takes_explicit_by_value(x) + real, value :: x(10) + end subroutine + end interface + real :: x(10) + call takes_explicit_by_value(x) +end subroutine +! CHECK-LABEL: func.func @_QPtest_explicit_by_val( +! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]](%[[VAL_2:[a-z0-9]*]]) {uniq_name = "_QFtest_explicit_by_valEx"} : (!fir.ref>, !fir.shape<1>) -> (!fir.ref>, !fir.ref>) +! CHECK: %[[VAL_4:.*]] = hlfir.as_expr %[[VAL_3]]#0 : (!fir.ref>) -> !hlfir.expr<10xf32> +! CHECK: %[[VAL_5:.*]]:3 = hlfir.associate %[[VAL_4]](%[[VAL_2]]) {uniq_name = "adapt.valuebyref"} : (!hlfir.expr<10xf32>, !fir.shape<1>) -> (!fir.ref>, !fir.ref>, i1) +! CHECK: fir.call @_QPtakes_explicit_by_value(%[[VAL_5]]#1) {{.*}} : (!fir.ref>) -> () +! CHECK: hlfir.end_associate %[[VAL_5]]#1, %[[VAL_5]]#2 : !fir.ref>, i1 diff --git a/flang/test/Lower/HLFIR/calls-optional.f90 b/flang/test/Lower/HLFIR/calls-optional.f90 new file mode 100644 index 0000000000000..8990e2c4bff7a --- /dev/null +++ b/flang/test/Lower/HLFIR/calls-optional.f90 @@ -0,0 +1,162 @@ +! Test lowering of user calls involving passing an actual argument +! that is syntactically present, but may be absent at runtime (is +! an optional or a pointer/allocatable). +! +! RUN: bbc -emit-fir -hlfir -polymorphic-type -o - %s | FileCheck %s + +subroutine optional_copy_in_out(x) + interface + subroutine takes_optional_explicit(x) + real, optional :: x(*) + end subroutine + end interface + real, optional :: x(:) + call takes_optional_explicit(x) +end subroutine +! CHECK-LABEL: func.func @_QPoptional_copy_in_out( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFoptional_copy_in_outEx"} : (!fir.box>) -> (!fir.box>, !fir.box>) +! CHECK: %[[VAL_2:.*]] = fir.is_present %[[VAL_1]]#0 : (!fir.box>) -> i1 +! CHECK: %[[VAL_3:.*]]:4 = fir.if %[[VAL_2]] -> (!fir.ref>, !fir.box>, i1, !fir.box>) { +! CHECK: %[[VAL_4:.*]]:2 = hlfir.copy_in %[[VAL_1]]#0 : (!fir.box>) -> (!fir.box>, i1) +! CHECK: %[[VAL_5:.*]] = fir.box_addr %[[VAL_4]]#0 : (!fir.box>) -> !fir.ref> +! CHECK: fir.result %[[VAL_5]], %[[VAL_4]]#0, %[[VAL_4]]#1, %[[VAL_1]]#0 : !fir.ref>, !fir.box>, i1, !fir.box> +! CHECK: } else { +! CHECK: %[[VAL_6:.*]] = fir.absent !fir.ref> +! CHECK: %[[VAL_7:.*]] = fir.absent !fir.box> +! CHECK: %[[VAL_8:.*]] = arith.constant false +! CHECK: %[[VAL_9:.*]] = fir.absent !fir.box> +! CHECK: fir.result %[[VAL_6]], %[[VAL_7]], %[[VAL_8]], %[[VAL_9]] : !fir.ref>, !fir.box>, i1, !fir.box> +! CHECK: } +! CHECK: fir.call @_QPtakes_optional_explicit(%[[VAL_3]]#0) {{.*}} : (!fir.ref>) -> () +! CHECK: hlfir.copy_out %[[VAL_3]]#1, %[[VAL_3]]#2 to %[[VAL_3]]#3 : (!fir.box>, i1, !fir.box>) -> () + +subroutine optional_value_copy(x) + interface + subroutine takes_optional_explicit_value(x) + real, value, optional :: x(100) + end subroutine + end interface + real, optional :: x(100) + call takes_optional_explicit_value(x) +end subroutine +! CHECK-LABEL: func.func @_QPoptional_value_copy( +! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]](%[[VAL_2:[a-z0-9]*]]) {fortran_attrs = #fir.var_attrs, uniq_name = "_QFoptional_value_copyEx"} : (!fir.ref>, !fir.shape<1>) -> (!fir.ref>, !fir.ref>) +! CHECK: %[[VAL_4:.*]] = fir.is_present %[[VAL_3]]#0 : (!fir.ref>) -> i1 +! CHECK: %[[VAL_5:.*]]:3 = fir.if %[[VAL_4]] -> (!fir.ref>, !fir.ref>, i1) { +! CHECK: %[[VAL_6:.*]] = hlfir.as_expr %[[VAL_3]]#0 : (!fir.ref>) -> !hlfir.expr<100xf32> +! CHECK: %[[VAL_7:.*]]:3 = hlfir.associate %[[VAL_6]](%[[VAL_2]]) {uniq_name = "adapt.valuebyref"} : (!hlfir.expr<100xf32>, !fir.shape<1>) -> (!fir.ref>, !fir.ref>, i1) +! CHECK: fir.result %[[VAL_7]]#1, %[[VAL_7]]#1, %[[VAL_7]]#2 : !fir.ref>, !fir.ref>, i1 +! CHECK: } else { +! CHECK: %[[VAL_8:.*]] = fir.absent !fir.ref> +! CHECK: %[[VAL_9:.*]] = fir.absent !fir.ref> +! CHECK: %[[VAL_10:.*]] = arith.constant false +! CHECK: fir.result %[[VAL_8]], %[[VAL_9]], %[[VAL_10]] : !fir.ref>, !fir.ref>, i1 +! CHECK: } +! CHECK: fir.call @_QPtakes_optional_explicit_value(%[[VAL_5]]#0) {{.*}} : (!fir.ref>) -> () +! CHECK: hlfir.end_associate %[[VAL_5]]#1, %[[VAL_5]]#2 : !fir.ref>, i1 + +subroutine elem_pointer_to_optional(x, y) + interface + elemental subroutine elem_takes_two_optional(x, y) + real, optional, intent(in) :: y, x + end subroutine + end interface + real :: x(:) + real, pointer :: y(:) + call elem_takes_two_optional(x, y) +end subroutine +! CHECK-LABEL: func.func @_QPelem_pointer_to_optional( +! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {uniq_name = "_QFelem_pointer_to_optionalEx"} : (!fir.box>) -> (!fir.box>, !fir.box>) +! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_1:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFelem_pointer_to_optionalEy"} : (!fir.ref>>>) -> (!fir.ref>>>, !fir.ref>>>) +! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_3]]#1 : !fir.ref>>> +! CHECK: %[[VAL_5:.*]] = fir.box_addr %[[VAL_4]] : (!fir.box>>) -> !fir.ptr> +! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (!fir.ptr>) -> i64 +! CHECK: %[[VAL_7:.*]] = arith.constant 0 : i64 +! CHECK: %[[VAL_8:.*]] = arith.cmpi ne, %[[VAL_6]], %[[VAL_7]] : i64 +! CHECK: %[[VAL_9:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_10:.*]]:3 = fir.box_dims %[[VAL_2]]#0, %[[VAL_9]] : (!fir.box>, index) -> (index, index, index) +! CHECK: %[[VAL_11:.*]] = fir.load %[[VAL_3]]#0 : !fir.ref>>> +! CHECK: %[[VAL_12:.*]] = arith.constant 1 : index +! CHECK: fir.do_loop %[[VAL_13:.*]] = %[[VAL_12]] to %[[VAL_10]]#1 step %[[VAL_12]] { +! CHECK: %[[VAL_14:.*]] = hlfir.designate %[[VAL_2]]#0 (%[[VAL_13]]) : (!fir.box>, index) -> !fir.ref +! CHECK: %[[VAL_15:.*]] = fir.if %[[VAL_8]] -> (!fir.ref) { +! CHECK: %[[VAL_16:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_17:.*]]:3 = fir.box_dims %[[VAL_11]], %[[VAL_16]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[VAL_18:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_19:.*]] = arith.subi %[[VAL_17]]#0, %[[VAL_18]] : index +! CHECK: %[[VAL_20:.*]] = arith.addi %[[VAL_13]], %[[VAL_19]] : index +! CHECK: %[[VAL_21:.*]] = hlfir.designate %[[VAL_11]] (%[[VAL_20]]) : (!fir.box>>, index) -> !fir.ref +! CHECK: fir.result %[[VAL_21]] : !fir.ref +! CHECK: } else { +! CHECK: %[[VAL_22:.*]] = fir.absent !fir.ref +! CHECK: fir.result %[[VAL_22]] : !fir.ref +! CHECK: } +! CHECK: fir.call @_QPelem_takes_two_optional(%[[VAL_14]], %[[VAL_15]]) {{.*}} : (!fir.ref, !fir.ref) -> () +! CHECK: } + +subroutine optional_cannot_be_absent_optional(x) + interface + elemental subroutine elem_takes_one_optional(x) + real, optional, intent(in) :: x + end subroutine + end interface + real, optional :: x(:) + ! If all array arguments in an call are optional, they must be all present. + call elem_takes_one_optional(x) +end subroutine +! CHECK-LABEL: func.func @_QPoptional_cannot_be_absent_optional( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFoptional_cannot_be_absent_optionalEx"} : (!fir.box>) -> (!fir.box>, !fir.box>) +! CHECK: %[[VAL_2:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_3:.*]]:3 = fir.box_dims %[[VAL_1]]#0, %[[VAL_2]] : (!fir.box>, index) -> (index, index, index) +! CHECK: %[[VAL_4:.*]] = arith.constant 1 : index +! CHECK: fir.do_loop %[[VAL_5:.*]] = %[[VAL_4]] to %[[VAL_3]]#1 step %[[VAL_4]] { +! CHECK: %[[VAL_6:.*]] = hlfir.designate %[[VAL_1]]#0 (%[[VAL_5]]) : (!fir.box>, index) -> !fir.ref +! CHECK: fir.call @_QPelem_takes_one_optional(%[[VAL_6]]) {{.*}} : (!fir.ref) -> () +! CHECK: } + +subroutine optional_elem_poly(x, y) + interface + elemental subroutine elem_optional_poly(x, y) + class(*), optional, intent(in) :: x, y + end subroutine + end interface + real :: x(:) + real, optional :: y(:) + call elem_optional_poly(x, y) +end subroutine +! CHECK-LABEL: func.func @_QPoptional_elem_poly( +! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {uniq_name = "_QFoptional_elem_polyEx"} : (!fir.box>) -> (!fir.box>, !fir.box>) +! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_1:[a-z0-9]*]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFoptional_elem_polyEy"} : (!fir.box>) -> (!fir.box>, !fir.box>) +! CHECK: %[[VAL_4:.*]] = fir.is_present %[[VAL_3]]#0 : (!fir.box>) -> i1 +! CHECK: %[[VAL_5:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_6:.*]]:3 = fir.box_dims %[[VAL_2]]#0, %[[VAL_5]] : (!fir.box>, index) -> (index, index, index) +! CHECK: %[[VAL_7:.*]] = arith.constant 1 : index +! CHECK: fir.do_loop %[[VAL_8:.*]] = %[[VAL_7]] to %[[VAL_6]]#1 step %[[VAL_7]] { +! CHECK: %[[VAL_9:.*]] = hlfir.designate %[[VAL_2]]#0 (%[[VAL_8]]) : (!fir.box>, index) -> !fir.ref +! CHECK: %[[VAL_10:.*]] = fir.embox %[[VAL_9]] : (!fir.ref) -> !fir.box +! CHECK: %[[VAL_11:.*]] = fir.rebox %[[VAL_10]] : (!fir.box) -> !fir.class +! CHECK: %[[VAL_12:.*]] = fir.if %[[VAL_4]] -> (!fir.class) { +! CHECK: %[[VAL_13:.*]] = hlfir.designate %[[VAL_3]]#0 (%[[VAL_8]]) : (!fir.box>, index) -> !fir.ref +! CHECK: %[[VAL_14:.*]] = fir.embox %[[VAL_13]] : (!fir.ref) -> !fir.box +! CHECK: %[[VAL_15:.*]] = fir.rebox %[[VAL_14]] : (!fir.box) -> !fir.class +! CHECK: fir.result %[[VAL_15]] : !fir.class +! CHECK: } else { +! CHECK: %[[VAL_16:.*]] = fir.absent !fir.class +! CHECK: fir.result %[[VAL_16]] : !fir.class +! CHECK: } +! CHECK: fir.call @_QPelem_optional_poly(%[[VAL_11]], %[[VAL_12]]) {{.*}} : (!fir.class, !fir.class) -> () +! CHECK: } + +subroutine test_passing_null() + interface + subroutine takes_optional_assumed(x) + real, optional :: x(:) + end subroutine + end interface + call takes_optional_assumed(null()) + ! NULL(MOLD) lowering is a TODO in HLFIR. + ! call takes_optional_assumed(null(p)) +end subroutine +! CHECK-LABEL: func.func @_QPtest_passing_null() { +! CHECK: %[[VAL_0:.*]] = fir.absent !fir.box> +! CHECK: fir.call @_QPtakes_optional_assumed(%[[VAL_0]]) {{.*}} : (!fir.box>) -> () diff --git a/flang/test/Lower/HLFIR/elemental-intrinsics.f90 b/flang/test/Lower/HLFIR/elemental-intrinsics.f90 index 20c5f5730dc01..d38e4a9d59c05 100644 --- a/flang/test/Lower/HLFIR/elemental-intrinsics.f90 +++ b/flang/test/Lower/HLFIR/elemental-intrinsics.f90 @@ -73,9 +73,9 @@ subroutine elemental_with_char_args(x,y) ! CHECK: %[[VAL_13:.*]] = hlfir.elemental %[[VAL_5]] : (!fir.shape<1>) -> !hlfir.expr<100xi32> { ! CHECK: ^bb0(%[[VAL_14:.*]]: index): ! CHECK: %[[VAL_15:.*]] = hlfir.designate %[[VAL_6]]#0 (%[[VAL_14]]) typeparams %[[VAL_2]]#1 : (!fir.box>>, index, index) -> !fir.boxchar<1> +! CHECK: %[[VAL_18:.*]]:2 = fir.unboxchar %[[VAL_15]] : (!fir.boxchar<1>) -> (!fir.ref>, index) ! CHECK: %[[VAL_16:.*]] = fir.box_elesize %[[VAL_7]]#1 : (!fir.box>>) -> index ! CHECK: %[[VAL_17:.*]] = hlfir.designate %[[VAL_7]]#0 (%[[VAL_14]]) typeparams %[[VAL_16]] : (!fir.box>>, index, index) -> !fir.boxchar<1> -! CHECK: %[[VAL_18:.*]]:2 = fir.unboxchar %[[VAL_15]] : (!fir.boxchar<1>) -> (!fir.ref>, index) ! CHECK: %[[VAL_19:.*]]:2 = fir.unboxchar %[[VAL_17]] : (!fir.boxchar<1>) -> (!fir.ref>, index) ! CHECK: %[[VAL_20:.*]] = arith.constant false ! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_18]]#0 : (!fir.ref>) -> !fir.ref @@ -139,10 +139,10 @@ subroutine test_merge(x, y, mask) ! CHECK: %[[VAL_16:.*]] = hlfir.elemental %[[VAL_9]] typeparams %[[VAL_6]]#1 : (!fir.shape<1>, index) -> !hlfir.expr<100x!fir.char<1,?>> { ! CHECK: ^bb0(%[[VAL_17:.*]]: index): ! CHECK: %[[VAL_18:.*]] = hlfir.designate %[[VAL_10]]#0 (%[[VAL_17]]) typeparams %[[VAL_6]]#1 : (!fir.box>>, index, index) -> !fir.boxchar<1> -! CHECK: %[[VAL_19:.*]] = hlfir.designate %[[VAL_15]]#0 (%[[VAL_17]]) typeparams %[[VAL_11]]#1 : (!fir.box>>, index, index) -> !fir.boxchar<1> -! CHECK: %[[VAL_20:.*]] = hlfir.designate %[[VAL_5]]#0 (%[[VAL_17]]) : (!fir.ref>>, index) -> !fir.ref> ! CHECK: %[[VAL_21:.*]]:2 = fir.unboxchar %[[VAL_18]] : (!fir.boxchar<1>) -> (!fir.ref>, index) +! CHECK: %[[VAL_19:.*]] = hlfir.designate %[[VAL_15]]#0 (%[[VAL_17]]) typeparams %[[VAL_11]]#1 : (!fir.box>>, index, index) -> !fir.boxchar<1> ! CHECK: %[[VAL_22:.*]]:2 = fir.unboxchar %[[VAL_19]] : (!fir.boxchar<1>) -> (!fir.ref>, index) +! CHECK: %[[VAL_20:.*]] = hlfir.designate %[[VAL_5]]#0 (%[[VAL_17]]) : (!fir.ref>>, index) -> !fir.ref> ! CHECK: %[[VAL_23:.*]] = fir.load %[[VAL_20]] : !fir.ref> ! CHECK: %[[VAL_24:.*]] = fir.convert %[[VAL_23]] : (!fir.logical<4>) -> i1 ! CHECK: %[[VAL_25:.*]] = arith.select %[[VAL_24]], %[[VAL_21]]#0, %[[VAL_22]]#0 : !fir.ref>