shylie/llvm-project
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

[flang] Lower procedure pointer components (#75453)

Browse Source 
Lower procedure pointer components, except in the context of structure
constructor (left TODO).

Procedure pointer components lowering share most of the lowering logic
of procedure poionters with the following particularities:
- They are components, so an hlfir.designate must be generated to
retrieve the procedure pointer address from its derived type base.
- They may have a PASS argument. While there is no dispatching as with
type bound procedure, special care must be taken to retrieve the derived
type component base in this case since semantics placed it in the
argument list and not in the evaluate::ProcedureDesignator.

These components also bring a new level of recursive MLIR types since a
fir.type may now contain a component with an MLIR function type where
one of the argument is the fir.type itself. This required moving the
"derived type in construction" stackto the converter so that the object
and function type lowering utilities share the same state (currently the
function type utilty would end-up creating a new stack when lowering its
arguments, leading to infinite loops). The BoxedProcedurePass also
needed an update to deal with this recursive aspect.
This commit is contained in:
jeanPerier 2023-12-19 17:17:09 +01:00 committed by GitHub
parent 747061f9ba
commit c373f58134
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
19 changed files with 441 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -58,6 +58,8 @@ struct Variable;
using SomeExpr = Fortran::evaluate::Expr<Fortran::evaluate::SomeType>;
using SymbolRef = Fortran::common::Reference<const Fortran::semantics::Symbol>;
using TypeConstructionStack =
llvm::SmallVector<std::pair<const Fortran::lower::SymbolRef, mlir::Type>>;
class StatementContext;
using ExprToValueMap = llvm::DenseMap<const SomeExpr *, mlir::Value>;
@ -231,6 +233,10 @@ public:
const Fortran::semantics::DerivedTypeSpec &typeSpec,
fir::RecordType type) = 0;
/// Get stack of derived type in construction. This is an internal entry point
/// for the type conversion utility to allow lowering recursive derived types.
virtual TypeConstructionStack &getTypeConstructionStack() = 0;
//===--------------------------------------------------------------------===//
// Locations
//===--------------------------------------------------------------------===//

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

@ -303,6 +303,11 @@ public:
/// index.
std::optional<unsigned> getPassArgIndex() const;
/// Get the passed-object if any. Crashes if there is a passed object
/// but it was not placed in the inputs yet. Return a null value
/// otherwise.
mlir::Value getIfPassedArg() const;
/// Return the procedure symbol if this is a call to a user defined
/// procedure.
const Fortran::semantics::Symbol *getProcedureSymbol() const;
@ -314,8 +319,8 @@ public:
mlir::Value addr, mlir::Value len);
/// If this is a call to a procedure pointer or dummy, returns the related
/// symbol. Nullptr otherwise.
const Fortran::semantics::Symbol *getIfIndirectCallSymbol() const;
/// procedure designator. Nullptr otherwise.
const Fortran::evaluate::ProcedureDesignator *getIfIndirectCall() const;
/// Get the input vector once it is complete.
llvm::ArrayRef<mlir::Value> getInputs() const {

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

@ -60,5 +60,13 @@ mlir::Value
convertProcedureDesignatorInitialTarget(Fortran::lower::AbstractConverter &,
mlir::Location,
const Fortran::semantics::Symbol &sym);
/// Given the value of a "PASS" actual argument \p passedArg and the
/// evaluate::ProcedureDesignator for the call, address and dereference
/// the argument's procedure pointer component that must be called.
mlir::Value derefPassProcPointerComponent(
mlir::Location loc, Fortran::lower::AbstractConverter &converter,
const Fortran::evaluate::ProcedureDesignator &proc, mlir::Value passedArg,
Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx);
} // namespace Fortran::lower
#endif // FORTRAN_LOWER_CONVERT_PROCEDURE_DESIGNATOR_H

8
flang/include/flang/Optimizer/Support/InternalNames.h
View File

@ -156,6 +156,14 @@ struct NameUniquer {
static std::string
getTypeDescriptorBindingTableName(llvm::StringRef mangledTypeName);
/// Remove markers that have been added when doing partial type
/// conversions. mlir::Type cannot be mutated in a pass, so new
/// fir::RecordType must be created when lowering member types.
/// Suffixes added to these new types are meaningless and are
/// dropped in the names passed to LLVM.
static llvm::StringRef
dropTypeConversionMarkers(llvm::StringRef mangledTypeName);
private:
static std::string intAsString(std::int64_t i);
static std::string doKind(std::int64_t kind);

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

@ -170,25 +170,22 @@ public:
if (seen.contains(typeInfoSym))
return;
seen.insert(typeInfoSym);
if (!skipRegistration) {
registeredTypeInfo.emplace_back(
TypeInfo{typeInfoSym, typeSpec, type, loc});
return;
}
// Once the registration is closed, symbols cannot be added to the
// registeredTypeInfoSymbols list because it may be iterated over.
// However, after registration is closed, it is safe to directly generate
// the globals because all FuncOps whose addresses may be required by the
// initializers have been generated.
createTypeInfoOpAndGlobal(converter,
TypeInfo{typeInfoSym, typeSpec, type, loc});
currentTypeInfoStack->emplace_back(
TypeInfo{typeInfoSym, typeSpec, type, loc});
return;
}
void createTypeInfo(Fortran::lower::AbstractConverter &converter) {
skipRegistration = true;
for (const TypeInfo &info : registeredTypeInfo)
createTypeInfoOpAndGlobal(converter, info);
registeredTypeInfo.clear();
while (!registeredTypeInfoA.empty()) {
currentTypeInfoStack = &registeredTypeInfoB;
for (const TypeInfo &info : registeredTypeInfoA)
createTypeInfoOpAndGlobal(converter, info);
registeredTypeInfoA.clear();
currentTypeInfoStack = &registeredTypeInfoA;
for (const TypeInfo &info : registeredTypeInfoB)
createTypeInfoOpAndGlobal(converter, info);
registeredTypeInfoB.clear();
}
}
private:
@ -249,11 +246,12 @@ private:
}
/// Store the front-end data that will be required to generate the type info
/// for the derived types that have been converted to fir.type<>.
llvm::SmallVector<TypeInfo> registeredTypeInfo;
/// Create derived type info immediately without storing the
/// symbol in registeredTypeInfo.
bool skipRegistration = false;
/// for the derived types that have been converted to fir.type<>. There are
/// two stacks since the type info may visit new types, so the new types must
/// be added to a new stack.
llvm::SmallVector<TypeInfo> registeredTypeInfoA;
llvm::SmallVector<TypeInfo> registeredTypeInfoB;
llvm::SmallVector<TypeInfo> *currentTypeInfoStack = &registeredTypeInfoA;
/// Track symbols symbols processed during and after the registration
/// to avoid infinite loops between type conversions and global variable
/// creation.
@ -602,6 +600,11 @@ public:
std::nullopt);
}
Fortran::lower::TypeConstructionStack &
getTypeConstructionStack() override final {
return typeConstructionStack;
}
bool isPresentShallowLookup(Fortran::semantics::Symbol &sym) override final {
return bool(shallowLookupSymbol(sym));
}
@ -5008,6 +5011,13 @@ private:
bool ompDeviceCodeFound = false;
const Fortran::lower::ExprToValueMap *exprValueOverrides{nullptr};
/// Stack of derived type under construction to avoid infinite loops when
/// dealing with recursive derived types. This is held in the bridge because
/// the state needs to be maintained between data and function type lowering
/// utilities to deal with procedure pointer components whose arguments have
/// the type of the containing derived type.
Fortran::lower::TypeConstructionStack typeConstructionStack;
};
} // namespace

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

@ -87,6 +87,11 @@ bool Fortran::lower::CallerInterface::isIndirectCall() const {
}
bool Fortran::lower::CallerInterface::requireDispatchCall() const {
// Procedure pointer component reference do not require dispatch, but
// have PASS/NOPASS argument.
if (const Fortran::semantics::Symbol *sym = procRef.proc().GetSymbol())
if (Fortran::semantics::IsPointer(*sym))
return false;
// calls with NOPASS attribute still have their component so check if it is
// polymorphic.
if (const Fortran::evaluate::Component *component =
@ -127,12 +132,21 @@ Fortran::lower::CallerInterface::getPassArgIndex() const {
return passArg;
}
const Fortran::semantics::Symbol *
Fortran::lower::CallerInterface::getIfIndirectCallSymbol() const {
mlir::Value Fortran::lower::CallerInterface::getIfPassedArg() const {
if (std::optional<unsigned> passArg = getPassArgIndex()) {
assert(actualInputs.size() > *passArg && actualInputs[*passArg] &&
"passed arg was not set yet");
return actualInputs[*passArg];
}
return {};
}
const Fortran::evaluate::ProcedureDesignator *
Fortran::lower::CallerInterface::getIfIndirectCall() const {
if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())
if (Fortran::semantics::IsPointer(*symbol) ||
Fortran::semantics::IsDummy(*symbol))
return symbol;
return &procRef.proc();
return nullptr;
}

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

@ -13,6 +13,7 @@
#include "flang/Lower/ConvertCall.h"
#include "flang/Lower/Allocatable.h"
#include "flang/Lower/ConvertExprToHLFIR.h"
#include "flang/Lower/ConvertProcedureDesignator.h"
#include "flang/Lower/ConvertVariable.h"
#include "flang/Lower/CustomIntrinsicCall.h"
#include "flang/Lower/HlfirIntrinsics.h"
@ -165,20 +166,28 @@ 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;
if (const Fortran::semantics::Symbol *sym =
caller.getIfIndirectCallSymbol()) {
funcPointer = fir::getBase(converter.getSymbolExtendedValue(*sym, &symMap));
if (!funcPointer)
fir::emitFatalError(loc, "failed to find indirect call symbol address");
if (fir::isCharacterProcedureTuple(funcPointer.getType(),
/*acceptRawFunc=*/false))
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);
if (const Fortran::evaluate::ProcedureDesignator *procDesignator =
caller.getIfIndirectCall()) {
if (mlir::Value passedArg = caller.getIfPassedArg()) {
// Procedure pointer component call with PASS argument. To avoid
// "double" lowering of the ComponentRef, semantics only place the
// ComponentRef in the ActualArguments, not in the ProcedureDesignator (
// that is only the component symbol).
// Fetch the passed argument and addresses of its procedure pointer
// component.
funcPointer = Fortran::lower::derefPassProcPointerComponent(
loc, converter, *procDesignator, passedArg, symMap, stmtCtx);
} else {
Fortran::lower::SomeExpr expr{*procDesignator};
fir::ExtendedValue loweredProc =
converter.genExprAddr(loc, expr, stmtCtx);
funcPointer = fir::getBase(loweredProc);
// Dummy procedure may have assumed length, in which case the result
// length was passed along the dummy procedure.
// This is not possible with procedure pointer components.
if (const fir::CharBoxValue *charBox = loweredProc.getCharBox())
charFuncPointerLength = charBox->getLen();
}
}
mlir::IndexType idxTy = builder.getIndexType();

2
flang/lib/Lower/ConvertConstant.cpp
View File

@ -366,6 +366,8 @@ static mlir::Value genStructureComponentInit(
TODO(loc, "allocatable component in structure constructor");
if (Fortran::semantics::IsPointer(sym)) {
if (Fortran::semantics::IsProcedure(sym))
TODO(loc, "procedure pointer component initial value");
mlir::Value initialTarget =
Fortran::lower::genInitialDataTarget(converter, loc, componentTy, expr);
res = builder.create<fir::InsertValueOp>(

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

@ -4849,7 +4849,7 @@ private:
}
}
if (caller.getIfIndirectCallSymbol())
if (caller.getIfIndirectCall())
fir::emitFatalError(loc, "cannot be indirect call");
// The lambda is mutable so that `caller` copy can be modified inside it.

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

@ -1738,6 +1738,8 @@ private:
if (attrs && bitEnumContainsAny(attrs.getFlags(),
fir::FortranVariableFlagsEnum::pointer)) {
if (Fortran::semantics::IsProcedure(sym))
TODO(loc, "procedure pointer component in structure constructor");
// Pointer component construction is just a copy of the box contents.
fir::ExtendedValue lhsExv =
hlfir::translateToExtendedValue(loc, builder, lhs);

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

@ -19,6 +19,7 @@
#include "flang/Optimizer/Builder/IntrinsicCall.h"
#include "flang/Optimizer/Builder/Todo.h"
#include "flang/Optimizer/Dialect/FIROps.h"
#include "flang/Optimizer/HLFIR/HLFIROps.h"
static bool areAllSymbolsInExprMapped(const Fortran::evaluate::ExtentExpr &expr,
Fortran::lower::SymMap &symMap) {
@ -96,6 +97,49 @@ fir::ExtendedValue Fortran::lower::convertProcedureDesignator(
return funcPtr;
}
static hlfir::EntityWithAttributes designateProcedurePointerComponent(
mlir::Location loc, Fortran::lower::AbstractConverter &converter,
const Fortran::evaluate::Symbol &procComponentSym, mlir::Value base,
Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
fir::FortranVariableFlagsAttr attributes =
Fortran::lower::translateSymbolAttributes(builder.getContext(),
procComponentSym);
/// Passed argument may be a descriptor. This is a scalar reference, so the
/// base address can be directly addressed.
if (base.getType().isa<fir::BaseBoxType>())
base = builder.create<fir::BoxAddrOp>(loc, base);
std::string fieldName = converter.getRecordTypeFieldName(procComponentSym);
auto recordType =
hlfir::getFortranElementType(base.getType()).cast<fir::RecordType>();
mlir::Type fieldType = recordType.getType(fieldName);
// FIXME: semantics is not expanding intermediate parent components in:
// call x%p() where p is a component of a parent type of x type.
if (!fieldType)
TODO(loc, "reference to procedure pointer component from parent type");
mlir::Type designatorType = fir::ReferenceType::get(fieldType);
mlir::Value compRef = builder.create<hlfir::DesignateOp>(
loc, designatorType, base, fieldName,
/*compShape=*/mlir::Value{}, hlfir::DesignateOp::Subscripts{},
/*substring=*/mlir::ValueRange{},
/*complexPart=*/std::nullopt,
/*shape=*/mlir::Value{}, /*typeParams=*/mlir::ValueRange{}, attributes);
return hlfir::EntityWithAttributes{compRef};
}
static hlfir::EntityWithAttributes convertProcedurePointerComponent(
mlir::Location loc, Fortran::lower::AbstractConverter &converter,
const Fortran::evaluate::Component &procComponent,
Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
fir::ExtendedValue baseExv = Fortran::lower::convertDataRefToValue(
loc, converter, procComponent.base(), symMap, stmtCtx);
mlir::Value base = fir::getBase(baseExv);
const Fortran::semantics::Symbol &procComponentSym =
procComponent.GetLastSymbol();
return designateProcedurePointerComponent(loc, converter, procComponentSym,
base, symMap, stmtCtx);
}
hlfir::EntityWithAttributes Fortran::lower::convertProcedureDesignatorToHLFIR(
mlir::Location loc, Fortran::lower::AbstractConverter &converter,
const Fortran::evaluate::ProcedureDesignator &proc,
@ -109,6 +153,10 @@ hlfir::EntityWithAttributes Fortran::lower::convertProcedureDesignatorToHLFIR(
return *varDef;
}
if (const Fortran::evaluate::Component *procComponent = proc.GetComponent())
return convertProcedurePointerComponent(loc, converter, *procComponent,
symMap, stmtCtx);
fir::ExtendedValue procExv =
convertProcedureDesignator(loc, converter, proc, symMap, stmtCtx);
// Directly package the procedure address as a fir.boxproc or
@ -148,3 +196,15 @@ mlir::Value Fortran::lower::convertProcedureDesignatorInitialTarget(
return fir::getBase(Fortran::lower::convertToAddress(
loc, converter, procVal, stmtCtx, procVal.getType()));
}
mlir::Value Fortran::lower::derefPassProcPointerComponent(
mlir::Location loc, Fortran::lower::AbstractConverter &converter,
const Fortran::evaluate::ProcedureDesignator &proc, mlir::Value passedArg,
Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
const Fortran::semantics::Symbol *procComponentSym = proc.GetSymbol();
assert(procComponentSym &&
"failed to retrieve pointer procedure component symbol");
hlfir::EntityWithAttributes pointerComp = designateProcedurePointerComponent(
loc, converter, *procComponentSym, passedArg, symMap, stmtCtx);
return converter.getFirOpBuilder().create<fir::LoadOp>(loc, pointerComp);
}

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

@ -140,7 +140,8 @@ namespace {
struct TypeBuilderImpl {
TypeBuilderImpl(Fortran::lower::AbstractConverter &converter)
: converter{converter}, context{&converter.getMLIRContext()} {}
: derivedTypeInConstruction{converter.getTypeConstructionStack()},
converter{converter}, context{&converter.getMLIRContext()} {}
template <typename A>
mlir::Type genExprType(const A &expr) {
@ -398,8 +399,6 @@ struct TypeBuilderImpl {
assert(scopeIter != derivedScope.cend() &&
"failed to find derived type component symbol");
const Fortran::semantics::Symbol &component = scopeIter->second.get();
if (IsProcedure(component))
TODO(converter.genLocation(component.name()), "procedure components");
mlir::Type ty = genSymbolType(component);
cs.emplace_back(converter.getRecordTypeFieldName(component), ty);
}
@ -568,8 +567,7 @@ struct TypeBuilderImpl {
/// Stack derived type being processed to avoid infinite loops in case of
/// recursive derived types. The depth of derived types is expected to be
/// shallow (<10), so a SmallVector is sufficient.
llvm::SmallVector<std::pair<const Fortran::lower::SymbolRef, mlir::Type>>
derivedTypeInConstruction;
Fortran::lower::TypeConstructionStack &derivedTypeInConstruction;
Fortran::lower::AbstractConverter &converter;
mlir::MLIRContext *context;
};

24
flang/lib/Optimizer/CodeGen/BoxedProcedure.cpp
View File

@ -19,6 +19,7 @@
#include "mlir/IR/PatternMatch.h"
#include "mlir/Pass/Pass.h"
#include "mlir/Transforms/DialectConversion.h"
#include "llvm/ADT/MapVector.h"
namespace fir {
#define GEN_PASS_DEF_BOXEDPROCEDUREPASS
@ -81,7 +82,7 @@ public:
visitedTypes.pop_back();
return result;
}
if (auto boxTy = ty.dyn_cast<BoxType>())
if (auto boxTy = ty.dyn_cast<BaseBoxType>())
return needsConversion(boxTy.getEleTy());
if (isa_ref_type(ty))
return needsConversion(unwrapRefType(ty));
@ -117,8 +118,14 @@ public:
});
addConversion(
[&](HeapType ty) { return HeapType::get(convertType(ty.getEleTy())); });
addConversion([&](fir::LLVMPointerType ty) {
return fir::LLVMPointerType::get(convertType(ty.getEleTy()));
});
addConversion(
[&](BoxType ty) { return BoxType::get(convertType(ty.getEleTy())); });
addConversion([&](ClassType ty) {
return ClassType::get(convertType(ty.getEleTy()));
});
addConversion([&](SequenceType ty) {
// TODO: add ty.getLayoutMap() as needed.
return SequenceType::get(ty.getShape(), convertType(ty.getEleTy()));
@ -126,10 +133,13 @@ public:
addConversion([&](RecordType ty) -> mlir::Type {
if (!needsConversion(ty))
return ty;
if (auto converted = typeInConversion.lookup(ty))
return converted;
auto rec = RecordType::get(ty.getContext(),
ty.getName().str() + boxprocSuffix.str());
if (rec.isFinalized())
return rec;
auto it = typeInConversion.try_emplace(ty, rec);
std::vector<RecordType::TypePair> ps = ty.getLenParamList();
std::vector<RecordType::TypePair> cs;
for (auto t : ty.getTypeList()) {
@ -139,6 +149,7 @@ public:
cs.emplace_back(t.first, t.second);
}
rec.finalize(ps, cs);
typeInConversion.erase(it.first);
return rec;
});
addArgumentMaterialization(materializeProcedure);
@ -159,6 +170,7 @@ public:
private:
llvm::SmallVector<mlir::Type> visitedTypes;
llvm::SmallMapVector<mlir::Type, mlir::Type, 8> typeInConversion;
mlir::Location loc;
};
@ -193,7 +205,8 @@ public:
getModule().walk([&](mlir::Operation *op) {
typeConverter.setLocation(op->getLoc());
if (auto addr = mlir::dyn_cast<BoxAddrOp>(op)) {
auto ty = addr.getVal().getType();
mlir::Type ty = addr.getVal().getType();
mlir::Type resTy = addr.getResult().getType();
if (typeConverter.needsConversion(ty) ||
ty.isa<mlir::FunctionType>()) {
// Rewrite all `fir.box_addr` ops on values of type `!fir.boxproc`
@ -201,6 +214,10 @@ public:
rewriter.setInsertionPoint(addr);
rewriter.replaceOpWithNewOp<ConvertOp>(
addr, typeConverter.convertType(addr.getType()), addr.getVal());
} else if (typeConverter.needsConversion(resTy)) {
rewriter.startRootUpdate(op);
op->getResult(0).setType(typeConverter.convertType(resTy));
rewriter.finalizeRootUpdate(op);
}
} else if (auto func = mlir::dyn_cast<mlir::func::FuncOp>(op)) {
mlir::FunctionType ty = func.getFunctionType();
@ -223,7 +240,8 @@ public:
} else if (auto embox = mlir::dyn_cast<EmboxProcOp>(op)) {
// Rewrite all `fir.emboxproc` ops to either `fir.convert` or a thunk
// as required.
mlir::Type toTy = embox.getType().cast<BoxProcType>().getEleTy();
mlir::Type toTy = typeConverter.convertType(
embox.getType().cast<BoxProcType>().getEleTy());
rewriter.setInsertionPoint(embox);
if (embox.getHost()) {
// Create the thunk.

3
flang/lib/Optimizer/CodeGen/TypeConverter.cpp
View File

@ -20,6 +20,7 @@
#include "flang/Optimizer/Dialect/FIRType.h"
#include "flang/Optimizer/Dialect/Support/FIRContext.h"
#include "flang/Optimizer/Dialect/Support/KindMapping.h"
#include "flang/Optimizer/Support/InternalNames.h"
#include "mlir/Conversion/LLVMCommon/TypeConverter.h"
#include "llvm/ADT/ScopeExit.h"
#include "llvm/Support/Debug.h"
@ -164,7 +165,7 @@ mlir::Type LLVMTypeConverter::indexType() const {
// fir.type<name(p : TY'...){f : TY...}> --> llvm<"%name = { ty... }">
std::optional<mlir::LogicalResult> LLVMTypeConverter::convertRecordType(
fir::RecordType derived, llvm::SmallVectorImpl<mlir::Type> &results) {
auto name = derived.getName();
auto name = fir::NameUniquer::dropTypeConversionMarkers(derived.getName());
auto st = mlir::LLVM::LLVMStructType::getIdentified(&getContext(), name);
auto &callStack = getCurrentThreadRecursiveStack();

12
flang/lib/Optimizer/Support/InternalNames.cpp
View File

@ -240,6 +240,7 @@ llvm::StringRef fir::NameUniquer::doProgramEntry() {
std::pair<fir::NameUniquer::NameKind, fir::NameUniquer::DeconstructedName>
fir::NameUniquer::deconstruct(llvm::StringRef uniq) {
uniq = fir::NameUniquer::dropTypeConversionMarkers(uniq);
if (uniq.starts_with("_Q")) {
llvm::SmallVector<std::string> modules;
llvm::SmallVector<std::string> procs;
@ -353,8 +354,8 @@ mangleTypeDescriptorKinds(llvm::ArrayRef<std::int64_t> kinds) {
static std::string getDerivedTypeObjectName(llvm::StringRef mangledTypeName,
const llvm::StringRef separator) {
if (mangledTypeName.ends_with(boxprocSuffix))
mangledTypeName = mangledTypeName.drop_back(boxprocSuffix.size());
mangledTypeName =
fir::NameUniquer::dropTypeConversionMarkers(mangledTypeName);
auto result = fir::NameUniquer::deconstruct(mangledTypeName);
if (result.first != fir::NameUniquer::NameKind::DERIVED_TYPE)
return "";
@ -379,3 +380,10 @@ std::string fir::NameUniquer::getTypeDescriptorBindingTableName(
llvm::StringRef mangledTypeName) {
return getDerivedTypeObjectName(mangledTypeName, bindingTableSeparator);
}
llvm::StringRef
fir::NameUniquer::dropTypeConversionMarkers(llvm::StringRef mangledTypeName) {
if (mangledTypeName.ends_with(boxprocSuffix))
return mangledTypeName.drop_back(boxprocSuffix.size());
return mangledTypeName;
}

123
flang/test/Lower/HLFIR/proc-pointer-comp-nopass.f90 Normal file
View File

@ -0,0 +1,123 @@
! Test lowering of NOPASS procedure pointers components.
! RUN: bbc -emit-hlfir -polymorphic-type -o - %s | FileCheck %s
module proc_comp_defs
interface
real function iface(x)
real :: x
end function
subroutine takes_proc_pointer(p)
import iface
procedure(iface), pointer :: p
end subroutine
end interface
type t
integer :: j
procedure(iface), nopass, pointer :: p
end type
end module
real function test1(x)
use proc_comp_defs, only : t
type(t) :: x
test1 = x%p(42.)
end function
! CHECK-LABEL: func.func @_QPtest1(
! CHECK: %[[VAL_1:.*]] = fir.alloca f32 {bindc_name = "test1", uniq_name = "_QFtest1Etest1"}
! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_1:[a-z0-9]*]] {{.*}}Etest1
! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {{.*}}Ex
! CHECK: %[[VAL_4:.*]] = arith.constant 4.200000e+01 : f32
! CHECK: %[[VAL_5:.*]]:3 = hlfir.associate %[[VAL_4]] {adapt.valuebyref} : (f32) -> (!fir.ref<f32>, !fir.ref<f32>, i1)
! CHECK: %[[VAL_6:.*]] = hlfir.designate %[[VAL_3]]#1{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!fir.type<_QMproc_comp_defsTt{j:i32,p:!fir.boxproc<(!fir.ref<f32>) -> f32>}>>) -> !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
! CHECK: %[[VAL_7:.*]] = fir.load %[[VAL_6]] : !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]](%[[VAL_5]]#1) fastmath<contract> : (!fir.ref<f32>) -> f32
! CHECK: hlfir.end_associate %[[VAL_5]]#1, %[[VAL_5]]#2 : !fir.ref<f32>, i1
! CHECK: hlfir.assign %[[VAL_9]] to %[[VAL_2]]#0 : f32, !fir.ref<f32>
subroutine test2(x)
use proc_comp_defs, only : t, iface
type(t) :: x
procedure(iface) :: ptarget
x%p => ptarget
end subroutine
! CHECK-LABEL: func.func @_QPtest2(
! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {{.*}}Ex
! CHECK: %[[VAL_2:.*]] = hlfir.designate %[[VAL_1]]#1{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!fir.type<_QMproc_comp_defsTt{j:i32,p:!fir.boxproc<(!fir.ref<f32>) -> f32>}>>) -> !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
! CHECK: %[[VAL_3:.*]] = fir.address_of(@_QPptarget) : (!fir.ref<f32>) -> f32
! CHECK: %[[VAL_4:.*]] = fir.emboxproc %[[VAL_3]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.boxproc<() -> ()>) -> !fir.boxproc<(!fir.ref<f32>) -> f32>
! CHECK: fir.store %[[VAL_5]] to %[[VAL_2]] : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
subroutine test3(x)
use proc_comp_defs, only : t
type(t) :: x
x%p => null()
end subroutine
! CHECK-LABEL: func.func @_QPtest3(
! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {{.*}}Ex
! CHECK: %[[VAL_2:.*]] = hlfir.designate %[[VAL_1]]#1{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!fir.type<_QMproc_comp_defsTt{j:i32,p:!fir.boxproc<(!fir.ref<f32>) -> f32>}>>) -> !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
! CHECK: %[[VAL_3:.*]] = fir.zero_bits () -> ()
! CHECK: %[[VAL_4:.*]] = fir.emboxproc %[[VAL_3]] : (() -> ()) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.boxproc<() -> ()>) -> !fir.boxproc<(!fir.ref<f32>) -> f32>
! CHECK: fir.store %[[VAL_5]] to %[[VAL_2]] : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
subroutine test4(x)
use proc_comp_defs, only : t
type(t) :: x
x%p => x%p
end subroutine
! CHECK-LABEL: func.func @_QPtest4(
! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {{.*}}Ex
! CHECK: %[[VAL_2:.*]] = hlfir.designate %[[VAL_1]]#1{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!fir.type<_QMproc_comp_defsTt{j:i32,p:!fir.boxproc<(!fir.ref<f32>) -> f32>}>>) -> !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
! CHECK: %[[VAL_3:.*]] = hlfir.designate %[[VAL_1]]#1{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!fir.type<_QMproc_comp_defsTt{j:i32,p:!fir.boxproc<(!fir.ref<f32>) -> f32>}>>) -> !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_3]] : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
! CHECK: fir.store %[[VAL_4]] to %[[VAL_2]] : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
subroutine test5(x)
use proc_comp_defs, only : t, takes_proc_pointer
type(t) :: x
call takes_proc_pointer(x%p)
end subroutine
! CHECK-LABEL: func.func @_QPtest5(
! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {{.*}}Ex
! CHECK: %[[VAL_2:.*]] = hlfir.designate %[[VAL_1]]#1{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!fir.type<_QMproc_comp_defsTt{j:i32,p:!fir.boxproc<(!fir.ref<f32>) -> f32>}>>) -> !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>) -> !fir.ref<!fir.boxproc<() -> ()>>
! CHECK: fir.call @_QPtakes_proc_pointer(%[[VAL_3]]) fastmath<contract> : (!fir.ref<!fir.boxproc<() -> ()>>) -> ()
subroutine test6(x)
use proc_comp_defs, only : t
type(t) :: x
nullify(x%p)
end subroutine
! CHECK-LABEL: func.func @_QPtest6(
! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {{.*}}Ex
! CHECK: %[[VAL_2:.*]] = hlfir.designate %[[VAL_1]]#1{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!fir.type<_QMproc_comp_defsTt{j:i32,p:!fir.boxproc<(!fir.ref<f32>) -> f32>}>>) -> !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
! CHECK: %[[VAL_3:.*]] = fir.zero_bits () -> ()
! CHECK: %[[VAL_4:.*]] = fir.emboxproc %[[VAL_3]] : (() -> ()) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.boxproc<() -> ()>) -> !fir.boxproc<(!fir.ref<f32>) -> f32>
! CHECK: fir.store %[[VAL_5]] to %[[VAL_2]] : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
subroutine test7(x, y)
use proc_comp_defs, only : t
type(t) :: x, y
x = y
end subroutine
! CHECK-LABEL: func.func @_QPtest7(
! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {{.*}}Ex
! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_1:[a-z0-9]*]] {{.*}}Ey
! CHECK: hlfir.assign %[[VAL_3]]#0 to %[[VAL_2]]#0 : !fir.ref<!fir.type<_QMproc_comp_defsTt{j:i32,p:!fir.boxproc<(!fir.ref<f32>) -> f32>}>>, !fir.ref<!fir.type<_QMproc_comp_defsTt{j:i32,p:!fir.boxproc<(!fir.ref<f32>) -> f32>}>>
subroutine test8(x, y)
use proc_comp_defs, only : t
type(t) :: x(10), y(10)
x = y
end subroutine
! CHECK-LABEL: func.func @_QPtest8(
! CHECK: %[[VAL_2:.*]] = arith.constant 10 : index
! CHECK: %[[VAL_3:.*]] = fir.shape %[[VAL_2]] : (index) -> !fir.shape<1>
! CHECK: %[[VAL_4:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]](%[[VAL_3:[a-z0-9]*]]) {{.*}}Ex
! CHECK: %[[VAL_5:.*]] = arith.constant 10 : index
! CHECK: %[[VAL_6:.*]] = fir.shape %[[VAL_5]] : (index) -> !fir.shape<1>
! CHECK: %[[VAL_7:.*]]:2 = hlfir.declare %[[VAL_1:[a-z0-9]*]](%[[VAL_6:[a-z0-9]*]]) {{.*}}Ey
! CHECK: hlfir.assign %[[VAL_7]]#0 to %[[VAL_4]]#0 : !fir.ref<!fir.array<10x!fir.type<_QMproc_comp_defsTt{j:i32,p:!fir.boxproc<(!fir.ref<f32>) -> f32>}>>>, !fir.ref<!fir.array<10x!fir.type<_QMproc_comp_defsTt{j:i32,p:!fir.boxproc<(!fir.ref<f32>) -> f32>}>>>

110
flang/test/Lower/HLFIR/proc-pointer-comp-pass.f90 Normal file
View File

@ -0,0 +1,110 @@
! Test lowering of PASS procedure pointers components.
! RUN: bbc -emit-hlfir -polymorphic-type -o - %s | FileCheck %s
module m
type t
sequence
integer :: i
procedure(hello), pointer :: p
end type
type t2
integer :: i
procedure(goodbye), pointer :: p
end type
type t3
sequence
character(4) :: c
procedure(char_func), pointer :: p
end type
interface
subroutine takes_hello(p)
import :: hello
procedure(hello), pointer :: p
end subroutine
end interface
contains
subroutine hello(x)
type(t) :: x
print *, "hello"
end subroutine
subroutine goodbye(x)
class(t2) :: x
print *, "goodbye"
end subroutine
function char_func(x)
type(t3) :: x
character(4) :: char_func
char_func = x%c
end function
end module
subroutine test1(x)
use m, only : t
type(t) :: x
call x%p()
end subroutine
! CHECK-LABEL: func.func @_QPtest1(
! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {{.*}}Ex
! CHECK: %[[VAL_2:.*]] = hlfir.designate %[[VAL_1]]#1{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!fir.type<_QMmTt{i:i32,p:!fir.boxproc<(!fir.ref<!fir.type<_QMmTt>>) -> ()>}>>) -> !fir.ref<!fir.boxproc<(!fir.ref<!fir.type<_QMmTt{i:i32,p:!fir.boxproc<(!fir.ref<!fir.type<_QMmTt>>) -> ()>}>>) -> ()>>
! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_2]] : !fir.ref<!fir.boxproc<(!fir.ref<!fir.type<_QMmTt{i:i32,p:!fir.boxproc<(!fir.ref<!fir.type<_QMmTt>>) -> ()>}>>) -> ()>>
! CHECK: %[[VAL_4:.*]] = fir.box_addr %[[VAL_3]] : (!fir.boxproc<(!fir.ref<!fir.type<_QMmTt{i:i32,p:!fir.boxproc<(!fir.ref<!fir.type<_QMmTt>>) -> ()>}>>) -> ()>) -> ((!fir.ref<!fir.type<_QMmTt{i:i32,p:!fir.boxproc<(!fir.ref<!fir.type<_QMmTt>>) -> ()>}>>) -> ())
! CHECK: fir.call %[[VAL_4]](%[[VAL_1]]#1) fastmath<contract> : (!fir.ref<!fir.type<_QMmTt{i:i32,p:!fir.boxproc<(!fir.ref<!fir.type<_QMmTt>>) -> ()>}>>) -> ()
subroutine test2(x)
use m, only : t2
type(t2) :: x
call x%p()
end subroutine
! CHECK-LABEL: func.func @_QPtest2(
! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {{.*}}Ex
! CHECK: %[[VAL_2:.*]] = fir.embox %[[VAL_1]]#0 : (!fir.ref<!fir.type<_QMmTt2{i:i32,p:!fir.boxproc<(!fir.class<!fir.type<_QMmTt2>>) -> ()>}>>) -> !fir.box<!fir.type<_QMmTt2{i:i32,p:!fir.boxproc<(!fir.class<!fir.type<_QMmTt2>>) -> ()>}>>
! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.box<!fir.type<_QMmTt2{i:i32,p:!fir.boxproc<(!fir.class<!fir.type<_QMmTt2>>) -> ()>}>>) -> !fir.class<!fir.type<_QMmTt2{i:i32,p:!fir.boxproc<(!fir.class<!fir.type<_QMmTt2>>) -> ()>}>>
! CHECK: %[[VAL_4:.*]] = fir.box_addr %[[VAL_3]] : (!fir.class<!fir.type<_QMmTt2{i:i32,p:!fir.boxproc<(!fir.class<!fir.type<_QMmTt2>>) -> ()>}>>) -> !fir.ref<!fir.type<_QMmTt2{i:i32,p:!fir.boxproc<(!fir.class<!fir.type<_QMmTt2>>) -> ()>}>>
! CHECK: %[[VAL_5:.*]] = hlfir.designate %[[VAL_4]]{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!fir.type<_QMmTt2{i:i32,p:!fir.boxproc<(!fir.class<!fir.type<_QMmTt2>>) -> ()>}>>) -> !fir.ref<!fir.boxproc<(!fir.class<!fir.type<_QMmTt2{i:i32,p:!fir.boxproc<(!fir.class<!fir.type<_QMmTt2>>) -> ()>}>>) -> ()>>
! CHECK: %[[VAL_6:.*]] = fir.load %[[VAL_5]] : !fir.ref<!fir.boxproc<(!fir.class<!fir.type<_QMmTt2{i:i32,p:!fir.boxproc<(!fir.class<!fir.type<_QMmTt2>>) -> ()>}>>) -> ()>>
! CHECK: %[[VAL_7:.*]] = fir.box_addr %[[VAL_6]] : (!fir.boxproc<(!fir.class<!fir.type<_QMmTt2{i:i32,p:!fir.boxproc<(!fir.class<!fir.type<_QMmTt2>>) -> ()>}>>) -> ()>) -> ((!fir.class<!fir.type<_QMmTt2{i:i32,p:!fir.boxproc<(!fir.class<!fir.type<_QMmTt2>>) -> ()>}>>) -> ())
! CHECK: fir.call %[[VAL_7]](%[[VAL_3]]) fastmath<contract> : (!fir.class<!fir.type<_QMmTt2{i:i32,p:!fir.boxproc<(!fir.class<!fir.type<_QMmTt2>>) -> ()>}>>) -> ()
subroutine test3(x)
use m, only : t, takes_hello
type(t) :: x
call takes_hello(x%p)
end subroutine
! CHECK-LABEL: func.func @_QPtest3(
! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {{.*}}Ex
! CHECK: %[[VAL_2:.*]] = hlfir.designate %[[VAL_1]]#1{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!fir.type<_QMmTt{i:i32,p:!fir.boxproc<(!fir.ref<!fir.type<_QMmTt>>) -> ()>}>>) -> !fir.ref<!fir.boxproc<(!fir.ref<!fir.type<_QMmTt{i:i32,p:!fir.boxproc<(!fir.ref<!fir.type<_QMmTt>>) -> ()>}>>) -> ()>>
! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.ref<!fir.boxproc<(!fir.ref<!fir.type<_QMmTt{i:i32,p:!fir.boxproc<(!fir.ref<!fir.type<_QMmTt>>) -> ()>}>>) -> ()>>) -> !fir.ref<!fir.boxproc<() -> ()>>
! CHECK: fir.call @_QPtakes_hello(%[[VAL_3]]) fastmath<contract> : (!fir.ref<!fir.boxproc<() -> ()>>) -> ()
subroutine test4(x, y)
use m, only : t
type(t) :: x, y
x%p => y%p
end subroutine
! CHECK-LABEL: func.func @_QPtest4(
! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {{.*}}Ex
! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_1:[a-z0-9]*]] {{.*}}Ey
! CHECK: %[[VAL_4:.*]] = hlfir.designate %[[VAL_2]]#1{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!fir.type<_QMmTt{i:i32,p:!fir.boxproc<(!fir.ref<!fir.type<_QMmTt>>) -> ()>}>>) -> !fir.ref<!fir.boxproc<(!fir.ref<!fir.type<_QMmTt{i:i32,p:!fir.boxproc<(!fir.ref<!fir.type<_QMmTt>>) -> ()>}>>) -> ()>>
! CHECK: %[[VAL_5:.*]] = hlfir.designate %[[VAL_3]]#1{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!fir.type<_QMmTt{i:i32,p:!fir.boxproc<(!fir.ref<!fir.type<_QMmTt>>) -> ()>}>>) -> !fir.ref<!fir.boxproc<(!fir.ref<!fir.type<_QMmTt{i:i32,p:!fir.boxproc<(!fir.ref<!fir.type<_QMmTt>>) -> ()>}>>) -> ()>>
! CHECK: %[[VAL_6:.*]] = fir.load %[[VAL_5]] : !fir.ref<!fir.boxproc<(!fir.ref<!fir.type<_QMmTt{i:i32,p:!fir.boxproc<(!fir.ref<!fir.type<_QMmTt>>) -> ()>}>>) -> ()>>
! CHECK: fir.store %[[VAL_6]] to %[[VAL_4]] : !fir.ref<!fir.boxproc<(!fir.ref<!fir.type<_QMmTt{i:i32,p:!fir.boxproc<(!fir.ref<!fir.type<_QMmTt>>) -> ()>}>>) -> ()>>
subroutine test5(x)
use m, only : t3
type(t3) :: x
call takes_char(x%p())
end subroutine
! CHECK-LABEL: func.func @_QPtest5(
! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.char<1,4> {bindc_name = ".result"}
! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] {{.*}}Ex
! CHECK: %[[VAL_3:.*]] = hlfir.designate %[[VAL_2]]#1{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!fir.type<_QMmTt3{c:!fir.char<1,4>,p:!fir.boxproc<(!fir.ref<!fir.char<1,4>>, index, !fir.ref<!fir.type<_QMmTt3>>) -> !fir.boxchar<1>>}>>) -> !fir.ref<!fir.boxproc<(!fir.ref<!fir.char<1,4>>, index, !fir.ref<!fir.type<_QMmTt3{c:!fir.char<1,4>,p:!fir.boxproc<(!fir.ref<!fir.char<1,4>>, index, !fir.ref<!fir.type<_QMmTt3>>) -> !fir.boxchar<1>>}>>) -> !fir.boxchar<1>>>
! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_3]] : !fir.ref<!fir.boxproc<(!fir.ref<!fir.char<1,4>>, index, !fir.ref<!fir.type<_QMmTt3{c:!fir.char<1,4>,p:!fir.boxproc<(!fir.ref<!fir.char<1,4>>, index, !fir.ref<!fir.type<_QMmTt3>>) -> !fir.boxchar<1>>}>>) -> !fir.boxchar<1>>>
! CHECK: %[[VAL_5:.*]] = arith.constant 4 : i64
! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i64) -> index
! CHECK: %[[VAL_7:.*]] = arith.constant 0 : index
! CHECK: %[[VAL_8:.*]] = arith.cmpi sgt, %[[VAL_6]], %[[VAL_7]] : index
! CHECK: %[[VAL_9:.*]] = arith.select %[[VAL_8]], %[[VAL_6]], %[[VAL_7]] : index
! CHECK: %[[VAL_10:.*]] = fir.call @llvm.stacksave.p0() fastmath<contract> : () -> !fir.ref<i8>
! CHECK: %[[VAL_11:.*]] = fir.box_addr %[[VAL_4]] : (!fir.boxproc<(!fir.ref<!fir.char<1,4>>, index, !fir.ref<!fir.type<_QMmTt3{c:!fir.char<1,4>,p:!fir.boxproc<(!fir.ref<!fir.char<1,4>>, index, !fir.ref<!fir.type<_QMmTt3>>) -> !fir.boxchar<1>>}>>) -> !fir.boxchar<1>>) -> ((!fir.ref<!fir.char<1,4>>, index, !fir.ref<!fir.type<_QMmTt3{c:!fir.char<1,4>,p:!fir.boxproc<(!fir.ref<!fir.char<1,4>>, index, !fir.ref<!fir.type<_QMmTt3>>) -> !fir.boxchar<1>>}>>) -> !fir.boxchar<1>)
! CHECK: %[[VAL_12:.*]] = fir.call %[[VAL_11]](%[[VAL_1]], %[[VAL_9]], %[[VAL_2]]#1) fastmath<contract> : (!fir.ref<!fir.char<1,4>>, index, !fir.ref<!fir.type<_QMmTt3{c:!fir.char<1,4>,p:!fir.boxproc<(!fir.ref<!fir.char<1,4>>, index, !fir.ref<!fir.type<_QMmTt3>>) -> !fir.boxchar<1>>}>>) -> !fir.boxchar<1>

8
flang/test/Lower/HLFIR/procedure-designators.f90
View File

@ -126,10 +126,10 @@ end subroutine
! CHECK-LABEL: func.func @_QMtest_proc_designatorPtest_call_character_dummy(
! CHECK-SAME: %[[VAL_0:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc}) {
! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.char<1,10> {bindc_name = ".result"}
! CHECK: %[[VAL_4:.*]] = fir.extract_value %[[VAL_0]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_5:.*]] = fir.box_addr %[[VAL_4]] : (!fir.boxproc<() -> ()>) -> (() -> ())
! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_5]] : (() -> ()) -> ((!fir.ref<!fir.char<1,10>>, index, !fir.ref<i32>) -> !fir.boxchar<1>)
! CHECK: %[[VAL_13:.*]] = fir.call %[[VAL_12]](%[[VAL_1]], {{.*}}
! CHECK: %[[VAL_3:.*]] = fir.insert_value %{{.*}}, %c10{{.*}}, [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
! CHECK: %[[VAL_4:.*]] = fir.extract_value %[[VAL_3]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
! CHECK: %[[VAL_5:.*]] = fir.box_addr %[[VAL_4]] : (!fir.boxproc<() -> ()>) -> ((!fir.ref<!fir.char<1,10>>, index, !fir.ref<i32>) -> !fir.boxchar<1>)
! CHECK: %[[VAL_13:.*]] = fir.call %[[VAL_5]](%[[VAL_1]], {{.*}}
subroutine test_present_simple_dummy(proc)
procedure(simple), optional :: proc

6
flang/test/Lower/HLFIR/procedure-pointer.f90
View File

@ -103,7 +103,7 @@ use m
! 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_7:.*]] = fir.load %[[VAL_3]]#0 : !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
@ -138,7 +138,7 @@ use m
! 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_12:.*]] = fir.load %[[VAL_3]]#0 : !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
@ -175,7 +175,7 @@ use m
! 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_6:.*]] = fir.load %[[VAL_3]]#0 : !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