[flang-commits] [flang] [Flang] Add partial support for lowering procedure pointer assignment. (PR #70461)
Daniel Chen via flang-commits
flang-commits at lists.llvm.org
Mon Nov 20 10:05:08 PST 2023
https://github.com/DanielCChen updated https://github.com/llvm/llvm-project/pull/70461
>From 9ce3d2eab35553ab50bffb66e6e1fa05d93079e8 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Tue, 31 Oct 2023 13:35:38 -0400
Subject: [PATCH 01/17] [Flang] Add partial support for procedure pointer.
---
flang/lib/Lower/Bridge.cpp | 9 ++-
flang/lib/Lower/ConvertCall.cpp | 16 +++--
.../lib/Lower/ConvertProcedureDesignator.cpp | 4 ++
flang/lib/Lower/ConvertType.cpp | 8 ++-
flang/lib/Lower/ConvertVariable.cpp | 58 +++++++++++++++++--
5 files changed, 81 insertions(+), 14 deletions(-)
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index 872bf6bc729ecd0..a3914c76cb5317d 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -3241,8 +3241,13 @@ class FirConverter : public Fortran::lower::AbstractConverter {
mlir::Location loc, const Fortran::evaluate::Assignment &assign,
const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {
Fortran::lower::StatementContext stmtCtx;
- if (Fortran::evaluate::IsProcedure(assign.rhs))
- TODO(loc, "procedure pointer assignment");
+
+ if (Fortran::evaluate::IsProcedure(assign.rhs)) {
+ auto lhs{fir::getBase(genExprAddr(assign.lhs, stmtCtx, &loc))};
+ auto rhs{fir::getBase(genExprAddr(assign.rhs, stmtCtx, &loc))};
+ builder->create<fir::StoreOp>(loc, rhs, lhs);
+ return;
+ }
std::optional<Fortran::evaluate::DynamicType> lhsType =
assign.lhs.GetType();
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index 82e1ece4efeafe7..a8bbab55d762c3f 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -165,8 +165,10 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
// will be used only if there is no explicit length in the local interface).
mlir::Value funcPointer;
mlir::Value charFuncPointerLength;
+ bool isProcPtr = false;
if (const Fortran::semantics::Symbol *sym =
caller.getIfIndirectCallSymbol()) {
+ isProcPtr = Fortran::semantics::IsProcedurePointer(sym);
funcPointer = fir::getBase(converter.getSymbolExtendedValue(*sym, &symMap));
if (!funcPointer)
fir::emitFatalError(loc, "failed to find indirect call symbol address");
@@ -325,10 +327,16 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
// compatible interface in Fortran, but that have different signatures in
// FIR.
if (funcPointer) {
- operands.push_back(
- funcPointer.getType().isa<fir::BoxProcType>()
- ? builder.create<fir::BoxAddrOp>(loc, funcType, funcPointer)
- : builder.createConvert(loc, funcType, funcPointer));
+ if (isProcPtr) {
+ funcPointer = builder.create<fir::LoadOp>(loc, funcPointer);
+ auto boxProcTy{fir::BoxProcType::get(builder.getContext(), funcType)};
+ auto func{builder.createConvert(loc, boxProcTy, funcPointer)};
+ operands.push_back(builder.create<fir::BoxAddrOp>(loc, funcType, func));
+ } else
+ operands.push_back(
+ funcPointer.getType().isa<fir::BoxProcType>()
+ ? builder.create<fir::BoxAddrOp>(loc, funcType, funcPointer)
+ : builder.createConvert(loc, funcType, funcPointer));
}
// Deal with potential mismatches in arguments types. Passing an array to a
diff --git a/flang/lib/Lower/ConvertProcedureDesignator.cpp b/flang/lib/Lower/ConvertProcedureDesignator.cpp
index 20ade1a04049fc4..b02fb3eb38141c8 100644
--- a/flang/lib/Lower/ConvertProcedureDesignator.cpp
+++ b/flang/lib/Lower/ConvertProcedureDesignator.cpp
@@ -98,6 +98,10 @@ 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) {
+ if (std::optional<fir::FortranVariableOpInterface> varDef =
+ symMap.lookupVariableDefinition(*proc.GetSymbol()))
+ return *varDef;
+
fir::ExtendedValue procExv =
convertProcedureDesignator(loc, converter, proc, symMap, stmtCtx);
// Directly package the procedure address as a fir.boxproc or
diff --git a/flang/lib/Lower/ConvertType.cpp b/flang/lib/Lower/ConvertType.cpp
index 1ed3b602621b449..dbcaaced169ce3c 100644
--- a/flang/lib/Lower/ConvertType.cpp
+++ b/flang/lib/Lower/ConvertType.cpp
@@ -248,8 +248,12 @@ 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);
+ return Fortran::lower::translateSignature(proc, converter);
+ }
+
if (const Fortran::semantics::DeclTypeSpec *type = ultimate.GetType()) {
if (const Fortran::semantics::IntrinsicTypeSpec *tySpec =
type->AsIntrinsic()) {
diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index e8137886d2cf54b..e54406f031fb963 100644
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -479,8 +479,20 @@ static fir::GlobalOp defineGlobal(Fortran::lower::AbstractConverter &converter,
if (global && globalIsInitialized(global))
return global;
- if (Fortran::semantics::IsProcedurePointer(sym))
- TODO(loc, "procedure pointer globals");
+ if (Fortran::semantics::IsProcedurePointer(sym)) {
+ auto boxProcTy{Fortran::lower::getUntypedBoxProcType(builder.getContext())};
+ global = builder.createGlobal(loc, boxProcTy, globalName, linkage,
+ mlir::Attribute{}, isConst, var.isTarget());
+ Fortran::lower::createGlobalInitialization(
+ builder, global, [&](fir::FirOpBuilder &builder) {
+ mlir::Value initVal{builder.create<fir::ZeroOp>(loc, symTy)};
+ auto emBoxVal{
+ builder.create<fir::EmboxProcOp>(loc, boxProcTy, initVal)};
+ builder.create<fir::HasValueOp>(loc, emBoxVal);
+ });
+ global.setVisibility(mlir::SymbolTable::Visibility::Public);
+ return global;
+ }
// If this is an array, check to see if we can use a dense attribute
// with a tensor mlir type. This optimization currently only supports
@@ -645,8 +657,19 @@ 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 boxProcTy{Fortran::lower::getUntypedBoxProcType(builder.getContext())};
+ auto res{builder.allocateLocal(loc, boxProcTy, nm, symNm, shape, lenParams,
+ isTarg)};
+ mlir::Value initVal{builder.create<fir::ZeroOp>(loc, ty)};
+ auto emBoxVal{builder.create<fir::EmboxProcOp>(loc, boxProcTy, initVal)};
+ builder.create<fir::StoreOp>(loc, emBoxVal, res);
+ return res;
}
/// Must \p var be default initialized at runtime when entering its scope.
@@ -1542,7 +1565,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 +1711,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 +1772,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;
}
>From e1c72e3907ed8ff71f2f465cded278627255d07e Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Sun, 5 Nov 2023 20:38:46 -0500
Subject: [PATCH 02/17] [Flang] Lowering procedure pointer actual/dummy
argument.
---
.../flang/Optimizer/HLFIR/HLFIRDialect.h | 6 +++
flang/lib/Lower/CallInterface.cpp | 42 ++++++++++---------
flang/lib/Lower/ConvertCall.cpp | 16 +++++++
3 files changed, 44 insertions(+), 20 deletions(-)
diff --git a/flang/include/flang/Optimizer/HLFIR/HLFIRDialect.h b/flang/include/flang/Optimizer/HLFIR/HLFIRDialect.h
index aa68d0811c4868a..e8f28485298277d 100644
--- a/flang/include/flang/Optimizer/HLFIR/HLFIRDialect.h
+++ b/flang/include/flang/Optimizer/HLFIR/HLFIRDialect.h
@@ -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>();
diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
index 51b0579fac36c0f..d78a612808cfaf7 100644
--- a/flang/lib/Lower/CallInterface.cpp
+++ b/flang/lib/Lower/CallInterface.cpp
@@ -1055,30 +1055,32 @@ class Fortran::lower::CallInterfaceImpl {
const DummyCharacteristics *characteristics,
const Fortran::evaluate::characteristics::DummyProcedure &proc,
const FortranEntity &entity) {
- if (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);
- std::optional<Fortran::evaluate::DynamicType> resultTy =
- getResultDynamicType(procedure);
- if (resultTy && mustPassLengthWithDummyProcedure(procedure)) {
- // The result length of dummy procedures that are character functions must
- // be passed so that the dummy procedure can be called if it has assumed
- // length on the callee side.
- mlir::Type tupleType =
- fir::factory::getCharacterProcedureTupleType(funcType);
- llvm::StringRef charProcAttr = fir::getCharacterProcedureDummyAttrName();
- addFirOperand(tupleType, nextPassedArgPosition(), Property::CharProcTuple,
- {mlir::NamedAttribute{
- mlir::StringAttr::get(&mlirContext, charProcAttr),
- mlir::UnitAttr::get(&mlirContext)}});
- addPassedArg(PassEntityBy::CharProcTuple, entity, characteristics);
- return;
+ if (proc.attrs.test(Fortran::evaluate::characteristics::DummyProcedure::
+ Attr::Pointer)) {
+ funcType = fir::ReferenceType::get(funcType);
+ } else { // Otherwise, it is a dummy procedure.
+ std::optional<Fortran::evaluate::DynamicType> resultTy =
+ getResultDynamicType(procedure);
+ if (resultTy && mustPassLengthWithDummyProcedure(procedure)) {
+ // The result length of dummy procedures that are character functions
+ // must be passed so that the dummy procedure can be called if it has
+ // assumed length on the callee side.
+ mlir::Type tupleType =
+ fir::factory::getCharacterProcedureTupleType(funcType);
+ llvm::StringRef charProcAttr =
+ fir::getCharacterProcedureDummyAttrName();
+ addFirOperand(tupleType, nextPassedArgPosition(),
+ Property::CharProcTuple,
+ {mlir::NamedAttribute{
+ mlir::StringAttr::get(&mlirContext, charProcAttr),
+ mlir::UnitAttr::get(&mlirContext)}});
+ addPassedArg(PassEntityBy::CharProcTuple, entity, characteristics);
+ return;
+ }
}
addFirOperand(funcType, nextPassedArgPosition(), Property::BaseAddress);
addPassedArg(PassEntityBy::BaseAddress, entity, characteristics);
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index a8bbab55d762c3f..1a21751561ad67f 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -878,6 +878,22 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
// element if this is an array in an elemental call.
hlfir::Entity actual = preparedActual.getActual(loc, builder);
+ // Handles the procedure pointer actual/dummy arguments.
+ // It could have a combination of
+ // acutal dummy
+ // 2. procedure pointer procedure pointer
+ // 3. procedure pointer procedure
+ // 4. procedure procedure pointer
+ if (hlfir::isBoxProcAddressType(actual.getType()) ||
+ hlfir::isBoxProcAddressType(dummyType)) {
+ if (actual.getType() != dummyType &&
+ hlfir::isBoxProcAddressType(actual.getType())) {
+ auto baseAddr{actual.getFirBase()};
+ actual = hlfir::Entity{builder.create<fir::LoadOp>(loc, baseAddr)};
+ }
+ return PreparedDummyArgument{actual, /*cleanups=*/{}};
+ }
+
// Do nothing if this is a procedure argument. It is already a
// fir.boxproc/fir.tuple<fir.boxproc, len> as it should.
if (actual.isProcedure()) {
>From 0b19d7019ca38845ff2f8761fd214a8ec9c0cda4 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Fri, 10 Nov 2023 14:07:32 -0500
Subject: [PATCH 03/17] [Flang] Addressing multiple review comments. The
details is in the PR.
---
flang/include/flang/Lower/BoxAnalyzer.h | 2 +
.../flang/Lower/ConvertProcedureDesignator.h | 11 +++
.../flang/Optimizer/Builder/FIRBuilder.h | 4 +
.../flang/Optimizer/Builder/HLFIRTools.h | 3 +
flang/lib/Lower/Bridge.cpp | 18 +++-
flang/lib/Lower/CallInterface.cpp | 82 +++++++++++--------
flang/lib/Lower/ConvertCall.cpp | 33 ++------
flang/lib/Lower/ConvertExprToHLFIR.cpp | 4 +-
.../lib/Lower/ConvertProcedureDesignator.cpp | 13 +++
flang/lib/Lower/ConvertType.cpp | 3 +-
flang/lib/Lower/ConvertVariable.cpp | 73 +++++++++++------
flang/lib/Optimizer/Builder/FIRBuilder.cpp | 11 +++
flang/lib/Optimizer/Builder/HLFIRTools.cpp | 2 +
13 files changed, 168 insertions(+), 91 deletions(-)
diff --git a/flang/include/flang/Lower/BoxAnalyzer.h b/flang/include/flang/Lower/BoxAnalyzer.h
index 52cded8b219d835..3b8e2455ff273be 100644
--- a/flang/include/flang/Lower/BoxAnalyzer.h
+++ b/flang/include/flang/Lower/BoxAnalyzer.h
@@ -382,6 +382,8 @@ class BoxAnalyzer : public fir::details::matcher<BoxAnalyzer> {
/// 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;
diff --git a/flang/include/flang/Lower/ConvertProcedureDesignator.h b/flang/include/flang/Lower/ConvertProcedureDesignator.h
index 86a757a9aadf4f4..b0d422b8c3ff88d 100644
--- a/flang/include/flang/Lower/ConvertProcedureDesignator.h
+++ b/flang/include/flang/Lower/ConvertProcedureDesignator.h
@@ -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,11 @@ 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
+convertProcedureDesignatorToAddress(Fortran::lower::AbstractConverter &,
+ mlir::Location, mlir::Type boxType,
+ Fortran::lower::StatementContext &stmtCtx,
+ const Fortran::semantics::Symbol *sym);
} // namespace Fortran::lower
#endif // FORTRAN_LOWER_CONVERT_PROCEDURE_DESIGNATOR_H
diff --git a/flang/include/flang/Optimizer/Builder/FIRBuilder.h b/flang/include/flang/Optimizer/Builder/FIRBuilder.h
index 0b36186d68a4614..b5b2c99810b15bb 100644
--- a/flang/include/flang/Optimizer/Builder/FIRBuilder.h
+++ b/flang/include/flang/Optimizer/Builder/FIRBuilder.h
@@ -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
diff --git a/flang/include/flang/Optimizer/Builder/HLFIRTools.h b/flang/include/flang/Optimizer/Builder/HLFIRTools.h
index 07bb380320bf712..999ac9c7a42fad2 100644
--- a/flang/include/flang/Optimizer/Builder/HLFIRTools.h
+++ b/flang/include/flang/Optimizer/Builder/HLFIRTools.h
@@ -58,6 +58,9 @@ class Entity : public mlir::Value {
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());
}
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index a3914c76cb5317d..a10701e0fa68b5d 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -3242,10 +3242,20 @@ class FirConverter : public Fortran::lower::AbstractConverter {
const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {
Fortran::lower::StatementContext stmtCtx;
- if (Fortran::evaluate::IsProcedure(assign.rhs)) {
- auto lhs{fir::getBase(genExprAddr(assign.lhs, stmtCtx, &loc))};
- auto rhs{fir::getBase(genExprAddr(assign.rhs, stmtCtx, &loc))};
- builder->create<fir::StoreOp>(loc, rhs, lhs);
+ if (Fortran::evaluate::IsProcedurePointerTarget(assign.rhs)) {
+ 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)));
+ rhs = hlfir::derefPointersAndAllocatables(loc, *builder, rhs);
+ builder->createStoreWithConvert(loc, rhs, lhs);
return;
}
diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
index d78a612808cfaf7..4b38ec488a439f0 100644
--- a/flang/lib/Lower/CallInterface.cpp
+++ b/flang/lib/Lower/CallInterface.cpp
@@ -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;
@@ -1059,10 +1063,10 @@ class Fortran::lower::CallInterfaceImpl {
proc.procedure.value();
mlir::Type funcType =
getProcedureDesignatorType(&procedure, interface.converter);
- if (proc.attrs.test(Fortran::evaluate::characteristics::DummyProcedure::
- Attr::Pointer)) {
+ if (proc.attrs.test(
+ Fortran::evaluate::characteristics::DummyProcedure::Attr::Pointer))
funcType = fir::ReferenceType::get(funcType);
- } else { // Otherwise, it is a dummy procedure.
+ else { // Otherwise, it is a dummy procedure.
std::optional<Fortran::evaluate::DynamicType> resultTy =
getResultDynamicType(procedure);
if (resultTy && mustPassLengthWithDummyProcedure(procedure)) {
@@ -1089,37 +1093,40 @@ class Fortran::lower::CallInterfaceImpl {
void handleExplicitResult(
const Fortran::evaluate::characteristics::FunctionResult &result) {
using Attr = Fortran::evaluate::characteristics::FunctionResult::Attr;
-
- 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;
+ 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 (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,
@@ -1536,3 +1543,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();
+}
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index 1a21751561ad67f..af07990c0c3c4bb 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -165,10 +165,8 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
// will be used only if there is no explicit length in the local interface).
mlir::Value funcPointer;
mlir::Value charFuncPointerLength;
- bool isProcPtr = false;
if (const Fortran::semantics::Symbol *sym =
caller.getIfIndirectCallSymbol()) {
- isProcPtr = Fortran::semantics::IsProcedurePointer(sym);
funcPointer = fir::getBase(converter.getSymbolExtendedValue(*sym, &symMap));
if (!funcPointer)
fir::emitFatalError(loc, "failed to find indirect call symbol address");
@@ -177,6 +175,9 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
std::tie(funcPointer, charFuncPointerLength) =
fir::factory::extractCharacterProcedureTuple(builder, loc,
funcPointer);
+ // RHS is a procedure pointer. Load its value.
+ if (Fortran::semantics::IsProcedurePointer(sym))
+ funcPointer = builder.create<fir::LoadOp>(loc, funcPointer);
}
mlir::IndexType idxTy = builder.getIndexType();
@@ -327,16 +328,10 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
// compatible interface in Fortran, but that have different signatures in
// FIR.
if (funcPointer) {
- if (isProcPtr) {
- funcPointer = builder.create<fir::LoadOp>(loc, funcPointer);
- auto boxProcTy{fir::BoxProcType::get(builder.getContext(), funcType)};
- auto func{builder.createConvert(loc, boxProcTy, funcPointer)};
- operands.push_back(builder.create<fir::BoxAddrOp>(loc, funcType, func));
- } else
- operands.push_back(
- funcPointer.getType().isa<fir::BoxProcType>()
- ? builder.create<fir::BoxAddrOp>(loc, funcType, funcPointer)
- : builder.createConvert(loc, funcType, funcPointer));
+ operands.push_back(
+ funcPointer.getType().isa<fir::BoxProcType>()
+ ? builder.create<fir::BoxAddrOp>(loc, funcType, funcPointer)
+ : builder.createConvert(loc, funcType, funcPointer));
}
// Deal with potential mismatches in arguments types. Passing an array to a
@@ -879,19 +874,9 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
hlfir::Entity actual = preparedActual.getActual(loc, builder);
// Handles the procedure pointer actual/dummy arguments.
- // It could have a combination of
- // acutal dummy
- // 2. procedure pointer procedure pointer
- // 3. procedure pointer procedure
- // 4. procedure procedure pointer
- if (hlfir::isBoxProcAddressType(actual.getType()) ||
- hlfir::isBoxProcAddressType(dummyType)) {
- if (actual.getType() != dummyType &&
- hlfir::isBoxProcAddressType(actual.getType())) {
- auto baseAddr{actual.getFirBase()};
- actual = hlfir::Entity{builder.create<fir::LoadOp>(loc, baseAddr)};
- }
+ if (actual.isProcedurePointer() || hlfir::isBoxProcAddressType(dummyType)) {
return PreparedDummyArgument{actual, /*cleanups=*/{}};
+ // TODO {loc, "procedure to procedure pointer argument passing");
}
// Do nothing if this is a procedure argument. It is already a
diff --git a/flang/lib/Lower/ConvertExprToHLFIR.cpp b/flang/lib/Lower/ConvertExprToHLFIR.cpp
index 5a51493c9aaa5d4..b114fbe1a13a26b 100644
--- a/flang/lib/Lower/ConvertExprToHLFIR.cpp
+++ b/flang/lib/Lower/ConvertExprToHLFIR.cpp
@@ -1425,7 +1425,9 @@ class HlfirBuilder {
}
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>
diff --git a/flang/lib/Lower/ConvertProcedureDesignator.cpp b/flang/lib/Lower/ConvertProcedureDesignator.cpp
index b02fb3eb38141c8..240645023e27ffc 100644
--- a/flang/lib/Lower/ConvertProcedureDesignator.cpp
+++ b/flang/lib/Lower/ConvertProcedureDesignator.cpp
@@ -11,6 +11,7 @@
#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"
@@ -129,3 +130,15 @@ hlfir::EntityWithAttributes Fortran::lower::convertProcedureDesignatorToHLFIR(
[funcAddr](const auto &) { return funcAddr; });
return hlfir::EntityWithAttributes{res};
}
+
+mlir::Value Fortran::lower::convertProcedureDesignatorToAddress(
+ Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ mlir::Type boxType, Fortran::lower::StatementContext &stmtCtx,
+ const Fortran::semantics::Symbol *sym) {
+ Fortran::lower::SymMap globalOpSymMap;
+ 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()));
+}
diff --git a/flang/lib/Lower/ConvertType.cpp b/flang/lib/Lower/ConvertType.cpp
index dbcaaced169ce3c..72f1ee7a2cb2baa 100644
--- a/flang/lib/Lower/ConvertType.cpp
+++ b/flang/lib/Lower/ConvertType.cpp
@@ -251,7 +251,8 @@ struct TypeBuilderImpl {
if (Fortran::semantics::IsProcedurePointer(ultimate)) {
Fortran::evaluate::ProcedureDesignator proc(ultimate);
- return Fortran::lower::translateSignature(proc, converter);
+ auto procTy{Fortran::lower::translateSignature(proc, converter)};
+ return fir::BoxProcType::get(context, procTy);
}
if (const Fortran::semantics::DeclTypeSpec *type = ultimate.GetType()) {
diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index e54406f031fb963..c2107534278c057 100644
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -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,21 +480,6 @@ static fir::GlobalOp defineGlobal(Fortran::lower::AbstractConverter &converter,
if (global && globalIsInitialized(global))
return global;
- if (Fortran::semantics::IsProcedurePointer(sym)) {
- auto boxProcTy{Fortran::lower::getUntypedBoxProcType(builder.getContext())};
- global = builder.createGlobal(loc, boxProcTy, globalName, linkage,
- mlir::Attribute{}, isConst, var.isTarget());
- Fortran::lower::createGlobalInitialization(
- builder, global, [&](fir::FirOpBuilder &builder) {
- mlir::Value initVal{builder.create<fir::ZeroOp>(loc, symTy)};
- auto emBoxVal{
- builder.create<fir::EmboxProcOp>(loc, boxProcTy, initVal)};
- builder.create<fir::HasValueOp>(loc, emBoxVal);
- });
- global.setVisibility(mlir::SymbolTable::Visibility::Public);
- return global;
- }
-
// If this is an array, check to see if we can use a dense attribute
// with a tensor mlir type. This optimization currently only supports
// Fortran arrays of integer, real, complex, or logical. The tensor
@@ -516,10 +502,19 @@ 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 (!global) {
+ if (Fortran::semantics::IsProcedurePointer(sym)) {
+ auto nullBoxProcTy{
+ Fortran::lower::getUntypedBoxProcType(builder.getContext())};
+ global = builder.createGlobal(loc, nullBoxProcTy, globalName, linkage,
+ mlir::Attribute{}, isConst, var.isTarget());
+ } else {
+ global = builder.createGlobal(loc, symTy, globalName, linkage,
+ mlir::Attribute{}, isConst, var.isTarget());
+ }
+ }
+ if (Fortran::semantics::IsAllocatableOrPointer(sym) &&
+ !Fortran::semantics::IsProcedure(sym)) {
const auto *details =
sym.detailsIf<Fortran::semantics::ObjectEntityDetails>();
if (details && details->init()) {
@@ -539,7 +534,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()) {
@@ -564,10 +558,38 @@ 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::convertProcedureDesignatorToAddress(
+ converter, loc, symTy, stmtCtx, sym)};
+ b.create<fir::HasValueOp>(loc, box);
+ });
+ 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)
@@ -663,12 +685,9 @@ static mlir::Value createNewLocal(Fortran::lower::AbstractConverter &converter,
return builder.allocateLocal(loc, ty, nm, symNm, shape, lenParams, isTarg);
// Local procedure pointer.
- auto boxProcTy{Fortran::lower::getUntypedBoxProcType(builder.getContext())};
- auto res{builder.allocateLocal(loc, boxProcTy, nm, symNm, shape, lenParams,
- isTarg)};
- mlir::Value initVal{builder.create<fir::ZeroOp>(loc, ty)};
- auto emBoxVal{builder.create<fir::EmboxProcOp>(loc, boxProcTy, initVal)};
- builder.create<fir::StoreOp>(loc, emBoxVal, res);
+ 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;
}
diff --git a/flang/lib/Optimizer/Builder/FIRBuilder.cpp b/flang/lib/Optimizer/Builder/FIRBuilder.cpp
index c6d632036c82e96..df42dc8a3d0c8ba 100644
--- a/flang/lib/Optimizer/Builder/FIRBuilder.cpp
+++ b/flang/lib/Optimizer/Builder/FIRBuilder.cpp
@@ -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);
+}
diff --git a/flang/lib/Optimizer/Builder/HLFIRTools.cpp b/flang/lib/Optimizer/Builder/HLFIRTools.cpp
index 3d0a59b468ba791..88d3f15deb9b3b8 100644
--- a/flang/lib/Optimizer/Builder/HLFIRTools.cpp
+++ b/flang/lib/Optimizer/Builder/HLFIRTools.cpp
@@ -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;
}
>From ac2abc009941a946dcd9e67c33e9f90c9b8a7934 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Sat, 11 Nov 2023 00:13:41 -0500
Subject: [PATCH 04/17] [Flang] Handle procedure pointer actual to procedure
dummy argument passing.
---
flang/lib/Lower/ConvertCall.cpp | 18 ++++++++++++++----
1 file changed, 14 insertions(+), 4 deletions(-)
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index af07990c0c3c4bb..14c9ee85bd612fb 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -873,15 +873,23 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
// element if this is an array in an elemental call.
hlfir::Entity actual = preparedActual.getActual(loc, builder);
- // Handles the procedure pointer actual/dummy arguments.
- if (actual.isProcedurePointer() || hlfir::isBoxProcAddressType(dummyType)) {
- return PreparedDummyArgument{actual, /*cleanups=*/{}};
- // TODO {loc, "procedure to procedure pointer argument passing");
+ // Handles the procedure pointer actual arguments.
+ if (actual.isProcedurePointer()) {
+ if (hlfir::isBoxProcAddressType(dummyType))
+ // Procedure pointer actual to procedure pointer dummy.
+ return PreparedDummyArgument{actual, /*cleanups=*/{}};
+ if (hlfir::isFortranProcedureValue(dummyType)) {
+ // Procedure pointer actual to procedure dummy.
+ actual = hlfir::derefPointersAndAllocatables(loc, builder, actual);
+ return PreparedDummyArgument{actual, /*cleanups=*/{}};
+ }
}
// Do nothing if this is a procedure argument. It is already a
// fir.boxproc/fir.tuple<fir.boxproc, len> as it should.
if (actual.isProcedure()) {
+ if (hlfir::isBoxProcAddressType(dummyType))
+ TODO(loc, "procedure to procedure pointer argument passing");
if (actual.getType() != dummyType)
actual = fixProcedureDummyMismatch(loc, builder, actual, dummyType);
return PreparedDummyArgument{actual, /*cleanups=*/{}};
@@ -1183,6 +1191,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);
>From af38724955fee96dc3e7e7e2c3e20afa254bfb49 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Sat, 11 Nov 2023 11:00:49 -0500
Subject: [PATCH 05/17] [Flang] Remove some leftover code from the 3rd commit.
---
flang/lib/Lower/ConvertVariable.cpp | 11 ++---------
1 file changed, 2 insertions(+), 9 deletions(-)
diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index c2107534278c057..88a7fb7154e5621 100644
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -503,15 +503,8 @@ static fir::GlobalOp defineGlobal(Fortran::lower::AbstractConverter &converter,
}
}
if (!global) {
- if (Fortran::semantics::IsProcedurePointer(sym)) {
- auto nullBoxProcTy{
- Fortran::lower::getUntypedBoxProcType(builder.getContext())};
- global = builder.createGlobal(loc, nullBoxProcTy, globalName, linkage,
- mlir::Attribute{}, isConst, var.isTarget());
- } else {
- global = builder.createGlobal(loc, symTy, globalName, linkage,
- mlir::Attribute{}, isConst, var.isTarget());
- }
+ global = builder.createGlobal(loc, symTy, globalName, linkage,
+ mlir::Attribute{}, isConst, var.isTarget());
}
if (Fortran::semantics::IsAllocatableOrPointer(sym) &&
!Fortran::semantics::IsProcedure(sym)) {
>From 4fec0ade18f8ced3afb6270df18164fe6dc1cbd4 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Sat, 11 Nov 2023 11:02:21 -0500
Subject: [PATCH 06/17] [Flang] minor clean up.
---
flang/lib/Lower/ConvertVariable.cpp | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index 88a7fb7154e5621..679b80dd4c2a5f8 100644
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -502,10 +502,9 @@ static fir::GlobalOp defineGlobal(Fortran::lower::AbstractConverter &converter,
}
}
}
- if (!global) {
+ if (!global)
global = builder.createGlobal(loc, symTy, globalName, linkage,
mlir::Attribute{}, isConst, var.isTarget());
- }
if (Fortran::semantics::IsAllocatableOrPointer(sym) &&
!Fortran::semantics::IsProcedure(sym)) {
const auto *details =
>From 43d8f2ad373797419ee9c3faa57bd5c3e83d0d28 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Sat, 11 Nov 2023 23:27:48 -0500
Subject: [PATCH 07/17] [Flang] Handle procedure actual to procedure pointer
dummy.
---
flang/lib/Lower/ConvertCall.cpp | 11 +++++++++--
1 file changed, 9 insertions(+), 2 deletions(-)
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index 14c9ee85bd612fb..058def204af0ac4 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -32,7 +32,9 @@
#include "mlir/IR/IRMapping.h"
#include "llvm/Support/CommandLine.h"
#include "llvm/Support/Debug.h"
+#include <iostream>
#include <optional>
+using namespace std;
#define DEBUG_TYPE "flang-lower-expr"
@@ -888,8 +890,13 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
// Do nothing if this is a procedure argument. It is already a
// fir.boxproc/fir.tuple<fir.boxproc, len> as it should.
if (actual.isProcedure()) {
- if (hlfir::isBoxProcAddressType(dummyType))
- TODO(loc, "procedure to procedure pointer argument passing");
+ if (hlfir::isBoxProcAddressType(dummyType)) {
+ // Procedure actual to procedure pointer dummy.
+ auto proc{fir::getBase(actual)};
+ auto tempBoxProc{builder.createTemporary(loc, proc.getType())};
+ builder.create<fir::StoreOp>(loc, actual, tempBoxProc);
+ return PreparedDummyArgument{tempBoxProc, /*cleanups=*/{}};
+ }
if (actual.getType() != dummyType)
actual = fixProcedureDummyMismatch(loc, builder, actual, dummyType);
return PreparedDummyArgument{actual, /*cleanups=*/{}};
>From 670e527a64b3267225c8c5d8f367d47a838ea719 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Sat, 11 Nov 2023 23:39:14 -0500
Subject: [PATCH 08/17] [Flang] Minor clean up and revise the comments a bit.
---
flang/lib/Lower/ConvertCall.cpp | 5 ++---
1 file changed, 2 insertions(+), 3 deletions(-)
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index 058def204af0ac4..55337665fb135a5 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -32,9 +32,7 @@
#include "mlir/IR/IRMapping.h"
#include "llvm/Support/CommandLine.h"
#include "llvm/Support/Debug.h"
-#include <iostream>
#include <optional>
-using namespace std;
#define DEBUG_TYPE "flang-lower-expr"
@@ -177,7 +175,8 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
std::tie(funcPointer, charFuncPointerLength) =
fir::factory::extractCharacterProcedureTuple(builder, loc,
funcPointer);
- // RHS is a procedure pointer. Load its value.
+ // Reference to a procedure pointer. Load its value, the address of the
+ // procedure it poiints to.
if (Fortran::semantics::IsProcedurePointer(sym))
funcPointer = builder.create<fir::LoadOp>(loc, funcPointer);
}
>From 32cb9b43d495ae71fe77985587c1cba48048933f Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Sun, 12 Nov 2023 11:18:10 -0500
Subject: [PATCH 09/17] [Flang] Use PassEntityBy::BoxProcRef for procedure
pointer.
---
flang/include/flang/Lower/CallInterface.h | 6 ++--
flang/lib/Lower/CallInterface.cpp | 44 ++++++++++++-----------
flang/lib/Lower/ConvertCall.cpp | 1 +
flang/lib/Lower/ConvertExpr.cpp | 3 ++
4 files changed, 31 insertions(+), 23 deletions(-)
diff --git a/flang/include/flang/Lower/CallInterface.h b/flang/include/flang/Lower/CallInterface.h
index 579bdcfd8988792..c7dca4f8f1348e0 100644
--- a/flang/include/flang/Lower/CallInterface.h
+++ b/flang/include/flang/Lower/CallInterface.h
@@ -111,7 +111,8 @@ class CallInterface {
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 @@ class CallInterface {
CharProcTuple,
Box,
MutableBox,
- Value
+ Value,
+ BoxProcRef
};
using FortranEntity = typename PassedEntityTypes<T>::FortranEntity;
diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
index 4b38ec488a439f0..0dd9289acee55d6 100644
--- a/flang/lib/Lower/CallInterface.cpp
+++ b/flang/lib/Lower/CallInterface.cpp
@@ -1063,28 +1063,30 @@ class Fortran::lower::CallInterfaceImpl {
proc.procedure.value();
mlir::Type funcType =
getProcedureDesignatorType(&procedure, interface.converter);
- if (proc.attrs.test(
- Fortran::evaluate::characteristics::DummyProcedure::Attr::Pointer))
+ if (proc.attrs.test(Fortran::evaluate::characteristics::DummyProcedure::
+ Attr::Pointer)) {
+ // Prodecure pointer dummy argument.
funcType = fir::ReferenceType::get(funcType);
- else { // Otherwise, it is a dummy procedure.
- std::optional<Fortran::evaluate::DynamicType> resultTy =
- getResultDynamicType(procedure);
- if (resultTy && mustPassLengthWithDummyProcedure(procedure)) {
- // The result length of dummy procedures that are character functions
- // must be passed so that the dummy procedure can be called if it has
- // assumed length on the callee side.
- mlir::Type tupleType =
- fir::factory::getCharacterProcedureTupleType(funcType);
- llvm::StringRef charProcAttr =
- fir::getCharacterProcedureDummyAttrName();
- addFirOperand(tupleType, nextPassedArgPosition(),
- Property::CharProcTuple,
- {mlir::NamedAttribute{
- mlir::StringAttr::get(&mlirContext, charProcAttr),
- mlir::UnitAttr::get(&mlirContext)}});
- addPassedArg(PassEntityBy::CharProcTuple, entity, characteristics);
- return;
- }
+ 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)) {
+ // The result length of dummy procedures that are character functions
+ // must be passed so that the dummy procedure can be called if it has
+ // assumed length on the callee side.
+ mlir::Type tupleType =
+ fir::factory::getCharacterProcedureTupleType(funcType);
+ llvm::StringRef charProcAttr = fir::getCharacterProcedureDummyAttrName();
+ addFirOperand(tupleType, nextPassedArgPosition(), Property::CharProcTuple,
+ {mlir::NamedAttribute{
+ mlir::StringAttr::get(&mlirContext, charProcAttr),
+ mlir::UnitAttr::get(&mlirContext)}});
+ addPassedArg(PassEntityBy::CharProcTuple, entity, characteristics);
+ return;
}
addFirOperand(funcType, nextPassedArgPosition(), Property::BaseAddress);
addPassedArg(PassEntityBy::BaseAddress, entity, characteristics);
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index 55337665fb135a5..0d3b6b17c922531 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -1181,6 +1181,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,
diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp
index 8c2318632f725b1..da2b32ac8226855 100644
--- a/flang/lib/Lower/ConvertExpr.cpp
+++ b/flang/lib/Lower/ConvertExpr.cpp
@@ -4845,6 +4845,9 @@ class ArrayExprLowering {
}
// See C15100 and C15101
fir::emitFatalError(loc, "cannot be POINTER, ALLOCATABLE");
+ case PassBy::BoxProcRef:
+ // Procedure pointer: no action here.
+ break;
}
}
>From 4cec00806dc5e2e965e9b103b286d5e318077eb9 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Sun, 12 Nov 2023 22:47:39 -0500
Subject: [PATCH 10/17] [Flang] Fix an oversight error that cuased LIT test
failures.
---
flang/lib/Lower/Bridge.cpp | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index a10701e0fa68b5d..a25f829413917fa 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -3242,7 +3242,7 @@ class FirConverter : public Fortran::lower::AbstractConverter {
const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {
Fortran::lower::StatementContext stmtCtx;
- if (Fortran::evaluate::IsProcedurePointerTarget(assign.rhs)) {
+ if (Fortran::evaluate::IsProcedurePointer(assign.lhs)) {
hlfir::Entity lhs = Fortran::lower::convertExprToHLFIR(
loc, *this, assign.lhs, localSymbols, stmtCtx);
if (Fortran::evaluate::IsNullProcedurePointer(assign.rhs)) {
>From 3eb8d079314d6c75c5868e8c8089f2f28da37609 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Mon, 13 Nov 2023 13:37:53 -0500
Subject: [PATCH 11/17] [Flang] To address review comments.
---
.../flang/Lower/ConvertProcedureDesignator.h | 7 +++----
flang/lib/Lower/Bridge.cpp | 3 ++-
flang/lib/Lower/CallInterface.cpp | 11 ++++++++---
flang/lib/Lower/ConvertCall.cpp | 16 +++++++++++-----
flang/lib/Lower/ConvertProcedureDesignator.cpp | 8 ++++----
flang/lib/Lower/ConvertVariable.cpp | 8 ++++++--
6 files changed, 34 insertions(+), 19 deletions(-)
diff --git a/flang/include/flang/Lower/ConvertProcedureDesignator.h b/flang/include/flang/Lower/ConvertProcedureDesignator.h
index b0d422b8c3ff88d..ae772c52e425bc1 100644
--- a/flang/include/flang/Lower/ConvertProcedureDesignator.h
+++ b/flang/include/flang/Lower/ConvertProcedureDesignator.h
@@ -57,9 +57,8 @@ hlfir::EntityWithAttributes convertProcedureDesignatorToHLFIR(
/// Generate initialization for procedure pointer to procedure target.
mlir::Value
-convertProcedureDesignatorToAddress(Fortran::lower::AbstractConverter &,
- mlir::Location, mlir::Type boxType,
- Fortran::lower::StatementContext &stmtCtx,
- const Fortran::semantics::Symbol *sym);
+convertProcedureDesignatorInitialTarget(Fortran::lower::AbstractConverter &,
+ mlir::Location,
+ const Fortran::semantics::Symbol &sym);
} // namespace Fortran::lower
#endif // FORTRAN_LOWER_CONVERT_PROCEDURE_DESIGNATOR_H
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index a25f829413917fa..e23e16b9a401251 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -3242,6 +3242,8 @@ class FirConverter : public Fortran::lower::AbstractConverter {
const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {
Fortran::lower::StatementContext stmtCtx;
+ 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);
@@ -3254,7 +3256,6 @@ class FirConverter : public Fortran::lower::AbstractConverter {
}
hlfir::Entity rhs(getBase(Fortran::lower::convertExprToAddress(
loc, *this, assign.rhs, localSymbols, stmtCtx)));
- rhs = hlfir::derefPointersAndAllocatables(loc, *builder, rhs);
builder->createStoreWithConvert(loc, rhs, lhs);
return;
}
diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
index 0dd9289acee55d6..b1420dcb25a1145 100644
--- a/flang/lib/Lower/CallInterface.cpp
+++ b/flang/lib/Lower/CallInterface.cpp
@@ -1059,6 +1059,11 @@ class Fortran::lower::CallInterfaceImpl {
const DummyCharacteristics *characteristics,
const Fortran::evaluate::characteristics::DummyProcedure &proc,
const FortranEntity &entity) {
+ if (!interface.converter.getLoweringOptions().getLowerToHighLevelFIR() &&
+ proc.attrs.test(
+ Fortran::evaluate::characteristics::DummyProcedure::Attr::Pointer))
+ TODO(interface.converter.getCurrentLocation(),
+ "procedure pointer arguments");
const Fortran::evaluate::characteristics::Procedure &procedure =
proc.procedure.value();
mlir::Type funcType =
@@ -1075,9 +1080,9 @@ class Fortran::lower::CallInterfaceImpl {
std::optional<Fortran::evaluate::DynamicType> resultTy =
getResultDynamicType(procedure);
if (resultTy && mustPassLengthWithDummyProcedure(procedure)) {
- // The result length of dummy procedures that are character functions
- // must be passed so that the dummy procedure can be called if it has
- // assumed length on the callee side.
+ // The result length of dummy procedures that are character functions must
+ // be passed so that the dummy procedure can be called if it has assumed
+ // length on the callee side.
mlir::Type tupleType =
fir::factory::getCharacterProcedureTupleType(funcType);
llvm::StringRef charProcAttr = fir::getCharacterProcedureDummyAttrName();
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index 0d3b6b17c922531..8eac78b63f7caaf 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -32,7 +32,9 @@
#include "mlir/IR/IRMapping.h"
#include "llvm/Support/CommandLine.h"
#include "llvm/Support/Debug.h"
+#include <iostream>
#include <optional>
+using namespace std;
#define DEBUG_TYPE "flang-lower-expr"
@@ -176,7 +178,7 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
fir::factory::extractCharacterProcedureTuple(builder, loc,
funcPointer);
// Reference to a procedure pointer. Load its value, the address of the
- // procedure it poiints to.
+ // procedure it points to.
if (Fortran::semantics::IsProcedurePointer(sym))
funcPointer = builder.create<fir::LoadOp>(loc, funcPointer);
}
@@ -890,9 +892,11 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
// fir.boxproc/fir.tuple<fir.boxproc, len> as it should.
if (actual.isProcedure()) {
if (hlfir::isBoxProcAddressType(dummyType)) {
+ if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(expr)) {
+ cout << " AAA" << endl;
+ }
// Procedure actual to procedure pointer dummy.
- auto proc{fir::getBase(actual)};
- auto tempBoxProc{builder.createTemporary(loc, proc.getType())};
+ auto tempBoxProc{builder.createTemporary(loc, actual.getType())};
builder.create<fir::StoreOp>(loc, actual, tempBoxProc);
return PreparedDummyArgument{tempBoxProc, /*cleanups=*/{}};
}
@@ -2175,8 +2179,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");
diff --git a/flang/lib/Lower/ConvertProcedureDesignator.cpp b/flang/lib/Lower/ConvertProcedureDesignator.cpp
index 240645023e27ffc..390e3d37bdc99b4 100644
--- a/flang/lib/Lower/ConvertProcedureDesignator.cpp
+++ b/flang/lib/Lower/ConvertProcedureDesignator.cpp
@@ -131,12 +131,12 @@ hlfir::EntityWithAttributes Fortran::lower::convertProcedureDesignatorToHLFIR(
return hlfir::EntityWithAttributes{res};
}
-mlir::Value Fortran::lower::convertProcedureDesignatorToAddress(
+mlir::Value Fortran::lower::convertProcedureDesignatorInitialTarget(
Fortran::lower::AbstractConverter &converter, mlir::Location loc,
- mlir::Type boxType, Fortran::lower::StatementContext &stmtCtx,
- const Fortran::semantics::Symbol *sym) {
+ const Fortran::semantics::Symbol &sym) {
Fortran::lower::SymMap globalOpSymMap;
- Fortran::evaluate::ProcedureDesignator proc(*sym);
+ 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(
diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index 679b80dd4c2a5f8..676b01dda4c847e 100644
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -480,6 +480,10 @@ static fir::GlobalOp defineGlobal(Fortran::lower::AbstractConverter &converter,
if (global && globalIsInitialized(global))
return global;
+ 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
// with a tensor mlir type. This optimization currently only supports
// Fortran arrays of integer, real, complex, or logical. The tensor
@@ -559,8 +563,8 @@ static fir::GlobalOp defineGlobal(Fortran::lower::AbstractConverter &converter,
builder, global, [&](fir::FirOpBuilder &b) {
Fortran::lower::StatementContext stmtCtx(
/*cleanupProhibited=*/true);
- auto box{Fortran::lower::convertProcedureDesignatorToAddress(
- converter, loc, symTy, stmtCtx, sym)};
+ auto box{Fortran::lower::convertProcedureDesignatorInitialTarget(
+ converter, loc, *sym)};
b.create<fir::HasValueOp>(loc, box);
});
else { // Has NULL() target.
>From aaa7e0f31a44cb118ea5fc73274cb704ccd412a9 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Mon, 13 Nov 2023 15:02:16 -0500
Subject: [PATCH 12/17] [Flang] Fix some unintended debug code.
---
flang/lib/Lower/ConvertCall.cpp | 5 -----
1 file changed, 5 deletions(-)
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index 8eac78b63f7caaf..0843cd4a60c61da 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -32,9 +32,7 @@
#include "mlir/IR/IRMapping.h"
#include "llvm/Support/CommandLine.h"
#include "llvm/Support/Debug.h"
-#include <iostream>
#include <optional>
-using namespace std;
#define DEBUG_TYPE "flang-lower-expr"
@@ -892,9 +890,6 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
// fir.boxproc/fir.tuple<fir.boxproc, len> as it should.
if (actual.isProcedure()) {
if (hlfir::isBoxProcAddressType(dummyType)) {
- if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(expr)) {
- cout << " AAA" << endl;
- }
// Procedure actual to procedure pointer dummy.
auto tempBoxProc{builder.createTemporary(loc, actual.getType())};
builder.create<fir::StoreOp>(loc, actual, tempBoxProc);
>From 1e1b13990bbea2310f3a4107736b55f143c6b628 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Mon, 13 Nov 2023 22:24:38 -0500
Subject: [PATCH 13/17] [Flang] Handle reference to null() as actual argument
to procedure pointer dummy.
---
flang/lib/Lower/ConvertCall.cpp | 24 ++++++++++++++++++------
1 file changed, 18 insertions(+), 6 deletions(-)
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index 0843cd4a60c61da..75947c335c23208 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -874,27 +874,39 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
// element if this is an array in an elemental call.
hlfir::Entity actual = preparedActual.getActual(loc, builder);
- // Handles the procedure pointer actual arguments.
+ // Handle the procedure pointer actual arguments.
if (actual.isProcedurePointer()) {
+ // Procedure pointer actual to procedure pointer dummy.
if (hlfir::isBoxProcAddressType(dummyType))
- // Procedure pointer actual to procedure pointer dummy.
return PreparedDummyArgument{actual, /*cleanups=*/{}};
+ // Procedure pointer actual to procedure dummy.
if (hlfir::isFortranProcedureValue(dummyType)) {
- // Procedure pointer actual to procedure dummy.
actual = hlfir::derefPointersAndAllocatables(loc, builder, actual);
return PreparedDummyArgument{actual, /*cleanups=*/{}};
}
}
- // Do nothing if this is a procedure argument. It is already a
- // fir.boxproc/fir.tuple<fir.boxproc, len> as it should.
+ // 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)) {
- // Procedure actual to procedure pointer dummy.
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=*/{}};
>From 5718608b366f834fdbcd1974087fa8c2544f12cc Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Tue, 14 Nov 2023 12:40:04 -0500
Subject: [PATCH 14/17] [Flang] Address the review comment.
---
flang/lib/Lower/ConvertProcedureDesignator.cpp | 8 +++++---
1 file changed, 5 insertions(+), 3 deletions(-)
diff --git a/flang/lib/Lower/ConvertProcedureDesignator.cpp b/flang/lib/Lower/ConvertProcedureDesignator.cpp
index 390e3d37bdc99b4..c36e61987f505bb 100644
--- a/flang/lib/Lower/ConvertProcedureDesignator.cpp
+++ b/flang/lib/Lower/ConvertProcedureDesignator.cpp
@@ -99,9 +99,11 @@ 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) {
- if (std::optional<fir::FortranVariableOpInterface> varDef =
- symMap.lookupVariableDefinition(*proc.GetSymbol()))
- return *varDef;
+ const auto *sym = proc.GetSymbol();
+ if (sym)
+ if (std::optional<fir::FortranVariableOpInterface> varDef =
+ symMap.lookupVariableDefinition(*sym))
+ return *varDef;
fir::ExtendedValue procExv =
convertProcedureDesignator(loc, converter, proc, symMap, stmtCtx);
>From 76db05373865b62f1a3311d2ee612aed1fdf88fc Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Tue, 14 Nov 2023 13:26:17 -0500
Subject: [PATCH 15/17] [Flang] Cast the init target to the decl type of
procedure pointer.
---
flang/lib/Lower/ConvertVariable.cpp | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index 676b01dda4c847e..d4f738e5dae116f 100644
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -565,7 +565,8 @@ static fir::GlobalOp defineGlobal(Fortran::lower::AbstractConverter &converter,
/*cleanupProhibited=*/true);
auto box{Fortran::lower::convertProcedureDesignatorInitialTarget(
converter, loc, *sym)};
- b.create<fir::HasValueOp>(loc, box);
+ auto castTo{builder.createConvert(loc, symTy, box)};
+ b.create<fir::HasValueOp>(loc, castTo);
});
else { // Has NULL() target.
Fortran::lower::createGlobalInitialization(
>From 1c14cd98149fc8ecdf2cd4b393d3f07b7c574237 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Thu, 16 Nov 2023 11:18:45 -0500
Subject: [PATCH 16/17] [Flang] Add a couple of TODOs for unsupported procedure
pointer usages.
---
flang/lib/Lower/ConvertCall.cpp | 2 ++
flang/lib/Lower/ConvertProcedureDesignator.cpp | 6 +++++-
2 files changed, 7 insertions(+), 1 deletion(-)
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index 75947c335c23208..395a98b43d53793 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -1532,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(
diff --git a/flang/lib/Lower/ConvertProcedureDesignator.cpp b/flang/lib/Lower/ConvertProcedureDesignator.cpp
index c36e61987f505bb..84e04b0a65f447e 100644
--- a/flang/lib/Lower/ConvertProcedureDesignator.cpp
+++ b/flang/lib/Lower/ConvertProcedureDesignator.cpp
@@ -17,6 +17,7 @@
#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,
@@ -100,10 +101,13 @@ hlfir::EntityWithAttributes Fortran::lower::convertProcedureDesignatorToHLFIR(
const Fortran::evaluate::ProcedureDesignator &proc,
Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
const auto *sym = proc.GetSymbol();
- if (sym)
+ 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);
>From 222080852426c6303257816bdcc2d346dfa3b152 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Mon, 20 Nov 2023 13:04:42 -0500
Subject: [PATCH 17/17] [Flang] Add LIT test for procedure pointer.
---
flang/test/Lower/HLFIR/procedure-pointer.f90 | 279 +++++++++++++++++++
1 file changed, 279 insertions(+)
create mode 100644 flang/test/Lower/HLFIR/procedure-pointer.f90
diff --git a/flang/test/Lower/HLFIR/procedure-pointer.f90 b/flang/test/Lower/HLFIR/procedure-pointer.f90
new file mode 100644
index 000000000000000..35a95651bb34f8b
--- /dev/null
+++ b/flang/test/Lower/HLFIR/procedure-pointer.f90
@@ -0,0 +1,279 @@
+! 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
+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: }
More information about the flang-commits
mailing list