1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
|
//===- ConvertProcedureDesignator.cpp -- Procedure Designator ---*- C++ -*-===//
//
// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
// See https://llvm.org/LICENSE.txt for license information.
// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
//
//===----------------------------------------------------------------------===//
#include "flang/Lower/ConvertProcedureDesignator.h"
#include "flang/Evaluate/intrinsics.h"
#include "flang/Lower/AbstractConverter.h"
#include "flang/Lower/CallInterface.h"
#include "flang/Lower/ConvertCall.h"
#include "flang/Lower/ConvertExprToHLFIR.h"
#include "flang/Lower/ConvertVariable.h"
#include "flang/Lower/Support/Utils.h"
#include "flang/Lower/SymbolMap.h"
#include "flang/Optimizer/Builder/Character.h"
#include "flang/Optimizer/Builder/IntrinsicCall.h"
#include "flang/Optimizer/Builder/Todo.h"
#include "flang/Optimizer/Dialect/FIROps.h"
#include "flang/Optimizer/HLFIR/HLFIROps.h"
static bool areAllSymbolsInExprMapped(const Fortran::evaluate::ExtentExpr &expr,
Fortran::lower::SymMap &symMap) {
for (const auto &sym : Fortran::evaluate::CollectSymbols(expr))
if (!symMap.lookupSymbol(sym))
return false;
return true;
}
fir::ExtendedValue Fortran::lower::convertProcedureDesignator(
mlir::Location loc, Fortran::lower::AbstractConverter &converter,
const Fortran::evaluate::ProcedureDesignator &proc,
Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
if (const Fortran::evaluate::SpecificIntrinsic *intrinsic =
proc.GetSpecificIntrinsic()) {
mlir::FunctionType signature =
Fortran::lower::translateSignature(proc, converter);
// Intrinsic lowering is based on the generic name, so retrieve it here in
// case it is different from the specific name. The type of the specific
// intrinsic is retained in the signature.
std::string genericName =
converter.getFoldingContext().intrinsics().GetGenericIntrinsicName(
intrinsic->name);
mlir::SymbolRefAttr symbolRefAttr =
fir::getUnrestrictedIntrinsicSymbolRefAttr(builder, loc, genericName,
signature);
mlir::Value funcPtr =
builder.create<fir::AddrOfOp>(loc, signature, symbolRefAttr);
return funcPtr;
}
const Fortran::semantics::Symbol *symbol = proc.GetSymbol();
assert(symbol && "expected symbol in ProcedureDesignator");
mlir::Value funcPtr;
mlir::Value funcPtrResultLength;
if (Fortran::semantics::IsDummy(*symbol)) {
Fortran::lower::SymbolBox val = symMap.lookupSymbol(*symbol);
assert(val && "Dummy procedure not in symbol map");
funcPtr = val.getAddr();
if (fir::isCharacterProcedureTuple(funcPtr.getType(),
/*acceptRawFunc=*/false))
std::tie(funcPtr, funcPtrResultLength) =
fir::factory::extractCharacterProcedureTuple(builder, loc, funcPtr);
} else {
mlir::func::FuncOp func =
Fortran::lower::getOrDeclareFunction(proc, converter);
mlir::SymbolRefAttr nameAttr = builder.getSymbolRefAttr(func.getSymName());
funcPtr =
builder.create<fir::AddrOfOp>(loc, func.getFunctionType(), nameAttr);
}
if (Fortran::lower::mustPassLengthWithDummyProcedure(proc, converter)) {
// The result length, if available here, must be propagated along the
// procedure address so that call sites where the result length is assumed
// can retrieve the length.
Fortran::evaluate::DynamicType resultType = proc.GetType().value();
if (const auto &lengthExpr = resultType.GetCharLength()) {
// The length expression may refer to dummy argument symbols that are
// meaningless without any actual arguments. Leave the length as
// unknown in that case, it be resolved on the call site
// with the actual arguments.
if (areAllSymbolsInExprMapped(*lengthExpr, symMap)) {
mlir::Value rawLen = fir::getBase(
converter.genExprValue(toEvExpr(*lengthExpr), stmtCtx));
// F2018 7.4.4.2 point 5.
funcPtrResultLength =
fir::factory::genMaxWithZero(builder, loc, rawLen);
}
}
if (!funcPtrResultLength)
funcPtrResultLength = builder.createIntegerConstant(
loc, builder.getCharacterLengthType(), -1);
return fir::CharBoxValue{funcPtr, funcPtrResultLength};
}
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);
// Note: semantics turns x%p() into x%t%p() when the procedure pointer
// component is part of parent component t.
if (!fieldType)
TODO(loc, "passing type bound procedure (extension)");
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,
Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
const auto *sym = proc.GetSymbol();
if (sym) {
if (sym->GetUltimate().attrs().test(Fortran::semantics::Attr::INTRINSIC))
TODO(loc, "Procedure pointer with intrinsic target.");
if (std::optional<fir::FortranVariableOpInterface> varDef =
symMap.lookupVariableDefinition(*sym))
return *varDef;
}
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
// tuple<fir.boxbroc, len> so that it can be returned as a single mlir::Value.
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
mlir::Value funcAddr = fir::getBase(procExv);
if (!funcAddr.getType().isa<fir::BoxProcType>()) {
mlir::Type boxTy =
Fortran::lower::getUntypedBoxProcType(&converter.getMLIRContext());
if (auto host = Fortran::lower::argumentHostAssocs(converter, funcAddr))
funcAddr = builder.create<fir::EmboxProcOp>(
loc, boxTy, llvm::ArrayRef<mlir::Value>{funcAddr, host});
else
funcAddr = builder.create<fir::EmboxProcOp>(loc, boxTy, funcAddr);
}
mlir::Value res = procExv.match(
[&](const fir::CharBoxValue &box) -> mlir::Value {
mlir::Type tupleTy =
fir::factory::getCharacterProcedureTupleType(funcAddr.getType());
return fir::factory::createCharacterProcedureTuple(
builder, loc, tupleTy, funcAddr, box.getLen());
},
[funcAddr](const auto &) { return funcAddr; });
return hlfir::EntityWithAttributes{res};
}
mlir::Value Fortran::lower::convertProcedureDesignatorInitialTarget(
Fortran::lower::AbstractConverter &converter, mlir::Location loc,
const Fortran::semantics::Symbol &sym) {
Fortran::lower::SymMap globalOpSymMap;
Fortran::lower::StatementContext stmtCtx;
Fortran::evaluate::ProcedureDesignator proc(sym);
auto procVal{Fortran::lower::convertProcedureDesignatorToHLFIR(
loc, converter, proc, globalOpSymMap, stmtCtx)};
return fir::getBase(Fortran::lower::convertToAddress(
loc, converter, procVal, stmtCtx, procVal.getType()));
}
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);
}
|
