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