Magic-Mirror/llvm-capstone
1
0
Fork 0
mirror of https://github.com/capstone-engine/llvm-capstone.git synced 2024-10-07 19:03:57 +00:00
Code Issues Actions 2 Packages Projects Releases Wiki Activity

[Flang] Add partial support for lowering procedure pointer assignment. (#70461)

Browse Source 
**Scope of the PR:**
1. Lowering global and local procedure pointer declaration statement
with explicit or implicit interface. The explicit interface can be from
an interface block, a module procedure or an internal procedure.
2. Lowering procedure pointer assignment, where the target procedure
could be external, module or internal procedures.
3. Lowering reference to procedure pointers so that it works end to end.

**PR notes:**
1. The first commit of the PR does not include testing. I would like to
collect some comments first, which may alter the output. Once I confirm
the implementation, I will add some testing as a follow up commit to
this PR.
2. No special handling of the host-associated entities when an internal
procedure is the target of a procedure pointer assignment in this PR.

**Implementation notes:**
1. The implementation is using the HLFIR path.
2. Flang currently uses `getUntypedBoxProcType` to get the
`fir::BoxProcType` for `ProcedureDesignator` when getting the address of
a procedure in order to pass it as an actual argument. This PR inherits
the same design decision for procedure pointer as the `fir::StoreOp`
requires the same memory type.

Note: this commit is actually resubmitting the original commit from
PR #70461 that was reverted. See PR #73221.
This commit is contained in:
Daniel Chen 2023-11-22 11:51:12 -05:00 committed by Jean Perier
parent fd9a777e01
commit af09219edd
17 changed files with 561 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
flang/include/flang/Lower/BoxAnalyzer.h
View File

@ -382,6 +382,8 @@ public:
/// Run the analysis on `sym`.
void analyze(const Fortran::semantics::Symbol &sym) {
if (Fortran::semantics::IsProcedurePointer(sym))
return;
if (symIsArray(sym)) {
bool isConstant = !isAssumedSize(sym);
llvm::SmallVector<int64_t> lbounds;

6
flang/include/flang/Lower/CallInterface.h
View File

@ -111,7 +111,8 @@ public:
CharBoxValueAttribute, // BoxChar with VALUE
// Passing a character procedure as a <procedure address, result length>
// tuple.
CharProcTuple
CharProcTuple,
BoxProcRef
};
/// Different properties of an entity that can be passed/returned.
/// One-to-One mapping with PassEntityBy but for
@ -124,7 +125,8 @@ public:
CharProcTuple,
Box,
MutableBox,
Value
Value,
BoxProcRef
};
using FortranEntity = typename PassedEntityTypes<T>::FortranEntity;

10
flang/include/flang/Lower/ConvertProcedureDesignator.h
View File

@ -19,6 +19,8 @@
namespace mlir {
class Location;
class Value;
class Type;
}
namespace fir {
class ExtendedValue;
@ -29,6 +31,9 @@ class EntityWithAttributes;
namespace Fortran::evaluate {
struct ProcedureDesignator;
}
namespace Fortran::semantics {
class Symbol;
}
namespace Fortran::lower {
class AbstractConverter;
@ -50,5 +55,10 @@ hlfir::EntityWithAttributes convertProcedureDesignatorToHLFIR(
const Fortran::evaluate::ProcedureDesignator &proc,
Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx);
/// Generate initialization for procedure pointer to procedure target.
mlir::Value
convertProcedureDesignatorInitialTarget(Fortran::lower::AbstractConverter &,
mlir::Location,
const Fortran::semantics::Symbol &sym);
} // namespace Fortran::lower
#endif // FORTRAN_LOWER_CONVERT_PROCEDURE_DESIGNATOR_H

4
flang/include/flang/Optimizer/Builder/FIRBuilder.h
View File

@ -677,6 +677,10 @@ mlir::Value genCPtrOrCFunptrValue(fir::FirOpBuilder &builder,
/// to keep all the lower bound and explicit parameter information.
fir::BoxValue createBoxValue(fir::FirOpBuilder &builder, mlir::Location loc,
const fir::ExtendedValue &exv);
/// Generate Null BoxProc for procedure pointer null initialization.
mlir::Value createNullBoxProc(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Type boxType);
} // namespace fir::factory
#endif // FORTRAN_OPTIMIZER_BUILDER_FIRBUILDER_H

3
flang/include/flang/Optimizer/Builder/HLFIRTools.h
View File

@ -58,6 +58,9 @@ public:
bool isValue() const { return isFortranValue(*this); }
bool isVariable() const { return !isValue(); }
bool isMutableBox() const { return hlfir::isBoxAddressType(getType()); }
bool isProcedurePointer() const {
return hlfir::isBoxProcAddressType(getType());
}
bool isBoxAddressOrValue() const {
return hlfir::isBoxAddressOrValueType(getType());
}

6
flang/include/flang/Optimizer/HLFIR/HLFIRDialect.h
View File

@ -67,6 +67,12 @@ inline bool isBoxAddressType(mlir::Type type) {
return type && type.isa<fir::BaseBoxType>();
}
/// Is this a fir.boxproc address type?
inline bool isBoxProcAddressType(mlir::Type type) {
type = fir::dyn_cast_ptrEleTy(type);
return type && type.isa<fir::BoxProcType>();
}
/// Is this a fir.box or fir.class address or value type?
inline bool isBoxAddressOrValueType(mlir::Type type) {
return fir::unwrapRefType(type).isa<fir::BaseBoxType>();

29
flang/lib/Lower/Bridge.cpp
View File

@ -3095,6 +3095,17 @@ private:
const Fortran::lower::SomeExpr *expr =
Fortran::semantics::GetExpr(pointerObject);
assert(expr);
if (Fortran::evaluate::IsProcedurePointer(*expr)) {
Fortran::lower::StatementContext stmtCtx;
hlfir::Entity pptr = Fortran::lower::convertExprToHLFIR(
loc, *this, *expr, localSymbols, stmtCtx);
auto boxTy{
Fortran::lower::getUntypedBoxProcType(builder->getContext())};
hlfir::Entity nullBoxProc(
fir::factory::createNullBoxProc(*builder, loc, boxTy));
builder->createStoreWithConvert(loc, nullBoxProc, pptr);
return;
}
fir::MutableBoxValue box = genExprMutableBox(loc, *expr);
fir::factory::disassociateMutableBox(*builder, loc, box);
}
@ -3241,8 +3252,24 @@ private:
mlir::Location loc, const Fortran::evaluate::Assignment &assign,
const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {
Fortran::lower::StatementContext stmtCtx;
if (Fortran::evaluate::IsProcedure(assign.rhs))
if (!lowerToHighLevelFIR() && Fortran::evaluate::IsProcedure(assign.rhs))
TODO(loc, "procedure pointer assignment");
if (Fortran::evaluate::IsProcedurePointer(assign.lhs)) {
hlfir::Entity lhs = Fortran::lower::convertExprToHLFIR(
loc, *this, assign.lhs, localSymbols, stmtCtx);
if (Fortran::evaluate::IsNullProcedurePointer(assign.rhs)) {
auto boxTy{Fortran::lower::getUntypedBoxProcType(&getMLIRContext())};
hlfir::Entity rhs(
fir::factory::createNullBoxProc(*builder, loc, boxTy));
builder->createStoreWithConvert(loc, rhs, lhs);
return;
}
hlfir::Entity rhs(getBase(Fortran::lower::convertExprToAddress(
loc, *this, assign.rhs, localSymbols, stmtCtx)));
builder->createStoreWithConvert(loc, rhs, lhs);
return;
}
std::optional<Fortran::evaluate::DynamicType> lhsType =
assign.lhs.GetType();

87
flang/lib/Lower/CallInterface.cpp
View File

@ -23,6 +23,10 @@
#include "flang/Semantics/tools.h"
#include <optional>
static mlir::FunctionType
getProcedureType(const Fortran::evaluate::characteristics::Procedure &proc,
Fortran::lower::AbstractConverter &converter);
mlir::Type Fortran::lower::getUntypedBoxProcType(mlir::MLIRContext *context) {
llvm::SmallVector<mlir::Type> resultTys;
llvm::SmallVector<mlir::Type> inputTys;
@ -1055,15 +1059,24 @@ private:
const DummyCharacteristics *characteristics,
const Fortran::evaluate::characteristics::DummyProcedure &proc,
const FortranEntity &entity) {
if (proc.attrs.test(
if (!interface.converter.getLoweringOptions().getLowerToHighLevelFIR() &&
proc.attrs.test(
Fortran::evaluate::characteristics::DummyProcedure::Attr::Pointer))
TODO(interface.converter.getCurrentLocation(),
"procedure pointer arguments");
// Otherwise, it is a dummy procedure.
const Fortran::evaluate::characteristics::Procedure &procedure =
proc.procedure.value();
mlir::Type funcType =
getProcedureDesignatorType(&procedure, interface.converter);
if (proc.attrs.test(Fortran::evaluate::characteristics::DummyProcedure::
Attr::Pointer)) {
// Prodecure pointer dummy argument.
funcType = fir::ReferenceType::get(funcType);
addFirOperand(funcType, nextPassedArgPosition(), Property::BoxProcRef);
addPassedArg(PassEntityBy::BoxProcRef, entity, characteristics);
return;
}
// Otherwise, it is a dummy procedure.
std::optional<Fortran::evaluate::DynamicType> resultTy =
getResultDynamicType(procedure);
if (resultTy && mustPassLengthWithDummyProcedure(procedure)) {
@ -1087,37 +1100,40 @@ private:
void handleExplicitResult(
const Fortran::evaluate::characteristics::FunctionResult &result) {
using Attr = Fortran::evaluate::characteristics::FunctionResult::Attr;
mlir::Type mlirType;
if (auto proc{result.IsProcedurePointer()})
mlirType = fir::BoxProcType::get(
&mlirContext, getProcedureType(*proc, interface.converter));
else {
const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
result.GetTypeAndShape();
assert(typeAndShape && "expect type for non proc pointer result");
mlirType = translateDynamicType(typeAndShape->type());
fir::SequenceType::Shape bounds = getBounds(typeAndShape->shape());
const auto *resTypeAndShape{result.GetTypeAndShape()};
bool resIsPolymorphic =
resTypeAndShape && resTypeAndShape->type().IsPolymorphic();
bool resIsAssumedType =
resTypeAndShape && resTypeAndShape->type().IsAssumedType();
if (!bounds.empty())
mlirType = fir::SequenceType::get(bounds, mlirType);
if (result.attrs.test(Attr::Allocatable))
mlirType = fir::wrapInClassOrBoxType(
fir::HeapType::get(mlirType), resIsPolymorphic, resIsAssumedType);
if (result.attrs.test(Attr::Pointer))
mlirType =
fir::wrapInClassOrBoxType(fir::PointerType::get(mlirType),
resIsPolymorphic, resIsAssumedType);
if (result.IsProcedurePointer())
TODO(interface.converter.getCurrentLocation(),
"procedure pointer results");
const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
result.GetTypeAndShape();
assert(typeAndShape && "expect type for non proc pointer result");
mlir::Type mlirType = translateDynamicType(typeAndShape->type());
fir::SequenceType::Shape bounds = getBounds(typeAndShape->shape());
const auto *resTypeAndShape{result.GetTypeAndShape()};
bool resIsPolymorphic =
resTypeAndShape && resTypeAndShape->type().IsPolymorphic();
bool resIsAssumedType =
resTypeAndShape && resTypeAndShape->type().IsAssumedType();
if (!bounds.empty())
mlirType = fir::SequenceType::get(bounds, mlirType);
if (result.attrs.test(Attr::Allocatable))
mlirType = fir::wrapInClassOrBoxType(fir::HeapType::get(mlirType),
resIsPolymorphic, resIsAssumedType);
if (result.attrs.test(Attr::Pointer))
mlirType = fir::wrapInClassOrBoxType(fir::PointerType::get(mlirType),
resIsPolymorphic, resIsAssumedType);
if (fir::isa_char(mlirType)) {
// Character scalar results must be passed as arguments in lowering so
// that an assumed length character function callee can access the result
// length. A function with a result requiring an explicit interface does
// not have to be compatible with assumed length function, but most
// compilers supports it.
handleImplicitCharacterResult(typeAndShape->type());
return;
if (fir::isa_char(mlirType)) {
// Character scalar results must be passed as arguments in lowering so
// that an assumed length character function callee can access the
// result length. A function with a result requiring an explicit
// interface does not have to be compatible with assumed length
// function, but most compilers supports it.
handleImplicitCharacterResult(typeAndShape->type());
return;
}
}
addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,
@ -1534,3 +1550,10 @@ bool Fortran::lower::isCPtrArgByValueType(mlir::Type ty) {
return ty.isa<fir::ReferenceType>() &&
fir::isa_integer(fir::unwrapRefType(ty));
}
// Return the mlir::FunctionType of a procedure
static mlir::FunctionType
getProcedureType(const Fortran::evaluate::characteristics::Procedure &proc,
Fortran::lower::AbstractConverter &converter) {
return SignatureBuilder{proc, converter, false}.genFunctionType();
}

49
flang/lib/Lower/ConvertCall.cpp
View File

@ -175,6 +175,10 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
std::tie(funcPointer, charFuncPointerLength) =
fir::factory::extractCharacterProcedureTuple(builder, loc,
funcPointer);
// Reference to a procedure pointer. Load its value, the address of the
// procedure it points to.
if (Fortran::semantics::IsProcedurePointer(sym))
funcPointer = builder.create<fir::LoadOp>(loc, funcPointer);
}
mlir::IndexType idxTy = builder.getIndexType();
@ -870,9 +874,39 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
// element if this is an array in an elemental call.
hlfir::Entity actual = preparedActual.getActual(loc, builder);
// Do nothing if this is a procedure argument. It is already a
// fir.boxproc/fir.tuple<fir.boxproc, len> as it should.
// Handle the procedure pointer actual arguments.
if (actual.isProcedurePointer()) {
// Procedure pointer actual to procedure pointer dummy.
if (hlfir::isBoxProcAddressType(dummyType))
return PreparedDummyArgument{actual, /*cleanups=*/{}};
// Procedure pointer actual to procedure dummy.
if (hlfir::isFortranProcedureValue(dummyType)) {
actual = hlfir::derefPointersAndAllocatables(loc, builder, actual);
return PreparedDummyArgument{actual, /*cleanups=*/{}};
}
}
// NULL() actual to procedure pointer dummy
if (Fortran::evaluate::IsNullProcedurePointer(expr) &&
hlfir::isBoxProcAddressType(dummyType)) {
auto boxTy{Fortran::lower::getUntypedBoxProcType(builder.getContext())};
auto tempBoxProc{builder.createTemporary(loc, boxTy)};
hlfir::Entity nullBoxProc(
fir::factory::createNullBoxProc(builder, loc, boxTy));
builder.create<fir::StoreOp>(loc, nullBoxProc, tempBoxProc);
return PreparedDummyArgument{tempBoxProc, /*cleanups=*/{}};
}
if (actual.isProcedure()) {
// Procedure actual to procedure pointer dummy.
if (hlfir::isBoxProcAddressType(dummyType)) {
auto tempBoxProc{builder.createTemporary(loc, actual.getType())};
builder.create<fir::StoreOp>(loc, actual, tempBoxProc);
return PreparedDummyArgument{tempBoxProc, /*cleanups=*/{}};
}
// Procedure actual to procedure dummy.
// Do nothing if this is a procedure argument. It is already a
// fir.boxproc/fir.tuple<fir.boxproc, len> as it should.
if (actual.getType() != dummyType)
actual = fixProcedureDummyMismatch(loc, builder, actual, dummyType);
return PreparedDummyArgument{actual, /*cleanups=*/{}};
@ -1158,6 +1192,7 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,
case PassBy::CharBoxValueAttribute:
case PassBy::Box:
case PassBy::BaseAddress:
case PassBy::BoxProcRef:
case PassBy::BoxChar: {
PreparedDummyArgument preparedDummy =
prepareUserCallActualArgument(loc, builder, *preparedActual, argTy,
@ -1174,6 +1209,8 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,
break;
case PassBy::CharProcTuple: {
hlfir::Entity actual = preparedActual->getActual(loc, builder);
if (actual.isProcedurePointer())
actual = hlfir::derefPointersAndAllocatables(loc, builder, actual);
if (!fir::isCharacterProcedureTuple(actual.getType()))
actual = fixProcedureDummyMismatch(loc, builder, actual, argTy);
caller.placeInput(arg, actual);
@ -1495,6 +1532,8 @@ genIntrinsicRefCore(Fortran::lower::PreparedActualArguments &loweredActuals,
}
hlfir::Entity actual = arg.value()->getActual(loc, builder);
if (actual.isProcedurePointer())
TODO(loc, "Procedure pointer as actual argument to intrinsics.");
switch (argRules.lowerAs) {
case fir::LowerIntrinsicArgAs::Value:
operands.emplace_back(
@ -2149,8 +2188,10 @@ genProcedureRef(CallContext &callContext) {
TODO(loc, "assumed type actual argument");
if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
*expr)) {
if (arg.passBy !=
Fortran::lower::CallerInterface::PassEntityBy::MutableBox) {
if ((arg.passBy !=
Fortran::lower::CallerInterface::PassEntityBy::MutableBox) &&
(arg.passBy !=
Fortran::lower::CallerInterface::PassEntityBy::BoxProcRef)) {
assert(
arg.isOptional() &&
"NULL must be passed only to pointer, allocatable, or OPTIONAL");

3
flang/lib/Lower/ConvertExpr.cpp
View File

@ -4845,6 +4845,9 @@ private:
}
// See C15100 and C15101
fir::emitFatalError(loc, "cannot be POINTER, ALLOCATABLE");
case PassBy::BoxProcRef:
// Procedure pointer: no action here.
break;
}
}

4
flang/lib/Lower/ConvertExprToHLFIR.cpp
View File

@ -1425,7 +1425,9 @@ private:
}
hlfir::EntityWithAttributes gen(const Fortran::evaluate::ProcedureRef &expr) {
TODO(getLoc(), "lowering ProcRef to HLFIR");
TODO(
getLoc(),
"lowering function references that return procedure pointers to HLFIR");
}
template <typename T>

23
flang/lib/Lower/ConvertProcedureDesignator.cpp
View File

@ -11,11 +11,13 @@
#include "flang/Lower/AbstractConverter.h"
#include "flang/Lower/CallInterface.h"
#include "flang/Lower/ConvertCall.h"
#include "flang/Lower/ConvertExprToHLFIR.h"
#include "flang/Lower/ConvertVariable.h"
#include "flang/Lower/Support/Utils.h"
#include "flang/Lower/SymbolMap.h"
#include "flang/Optimizer/Builder/Character.h"
#include "flang/Optimizer/Builder/IntrinsicCall.h"
#include "flang/Optimizer/Builder/Todo.h"
#include "flang/Optimizer/Dialect/FIROps.h"
static bool areAllSymbolsInExprMapped(const Fortran::evaluate::ExtentExpr &expr,
@ -98,6 +100,15 @@ hlfir::EntityWithAttributes Fortran::lower::convertProcedureDesignatorToHLFIR(
mlir::Location loc, Fortran::lower::AbstractConverter &converter,
const Fortran::evaluate::ProcedureDesignator &proc,
Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
const auto *sym = proc.GetSymbol();
if (sym) {
if (sym->GetUltimate().attrs().test(Fortran::semantics::Attr::INTRINSIC))
TODO(loc, "Procedure pointer with intrinsic target.");
if (std::optional<fir::FortranVariableOpInterface> varDef =
symMap.lookupVariableDefinition(*sym))
return *varDef;
}
fir::ExtendedValue procExv =
convertProcedureDesignator(loc, converter, proc, symMap, stmtCtx);
// Directly package the procedure address as a fir.boxproc or
@ -125,3 +136,15 @@ hlfir::EntityWithAttributes Fortran::lower::convertProcedureDesignatorToHLFIR(
[funcAddr](const auto &) { return funcAddr; });
return hlfir::EntityWithAttributes{res};
}
mlir::Value Fortran::lower::convertProcedureDesignatorInitialTarget(
Fortran::lower::AbstractConverter &converter, mlir::Location loc,
const Fortran::semantics::Symbol &sym) {
Fortran::lower::SymMap globalOpSymMap;
Fortran::lower::StatementContext stmtCtx;
Fortran::evaluate::ProcedureDesignator proc(sym);
auto procVal{Fortran::lower::convertProcedureDesignatorToHLFIR(
loc, converter, proc, globalOpSymMap, stmtCtx)};
return fir::getBase(Fortran::lower::convertToAddress(
loc, converter, procVal, stmtCtx, procVal.getType()));
}

9
flang/lib/Lower/ConvertType.cpp
View File

@ -248,8 +248,13 @@ struct TypeBuilderImpl {
// links, the fir type is built based on the ultimate symbol. This relies
// on the fact volatile and asynchronous are not reflected in fir types.
const Fortran::semantics::Symbol &ultimate = symbol.GetUltimate();
if (Fortran::semantics::IsProcedurePointer(ultimate))
TODO(loc, "procedure pointers");
if (Fortran::semantics::IsProcedurePointer(ultimate)) {
Fortran::evaluate::ProcedureDesignator proc(ultimate);
auto procTy{Fortran::lower::translateSignature(proc, converter)};
return fir::BoxProcType::get(context, procTy);
}
if (const Fortran::semantics::DeclTypeSpec *type = ultimate.GetType()) {
if (const Fortran::semantics::IntrinsicTypeSpec *tySpec =
type->AsIntrinsic()) {

78
flang/lib/Lower/ConvertVariable.cpp
View File

@ -18,6 +18,7 @@
#include "flang/Lower/ConvertConstant.h"
#include "flang/Lower/ConvertExpr.h"
#include "flang/Lower/ConvertExprToHLFIR.h"
#include "flang/Lower/ConvertProcedureDesignator.h"
#include "flang/Lower/Mangler.h"
#include "flang/Lower/PFTBuilder.h"
#include "flang/Lower/StatementContext.h"
@ -479,7 +480,8 @@ static fir::GlobalOp defineGlobal(Fortran::lower::AbstractConverter &converter,
if (global && globalIsInitialized(global))
return global;
if (Fortran::semantics::IsProcedurePointer(sym))
if (!converter.getLoweringOptions().getLowerToHighLevelFIR() &&
Fortran::semantics::IsProcedurePointer(sym))
TODO(loc, "procedure pointer globals");
// If this is an array, check to see if we can use a dense attribute
@ -507,7 +509,8 @@ static fir::GlobalOp defineGlobal(Fortran::lower::AbstractConverter &converter,
if (!global)
global = builder.createGlobal(loc, symTy, globalName, linkage,
mlir::Attribute{}, isConst, var.isTarget());
if (Fortran::semantics::IsAllocatableOrPointer(sym)) {
if (Fortran::semantics::IsAllocatableOrPointer(sym) &&
!Fortran::semantics::IsProcedure(sym)) {
const auto *details =
sym.detailsIf<Fortran::semantics::ObjectEntityDetails>();
if (details && details->init()) {
@ -527,7 +530,6 @@ static fir::GlobalOp defineGlobal(Fortran::lower::AbstractConverter &converter,
b.create<fir::HasValueOp>(loc, box);
});
}
} else if (const auto *details =
sym.detailsIf<Fortran::semantics::ObjectEntityDetails>()) {
if (details->init()) {
@ -552,10 +554,39 @@ static fir::GlobalOp defineGlobal(Fortran::lower::AbstractConverter &converter,
builder.create<fir::HasValueOp>(loc, castTo);
});
}
} else if (Fortran::semantics::IsProcedurePointer(sym)) {
const auto *details{sym.detailsIf<Fortran::semantics::ProcEntityDetails>()};
if (details && details->init()) {
auto sym{*details->init()};
if (sym) // Has a procedure target.
Fortran::lower::createGlobalInitialization(
builder, global, [&](fir::FirOpBuilder &b) {
Fortran::lower::StatementContext stmtCtx(
/*cleanupProhibited=*/true);
auto box{Fortran::lower::convertProcedureDesignatorInitialTarget(
converter, loc, *sym)};
auto castTo{builder.createConvert(loc, symTy, box)};
b.create<fir::HasValueOp>(loc, castTo);
});
else { // Has NULL() target.
Fortran::lower::createGlobalInitialization(
builder, global, [&](fir::FirOpBuilder &b) {
auto box{fir::factory::createNullBoxProc(b, loc, symTy)};
b.create<fir::HasValueOp>(loc, box);
});
}
} else {
// No initialization.
Fortran::lower::createGlobalInitialization(
builder, global, [&](fir::FirOpBuilder &b) {
auto box{fir::factory::createNullBoxProc(b, loc, symTy)};
b.create<fir::HasValueOp>(loc, box);
});
}
} else if (sym.has<Fortran::semantics::CommonBlockDetails>()) {
mlir::emitError(loc, "COMMON symbol processed elsewhere");
} else {
TODO(loc, "global"); // Procedure pointer or something else
TODO(loc, "global"); // Something else
}
// Creates zero initializer for globals without initializers, this is a common
// and expected behavior (although not required by the standard)
@ -645,8 +676,16 @@ static mlir::Value createNewLocal(Fortran::lower::AbstractConverter &converter,
var.getSymbol().GetUltimate();
llvm::StringRef symNm = toStringRef(ultimateSymbol.name());
bool isTarg = var.isTarget();
// Let the builder do all the heavy lifting.
return builder.allocateLocal(loc, ty, nm, symNm, shape, lenParams, isTarg);
if (!Fortran::semantics::IsProcedurePointer(ultimateSymbol))
return builder.allocateLocal(loc, ty, nm, symNm, shape, lenParams, isTarg);
// Local procedure pointer.
auto res{builder.allocateLocal(loc, ty, nm, symNm, shape, lenParams, isTarg)};
auto box{fir::factory::createNullBoxProc(builder, loc, ty)};
builder.create<fir::StoreOp>(loc, box, res);
return res;
}
/// Must \p var be default initialized at runtime when entering its scope.
@ -1542,7 +1581,8 @@ static void genDeclareSymbol(Fortran::lower::AbstractConverter &converter,
// is useful to maintain the address of the commonblock in an MLIR value and
// query it. hlfir.declare need not be created for these.
if (converter.getLoweringOptions().getLowerToHighLevelFIR() &&
!Fortran::semantics::IsProcedure(sym) &&
(!Fortran::semantics::IsProcedure(sym) ||
Fortran::semantics::IsPointer(sym)) &&
!sym.detailsIf<Fortran::semantics::CommonBlockDetails>()) {
bool isCrayPointee =
sym.test(Fortran::semantics::Symbol::Flag::CrayPointee);
@ -1687,6 +1727,16 @@ genAllocatableOrPointerDeclare(Fortran::lower::AbstractConverter &converter,
/*lbounds=*/std::nullopt, force);
}
/// Map a procedure pointer
static void genProcPointer(Fortran::lower::AbstractConverter &converter,
Fortran::lower::SymMap &symMap,
const Fortran::semantics::Symbol &sym,
mlir::Value addr, bool force = false) {
genDeclareSymbol(converter, symMap, sym, addr, mlir::Value{},
/*shape=*/std::nullopt,
/*lbounds=*/std::nullopt, force);
}
/// Map a symbol represented with a runtime descriptor to its FIR fir.box and
/// evaluated specification expressions. Will optionally create fir.declare.
static void genBoxDeclare(Fortran::lower::AbstractConverter &converter,
@ -1738,8 +1788,20 @@ void Fortran::lower::mapSymbolAttributes(
Fortran::lower::genDeclareSymbol(converter, symMap, sym, undefOp);
}
if (Fortran::semantics::IsPointer(sym))
TODO(loc, "procedure pointers");
// Procedure pointer.
if (Fortran::semantics::IsPointer(sym)) {
// global
mlir::Value boxAlloc = preAlloc;
// dummy or passed result
if (!boxAlloc)
if (Fortran::lower::SymbolBox symbox = symMap.lookupSymbol(sym))
boxAlloc = symbox.getAddr();
// local
if (!boxAlloc)
boxAlloc = createNewLocal(converter, loc, var, preAlloc);
genProcPointer(converter, symMap, sym, boxAlloc, replace);
}
return;
}

11
flang/lib/Optimizer/Builder/FIRBuilder.cpp
View File

@ -1516,3 +1516,14 @@ mlir::Value fir::factory::genCPtrOrCFunptrValue(fir::FirOpBuilder &builder,
fir::factory::genCPtrOrCFunptrAddr(builder, loc, cPtr, cPtrTy);
return builder.create<fir::LoadOp>(loc, cPtrAddr);
}
mlir::Value fir::factory::createNullBoxProc(fir::FirOpBuilder &builder,
mlir::Location loc,
mlir::Type boxType) {
auto boxTy{boxType.dyn_cast<fir::BoxProcType>()};
if (!boxTy)
fir::emitFatalError(loc, "Procedure pointer must be of BoxProcType");
auto boxEleTy{fir::unwrapRefType(boxTy.getEleTy())};
mlir::Value initVal{builder.create<fir::ZeroOp>(loc, boxEleTy)};
return builder.create<fir::EmboxProcOp>(loc, boxTy, initVal);
}

2
flang/lib/Optimizer/Builder/HLFIRTools.cpp
View File

@ -696,6 +696,8 @@ hlfir::Entity hlfir::derefPointersAndAllocatables(mlir::Location loc,
// or fir.class to hold bounds, dynamic type or length parameter
// information. Keep them boxed.
return boxLoad;
} else if (entity.isProcedurePointer()) {
return hlfir::Entity{builder.create<fir::LoadOp>(loc, entity)};
}
return entity;
}

285
flang/test/Lower/HLFIR/procedure-pointer.f90 Normal file
View File

@ -0,0 +1,285 @@
! test level 1 procedure pointer for
! 1. declaration and initialization
! 2. pointer assignment and invocation
! 3. procedure pointer argument passing.
! RUN: bbc -emit-hlfir -o - %s | FileCheck %s
module m
interface
real function real_func(x)
real :: x
end function
character(:) function char_func(x)
pointer :: char_func
integer :: x
end function
subroutine sub(x)
real :: x
end subroutine
subroutine foo2(q)
import
procedure(char_func), pointer :: q
end
end interface
end module m
!!! Testing declaration and initialization
subroutine sub1()
use m
procedure(real_func), pointer :: p1
! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.boxproc<(!fir.ref<f32>) -> f32> {bindc_name = "p1", uniq_name = "_QFsub1Ep1"}
! CHECK: %[[VAL_1:.*]] = fir.zero_bits (!fir.ref<f32>) -> f32
! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_1]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<(!fir.ref<f32>) -> f32>
! CHECK: fir.store %[[VAL_2]] to %[[VAL_0]] : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub1Ep1"} : (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>) -> (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>, !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>)
procedure(real_func), pointer :: p2 => null()
! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QFsub1Ep2) : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub1Ep2"} : (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>) -> (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>, !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>)
procedure(real_func), pointer :: p3 => real_func
! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QFsub1Ep3) : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub1Ep3"} : (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>) -> (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>, !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>)
procedure(), pointer :: p4
! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.boxproc<() -> ()> {bindc_name = "p4", uniq_name = "_QFsub1Ep4"}
! CHECK: %[[VAL_1:.*]] = fir.zero_bits () -> ()
! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_1]] : (() -> ()) -> !fir.boxproc<() -> ()>
! CHECK: fir.store %[[VAL_2]] to %[[VAL_0]] : !fir.ref<!fir.boxproc<() -> ()>>
! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub1Ep4"} : (!fir.ref<!fir.boxproc<() -> ()>>) -> (!fir.ref<!fir.boxproc<() -> ()>>, !fir.ref<!fir.boxproc<() -> ()>>)
procedure(real), pointer :: p5
! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.boxproc<() -> f32> {bindc_name = "p5", uniq_name = "_QFsub1Ep5"}
! CHECK: %[[VAL_1:.*]] = fir.zero_bits () -> f32
! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_1]] : (() -> f32) -> !fir.boxproc<() -> f32>
! CHECK: fir.store %[[VAL_2]] to %[[VAL_0]] : !fir.ref<!fir.boxproc<() -> f32>>
! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub1Ep5"} : (!fir.ref<!fir.boxproc<() -> f32>>) -> (!fir.ref<!fir.boxproc<() -> f32>>, !fir.ref<!fir.boxproc<() -> f32>>)
procedure(char_func), pointer :: p6
! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>> {bindc_name = "p6", uniq_name = "_QFsub1Ep6"}
! CHECK: %[[VAL_1:.*]] = fir.zero_bits (!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_1]] : ((!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>) -> !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>
! CHECK: fir.store %[[VAL_2]] to %[[VAL_0]] : !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>
! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub1Ep6"} : (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>) -> (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>, !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>)
procedure(char_func), pointer :: p7 => char_func
! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QFsub1Ep7) : !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>
! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub1Ep7"} : (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>) -> (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>, !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>)
end subroutine sub1
!!! Testing pointer assignment and invocation
subroutine sub2()
use m
procedure(real_func), pointer :: p1
p1 => null()
! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.boxproc<(!fir.ref<f32>) -> f32> {bindc_name = "p1", uniq_name = "_QFsub2Ep1"}
! CHECK: %[[VAL_1:.*]] = fir.zero_bits (!fir.ref<f32>) -> f32
! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_1]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<(!fir.ref<f32>) -> f32>
! CHECK: fir.store %[[VAL_2]] to %[[VAL_0]] : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %0 {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub2Ep1"} : (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>) -> (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>, !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>)
! CHECK: %[[VAL_4:.*]] = fir.zero_bits () -> ()
! CHECK: %[[VAL_5:.*]] = fir.emboxproc %[[VAL_4]] : (() -> ()) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (!fir.boxproc<() -> ()>) -> !fir.boxproc<(!fir.ref<f32>) -> f32>
! CHECK: fir.store %[[VAL_6]] to %[[VAL_3]]#0 : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
end subroutine
subroutine sub3()
use m
procedure(real_func), pointer :: p1
real :: res, r
p1 => real_func
! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.boxproc<(!fir.ref<f32>) -> f32> {bindc_name = "p1", uniq_name = "_QFsub3Ep1"}
! CHECK: %[[VAL_1:.*]] = fir.zero_bits (!fir.ref<f32>) -> f32
! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_1]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<(!fir.ref<f32>) -> f32>
! CHECK: fir.store %[[VAL_2]] to %[[VAL_0]] : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %0 {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub3Ep1"} : (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>) -> (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>, !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>)
! CHECK: %[[VAL_4:.*]] = fir.address_of(@_QPreal_func) : (!fir.ref<f32>) -> f32
! CHECK: %[[VAL_5:.*]] = fir.emboxproc %[[VAL_4]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (!fir.boxproc<() -> ()>) -> !fir.boxproc<(!fir.ref<f32>) -> f32>
! CHECK: fir.store %[[VAL_6]] to %[[VAL_3]]#0 : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
res = p1(r)
! CHECK: %[[VAL_7:.*]] = fir.load %[[VAL_3]]#1 : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
! CHECK: %[[VAL_8:.*]] = fir.box_addr %[[VAL_7]] : (!fir.boxproc<(!fir.ref<f32>) -> f32>) -> ((!fir.ref<f32>) -> f32)
! CHECK: %[[VAL_9:.*]] = fir.call %[[VAL_8]](%5#1) fastmath<contract> : (!fir.ref<f32>) -> f32
nullify(p1)
! CHECK: %[[VAL_10:.*]] = fir.zero_bits () -> ()
! CHECK: %[[VAL_11:.*]] = fir.emboxproc %[[VAL_10]] : (() -> ()) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (!fir.boxproc<() -> ()>) -> !fir.boxproc<(!fir.ref<f32>) -> f32>
! CHECK: fir.store %[[VAL_12]] to %[[VAL_3]]#0 : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
end subroutine
subroutine sub4()
use m
procedure(char_func), pointer :: p2
character(:), pointer :: res
integer :: i
p2 => char_func
! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>> {bindc_name = "p2", uniq_name = "_QFsub4Ep2"}
! CHECK: %[[VAL_1:.*]] = fir.zero_bits (!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_1]] : ((!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>) -> !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>
! CHECK: fir.store %[[VAL_2]] to %[[VAL_0]] : !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>
! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub4Ep2"} : (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>) -> (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>, !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>)
! CHECK: %[[VAL_4:.*]] = fir.address_of(@_QPchar_func) : (!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
! CHECK: %[[VAL_12:.*]] = arith.constant -1 : index
! CHECK: %[[VAL_5:.*]] = fir.emboxproc %[[VAL_4]] : ((!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_12]] : (index) -> i64
! CHECK: %[[VAL_7:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_8:.*]] = fir.insert_value %[[VAL_7]], %[[VAL_5]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_9:.*]] = fir.insert_value %[[VAL_8]], %[[VAL_6]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_10:.*]] = fir.extract_value %[[VAL_9]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_10]] : (!fir.boxproc<() -> ()>) -> !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>
! CHECK: fir.store %[[VAL_11]] to %[[VAL_3]]#0 : !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>
res = p2(i)
! CHECK: %[[VAL_12:.*]] = fir.load %[[VAL_3]]#1 : !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>
! CHECK: %[[VAL_13:.*]] = fir.box_addr %[[VAL_12]] : (!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>) -> ((!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>)
! CHECK: %[[VAL_14:.*]] = fir.call %[[VAL_13]](%2#1) fastmath<contract> : (!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
end subroutine
subroutine sub5()
use m
procedure(real), pointer :: p3
p3 => real_func
! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.boxproc<() -> f32> {bindc_name = "p3", uniq_name = "_QFsub5Ep3"}
! CHECK: %[[VAL_1:.*]] = fir.zero_bits () -> f32
! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_1]] : (() -> f32) -> !fir.boxproc<() -> f32>
! CHECK: fir.store %[[VAL_2]] to %[[VAL_0]] : !fir.ref<!fir.boxproc<() -> f32>>
! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %0 {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub5Ep3"} : (!fir.ref<!fir.boxproc<() -> f32>>) -> (!fir.ref<!fir.boxproc<() -> f32>>, !fir.ref<!fir.boxproc<() -> f32>>)
! CHECK: %[[VAL_4:.*]] = fir.address_of(@_QPreal_func) : (!fir.ref<f32>) -> f32
! CHECK: %[[VAL_5:.*]] = fir.emboxproc %[[VAL_4]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (!fir.boxproc<() -> ()>) -> !fir.boxproc<() -> f32>
! CHECK: fir.store %[[VAL_6]] to %[[VAL_3]]#0 : !fir.ref<!fir.boxproc<() -> f32>>
end subroutine
subroutine sub6()
use m
procedure(), pointer :: p4
real :: r
p4 => sub
! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.boxproc<() -> ()> {bindc_name = "p4", uniq_name = "_QFsub6Ep4"}
! CHECK: %[[VAL_1:.*]] = fir.zero_bits () -> ()
! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_1]] : (() -> ()) -> !fir.boxproc<() -> ()>
! CHECK: fir.store %[[VAL_2]] to %[[VAL_0]] : !fir.ref<!fir.boxproc<() -> ()>>
! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %0 {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub6Ep4"} : (!fir.ref<!fir.boxproc<() -> ()>>) -> (!fir.ref<!fir.boxproc<() -> ()>>, !fir.ref<!fir.boxproc<() -> ()>>)
! CHECK: %[[VAL_4:.*]] = fir.address_of(@_QPsub) : (!fir.ref<f32>) -> ()
! CHECK: %[[VAL_5:.*]] = fir.emboxproc %[[VAL_4]] : ((!fir.ref<f32>) -> ()) -> !fir.boxproc<() -> ()>
! CHECK: fir.store %[[VAL_5]] to %[[VAL_3]]#0 : !fir.ref<!fir.boxproc<() -> ()>>
call p4(r)
! CHECK: %[[VAL_6:.*]] = fir.load %[[VAL_3]]#1 : !fir.ref<!fir.boxproc<() -> ()>>
! CHECK: %[[VAL_7:.*]] = fir.box_addr %[[VAL_6]] : (!fir.boxproc<() -> ()>) -> ((!fir.ref<f32>) -> ())
! CHECK: fir.call %[[VAL_7]](%5#1) fastmath<contract> : (!fir.ref<f32>) -> ()
end subroutine
!!! Testing pointer assignment and invocation
subroutine sub7(p1, p2)
use m
procedure(real_func), pointer :: p1
! CHECK: %[[VAL_0:.*]]:2 = hlfir.declare %arg0 {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub7Ep1"} : (!fir.ref<!fir.boxproc<() -> ()>>) -> (!fir.ref<!fir.boxproc<() -> ()>>, !fir.ref<!fir.boxproc<() -> ()>>)
procedure(char_func), pointer :: p2
! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %arg1 {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub7Ep2"} : (!fir.ref<!fir.boxproc<() -> ()>>) -> (!fir.ref<!fir.boxproc<() -> ()>>, !fir.ref<!fir.boxproc<() -> ()>>)
call foo1(p1)
! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_0]]#0 : !fir.ref<!fir.boxproc<() -> ()>>
! CHECK: fir.call @_QPfoo1(%[[VAL_2]]) fastmath<contract> : (!fir.boxproc<() -> ()>) -> ()
call foo2(p2)
! CHECK: fir.call @_QPfoo2(%[[VAL_1]]#0) fastmath<contract> : (!fir.ref<!fir.boxproc<() -> ()>>) -> ()
end
subroutine sub8()
use m
procedure(real_func), pointer, save :: pp1
! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QFsub8Epp1) : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub8Epp1"} : (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>) -> (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>, !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>)
procedure(char_func), pointer, save :: pp2
! CHECK: %[[VAL_2:.*]] = fir.address_of(@_QFsub8Epp2) : !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>
! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_2]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub8Epp2"} : (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>) -> (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>, !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>)
call foo1(pp1)
! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.boxproc<(!fir.ref<f32>) -> f32>) -> !fir.boxproc<() -> ()>
! CHECK: fir.call @_QPfoo1(%[[VAL_5]]) fastmath<contract> : (!fir.boxproc<() -> ()>) -> ()
call foo2(pp2)
! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_3]]#0 : (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>) -> !fir.ref<!fir.boxproc<() -> ()>>
! CHECK: fir.call @_QPfoo2(%[[VAL_6]]) fastmath<contract> : (!fir.ref<!fir.boxproc<() -> ()>>) -> ()
end
subroutine sub9()
use m
procedure(real_func), pointer :: p1
! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.boxproc<(!fir.ref<f32>) -> f32> {bindc_name = "p1", uniq_name = "_QFsub9Ep1"}
! CHECK: %[[VAL_1:.*]] = fir.zero_bits (!fir.ref<f32>) -> f32
! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_1]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<(!fir.ref<f32>) -> f32>
! CHECK: fir.store %[[VAL_2]] to %[[VAL_0]] : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub9Ep1"} : (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>) -> (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>, !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>)
procedure(char_func), pointer :: p2
! CHECK: %[[VAL_4:.*]] = fir.alloca !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>> {bindc_name = "p2", uniq_name = "_QFsub9Ep2"}
! CHECK: %[[VAL_5:.*]] = fir.zero_bits (!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
! CHECK: %[[VAL_6:.*]] = fir.emboxproc %[[VAL_5]] : ((!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>) -> !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>
! CHECK: fir.store %[[VAL_6]] to %[[VAL_4]] : !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>
! CHECK: %[[VAL_7:.*]]:2 = hlfir.declare %[[VAL_4]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub9Ep2"} : (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>) -> (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>, !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>)
call foo1(p1)
! CHECK: %[[VAL_8:.*]] = fir.load %[[VAL_3]]#0 : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_8]] : (!fir.boxproc<(!fir.ref<f32>) -> f32>) -> !fir.boxproc<() -> ()>
! CHECK: fir.call @_QPfoo1(%[[VAL_9]]) fastmath<contract> : (!fir.boxproc<() -> ()>) -> ()
call foo2(p2)
! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_7]]#0 : (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>) -> !fir.ref<!fir.boxproc<() -> ()>>
! CHECK: fir.call @_QPfoo2(%[[VAL_10]]) fastmath<contract> : (!fir.ref<!fir.boxproc<() -> ()>>) -> ()
end
! CHECK-LABEL: fir.global internal @_QFsub1Ep2 : !fir.boxproc<(!fir.ref<f32>) -> f32> {
! CHECK: %[[VAL_0:.*]] = fir.zero_bits (!fir.ref<f32>) -> f32
! CHECK: %[[VAL_1:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<(!fir.ref<f32>) -> f32>
! CHECK: fir.has_value %[[VAL_1]] : !fir.boxproc<(!fir.ref<f32>) -> f32>
! CHECK: }
! CHECK-LABEL: fir.global internal @_QFsub1Ep3 : !fir.boxproc<(!fir.ref<f32>) -> f32> {
! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QPreal_func) : (!fir.ref<f32>) -> f32
! CHECK: %[[VAL_1:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]] : (!fir.boxproc<() -> ()>) -> !fir.boxproc<(!fir.ref<f32>) -> f32>
! CHECK: fir.has_value %[[VAL_2]] : !fir.boxproc<(!fir.ref<f32>) -> f32>
! CHECK: }
! CHECK-LABEL: fir.global internal @_QFsub1Ep7 : !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>> {
! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QPchar_func) : (!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
! CHECK: %[[VAL_11:.*]] = arith.constant -1 : index
! CHECK: %[[VAL_1:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_11]] : (index) -> i64
! CHECK: %[[VAL_3:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_4:.*]] = fir.insert_value %[[VAL_3]], %[[VAL_1]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_2]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_6:.*]] = fir.extract_value %[[VAL_5]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_7:.*]] = fir.extract_value %[[VAL_5]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> i64
! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_6]] : (!fir.boxproc<() -> ()>) -> !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>
! CHECK: fir.has_value %[[VAL_8]] : !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>
! CHECK: }
! CHECK-LABEL: fir.global internal @_QFsub8Epp1 : !fir.boxproc<(!fir.ref<f32>) -> f32> {
! CHECK: %[[VAL_0:.*]] = fir.zero_bits (!fir.ref<f32>) -> f32
! CHECK: %[[VAL_1:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<(!fir.ref<f32>) -> f32>
! CHECK: fir.has_value %[[VAL_1]] : !fir.boxproc<(!fir.ref<f32>) -> f32>
! CHECK: }
! CHECK-LABEL: fir.global internal @_QFsub8Epp2 : !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>> {
! CHECK: %[[VAL_0:.*]] = fir.zero_bits (!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
! CHECK: %[[VAL_1:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>) -> !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>
! CHECK: fir.has_value %[[VAL_1]] : !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>
! CHECK: }