7188 lines · cpp
1//===-- Bridge.cpp -- bridge to lower to MLIR -----------------------------===//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-exception6//7//===----------------------------------------------------------------------===//8//9// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/10//11//===----------------------------------------------------------------------===//12 13#include "flang/Lower/Bridge.h"14 15#include "flang/Lower/Allocatable.h"16#include "flang/Lower/CUDA.h"17#include "flang/Lower/CallInterface.h"18#include "flang/Lower/ConvertCall.h"19#include "flang/Lower/ConvertExpr.h"20#include "flang/Lower/ConvertExprToHLFIR.h"21#include "flang/Lower/ConvertType.h"22#include "flang/Lower/ConvertVariable.h"23#include "flang/Lower/DirectivesCommon.h"24#include "flang/Lower/HostAssociations.h"25#include "flang/Lower/IO.h"26#include "flang/Lower/IterationSpace.h"27#include "flang/Lower/Mangler.h"28#include "flang/Lower/MultiImageFortran.h"29#include "flang/Lower/OpenACC.h"30#include "flang/Lower/OpenMP.h"31#include "flang/Lower/PFTBuilder.h"32#include "flang/Lower/Runtime.h"33#include "flang/Lower/StatementContext.h"34#include "flang/Lower/Support/ReductionProcessor.h"35#include "flang/Lower/Support/Utils.h"36#include "flang/Optimizer/Builder/BoxValue.h"37#include "flang/Optimizer/Builder/CUFCommon.h"38#include "flang/Optimizer/Builder/Character.h"39#include "flang/Optimizer/Builder/FIRBuilder.h"40#include "flang/Optimizer/Builder/Runtime/Assign.h"41#include "flang/Optimizer/Builder/Runtime/Character.h"42#include "flang/Optimizer/Builder/Runtime/Derived.h"43#include "flang/Optimizer/Builder/Runtime/EnvironmentDefaults.h"44#include "flang/Optimizer/Builder/Runtime/Exceptions.h"45#include "flang/Optimizer/Builder/Runtime/Main.h"46#include "flang/Optimizer/Builder/Runtime/Ragged.h"47#include "flang/Optimizer/Builder/Runtime/Stop.h"48#include "flang/Optimizer/Builder/Todo.h"49#include "flang/Optimizer/Dialect/CUF/Attributes/CUFAttr.h"50#include "flang/Optimizer/Dialect/CUF/CUFOps.h"51#include "flang/Optimizer/Dialect/FIRAttr.h"52#include "flang/Optimizer/Dialect/FIRDialect.h"53#include "flang/Optimizer/Dialect/FIROps.h"54#include "flang/Optimizer/Dialect/Support/FIRContext.h"55#include "flang/Optimizer/HLFIR/HLFIROps.h"56#include "flang/Optimizer/Support/DataLayout.h"57#include "flang/Optimizer/Support/FatalError.h"58#include "flang/Optimizer/Support/InternalNames.h"59#include "flang/Optimizer/Transforms/Passes.h"60#include "flang/Parser/parse-tree.h"61#include "flang/Parser/tools.h"62#include "flang/Runtime/iostat-consts.h"63#include "flang/Semantics/openmp-dsa.h"64#include "flang/Semantics/runtime-type-info.h"65#include "flang/Semantics/symbol.h"66#include "flang/Semantics/tools.h"67#include "flang/Support/Flags.h"68#include "flang/Support/Version.h"69#include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h"70#include "mlir/IR/BuiltinAttributes.h"71#include "mlir/IR/Matchers.h"72#include "mlir/IR/PatternMatch.h"73#include "mlir/Parser/Parser.h"74#include "mlir/Support/StateStack.h"75#include "mlir/Transforms/RegionUtils.h"76#include "llvm/ADT/ScopeExit.h"77#include "llvm/ADT/SmallVector.h"78#include "llvm/ADT/StringSet.h"79#include "llvm/Support/CommandLine.h"80#include "llvm/Support/Debug.h"81#include "llvm/Support/ErrorHandling.h"82#include "llvm/Support/FileSystem.h"83#include "llvm/Support/Path.h"84#include "llvm/Target/TargetMachine.h"85#include <optional>86 87#define DEBUG_TYPE "flang-lower-bridge"88 89static llvm::cl::opt<bool> forceLoopToExecuteOnce(90 "always-execute-loop-body", llvm::cl::init(false),91 llvm::cl::desc("force the body of a loop to execute at least once"));92 93namespace {94/// Information for generating a structured or unstructured increment loop.95struct IncrementLoopInfo {96 template <typename T>97 explicit IncrementLoopInfo(Fortran::semantics::Symbol &sym, const T &lower,98 const T &upper, const std::optional<T> &step,99 bool isConcurrent = false)100 : loopVariableSym{&sym}, lowerExpr{Fortran::semantics::GetExpr(lower)},101 upperExpr{Fortran::semantics::GetExpr(upper)},102 stepExpr{Fortran::semantics::GetExpr(step)},103 isConcurrent{isConcurrent} {}104 105 IncrementLoopInfo(IncrementLoopInfo &&) = default;106 IncrementLoopInfo &operator=(IncrementLoopInfo &&x) = default;107 108 bool isStructured() const { return !headerBlock; }109 110 mlir::Type getLoopVariableType() const {111 assert(loopVariable && "must be set");112 return fir::unwrapRefType(loopVariable.getType());113 }114 115 bool hasLocalitySpecs() const {116 return !localSymList.empty() || !localInitSymList.empty() ||117 !reduceSymList.empty() || !sharedSymList.empty();118 }119 120 // Data members common to both structured and unstructured loops.121 const Fortran::semantics::Symbol *loopVariableSym;122 const Fortran::lower::SomeExpr *lowerExpr;123 const Fortran::lower::SomeExpr *upperExpr;124 const Fortran::lower::SomeExpr *stepExpr;125 const Fortran::lower::SomeExpr *maskExpr = nullptr;126 bool isConcurrent;127 llvm::SmallVector<const Fortran::semantics::Symbol *> localSymList;128 llvm::SmallVector<const Fortran::semantics::Symbol *> localInitSymList;129 llvm::SmallVector<const Fortran::semantics::Symbol *> reduceSymList;130 llvm::SmallVector<fir::ReduceOperationEnum> reduceOperatorList;131 llvm::SmallVector<const Fortran::semantics::Symbol *> sharedSymList;132 mlir::Value loopVariable = nullptr;133 134 // Data members for structured loops.135 mlir::Operation *loopOp = nullptr;136 137 // Data members for unstructured loops.138 bool hasRealControl = false;139 mlir::Value tripVariable = nullptr;140 mlir::Value stepVariable = nullptr;141 mlir::Block *headerBlock = nullptr; // loop entry and test block142 mlir::Block *maskBlock = nullptr; // concurrent loop mask block143 mlir::Block *bodyBlock = nullptr; // first loop body block144 mlir::Block *exitBlock = nullptr; // loop exit target block145};146 147/// Information to support stack management, object deallocation, and148/// object finalization at early and normal construct exits.149struct ConstructContext {150 explicit ConstructContext(Fortran::lower::pft::Evaluation &eval,151 Fortran::lower::StatementContext &stmtCtx)152 : eval{eval}, stmtCtx{stmtCtx} {}153 154 Fortran::lower::pft::Evaluation &eval; // construct eval155 Fortran::lower::StatementContext &stmtCtx; // construct exit code156 std::optional<hlfir::Entity> selector; // construct selector, if any.157 bool pushedScope = false; // was a scoped pushed for this construct?158};159 160/// Helper to gather the lower bounds of array components with non deferred161/// shape when they are not all ones. Return an empty array attribute otherwise.162static mlir::DenseI64ArrayAttr163gatherComponentNonDefaultLowerBounds(mlir::Location loc,164 mlir::MLIRContext *mlirContext,165 const Fortran::semantics::Symbol &sym) {166 if (Fortran::semantics::IsAllocatableOrObjectPointer(&sym))167 return {};168 mlir::DenseI64ArrayAttr lbs_attr;169 if (const auto *objDetails =170 sym.detailsIf<Fortran::semantics::ObjectEntityDetails>()) {171 llvm::SmallVector<std::int64_t> lbs;172 bool hasNonDefaultLbs = false;173 for (const Fortran::semantics::ShapeSpec &bounds : objDetails->shape())174 if (auto lb = bounds.lbound().GetExplicit()) {175 if (auto constant = Fortran::evaluate::ToInt64(*lb)) {176 hasNonDefaultLbs |= (*constant != 1);177 lbs.push_back(*constant);178 } else {179 TODO(loc, "generate fir.dt_component for length parametrized derived "180 "types");181 }182 }183 if (hasNonDefaultLbs) {184 assert(static_cast<int>(lbs.size()) == sym.Rank() &&185 "expected component bounds to be constant or deferred");186 lbs_attr = mlir::DenseI64ArrayAttr::get(mlirContext, lbs);187 }188 }189 return lbs_attr;190}191 192// Helper class to generate name of fir.global containing component explicit193// default value for objects, and initial procedure target for procedure pointer194// components.195static mlir::FlatSymbolRefAttr gatherComponentInit(196 mlir::Location loc, Fortran::lower::AbstractConverter &converter,197 const Fortran::semantics::Symbol &sym, fir::RecordType derivedType) {198 mlir::MLIRContext *mlirContext = &converter.getMLIRContext();199 // Return procedure target mangled name for procedure pointer components.200 if (const auto *procPtr =201 sym.detailsIf<Fortran::semantics::ProcEntityDetails>()) {202 if (std::optional<const Fortran::semantics::Symbol *> maybeInitSym =203 procPtr->init()) {204 // So far, do not make distinction between p => NULL() and p without init,205 // f18 always initialize pointers to NULL anyway.206 if (!*maybeInitSym)207 return {};208 return mlir::FlatSymbolRefAttr::get(mlirContext,209 converter.mangleName(**maybeInitSym));210 }211 }212 213 const auto *objDetails =214 sym.detailsIf<Fortran::semantics::ObjectEntityDetails>();215 if (!objDetails || !objDetails->init().has_value())216 return {};217 // Object component initial value. Semantic package component object default218 // value into compiler generated symbols that are lowered as read-only219 // fir.global. Get the name of this global.220 std::string name = fir::NameUniquer::getComponentInitName(221 derivedType.getName(), toStringRef(sym.name()));222 return mlir::FlatSymbolRefAttr::get(mlirContext, name);223}224 225/// Helper class to generate the runtime type info global data and the226/// fir.type_info operations that contain the dipatch tables (if any).227/// The type info global data is required to describe the derived type to the228/// runtime so that it can operate over it.229/// It must be ensured these operations will be generated for every derived type230/// lowered in the current translated unit. However, these operations231/// cannot be generated before FuncOp have been created for functions since the232/// initializers may take their address (e.g for type bound procedures). This233/// class allows registering all the required type info while it is not234/// possible to create GlobalOp/TypeInfoOp, and to generate this data afte235/// function lowering.236class TypeInfoConverter {237 /// Store the location and symbols of derived type info to be generated.238 /// The location of the derived type instantiation is also stored because239 /// runtime type descriptor symbols are compiler generated and cannot be240 /// mapped to user code on their own.241 struct TypeInfo {242 Fortran::semantics::SymbolRef symbol;243 const Fortran::semantics::DerivedTypeSpec &typeSpec;244 fir::RecordType type;245 mlir::Location loc;246 };247 248public:249 void registerTypeInfo(Fortran::lower::AbstractConverter &converter,250 mlir::Location loc,251 Fortran::semantics::SymbolRef typeInfoSym,252 const Fortran::semantics::DerivedTypeSpec &typeSpec,253 fir::RecordType type) {254 if (seen.contains(typeInfoSym))255 return;256 seen.insert(typeInfoSym);257 currentTypeInfoStack->emplace_back(258 TypeInfo{typeInfoSym, typeSpec, type, loc});259 return;260 }261 262 void createTypeInfo(Fortran::lower::AbstractConverter &converter) {263 createTypeInfoForTypeDescriptorBuiltinType(converter);264 while (!registeredTypeInfoA.empty()) {265 currentTypeInfoStack = ®isteredTypeInfoB;266 for (const TypeInfo &info : registeredTypeInfoA)267 createTypeInfoOpAndGlobal(converter, info);268 registeredTypeInfoA.clear();269 currentTypeInfoStack = ®isteredTypeInfoA;270 for (const TypeInfo &info : registeredTypeInfoB)271 createTypeInfoOpAndGlobal(converter, info);272 registeredTypeInfoB.clear();273 }274 }275 276private:277 void createTypeInfoOpAndGlobal(Fortran::lower::AbstractConverter &converter,278 const TypeInfo &info) {279 if (!converter.getLoweringOptions().getSkipExternalRttiDefinition())280 Fortran::lower::createRuntimeTypeInfoGlobal(converter, info.symbol.get());281 createTypeInfoOp(converter, info);282 }283 284 void createTypeInfoForTypeDescriptorBuiltinType(285 Fortran::lower::AbstractConverter &converter) {286 if (registeredTypeInfoA.empty())287 return;288 auto builtinTypeInfoType = llvm::cast<fir::RecordType>(289 converter.genType(registeredTypeInfoA[0].symbol.get()));290 converter.getFirOpBuilder().createTypeInfoOp(291 registeredTypeInfoA[0].loc, builtinTypeInfoType,292 /*parentType=*/fir::RecordType{});293 }294 295 void createTypeInfoOp(Fortran::lower::AbstractConverter &converter,296 const TypeInfo &info) {297 fir::RecordType parentType{};298 if (const Fortran::semantics::DerivedTypeSpec *parent =299 Fortran::evaluate::GetParentTypeSpec(info.typeSpec))300 parentType = mlir::cast<fir::RecordType>(converter.genType(*parent));301 302 fir::FirOpBuilder &builder = converter.getFirOpBuilder();303 fir::TypeInfoOp dt;304 mlir::OpBuilder::InsertPoint insertPointIfCreated;305 std::tie(dt, insertPointIfCreated) =306 builder.createTypeInfoOp(info.loc, info.type, parentType);307 if (!insertPointIfCreated.isSet())308 return; // fir.type_info was already built in a previous call.309 310 // Set init, destroy, and nofinal attributes.311 if (!info.typeSpec.HasDefaultInitialization(/*ignoreAllocatable=*/false,312 /*ignorePointer=*/false))313 dt->setAttr(dt.getNoInitAttrName(), builder.getUnitAttr());314 if (!info.typeSpec.HasDestruction())315 dt->setAttr(dt.getNoDestroyAttrName(), builder.getUnitAttr());316 if (!Fortran::semantics::MayRequireFinalization(info.typeSpec))317 dt->setAttr(dt.getNoFinalAttrName(), builder.getUnitAttr());318 319 const Fortran::semantics::Scope &derivedScope =320 DEREF(info.typeSpec.GetScope());321 322 // Fill binding table region if the derived type has bindings.323 Fortran::semantics::SymbolVector bindings =324 Fortran::semantics::CollectBindings(derivedScope);325 if (!bindings.empty()) {326 builder.createBlock(&dt.getDispatchTable());327 for (const Fortran::semantics::SymbolRef &binding : bindings) {328 const auto &details =329 binding.get().get<Fortran::semantics::ProcBindingDetails>();330 std::string tbpName = binding.get().name().ToString();331 if (details.numPrivatesNotOverridden() > 0)332 tbpName += "."s + std::to_string(details.numPrivatesNotOverridden());333 std::string bindingName = converter.mangleName(details.symbol());334 fir::DTEntryOp::create(335 builder, info.loc,336 mlir::StringAttr::get(builder.getContext(), tbpName),337 mlir::SymbolRefAttr::get(builder.getContext(), bindingName));338 }339 fir::FirEndOp::create(builder, info.loc);340 }341 // Gather info about components that is not reflected in fir.type and may be342 // needed later: component initial values and array component non default343 // lower bounds.344 mlir::Block *componentInfo = nullptr;345 for (const auto &componentName :346 info.typeSpec.typeSymbol()347 .get<Fortran::semantics::DerivedTypeDetails>()348 .componentNames()) {349 auto scopeIter = derivedScope.find(componentName);350 assert(scopeIter != derivedScope.cend() &&351 "failed to find derived type component symbol");352 const Fortran::semantics::Symbol &component = scopeIter->second.get();353 mlir::FlatSymbolRefAttr init_val =354 gatherComponentInit(info.loc, converter, component, info.type);355 mlir::DenseI64ArrayAttr lbs = gatherComponentNonDefaultLowerBounds(356 info.loc, builder.getContext(), component);357 if (init_val || lbs) {358 if (!componentInfo)359 componentInfo = builder.createBlock(&dt.getComponentInfo());360 auto compName = mlir::StringAttr::get(builder.getContext(),361 toStringRef(component.name()));362 fir::DTComponentOp::create(builder, info.loc, compName, lbs, init_val);363 }364 }365 if (componentInfo)366 fir::FirEndOp::create(builder, info.loc);367 builder.restoreInsertionPoint(insertPointIfCreated);368 }369 370 /// Store the front-end data that will be required to generate the type info371 /// for the derived types that have been converted to fir.type<>. There are372 /// two stacks since the type info may visit new types, so the new types must373 /// be added to a new stack.374 llvm::SmallVector<TypeInfo> registeredTypeInfoA;375 llvm::SmallVector<TypeInfo> registeredTypeInfoB;376 llvm::SmallVector<TypeInfo> *currentTypeInfoStack = ®isteredTypeInfoA;377 /// Track symbols symbols processed during and after the registration378 /// to avoid infinite loops between type conversions and global variable379 /// creation.380 llvm::SmallSetVector<Fortran::semantics::SymbolRef, 32> seen;381};382 383using IncrementLoopNestInfo = llvm::SmallVector<IncrementLoopInfo, 8>;384} // namespace385 386//===----------------------------------------------------------------------===//387// FirConverter388//===----------------------------------------------------------------------===//389 390namespace {391 392/// Traverse the pre-FIR tree (PFT) to generate the FIR dialect of MLIR.393class FirConverter : public Fortran::lower::AbstractConverter {394public:395 explicit FirConverter(Fortran::lower::LoweringBridge &bridge)396 : Fortran::lower::AbstractConverter(bridge.getLoweringOptions()),397 bridge{bridge}, foldingContext{bridge.createFoldingContext()},398 mlirSymbolTable{bridge.getModule()} {}399 virtual ~FirConverter() = default;400 401 /// Convert the PFT to FIR.402 void run(Fortran::lower::pft::Program &pft) {403 // Preliminary translation pass.404 405 // Lower common blocks, taking into account initialization and the largest406 // size of all instances of each common block. This is done before lowering407 // since the global definition may differ from any one local definition.408 lowerCommonBlocks(pft.getCommonBlocks());409 410 // - Declare all functions that have definitions so that definition411 // signatures prevail over call site signatures.412 // - Define module variables and OpenMP/OpenACC declarative constructs so413 // they are available before lowering any function that may use them.414 bool hasMainProgram = false;415 const Fortran::semantics::Symbol *globalOmpRequiresSymbol = nullptr;416 createBuilderOutsideOfFuncOpAndDo([&]() {417 for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) {418 Fortran::common::visit(419 Fortran::common::visitors{420 [&](Fortran::lower::pft::FunctionLikeUnit &f) {421 if (f.isMainProgram())422 hasMainProgram = true;423 declareFunction(f);424 if (!globalOmpRequiresSymbol)425 globalOmpRequiresSymbol = f.getScope().symbol();426 },427 [&](Fortran::lower::pft::ModuleLikeUnit &m) {428 lowerModuleDeclScope(m);429 for (Fortran::lower::pft::ContainedUnit &unit :430 m.containedUnitList)431 if (auto *f =432 std::get_if<Fortran::lower::pft::FunctionLikeUnit>(433 &unit))434 declareFunction(*f);435 },436 [&](Fortran::lower::pft::BlockDataUnit &b) {437 if (!globalOmpRequiresSymbol)438 globalOmpRequiresSymbol = b.symTab.symbol();439 },440 [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {},441 [&](Fortran::lower::pft::OpenACCDirectiveUnit &d) {},442 },443 u);444 }445 });446 447 // Ensure imported OpenMP declare mappers are materialized at module448 // scope before lowering any constructs that may reference them.449 createBuilderOutsideOfFuncOpAndDo([&]() {450 Fortran::lower::materializeOpenMPDeclareMappers(451 *this, bridge.getSemanticsContext());452 });453 454 // Create definitions of intrinsic module constants.455 createBuilderOutsideOfFuncOpAndDo(456 [&]() { createIntrinsicModuleDefinitions(pft); });457 458 // Primary translation pass.459 for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) {460 Fortran::common::visit(461 Fortran::common::visitors{462 [&](Fortran::lower::pft::FunctionLikeUnit &f) { lowerFunc(f); },463 [&](Fortran::lower::pft::ModuleLikeUnit &m) { lowerMod(m); },464 [&](Fortran::lower::pft::BlockDataUnit &b) {},465 [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {},466 [&](Fortran::lower::pft::OpenACCDirectiveUnit &d) {},467 },468 u);469 }470 471 // Once all the code has been translated, create global runtime type info472 // data structures for the derived types that have been processed, as well473 // as fir.type_info operations for the dispatch tables.474 createBuilderOutsideOfFuncOpAndDo(475 [&]() { typeInfoConverter.createTypeInfo(*this); });476 477 // Generate the `main` entry point if necessary478 if (hasMainProgram)479 createBuilderOutsideOfFuncOpAndDo([&]() {480 fir::runtime::genMain(*builder, toLocation(),481 bridge.getEnvironmentDefaults(),482 getFoldingContext().languageFeatures().IsEnabled(483 Fortran::common::LanguageFeature::CUDA),484 getFoldingContext().languageFeatures().IsEnabled(485 Fortran::common::LanguageFeature::Coarray));486 });487 488 finalizeOpenMPLowering(globalOmpRequiresSymbol);489 }490 491 /// Declare a function.492 void declareFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {493 CHECK(builder && "declareFunction called with uninitialized builder");494 setCurrentPosition(funit.getStartingSourceLoc());495 for (int entryIndex = 0, last = funit.entryPointList.size();496 entryIndex < last; ++entryIndex) {497 funit.setActiveEntry(entryIndex);498 // Calling CalleeInterface ctor will build a declaration499 // mlir::func::FuncOp with no other side effects.500 // TODO: when doing some compiler profiling on real apps, it may be worth501 // to check it's better to save the CalleeInterface instead of recomputing502 // it later when lowering the body. CalleeInterface ctor should be linear503 // with the number of arguments, so it is not awful to do it that way for504 // now, but the linear coefficient might be non negligible. Until505 // measured, stick to the solution that impacts the code less.506 Fortran::lower::CalleeInterface{funit, *this};507 }508 funit.setActiveEntry(0);509 510 // Compute the set of host associated entities from the nested functions.511 llvm::SetVector<const Fortran::semantics::Symbol *> escapeHost;512 for (Fortran::lower::pft::ContainedUnit &unit : funit.containedUnitList)513 if (auto *f = std::get_if<Fortran::lower::pft::FunctionLikeUnit>(&unit))514 collectHostAssociatedVariables(*f, escapeHost);515 funit.setHostAssociatedSymbols(escapeHost);516 517 // Declare internal procedures518 for (Fortran::lower::pft::ContainedUnit &unit : funit.containedUnitList)519 if (auto *f = std::get_if<Fortran::lower::pft::FunctionLikeUnit>(&unit))520 declareFunction(*f);521 }522 523 /// Get the scope that is defining or using \p sym. The returned scope is not524 /// the ultimate scope, since this helper does not traverse use association.525 /// This allows capturing module variables that are referenced in an internal526 /// procedure but whose use statement is inside the host program.527 const Fortran::semantics::Scope &528 getSymbolHostScope(const Fortran::semantics::Symbol &sym) {529 const Fortran::semantics::Symbol *hostSymbol = &sym;530 while (const auto *details =531 hostSymbol->detailsIf<Fortran::semantics::HostAssocDetails>())532 hostSymbol = &details->symbol();533 return hostSymbol->owner();534 }535 536 /// Collects the canonical list of all host associated symbols. These bindings537 /// must be aggregated into a tuple which can then be added to each of the538 /// internal procedure declarations and passed at each call site.539 void collectHostAssociatedVariables(540 Fortran::lower::pft::FunctionLikeUnit &funit,541 llvm::SetVector<const Fortran::semantics::Symbol *> &escapees) {542 const Fortran::semantics::Scope *internalScope =543 funit.getSubprogramSymbol().scope();544 assert(internalScope && "internal procedures symbol must create a scope");545 auto addToListIfEscapee = [&](const Fortran::semantics::Symbol &sym) {546 const Fortran::semantics::Symbol &ultimate = sym.GetUltimate();547 const auto *namelistDetails =548 ultimate.detailsIf<Fortran::semantics::NamelistDetails>();549 if (ultimate.has<Fortran::semantics::ObjectEntityDetails>() ||550 Fortran::semantics::IsProcedurePointer(ultimate) ||551 Fortran::semantics::IsDummy(sym) || namelistDetails) {552 const Fortran::semantics::Scope &symbolScope = getSymbolHostScope(sym);553 if (symbolScope.kind() ==554 Fortran::semantics::Scope::Kind::MainProgram ||555 symbolScope.kind() == Fortran::semantics::Scope::Kind::Subprogram)556 if (symbolScope != *internalScope &&557 symbolScope.Contains(*internalScope)) {558 if (namelistDetails) {559 // So far, namelist symbols are processed on the fly in IO and560 // the related namelist data structure is not added to the symbol561 // map, so it cannot be passed to the internal procedures.562 // Instead, all the symbols of the host namelist used in the563 // internal procedure must be considered as host associated so564 // that IO lowering can find them when needed.565 for (const auto &namelistObject : namelistDetails->objects())566 escapees.insert(&*namelistObject);567 } else {568 escapees.insert(&ultimate);569 }570 }571 }572 };573 Fortran::lower::pft::visitAllSymbols(funit, addToListIfEscapee);574 }575 576 //===--------------------------------------------------------------------===//577 // AbstractConverter overrides578 //===--------------------------------------------------------------------===//579 580 mlir::Value getSymbolAddress(Fortran::lower::SymbolRef sym) override final {581 return lookupSymbol(sym).getAddr();582 }583 584 fir::ExtendedValue symBoxToExtendedValue(585 const Fortran::lower::SymbolBox &symBox) override final {586 return symBox.match(587 [](const Fortran::lower::SymbolBox::Intrinsic &box)588 -> fir::ExtendedValue { return box.getAddr(); },589 [](const Fortran::lower::SymbolBox::None &) -> fir::ExtendedValue {590 llvm::report_fatal_error("symbol not mapped");591 },592 [&](const fir::FortranVariableOpInterface &x) -> fir::ExtendedValue {593 return hlfir::translateToExtendedValue(getCurrentLocation(),594 getFirOpBuilder(), x);595 },596 [](const auto &box) -> fir::ExtendedValue { return box; });597 }598 599 fir::ExtendedValue600 getSymbolExtendedValue(const Fortran::semantics::Symbol &sym,601 Fortran::lower::SymMap *symMap) override final {602 Fortran::lower::SymbolBox sb = lookupSymbol(sym, symMap);603 if (!sb) {604 LLVM_DEBUG(llvm::dbgs() << "unknown symbol: " << sym << "\nmap: "605 << (symMap ? *symMap : localSymbols) << '\n');606 fir::emitFatalError(getCurrentLocation(),607 "symbol is not mapped to any IR value");608 }609 return symBoxToExtendedValue(sb);610 }611 612 mlir::Value impliedDoBinding(llvm::StringRef name) override final {613 mlir::Value val = localSymbols.lookupImpliedDo(name);614 if (!val)615 fir::emitFatalError(toLocation(), "ac-do-variable has no binding");616 return val;617 }618 619 void copySymbolBinding(Fortran::lower::SymbolRef src,620 Fortran::lower::SymbolRef target) override final {621 localSymbols.copySymbolBinding(src, target);622 }623 624 /// Add the symbol binding to the inner-most level of the symbol map and625 /// return true if it is not already present. Otherwise, return false.626 bool bindIfNewSymbol(Fortran::lower::SymbolRef sym,627 const fir::ExtendedValue &exval) {628 if (shallowLookupSymbol(sym))629 return false;630 bindSymbol(sym, exval);631 return true;632 }633 634 void bindSymbol(Fortran::lower::SymbolRef sym,635 const fir::ExtendedValue &exval) override final {636 addSymbol(sym, exval, /*forced=*/true);637 }638 639 void bindSymbolStorage(640 Fortran::lower::SymbolRef sym,641 Fortran::lower::SymMap::StorageDesc storage) override final {642 localSymbols.registerStorage(sym, std::move(storage));643 }644 645 Fortran::lower::SymMap::StorageDesc646 getSymbolStorage(Fortran::lower::SymbolRef sym) override final {647 return localSymbols.lookupStorage(sym);648 }649 650 Fortran::lower::SymMap &getSymbolMap() override final { return localSymbols; }651 652 void653 overrideExprValues(const Fortran::lower::ExprToValueMap *map) override final {654 exprValueOverrides = map;655 }656 657 const Fortran::lower::ExprToValueMap *getExprOverrides() override final {658 return exprValueOverrides;659 }660 661 bool lookupLabelSet(Fortran::lower::SymbolRef sym,662 Fortran::lower::pft::LabelSet &labelSet) override final {663 Fortran::lower::pft::FunctionLikeUnit &owningProc =664 *getEval().getOwningProcedure();665 auto iter = owningProc.assignSymbolLabelMap.find(sym);666 if (iter == owningProc.assignSymbolLabelMap.end())667 return false;668 labelSet = iter->second;669 return true;670 }671 672 Fortran::lower::pft::Evaluation *673 lookupLabel(Fortran::lower::pft::Label label) override final {674 Fortran::lower::pft::FunctionLikeUnit &owningProc =675 *getEval().getOwningProcedure();676 return owningProc.labelEvaluationMap.lookup(label);677 }678 679 fir::ExtendedValue680 genExprAddr(const Fortran::lower::SomeExpr &expr,681 Fortran::lower::StatementContext &context,682 mlir::Location *locPtr = nullptr) override final {683 mlir::Location loc = locPtr ? *locPtr : toLocation();684 if (lowerToHighLevelFIR())685 return Fortran::lower::convertExprToAddress(loc, *this, expr,686 localSymbols, context);687 return Fortran::lower::createSomeExtendedAddress(loc, *this, expr,688 localSymbols, context);689 }690 691 fir::ExtendedValue692 genExprValue(const Fortran::lower::SomeExpr &expr,693 Fortran::lower::StatementContext &context,694 mlir::Location *locPtr = nullptr) override final {695 mlir::Location loc = locPtr ? *locPtr : toLocation();696 if (lowerToHighLevelFIR())697 return Fortran::lower::convertExprToValue(loc, *this, expr, localSymbols,698 context);699 return Fortran::lower::createSomeExtendedExpression(loc, *this, expr,700 localSymbols, context);701 }702 703 fir::ExtendedValue704 genExprBox(mlir::Location loc, const Fortran::lower::SomeExpr &expr,705 Fortran::lower::StatementContext &stmtCtx) override final {706 if (lowerToHighLevelFIR())707 return Fortran::lower::convertExprToBox(loc, *this, expr, localSymbols,708 stmtCtx);709 return Fortran::lower::createBoxValue(loc, *this, expr, localSymbols,710 stmtCtx);711 }712 713 Fortran::evaluate::FoldingContext &getFoldingContext() override final {714 return foldingContext;715 }716 717 mlir::Type genType(const Fortran::lower::SomeExpr &expr) override final {718 return Fortran::lower::translateSomeExprToFIRType(*this, expr);719 }720 mlir::Type genType(const Fortran::lower::pft::Variable &var) override final {721 return Fortran::lower::translateVariableToFIRType(*this, var);722 }723 mlir::Type genType(Fortran::lower::SymbolRef sym) override final {724 return Fortran::lower::translateSymbolToFIRType(*this, sym);725 }726 mlir::Type727 genType(Fortran::common::TypeCategory tc, int kind,728 llvm::ArrayRef<std::int64_t> lenParameters) override final {729 return Fortran::lower::getFIRType(&getMLIRContext(), tc, kind,730 lenParameters);731 }732 mlir::Type733 genType(const Fortran::semantics::DerivedTypeSpec &tySpec) override final {734 return Fortran::lower::translateDerivedTypeToFIRType(*this, tySpec);735 }736 mlir::Type genType(Fortran::common::TypeCategory tc) override final {737 return Fortran::lower::getFIRType(738 &getMLIRContext(), tc, bridge.getDefaultKinds().GetDefaultKind(tc), {});739 }740 741 Fortran::lower::TypeConstructionStack &742 getTypeConstructionStack() override final {743 return typeConstructionStack;744 }745 746 bool747 isPresentShallowLookup(const Fortran::semantics::Symbol &sym) override final {748 return bool(shallowLookupSymbol(sym));749 }750 751 bool createHostAssociateVarClone(const Fortran::semantics::Symbol &sym,752 bool skipDefaultInit) override final {753 mlir::Location loc = genLocation(sym.name());754 mlir::Type symType = genType(sym);755 const auto *details = sym.detailsIf<Fortran::semantics::HostAssocDetails>();756 assert(details && "No host-association found");757 const Fortran::semantics::Symbol &hsym = details->symbol();758 mlir::Type hSymType = genType(hsym.GetUltimate());759 Fortran::lower::SymbolBox hsb =760 lookupSymbol(hsym, /*symMap=*/nullptr, /*forceHlfirBase=*/true);761 762 auto allocate = [&](llvm::ArrayRef<mlir::Value> shape,763 llvm::ArrayRef<mlir::Value> typeParams) -> mlir::Value {764 mlir::Value allocVal = builder->allocateLocal(765 loc,766 Fortran::semantics::IsAllocatableOrObjectPointer(&hsym.GetUltimate())767 ? hSymType768 : symType,769 mangleName(sym), toStringRef(sym.GetUltimate().name()),770 /*pinned=*/true, shape, typeParams,771 sym.GetUltimate().attrs().test(Fortran::semantics::Attr::TARGET));772 return allocVal;773 };774 775 fir::ExtendedValue hexv = symBoxToExtendedValue(hsb);776 fir::ExtendedValue exv = hexv.match(777 [&](const fir::BoxValue &box) -> fir::ExtendedValue {778 const Fortran::semantics::DeclTypeSpec *type = sym.GetType();779 if (type && type->IsPolymorphic())780 TODO(loc, "create polymorphic host associated copy");781 // Create a contiguous temp with the same shape and length as782 // the original variable described by a fir.box.783 llvm::SmallVector<mlir::Value> extents =784 fir::factory::getExtents(loc, *builder, hexv);785 if (box.isDerivedWithLenParameters())786 TODO(loc, "get length parameters from derived type BoxValue");787 if (box.isCharacter()) {788 mlir::Value len = fir::factory::readCharLen(*builder, loc, box);789 mlir::Value temp = allocate(extents, {len});790 return fir::CharArrayBoxValue{temp, len, extents};791 }792 return fir::ArrayBoxValue{allocate(extents, {}), extents};793 },794 [&](const fir::MutableBoxValue &box) -> fir::ExtendedValue {795 // Allocate storage for a pointer/allocatble descriptor.796 // No shape/lengths to be passed to the alloca.797 return fir::MutableBoxValue(allocate({}, {}), {}, {});798 },799 [&](const auto &) -> fir::ExtendedValue {800 mlir::Value temp =801 allocate(fir::factory::getExtents(loc, *builder, hexv),802 fir::factory::getTypeParams(loc, *builder, hexv));803 return fir::substBase(hexv, temp);804 });805 806 // Initialise cloned allocatable807 hexv.match(808 [&](const fir::MutableBoxValue &box) -> void {809 const auto new_box = exv.getBoxOf<fir::MutableBoxValue>();810 if (Fortran::semantics::IsPointer(sym.GetUltimate())) {811 // Establish the pointer descriptors. The rank and type code/size812 // at least must be set properly for later inquiry of the pointer813 // to work, and new pointers are always given disassociated status814 // by flang for safety, even if this is not required by the815 // language.816 auto empty = fir::factory::createUnallocatedBox(817 *builder, loc, new_box->getBoxTy(), box.nonDeferredLenParams(),818 {});819 fir::StoreOp::create(*builder, loc, empty, new_box->getAddr());820 return;821 }822 // Copy allocation status of Allocatables, creating new storage if823 // needed.824 825 // allocate if allocated826 mlir::Value isAllocated =827 fir::factory::genIsAllocatedOrAssociatedTest(*builder, loc, box);828 auto if_builder = builder->genIfThenElse(loc, isAllocated);829 if_builder.genThen([&]() {830 std::string name = mangleName(sym) + ".alloc";831 fir::ExtendedValue read = fir::factory::genMutableBoxRead(832 *builder, loc, box, /*mayBePolymorphic=*/false);833 if (auto read_arr_box = read.getBoxOf<fir::ArrayBoxValue>()) {834 fir::factory::genInlinedAllocation(*builder, loc, *new_box,835 read_arr_box->getLBounds(),836 read_arr_box->getExtents(),837 /*lenParams=*/{}, name,838 /*mustBeHeap=*/true);839 } else if (auto read_char_arr_box =840 read.getBoxOf<fir::CharArrayBoxValue>()) {841 fir::factory::genInlinedAllocation(842 *builder, loc, *new_box, read_char_arr_box->getLBounds(),843 read_char_arr_box->getExtents(), read_char_arr_box->getLen(),844 name,845 /*mustBeHeap=*/true);846 } else if (auto read_char_box =847 read.getBoxOf<fir::CharBoxValue>()) {848 fir::factory::genInlinedAllocation(*builder, loc, *new_box,849 /*lbounds=*/{},850 /*extents=*/{},851 read_char_box->getLen(), name,852 /*mustBeHeap=*/true);853 } else {854 fir::factory::genInlinedAllocation(855 *builder, loc, *new_box, box.getMutableProperties().lbounds,856 box.getMutableProperties().extents,857 box.nonDeferredLenParams(), name,858 /*mustBeHeap=*/true);859 }860 });861 if_builder.genElse([&]() {862 // nullify box863 auto empty = fir::factory::createUnallocatedBox(864 *builder, loc, new_box->getBoxTy(),865 new_box->nonDeferredLenParams(), {});866 fir::StoreOp::create(*builder, loc, empty, new_box->getAddr());867 });868 if_builder.end();869 },870 [&](const auto &) -> void {871 // Always initialize allocatable component descriptor, even when the872 // value is later copied from the host (e.g. firstprivate) because the873 // assignment from the host to the copy will fail if the component874 // descriptors are not initialized.875 if (skipDefaultInit && !hlfir::mayHaveAllocatableComponent(hSymType))876 return;877 // Initialize local/private derived types with default878 // initialization (Fortran 2023 section 11.1.7.5 and OpenMP 5.2879 // section 5.3). Pointer and allocatable components, when allowed,880 // also need to be established so that flang runtime can later work881 // with them.882 if (const Fortran::semantics::DeclTypeSpec *declTypeSpec =883 sym.GetType())884 if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec =885 declTypeSpec->AsDerived())886 if (derivedTypeSpec->HasDefaultInitialization(887 /*ignoreAllocatable=*/false, /*ignorePointer=*/false)) {888 mlir::Value box = builder->createBox(loc, exv);889 fir::runtime::genDerivedTypeInitialize(*builder, loc, box);890 }891 });892 893 return bindIfNewSymbol(sym, exv);894 }895 896 void createHostAssociateVarCloneDealloc(897 const Fortran::semantics::Symbol &sym) override final {898 mlir::Location loc = genLocation(sym.name());899 Fortran::lower::SymbolBox hsb =900 lookupSymbol(sym, /*symMap=*/nullptr, /*forceHlfirBase=*/true);901 902 fir::ExtendedValue hexv = symBoxToExtendedValue(hsb);903 hexv.match(904 [&](const fir::MutableBoxValue &new_box) -> void {905 // Do not process pointers906 if (Fortran::semantics::IsPointer(sym.GetUltimate())) {907 return;908 }909 // deallocate allocated in createHostAssociateVarClone value910 Fortran::lower::genDeallocateIfAllocated(*this, new_box, loc);911 },912 [&](const auto &) -> void {913 // Do nothing914 });915 }916 917 void copyVar(mlir::Location loc, mlir::Value dst, mlir::Value src,918 fir::FortranVariableFlagsEnum attrs) override final {919 bool isAllocatable =920 bitEnumContainsAny(attrs, fir::FortranVariableFlagsEnum::allocatable);921 bool isPointer =922 bitEnumContainsAny(attrs, fir::FortranVariableFlagsEnum::pointer);923 924 copyVarHLFIR(loc, Fortran::lower::SymbolBox::Intrinsic{dst},925 Fortran::lower::SymbolBox::Intrinsic{src}, isAllocatable,926 isPointer, Fortran::semantics::Symbol::Flags());927 }928 929 void930 copyHostAssociateVar(const Fortran::semantics::Symbol &sym,931 mlir::OpBuilder::InsertPoint *copyAssignIP = nullptr,932 bool hostIsSource = true) override final {933 // 1) Fetch the original copy of the variable.934 assert(sym.has<Fortran::semantics::HostAssocDetails>() &&935 "No host-association found");936 const Fortran::semantics::Symbol &hsym = sym.GetUltimate();937 Fortran::lower::SymbolBox hsb = lookupOneLevelUpSymbol(hsym);938 assert(hsb && "Host symbol box not found");939 940 // 2) Fetch the copied one that will mask the original.941 Fortran::lower::SymbolBox sb = shallowLookupSymbol(sym);942 assert(sb && "Host-associated symbol box not found");943 assert(hsb.getAddr() != sb.getAddr() &&944 "Host and associated symbol boxes are the same");945 946 // 3) Perform the assignment.947 mlir::OpBuilder::InsertionGuard guard(*builder);948 if (copyAssignIP && copyAssignIP->isSet())949 builder->restoreInsertionPoint(*copyAssignIP);950 else951 builder->setInsertionPointAfter(sb.getAddr().getDefiningOp());952 953 Fortran::lower::SymbolBox *lhs_sb, *rhs_sb;954 if (!hostIsSource) {955 lhs_sb = &hsb;956 rhs_sb = &sb;957 } else {958 lhs_sb = &sb;959 rhs_sb = &hsb;960 }961 962 copyVar(sym, *lhs_sb, *rhs_sb, sym.flags());963 }964 965 void genEval(Fortran::lower::pft::Evaluation &eval,966 bool unstructuredContext) override final {967 genFIR(eval, unstructuredContext);968 }969 970 //===--------------------------------------------------------------------===//971 // Utility methods972 //===--------------------------------------------------------------------===//973 974 void collectSymbolSet(975 Fortran::lower::pft::Evaluation &eval,976 llvm::SetVector<const Fortran::semantics::Symbol *> &symbolSet,977 Fortran::semantics::Symbol::Flag flag, bool collectSymbols,978 bool checkHostAssociatedSymbols) override final {979 auto addToList = [&](const Fortran::semantics::Symbol &sym) {980 std::function<void(const Fortran::semantics::Symbol &, bool)>981 insertSymbols = [&](const Fortran::semantics::Symbol &oriSymbol,982 bool collectSymbol) {983 if (collectSymbol && oriSymbol.test(flag)) {984 symbolSet.insert(&oriSymbol);985 } else if (const auto *commonDetails =986 oriSymbol.detailsIf<987 Fortran::semantics::CommonBlockDetails>()) {988 for (const auto &mem : commonDetails->objects())989 if (collectSymbol && mem->test(flag))990 symbolSet.insert(&(*mem).GetUltimate());991 } else if (checkHostAssociatedSymbols) {992 if (const auto *details{993 oriSymbol994 .detailsIf<Fortran::semantics::HostAssocDetails>()})995 insertSymbols(details->symbol(), true);996 }997 };998 insertSymbols(sym, collectSymbols);999 };1000 Fortran::lower::pft::visitAllSymbols(eval, addToList);1001 }1002 1003 mlir::Location getCurrentLocation() override final { return toLocation(); }1004 1005 /// Generate a dummy location.1006 mlir::Location genUnknownLocation() override final {1007 // Note: builder may not be instantiated yet1008 return mlir::UnknownLoc::get(&getMLIRContext());1009 }1010 1011 static mlir::Location genLocation(Fortran::parser::SourcePosition pos,1012 mlir::MLIRContext &ctx) {1013 llvm::SmallString<256> path(*pos.path);1014 llvm::sys::fs::make_absolute(path);1015 llvm::sys::path::remove_dots(path);1016 return mlir::FileLineColLoc::get(&ctx, path.str(), pos.line, pos.column);1017 }1018 1019 /// Generate a `Location` from the `CharBlock`.1020 mlir::Location1021 genLocation(const Fortran::parser::CharBlock &block) override final {1022 mlir::Location mainLocation = genUnknownLocation();1023 if (const Fortran::parser::AllCookedSources *cooked =1024 bridge.getCookedSource()) {1025 if (std::optional<Fortran::parser::ProvenanceRange> provenance =1026 cooked->GetProvenanceRange(block)) {1027 if (std::optional<Fortran::parser::SourcePosition> filePos =1028 cooked->allSources().GetSourcePosition(provenance->start()))1029 mainLocation = genLocation(*filePos, getMLIRContext());1030 1031 llvm::SmallVector<mlir::Location> locs;1032 locs.push_back(mainLocation);1033 1034 llvm::SmallVector<fir::LocationKindAttr> locAttrs;1035 locAttrs.push_back(fir::LocationKindAttr::get(&getMLIRContext(),1036 fir::LocationKind::Base));1037 1038 // Gather include location information if any.1039 Fortran::parser::ProvenanceRange *prov = &*provenance;1040 while (prov) {1041 if (std::optional<Fortran::parser::ProvenanceRange> include =1042 cooked->allSources().GetInclusionInfo(*prov)) {1043 if (std::optional<Fortran::parser::SourcePosition> incPos =1044 cooked->allSources().GetSourcePosition(include->start())) {1045 locs.push_back(genLocation(*incPos, getMLIRContext()));1046 locAttrs.push_back(fir::LocationKindAttr::get(1047 &getMLIRContext(), fir::LocationKind::Inclusion));1048 }1049 prov = &*include;1050 } else {1051 prov = nullptr;1052 }1053 }1054 if (locs.size() > 1) {1055 assert(locs.size() == locAttrs.size() &&1056 "expect as many attributes as locations");1057 return mlir::FusedLocWith<fir::LocationKindArrayAttr>::get(1058 &getMLIRContext(), locs,1059 fir::LocationKindArrayAttr::get(&getMLIRContext(), locAttrs));1060 }1061 }1062 }1063 return mainLocation;1064 }1065 1066 const Fortran::semantics::Scope &getCurrentScope() override final {1067 return bridge.getSemanticsContext().FindScope(currentPosition);1068 }1069 1070 fir::FirOpBuilder &getFirOpBuilder() override final {1071 CHECK(builder && "builder is not set before calling getFirOpBuilder");1072 return *builder;1073 }1074 1075 mlir::ModuleOp getModuleOp() override final { return bridge.getModule(); }1076 1077 mlir::MLIRContext &getMLIRContext() override final {1078 return bridge.getMLIRContext();1079 }1080 std::string1081 mangleName(const Fortran::semantics::Symbol &symbol) override final {1082 return Fortran::lower::mangle::mangleName(1083 symbol, scopeBlockIdMap, /*keepExternalInScope=*/false,1084 getLoweringOptions().getUnderscoring());1085 }1086 std::string mangleName(1087 const Fortran::semantics::DerivedTypeSpec &derivedType) override final {1088 return Fortran::lower::mangle::mangleName(derivedType, scopeBlockIdMap);1089 }1090 std::string mangleName(std::string &name) override final {1091 return Fortran::lower::mangle::mangleName(name, getCurrentScope(),1092 scopeBlockIdMap);1093 }1094 std::string1095 mangleName(std::string &name,1096 const Fortran::semantics::Scope &myScope) override final {1097 return Fortran::lower::mangle::mangleName(name, myScope, scopeBlockIdMap);1098 }1099 std::string getRecordTypeFieldName(1100 const Fortran::semantics::Symbol &component) override final {1101 return Fortran::lower::mangle::getRecordTypeFieldName(component,1102 scopeBlockIdMap);1103 }1104 const fir::KindMapping &getKindMap() override final {1105 return bridge.getKindMap();1106 }1107 1108 /// Return the current function context, which may be a nested BLOCK context1109 /// or a full subprogram context.1110 Fortran::lower::StatementContext &getFctCtx() override final {1111 if (!activeConstructStack.empty() &&1112 activeConstructStack.back().eval.isA<Fortran::parser::BlockConstruct>())1113 return activeConstructStack.back().stmtCtx;1114 return bridge.fctCtx();1115 }1116 1117 /// Initializes values for STAT and ERRMSG1118 std::pair<mlir::Value, mlir::Value>1119 genStatAndErrmsg(mlir::Location loc,1120 const std::list<Fortran::parser::StatOrErrmsg>1121 &statOrErrList) override final {1122 Fortran::lower::StatementContext stmtCtx;1123 1124 mlir::Value errMsgExpr, statExpr;1125 for (const Fortran::parser::StatOrErrmsg &statOrErr : statOrErrList) {1126 std::visit(Fortran::common::visitors{1127 [&](const Fortran::parser::StatVariable &statVar) {1128 const Fortran::semantics::SomeExpr *expr =1129 Fortran::semantics::GetExpr(statVar);1130 statExpr =1131 fir::getBase(genExprAddr(*expr, stmtCtx, &loc));1132 },1133 [&](const Fortran::parser::MsgVariable &errMsgVar) {1134 const Fortran::semantics::SomeExpr *expr =1135 Fortran::semantics::GetExpr(errMsgVar);1136 errMsgExpr =1137 fir::getBase(genExprBox(loc, *expr, stmtCtx));1138 }},1139 statOrErr.u);1140 }1141 1142 return {statExpr, errMsgExpr};1143 }1144 1145 mlir::Value hostAssocTupleValue() override final { return hostAssocTuple; }1146 1147 /// Record a binding for the ssa-value of the tuple for this function.1148 void bindHostAssocTuple(mlir::Value val) override final {1149 assert(!hostAssocTuple && val);1150 hostAssocTuple = val;1151 }1152 1153 mlir::Value dummyArgsScopeValue() const override final {1154 return dummyArgsScope;1155 }1156 1157 bool isRegisteredDummySymbol(1158 Fortran::semantics::SymbolRef symRef) const override final {1159 auto *sym = &*symRef;1160 return registeredDummySymbols.contains(sym);1161 }1162 1163 unsigned getDummyArgPosition(1164 const Fortran::semantics::Symbol &sym) const override final {1165 auto it = dummyArgPositions.find(&sym);1166 return (it != dummyArgPositions.end()) ? it->second : 0;1167 }1168 1169 const Fortran::lower::pft::FunctionLikeUnit *1170 getCurrentFunctionUnit() const override final {1171 return currentFunctionUnit;1172 }1173 1174 void checkCoarrayEnabled() override final {1175 if (!getFoldingContext().languageFeatures().IsEnabled(1176 Fortran::common::LanguageFeature::Coarray))1177 fir::emitFatalError(1178 getCurrentLocation(),1179 "Not yet implemented: Multi-image features are experimental and are "1180 "disabled by default, use '-fcoarray' to enable.",1181 false);1182 }1183 1184 void registerTypeInfo(mlir::Location loc,1185 Fortran::lower::SymbolRef typeInfoSym,1186 const Fortran::semantics::DerivedTypeSpec &typeSpec,1187 fir::RecordType type) override final {1188 typeInfoConverter.registerTypeInfo(*this, loc, typeInfoSym, typeSpec, type);1189 }1190 1191 llvm::StringRef1192 getUniqueLitName(mlir::Location loc,1193 std::unique_ptr<Fortran::lower::SomeExpr> expr,1194 mlir::Type eleTy) override final {1195 std::string namePrefix =1196 getConstantExprManglePrefix(loc, *expr.get(), eleTy);1197 auto [it, inserted] = literalNamesMap.try_emplace(1198 expr.get(), namePrefix + std::to_string(uniqueLitId));1199 const auto &name = it->second;1200 if (inserted) {1201 // Keep ownership of the expr key.1202 literalExprsStorage.push_back(std::move(expr));1203 1204 // If we've just added a new name, we have to make sure1205 // there is no global object with the same name in the module.1206 fir::GlobalOp global = builder->getNamedGlobal(name);1207 if (global)1208 fir::emitFatalError(loc, llvm::Twine("global object with name '") +1209 llvm::Twine(name) +1210 llvm::Twine("' already exists"));1211 ++uniqueLitId;1212 return name;1213 }1214 1215 // The name already exists. Verify that the prefix is the same.1216 if (!llvm::StringRef(name).starts_with(namePrefix))1217 fir::emitFatalError(loc, llvm::Twine("conflicting prefixes: '") +1218 llvm::Twine(name) +1219 llvm::Twine("' does not start with '") +1220 llvm::Twine(namePrefix) + llvm::Twine("'"));1221 1222 return name;1223 }1224 1225 /// Find the symbol in the inner-most level of the local map or return null.1226 Fortran::lower::SymbolBox1227 shallowLookupSymbol(const Fortran::semantics::Symbol &sym) override {1228 if (Fortran::lower::SymbolBox v = localSymbols.shallowLookupSymbol(sym))1229 return v;1230 return {};1231 }1232 1233private:1234 FirConverter() = delete;1235 FirConverter(const FirConverter &) = delete;1236 FirConverter &operator=(const FirConverter &) = delete;1237 1238 //===--------------------------------------------------------------------===//1239 // Helper member functions1240 //===--------------------------------------------------------------------===//1241 1242 mlir::Value createFIRExpr(mlir::Location loc,1243 const Fortran::lower::SomeExpr *expr,1244 Fortran::lower::StatementContext &stmtCtx) {1245 return fir::getBase(genExprValue(*expr, stmtCtx, &loc));1246 }1247 1248 /// Find the symbol in the local map or return null.1249 Fortran::lower::SymbolBox1250 lookupSymbol(const Fortran::semantics::Symbol &sym,1251 Fortran::lower::SymMap *symMap = nullptr,1252 bool forceHlfirBase = false) {1253 symMap = symMap ? symMap : &localSymbols;1254 if (lowerToHighLevelFIR()) {1255 if (std::optional<fir::FortranVariableOpInterface> var =1256 symMap->lookupVariableDefinition(sym)) {1257 auto exv = hlfir::translateToExtendedValue(toLocation(), *builder, *var,1258 forceHlfirBase);1259 return exv.match(1260 [](mlir::Value x) -> Fortran::lower::SymbolBox {1261 return Fortran::lower::SymbolBox::Intrinsic{x};1262 },1263 [](auto x) -> Fortran::lower::SymbolBox { return x; });1264 }1265 1266 // Entry character result represented as an argument pair1267 // needs to be represented in the symbol table even before1268 // we can create DeclareOp for it. The temporary mapping1269 // is EmboxCharOp that conveys the address and length information.1270 // After mapSymbolAttributes is done, the mapping is replaced1271 // with the new DeclareOp, and the following table lookups1272 // do not reach here.1273 if (sym.IsFuncResult())1274 if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType())1275 if (declTy->category() ==1276 Fortran::semantics::DeclTypeSpec::Category::Character)1277 return symMap->lookupSymbol(sym);1278 1279 // Procedure dummies are not mapped with an hlfir.declare because1280 // they are not "variable" (cannot be assigned to), and it would1281 // make hlfir.declare more complex than it needs to to allow this.1282 // Do a regular lookup.1283 if (Fortran::semantics::IsProcedure(sym))1284 return symMap->lookupSymbol(sym);1285 1286 // Commonblock names are not variables, but in some lowerings (like1287 // OpenMP) it is useful to maintain the address of the commonblock in an1288 // MLIR value and query it. hlfir.declare need not be created for these.1289 if (sym.detailsIf<Fortran::semantics::CommonBlockDetails>())1290 return symMap->lookupSymbol(sym);1291 1292 // For symbols to be privatized in OMP, the symbol is mapped to an1293 // instance of `SymbolBox::Intrinsic` (i.e. a direct mapping to an MLIR1294 // SSA value). This MLIR SSA value is the block argument to the1295 // `omp.private`'s `alloc` block. If this is the case, we return this1296 // `SymbolBox::Intrinsic` value.1297 if (Fortran::lower::SymbolBox v = symMap->lookupSymbol(sym))1298 return v;1299 1300 return {};1301 }1302 if (Fortran::lower::SymbolBox v = symMap->lookupSymbol(sym))1303 return v;1304 return {};1305 }1306 1307 /// Find the symbol in one level up of symbol map such as for host-association1308 /// in OpenMP code or return null.1309 Fortran::lower::SymbolBox1310 lookupOneLevelUpSymbol(const Fortran::semantics::Symbol &sym) override {1311 if (Fortran::lower::SymbolBox v = localSymbols.lookupOneLevelUpSymbol(sym))1312 return v;1313 return {};1314 }1315 1316 mlir::SymbolTable *getMLIRSymbolTable() override { return &mlirSymbolTable; }1317 1318 mlir::StateStack &getStateStack() override { return stateStack; }1319 1320 /// Add the symbol to the local map and return `true`. If the symbol is1321 /// already in the map and \p forced is `false`, the map is not updated.1322 /// Instead the value `false` is returned.1323 bool addSymbol(const Fortran::semantics::SymbolRef sym,1324 fir::ExtendedValue val, bool forced = false) {1325 if (!forced && lookupSymbol(sym))1326 return false;1327 if (lowerToHighLevelFIR()) {1328 Fortran::lower::genDeclareSymbol(*this, localSymbols, sym, val,1329 fir::FortranVariableFlagsEnum::None,1330 forced);1331 } else {1332 localSymbols.addSymbol(sym, val, forced);1333 }1334 return true;1335 }1336 1337 void copyVar(const Fortran::semantics::Symbol &sym,1338 const Fortran::lower::SymbolBox &lhs_sb,1339 const Fortran::lower::SymbolBox &rhs_sb,1340 Fortran::semantics::Symbol::Flags flags) {1341 mlir::Location loc = genLocation(sym.name());1342 if (lowerToHighLevelFIR())1343 copyVarHLFIR(loc, lhs_sb, rhs_sb, flags);1344 else1345 copyVarFIR(loc, sym, lhs_sb, rhs_sb);1346 }1347 1348 void copyVarHLFIR(mlir::Location loc, Fortran::lower::SymbolBox dst,1349 Fortran::lower::SymbolBox src,1350 Fortran::semantics::Symbol::Flags flags) {1351 assert(lowerToHighLevelFIR());1352 1353 bool isBoxAllocatable = dst.match(1354 [](const fir::MutableBoxValue &box) { return box.isAllocatable(); },1355 [](const fir::FortranVariableOpInterface &box) {1356 return fir::FortranVariableOpInterface(box).isAllocatable();1357 },1358 [](const auto &box) { return false; });1359 1360 bool isBoxPointer = dst.match(1361 [](const fir::MutableBoxValue &box) { return box.isPointer(); },1362 [](const fir::FortranVariableOpInterface &box) {1363 return fir::FortranVariableOpInterface(box).isPointer();1364 },1365 [](const fir::AbstractBox &box) {1366 return fir::isBoxProcAddressType(box.getAddr().getType());1367 },1368 [](const auto &box) { return false; });1369 1370 copyVarHLFIR(loc, dst, src, isBoxAllocatable, isBoxPointer, flags);1371 }1372 1373 void copyVarHLFIR(mlir::Location loc, Fortran::lower::SymbolBox dst,1374 Fortran::lower::SymbolBox src, bool isAllocatable,1375 bool isPointer, Fortran::semantics::Symbol::Flags flags) {1376 assert(lowerToHighLevelFIR());1377 hlfir::Entity lhs{dst.getAddr()};1378 hlfir::Entity rhs{src.getAddr()};1379 1380 auto copyData = [&](hlfir::Entity l, hlfir::Entity r) {1381 // Dereference RHS and load it if trivial scalar.1382 r = hlfir::loadTrivialScalar(loc, *builder, r);1383 hlfir::AssignOp::create(*builder, loc, r, l, isAllocatable);1384 };1385 1386 if (isPointer) {1387 // Set LHS target to the target of RHS (do not copy the RHS1388 // target data into the LHS target storage).1389 auto loadVal = fir::LoadOp::create(*builder, loc, rhs);1390 fir::StoreOp::create(*builder, loc, loadVal, lhs);1391 } else if (isAllocatable &&1392 flags.test(Fortran::semantics::Symbol::Flag::OmpCopyIn)) {1393 // For copyin allocatable variables, RHS must be copied to lhs1394 // only when rhs is allocated.1395 hlfir::Entity temp =1396 hlfir::derefPointersAndAllocatables(loc, *builder, rhs);1397 mlir::Value addr = hlfir::genVariableRawAddress(loc, *builder, temp);1398 mlir::Value isAllocated = builder->genIsNotNullAddr(loc, addr);1399 builder->genIfThenElse(loc, isAllocated)1400 .genThen([&]() { copyData(lhs, rhs); })1401 .genElse([&]() {1402 fir::ExtendedValue hexv = symBoxToExtendedValue(dst);1403 hexv.match(1404 [&](const fir::MutableBoxValue &new_box) -> void {1405 // if the allocation status of original list item is1406 // unallocated, unallocate the copy if it is allocated, else1407 // do nothing.1408 Fortran::lower::genDeallocateIfAllocated(*this, new_box, loc);1409 },1410 [&](const auto &) -> void {});1411 })1412 .end();1413 } else if (isAllocatable &&1414 flags.test(Fortran::semantics::Symbol::Flag::OmpFirstPrivate)) {1415 // For firstprivate allocatable variables, RHS must be copied1416 // only when LHS is allocated.1417 hlfir::Entity temp =1418 hlfir::derefPointersAndAllocatables(loc, *builder, lhs);1419 mlir::Value addr = hlfir::genVariableRawAddress(loc, *builder, temp);1420 mlir::Value isAllocated = builder->genIsNotNullAddr(loc, addr);1421 builder->genIfThen(loc, isAllocated)1422 .genThen([&]() { copyData(lhs, rhs); })1423 .end();1424 } else {1425 copyData(lhs, rhs);1426 }1427 }1428 1429 void copyVarFIR(mlir::Location loc, const Fortran::semantics::Symbol &sym,1430 const Fortran::lower::SymbolBox &lhs_sb,1431 const Fortran::lower::SymbolBox &rhs_sb) {1432 assert(!lowerToHighLevelFIR());1433 fir::ExtendedValue lhs = symBoxToExtendedValue(lhs_sb);1434 fir::ExtendedValue rhs = symBoxToExtendedValue(rhs_sb);1435 mlir::Type symType = genType(sym);1436 if (auto seqTy = mlir::dyn_cast<fir::SequenceType>(symType)) {1437 Fortran::lower::StatementContext stmtCtx;1438 Fortran::lower::createSomeArrayAssignment(*this, lhs, rhs, localSymbols,1439 stmtCtx);1440 stmtCtx.finalizeAndReset();1441 } else if (lhs.getBoxOf<fir::CharBoxValue>()) {1442 fir::factory::CharacterExprHelper{*builder, loc}.createAssign(lhs, rhs);1443 } else {1444 auto loadVal = fir::LoadOp::create(*builder, loc, fir::getBase(rhs));1445 fir::StoreOp::create(*builder, loc, loadVal, fir::getBase(lhs));1446 }1447 }1448 1449 /// Map a block argument to a result or dummy symbol. This is not the1450 /// definitive mapping. The specification expression have not been lowered1451 /// yet. The final mapping will be done using this pre-mapping in1452 /// Fortran::lower::mapSymbolAttributes.1453 /// \param argNo The 1-based source position of this argument (0 if1454 /// unknown/result)1455 bool mapBlockArgToDummyOrResult(const Fortran::semantics::SymbolRef sym,1456 mlir::Value val, bool isResult,1457 unsigned argNo = 0) {1458 localSymbols.addSymbol(sym, val);1459 if (!isResult)1460 registerDummySymbol(sym, argNo);1461 1462 return true;1463 }1464 1465 /// Generate the address of loop variable \p sym.1466 /// If \p sym is not mapped yet, allocate local storage for it.1467 mlir::Value genLoopVariableAddress(mlir::Location loc,1468 const Fortran::semantics::Symbol &sym,1469 bool isUnordered) {1470 if (!shallowLookupSymbol(sym) &&1471 (isUnordered ||1472 GetSymbolDSA(sym).test(Fortran::semantics::Symbol::Flag::OmpPrivate) ||1473 GetSymbolDSA(sym).test(1474 Fortran::semantics::Symbol::Flag::OmpFirstPrivate) ||1475 GetSymbolDSA(sym).test(1476 Fortran::semantics::Symbol::Flag::OmpLastPrivate) ||1477 GetSymbolDSA(sym).test(Fortran::semantics::Symbol::Flag::OmpLinear))) {1478 // Do concurrent loop variables are not mapped yet since they are1479 // local to the Do concurrent scope (same for OpenMP loops).1480 mlir::OpBuilder::InsertPoint insPt = builder->saveInsertionPoint();1481 builder->setInsertionPointToStart(builder->getAllocaBlock());1482 mlir::Type tempTy = genType(sym);1483 mlir::Value temp =1484 builder->createTemporaryAlloc(loc, tempTy, toStringRef(sym.name()));1485 bindIfNewSymbol(sym, temp);1486 builder->restoreInsertionPoint(insPt);1487 }1488 auto entry = lookupSymbol(sym);1489 (void)entry;1490 assert(entry && "loop control variable must already be in map");1491 Fortran::lower::StatementContext stmtCtx;1492 return fir::getBase(1493 genExprAddr(Fortran::evaluate::AsGenericExpr(sym).value(), stmtCtx));1494 }1495 1496 static bool isNumericScalarCategory(Fortran::common::TypeCategory cat) {1497 return cat == Fortran::common::TypeCategory::Integer ||1498 cat == Fortran::common::TypeCategory::Real ||1499 cat == Fortran::common::TypeCategory::Complex ||1500 cat == Fortran::common::TypeCategory::Logical;1501 }1502 static bool isLogicalCategory(Fortran::common::TypeCategory cat) {1503 return cat == Fortran::common::TypeCategory::Logical;1504 }1505 static bool isCharacterCategory(Fortran::common::TypeCategory cat) {1506 return cat == Fortran::common::TypeCategory::Character;1507 }1508 static bool isDerivedCategory(Fortran::common::TypeCategory cat) {1509 return cat == Fortran::common::TypeCategory::Derived;1510 }1511 1512 /// Insert a new block before \p block. Leave the insertion point unchanged.1513 mlir::Block *insertBlock(mlir::Block *block) {1514 mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint();1515 mlir::Block *newBlock = builder->createBlock(block);1516 builder->restoreInsertionPoint(insertPt);1517 return newBlock;1518 }1519 1520 Fortran::lower::pft::Evaluation &evalOfLabel(Fortran::parser::Label label) {1521 const Fortran::lower::pft::LabelEvalMap &labelEvaluationMap =1522 getEval().getOwningProcedure()->labelEvaluationMap;1523 const auto iter = labelEvaluationMap.find(label);1524 assert(iter != labelEvaluationMap.end() && "label missing from map");1525 return *iter->second;1526 }1527 1528 void genBranch(mlir::Block *targetBlock) {1529 assert(targetBlock && "missing unconditional target block");1530 mlir::cf::BranchOp::create(*builder, toLocation(), targetBlock);1531 }1532 1533 void genConditionalBranch(mlir::Value cond, mlir::Block *trueTarget,1534 mlir::Block *falseTarget) {1535 assert(trueTarget && "missing conditional branch true block");1536 assert(falseTarget && "missing conditional branch false block");1537 mlir::Location loc = toLocation();1538 mlir::Value bcc = builder->createConvert(loc, builder->getI1Type(), cond);1539 mlir::cf::CondBranchOp::create(*builder, loc, bcc, trueTarget,1540 mlir::ValueRange{}, falseTarget,1541 mlir::ValueRange{});1542 }1543 void genConditionalBranch(mlir::Value cond,1544 Fortran::lower::pft::Evaluation *trueTarget,1545 Fortran::lower::pft::Evaluation *falseTarget) {1546 genConditionalBranch(cond, trueTarget->block, falseTarget->block);1547 }1548 void genConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr,1549 mlir::Block *trueTarget, mlir::Block *falseTarget) {1550 Fortran::lower::StatementContext stmtCtx;1551 mlir::Value cond =1552 createFIRExpr(toLocation(), Fortran::semantics::GetExpr(expr), stmtCtx);1553 stmtCtx.finalizeAndReset();1554 genConditionalBranch(cond, trueTarget, falseTarget);1555 }1556 void genConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr,1557 Fortran::lower::pft::Evaluation *trueTarget,1558 Fortran::lower::pft::Evaluation *falseTarget) {1559 Fortran::lower::StatementContext stmtCtx;1560 mlir::Value cond =1561 createFIRExpr(toLocation(), Fortran::semantics::GetExpr(expr), stmtCtx);1562 stmtCtx.finalizeAndReset();1563 genConditionalBranch(cond, trueTarget->block, falseTarget->block);1564 }1565 1566 /// Return the nearest active ancestor construct of \p eval, or nullptr.1567 Fortran::lower::pft::Evaluation *1568 getActiveAncestor(const Fortran::lower::pft::Evaluation &eval) {1569 Fortran::lower::pft::Evaluation *ancestor = eval.parentConstruct;1570 for (; ancestor; ancestor = ancestor->parentConstruct)1571 if (ancestor->activeConstruct)1572 break;1573 return ancestor;1574 }1575 1576 /// Return the predicate: "a branch to \p targetEval has exit code".1577 bool hasExitCode(const Fortran::lower::pft::Evaluation &targetEval) {1578 Fortran::lower::pft::Evaluation *activeAncestor =1579 getActiveAncestor(targetEval);1580 for (auto it = activeConstructStack.rbegin(),1581 rend = activeConstructStack.rend();1582 it != rend; ++it) {1583 if (&it->eval == activeAncestor)1584 break;1585 if (it->stmtCtx.hasCode())1586 return true;1587 }1588 return false;1589 }1590 1591 /// Generate a branch to \p targetEval after generating on-exit code for1592 /// any enclosing construct scopes that are exited by taking the branch.1593 void1594 genConstructExitBranch(const Fortran::lower::pft::Evaluation &targetEval) {1595 Fortran::lower::pft::Evaluation *activeAncestor =1596 getActiveAncestor(targetEval);1597 for (auto it = activeConstructStack.rbegin(),1598 rend = activeConstructStack.rend();1599 it != rend; ++it) {1600 if (&it->eval == activeAncestor)1601 break;1602 it->stmtCtx.finalizeAndKeep();1603 }1604 genBranch(targetEval.block);1605 }1606 1607 /// A construct contains nested evaluations. Some of these evaluations1608 /// may start a new basic block, others will add code to an existing1609 /// block.1610 /// Collect the list of nested evaluations that are last in their block,1611 /// organize them into two sets:1612 /// 1. Exiting evaluations: they may need a branch exiting from their1613 /// parent construct,1614 /// 2. Fall-through evaluations: they will continue to the following1615 /// evaluation. They may still need a branch, but they do not exit1616 /// the construct. They appear in cases where the following evaluation1617 /// is a target of some branch.1618 void collectFinalEvaluations(1619 Fortran::lower::pft::Evaluation &construct,1620 llvm::SmallVector<Fortran::lower::pft::Evaluation *> &exits,1621 llvm::SmallVector<Fortran::lower::pft::Evaluation *> &fallThroughs) {1622 Fortran::lower::pft::EvaluationList &nested =1623 construct.getNestedEvaluations();1624 if (nested.empty())1625 return;1626 1627 Fortran::lower::pft::Evaluation *exit = construct.constructExit;1628 Fortran::lower::pft::Evaluation *previous = &nested.front();1629 1630 for (auto it = ++nested.begin(), end = nested.end(); it != end;1631 previous = &*it++) {1632 if (it->block == nullptr)1633 continue;1634 // "*it" starts a new block, check what to do with "previous"1635 if (it->isIntermediateConstructStmt() && previous != exit)1636 exits.push_back(previous);1637 else if (previous->lexicalSuccessor && previous->lexicalSuccessor->block)1638 fallThroughs.push_back(previous);1639 }1640 if (previous != exit)1641 exits.push_back(previous);1642 }1643 1644 /// Generate a SelectOp or branch sequence that compares \p selector against1645 /// values in \p valueList and targets corresponding labels in \p labelList.1646 /// If no value matches the selector, branch to \p defaultEval.1647 ///1648 /// Three cases require special processing.1649 ///1650 /// An empty \p valueList indicates an ArithmeticIfStmt context that requires1651 /// two comparisons against 0 or 0.0. The selector may have either INTEGER1652 /// or REAL type.1653 ///1654 /// A nonpositive \p valuelist value indicates an IO statement context1655 /// (0 for ERR, -1 for END, -2 for EOR). An ERR branch must be taken for1656 /// any positive (IOSTAT) value. A missing (zero) label requires a branch1657 /// to \p defaultEval for that value.1658 ///1659 /// A non-null \p errorBlock indicates an AssignedGotoStmt context that1660 /// must always branch to an explicit target. There is no valid defaultEval1661 /// in this case. Generate a branch to \p errorBlock for an AssignedGotoStmt1662 /// that violates this program requirement.1663 ///1664 /// If this is not an ArithmeticIfStmt and no targets have exit code,1665 /// generate a SelectOp. Otherwise, for each target, if it has exit code,1666 /// branch to a new block, insert exit code, and then branch to the target.1667 /// Otherwise, branch directly to the target.1668 void genMultiwayBranch(mlir::Value selector,1669 llvm::SmallVector<int64_t> valueList,1670 llvm::SmallVector<Fortran::parser::Label> labelList,1671 const Fortran::lower::pft::Evaluation &defaultEval,1672 mlir::Block *errorBlock = nullptr) {1673 bool inArithmeticIfContext = valueList.empty();1674 assert(((inArithmeticIfContext && labelList.size() == 2) ||1675 (valueList.size() && labelList.size() == valueList.size())) &&1676 "mismatched multiway branch targets");1677 mlir::Block *defaultBlock = errorBlock ? errorBlock : defaultEval.block;1678 bool defaultHasExitCode = !errorBlock && hasExitCode(defaultEval);1679 bool hasAnyExitCode = defaultHasExitCode;1680 if (!hasAnyExitCode)1681 for (auto label : labelList)1682 if (label && hasExitCode(evalOfLabel(label))) {1683 hasAnyExitCode = true;1684 break;1685 }1686 mlir::Location loc = toLocation();1687 size_t branchCount = labelList.size();1688 if (!inArithmeticIfContext && !hasAnyExitCode &&1689 !getEval().forceAsUnstructured()) { // from -no-structured-fir option1690 // Generate a SelectOp.1691 llvm::SmallVector<mlir::Block *> blockList;1692 for (auto label : labelList) {1693 mlir::Block *block =1694 label ? evalOfLabel(label).block : defaultEval.block;1695 assert(block && "missing multiway branch block");1696 blockList.push_back(block);1697 }1698 blockList.push_back(defaultBlock);1699 if (valueList[branchCount - 1] == 0) // Swap IO ERR and default blocks.1700 std::swap(blockList[branchCount - 1], blockList[branchCount]);1701 fir::SelectOp::create(*builder, loc, selector, valueList, blockList);1702 return;1703 }1704 mlir::Type selectorType = selector.getType();1705 bool realSelector = mlir::isa<mlir::FloatType>(selectorType);1706 assert((inArithmeticIfContext || !realSelector) && "invalid selector type");1707 mlir::Value zero;1708 if (inArithmeticIfContext)1709 zero = realSelector1710 ? mlir::arith::ConstantOp::create(1711 *builder, loc, selectorType,1712 builder->getFloatAttr(selectorType, 0.0))1713 : builder->createIntegerConstant(loc, selectorType, 0);1714 for (auto label : llvm::enumerate(labelList)) {1715 mlir::Value cond;1716 if (realSelector) // inArithmeticIfContext1717 cond = mlir::arith::CmpFOp::create(1718 *builder, loc,1719 label.index() == 0 ? mlir::arith::CmpFPredicate::OLT1720 : mlir::arith::CmpFPredicate::OGT,1721 selector, zero);1722 else if (inArithmeticIfContext) // INTEGER selector1723 cond = mlir::arith::CmpIOp::create(1724 *builder, loc,1725 label.index() == 0 ? mlir::arith::CmpIPredicate::slt1726 : mlir::arith::CmpIPredicate::sgt,1727 selector, zero);1728 else // A value of 0 is an IO ERR branch: invert comparison.1729 cond = mlir::arith::CmpIOp::create(1730 *builder, loc,1731 valueList[label.index()] == 0 ? mlir::arith::CmpIPredicate::ne1732 : mlir::arith::CmpIPredicate::eq,1733 selector,1734 builder->createIntegerConstant(loc, selectorType,1735 valueList[label.index()]));1736 // Branch to a new block with exit code and then to the target, or branch1737 // directly to the target. defaultBlock is the "else" target.1738 bool lastBranch = label.index() == branchCount - 1;1739 mlir::Block *nextBlock =1740 lastBranch && !defaultHasExitCode1741 ? defaultBlock1742 : builder->getBlock()->splitBlock(builder->getInsertionPoint());1743 const Fortran::lower::pft::Evaluation &targetEval =1744 label.value() ? evalOfLabel(label.value()) : defaultEval;1745 if (hasExitCode(targetEval)) {1746 mlir::Block *jumpBlock =1747 builder->getBlock()->splitBlock(builder->getInsertionPoint());1748 genConditionalBranch(cond, jumpBlock, nextBlock);1749 startBlock(jumpBlock);1750 genConstructExitBranch(targetEval);1751 } else {1752 genConditionalBranch(cond, targetEval.block, nextBlock);1753 }1754 if (!lastBranch) {1755 startBlock(nextBlock);1756 } else if (defaultHasExitCode) {1757 startBlock(nextBlock);1758 genConstructExitBranch(defaultEval);1759 }1760 }1761 }1762 1763 void pushActiveConstruct(Fortran::lower::pft::Evaluation &eval,1764 Fortran::lower::StatementContext &stmtCtx) {1765 activeConstructStack.push_back(ConstructContext{eval, stmtCtx});1766 eval.activeConstruct = true;1767 }1768 void popActiveConstruct() {1769 assert(!activeConstructStack.empty() && "invalid active construct stack");1770 activeConstructStack.back().eval.activeConstruct = false;1771 if (activeConstructStack.back().pushedScope)1772 localSymbols.popScope();1773 activeConstructStack.pop_back();1774 }1775 1776 //===--------------------------------------------------------------------===//1777 // Termination of symbolically referenced execution units1778 //===--------------------------------------------------------------------===//1779 1780 /// Exit of a routine1781 ///1782 /// Generate the cleanup block before the routine exits1783 void genExitRoutine(bool earlyReturn, mlir::ValueRange retval = {}) {1784 if (blockIsUnterminated()) {1785 bridge.openAccCtx().finalizeAndKeep();1786 bridge.fctCtx().finalizeAndKeep();1787 mlir::func::ReturnOp::create(*builder, toLocation(), retval);1788 }1789 if (!earlyReturn) {1790 bridge.openAccCtx().pop();1791 bridge.fctCtx().pop();1792 }1793 }1794 1795 /// END of procedure-like constructs1796 ///1797 /// Generate the cleanup block before the procedure exits1798 void genReturnSymbol(const Fortran::semantics::Symbol &functionSymbol) {1799 const Fortran::semantics::Symbol &resultSym =1800 functionSymbol.get<Fortran::semantics::SubprogramDetails>().result();1801 Fortran::lower::SymbolBox resultSymBox = lookupSymbol(resultSym);1802 mlir::Location loc = toLocation();1803 if (!resultSymBox) {1804 // Create a dummy undefined value of the expected return type.1805 // This prevents improper cleanup of StatementContext, which would lead1806 // to a crash due to a block with no terminator. See issue #126452.1807 mlir::FunctionType funcType = builder->getFunction().getFunctionType();1808 mlir::Type resultType = funcType.getResult(0);1809 mlir::Value undefResult = fir::UndefOp::create(*builder, loc, resultType);1810 genExitRoutine(false, undefResult);1811 return;1812 }1813 mlir::Value resultVal = resultSymBox.match(1814 [&](const fir::CharBoxValue &x) -> mlir::Value {1815 if (Fortran::semantics::IsBindCProcedure(functionSymbol))1816 return fir::LoadOp::create(*builder, loc, x.getBuffer());1817 return fir::factory::CharacterExprHelper{*builder, loc}1818 .createEmboxChar(x.getBuffer(), x.getLen());1819 },1820 [&](const fir::MutableBoxValue &x) -> mlir::Value {1821 mlir::Value resultRef = resultSymBox.getAddr();1822 mlir::Value load = fir::LoadOp::create(*builder, loc, resultRef);1823 unsigned rank = x.rank();1824 if (x.isAllocatable() && rank > 0) {1825 // ALLOCATABLE array result must have default lower bounds.1826 // At the call site the result box of a function reference1827 // might be considered having default lower bounds, but1828 // the runtime box should probably comply with this assumption1829 // as well. If the result box has proper lbounds in runtime,1830 // this may improve the debugging experience of Fortran apps.1831 // We may consider removing this, if the overhead of setting1832 // default lower bounds is too big.1833 mlir::Value one =1834 builder->createIntegerConstant(loc, builder->getIndexType(), 1);1835 llvm::SmallVector<mlir::Value> lbounds{rank, one};1836 auto shiftTy = fir::ShiftType::get(builder->getContext(), rank);1837 mlir::Value shiftOp =1838 fir::ShiftOp::create(*builder, loc, shiftTy, lbounds);1839 load = fir::ReboxOp::create(*builder, loc, load.getType(), load,1840 shiftOp, /*slice=*/mlir::Value{});1841 }1842 return load;1843 },1844 [&](const auto &) -> mlir::Value {1845 mlir::Value resultRef = resultSymBox.getAddr();1846 mlir::Type resultType = genType(resultSym);1847 mlir::Type resultRefType = builder->getRefType(resultType);1848 // A function with multiple entry points returning different types1849 // tags all result variables with one of the largest types to allow1850 // them to share the same storage. Convert this to the actual type.1851 if (resultRef.getType() != resultRefType)1852 resultRef = builder->createConvertWithVolatileCast(1853 loc, resultRefType, resultRef);1854 return fir::LoadOp::create(*builder, loc, resultRef);1855 });1856 genExitRoutine(false, resultVal);1857 }1858 1859 /// Get the return value of a call to \p symbol, which is a subroutine entry1860 /// point that has alternative return specifiers.1861 const mlir::Value1862 getAltReturnResult(const Fortran::semantics::Symbol &symbol) {1863 assert(Fortran::semantics::HasAlternateReturns(symbol) &&1864 "subroutine does not have alternate returns");1865 return getSymbolAddress(symbol);1866 }1867 1868 void genFIRProcedureExit(Fortran::lower::pft::FunctionLikeUnit &funit,1869 const Fortran::semantics::Symbol &symbol) {1870 if (mlir::Block *finalBlock = funit.finalBlock) {1871 // The current block must end with a terminator.1872 if (blockIsUnterminated())1873 mlir::cf::BranchOp::create(*builder, toLocation(), finalBlock);1874 // Set insertion point to final block.1875 builder->setInsertionPoint(finalBlock, finalBlock->end());1876 }1877 if (Fortran::semantics::IsFunction(symbol)) {1878 genReturnSymbol(symbol);1879 } else if (Fortran::semantics::HasAlternateReturns(symbol)) {1880 mlir::Value retval = fir::LoadOp::create(*builder, toLocation(),1881 getAltReturnResult(symbol));1882 genExitRoutine(false, retval);1883 } else {1884 genExitRoutine(false);1885 }1886 }1887 1888 //1889 // Statements that have control-flow semantics1890 //1891 1892 /// Generate an If[Then]Stmt condition or its negation.1893 template <typename A>1894 mlir::Value genIfCondition(const A *stmt, bool negate = false) {1895 mlir::Location loc = toLocation();1896 Fortran::lower::StatementContext stmtCtx;1897 mlir::Value condExpr = createFIRExpr(1898 loc,1899 Fortran::semantics::GetExpr(1900 std::get<Fortran::parser::ScalarLogicalExpr>(stmt->t)),1901 stmtCtx);1902 stmtCtx.finalizeAndReset();1903 mlir::Value cond =1904 builder->createConvert(loc, builder->getI1Type(), condExpr);1905 if (negate)1906 cond = mlir::arith::XOrIOp::create(1907 *builder, loc, cond,1908 builder->createIntegerConstant(loc, cond.getType(), 1));1909 return cond;1910 }1911 1912 mlir::func::FuncOp getFunc(llvm::StringRef name, mlir::FunctionType ty) {1913 if (mlir::func::FuncOp func = builder->getNamedFunction(name)) {1914 assert(func.getFunctionType() == ty);1915 return func;1916 }1917 return builder->createFunction(toLocation(), name, ty);1918 }1919 1920 /// Lowering of CALL statement1921 void genFIR(const Fortran::parser::CallStmt &stmt) {1922 Fortran::lower::StatementContext stmtCtx;1923 Fortran::lower::pft::Evaluation &eval = getEval();1924 setCurrentPosition(stmt.source);1925 assert(stmt.typedCall && "Call was not analyzed");1926 mlir::Value res{};1927 1928 // Set 'no_inline', 'inline_hint' or 'always_inline' to true on the1929 // ProcedureRef. The NoInline and AlwaysInline attribute will be set in1930 // genProcedureRef later.1931 for (const auto *dir : eval.dirs) {1932 Fortran::common::visit(1933 Fortran::common::visitors{1934 [&](const Fortran::parser::CompilerDirective::ForceInline &) {1935 stmt.typedCall->setAlwaysInline(true);1936 },1937 [&](const Fortran::parser::CompilerDirective::Inline &) {1938 stmt.typedCall->setInlineHint(true);1939 },1940 [&](const Fortran::parser::CompilerDirective::NoInline &) {1941 stmt.typedCall->setNoInline(true);1942 },1943 [&](const auto &) {}},1944 dir->u);1945 }1946 1947 if (lowerToHighLevelFIR()) {1948 std::optional<mlir::Type> resultType;1949 if (stmt.typedCall->hasAlternateReturns())1950 resultType = builder->getIndexType();1951 auto hlfirRes = Fortran::lower::convertCallToHLFIR(1952 toLocation(), *this, *stmt.typedCall, resultType, localSymbols,1953 stmtCtx);1954 if (hlfirRes)1955 res = *hlfirRes;1956 } else {1957 // Call statement lowering shares code with function call lowering.1958 res = Fortran::lower::createSubroutineCall(1959 *this, *stmt.typedCall, explicitIterSpace, implicitIterSpace,1960 localSymbols, stmtCtx, /*isUserDefAssignment=*/false);1961 }1962 stmtCtx.finalizeAndReset();1963 if (!res)1964 return; // "Normal" subroutine call.1965 // Call with alternate return specifiers.1966 // The call returns an index that selects an alternate return branch target.1967 llvm::SmallVector<int64_t> indexList;1968 llvm::SmallVector<Fortran::parser::Label> labelList;1969 int64_t index = 0;1970 for (const Fortran::parser::ActualArgSpec &arg :1971 std::get<std::list<Fortran::parser::ActualArgSpec>>(stmt.call.t)) {1972 const auto &actual = std::get<Fortran::parser::ActualArg>(arg.t);1973 if (const auto *altReturn =1974 std::get_if<Fortran::parser::AltReturnSpec>(&actual.u)) {1975 indexList.push_back(++index);1976 labelList.push_back(altReturn->v);1977 }1978 }1979 genMultiwayBranch(res, indexList, labelList, eval.nonNopSuccessor());1980 }1981 1982 void genFIR(const Fortran::parser::ComputedGotoStmt &stmt) {1983 Fortran::lower::StatementContext stmtCtx;1984 Fortran::lower::pft::Evaluation &eval = getEval();1985 mlir::Value selectExpr =1986 createFIRExpr(toLocation(),1987 Fortran::semantics::GetExpr(1988 std::get<Fortran::parser::ScalarIntExpr>(stmt.t)),1989 stmtCtx);1990 stmtCtx.finalizeAndReset();1991 llvm::SmallVector<int64_t> indexList;1992 llvm::SmallVector<Fortran::parser::Label> labelList;1993 int64_t index = 0;1994 for (Fortran::parser::Label label :1995 std::get<std::list<Fortran::parser::Label>>(stmt.t)) {1996 indexList.push_back(++index);1997 labelList.push_back(label);1998 }1999 genMultiwayBranch(selectExpr, indexList, labelList, eval.nonNopSuccessor());2000 }2001 2002 void genFIR(const Fortran::parser::ArithmeticIfStmt &stmt) {2003 Fortran::lower::StatementContext stmtCtx;2004 mlir::Value expr = createFIRExpr(2005 toLocation(),2006 Fortran::semantics::GetExpr(std::get<Fortran::parser::Expr>(stmt.t)),2007 stmtCtx);2008 stmtCtx.finalizeAndReset();2009 // Raise an exception if REAL expr is a NaN.2010 if (mlir::isa<mlir::FloatType>(expr.getType()))2011 expr = mlir::arith::AddFOp::create(*builder, toLocation(), expr, expr);2012 // An empty valueList indicates to genMultiwayBranch that the branch is2013 // an ArithmeticIfStmt that has two branches on value 0 or 0.0.2014 llvm::SmallVector<int64_t> valueList;2015 llvm::SmallVector<Fortran::parser::Label> labelList;2016 labelList.push_back(std::get<1>(stmt.t));2017 labelList.push_back(std::get<3>(stmt.t));2018 const Fortran::lower::pft::LabelEvalMap &labelEvaluationMap =2019 getEval().getOwningProcedure()->labelEvaluationMap;2020 const auto iter = labelEvaluationMap.find(std::get<2>(stmt.t));2021 assert(iter != labelEvaluationMap.end() && "label missing from map");2022 genMultiwayBranch(expr, valueList, labelList, *iter->second);2023 }2024 2025 void genFIR(const Fortran::parser::AssignedGotoStmt &stmt) {2026 // See Fortran 90 Clause 8.2.4.2027 // Relax the requirement that the GOTO variable must have a value in the2028 // label list when a list is present, and allow a branch to any non-format2029 // target that has an ASSIGN statement for the variable.2030 mlir::Location loc = toLocation();2031 Fortran::lower::pft::Evaluation &eval = getEval();2032 Fortran::lower::pft::FunctionLikeUnit &owningProc =2033 *eval.getOwningProcedure();2034 const Fortran::lower::pft::SymbolLabelMap &symbolLabelMap =2035 owningProc.assignSymbolLabelMap;2036 const Fortran::lower::pft::LabelEvalMap &labelEvalMap =2037 owningProc.labelEvaluationMap;2038 const Fortran::semantics::Symbol &symbol =2039 *std::get<Fortran::parser::Name>(stmt.t).symbol;2040 auto labelSetIter = symbolLabelMap.find(symbol);2041 llvm::SmallVector<int64_t> valueList;2042 llvm::SmallVector<Fortran::parser::Label> labelList;2043 if (labelSetIter != symbolLabelMap.end()) {2044 for (auto &label : labelSetIter->second) {2045 const auto evalIter = labelEvalMap.find(label);2046 assert(evalIter != labelEvalMap.end() && "assigned goto label missing");2047 if (evalIter->second->block) { // non-format statement2048 valueList.push_back(label); // label as an integer2049 labelList.push_back(label);2050 }2051 }2052 }2053 if (!labelList.empty()) {2054 auto selectExpr =2055 fir::LoadOp::create(*builder, loc, getSymbolAddress(symbol));2056 // Add a default error target in case the goto is nonconforming.2057 mlir::Block *errorBlock =2058 builder->getBlock()->splitBlock(builder->getInsertionPoint());2059 genMultiwayBranch(selectExpr, valueList, labelList,2060 eval.nonNopSuccessor(), errorBlock);2061 startBlock(errorBlock);2062 }2063 fir::runtime::genReportFatalUserError(2064 *builder, loc,2065 "Assigned GOTO variable '" + symbol.name().ToString() +2066 "' does not have a valid target label value");2067 fir::UnreachableOp::create(*builder, loc);2068 }2069 2070 fir::ReduceOperationEnum2071 getReduceOperationEnum(const Fortran::parser::ReductionOperator &rOpr) {2072 switch (rOpr.v) {2073 case Fortran::parser::ReductionOperator::Operator::Plus:2074 return fir::ReduceOperationEnum::Add;2075 case Fortran::parser::ReductionOperator::Operator::Multiply:2076 return fir::ReduceOperationEnum::Multiply;2077 case Fortran::parser::ReductionOperator::Operator::And:2078 return fir::ReduceOperationEnum::AND;2079 case Fortran::parser::ReductionOperator::Operator::Or:2080 return fir::ReduceOperationEnum::OR;2081 case Fortran::parser::ReductionOperator::Operator::Eqv:2082 return fir::ReduceOperationEnum::EQV;2083 case Fortran::parser::ReductionOperator::Operator::Neqv:2084 return fir::ReduceOperationEnum::NEQV;2085 case Fortran::parser::ReductionOperator::Operator::Max:2086 return fir::ReduceOperationEnum::MAX;2087 case Fortran::parser::ReductionOperator::Operator::Min:2088 return fir::ReduceOperationEnum::MIN;2089 case Fortran::parser::ReductionOperator::Operator::Iand:2090 return fir::ReduceOperationEnum::IAND;2091 case Fortran::parser::ReductionOperator::Operator::Ior:2092 return fir::ReduceOperationEnum::IOR;2093 case Fortran::parser::ReductionOperator::Operator::Ieor:2094 return fir::ReduceOperationEnum::IEOR;2095 }2096 llvm_unreachable("illegal reduction operator");2097 }2098 2099 /// Collect DO CONCURRENT loop control information.2100 IncrementLoopNestInfo getConcurrentControl(2101 const Fortran::parser::ConcurrentHeader &header,2102 const std::list<Fortran::parser::LocalitySpec> &localityList = {}) {2103 IncrementLoopNestInfo incrementLoopNestInfo;2104 for (const Fortran::parser::ConcurrentControl &control :2105 std::get<std::list<Fortran::parser::ConcurrentControl>>(header.t))2106 incrementLoopNestInfo.emplace_back(2107 *std::get<0>(control.t).symbol, std::get<1>(control.t),2108 std::get<2>(control.t), std::get<3>(control.t), /*isUnordered=*/true);2109 IncrementLoopInfo &info = incrementLoopNestInfo.back();2110 info.maskExpr = Fortran::semantics::GetExpr(2111 std::get<std::optional<Fortran::parser::ScalarLogicalExpr>>(header.t));2112 for (const Fortran::parser::LocalitySpec &x : localityList) {2113 if (const auto *localList =2114 std::get_if<Fortran::parser::LocalitySpec::Local>(&x.u))2115 for (const Fortran::parser::Name &x : localList->v)2116 info.localSymList.push_back(x.symbol);2117 if (const auto *localInitList =2118 std::get_if<Fortran::parser::LocalitySpec::LocalInit>(&x.u))2119 for (const Fortran::parser::Name &x : localInitList->v)2120 info.localInitSymList.push_back(x.symbol);2121 for (IncrementLoopInfo &info : incrementLoopNestInfo) {2122 if (const auto *reduceList =2123 std::get_if<Fortran::parser::LocalitySpec::Reduce>(&x.u)) {2124 fir::ReduceOperationEnum reduce_operation = getReduceOperationEnum(2125 std::get<Fortran::parser::ReductionOperator>(reduceList->t));2126 for (const Fortran::parser::Name &x :2127 std::get<std::list<Fortran::parser::Name>>(reduceList->t)) {2128 info.reduceSymList.push_back(x.symbol);2129 info.reduceOperatorList.push_back(reduce_operation);2130 }2131 }2132 }2133 if (const auto *sharedList =2134 std::get_if<Fortran::parser::LocalitySpec::Shared>(&x.u))2135 for (const Fortran::parser::Name &x : sharedList->v)2136 info.sharedSymList.push_back(x.symbol);2137 }2138 return incrementLoopNestInfo;2139 }2140 2141 /// Create DO CONCURRENT construct symbol bindings and generate LOCAL_INIT2142 /// assignments.2143 void handleLocalitySpecs(const IncrementLoopInfo &info) {2144 Fortran::semantics::SemanticsContext &semanticsContext =2145 bridge.getSemanticsContext();2146 fir::LocalitySpecifierOperands privateClauseOps;2147 auto doConcurrentLoopOp =2148 mlir::dyn_cast_if_present<fir::DoConcurrentLoopOp>(info.loopOp);2149 // TODO Promote to using `enableDelayedPrivatization` (which is enabled by2150 // default unlike the staging flag) once the implementation of this is more2151 // complete.2152 bool useDelayedPriv = enableDelayedPrivatization && doConcurrentLoopOp;2153 llvm::SetVector<const Fortran::semantics::Symbol *> allPrivatizedSymbols;2154 llvm::SmallPtrSet<const Fortran::semantics::Symbol *, 16>2155 mightHaveReadHostSym;2156 2157 for (const Fortran::semantics::Symbol *symToPrivatize : info.localSymList) {2158 if (useDelayedPriv) {2159 Fortran::lower::privatizeSymbol<fir::LocalitySpecifierOp>(2160 *this, this->getFirOpBuilder(), localSymbols, allPrivatizedSymbols,2161 mightHaveReadHostSym, symToPrivatize, &privateClauseOps);2162 continue;2163 }2164 2165 createHostAssociateVarClone(*symToPrivatize, /*skipDefaultInit=*/false);2166 }2167 2168 for (const Fortran::semantics::Symbol *symToPrivatize :2169 info.localInitSymList) {2170 if (useDelayedPriv) {2171 Fortran::lower::privatizeSymbol<fir::LocalitySpecifierOp>(2172 *this, this->getFirOpBuilder(), localSymbols, allPrivatizedSymbols,2173 mightHaveReadHostSym, symToPrivatize, &privateClauseOps);2174 continue;2175 }2176 2177 createHostAssociateVarClone(*symToPrivatize, /*skipDefaultInit=*/true);2178 const auto *hostDetails =2179 symToPrivatize->detailsIf<Fortran::semantics::HostAssocDetails>();2180 assert(hostDetails && "missing locality spec host symbol");2181 const Fortran::semantics::Symbol *hostSym = &hostDetails->symbol();2182 Fortran::evaluate::ExpressionAnalyzer ea{semanticsContext};2183 Fortran::evaluate::Assignment assign{2184 ea.Designate(Fortran::evaluate::DataRef{*symToPrivatize}).value(),2185 ea.Designate(Fortran::evaluate::DataRef{*hostSym}).value()};2186 if (Fortran::semantics::IsPointer(*symToPrivatize))2187 assign.u = Fortran::evaluate::Assignment::BoundsSpec{};2188 genAssignment(assign);2189 }2190 2191 for (const Fortran::semantics::Symbol *sym : info.sharedSymList) {2192 const auto *hostDetails =2193 sym->detailsIf<Fortran::semantics::HostAssocDetails>();2194 copySymbolBinding(hostDetails->symbol(), *sym);2195 }2196 2197 if (useDelayedPriv) {2198 doConcurrentLoopOp.getLocalVarsMutable().assign(2199 privateClauseOps.privateVars);2200 doConcurrentLoopOp.setLocalSymsAttr(2201 builder->getArrayAttr(privateClauseOps.privateSyms));2202 2203 for (auto [sym, privateVar] : llvm::zip_equal(2204 allPrivatizedSymbols, privateClauseOps.privateVars)) {2205 auto arg = doConcurrentLoopOp.getRegion().begin()->addArgument(2206 privateVar.getType(), doConcurrentLoopOp.getLoc());2207 bindSymbol(*sym, hlfir::translateToExtendedValue(2208 privateVar.getLoc(), *builder, hlfir::Entity{arg},2209 /*contiguousHint=*/true)2210 .first);2211 }2212 }2213 2214 if (!doConcurrentLoopOp)2215 return;2216 2217 llvm::SmallVector<bool> reduceVarByRef;2218 llvm::SmallVector<mlir::Attribute> reductionDeclSymbols;2219 llvm::SmallVector<mlir::Attribute> nestReduceAttrs;2220 2221 for (const auto &reduceOp : info.reduceOperatorList)2222 nestReduceAttrs.push_back(2223 fir::ReduceAttr::get(builder->getContext(), reduceOp));2224 2225 llvm::SmallVector<mlir::Value> reduceVars;2226 Fortran::lower::omp::ReductionProcessor rp;2227 bool result = rp.processReductionArguments<fir::DeclareReductionOp>(2228 toLocation(), *this, info.reduceOperatorList, reduceVars,2229 reduceVarByRef, reductionDeclSymbols, info.reduceSymList);2230 if (!result)2231 TODO(toLocation(), "Lowering unrecognised reduction type");2232 2233 doConcurrentLoopOp.getReduceVarsMutable().assign(reduceVars);2234 doConcurrentLoopOp.setReduceSymsAttr(2235 reductionDeclSymbols.empty()2236 ? nullptr2237 : mlir::ArrayAttr::get(builder->getContext(),2238 reductionDeclSymbols));2239 doConcurrentLoopOp.setReduceAttrsAttr(2240 nestReduceAttrs.empty()2241 ? nullptr2242 : mlir::ArrayAttr::get(builder->getContext(), nestReduceAttrs));2243 doConcurrentLoopOp.setReduceByrefAttr(2244 reduceVarByRef.empty() ? nullptr2245 : mlir::DenseBoolArrayAttr::get(2246 builder->getContext(), reduceVarByRef));2247 2248 for (auto [sym, reduceVar] :2249 llvm::zip_equal(info.reduceSymList, reduceVars)) {2250 auto arg = doConcurrentLoopOp.getRegion().begin()->addArgument(2251 reduceVar.getType(), doConcurrentLoopOp.getLoc());2252 bindSymbol(*sym, hlfir::translateToExtendedValue(2253 reduceVar.getLoc(), *builder, hlfir::Entity{arg},2254 /*contiguousHint=*/true)2255 .first);2256 }2257 2258 // Note that allocatable, types with ultimate components, and type2259 // requiring finalization are forbidden in LOCAL/LOCAL_INIT (F2023 C1130),2260 // so no clean-up needs to be generated for these entities.2261 }2262 2263 void attachInlineAttributes(2264 mlir::Operation &op,2265 const llvm::ArrayRef<const Fortran::parser::CompilerDirective *> &dirs) {2266 if (dirs.empty())2267 return;2268 2269 for (mlir::Value operand : op.getOperands()) {2270 if (operand.getDefiningOp())2271 attachInlineAttributes(*operand.getDefiningOp(), dirs);2272 }2273 2274 if (fir::CallOp callOp = mlir::dyn_cast<fir::CallOp>(op)) {2275 for (const auto *dir : dirs) {2276 Fortran::common::visit(2277 Fortran::common::visitors{2278 [&](const Fortran::parser::CompilerDirective::NoInline &) {2279 callOp.setInlineAttr(fir::FortranInlineEnum::no_inline);2280 },2281 [&](const Fortran::parser::CompilerDirective::Inline &) {2282 callOp.setInlineAttr(fir::FortranInlineEnum::inline_hint);2283 },2284 [&](const Fortran::parser::CompilerDirective::ForceInline &) {2285 callOp.setInlineAttr(fir::FortranInlineEnum::always_inline);2286 },2287 [&](const auto &) {}},2288 dir->u);2289 }2290 }2291 }2292 2293 void attachAttributesToDoLoopOperations(2294 fir::DoLoopOp &doLoop,2295 llvm::SmallVectorImpl<const Fortran::parser::CompilerDirective *> &dirs) {2296 if (!doLoop.getOperation() || dirs.empty())2297 return;2298 2299 for (mlir::Block &block : doLoop.getRegion()) {2300 for (mlir::Operation &op : block.getOperations()) {2301 if (!dirs.empty())2302 attachInlineAttributes(op, dirs);2303 }2304 }2305 }2306 2307 // Add AccessGroups attribute on operations in fir::DoLoopOp if this2308 // operation has the parallelAccesses attribute.2309 void attachAccessGroupAttrToDoLoopOperations(fir::DoLoopOp &doLoop) {2310 if (auto loopAnnotAttr = doLoop.getLoopAnnotationAttr()) {2311 if (loopAnnotAttr.getParallelAccesses().size()) {2312 llvm::SmallVector<mlir::Attribute> accessGroupAttrs(2313 loopAnnotAttr.getParallelAccesses().begin(),2314 loopAnnotAttr.getParallelAccesses().end());2315 mlir::ArrayAttr attrs =2316 mlir::ArrayAttr::get(builder->getContext(), accessGroupAttrs);2317 doLoop.walk([&](mlir::Operation *op) {2318 if (fir::StoreOp storeOp = mlir::dyn_cast<fir::StoreOp>(op)) {2319 storeOp.setAccessGroupsAttr(attrs);2320 } else if (fir::LoadOp loadOp = mlir::dyn_cast<fir::LoadOp>(op)) {2321 loadOp.setAccessGroupsAttr(attrs);2322 } else if (hlfir::AssignOp assignOp =2323 mlir::dyn_cast<hlfir::AssignOp>(op)) {2324 // In some loops, the HLFIR AssignOp operation can be translated2325 // into FIR operation(s) containing StoreOp. It is therefore2326 // necessary to forward the AccessGroups attribute.2327 assignOp.getOperation()->setAttr("access_groups", attrs);2328 } else if (fir::CallOp callOp = mlir::dyn_cast<fir::CallOp>(op)) {2329 callOp.setAccessGroupsAttr(attrs);2330 }2331 });2332 }2333 }2334 }2335 2336 /// Generate FIR for a DO construct. There are six variants:2337 /// - unstructured infinite and while loops2338 /// - structured and unstructured increment loops2339 /// - structured and unstructured concurrent loops2340 void genFIR(const Fortran::parser::DoConstruct &doConstruct) {2341 setCurrentPositionAt(doConstruct);2342 Fortran::lower::pft::Evaluation &eval = getEval();2343 bool unstructuredContext = eval.lowerAsUnstructured();2344 2345 // Loops with induction variables inside OpenACC compute constructs2346 // need special handling to ensure that the IVs are privatized.2347 if (Fortran::lower::isInsideOpenACCComputeConstruct(*builder)) {2348 // Open up a new scope for the loop variables.2349 localSymbols.pushScope();2350 auto scopeGuard =2351 llvm::make_scope_exit([&]() { localSymbols.popScope(); });2352 2353 mlir::Operation *loopOp = Fortran::lower::genOpenACCLoopFromDoConstruct(2354 *this, bridge.getSemanticsContext(), localSymbols, doConstruct, eval);2355 bool success = loopOp != nullptr;2356 if (success) {2357 // Sanity check that the builder insertion point is inside the newly2358 // generated loop.2359 assert(2360 loopOp->getRegion(0).isAncestor(2361 builder->getInsertionPoint()->getBlock()->getParent()) &&2362 "builder insertion point is not inside the newly generated loop");2363 2364 // Loop body code.2365 auto iter = eval.getNestedEvaluations().begin();2366 for (auto end = --eval.getNestedEvaluations().end(); iter != end;2367 ++iter)2368 genFIR(*iter, unstructuredContext);2369 2370 builder->setInsertionPointAfter(loopOp);2371 return;2372 }2373 // Fall back to normal loop handling.2374 }2375 2376 // Collect loop nest information.2377 // Generate begin loop code directly for infinite and while loops.2378 Fortran::lower::pft::Evaluation &doStmtEval =2379 eval.getFirstNestedEvaluation();2380 auto *doStmt = doStmtEval.getIf<Fortran::parser::NonLabelDoStmt>();2381 const auto &loopControl =2382 std::get<std::optional<Fortran::parser::LoopControl>>(doStmt->t);2383 mlir::Block *preheaderBlock = doStmtEval.block;2384 mlir::Block *beginBlock =2385 preheaderBlock ? preheaderBlock : builder->getBlock();2386 auto createNextBeginBlock = [&]() {2387 // Step beginBlock through unstructured preheader, header, and mask2388 // blocks, created in outermost to innermost order.2389 return beginBlock = beginBlock->splitBlock(beginBlock->end());2390 };2391 mlir::Block *headerBlock =2392 unstructuredContext ? createNextBeginBlock() : nullptr;2393 mlir::Block *bodyBlock = doStmtEval.lexicalSuccessor->block;2394 mlir::Block *exitBlock = doStmtEval.parentConstruct->constructExit->block;2395 IncrementLoopNestInfo incrementLoopNestInfo;2396 const Fortran::parser::ScalarLogicalExpr *whileCondition = nullptr;2397 bool infiniteLoop = !loopControl.has_value();2398 if (infiniteLoop) {2399 assert(unstructuredContext && "infinite loop must be unstructured");2400 startBlock(headerBlock);2401 } else if ((whileCondition =2402 std::get_if<Fortran::parser::ScalarLogicalExpr>(2403 &loopControl->u))) {2404 assert(unstructuredContext && "while loop must be unstructured");2405 maybeStartBlock(preheaderBlock); // no block or empty block2406 startBlock(headerBlock);2407 genConditionalBranch(*whileCondition, bodyBlock, exitBlock);2408 } else if (const auto *bounds =2409 std::get_if<Fortran::parser::LoopControl::Bounds>(2410 &loopControl->u)) {2411 // Non-concurrent increment loop.2412 IncrementLoopInfo &info = incrementLoopNestInfo.emplace_back(2413 *bounds->name.thing.symbol, bounds->lower, bounds->upper,2414 bounds->step);2415 if (unstructuredContext) {2416 maybeStartBlock(preheaderBlock);2417 info.hasRealControl = info.loopVariableSym->GetType()->IsNumeric(2418 Fortran::common::TypeCategory::Real);2419 info.headerBlock = headerBlock;2420 info.bodyBlock = bodyBlock;2421 info.exitBlock = exitBlock;2422 }2423 } else {2424 const auto *concurrent =2425 std::get_if<Fortran::parser::LoopControl::Concurrent>(2426 &loopControl->u);2427 assert(concurrent && "invalid DO loop variant");2428 incrementLoopNestInfo = getConcurrentControl(2429 std::get<Fortran::parser::ConcurrentHeader>(concurrent->t),2430 std::get<std::list<Fortran::parser::LocalitySpec>>(concurrent->t));2431 if (unstructuredContext) {2432 maybeStartBlock(preheaderBlock);2433 for (IncrementLoopInfo &info : incrementLoopNestInfo) {2434 // The original loop body provides the body and latch blocks of the2435 // innermost dimension. The (first) body block of a non-innermost2436 // dimension is the preheader block of the immediately enclosed2437 // dimension. The latch block of a non-innermost dimension is the2438 // exit block of the immediately enclosed dimension.2439 auto createNextExitBlock = [&]() {2440 // Create unstructured loop exit blocks, outermost to innermost.2441 return exitBlock = insertBlock(exitBlock);2442 };2443 bool isInnermost = &info == &incrementLoopNestInfo.back();2444 bool isOutermost = &info == &incrementLoopNestInfo.front();2445 info.headerBlock = isOutermost ? headerBlock : createNextBeginBlock();2446 info.bodyBlock = isInnermost ? bodyBlock : createNextBeginBlock();2447 info.exitBlock = isOutermost ? exitBlock : createNextExitBlock();2448 if (info.maskExpr)2449 info.maskBlock = createNextBeginBlock();2450 }2451 }2452 }2453 2454 // Introduce a `do concurrent` scope to bind symbols corresponding to local,2455 // local_init, and reduce region arguments.2456 if (!incrementLoopNestInfo.empty() &&2457 incrementLoopNestInfo.back().isConcurrent)2458 localSymbols.pushScope();2459 2460 // Increment loop begin code. (Infinite/while code was already generated.)2461 if (!infiniteLoop && !whileCondition)2462 genFIRIncrementLoopBegin(incrementLoopNestInfo, doStmtEval.dirs);2463 2464 // Loop body code.2465 auto iter = eval.getNestedEvaluations().begin();2466 for (auto end = --eval.getNestedEvaluations().end(); iter != end; ++iter)2467 genFIR(*iter, unstructuredContext);2468 2469 // An EndDoStmt in unstructured code may start a new block.2470 Fortran::lower::pft::Evaluation &endDoEval = *iter;2471 assert(endDoEval.getIf<Fortran::parser::EndDoStmt>() && "no enddo stmt");2472 if (unstructuredContext)2473 maybeStartBlock(endDoEval.block);2474 2475 // Loop end code.2476 if (infiniteLoop || whileCondition)2477 genBranch(headerBlock);2478 else2479 genFIRIncrementLoopEnd(incrementLoopNestInfo);2480 2481 // This call may generate a branch in some contexts.2482 genFIR(endDoEval, unstructuredContext);2483 2484 // Add AccessGroups attribute on operations in fir::DoLoopOp if necessary2485 for (IncrementLoopInfo &info : incrementLoopNestInfo)2486 if (auto loopOp = mlir::dyn_cast_if_present<fir::DoLoopOp>(info.loopOp))2487 attachAccessGroupAttrToDoLoopOperations(loopOp);2488 2489 if (!incrementLoopNestInfo.empty() &&2490 incrementLoopNestInfo.back().isConcurrent)2491 localSymbols.popScope();2492 2493 // Add attribute(s) on operations in fir::DoLoopOp if necessary2494 for (IncrementLoopInfo &info : incrementLoopNestInfo)2495 if (auto loopOp = mlir::dyn_cast_if_present<fir::DoLoopOp>(info.loopOp))2496 attachAttributesToDoLoopOperations(loopOp, doStmtEval.dirs);2497 }2498 2499 /// Generate FIR to evaluate loop control values (lower, upper and step).2500 mlir::Value genControlValue(const Fortran::lower::SomeExpr *expr,2501 const IncrementLoopInfo &info,2502 bool *isConst = nullptr) {2503 mlir::Location loc = toLocation();2504 mlir::Type controlType = info.isStructured() ? builder->getIndexType()2505 : info.getLoopVariableType();2506 Fortran::lower::StatementContext stmtCtx;2507 if (expr) {2508 if (isConst)2509 *isConst = Fortran::evaluate::IsConstantExpr(*expr);2510 return builder->createConvert(loc, controlType,2511 createFIRExpr(loc, expr, stmtCtx));2512 }2513 2514 if (isConst)2515 *isConst = true;2516 if (info.hasRealControl)2517 return builder->createRealConstant(loc, controlType, 1u);2518 return builder->createIntegerConstant(loc, controlType, 1); // step2519 }2520 2521 // For unroll directives without a value, force full unrolling.2522 // For unroll directives with a value, if the value is greater than 1,2523 // force unrolling with the given factor. Otherwise, disable unrolling.2524 mlir::LLVM::LoopUnrollAttr2525 genLoopUnrollAttr(std::optional<std::uint64_t> directiveArg) {2526 mlir::BoolAttr falseAttr =2527 mlir::BoolAttr::get(builder->getContext(), false);2528 mlir::BoolAttr trueAttr = mlir::BoolAttr::get(builder->getContext(), true);2529 mlir::IntegerAttr countAttr;2530 mlir::BoolAttr fullUnrollAttr;2531 bool shouldUnroll = true;2532 if (directiveArg.has_value()) {2533 auto unrollingFactor = directiveArg.value();2534 if (unrollingFactor == 0 || unrollingFactor == 1) {2535 shouldUnroll = false;2536 } else {2537 countAttr =2538 builder->getIntegerAttr(builder->getI64Type(), unrollingFactor);2539 }2540 } else {2541 fullUnrollAttr = trueAttr;2542 }2543 2544 mlir::BoolAttr disableAttr = shouldUnroll ? falseAttr : trueAttr;2545 return mlir::LLVM::LoopUnrollAttr::get(2546 builder->getContext(), /*disable=*/disableAttr, /*count=*/countAttr, {},2547 /*full=*/fullUnrollAttr, {}, {}, {});2548 }2549 2550 // Enabling unroll and jamming directive without a value.2551 // For directives with a value, if the value is greater than 1,2552 // force unrolling with the given factor. Otherwise, disable unrolling and2553 // jamming.2554 mlir::LLVM::LoopUnrollAndJamAttr2555 genLoopUnrollAndJamAttr(std::optional<std::uint64_t> count) {2556 mlir::BoolAttr falseAttr =2557 mlir::BoolAttr::get(builder->getContext(), false);2558 mlir::BoolAttr trueAttr = mlir::BoolAttr::get(builder->getContext(), true);2559 mlir::IntegerAttr countAttr;2560 bool shouldUnroll = true;2561 if (count.has_value()) {2562 auto unrollingFactor = count.value();2563 if (unrollingFactor == 0 || unrollingFactor == 1) {2564 shouldUnroll = false;2565 } else {2566 countAttr =2567 builder->getIntegerAttr(builder->getI64Type(), unrollingFactor);2568 }2569 }2570 2571 mlir::BoolAttr disableAttr = shouldUnroll ? falseAttr : trueAttr;2572 return mlir::LLVM::LoopUnrollAndJamAttr::get(2573 builder->getContext(), /*disable=*/disableAttr, /*count*/ countAttr, {},2574 {}, {}, {}, {});2575 }2576 2577 // Enabling loop vectorization attribute.2578 mlir::LLVM::LoopVectorizeAttr2579 genLoopVectorizeAttr(mlir::BoolAttr disableAttr) {2580 mlir::LLVM::LoopVectorizeAttr va;2581 if (disableAttr)2582 va = mlir::LLVM::LoopVectorizeAttr::get(builder->getContext(),2583 /*disable=*/disableAttr, {}, {},2584 {}, {}, {}, {});2585 return va;2586 }2587 2588 void addLoopAnnotationAttr(2589 IncrementLoopInfo &info,2590 llvm::SmallVectorImpl<const Fortran::parser::CompilerDirective *> &dirs) {2591 mlir::BoolAttr disableVecAttr;2592 mlir::LLVM::LoopUnrollAttr ua;2593 mlir::LLVM::LoopUnrollAndJamAttr uja;2594 llvm::SmallVector<mlir::LLVM::AccessGroupAttr> aga;2595 bool has_attrs = false;2596 for (const auto *dir : dirs) {2597 Fortran::common::visit(2598 Fortran::common::visitors{2599 [&](const Fortran::parser::CompilerDirective::VectorAlways &) {2600 disableVecAttr =2601 mlir::BoolAttr::get(builder->getContext(), false);2602 has_attrs = true;2603 },2604 [&](const Fortran::parser::CompilerDirective::Unroll &u) {2605 ua = genLoopUnrollAttr(u.v);2606 has_attrs = true;2607 },2608 [&](const Fortran::parser::CompilerDirective::UnrollAndJam &u) {2609 uja = genLoopUnrollAndJamAttr(u.v);2610 has_attrs = true;2611 },2612 [&](const Fortran::parser::CompilerDirective::NoVector &u) {2613 disableVecAttr =2614 mlir::BoolAttr::get(builder->getContext(), true);2615 has_attrs = true;2616 },2617 [&](const Fortran::parser::CompilerDirective::NoUnroll &u) {2618 ua = genLoopUnrollAttr(/*unrollingFactor=*/0);2619 has_attrs = true;2620 },2621 [&](const Fortran::parser::CompilerDirective::NoUnrollAndJam &u) {2622 uja = genLoopUnrollAndJamAttr(/*unrollingFactor=*/0);2623 has_attrs = true;2624 },2625 [&](const Fortran::parser::CompilerDirective::IVDep &iv) {2626 disableVecAttr =2627 mlir::BoolAttr::get(builder->getContext(), false);2628 aga.push_back(2629 mlir::LLVM::AccessGroupAttr::get(builder->getContext()));2630 has_attrs = true;2631 },2632 [&](const auto &) {}},2633 dir->u);2634 }2635 mlir::LLVM::LoopVectorizeAttr va = genLoopVectorizeAttr(disableVecAttr);2636 mlir::LLVM::LoopAnnotationAttr la = mlir::LLVM::LoopAnnotationAttr::get(2637 builder->getContext(), {}, /*vectorize=*/va, {}, /*unroll*/ ua,2638 /*unroll_and_jam*/ uja, {}, {}, {}, {}, {}, {}, {}, {}, {},2639 /*parallelAccesses*/ aga);2640 if (has_attrs) {2641 if (auto loopOp = mlir::dyn_cast<fir::DoLoopOp>(info.loopOp))2642 loopOp.setLoopAnnotationAttr(la);2643 2644 if (auto doConcurrentOp =2645 mlir::dyn_cast<fir::DoConcurrentLoopOp>(info.loopOp))2646 doConcurrentOp.setLoopAnnotationAttr(la);2647 }2648 }2649 2650 /// Generate FIR to begin a structured or unstructured increment loop nest.2651 void genFIRIncrementLoopBegin(2652 IncrementLoopNestInfo &incrementLoopNestInfo,2653 llvm::SmallVectorImpl<const Fortran::parser::CompilerDirective *> &dirs) {2654 assert(!incrementLoopNestInfo.empty() && "empty loop nest");2655 mlir::Location loc = toLocation();2656 mlir::arith::IntegerOverflowFlags iofBackup{};2657 2658 llvm::SmallVector<mlir::Value> nestLBs;2659 llvm::SmallVector<mlir::Value> nestUBs;2660 llvm::SmallVector<mlir::Value> nestSts;2661 llvm::SmallVector<mlir::Value> nestReduceOperands;2662 llvm::SmallVector<mlir::Attribute> nestReduceAttrs;2663 bool genDoConcurrent = false;2664 2665 for (IncrementLoopInfo &info : incrementLoopNestInfo) {2666 genDoConcurrent = info.isStructured() && info.isConcurrent;2667 2668 if (!genDoConcurrent)2669 info.loopVariable = genLoopVariableAddress(loc, *info.loopVariableSym,2670 info.isConcurrent);2671 2672 if (!getLoweringOptions().getIntegerWrapAround()) {2673 iofBackup = builder->getIntegerOverflowFlags();2674 builder->setIntegerOverflowFlags(2675 mlir::arith::IntegerOverflowFlags::nsw);2676 }2677 2678 nestLBs.push_back(genControlValue(info.lowerExpr, info));2679 nestUBs.push_back(genControlValue(info.upperExpr, info));2680 bool isConst = true;2681 nestSts.push_back(genControlValue(2682 info.stepExpr, info, info.isStructured() ? nullptr : &isConst));2683 2684 if (!getLoweringOptions().getIntegerWrapAround())2685 builder->setIntegerOverflowFlags(iofBackup);2686 2687 // Use a temp variable for unstructured loops with non-const step.2688 if (!isConst) {2689 mlir::Value stepValue = nestSts.back();2690 info.stepVariable = builder->createTemporary(loc, stepValue.getType());2691 fir::StoreOp::create(*builder, loc, stepValue, info.stepVariable);2692 }2693 }2694 2695 for (auto [info, lowerValue, upperValue, stepValue] :2696 llvm::zip_equal(incrementLoopNestInfo, nestLBs, nestUBs, nestSts)) {2697 // Structured loop - generate fir.do_loop.2698 if (info.isStructured()) {2699 if (genDoConcurrent)2700 continue;2701 2702 // The loop variable is a doLoop op argument.2703 mlir::Type loopVarType = info.getLoopVariableType();2704 auto loopOp = fir::DoLoopOp::create(2705 *builder, loc, lowerValue, upperValue, stepValue,2706 /*unordered=*/false,2707 /*finalCountValue=*/false,2708 builder->createConvert(loc, loopVarType, lowerValue));2709 info.loopOp = loopOp;2710 builder->setInsertionPointToStart(loopOp.getBody());2711 mlir::Value loopValue = loopOp.getRegionIterArgs()[0];2712 2713 // Update the loop variable value in case it has non-index references.2714 fir::StoreOp::create(*builder, loc, loopValue, info.loopVariable);2715 addLoopAnnotationAttr(info, dirs);2716 continue;2717 }2718 2719 // Unstructured loop preheader - initialize tripVariable and loopVariable.2720 mlir::Value tripCount;2721 if (info.hasRealControl) {2722 auto diff1 =2723 mlir::arith::SubFOp::create(*builder, loc, upperValue, lowerValue);2724 auto diff2 =2725 mlir::arith::AddFOp::create(*builder, loc, diff1, stepValue);2726 tripCount =2727 mlir::arith::DivFOp::create(*builder, loc, diff2, stepValue);2728 tripCount =2729 builder->createConvert(loc, builder->getIndexType(), tripCount);2730 } else {2731 auto diff1 =2732 mlir::arith::SubIOp::create(*builder, loc, upperValue, lowerValue);2733 auto diff2 =2734 mlir::arith::AddIOp::create(*builder, loc, diff1, stepValue);2735 tripCount =2736 mlir::arith::DivSIOp::create(*builder, loc, diff2, stepValue);2737 }2738 if (forceLoopToExecuteOnce) { // minimum tripCount is 12739 mlir::Value one =2740 builder->createIntegerConstant(loc, tripCount.getType(), 1);2741 auto cond = mlir::arith::CmpIOp::create(2742 *builder, loc, mlir::arith::CmpIPredicate::slt, tripCount, one);2743 tripCount =2744 mlir::arith::SelectOp::create(*builder, loc, cond, one, tripCount);2745 }2746 info.tripVariable = builder->createTemporary(loc, tripCount.getType());2747 fir::StoreOp::create(*builder, loc, tripCount, info.tripVariable);2748 fir::StoreOp::create(*builder, loc, lowerValue, info.loopVariable);2749 2750 // Unstructured loop header - generate loop condition and mask.2751 // Note - Currently there is no way to tag a loop as a concurrent loop.2752 startBlock(info.headerBlock);2753 tripCount = fir::LoadOp::create(*builder, loc, info.tripVariable);2754 mlir::Value zero =2755 builder->createIntegerConstant(loc, tripCount.getType(), 0);2756 auto cond = mlir::arith::CmpIOp::create(2757 *builder, loc, mlir::arith::CmpIPredicate::sgt, tripCount, zero);2758 if (info.maskExpr) {2759 genConditionalBranch(cond, info.maskBlock, info.exitBlock);2760 startBlock(info.maskBlock);2761 mlir::Block *latchBlock = getEval().getLastNestedEvaluation().block;2762 assert(latchBlock && "missing masked concurrent loop latch block");2763 Fortran::lower::StatementContext stmtCtx;2764 mlir::Value maskCond = createFIRExpr(loc, info.maskExpr, stmtCtx);2765 stmtCtx.finalizeAndReset();2766 genConditionalBranch(maskCond, info.bodyBlock, latchBlock);2767 } else {2768 genConditionalBranch(cond, info.bodyBlock, info.exitBlock);2769 if (&info != &incrementLoopNestInfo.back()) // not innermost2770 startBlock(info.bodyBlock); // preheader block of enclosed dimension2771 }2772 if (info.hasLocalitySpecs()) {2773 mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint();2774 builder->setInsertionPointToStart(info.bodyBlock);2775 handleLocalitySpecs(info);2776 builder->restoreInsertionPoint(insertPt);2777 }2778 }2779 2780 if (genDoConcurrent) {2781 auto loopWrapperOp = fir::DoConcurrentOp::create(*builder, loc);2782 builder->setInsertionPointToStart(2783 builder->createBlock(&loopWrapperOp.getRegion()));2784 2785 for (IncrementLoopInfo &info : llvm::reverse(incrementLoopNestInfo)) {2786 info.loopVariable = genLoopVariableAddress(loc, *info.loopVariableSym,2787 info.isConcurrent);2788 }2789 2790 builder->setInsertionPointToEnd(loopWrapperOp.getBody());2791 auto loopOp = fir::DoConcurrentLoopOp::create(2792 *builder, loc, nestLBs, nestUBs, nestSts, /*loopAnnotation=*/nullptr,2793 /*local_vars=*/mlir::ValueRange{},2794 /*local_syms=*/nullptr, /*reduce_vars=*/mlir::ValueRange{},2795 /*reduce_byref=*/nullptr, /*reduce_syms=*/nullptr,2796 /*reduce_attrs=*/nullptr);2797 2798 llvm::SmallVector<mlir::Type> loopBlockArgTypes(2799 incrementLoopNestInfo.size(), builder->getIndexType());2800 llvm::SmallVector<mlir::Location> loopBlockArgLocs(2801 incrementLoopNestInfo.size(), loc);2802 mlir::Region &loopRegion = loopOp.getRegion();2803 mlir::Block *loopBlock = builder->createBlock(2804 &loopRegion, loopRegion.begin(), loopBlockArgTypes, loopBlockArgLocs);2805 builder->setInsertionPointToStart(loopBlock);2806 2807 for (auto [info, blockArg] :2808 llvm::zip_equal(incrementLoopNestInfo, loopBlock->getArguments())) {2809 info.loopOp = loopOp;2810 mlir::Value loopValue =2811 builder->createConvert(loc, info.getLoopVariableType(), blockArg);2812 fir::StoreOp::create(*builder, loc, loopValue, info.loopVariable);2813 2814 if (info.maskExpr) {2815 Fortran::lower::StatementContext stmtCtx;2816 mlir::Value maskCond = createFIRExpr(loc, info.maskExpr, stmtCtx);2817 stmtCtx.finalizeAndReset();2818 mlir::Value maskCondCast =2819 builder->createConvert(loc, builder->getI1Type(), maskCond);2820 auto ifOp = fir::IfOp::create(*builder, loc, maskCondCast,2821 /*withElseRegion=*/false);2822 builder->setInsertionPointToStart(&ifOp.getThenRegion().front());2823 }2824 }2825 2826 IncrementLoopInfo &innermostInfo = incrementLoopNestInfo.back();2827 2828 if (innermostInfo.hasLocalitySpecs())2829 handleLocalitySpecs(innermostInfo);2830 2831 addLoopAnnotationAttr(innermostInfo, dirs);2832 }2833 }2834 2835 /// Generate FIR to end a structured or unstructured increment loop nest.2836 void genFIRIncrementLoopEnd(IncrementLoopNestInfo &incrementLoopNestInfo) {2837 assert(!incrementLoopNestInfo.empty() && "empty loop nest");2838 mlir::Location loc = toLocation();2839 mlir::arith::IntegerOverflowFlags flags{};2840 if (!getLoweringOptions().getIntegerWrapAround())2841 flags = bitEnumSet(flags, mlir::arith::IntegerOverflowFlags::nsw);2842 auto iofAttr = mlir::arith::IntegerOverflowFlagsAttr::get(2843 builder->getContext(), flags);2844 for (auto it = incrementLoopNestInfo.rbegin(),2845 rend = incrementLoopNestInfo.rend();2846 it != rend; ++it) {2847 IncrementLoopInfo &info = *it;2848 if (info.isStructured()) {2849 // End fir.do_concurent.loop.2850 if (info.isConcurrent) {2851 builder->setInsertionPointAfter(info.loopOp->getParentOp());2852 continue;2853 }2854 2855 // End fir.do_loop.2856 // Decrement tripVariable.2857 auto doLoopOp = mlir::cast<fir::DoLoopOp>(info.loopOp);2858 builder->setInsertionPointToEnd(doLoopOp.getBody());2859 // Step loopVariable to help optimizations such as vectorization.2860 // Induction variable elimination will clean up as necessary.2861 mlir::Value step = builder->createConvert(2862 loc, info.getLoopVariableType(), doLoopOp.getStep());2863 mlir::Value loopVar =2864 fir::LoadOp::create(*builder, loc, info.loopVariable);2865 mlir::Value loopVarInc =2866 mlir::arith::AddIOp::create(*builder, loc, loopVar, step, iofAttr);2867 fir::ResultOp::create(*builder, loc, loopVarInc);2868 builder->setInsertionPointAfter(doLoopOp);2869 // The loop control variable may be used after the loop.2870 fir::StoreOp::create(*builder, loc, doLoopOp.getResult(0),2871 info.loopVariable);2872 continue;2873 }2874 2875 // Unstructured loop - decrement tripVariable and step loopVariable.2876 mlir::Value tripCount =2877 fir::LoadOp::create(*builder, loc, info.tripVariable);2878 mlir::Value one =2879 builder->createIntegerConstant(loc, tripCount.getType(), 1);2880 tripCount = mlir::arith::SubIOp::create(*builder, loc, tripCount, one);2881 fir::StoreOp::create(*builder, loc, tripCount, info.tripVariable);2882 mlir::Value value = fir::LoadOp::create(*builder, loc, info.loopVariable);2883 mlir::Value step;2884 if (info.stepVariable)2885 step = fir::LoadOp::create(*builder, loc, info.stepVariable);2886 else2887 step = genControlValue(info.stepExpr, info);2888 if (info.hasRealControl)2889 value = mlir::arith::AddFOp::create(*builder, loc, value, step);2890 else2891 value =2892 mlir::arith::AddIOp::create(*builder, loc, value, step, iofAttr);2893 fir::StoreOp::create(*builder, loc, value, info.loopVariable);2894 2895 genBranch(info.headerBlock);2896 if (&info != &incrementLoopNestInfo.front()) // not outermost2897 startBlock(info.exitBlock); // latch block of enclosing dimension2898 }2899 }2900 2901 /// Generate structured or unstructured FIR for an IF construct.2902 /// The initial statement may be either an IfStmt or an IfThenStmt.2903 void genFIR(const Fortran::parser::IfConstruct &) {2904 Fortran::lower::pft::Evaluation &eval = getEval();2905 2906 // Structured fir.if nest.2907 if (eval.lowerAsStructured()) {2908 fir::IfOp topIfOp, currentIfOp;2909 for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {2910 auto genIfOp = [&](mlir::Value cond) {2911 Fortran::lower::pft::Evaluation &succ = *e.controlSuccessor;2912 bool hasElse = succ.isA<Fortran::parser::ElseIfStmt>() ||2913 succ.isA<Fortran::parser::ElseStmt>();2914 auto ifOp = fir::IfOp::create(*builder, toLocation(), cond,2915 /*withElseRegion=*/hasElse);2916 builder->setInsertionPointToStart(&ifOp.getThenRegion().front());2917 return ifOp;2918 };2919 setCurrentPosition(e.position);2920 if (auto *s = e.getIf<Fortran::parser::IfThenStmt>()) {2921 topIfOp = currentIfOp = genIfOp(genIfCondition(s, e.negateCondition));2922 } else if (auto *s = e.getIf<Fortran::parser::IfStmt>()) {2923 topIfOp = currentIfOp = genIfOp(genIfCondition(s, e.negateCondition));2924 } else if (auto *s = e.getIf<Fortran::parser::ElseIfStmt>()) {2925 builder->setInsertionPointToStart(2926 ¤tIfOp.getElseRegion().front());2927 currentIfOp = genIfOp(genIfCondition(s));2928 } else if (e.isA<Fortran::parser::ElseStmt>()) {2929 builder->setInsertionPointToStart(2930 ¤tIfOp.getElseRegion().front());2931 } else if (e.isA<Fortran::parser::EndIfStmt>()) {2932 builder->setInsertionPointAfter(topIfOp);2933 genFIR(e, /*unstructuredContext=*/false); // may generate branch2934 } else {2935 genFIR(e, /*unstructuredContext=*/false);2936 }2937 }2938 return;2939 }2940 2941 // Unstructured branch sequence.2942 llvm::SmallVector<Fortran::lower::pft::Evaluation *> exits, fallThroughs;2943 collectFinalEvaluations(eval, exits, fallThroughs);2944 2945 for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {2946 auto genIfBranch = [&](mlir::Value cond) {2947 if (e.lexicalSuccessor == e.controlSuccessor) // empty block -> exit2948 genConditionalBranch(cond, e.parentConstruct->constructExit,2949 e.controlSuccessor);2950 else // non-empty block2951 genConditionalBranch(cond, e.lexicalSuccessor, e.controlSuccessor);2952 };2953 setCurrentPosition(e.position);2954 if (auto *s = e.getIf<Fortran::parser::IfThenStmt>()) {2955 maybeStartBlock(e.block);2956 genIfBranch(genIfCondition(s, e.negateCondition));2957 } else if (auto *s = e.getIf<Fortran::parser::IfStmt>()) {2958 maybeStartBlock(e.block);2959 genIfBranch(genIfCondition(s, e.negateCondition));2960 } else if (auto *s = e.getIf<Fortran::parser::ElseIfStmt>()) {2961 startBlock(e.block);2962 genIfBranch(genIfCondition(s));2963 } else {2964 genFIR(e);2965 if (blockIsUnterminated()) {2966 if (llvm::is_contained(exits, &e))2967 genConstructExitBranch(*eval.constructExit);2968 else if (llvm::is_contained(fallThroughs, &e))2969 genBranch(e.lexicalSuccessor->block);2970 }2971 }2972 }2973 }2974 2975 void genCaseOrRankConstruct() {2976 Fortran::lower::pft::Evaluation &eval = getEval();2977 Fortran::lower::StatementContext stmtCtx;2978 pushActiveConstruct(eval, stmtCtx);2979 2980 llvm::SmallVector<Fortran::lower::pft::Evaluation *> exits, fallThroughs;2981 collectFinalEvaluations(eval, exits, fallThroughs);2982 2983 for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {2984 if (e.getIf<Fortran::parser::EndSelectStmt>())2985 maybeStartBlock(e.block);2986 else2987 genFIR(e);2988 if (blockIsUnterminated()) {2989 if (llvm::is_contained(exits, &e))2990 genConstructExitBranch(*eval.constructExit);2991 else if (llvm::is_contained(fallThroughs, &e))2992 genBranch(e.lexicalSuccessor->block);2993 }2994 }2995 popActiveConstruct();2996 }2997 void genFIR(const Fortran::parser::CaseConstruct &) {2998 genCaseOrRankConstruct();2999 }3000 3001 template <typename A>3002 void genNestedStatement(const Fortran::parser::Statement<A> &stmt) {3003 setCurrentPosition(stmt.source);3004 genFIR(stmt.statement);3005 }3006 3007 /// Force the binding of an explicit symbol. This is used to bind and re-bind3008 /// a concurrent control symbol to its value.3009 void forceControlVariableBinding(const Fortran::semantics::Symbol *sym,3010 mlir::Value inducVar) {3011 mlir::Location loc = toLocation();3012 assert(sym && "There must be a symbol to bind");3013 mlir::Type toTy = genType(*sym);3014 // FIXME: this should be a "per iteration" temporary.3015 mlir::Value tmp =3016 builder->createTemporary(loc, toTy, toStringRef(sym->name()),3017 llvm::ArrayRef<mlir::NamedAttribute>{3018 fir::getAdaptToByRefAttr(*builder)});3019 mlir::Value cast = builder->createConvert(loc, toTy, inducVar);3020 fir::StoreOp::create(*builder, loc, cast, tmp);3021 addSymbol(*sym, tmp, /*force=*/true);3022 }3023 3024 /// Process a concurrent header for a FORALL. (Concurrent headers for DO3025 /// CONCURRENT loops are lowered elsewhere.)3026 void genFIR(const Fortran::parser::ConcurrentHeader &header) {3027 llvm::SmallVector<mlir::Value> lows;3028 llvm::SmallVector<mlir::Value> highs;3029 llvm::SmallVector<mlir::Value> steps;3030 if (explicitIterSpace.isOutermostForall()) {3031 // For the outermost forall, we evaluate the bounds expressions once.3032 // Contrastingly, if this forall is nested, the bounds expressions are3033 // assumed to be pure, possibly dependent on outer concurrent control3034 // variables, possibly variant with respect to arguments, and will be3035 // re-evaluated.3036 mlir::Location loc = toLocation();3037 mlir::Type idxTy = builder->getIndexType();3038 Fortran::lower::StatementContext &stmtCtx =3039 explicitIterSpace.stmtContext();3040 auto lowerExpr = [&](auto &e) {3041 return fir::getBase(genExprValue(e, stmtCtx));3042 };3043 for (const Fortran::parser::ConcurrentControl &ctrl :3044 std::get<std::list<Fortran::parser::ConcurrentControl>>(header.t)) {3045 const Fortran::lower::SomeExpr *lo =3046 Fortran::semantics::GetExpr(std::get<1>(ctrl.t));3047 const Fortran::lower::SomeExpr *hi =3048 Fortran::semantics::GetExpr(std::get<2>(ctrl.t));3049 auto &optStep =3050 std::get<std::optional<Fortran::parser::ScalarIntExpr>>(ctrl.t);3051 lows.push_back(builder->createConvert(loc, idxTy, lowerExpr(*lo)));3052 highs.push_back(builder->createConvert(loc, idxTy, lowerExpr(*hi)));3053 steps.push_back(3054 optStep.has_value()3055 ? builder->createConvert(3056 loc, idxTy,3057 lowerExpr(*Fortran::semantics::GetExpr(*optStep)))3058 : builder->createIntegerConstant(loc, idxTy, 1));3059 }3060 }3061 auto lambda = [&, lows, highs, steps]() {3062 // Create our iteration space from the header spec.3063 mlir::Location loc = toLocation();3064 mlir::Type idxTy = builder->getIndexType();3065 llvm::SmallVector<fir::DoLoopOp> loops;3066 Fortran::lower::StatementContext &stmtCtx =3067 explicitIterSpace.stmtContext();3068 auto lowerExpr = [&](auto &e) {3069 return fir::getBase(genExprValue(e, stmtCtx));3070 };3071 const bool outermost = !lows.empty();3072 std::size_t headerIndex = 0;3073 for (const Fortran::parser::ConcurrentControl &ctrl :3074 std::get<std::list<Fortran::parser::ConcurrentControl>>(header.t)) {3075 const Fortran::semantics::Symbol *ctrlVar =3076 std::get<Fortran::parser::Name>(ctrl.t).symbol;3077 mlir::Value lb;3078 mlir::Value ub;3079 mlir::Value by;3080 if (outermost) {3081 assert(headerIndex < lows.size());3082 if (headerIndex == 0)3083 explicitIterSpace.resetInnerArgs();3084 lb = lows[headerIndex];3085 ub = highs[headerIndex];3086 by = steps[headerIndex++];3087 } else {3088 const Fortran::lower::SomeExpr *lo =3089 Fortran::semantics::GetExpr(std::get<1>(ctrl.t));3090 const Fortran::lower::SomeExpr *hi =3091 Fortran::semantics::GetExpr(std::get<2>(ctrl.t));3092 auto &optStep =3093 std::get<std::optional<Fortran::parser::ScalarIntExpr>>(ctrl.t);3094 lb = builder->createConvert(loc, idxTy, lowerExpr(*lo));3095 ub = builder->createConvert(loc, idxTy, lowerExpr(*hi));3096 by = optStep.has_value()3097 ? builder->createConvert(3098 loc, idxTy,3099 lowerExpr(*Fortran::semantics::GetExpr(*optStep)))3100 : builder->createIntegerConstant(loc, idxTy, 1);3101 }3102 auto lp = fir::DoLoopOp::create(3103 *builder, loc, lb, ub, by, /*unordered=*/true,3104 /*finalCount=*/false, explicitIterSpace.getInnerArgs());3105 if ((!loops.empty() || !outermost) && !lp.getRegionIterArgs().empty())3106 fir::ResultOp::create(*builder, loc, lp.getResults());3107 explicitIterSpace.setInnerArgs(lp.getRegionIterArgs());3108 builder->setInsertionPointToStart(lp.getBody());3109 forceControlVariableBinding(ctrlVar, lp.getInductionVar());3110 loops.push_back(lp);3111 }3112 if (outermost)3113 explicitIterSpace.setOuterLoop(loops[0]);3114 explicitIterSpace.appendLoops(loops);3115 if (const auto &mask =3116 std::get<std::optional<Fortran::parser::ScalarLogicalExpr>>(3117 header.t);3118 mask.has_value()) {3119 mlir::Type i1Ty = builder->getI1Type();3120 fir::ExtendedValue maskExv =3121 genExprValue(*Fortran::semantics::GetExpr(mask.value()), stmtCtx);3122 mlir::Value cond =3123 builder->createConvert(loc, i1Ty, fir::getBase(maskExv));3124 auto ifOp = fir::IfOp::create(*builder, loc,3125 explicitIterSpace.innerArgTypes(), cond,3126 /*withElseRegion=*/true);3127 fir::ResultOp::create(*builder, loc, ifOp.getResults());3128 builder->setInsertionPointToStart(&ifOp.getElseRegion().front());3129 fir::ResultOp::create(*builder, loc, explicitIterSpace.getInnerArgs());3130 builder->setInsertionPointToStart(&ifOp.getThenRegion().front());3131 }3132 };3133 // Push the lambda to gen the loop nest context.3134 explicitIterSpace.pushLoopNest(lambda);3135 }3136 3137 void genFIR(const Fortran::parser::ForallAssignmentStmt &stmt) {3138 Fortran::common::visit([&](const auto &x) { genFIR(x); }, stmt.u);3139 }3140 3141 void genFIR(const Fortran::parser::EndForallStmt &) {3142 if (!lowerToHighLevelFIR())3143 cleanupExplicitSpace();3144 }3145 3146 template <typename A>3147 void prepareExplicitSpace(const A &forall) {3148 if (!explicitIterSpace.isActive())3149 analyzeExplicitSpace(forall);3150 localSymbols.pushScope();3151 explicitIterSpace.enter();3152 }3153 3154 /// Cleanup all the FORALL context information when we exit.3155 void cleanupExplicitSpace() {3156 explicitIterSpace.leave();3157 localSymbols.popScope();3158 }3159 3160 /// Generate FIR for a FORALL statement.3161 void genFIR(const Fortran::parser::ForallStmt &stmt) {3162 const auto &concurrentHeader =3163 std::get<3164 Fortran::common::Indirection<Fortran::parser::ConcurrentHeader>>(3165 stmt.t)3166 .value();3167 if (lowerToHighLevelFIR()) {3168 mlir::OpBuilder::InsertionGuard guard(*builder);3169 Fortran::lower::SymMapScope scope(localSymbols);3170 genForallNest(concurrentHeader);3171 genFIR(std::get<Fortran::parser::UnlabeledStatement<3172 Fortran::parser::ForallAssignmentStmt>>(stmt.t)3173 .statement);3174 return;3175 }3176 prepareExplicitSpace(stmt);3177 genFIR(concurrentHeader);3178 genFIR(std::get<Fortran::parser::UnlabeledStatement<3179 Fortran::parser::ForallAssignmentStmt>>(stmt.t)3180 .statement);3181 cleanupExplicitSpace();3182 }3183 3184 /// Generate FIR for a FORALL construct.3185 void genFIR(const Fortran::parser::ForallConstruct &forall) {3186 mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint();3187 if (lowerToHighLevelFIR())3188 localSymbols.pushScope();3189 else3190 prepareExplicitSpace(forall);3191 genNestedStatement(3192 std::get<3193 Fortran::parser::Statement<Fortran::parser::ForallConstructStmt>>(3194 forall.t));3195 for (const Fortran::parser::ForallBodyConstruct &s :3196 std::get<std::list<Fortran::parser::ForallBodyConstruct>>(forall.t)) {3197 Fortran::common::visit(3198 Fortran::common::visitors{3199 [&](const Fortran::parser::WhereConstruct &b) { genFIR(b); },3200 [&](const Fortran::common::Indirection<3201 Fortran::parser::ForallConstruct> &b) { genFIR(b.value()); },3202 [&](const auto &b) { genNestedStatement(b); }},3203 s.u);3204 }3205 genNestedStatement(3206 std::get<Fortran::parser::Statement<Fortran::parser::EndForallStmt>>(3207 forall.t));3208 if (lowerToHighLevelFIR()) {3209 localSymbols.popScope();3210 builder->restoreInsertionPoint(insertPt);3211 }3212 }3213 3214 /// Lower the concurrent header specification.3215 void genFIR(const Fortran::parser::ForallConstructStmt &stmt) {3216 const auto &concurrentHeader =3217 std::get<3218 Fortran::common::Indirection<Fortran::parser::ConcurrentHeader>>(3219 stmt.t)3220 .value();3221 if (lowerToHighLevelFIR())3222 genForallNest(concurrentHeader);3223 else3224 genFIR(concurrentHeader);3225 }3226 3227 /// Generate hlfir.forall and hlfir.forall_mask nest given a Forall3228 /// concurrent header3229 void genForallNest(const Fortran::parser::ConcurrentHeader &header) {3230 mlir::Location loc = getCurrentLocation();3231 const bool isOutterForall = !isInsideHlfirForallOrWhere();3232 hlfir::ForallOp outerForall;3233 auto evaluateControl = [&](const auto &parserExpr, mlir::Region ®ion,3234 bool isMask = false) {3235 if (region.empty())3236 builder->createBlock(®ion);3237 Fortran::lower::StatementContext localStmtCtx;3238 const Fortran::semantics::SomeExpr *anlalyzedExpr =3239 Fortran::semantics::GetExpr(parserExpr);3240 assert(anlalyzedExpr && "expression semantics failed");3241 // Generate the controls of outer forall outside of the hlfir.forall3242 // region. They do not depend on any previous forall indices (C1123) and3243 // no assignment has been made yet that could modify their value. This3244 // will simplify hlfir.forall analysis because the SSA integer value3245 // yielded will obviously not depend on any variable modified by the3246 // forall when produced outside of it.3247 // This is not done for the mask because it may (and in usual code, does)3248 // depend on the forall indices that have just been defined as3249 // hlfir.forall block arguments.3250 mlir::OpBuilder::InsertPoint innerInsertionPoint;3251 if (outerForall && !isMask) {3252 innerInsertionPoint = builder->saveInsertionPoint();3253 builder->setInsertionPoint(outerForall);3254 }3255 mlir::Value exprVal =3256 fir::getBase(genExprValue(*anlalyzedExpr, localStmtCtx, &loc));3257 localStmtCtx.finalizeAndPop();3258 if (isMask)3259 exprVal = builder->createConvert(loc, builder->getI1Type(), exprVal);3260 if (innerInsertionPoint.isSet())3261 builder->restoreInsertionPoint(innerInsertionPoint);3262 hlfir::YieldOp::create(*builder, loc, exprVal);3263 };3264 for (const Fortran::parser::ConcurrentControl &control :3265 std::get<std::list<Fortran::parser::ConcurrentControl>>(header.t)) {3266 auto forallOp = hlfir::ForallOp::create(*builder, loc);3267 if (isOutterForall && !outerForall)3268 outerForall = forallOp;3269 evaluateControl(std::get<1>(control.t), forallOp.getLbRegion());3270 evaluateControl(std::get<2>(control.t), forallOp.getUbRegion());3271 if (const auto &optionalStep =3272 std::get<std::optional<Fortran::parser::ScalarIntExpr>>(3273 control.t))3274 evaluateControl(*optionalStep, forallOp.getStepRegion());3275 // Create block argument and map it to a symbol via an hlfir.forall_index3276 // op (symbols must be mapped to in memory values).3277 const Fortran::semantics::Symbol *controlVar =3278 std::get<Fortran::parser::Name>(control.t).symbol;3279 assert(controlVar && "symbol analysis failed");3280 mlir::Type controlVarType = genType(*controlVar);3281 mlir::Block *forallBody = builder->createBlock(&forallOp.getBody(), {},3282 {controlVarType}, {loc});3283 auto forallIndex = hlfir::ForallIndexOp::create(3284 *builder, loc, fir::ReferenceType::get(controlVarType),3285 forallBody->getArguments()[0],3286 builder->getStringAttr(controlVar->name().ToString()));3287 localSymbols.addVariableDefinition(*controlVar, forallIndex,3288 /*force=*/true);3289 auto end = fir::FirEndOp::create(*builder, loc);3290 builder->setInsertionPoint(end);3291 }3292 3293 if (const auto &maskExpr =3294 std::get<std::optional<Fortran::parser::ScalarLogicalExpr>>(3295 header.t)) {3296 // Create hlfir.forall_mask and set insertion point in its body.3297 auto forallMaskOp = hlfir::ForallMaskOp::create(*builder, loc);3298 evaluateControl(*maskExpr, forallMaskOp.getMaskRegion(), /*isMask=*/true);3299 builder->createBlock(&forallMaskOp.getBody());3300 auto end = fir::FirEndOp::create(*builder, loc);3301 builder->setInsertionPoint(end);3302 }3303 }3304 3305 void attachDirectiveToLoop(const Fortran::parser::CompilerDirective &dir,3306 Fortran::lower::pft::Evaluation *e) {3307 while (e->isDirective())3308 e = e->lexicalSuccessor;3309 3310 if (e->isA<Fortran::parser::NonLabelDoStmt>())3311 e->dirs.push_back(&dir);3312 }3313 3314 void3315 attachInliningDirectiveToStmt(const Fortran::parser::CompilerDirective &dir,3316 Fortran::lower::pft::Evaluation *e) {3317 while (e->isDirective())3318 e = e->lexicalSuccessor;3319 3320 // If the successor is a statement or a do loop, the compiler3321 // will perform inlining.3322 if (e->isA<Fortran::parser::CallStmt>() ||3323 e->isA<Fortran::parser::NonLabelDoStmt>() ||3324 e->isA<Fortran::parser::AssignmentStmt>()) {3325 e->dirs.push_back(&dir);3326 } else {3327 mlir::Location loc = toLocation();3328 mlir::emitWarning(loc,3329 "Inlining directive not in front of loops, function"3330 "call or assignment.\n");3331 }3332 }3333 3334 void genFIR(const Fortran::parser::CompilerDirective &dir) {3335 Fortran::lower::pft::Evaluation &eval = getEval();3336 3337 Fortran::common::visit(3338 Fortran::common::visitors{3339 [&](const Fortran::parser::CompilerDirective::VectorAlways &) {3340 attachDirectiveToLoop(dir, &eval);3341 },3342 [&](const Fortran::parser::CompilerDirective::Unroll &) {3343 attachDirectiveToLoop(dir, &eval);3344 },3345 [&](const Fortran::parser::CompilerDirective::UnrollAndJam &) {3346 attachDirectiveToLoop(dir, &eval);3347 },3348 [&](const Fortran::parser::CompilerDirective::NoVector &) {3349 attachDirectiveToLoop(dir, &eval);3350 },3351 [&](const Fortran::parser::CompilerDirective::NoUnroll &) {3352 attachDirectiveToLoop(dir, &eval);3353 },3354 [&](const Fortran::parser::CompilerDirective::NoUnrollAndJam &) {3355 attachDirectiveToLoop(dir, &eval);3356 },3357 [&](const Fortran::parser::CompilerDirective::ForceInline &) {3358 attachInliningDirectiveToStmt(dir, &eval);3359 },3360 [&](const Fortran::parser::CompilerDirective::Inline &) {3361 attachInliningDirectiveToStmt(dir, &eval);3362 },3363 [&](const Fortran::parser::CompilerDirective::NoInline &) {3364 attachInliningDirectiveToStmt(dir, &eval);3365 },3366 [&](const Fortran::parser::CompilerDirective::Prefetch &prefetch) {3367 TODO(getCurrentLocation(), "!$dir prefetch");3368 },3369 [&](const Fortran::parser::CompilerDirective::IVDep &) {3370 attachDirectiveToLoop(dir, &eval);3371 },3372 [&](const auto &) {}},3373 dir.u);3374 }3375 3376 void genFIR(const Fortran::parser::OpenACCConstruct &acc) {3377 mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint();3378 localSymbols.pushScope();3379 mlir::Value exitCond = genOpenACCConstruct(3380 *this, bridge.getSemanticsContext(), getEval(), acc, localSymbols);3381 3382 const Fortran::parser::OpenACCLoopConstruct *accLoop =3383 std::get_if<Fortran::parser::OpenACCLoopConstruct>(&acc.u);3384 const Fortran::parser::OpenACCCombinedConstruct *accCombined =3385 std::get_if<Fortran::parser::OpenACCCombinedConstruct>(&acc.u);3386 3387 Fortran::lower::pft::Evaluation *curEval = &getEval();3388 // Determine collapse depth/force and loopCount3389 bool collapseForce = false;3390 uint64_t collapseDepth = 1;3391 uint64_t loopCount = 1;3392 3393 if (accLoop || accCombined) {3394 if (accLoop) {3395 const Fortran::parser::AccBeginLoopDirective &beginLoopDir =3396 std::get<Fortran::parser::AccBeginLoopDirective>(accLoop->t);3397 const Fortran::parser::AccClauseList &clauseList =3398 std::get<Fortran::parser::AccClauseList>(beginLoopDir.t);3399 loopCount = Fortran::lower::getLoopCountForCollapseAndTile(clauseList);3400 std::tie(collapseDepth, collapseForce) =3401 Fortran::lower::getCollapseSizeAndForce(clauseList);3402 } else if (accCombined) {3403 const Fortran::parser::AccBeginCombinedDirective &beginCombinedDir =3404 std::get<Fortran::parser::AccBeginCombinedDirective>(3405 accCombined->t);3406 const Fortran::parser::AccClauseList &clauseList =3407 std::get<Fortran::parser::AccClauseList>(beginCombinedDir.t);3408 loopCount = Fortran::lower::getLoopCountForCollapseAndTile(clauseList);3409 std::tie(collapseDepth, collapseForce) =3410 Fortran::lower::getCollapseSizeAndForce(clauseList);3411 }3412 3413 if (curEval->lowerAsStructured()) {3414 curEval = &curEval->getFirstNestedEvaluation();3415 for (uint64_t i = 1; i < loopCount; i++)3416 curEval = &*std::next(curEval->getNestedEvaluations().begin());3417 }3418 }3419 3420 const bool isStructured = curEval && curEval->lowerAsStructured();3421 if (isStructured && collapseForce && collapseDepth > 1) {3422 // force: collect prologue/epilogue for the first collapseDepth nested3423 // loops and sink them into the innermost loop body at that depth3424 llvm::SmallVector<Fortran::lower::pft::Evaluation *> prologue, epilogue;3425 Fortran::lower::pft::Evaluation *parent = &getEval();3426 Fortran::lower::pft::Evaluation *innermostLoopEval = nullptr;3427 for (uint64_t lvl = 0; lvl + 1 < collapseDepth; ++lvl) {3428 epilogue.clear();3429 auto &kids = parent->getNestedEvaluations();3430 // Collect all non-loop statements before the next inner loop as3431 // prologue, then mark remaining siblings as epilogue and descend into3432 // the inner loop.3433 Fortran::lower::pft::Evaluation *childLoop = nullptr;3434 for (auto it = kids.begin(); it != kids.end(); ++it) {3435 if (it->getIf<Fortran::parser::DoConstruct>()) {3436 childLoop = &*it;3437 for (auto it2 = std::next(it); it2 != kids.end(); ++it2)3438 epilogue.push_back(&*it2);3439 break;3440 }3441 prologue.push_back(&*it);3442 }3443 // Semantics guarantees collapseDepth does not exceed nest depth3444 // so childLoop must be found here.3445 assert(childLoop && "Expected inner DoConstruct for collapse");3446 parent = childLoop;3447 innermostLoopEval = childLoop;3448 }3449 3450 // Track sunk evaluations (avoid double-lowering)3451 llvm::SmallPtrSet<const Fortran::lower::pft::Evaluation *, 16> sunk;3452 for (auto *e : prologue)3453 sunk.insert(e);3454 for (auto *e : epilogue)3455 sunk.insert(e);3456 3457 auto sink =3458 [&](llvm::SmallVector<Fortran::lower::pft::Evaluation *> &lst) {3459 for (auto *e : lst)3460 genFIR(*e);3461 };3462 3463 sink(prologue);3464 3465 // Lower innermost loop body, skipping sunk3466 for (Fortran::lower::pft::Evaluation &e :3467 innermostLoopEval->getNestedEvaluations())3468 if (!sunk.contains(&e))3469 genFIR(e);3470 3471 sink(epilogue);3472 } else {3473 // Normal lowering3474 for (Fortran::lower::pft::Evaluation &e : curEval->getNestedEvaluations())3475 genFIR(e);3476 }3477 localSymbols.popScope();3478 builder->restoreInsertionPoint(insertPt);3479 3480 if (accLoop && exitCond) {3481 Fortran::lower::pft::FunctionLikeUnit *funit =3482 getEval().getOwningProcedure();3483 assert(funit && "not inside main program, function or subroutine");3484 mlir::Block *continueBlock =3485 builder->getBlock()->splitBlock(builder->getBlock()->end());3486 mlir::cf::CondBranchOp::create(*builder, toLocation(), exitCond,3487 funit->finalBlock, continueBlock);3488 builder->setInsertionPointToEnd(continueBlock);3489 }3490 }3491 3492 void genFIR(const Fortran::parser::OpenACCDeclarativeConstruct &accDecl) {3493 genOpenACCDeclarativeConstruct(*this, bridge.getSemanticsContext(),3494 bridge.openAccCtx(), accDecl);3495 for (Fortran::lower::pft::Evaluation &e : getEval().getNestedEvaluations())3496 genFIR(e);3497 }3498 3499 void genFIR(const Fortran::parser::OpenACCRoutineConstruct &acc) {3500 // Handled by genFIR(const Fortran::parser::OpenACCDeclarativeConstruct &)3501 }3502 3503 void genFIR(const Fortran::parser::CUFKernelDoConstruct &kernel) {3504 Fortran::lower::SymMapScope scope(localSymbols);3505 const Fortran::parser::CUFKernelDoConstruct::Directive &dir =3506 std::get<Fortran::parser::CUFKernelDoConstruct::Directive>(kernel.t);3507 3508 mlir::Location loc = genLocation(dir.source);3509 3510 Fortran::lower::StatementContext stmtCtx;3511 3512 unsigned nestedLoops = 1;3513 3514 const auto &nLoops =3515 std::get<std::optional<Fortran::parser::ScalarIntConstantExpr>>(dir.t);3516 if (nLoops)3517 nestedLoops = *Fortran::semantics::GetIntValue(*nLoops);3518 3519 mlir::IntegerAttr n;3520 if (nestedLoops > 1)3521 n = builder->getIntegerAttr(builder->getI64Type(), nestedLoops);3522 3523 const auto &launchConfig = std::get<std::optional<3524 Fortran::parser::CUFKernelDoConstruct::LaunchConfiguration>>(dir.t);3525 3526 const std::list<Fortran::parser::CUFReduction> &cufreds =3527 std::get<2>(dir.t);3528 3529 llvm::SmallVector<mlir::Value> reduceOperands;3530 llvm::SmallVector<mlir::Attribute> reduceAttrs;3531 3532 for (const Fortran::parser::CUFReduction &cufred : cufreds) {3533 fir::ReduceOperationEnum redOpEnum = getReduceOperationEnum(3534 std::get<Fortran::parser::ReductionOperator>(cufred.t));3535 const std::list<Fortran::parser::Scalar<Fortran::parser::Variable>>3536 &scalarvars = std::get<1>(cufred.t);3537 for (const Fortran::parser::Scalar<Fortran::parser::Variable> &scalarvar :3538 scalarvars) {3539 auto reduce_attr =3540 fir::ReduceAttr::get(builder->getContext(), redOpEnum);3541 reduceAttrs.push_back(reduce_attr);3542 const Fortran::parser::Variable &var = scalarvar.thing;3543 if (const auto *iDesignator = std::get_if<3544 Fortran::common::Indirection<Fortran::parser::Designator>>(3545 &var.u)) {3546 const Fortran::parser::Designator &designator = iDesignator->value();3547 if (const auto *name =3548 Fortran::parser::GetDesignatorNameIfDataRef(designator)) {3549 auto val = getSymbolAddress(*name->symbol);3550 reduceOperands.push_back(val);3551 }3552 }3553 }3554 }3555 3556 auto isOnlyStars =3557 [&](const std::list<Fortran::parser::CUFKernelDoConstruct::StarOrExpr>3558 &list) -> bool {3559 for (const Fortran::parser::CUFKernelDoConstruct::StarOrExpr &expr :3560 list) {3561 if (expr.v)3562 return false;3563 }3564 return true;3565 };3566 3567 mlir::Value zero =3568 builder->createIntegerConstant(loc, builder->getI32Type(), 0);3569 3570 llvm::SmallVector<mlir::Value> gridValues;3571 llvm::SmallVector<mlir::Value> blockValues;3572 mlir::Value streamAddr;3573 3574 if (launchConfig) {3575 const std::list<Fortran::parser::CUFKernelDoConstruct::StarOrExpr> &grid =3576 std::get<0>(launchConfig->t);3577 const std::list<Fortran::parser::CUFKernelDoConstruct::StarOrExpr>3578 &block = std::get<1>(launchConfig->t);3579 const std::optional<Fortran::parser::ScalarIntExpr> &stream =3580 std::get<2>(launchConfig->t);3581 if (!isOnlyStars(grid)) {3582 for (const Fortran::parser::CUFKernelDoConstruct::StarOrExpr &expr :3583 grid) {3584 if (expr.v) {3585 gridValues.push_back(fir::getBase(3586 genExprValue(*Fortran::semantics::GetExpr(*expr.v), stmtCtx)));3587 } else {3588 gridValues.push_back(zero);3589 }3590 }3591 }3592 if (!isOnlyStars(block)) {3593 for (const Fortran::parser::CUFKernelDoConstruct::StarOrExpr &expr :3594 block) {3595 if (expr.v) {3596 blockValues.push_back(fir::getBase(3597 genExprValue(*Fortran::semantics::GetExpr(*expr.v), stmtCtx)));3598 } else {3599 blockValues.push_back(zero);3600 }3601 }3602 }3603 3604 if (stream)3605 streamAddr = fir::getBase(3606 genExprAddr(*Fortran::semantics::GetExpr(*stream), stmtCtx));3607 }3608 3609 const auto &outerDoConstruct =3610 std::get<std::optional<Fortran::parser::DoConstruct>>(kernel.t);3611 3612 llvm::SmallVector<mlir::Location> locs;3613 locs.push_back(loc);3614 llvm::SmallVector<mlir::Value> lbs, ubs, steps;3615 3616 mlir::Type idxTy = builder->getIndexType();3617 3618 llvm::SmallVector<mlir::Type> ivTypes;3619 llvm::SmallVector<mlir::Location> ivLocs;3620 llvm::SmallVector<mlir::Value> ivValues;3621 Fortran::lower::pft::Evaluation *loopEval =3622 &getEval().getFirstNestedEvaluation();3623 if (outerDoConstruct->IsDoConcurrent()) {3624 // Handle DO CONCURRENT3625 locs.push_back(3626 genLocation(Fortran::parser::FindSourceLocation(outerDoConstruct)));3627 const Fortran::parser::LoopControl *loopControl =3628 &*outerDoConstruct->GetLoopControl();3629 const auto &concurrent =3630 std::get<Fortran::parser::LoopControl::Concurrent>(loopControl->u);3631 3632 if (!std::get<std::list<Fortran::parser::LocalitySpec>>(concurrent.t)3633 .empty())3634 TODO(loc, "DO CONCURRENT with locality spec");3635 3636 const auto &concurrentHeader =3637 std::get<Fortran::parser::ConcurrentHeader>(concurrent.t);3638 const auto &controls =3639 std::get<std::list<Fortran::parser::ConcurrentControl>>(3640 concurrentHeader.t);3641 3642 for (const auto &control : controls) {3643 mlir::Value lb = fir::getBase(genExprValue(3644 *Fortran::semantics::GetExpr(std::get<1>(control.t)), stmtCtx));3645 mlir::Value ub = fir::getBase(genExprValue(3646 *Fortran::semantics::GetExpr(std::get<2>(control.t)), stmtCtx));3647 mlir::Value step;3648 3649 if (const auto &expr =3650 std::get<std::optional<Fortran::parser::ScalarIntExpr>>(3651 control.t))3652 step = fir::getBase(3653 genExprValue(*Fortran::semantics::GetExpr(*expr), stmtCtx));3654 else3655 step = mlir::arith::ConstantIndexOp::create(3656 *builder, loc, 1); // Use index type directly3657 3658 // Ensure lb, ub, and step are of index type using fir.convert3659 lb = fir::ConvertOp::create(*builder, loc, idxTy, lb);3660 ub = fir::ConvertOp::create(*builder, loc, idxTy, ub);3661 step = fir::ConvertOp::create(*builder, loc, idxTy, step);3662 3663 lbs.push_back(lb);3664 ubs.push_back(ub);3665 steps.push_back(step);3666 3667 const auto &name = std::get<Fortran::parser::Name>(control.t);3668 3669 // Handle induction variable3670 mlir::Value ivValue = getSymbolAddress(*name.symbol);3671 3672 if (!ivValue) {3673 // DO CONCURRENT induction variables are not mapped yet since they are3674 // local to the DO CONCURRENT scope.3675 mlir::OpBuilder::InsertPoint insPt = builder->saveInsertionPoint();3676 builder->setInsertionPointToStart(builder->getAllocaBlock());3677 ivValue = builder->createTemporaryAlloc(3678 loc, idxTy, toStringRef(name.symbol->name()));3679 builder->restoreInsertionPoint(insPt);3680 }3681 3682 // Bind the symbol to the declared variable3683 bindSymbol(*name.symbol, ivValue);3684 Fortran::lower::SymbolBox hsb = localSymbols.lookupSymbol(*name.symbol);3685 fir::ExtendedValue extIvValue = symBoxToExtendedValue(hsb);3686 ivValue = fir::getBase(extIvValue);3687 ivValues.push_back(ivValue);3688 ivTypes.push_back(idxTy);3689 ivLocs.push_back(loc);3690 }3691 } else {3692 for (unsigned i = 0; i < nestedLoops; ++i) {3693 const Fortran::parser::LoopControl *loopControl;3694 mlir::Location crtLoc = loc;3695 if (i == 0) {3696 loopControl = &*outerDoConstruct->GetLoopControl();3697 crtLoc = genLocation(3698 Fortran::parser::FindSourceLocation(outerDoConstruct));3699 } else {3700 auto *doCons = loopEval->getIf<Fortran::parser::DoConstruct>();3701 assert(doCons && "expect do construct");3702 loopControl = &*doCons->GetLoopControl();3703 crtLoc = genLocation(Fortran::parser::FindSourceLocation(*doCons));3704 }3705 3706 locs.push_back(crtLoc);3707 3708 const Fortran::parser::LoopControl::Bounds *bounds =3709 std::get_if<Fortran::parser::LoopControl::Bounds>(&loopControl->u);3710 assert(bounds && "Expected bounds on the loop construct");3711 3712 Fortran::semantics::Symbol &ivSym =3713 bounds->name.thing.symbol->GetUltimate();3714 ivValues.push_back(getSymbolAddress(ivSym));3715 3716 lbs.push_back(builder->createConvert(3717 crtLoc, idxTy,3718 fir::getBase(genExprValue(3719 *Fortran::semantics::GetExpr(bounds->lower), stmtCtx))));3720 ubs.push_back(builder->createConvert(3721 crtLoc, idxTy,3722 fir::getBase(genExprValue(3723 *Fortran::semantics::GetExpr(bounds->upper), stmtCtx))));3724 if (bounds->step)3725 steps.push_back(builder->createConvert(3726 crtLoc, idxTy,3727 fir::getBase(genExprValue(3728 *Fortran::semantics::GetExpr(bounds->step), stmtCtx))));3729 else // If `step` is not present, assume it is `1`.3730 steps.push_back(builder->createIntegerConstant(loc, idxTy, 1));3731 3732 ivTypes.push_back(idxTy);3733 ivLocs.push_back(crtLoc);3734 if (i < nestedLoops - 1)3735 loopEval = &*std::next(loopEval->getNestedEvaluations().begin());3736 }3737 }3738 3739 auto op = cuf::KernelOp::create(3740 *builder, loc, gridValues, blockValues, streamAddr, lbs, ubs, steps, n,3741 mlir::ValueRange(reduceOperands), builder->getArrayAttr(reduceAttrs));3742 builder->createBlock(&op.getRegion(), op.getRegion().end(), ivTypes,3743 ivLocs);3744 mlir::Block &b = op.getRegion().back();3745 builder->setInsertionPointToStart(&b);3746 3747 Fortran::lower::pft::Evaluation *crtEval = &getEval();3748 if (crtEval->lowerAsUnstructured())3749 Fortran::lower::createEmptyRegionBlocks<fir::FirEndOp>(3750 *builder, crtEval->getNestedEvaluations());3751 builder->setInsertionPointToStart(&b);3752 3753 for (auto [arg, value] : llvm::zip(3754 op.getLoopRegions().front()->front().getArguments(), ivValues)) {3755 mlir::Value convArg =3756 builder->createConvert(loc, fir::unwrapRefType(value.getType()), arg);3757 fir::StoreOp::create(*builder, loc, convArg, value);3758 }3759 3760 if (crtEval->lowerAsStructured()) {3761 crtEval = &crtEval->getFirstNestedEvaluation();3762 for (int64_t i = 1; i < nestedLoops; i++)3763 crtEval = &*std::next(crtEval->getNestedEvaluations().begin());3764 }3765 3766 // Generate loop body3767 for (Fortran::lower::pft::Evaluation &e : crtEval->getNestedEvaluations())3768 genFIR(e);3769 3770 fir::FirEndOp::create(*builder, loc);3771 builder->setInsertionPointAfter(op);3772 }3773 3774 void genFIR(const Fortran::parser::OpenMPConstruct &omp) {3775 mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint();3776 genOpenMPConstruct(*this, localSymbols, bridge.getSemanticsContext(),3777 getEval(), omp);3778 builder->restoreInsertionPoint(insertPt);3779 3780 // Register if a target region was found3781 ompDeviceCodeFound =3782 ompDeviceCodeFound || Fortran::lower::isOpenMPTargetConstruct(omp);3783 }3784 3785 void genFIR(const Fortran::parser::OpenMPDeclarativeConstruct &ompDecl) {3786 mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint();3787 // Register if a declare target construct intended for a target device was3788 // found3789 ompDeviceCodeFound =3790 ompDeviceCodeFound ||3791 Fortran::lower::isOpenMPDeviceDeclareTarget(3792 *this, bridge.getSemanticsContext(), getEval(), ompDecl);3793 Fortran::lower::gatherOpenMPDeferredDeclareTargets(3794 *this, bridge.getSemanticsContext(), getEval(), ompDecl,3795 ompDeferredDeclareTarget);3796 genOpenMPDeclarativeConstruct(3797 *this, localSymbols, bridge.getSemanticsContext(), getEval(), ompDecl);3798 builder->restoreInsertionPoint(insertPt);3799 }3800 3801 /// Generate FIR for a SELECT CASE statement.3802 /// The selector may have CHARACTER, INTEGER, UNSIGNED, or LOGICAL type.3803 void genFIR(const Fortran::parser::SelectCaseStmt &stmt) {3804 Fortran::lower::pft::Evaluation &eval = getEval();3805 Fortran::lower::pft::Evaluation *parentConstruct = eval.parentConstruct;3806 assert(!activeConstructStack.empty() &&3807 &activeConstructStack.back().eval == parentConstruct &&3808 "select case construct is not active");3809 Fortran::lower::StatementContext &stmtCtx =3810 activeConstructStack.back().stmtCtx;3811 const Fortran::lower::SomeExpr *expr = Fortran::semantics::GetExpr(3812 std::get<Fortran::parser::Scalar<Fortran::parser::Expr>>(stmt.t));3813 bool isCharSelector = isCharacterCategory(expr->GetType()->category());3814 bool isLogicalSelector = isLogicalCategory(expr->GetType()->category());3815 mlir::MLIRContext *context = builder->getContext();3816 mlir::Location loc = toLocation();3817 auto charValue = [&](const Fortran::lower::SomeExpr *expr) {3818 fir::ExtendedValue exv = genExprAddr(*expr, stmtCtx, &loc);3819 return exv.match(3820 [&](const fir::CharBoxValue &cbv) {3821 return fir::factory::CharacterExprHelper{*builder, loc}3822 .createEmboxChar(cbv.getAddr(), cbv.getLen());3823 },3824 [&](auto) {3825 fir::emitFatalError(loc, "not a character");3826 return mlir::Value{};3827 });3828 };3829 mlir::Value selector;3830 if (isCharSelector) {3831 selector = charValue(expr);3832 } else {3833 selector = createFIRExpr(loc, expr, stmtCtx);3834 if (isLogicalSelector)3835 selector = builder->createConvert(loc, builder->getI1Type(), selector);3836 }3837 mlir::Type selectType = selector.getType();3838 if (selectType.isUnsignedInteger())3839 selectType = mlir::IntegerType::get(3840 builder->getContext(), selectType.getIntOrFloatBitWidth(),3841 mlir::IntegerType::SignednessSemantics::Signless);3842 llvm::SmallVector<mlir::Attribute> attrList;3843 llvm::SmallVector<mlir::Value> valueList;3844 llvm::SmallVector<mlir::Block *> blockList;3845 mlir::Block *defaultBlock = parentConstruct->constructExit->block;3846 using CaseValue = Fortran::parser::Scalar<Fortran::parser::ConstantExpr>;3847 auto addValue = [&](const CaseValue &caseValue) {3848 const Fortran::lower::SomeExpr *expr =3849 Fortran::semantics::GetExpr(caseValue.thing);3850 if (isCharSelector)3851 valueList.push_back(charValue(expr));3852 else if (isLogicalSelector)3853 valueList.push_back(builder->createConvert(3854 loc, selectType, createFIRExpr(toLocation(), expr, stmtCtx)));3855 else {3856 valueList.push_back(builder->createIntegerConstant(3857 loc, selectType, *Fortran::evaluate::ToInt64(*expr)));3858 }3859 };3860 for (Fortran::lower::pft::Evaluation *e = eval.controlSuccessor; e;3861 e = e->controlSuccessor) {3862 const auto &caseStmt = e->getIf<Fortran::parser::CaseStmt>();3863 assert(e->block && "missing CaseStmt block");3864 const auto &caseSelector =3865 std::get<Fortran::parser::CaseSelector>(caseStmt->t);3866 const auto *caseValueRangeList =3867 std::get_if<std::list<Fortran::parser::CaseValueRange>>(3868 &caseSelector.u);3869 if (!caseValueRangeList) {3870 defaultBlock = e->block;3871 continue;3872 }3873 for (const Fortran::parser::CaseValueRange &caseValueRange :3874 *caseValueRangeList) {3875 blockList.push_back(e->block);3876 if (const auto *caseValue = std::get_if<CaseValue>(&caseValueRange.u)) {3877 attrList.push_back(fir::PointIntervalAttr::get(context));3878 addValue(*caseValue);3879 continue;3880 }3881 const auto &caseRange =3882 std::get<Fortran::parser::CaseValueRange::Range>(caseValueRange.u);3883 if (caseRange.lower && caseRange.upper) {3884 attrList.push_back(fir::ClosedIntervalAttr::get(context));3885 addValue(*caseRange.lower);3886 addValue(*caseRange.upper);3887 } else if (caseRange.lower) {3888 attrList.push_back(fir::LowerBoundAttr::get(context));3889 addValue(*caseRange.lower);3890 } else {3891 attrList.push_back(fir::UpperBoundAttr::get(context));3892 addValue(*caseRange.upper);3893 }3894 }3895 }3896 // Skip a logical default block that can never be referenced.3897 if (isLogicalSelector && attrList.size() == 2)3898 defaultBlock = parentConstruct->constructExit->block;3899 attrList.push_back(mlir::UnitAttr::get(context));3900 blockList.push_back(defaultBlock);3901 3902 // Generate a fir::SelectCaseOp. Explicit branch code is better for the3903 // LOGICAL type. The CHARACTER type does not have downstream SelectOp3904 // support. The -no-structured-fir option can be used to force generation3905 // of INTEGER type branch code.3906 if (!isLogicalSelector && !isCharSelector &&3907 !getEval().forceAsUnstructured()) {3908 // The selector is in an ssa register. Any temps that may have been3909 // generated while evaluating it can be cleaned up now.3910 stmtCtx.finalizeAndReset();3911 fir::SelectCaseOp::create(*builder, loc, selector, attrList, valueList,3912 blockList);3913 return;3914 }3915 3916 // Generate a sequence of case value comparisons and branches.3917 auto caseValue = valueList.begin();3918 auto caseBlock = blockList.begin();3919 for (mlir::Attribute attr : attrList) {3920 if (mlir::isa<mlir::UnitAttr>(attr)) {3921 genBranch(*caseBlock++);3922 break;3923 }3924 auto genCond = [&](mlir::Value rhs,3925 mlir::arith::CmpIPredicate pred) -> mlir::Value {3926 if (!isCharSelector)3927 return mlir::arith::CmpIOp::create(*builder, loc, pred, selector,3928 rhs);3929 else3930 return hlfir::CmpCharOp::create(*builder, loc, pred, selector, rhs);3931 };3932 mlir::Block *newBlock = insertBlock(*caseBlock);3933 if (mlir::isa<fir::ClosedIntervalAttr>(attr)) {3934 mlir::Block *newBlock2 = insertBlock(*caseBlock);3935 mlir::Value cond =3936 genCond(*caseValue++, mlir::arith::CmpIPredicate::sge);3937 genConditionalBranch(cond, newBlock, newBlock2);3938 builder->setInsertionPointToEnd(newBlock);3939 mlir::Value cond2 =3940 genCond(*caseValue++, mlir::arith::CmpIPredicate::sle);3941 genConditionalBranch(cond2, *caseBlock++, newBlock2);3942 builder->setInsertionPointToEnd(newBlock2);3943 continue;3944 }3945 mlir::arith::CmpIPredicate pred;3946 if (mlir::isa<fir::PointIntervalAttr>(attr)) {3947 pred = mlir::arith::CmpIPredicate::eq;3948 } else if (mlir::isa<fir::LowerBoundAttr>(attr)) {3949 pred = mlir::arith::CmpIPredicate::sge;3950 } else {3951 assert(mlir::isa<fir::UpperBoundAttr>(attr) && "unexpected predicate");3952 pred = mlir::arith::CmpIPredicate::sle;3953 }3954 mlir::Value cond = genCond(*caseValue++, pred);3955 genConditionalBranch(cond, *caseBlock++, newBlock);3956 builder->setInsertionPointToEnd(newBlock);3957 }3958 assert(caseValue == valueList.end() && caseBlock == blockList.end() &&3959 "select case list mismatch");3960 }3961 3962 fir::ExtendedValue3963 genAssociateSelector(const Fortran::lower::SomeExpr &selector,3964 Fortran::lower::StatementContext &stmtCtx) {3965 if (lowerToHighLevelFIR())3966 return genExprAddr(selector, stmtCtx);3967 return Fortran::lower::isArraySectionWithoutVectorSubscript(selector)3968 ? Fortran::lower::createSomeArrayBox(*this, selector,3969 localSymbols, stmtCtx)3970 : genExprAddr(selector, stmtCtx);3971 }3972 3973 void genFIR(const Fortran::parser::AssociateConstruct &) {3974 Fortran::lower::pft::Evaluation &eval = getEval();3975 Fortran::lower::StatementContext stmtCtx;3976 pushActiveConstruct(eval, stmtCtx);3977 for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {3978 setCurrentPosition(e.position);3979 if (auto *stmt = e.getIf<Fortran::parser::AssociateStmt>()) {3980 if (eval.lowerAsUnstructured())3981 maybeStartBlock(e.block);3982 localSymbols.pushScope();3983 for (const Fortran::parser::Association &assoc :3984 std::get<std::list<Fortran::parser::Association>>(stmt->t)) {3985 Fortran::semantics::Symbol &sym =3986 *std::get<Fortran::parser::Name>(assoc.t).symbol;3987 const Fortran::lower::SomeExpr &selector =3988 *sym.get<Fortran::semantics::AssocEntityDetails>().expr();3989 addSymbol(sym, genAssociateSelector(selector, stmtCtx));3990 }3991 } else if (e.getIf<Fortran::parser::EndAssociateStmt>()) {3992 if (eval.lowerAsUnstructured())3993 maybeStartBlock(e.block);3994 localSymbols.popScope();3995 } else {3996 genFIR(e);3997 }3998 }3999 popActiveConstruct();4000 }4001 4002 void genFIR(const Fortran::parser::BlockConstruct &blockConstruct) {4003 Fortran::lower::pft::Evaluation &eval = getEval();4004 Fortran::lower::StatementContext stmtCtx;4005 pushActiveConstruct(eval, stmtCtx);4006 for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {4007 setCurrentPosition(e.position);4008 if (e.getIf<Fortran::parser::BlockStmt>()) {4009 if (eval.lowerAsUnstructured())4010 maybeStartBlock(e.block);4011 const Fortran::parser::CharBlock &endPosition =4012 eval.getLastNestedEvaluation().position;4013 localSymbols.pushScope();4014 mlir::Value stackPtr = builder->genStackSave(toLocation());4015 mlir::Location endLoc = genLocation(endPosition);4016 stmtCtx.attachCleanup(4017 [=]() { builder->genStackRestore(endLoc, stackPtr); });4018 Fortran::semantics::Scope &scope =4019 bridge.getSemanticsContext().FindScope(endPosition);4020 scopeBlockIdMap.try_emplace(&scope, ++blockId);4021 Fortran::lower::AggregateStoreMap storeMap;4022 for (const Fortran::lower::pft::Variable &var :4023 Fortran::lower::pft::getScopeVariableList(scope)) {4024 // Do no instantiate again variables from the block host4025 // that appears in specification of block variables.4026 if (!var.hasSymbol() || !lookupSymbol(var.getSymbol()))4027 instantiateVar(var, storeMap);4028 }4029 } else if (e.getIf<Fortran::parser::EndBlockStmt>()) {4030 if (eval.lowerAsUnstructured())4031 maybeStartBlock(e.block);4032 localSymbols.popScope();4033 } else {4034 genFIR(e);4035 }4036 }4037 popActiveConstruct();4038 }4039 4040 void genFIR(const Fortran::parser::ChangeTeamConstruct &construct) {4041 Fortran::lower::StatementContext stmtCtx;4042 pushActiveConstruct(getEval(), stmtCtx);4043 4044 for (Fortran::lower::pft::Evaluation &e :4045 getEval().getNestedEvaluations()) {4046 if (e.getIf<Fortran::parser::ChangeTeamStmt>()) {4047 maybeStartBlock(e.block);4048 setCurrentPosition(e.position);4049 genFIR(e);4050 } else if (e.getIf<Fortran::parser::EndChangeTeamStmt>()) {4051 maybeStartBlock(e.block);4052 setCurrentPosition(e.position);4053 genFIR(e);4054 } else {4055 genFIR(e);4056 }4057 }4058 popActiveConstruct();4059 }4060 void genFIR(const Fortran::parser::ChangeTeamStmt &stmt) {4061 genChangeTeamStmt(*this, getEval(), stmt);4062 }4063 void genFIR(const Fortran::parser::EndChangeTeamStmt &stmt) {4064 genEndChangeTeamStmt(*this, getEval(), stmt);4065 }4066 4067 void genFIR(const Fortran::parser::CriticalConstruct &criticalConstruct) {4068 setCurrentPositionAt(criticalConstruct);4069 TODO(toLocation(), "coarray: CriticalConstruct");4070 }4071 void genFIR(const Fortran::parser::CriticalStmt &) {4072 TODO(toLocation(), "coarray: CriticalStmt");4073 }4074 void genFIR(const Fortran::parser::EndCriticalStmt &) {4075 TODO(toLocation(), "coarray: EndCriticalStmt");4076 }4077 4078 void genFIR(const Fortran::parser::SelectRankConstruct &selectRankConstruct) {4079 setCurrentPositionAt(selectRankConstruct);4080 genCaseOrRankConstruct();4081 }4082 4083 void genFIR(const Fortran::parser::SelectRankStmt &selectRankStmt) {4084 // Generate a fir.select_case with the selector rank. The RANK(*) case,4085 // if any, is handles with a conditional branch before the fir.select_case.4086 mlir::Type rankType = builder->getIntegerType(8);4087 mlir::MLIRContext *context = builder->getContext();4088 mlir::Location loc = toLocation();4089 // Build block list for fir.select_case, and identify RANK(*) block, if any.4090 // Default block must be placed last in the fir.select_case block list.4091 mlir::Block *rankStarBlock = nullptr;4092 Fortran::lower::pft::Evaluation &eval = getEval();4093 mlir::Block *defaultBlock = eval.parentConstruct->constructExit->block;4094 llvm::SmallVector<mlir::Attribute> attrList;4095 llvm::SmallVector<mlir::Value> valueList;4096 llvm::SmallVector<mlir::Block *> blockList;4097 for (Fortran::lower::pft::Evaluation *e = eval.controlSuccessor; e;4098 e = e->controlSuccessor) {4099 if (const auto *rankCaseStmt =4100 e->getIf<Fortran::parser::SelectRankCaseStmt>()) {4101 const auto &rank = std::get<Fortran::parser::SelectRankCaseStmt::Rank>(4102 rankCaseStmt->t);4103 assert(e->block && "missing SelectRankCaseStmt block");4104 Fortran::common::visit(4105 Fortran::common::visitors{4106 [&](const Fortran::parser::ScalarIntConstantExpr &rankExpr) {4107 blockList.emplace_back(e->block);4108 attrList.emplace_back(fir::PointIntervalAttr::get(context));4109 std::optional<std::int64_t> rankCst =4110 Fortran::evaluate::ToInt64(4111 Fortran::semantics::GetExpr(rankExpr));4112 assert(rankCst.has_value() &&4113 "rank expr must be constant integer");4114 valueList.emplace_back(4115 builder->createIntegerConstant(loc, rankType, *rankCst));4116 },4117 [&](const Fortran::parser::Star &) {4118 rankStarBlock = e->block;4119 },4120 [&](const Fortran::parser::Default &) {4121 defaultBlock = e->block;4122 }},4123 rank.u);4124 }4125 }4126 attrList.push_back(mlir::UnitAttr::get(context));4127 blockList.push_back(defaultBlock);4128 4129 // Lower selector.4130 assert(!activeConstructStack.empty() && "must be inside construct");4131 assert(!activeConstructStack.back().selector &&4132 "selector should not yet be set");4133 Fortran::lower::StatementContext &stmtCtx =4134 activeConstructStack.back().stmtCtx;4135 const Fortran::lower::SomeExpr *selectorExpr = Fortran::common::visit(4136 [](const auto &x) { return Fortran::semantics::GetExpr(x); },4137 std::get<Fortran::parser::Selector>(selectRankStmt.t).u);4138 assert(selectorExpr && "failed to retrieve selector expr");4139 hlfir::Entity selector = Fortran::lower::convertExprToHLFIR(4140 loc, *this, *selectorExpr, localSymbols, stmtCtx);4141 activeConstructStack.back().selector = selector;4142 4143 // Deal with assumed-size first. They must fall into RANK(*) if present, or4144 // the default case (F'2023 11.1.10.2.). The selector cannot be an4145 // assumed-size if it is allocatable or pointer, so the check is skipped.4146 if (!Fortran::evaluate::IsAllocatableOrPointerObject(*selectorExpr)) {4147 mlir::Value isAssumedSize = fir::IsAssumedSizeOp::create(4148 *builder, loc, builder->getI1Type(), selector);4149 // Create new block to hold the fir.select_case for the non assumed-size4150 // cases.4151 mlir::Block *selectCaseBlock = insertBlock(blockList[0]);4152 mlir::Block *assumedSizeBlock =4153 rankStarBlock ? rankStarBlock : defaultBlock;4154 mlir::cf::CondBranchOp::create(*builder, loc, isAssumedSize,4155 assumedSizeBlock, mlir::ValueRange{},4156 selectCaseBlock, mlir::ValueRange{});4157 startBlock(selectCaseBlock);4158 }4159 // Create fir.select_case for the other rank cases.4160 mlir::Value rank =4161 fir::BoxRankOp::create(*builder, loc, rankType, selector);4162 stmtCtx.finalizeAndReset();4163 fir::SelectCaseOp::create(*builder, loc, rank, attrList, valueList,4164 blockList);4165 }4166 4167 // Get associating entity symbol inside case statement scope.4168 static const Fortran::semantics::Symbol &4169 getAssociatingEntitySymbol(const Fortran::semantics::Scope &scope) {4170 const Fortran::semantics::Symbol *assocSym = nullptr;4171 for (const auto &sym : scope.GetSymbols()) {4172 if (sym->has<Fortran::semantics::AssocEntityDetails>()) {4173 assert(!assocSym &&4174 "expect only one associating entity symbol in this scope");4175 assocSym = &*sym;4176 }4177 }4178 assert(assocSym && "should contain associating entity symbol");4179 return *assocSym;4180 }4181 4182 void genFIR(const Fortran::parser::SelectRankCaseStmt &stmt) {4183 assert(!activeConstructStack.empty() &&4184 "must be inside select rank construct");4185 // Pop previous associating entity mapping, if any, and push scope for new4186 // mapping.4187 if (activeConstructStack.back().pushedScope)4188 localSymbols.popScope();4189 localSymbols.pushScope();4190 activeConstructStack.back().pushedScope = true;4191 const Fortran::semantics::Symbol &assocEntitySymbol =4192 getAssociatingEntitySymbol(4193 bridge.getSemanticsContext().FindScope(getEval().position));4194 const auto &details =4195 assocEntitySymbol.get<Fortran::semantics::AssocEntityDetails>();4196 assert(!activeConstructStack.empty() &&4197 activeConstructStack.back().selector.has_value() &&4198 "selector must have been created");4199 // Get lowered value for the selector.4200 hlfir::Entity selector = *activeConstructStack.back().selector;4201 assert(selector.isVariable() && "assumed-rank selector are variables");4202 // Cook selector mlir::Value according to rank case and map it to4203 // associating entity symbol.4204 Fortran::lower::StatementContext stmtCtx;4205 mlir::Location loc = toLocation();4206 if (details.IsAssumedRank()) {4207 fir::ExtendedValue selectorExv = Fortran::lower::translateToExtendedValue(4208 loc, *builder, selector, stmtCtx);4209 addSymbol(assocEntitySymbol, selectorExv);4210 } else if (details.IsAssumedSize()) {4211 // Create rank-1 assumed-size from descriptor. Assumed-size are contiguous4212 // so a new entity can be built from scratch using the base address, type4213 // parameters and dynamic type. The selector cannot be a4214 // POINTER/ALLOCATBLE as per F'2023 C1160.4215 fir::ExtendedValue newExv;4216 llvm::SmallVector<mlir::Value> assumeSizeExtents{4217 fir::AssumedSizeExtentOp::create(*builder, loc)};4218 mlir::Value baseAddr =4219 hlfir::genVariableRawAddress(loc, *builder, selector);4220 const bool isVolatile = fir::isa_volatile_type(selector.getType());4221 mlir::Type eleType =4222 fir::unwrapSequenceType(fir::unwrapRefType(baseAddr.getType()));4223 mlir::Type rank1Type = fir::ReferenceType::get(4224 builder->getVarLenSeqTy(eleType, 1), isVolatile);4225 baseAddr = builder->createConvert(loc, rank1Type, baseAddr);4226 if (selector.isCharacter()) {4227 mlir::Value len = hlfir::genCharLength(loc, *builder, selector);4228 newExv = fir::CharArrayBoxValue{baseAddr, len, assumeSizeExtents};4229 } else if (selector.isDerivedWithLengthParameters()) {4230 TODO(loc, "RANK(*) with parameterized derived type selector");4231 } else if (selector.isPolymorphic()) {4232 TODO(loc, "RANK(*) with polymorphic selector");4233 } else {4234 // Simple intrinsic or derived type.4235 newExv = fir::ArrayBoxValue{baseAddr, assumeSizeExtents};4236 }4237 addSymbol(assocEntitySymbol, newExv);4238 } else {4239 int rank = details.rank().value();4240 auto boxTy =4241 mlir::cast<fir::BaseBoxType>(fir::unwrapRefType(selector.getType()));4242 mlir::Type newBoxType = boxTy.getBoxTypeWithNewShape(rank);4243 if (fir::isa_ref_type(selector.getType()))4244 newBoxType = fir::ReferenceType::get(4245 newBoxType, fir::isa_volatile_type(selector.getType()));4246 // Give rank info to value via cast, and get rid of the box if not needed4247 // (simple scalars, contiguous arrays... This is done by4248 // translateVariableToExtendedValue).4249 hlfir::Entity rankedBox{4250 builder->createConvert(loc, newBoxType, selector)};4251 bool isSimplyContiguous = Fortran::evaluate::IsSimplyContiguous(4252 assocEntitySymbol, getFoldingContext());4253 fir::ExtendedValue newExv = Fortran::lower::translateToExtendedValue(4254 loc, *builder, rankedBox, stmtCtx, isSimplyContiguous);4255 4256 // Non deferred length parameters of character allocatable/pointer4257 // MutableBoxValue should be properly set before binding it to a symbol in4258 // order to get correct assignment semantics.4259 if (const fir::MutableBoxValue *mutableBox =4260 newExv.getBoxOf<fir::MutableBoxValue>()) {4261 if (selector.isCharacter()) {4262 auto dynamicType =4263 Fortran::evaluate::DynamicType::From(assocEntitySymbol);4264 if (!dynamicType.value().HasDeferredTypeParameter()) {4265 llvm::SmallVector<mlir::Value> lengthParams;4266 hlfir::genLengthParameters(loc, *builder, selector, lengthParams);4267 newExv = fir::MutableBoxValue{rankedBox, lengthParams,4268 mutableBox->getMutableProperties()};4269 }4270 }4271 }4272 addSymbol(assocEntitySymbol, newExv);4273 }4274 // Statements inside rank case are lowered by SelectRankConstruct visit.4275 }4276 4277 void genFIR(const Fortran::parser::SelectTypeConstruct &selectTypeConstruct) {4278 mlir::MLIRContext *context = builder->getContext();4279 Fortran::lower::StatementContext stmtCtx;4280 fir::ExtendedValue selector;4281 llvm::SmallVector<mlir::Attribute> attrList;4282 llvm::SmallVector<mlir::Block *> blockList;4283 unsigned typeGuardIdx = 0;4284 std::size_t defaultAttrPos = std::numeric_limits<size_t>::max();4285 bool hasLocalScope = false;4286 llvm::SmallVector<const Fortran::semantics::Scope *> typeCaseScopes;4287 4288 const auto selectorIsVolatile = [&selector]() {4289 return fir::isa_volatile_type(fir::getBase(selector).getType());4290 };4291 4292 const auto &typeCaseList =4293 std::get<std::list<Fortran::parser::SelectTypeConstruct::TypeCase>>(4294 selectTypeConstruct.t);4295 for (const auto &typeCase : typeCaseList) {4296 const auto &stmt =4297 std::get<Fortran::parser::Statement<Fortran::parser::TypeGuardStmt>>(4298 typeCase.t);4299 const Fortran::semantics::Scope &scope =4300 bridge.getSemanticsContext().FindScope(stmt.source);4301 typeCaseScopes.push_back(&scope);4302 }4303 4304 pushActiveConstruct(getEval(), stmtCtx);4305 llvm::SmallVector<Fortran::lower::pft::Evaluation *> exits, fallThroughs;4306 collectFinalEvaluations(getEval(), exits, fallThroughs);4307 Fortran::lower::pft::Evaluation &constructExit = *getEval().constructExit;4308 4309 for (Fortran::lower::pft::Evaluation &eval :4310 getEval().getNestedEvaluations()) {4311 setCurrentPosition(eval.position);4312 mlir::Location loc = toLocation();4313 if (auto *selectTypeStmt =4314 eval.getIf<Fortran::parser::SelectTypeStmt>()) {4315 // A genFIR(SelectTypeStmt) call would have unwanted side effects.4316 maybeStartBlock(eval.block);4317 // Retrieve the selector4318 const auto &s = std::get<Fortran::parser::Selector>(selectTypeStmt->t);4319 if (const auto *v = std::get_if<Fortran::parser::Variable>(&s.u))4320 selector = genExprBox(loc, *Fortran::semantics::GetExpr(*v), stmtCtx);4321 else if (const auto *e = std::get_if<Fortran::parser::Expr>(&s.u))4322 selector = genExprBox(loc, *Fortran::semantics::GetExpr(*e), stmtCtx);4323 4324 // Going through the controlSuccessor first to create the4325 // fir.select_type operation.4326 mlir::Block *defaultBlock = eval.parentConstruct->constructExit->block;4327 for (Fortran::lower::pft::Evaluation *e = eval.controlSuccessor; e;4328 e = e->controlSuccessor) {4329 const auto &typeGuardStmt =4330 e->getIf<Fortran::parser::TypeGuardStmt>();4331 const auto &guard =4332 std::get<Fortran::parser::TypeGuardStmt::Guard>(typeGuardStmt->t);4333 assert(e->block && "missing TypeGuardStmt block");4334 // CLASS DEFAULT4335 if (std::holds_alternative<Fortran::parser::Default>(guard.u)) {4336 defaultBlock = e->block;4337 // Keep track of the actual position of the CLASS DEFAULT type guard4338 // in the SELECT TYPE construct.4339 defaultAttrPos = attrList.size();4340 continue;4341 }4342 4343 blockList.push_back(e->block);4344 if (const auto *typeSpec =4345 std::get_if<Fortran::parser::TypeSpec>(&guard.u)) {4346 // TYPE IS4347 mlir::Type ty;4348 if (std::holds_alternative<Fortran::parser::IntrinsicTypeSpec>(4349 typeSpec->u)) {4350 const Fortran::semantics::IntrinsicTypeSpec *intrinsic =4351 typeSpec->declTypeSpec->AsIntrinsic();4352 int kind =4353 Fortran::evaluate::ToInt64(intrinsic->kind()).value_or(kind);4354 llvm::SmallVector<Fortran::lower::LenParameterTy> params;4355 ty = genType(intrinsic->category(), kind, params);4356 } else {4357 const Fortran::semantics::DerivedTypeSpec *derived =4358 typeSpec->declTypeSpec->AsDerived();4359 ty = genType(*derived);4360 }4361 attrList.push_back(fir::ExactTypeAttr::get(ty));4362 } else if (const auto *derived =4363 std::get_if<Fortran::parser::DerivedTypeSpec>(4364 &guard.u)) {4365 // CLASS IS4366 assert(derived->derivedTypeSpec && "derived type spec is null");4367 mlir::Type ty = genType(*(derived->derivedTypeSpec));4368 attrList.push_back(fir::SubclassAttr::get(ty));4369 }4370 }4371 attrList.push_back(mlir::UnitAttr::get(context));4372 blockList.push_back(defaultBlock);4373 fir::SelectTypeOp::create(*builder, loc, fir::getBase(selector),4374 attrList, blockList);4375 4376 // If the actual position of CLASS DEFAULT type guard is not the last4377 // one, it needs to be put back at its correct position for the rest of4378 // the processing. TypeGuardStmt are processed in the same order they4379 // appear in the Fortran code.4380 if (defaultAttrPos < attrList.size() - 1) {4381 auto attrIt = attrList.begin();4382 attrIt = attrIt + defaultAttrPos;4383 auto blockIt = blockList.begin();4384 blockIt = blockIt + defaultAttrPos;4385 attrList.insert(attrIt, mlir::UnitAttr::get(context));4386 blockList.insert(blockIt, defaultBlock);4387 attrList.pop_back();4388 blockList.pop_back();4389 }4390 } else if (auto *typeGuardStmt =4391 eval.getIf<Fortran::parser::TypeGuardStmt>()) {4392 // Map the type guard local symbol for the selector to a more precise4393 // typed entity in the TypeGuardStmt when necessary.4394 genFIR(eval);4395 const auto &guard =4396 std::get<Fortran::parser::TypeGuardStmt::Guard>(typeGuardStmt->t);4397 if (hasLocalScope)4398 localSymbols.popScope();4399 localSymbols.pushScope();4400 hasLocalScope = true;4401 assert(attrList.size() >= typeGuardIdx &&4402 "TypeGuard attribute missing");4403 mlir::Attribute typeGuardAttr = attrList[typeGuardIdx];4404 mlir::Block *typeGuardBlock = blockList[typeGuardIdx];4405 mlir::OpBuilder::InsertPoint crtInsPt = builder->saveInsertionPoint();4406 builder->setInsertionPointToStart(typeGuardBlock);4407 4408 auto addAssocEntitySymbol = [&](fir::ExtendedValue exv) {4409 for (auto &symbol : typeCaseScopes[typeGuardIdx]->GetSymbols()) {4410 if (symbol->GetUltimate()4411 .detailsIf<Fortran::semantics::AssocEntityDetails>()) {4412 addSymbol(symbol, exv);4413 break;4414 }4415 }4416 };4417 4418 mlir::Type baseTy = fir::getBase(selector).getType();4419 bool isPointer = fir::isPointerType(baseTy);4420 bool isAllocatable = fir::isAllocatableType(baseTy);4421 bool isArray =4422 mlir::isa<fir::SequenceType>(fir::dyn_cast_ptrOrBoxEleTy(baseTy));4423 const fir::BoxValue *selectorBox = selector.getBoxOf<fir::BoxValue>();4424 if (std::holds_alternative<Fortran::parser::Default>(guard.u)) {4425 // CLASS DEFAULT4426 addAssocEntitySymbol(selector);4427 } else if (const auto *typeSpec =4428 std::get_if<Fortran::parser::TypeSpec>(&guard.u)) {4429 // TYPE IS4430 fir::ExactTypeAttr attr =4431 mlir::dyn_cast<fir::ExactTypeAttr>(typeGuardAttr);4432 mlir::Value exactValue;4433 mlir::Type addrTy = attr.getType();4434 if (isArray) {4435 auto seqTy = mlir::dyn_cast<fir::SequenceType>(4436 fir::dyn_cast_ptrOrBoxEleTy(baseTy));4437 addrTy = fir::SequenceType::get(seqTy.getShape(), attr.getType());4438 }4439 if (isPointer)4440 addrTy = fir::PointerType::get(addrTy);4441 if (isAllocatable)4442 addrTy = fir::HeapType::get(addrTy);4443 if (std::holds_alternative<Fortran::parser::IntrinsicTypeSpec>(4444 typeSpec->u)) {4445 mlir::Type refTy =4446 fir::ReferenceType::get(addrTy, selectorIsVolatile());4447 if (isPointer || isAllocatable)4448 refTy = addrTy;4449 exactValue = fir::BoxAddrOp::create(*builder, loc, refTy,4450 fir::getBase(selector));4451 const Fortran::semantics::IntrinsicTypeSpec *intrinsic =4452 typeSpec->declTypeSpec->AsIntrinsic();4453 if (isArray) {4454 mlir::Value exact = fir::ConvertOp::create(4455 *builder, loc,4456 fir::BoxType::get(addrTy, selectorIsVolatile()),4457 fir::getBase(selector));4458 addAssocEntitySymbol(selectorBox->clone(exact));4459 } else if (intrinsic->category() ==4460 Fortran::common::TypeCategory::Character) {4461 auto charTy = mlir::dyn_cast<fir::CharacterType>(attr.getType());4462 mlir::Value charLen =4463 fir::factory::CharacterExprHelper(*builder, loc)4464 .readLengthFromBox(fir::getBase(selector), charTy);4465 addAssocEntitySymbol(fir::CharBoxValue(exactValue, charLen));4466 } else {4467 addAssocEntitySymbol(exactValue);4468 }4469 } else if (std::holds_alternative<Fortran::parser::DerivedTypeSpec>(4470 typeSpec->u)) {4471 exactValue = fir::ConvertOp::create(4472 *builder, loc, fir::BoxType::get(addrTy, selectorIsVolatile()),4473 fir::getBase(selector));4474 addAssocEntitySymbol(selectorBox->clone(exactValue));4475 }4476 } else if (std::holds_alternative<Fortran::parser::DerivedTypeSpec>(4477 guard.u)) {4478 // CLASS IS4479 fir::SubclassAttr attr =4480 mlir::dyn_cast<fir::SubclassAttr>(typeGuardAttr);4481 mlir::Type addrTy = attr.getType();4482 if (isArray) {4483 auto seqTy = mlir::dyn_cast<fir::SequenceType>(4484 fir::dyn_cast_ptrOrBoxEleTy(baseTy));4485 addrTy = fir::SequenceType::get(seqTy.getShape(), attr.getType());4486 }4487 if (isPointer)4488 addrTy = fir::PointerType::get(addrTy);4489 if (isAllocatable)4490 addrTy = fir::HeapType::get(addrTy);4491 mlir::Type classTy =4492 fir::ClassType::get(addrTy, selectorIsVolatile());4493 if (classTy == baseTy) {4494 addAssocEntitySymbol(selector);4495 } else {4496 mlir::Value derived = fir::ConvertOp::create(4497 *builder, loc, classTy, fir::getBase(selector));4498 addAssocEntitySymbol(selectorBox->clone(derived));4499 }4500 }4501 builder->restoreInsertionPoint(crtInsPt);4502 ++typeGuardIdx;4503 } else if (eval.getIf<Fortran::parser::EndSelectStmt>()) {4504 maybeStartBlock(eval.block);4505 if (hasLocalScope)4506 localSymbols.popScope();4507 } else {4508 genFIR(eval);4509 }4510 if (blockIsUnterminated()) {4511 if (llvm::is_contained(exits, &eval))4512 genConstructExitBranch(constructExit);4513 else if (llvm::is_contained(fallThroughs, &eval))4514 genBranch(eval.lexicalSuccessor->block);4515 }4516 }4517 popActiveConstruct();4518 }4519 4520 //===--------------------------------------------------------------------===//4521 // IO statements (see io.h)4522 //===--------------------------------------------------------------------===//4523 4524 void genFIR(const Fortran::parser::BackspaceStmt &stmt) {4525 mlir::Value iostat = genBackspaceStatement(*this, stmt);4526 genIoConditionBranches(getEval(), stmt.v, iostat);4527 }4528 void genFIR(const Fortran::parser::CloseStmt &stmt) {4529 mlir::Value iostat = genCloseStatement(*this, stmt);4530 genIoConditionBranches(getEval(), stmt.v, iostat);4531 }4532 void genFIR(const Fortran::parser::EndfileStmt &stmt) {4533 mlir::Value iostat = genEndfileStatement(*this, stmt);4534 genIoConditionBranches(getEval(), stmt.v, iostat);4535 }4536 void genFIR(const Fortran::parser::FlushStmt &stmt) {4537 mlir::Value iostat = genFlushStatement(*this, stmt);4538 genIoConditionBranches(getEval(), stmt.v, iostat);4539 }4540 void genFIR(const Fortran::parser::InquireStmt &stmt) {4541 mlir::Value iostat = genInquireStatement(*this, stmt);4542 if (const auto *specs =4543 std::get_if<std::list<Fortran::parser::InquireSpec>>(&stmt.u))4544 genIoConditionBranches(getEval(), *specs, iostat);4545 }4546 void genFIR(const Fortran::parser::OpenStmt &stmt) {4547 mlir::Value iostat = genOpenStatement(*this, stmt);4548 genIoConditionBranches(getEval(), stmt.v, iostat);4549 }4550 void genFIR(const Fortran::parser::PrintStmt &stmt) {4551 genPrintStatement(*this, stmt);4552 }4553 void genFIR(const Fortran::parser::ReadStmt &stmt) {4554 mlir::Value iostat = genReadStatement(*this, stmt);4555 genIoConditionBranches(getEval(), stmt.controls, iostat);4556 }4557 void genFIR(const Fortran::parser::RewindStmt &stmt) {4558 mlir::Value iostat = genRewindStatement(*this, stmt);4559 genIoConditionBranches(getEval(), stmt.v, iostat);4560 }4561 void genFIR(const Fortran::parser::WaitStmt &stmt) {4562 mlir::Value iostat = genWaitStatement(*this, stmt);4563 genIoConditionBranches(getEval(), stmt.v, iostat);4564 }4565 void genFIR(const Fortran::parser::WriteStmt &stmt) {4566 mlir::Value iostat = genWriteStatement(*this, stmt);4567 genIoConditionBranches(getEval(), stmt.controls, iostat);4568 }4569 4570 template <typename A>4571 void genIoConditionBranches(Fortran::lower::pft::Evaluation &eval,4572 const A &specList, mlir::Value iostat) {4573 if (!iostat)4574 return;4575 4576 Fortran::parser::Label endLabel{};4577 Fortran::parser::Label eorLabel{};4578 Fortran::parser::Label errLabel{};4579 bool hasIostat{};4580 for (const auto &spec : specList) {4581 Fortran::common::visit(4582 Fortran::common::visitors{4583 [&](const Fortran::parser::EndLabel &label) {4584 endLabel = label.v;4585 },4586 [&](const Fortran::parser::EorLabel &label) {4587 eorLabel = label.v;4588 },4589 [&](const Fortran::parser::ErrLabel &label) {4590 errLabel = label.v;4591 },4592 [&](const Fortran::parser::StatVariable &) { hasIostat = true; },4593 [](const auto &) {}},4594 spec.u);4595 }4596 if (!endLabel && !eorLabel && !errLabel)4597 return;4598 4599 // An ERR specifier branch is taken on any positive error value rather than4600 // some single specific value. If ERR and IOSTAT specifiers are given and4601 // END and EOR specifiers are allowed, the latter two specifiers must have4602 // explicit branch targets to allow the ERR branch to be implemented as a4603 // default/else target. A label=0 target for an absent END or EOR specifier4604 // indicates that these specifiers have a fallthrough target. END and EOR4605 // specifiers may appear on READ and WAIT statements.4606 bool allSpecifiersRequired = errLabel && hasIostat &&4607 (eval.isA<Fortran::parser::ReadStmt>() ||4608 eval.isA<Fortran::parser::WaitStmt>());4609 mlir::Value selector =4610 builder->createConvert(toLocation(), builder->getIndexType(), iostat);4611 llvm::SmallVector<int64_t> valueList;4612 llvm::SmallVector<Fortran::parser::Label> labelList;4613 if (eorLabel || allSpecifiersRequired) {4614 valueList.push_back(Fortran::runtime::io::IostatEor);4615 labelList.push_back(eorLabel ? eorLabel : 0);4616 }4617 if (endLabel || allSpecifiersRequired) {4618 valueList.push_back(Fortran::runtime::io::IostatEnd);4619 labelList.push_back(endLabel ? endLabel : 0);4620 }4621 if (errLabel) {4622 // Must be last. Value 0 is interpreted as any positive value, or4623 // equivalently as any value other than 0, IostatEor, or IostatEnd.4624 valueList.push_back(0);4625 labelList.push_back(errLabel);4626 }4627 genMultiwayBranch(selector, valueList, labelList, eval.nonNopSuccessor());4628 }4629 4630 //===--------------------------------------------------------------------===//4631 // Memory allocation and deallocation4632 //===--------------------------------------------------------------------===//4633 4634 void genFIR(const Fortran::parser::AllocateStmt &stmt) {4635 Fortran::lower::genAllocateStmt(*this, stmt, toLocation());4636 }4637 4638 void genFIR(const Fortran::parser::DeallocateStmt &stmt) {4639 Fortran::lower::genDeallocateStmt(*this, stmt, toLocation());4640 }4641 4642 /// Nullify pointer object list4643 ///4644 /// For each pointer object, reset the pointer to a disassociated status.4645 /// We do this by setting each pointer to null.4646 void genFIR(const Fortran::parser::NullifyStmt &stmt) {4647 mlir::Location loc = toLocation();4648 for (auto &pointerObject : stmt.v) {4649 const Fortran::lower::SomeExpr *expr =4650 Fortran::semantics::GetExpr(pointerObject);4651 assert(expr);4652 if (Fortran::evaluate::IsProcedurePointer(*expr)) {4653 Fortran::lower::StatementContext stmtCtx;4654 hlfir::Entity pptr = Fortran::lower::convertExprToHLFIR(4655 loc, *this, *expr, localSymbols, stmtCtx);4656 auto boxTy{4657 Fortran::lower::getUntypedBoxProcType(builder->getContext())};4658 hlfir::Entity nullBoxProc(4659 fir::factory::createNullBoxProc(*builder, loc, boxTy));4660 builder->createStoreWithConvert(loc, nullBoxProc, pptr);4661 } else {4662 fir::MutableBoxValue box = genExprMutableBox(loc, *expr);4663 fir::factory::disassociateMutableBox(*builder, loc, box);4664 cuf::genPointerSync(box.getAddr(), *builder);4665 }4666 }4667 }4668 4669 //===--------------------------------------------------------------------===//4670 4671 void genFIR(const Fortran::parser::NotifyWaitStmt &stmt) {4672 genNotifyWaitStatement(*this, stmt);4673 }4674 4675 void genFIR(const Fortran::parser::EventPostStmt &stmt) {4676 genEventPostStatement(*this, stmt);4677 }4678 4679 void genFIR(const Fortran::parser::EventWaitStmt &stmt) {4680 genEventWaitStatement(*this, stmt);4681 }4682 4683 void genFIR(const Fortran::parser::FormTeamStmt &stmt) {4684 genFormTeamStatement(*this, getEval(), stmt);4685 }4686 4687 void genFIR(const Fortran::parser::LockStmt &stmt) {4688 genLockStatement(*this, stmt);4689 }4690 4691 fir::ExtendedValue4692 genInitializerExprValue(const Fortran::lower::SomeExpr &expr,4693 Fortran::lower::StatementContext &stmtCtx) {4694 return Fortran::lower::createSomeInitializerExpression(4695 toLocation(), *this, expr, localSymbols, stmtCtx);4696 }4697 4698 /// Return true if the current context is a conditionalized and implied4699 /// iteration space.4700 bool implicitIterationSpace() { return !implicitIterSpace.empty(); }4701 4702 /// Return true if context is currently an explicit iteration space. A scalar4703 /// assignment expression may be contextually within a user-defined iteration4704 /// space, transforming it into an array expression.4705 bool explicitIterationSpace() { return explicitIterSpace.isActive(); }4706 4707 /// Generate an array assignment.4708 /// This is an assignment expression with rank > 0. The assignment may or may4709 /// not be in a WHERE and/or FORALL context.4710 /// In a FORALL context, the assignment may be a pointer assignment and the \p4711 /// lbounds and \p ubounds parameters should only be used in such a pointer4712 /// assignment case. (If both are None then the array assignment cannot be a4713 /// pointer assignment.)4714 void genArrayAssignment(4715 const Fortran::evaluate::Assignment &assign,4716 Fortran::lower::StatementContext &localStmtCtx,4717 std::optional<llvm::SmallVector<mlir::Value>> lbounds = std::nullopt,4718 std::optional<llvm::SmallVector<mlir::Value>> ubounds = std::nullopt) {4719 4720 Fortran::lower::StatementContext &stmtCtx =4721 explicitIterationSpace()4722 ? explicitIterSpace.stmtContext()4723 : (implicitIterationSpace() ? implicitIterSpace.stmtContext()4724 : localStmtCtx);4725 if (Fortran::lower::isWholeAllocatable(assign.lhs)) {4726 // Assignment to allocatables may require the lhs to be4727 // deallocated/reallocated. See Fortran 2018 10.2.1.3 p34728 Fortran::lower::createAllocatableArrayAssignment(4729 *this, assign.lhs, assign.rhs, explicitIterSpace, implicitIterSpace,4730 localSymbols, stmtCtx);4731 return;4732 }4733 4734 if (lbounds) {4735 // Array of POINTER entities, with elemental assignment.4736 if (!Fortran::lower::isWholePointer(assign.lhs))4737 fir::emitFatalError(toLocation(), "pointer assignment to non-pointer");4738 4739 Fortran::lower::createArrayOfPointerAssignment(4740 *this, assign.lhs, assign.rhs, explicitIterSpace, implicitIterSpace,4741 *lbounds, ubounds, localSymbols, stmtCtx);4742 return;4743 }4744 4745 if (!implicitIterationSpace() && !explicitIterationSpace()) {4746 // No masks and the iteration space is implied by the array, so create a4747 // simple array assignment.4748 Fortran::lower::createSomeArrayAssignment(*this, assign.lhs, assign.rhs,4749 localSymbols, stmtCtx);4750 return;4751 }4752 4753 // If there is an explicit iteration space, generate an array assignment4754 // with a user-specified iteration space and possibly with masks. These4755 // assignments may *appear* to be scalar expressions, but the scalar4756 // expression is evaluated at all points in the user-defined space much like4757 // an ordinary array assignment. More specifically, the semantics inside the4758 // FORALL much more closely resembles that of WHERE than a scalar4759 // assignment.4760 // Otherwise, generate a masked array assignment. The iteration space is4761 // implied by the lhs array expression.4762 Fortran::lower::createAnyMaskedArrayAssignment(4763 *this, assign.lhs, assign.rhs, explicitIterSpace, implicitIterSpace,4764 localSymbols, stmtCtx);4765 }4766 4767#if !defined(NDEBUG)4768 static bool isFuncResultDesignator(const Fortran::lower::SomeExpr &expr) {4769 const Fortran::semantics::Symbol *sym =4770 Fortran::evaluate::GetFirstSymbol(expr);4771 return sym && sym->IsFuncResult();4772 }4773#endif4774 4775 inline fir::MutableBoxValue4776 genExprMutableBox(mlir::Location loc,4777 const Fortran::lower::SomeExpr &expr) override final {4778 if (lowerToHighLevelFIR())4779 return Fortran::lower::convertExprToMutableBox(loc, *this, expr,4780 localSymbols);4781 return Fortran::lower::createMutableBox(loc, *this, expr, localSymbols);4782 }4783 4784 // Create the [newRank] array with the lower bounds to be passed to the4785 // runtime as a descriptor.4786 mlir::Value createLboundArray(llvm::ArrayRef<mlir::Value> lbounds,4787 mlir::Location loc) {4788 mlir::Type indexTy = builder->getIndexType();4789 mlir::Type boundArrayTy = fir::SequenceType::get(4790 {static_cast<int64_t>(lbounds.size())}, builder->getI64Type());4791 mlir::Value boundArray = fir::AllocaOp::create(*builder, loc, boundArrayTy);4792 mlir::Value array = fir::UndefOp::create(*builder, loc, boundArrayTy);4793 for (unsigned i = 0; i < lbounds.size(); ++i) {4794 array = fir::InsertValueOp::create(4795 *builder, loc, boundArrayTy, array, lbounds[i],4796 builder->getArrayAttr({builder->getIntegerAttr(4797 builder->getIndexType(), static_cast<int>(i))}));4798 }4799 fir::StoreOp::create(*builder, loc, array, boundArray);4800 mlir::Type boxTy = fir::BoxType::get(boundArrayTy);4801 mlir::Value ext =4802 builder->createIntegerConstant(loc, indexTy, lbounds.size());4803 llvm::SmallVector<mlir::Value> shapes = {ext};4804 mlir::Value shapeOp = builder->genShape(loc, shapes);4805 return fir::EmboxOp::create(*builder, loc, boxTy, boundArray, shapeOp);4806 }4807 4808 // Generate pointer assignment with possibly empty bounds-spec. R1035: a4809 // bounds-spec is a lower bound value.4810 void genNoHLFIRPointerAssignment(4811 mlir::Location loc, const Fortran::evaluate::Assignment &assign,4812 const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {4813 Fortran::lower::StatementContext stmtCtx;4814 4815 assert(!lowerToHighLevelFIR() && "code should not be called with HFLIR");4816 if (Fortran::evaluate::IsProcedureDesignator(assign.rhs))4817 TODO(loc, "procedure pointer assignment");4818 4819 std::optional<Fortran::evaluate::DynamicType> lhsType =4820 assign.lhs.GetType();4821 // Delegate pointer association to unlimited polymorphic pointer4822 // to the runtime. element size, type code, attribute and of4823 // course base_addr might need to be updated.4824 if (lhsType && lhsType->IsPolymorphic()) {4825 if (explicitIterationSpace())4826 TODO(loc, "polymorphic pointer assignment in FORALL");4827 llvm::SmallVector<mlir::Value> lbounds;4828 for (const Fortran::evaluate::ExtentExpr &lbExpr : lbExprs)4829 lbounds.push_back(4830 fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx)));4831 fir::MutableBoxValue lhsMutableBox = genExprMutableBox(loc, assign.lhs);4832 if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(4833 assign.rhs)) {4834 fir::factory::disassociateMutableBox(*builder, loc, lhsMutableBox);4835 return;4836 }4837 mlir::Value lhs = lhsMutableBox.getAddr();4838 mlir::Value rhs = fir::getBase(genExprBox(loc, assign.rhs, stmtCtx));4839 if (!lbounds.empty()) {4840 mlir::Value boundsDesc = createLboundArray(lbounds, loc);4841 Fortran::lower::genPointerAssociateLowerBounds(*builder, loc, lhs, rhs,4842 boundsDesc);4843 return;4844 }4845 Fortran::lower::genPointerAssociate(*builder, loc, lhs, rhs);4846 return;4847 }4848 4849 llvm::SmallVector<mlir::Value> lbounds;4850 for (const Fortran::evaluate::ExtentExpr &lbExpr : lbExprs)4851 lbounds.push_back(fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx)));4852 if (explicitIterationSpace()) {4853 // Pointer assignment in FORALL context. Copy the rhs box value4854 // into the lhs box variable.4855 genArrayAssignment(assign, stmtCtx, lbounds);4856 return;4857 }4858 fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs);4859 Fortran::lower::associateMutableBox(*this, loc, lhs, assign.rhs, lbounds,4860 stmtCtx);4861 }4862 4863 void genPointerAssignment(mlir::Location loc,4864 const Fortran::evaluate::Assignment &assign) {4865 if (isInsideHlfirForallOrWhere()) {4866 // Generate Pointer assignment as hlfir.region_assign.4867 genForallPointerAssignment(loc, assign);4868 return;4869 }4870 Fortran::lower::StatementContext stmtCtx;4871 hlfir::Entity lhs = Fortran::lower::convertExprToHLFIR(4872 loc, *this, assign.lhs, localSymbols, stmtCtx);4873 mlir::Value rhs = genPointerAssignmentRhs(loc, lhs, assign, stmtCtx);4874 builder->createStoreWithConvert(loc, rhs, lhs);4875 cuf::genPointerSync(lhs, *builder);4876 }4877 4878 void genForallPointerAssignment(mlir::Location loc,4879 const Fortran::evaluate::Assignment &assign) {4880 // Lower pointer assignment inside forall with hlfir.region_assign with4881 // descriptor address/value and later implemented with a store.4882 // The RHS is fully prepared in lowering, so that all that is left4883 // in hlfir.region_assign code generation is the store.4884 auto regionAssignOp = hlfir::RegionAssignOp::create(*builder, loc);4885 4886 // Lower LHS in its own region.4887 builder->createBlock(®ionAssignOp.getLhsRegion());4888 Fortran::lower::StatementContext lhsContext;4889 hlfir::Entity lhs = Fortran::lower::convertExprToHLFIR(4890 loc, *this, assign.lhs, localSymbols, lhsContext);4891 auto lhsYieldOp = hlfir::YieldOp::create(*builder, loc, lhs);4892 Fortran::lower::genCleanUpInRegionIfAny(4893 loc, *builder, lhsYieldOp.getCleanup(), lhsContext);4894 4895 // Lower RHS in its own region.4896 builder->createBlock(®ionAssignOp.getRhsRegion());4897 Fortran::lower::StatementContext rhsContext;4898 mlir::Value rhs = genPointerAssignmentRhs(loc, lhs, assign, rhsContext);4899 auto rhsYieldOp = hlfir::YieldOp::create(*builder, loc, rhs);4900 Fortran::lower::genCleanUpInRegionIfAny(4901 loc, *builder, rhsYieldOp.getCleanup(), rhsContext);4902 4903 builder->setInsertionPointAfter(regionAssignOp);4904 }4905 4906 mlir::Value lowerToIndexValue(mlir::Location loc,4907 const Fortran::evaluate::ExtentExpr &expr,4908 Fortran::lower::StatementContext &stmtCtx) {4909 mlir::Value val = fir::getBase(genExprValue(toEvExpr(expr), stmtCtx));4910 return builder->createConvert(loc, builder->getIndexType(), val);4911 }4912 4913 mlir::Value4914 genPointerAssignmentRhs(mlir::Location loc, hlfir::Entity lhs,4915 const Fortran::evaluate::Assignment &assign,4916 Fortran::lower::StatementContext &rhsContext) {4917 if (Fortran::evaluate::IsProcedureDesignator(assign.lhs)) {4918 if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(4919 assign.rhs))4920 return fir::factory::createNullBoxProc(4921 *builder, loc, fir::unwrapRefType(lhs.getType()));4922 return fir::getBase(Fortran::lower::convertExprToAddress(4923 loc, *this, assign.rhs, localSymbols, rhsContext));4924 }4925 // Data target.4926 auto lhsBoxType =4927 llvm::cast<fir::BaseBoxType>(fir::unwrapRefType(lhs.getType()));4928 // For NULL, create disassociated descriptor whose dynamic type is the4929 // static type of the LHS (fulfills 7.3.2.3 requirements that the dynamic4930 // type of a deallocated polymorphic pointer is its static type).4931 if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(4932 assign.rhs)) {4933 llvm::SmallVector<mlir::Value, 1> nonDeferredLenParams;4934 if (auto lhsVar =4935 llvm::dyn_cast_if_present<fir::FortranVariableOpInterface>(4936 lhs.getDefiningOp()))4937 nonDeferredLenParams = lhsVar.getExplicitTypeParams();4938 if (isInsideHlfirForallOrWhere()) {4939 // Inside FORALL, the non deferred type parameters may only be4940 // accessible in the hlfir.region_assign lhs region if they were4941 // computed there.4942 for (mlir::Value ¶m : nonDeferredLenParams)4943 if (!param.getParentRegion()->isAncestor(4944 builder->getBlock()->getParent())) {4945 if (llvm::isa_and_nonnull<mlir::arith::ConstantOp>(4946 param.getDefiningOp()))4947 param = builder->clone(*param.getDefiningOp())->getResult(0);4948 else4949 TODO(loc, "Pointer assignment with non deferred type parameter "4950 "inside FORALL");4951 }4952 }4953 return fir::factory::createUnallocatedBox(*builder, loc, lhsBoxType,4954 nonDeferredLenParams);4955 }4956 hlfir::Entity rhs = Fortran::lower::convertExprToHLFIR(4957 loc, *this, assign.rhs, localSymbols, rhsContext);4958 auto rhsBoxType = rhs.getBoxType();4959 // Create pointer descriptor value from the RHS.4960 if (rhs.isMutableBox())4961 rhs = hlfir::Entity{fir::LoadOp::create(*builder, loc, rhs)};4962 4963 // Use LHS type if LHS is not polymorphic.4964 fir::BaseBoxType targetBoxType;4965 if (assign.lhs.GetType()->IsPolymorphic())4966 targetBoxType = rhsBoxType.getBoxTypeWithNewAttr(4967 fir::BaseBoxType::Attribute::Pointer);4968 else4969 targetBoxType = lhsBoxType.getBoxTypeWithNewShape(rhs.getRank());4970 mlir::Value rhsBox =4971 hlfir::genVariableBox(loc, *builder, rhs, targetBoxType);4972 4973 // Apply lower bounds or reshaping if any.4974 if (const auto *lbExprs =4975 std::get_if<Fortran::evaluate::Assignment::BoundsSpec>(&assign.u);4976 lbExprs && !lbExprs->empty()) {4977 // Override target lower bounds with the LHS bounds spec.4978 llvm::SmallVector<mlir::Value> lbounds;4979 for (const Fortran::evaluate::ExtentExpr &lbExpr : *lbExprs)4980 lbounds.push_back(lowerToIndexValue(loc, lbExpr, rhsContext));4981 mlir::Value shift = builder->genShift(loc, lbounds);4982 rhsBox = fir::ReboxOp::create(*builder, loc, lhsBoxType, rhsBox, shift,4983 /*slice=*/mlir::Value{});4984 } else if (const auto *boundExprs =4985 std::get_if<Fortran::evaluate::Assignment::BoundsRemapping>(4986 &assign.u);4987 boundExprs && !boundExprs->empty()) {4988 // Reshape the target according to the LHS bounds remapping.4989 llvm::SmallVector<mlir::Value> lbounds;4990 llvm::SmallVector<mlir::Value> extents;4991 mlir::Type indexTy = builder->getIndexType();4992 mlir::Value zero = builder->createIntegerConstant(loc, indexTy, 0);4993 mlir::Value one = builder->createIntegerConstant(loc, indexTy, 1);4994 for (const auto &[lbExpr, ubExpr] : *boundExprs) {4995 lbounds.push_back(lowerToIndexValue(loc, lbExpr, rhsContext));4996 mlir::Value ub = lowerToIndexValue(loc, ubExpr, rhsContext);4997 extents.push_back(fir::factory::computeExtent(4998 *builder, loc, lbounds.back(), ub, zero, one));4999 }5000 mlir::Value shape = builder->genShape(loc, lbounds, extents);5001 rhsBox = fir::ReboxOp::create(*builder, loc, lhsBoxType, rhsBox, shape,5002 /*slice=*/mlir::Value{});5003 } else if (fir::isClassStarType(lhsBoxType) &&5004 !fir::ConvertOp::canBeConverted(rhsBoxType, lhsBoxType)) {5005 rhsBox = fir::ReboxOp::create(*builder, loc, lhsBoxType, rhsBox,5006 mlir::Value{}, mlir::Value{});5007 }5008 return rhsBox;5009 }5010 5011 // Create the 2 x newRank array with the bounds to be passed to the runtime as5012 // a descriptor.5013 mlir::Value createBoundArray(llvm::ArrayRef<mlir::Value> lbounds,5014 llvm::ArrayRef<mlir::Value> ubounds,5015 mlir::Location loc) {5016 assert(lbounds.size() && ubounds.size());5017 mlir::Type indexTy = builder->getIndexType();5018 mlir::Type boundArrayTy = fir::SequenceType::get(5019 {2, static_cast<int64_t>(lbounds.size())}, builder->getI64Type());5020 mlir::Value boundArray = fir::AllocaOp::create(*builder, loc, boundArrayTy);5021 mlir::Value array = fir::UndefOp::create(*builder, loc, boundArrayTy);5022 for (unsigned i = 0; i < lbounds.size(); ++i) {5023 array = fir::InsertValueOp::create(5024 *builder, loc, boundArrayTy, array, lbounds[i],5025 builder->getArrayAttr(5026 {builder->getIntegerAttr(builder->getIndexType(), 0),5027 builder->getIntegerAttr(builder->getIndexType(),5028 static_cast<int>(i))}));5029 array = fir::InsertValueOp::create(5030 *builder, loc, boundArrayTy, array, ubounds[i],5031 builder->getArrayAttr(5032 {builder->getIntegerAttr(builder->getIndexType(), 1),5033 builder->getIntegerAttr(builder->getIndexType(),5034 static_cast<int>(i))}));5035 }5036 fir::StoreOp::create(*builder, loc, array, boundArray);5037 mlir::Type boxTy = fir::BoxType::get(boundArrayTy);5038 mlir::Value ext =5039 builder->createIntegerConstant(loc, indexTy, lbounds.size());5040 mlir::Value c2 = builder->createIntegerConstant(loc, indexTy, 2);5041 llvm::SmallVector<mlir::Value> shapes = {c2, ext};5042 mlir::Value shapeOp = builder->genShape(loc, shapes);5043 return fir::EmboxOp::create(*builder, loc, boxTy, boundArray, shapeOp);5044 }5045 5046 // Pointer assignment with bounds-remapping. R1036: a bounds-remapping is a5047 // pair, lower bound and upper bound.5048 void genNoHLFIRPointerAssignment(5049 mlir::Location loc, const Fortran::evaluate::Assignment &assign,5050 const Fortran::evaluate::Assignment::BoundsRemapping &boundExprs) {5051 assert(!lowerToHighLevelFIR() && "code should not be called with HFLIR");5052 Fortran::lower::StatementContext stmtCtx;5053 llvm::SmallVector<mlir::Value> lbounds;5054 llvm::SmallVector<mlir::Value> ubounds;5055 for (const std::pair<Fortran::evaluate::ExtentExpr,5056 Fortran::evaluate::ExtentExpr> &pair : boundExprs) {5057 const Fortran::evaluate::ExtentExpr &lbExpr = pair.first;5058 const Fortran::evaluate::ExtentExpr &ubExpr = pair.second;5059 lbounds.push_back(fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx)));5060 ubounds.push_back(fir::getBase(genExprValue(toEvExpr(ubExpr), stmtCtx)));5061 }5062 5063 std::optional<Fortran::evaluate::DynamicType> lhsType =5064 assign.lhs.GetType();5065 std::optional<Fortran::evaluate::DynamicType> rhsType =5066 assign.rhs.GetType();5067 // Polymorphic lhs/rhs need more care. See F2018 10.2.2.3.5068 if ((lhsType && lhsType->IsPolymorphic()) ||5069 (rhsType && rhsType->IsPolymorphic())) {5070 if (explicitIterationSpace())5071 TODO(loc, "polymorphic pointer assignment in FORALL");5072 5073 fir::MutableBoxValue lhsMutableBox = genExprMutableBox(loc, assign.lhs);5074 if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(5075 assign.rhs)) {5076 fir::factory::disassociateMutableBox(*builder, loc, lhsMutableBox);5077 return;5078 }5079 mlir::Value lhs = lhsMutableBox.getAddr();5080 mlir::Value rhs = fir::getBase(genExprBox(loc, assign.rhs, stmtCtx));5081 mlir::Value boundsDesc = createBoundArray(lbounds, ubounds, loc);5082 Fortran::lower::genPointerAssociateRemapping(5083 *builder, loc, lhs, rhs, boundsDesc,5084 lhsType && rhsType && !lhsType->IsPolymorphic() &&5085 rhsType->IsPolymorphic());5086 return;5087 }5088 if (explicitIterationSpace()) {5089 // Pointer assignment in FORALL context. Copy the rhs box value5090 // into the lhs box variable.5091 genArrayAssignment(assign, stmtCtx, lbounds, ubounds);5092 return;5093 }5094 fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs);5095 if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(5096 assign.rhs)) {5097 fir::factory::disassociateMutableBox(*builder, loc, lhs);5098 return;5099 }5100 // Do not generate a temp in case rhs is an array section.5101 fir::ExtendedValue rhs =5102 Fortran::lower::isArraySectionWithoutVectorSubscript(assign.rhs)5103 ? Fortran::lower::createSomeArrayBox(*this, assign.rhs,5104 localSymbols, stmtCtx)5105 : genExprAddr(assign.rhs, stmtCtx);5106 fir::factory::associateMutableBoxWithRemap(*builder, loc, lhs, rhs, lbounds,5107 ubounds);5108 if (explicitIterationSpace()) {5109 mlir::ValueRange inners = explicitIterSpace.getInnerArgs();5110 if (!inners.empty())5111 fir::ResultOp::create(*builder, loc, inners);5112 }5113 }5114 5115 /// Given converted LHS and RHS of the assignment, materialize any5116 /// implicit conversion of the RHS to the LHS type. The front-end5117 /// usually already makes those explicit, except for non-standard5118 /// LOGICAL <-> INTEGER, or if the LHS is a whole allocatable5119 /// (making the conversion explicit in the front-end would prevent5120 /// propagation of the LHS lower bound in the reallocation).5121 /// If array temporaries or values are created, the cleanups are5122 /// added in the statement context.5123 hlfir::Entity genImplicitConvert(const Fortran::evaluate::Assignment &assign,5124 hlfir::Entity rhs, bool preserveLowerBounds,5125 Fortran::lower::StatementContext &stmtCtx) {5126 mlir::Location loc = toLocation();5127 auto &builder = getFirOpBuilder();5128 mlir::Type toType = genType(assign.lhs);5129 auto valueAndPair = hlfir::genTypeAndKindConvert(loc, builder, rhs, toType,5130 preserveLowerBounds);5131 if (valueAndPair.second)5132 stmtCtx.attachCleanup(*valueAndPair.second);5133 return hlfir::Entity{valueAndPair.first};5134 }5135 5136 bool firstDummyIsPointerOrAllocatable(5137 const Fortran::evaluate::ProcedureRef &userDefinedAssignment) {5138 using DummyAttr = Fortran::evaluate::characteristics::DummyDataObject::Attr;5139 if (auto procedure =5140 Fortran::evaluate::characteristics::Procedure::Characterize(5141 userDefinedAssignment.proc(), getFoldingContext(),5142 /*emitError=*/false))5143 if (!procedure->dummyArguments.empty())5144 if (const auto *dataArg = std::get_if<5145 Fortran::evaluate::characteristics::DummyDataObject>(5146 &procedure->dummyArguments[0].u))5147 return dataArg->attrs.test(DummyAttr::Pointer) ||5148 dataArg->attrs.test(DummyAttr::Allocatable);5149 return false;5150 }5151 5152 void genCUDADataTransfer(fir::FirOpBuilder &builder, mlir::Location loc,5153 const Fortran::evaluate::Assignment &assign,5154 hlfir::Entity &lhs, hlfir::Entity &rhs,5155 bool isWholeAllocatableAssignment,5156 bool keepLhsLengthInAllocatableAssignment) {5157 bool lhsIsDevice = Fortran::evaluate::HasCUDADeviceAttrs(assign.lhs);5158 bool rhsIsDevice = Fortran::evaluate::HasCUDADeviceAttrs(assign.rhs);5159 5160 auto getRefFromValue = [](mlir::Value val) -> mlir::Value {5161 if (auto loadOp =5162 mlir::dyn_cast_or_null<fir::LoadOp>(val.getDefiningOp()))5163 return loadOp.getMemref();5164 if (!mlir::isa<fir::BaseBoxType>(val.getType()))5165 return val;5166 if (auto declOp =5167 mlir::dyn_cast_or_null<hlfir::DeclareOp>(val.getDefiningOp())) {5168 if (!declOp.getShape())5169 return val;5170 if (mlir::isa<fir::ReferenceType>(declOp.getMemref().getType()))5171 return declOp.getResults()[1];5172 }5173 return val;5174 };5175 5176 auto getShapeFromDecl = [](mlir::Value val) -> mlir::Value {5177 if (!mlir::isa<fir::BaseBoxType>(val.getType()))5178 return {};5179 if (auto declOp =5180 mlir::dyn_cast_or_null<hlfir::DeclareOp>(val.getDefiningOp()))5181 return declOp.getShape();5182 return {};5183 };5184 5185 mlir::Value rhsVal = getRefFromValue(rhs.getBase());5186 mlir::Value lhsVal = getRefFromValue(lhs.getBase());5187 // Get shape from the rhs if available otherwise get it from lhs.5188 mlir::Value shape = getShapeFromDecl(rhs.getBase());5189 if (!shape)5190 shape = getShapeFromDecl(lhs.getBase());5191 5192 // device = host5193 if (lhsIsDevice && !rhsIsDevice) {5194 auto transferKindAttr = cuf::DataTransferKindAttr::get(5195 builder.getContext(), cuf::DataTransferKind::HostDevice);5196 if (!rhs.isVariable()) {5197 mlir::Value base = rhs;5198 if (auto convertOp =5199 mlir::dyn_cast<fir::ConvertOp>(rhs.getDefiningOp()))5200 base = convertOp.getValue();5201 // Special case if the rhs is a constant.5202 if (matchPattern(base.getDefiningOp(), mlir::m_Constant())) {5203 cuf::DataTransferOp::create(builder, loc, base, lhsVal, shape,5204 transferKindAttr);5205 } else {5206 auto associate = hlfir::genAssociateExpr(5207 loc, builder, rhs, rhs.getType(), ".cuf_host_tmp");5208 cuf::DataTransferOp::create(builder, loc, associate.getBase(), lhsVal,5209 shape, transferKindAttr);5210 hlfir::EndAssociateOp::create(builder, loc, associate);5211 }5212 } else {5213 cuf::DataTransferOp::create(builder, loc, rhsVal, lhsVal, shape,5214 transferKindAttr);5215 }5216 return;5217 }5218 5219 // host = device5220 if (!lhsIsDevice && rhsIsDevice) {5221 if (auto elementalOp = Fortran::lower::isTransferWithConversion(rhs)) {5222 mlir::OpBuilder::InsertionGuard insertionGuard(builder);5223 auto designateOp =5224 *elementalOp.getBody()->getOps<hlfir::DesignateOp>().begin();5225 builder.setInsertionPoint(elementalOp);5226 // Create a temp to transfer the rhs before applying the conversion.5227 hlfir::Entity entity{designateOp.getMemref()};5228 auto [temp, cleanup] = hlfir::createTempFromMold(loc, builder, entity);5229 auto transferKindAttr = cuf::DataTransferKindAttr::get(5230 builder.getContext(), cuf::DataTransferKind::DeviceHost);5231 cuf::DataTransferOp::create(builder, loc, designateOp.getMemref(), temp,5232 /*shape=*/mlir::Value{}, transferKindAttr);5233 designateOp.getMemrefMutable().assign(temp);5234 builder.setInsertionPointAfter(elementalOp);5235 hlfir::AssignOp::create(builder, loc, elementalOp, lhs,5236 isWholeAllocatableAssignment,5237 keepLhsLengthInAllocatableAssignment);5238 return;5239 }5240 auto transferKindAttr = cuf::DataTransferKindAttr::get(5241 builder.getContext(), cuf::DataTransferKind::DeviceHost);5242 cuf::DataTransferOp::create(builder, loc, rhsVal, lhsVal, shape,5243 transferKindAttr);5244 return;5245 }5246 5247 // device = device5248 if (lhsIsDevice && rhsIsDevice) {5249 auto transferKindAttr = cuf::DataTransferKindAttr::get(5250 builder.getContext(), cuf::DataTransferKind::DeviceDevice);5251 cuf::DataTransferOp::create(builder, loc, rhsVal, lhsVal, shape,5252 transferKindAttr);5253 return;5254 }5255 llvm_unreachable("Unhandled CUDA data transfer");5256 }5257 5258 llvm::SmallVector<mlir::Value>5259 genCUDAImplicitDataTransfer(fir::FirOpBuilder &builder, mlir::Location loc,5260 const Fortran::evaluate::Assignment &assign) {5261 llvm::SmallVector<mlir::Value> temps;5262 localSymbols.pushScope();5263 auto transferKindAttr = cuf::DataTransferKindAttr::get(5264 builder.getContext(), cuf::DataTransferKind::DeviceHost);5265 [[maybe_unused]] unsigned nbDeviceResidentObject = 0;5266 for (const Fortran::semantics::Symbol &sym :5267 Fortran::evaluate::CollectSymbols(assign.rhs)) {5268 if (const auto *details =5269 sym.GetUltimate()5270 .detailsIf<Fortran::semantics::ObjectEntityDetails>()) {5271 if (details->cudaDataAttr() &&5272 *details->cudaDataAttr() != Fortran::common::CUDADataAttr::Pinned) {5273 assert(5274 nbDeviceResidentObject <= 1 &&5275 "Only one reference to the device resident object is supported");5276 auto addr = getSymbolAddress(sym);5277 mlir::Value baseValue;5278 if (auto declareOp =5279 llvm::dyn_cast<hlfir::DeclareOp>(addr.getDefiningOp()))5280 baseValue = declareOp.getBase();5281 else5282 baseValue = addr;5283 5284 hlfir::Entity entity{baseValue};5285 auto [temp, cleanup] =5286 hlfir::createTempFromMold(loc, builder, entity);5287 if (cleanup) {5288 if (auto declareOp =5289 mlir::dyn_cast<hlfir::DeclareOp>(temp.getDefiningOp()))5290 temps.push_back(declareOp.getMemref());5291 else5292 temps.push_back(temp);5293 }5294 addSymbol(sym,5295 hlfir::translateToExtendedValue(loc, builder, temp).first,5296 /*forced=*/true);5297 cuf::DataTransferOp::create(builder, loc, addr, temp,5298 /*shape=*/mlir::Value{},5299 transferKindAttr);5300 ++nbDeviceResidentObject;5301 }5302 }5303 }5304 return temps;5305 }5306 5307 void genDataAssignment(5308 const Fortran::evaluate::Assignment &assign,5309 const Fortran::evaluate::ProcedureRef *userDefinedAssignment,5310 const llvm::ArrayRef<const Fortran::parser::CompilerDirective *> &dirs =5311 {}) {5312 mlir::Location loc = getCurrentLocation();5313 fir::FirOpBuilder &builder = getFirOpBuilder();5314 5315 bool isInDeviceContext = cuf::isCUDADeviceContext(5316 builder.getRegion(),5317 getFoldingContext().languageFeatures().IsEnabled(5318 Fortran::common::LanguageFeature::DoConcurrentOffload));5319 5320 bool isCUDATransfer =5321 IsCUDADataTransfer(assign.lhs, assign.rhs) && !isInDeviceContext;5322 bool hasCUDAImplicitTransfer =5323 isCUDATransfer &&5324 Fortran::evaluate::HasCUDAImplicitTransfer(assign.rhs);5325 llvm::SmallVector<mlir::Value> implicitTemps;5326 5327 if (hasCUDAImplicitTransfer && !isInDeviceContext)5328 implicitTemps = genCUDAImplicitDataTransfer(builder, loc, assign);5329 5330 // Gather some information about the assignment that will impact how it is5331 // lowered.5332 const bool isWholeAllocatableAssignment =5333 !userDefinedAssignment && !isInsideHlfirWhere() &&5334 Fortran::lower::isWholeAllocatable(assign.lhs) &&5335 bridge.getLoweringOptions().getReallocateLHS();5336 const bool isUserDefAssignToPointerOrAllocatable =5337 userDefinedAssignment &&5338 firstDummyIsPointerOrAllocatable(*userDefinedAssignment);5339 std::optional<Fortran::evaluate::DynamicType> lhsType =5340 assign.lhs.GetType();5341 const bool keepLhsLengthInAllocatableAssignment =5342 isWholeAllocatableAssignment && lhsType.has_value() &&5343 lhsType->category() == Fortran::common::TypeCategory::Character &&5344 !lhsType->HasDeferredTypeParameter();5345 const bool lhsHasVectorSubscripts =5346 Fortran::evaluate::HasVectorSubscript(assign.lhs);5347 5348 // Helper to generate the code evaluating the right-hand side.5349 auto evaluateRhs = [&](Fortran::lower::StatementContext &stmtCtx) {5350 hlfir::Entity rhs = Fortran::lower::convertExprToHLFIR(5351 loc, *this, assign.rhs, localSymbols, stmtCtx);5352 // Load trivial scalar RHS to allow the loads to be hoisted outside of5353 // loops early if possible. This also dereferences pointer and5354 // allocatable RHS: the target is being assigned from.5355 rhs = hlfir::loadTrivialScalar(loc, builder, rhs);5356 // In intrinsic assignments, the LHS type may not match the RHS type, in5357 // which case an implicit conversion of the LHS must be done. The5358 // front-end usually makes it explicit, unless it cannot (whole5359 // allocatable LHS or Logical<->Integer assignment extension). Recognize5360 // any type mismatches here and insert explicit scalar convert or5361 // ElementalOp for array assignment. Preserve the RHS lower bounds on the5362 // converted entity in case of assignment to whole allocatables so to5363 // propagate the lower bounds to the LHS in case of reallocation.5364 if (!userDefinedAssignment)5365 rhs = genImplicitConvert(assign, rhs, isWholeAllocatableAssignment,5366 stmtCtx);5367 return rhs;5368 };5369 5370 // Helper to generate the code evaluating the left-hand side.5371 auto evaluateLhs = [&](Fortran::lower::StatementContext &stmtCtx) {5372 hlfir::Entity lhs = Fortran::lower::convertExprToHLFIR(5373 loc, *this, assign.lhs, localSymbols, stmtCtx);5374 // Dereference pointer LHS: the target is being assigned to.5375 // Same for allocatables outside of whole allocatable assignments.5376 if (!isWholeAllocatableAssignment &&5377 !isUserDefAssignToPointerOrAllocatable)5378 lhs = hlfir::derefPointersAndAllocatables(loc, builder, lhs);5379 return lhs;5380 };5381 5382 if (!isInsideHlfirForallOrWhere() && !lhsHasVectorSubscripts &&5383 !userDefinedAssignment) {5384 Fortran::lower::StatementContext localStmtCtx;5385 hlfir::Entity rhs = evaluateRhs(localStmtCtx);5386 hlfir::Entity lhs = evaluateLhs(localStmtCtx);5387 if (isCUDATransfer && !hasCUDAImplicitTransfer)5388 genCUDADataTransfer(builder, loc, assign, lhs, rhs,5389 isWholeAllocatableAssignment,5390 keepLhsLengthInAllocatableAssignment);5391 else {5392 // If RHS or LHS have a CallOp in their expression, this operation will5393 // have the 'no_inline' or 'always_inline' attribute if there is a5394 // directive just before the assignement.5395 if (!dirs.empty()) {5396 if (rhs.getDefiningOp())5397 attachInlineAttributes(*rhs.getDefiningOp(), dirs);5398 if (lhs.getDefiningOp())5399 attachInlineAttributes(*lhs.getDefiningOp(), dirs);5400 }5401 hlfir::AssignOp::create(builder, loc, rhs, lhs,5402 isWholeAllocatableAssignment,5403 keepLhsLengthInAllocatableAssignment);5404 }5405 if (hasCUDAImplicitTransfer && !isInDeviceContext) {5406 localSymbols.popScope();5407 for (mlir::Value temp : implicitTemps)5408 fir::FreeMemOp::create(builder, loc, temp);5409 }5410 return;5411 }5412 // Assignments inside Forall, Where, or assignments to a vector subscripted5413 // left-hand side requires using an hlfir.region_assign in HLFIR. The5414 // right-hand side and left-hand side must be evaluated inside the5415 // hlfir.region_assign regions.5416 auto regionAssignOp = hlfir::RegionAssignOp::create(builder, loc);5417 5418 // Lower RHS in its own region.5419 builder.createBlock(®ionAssignOp.getRhsRegion());5420 Fortran::lower::StatementContext rhsContext;5421 hlfir::Entity rhs = evaluateRhs(rhsContext);5422 auto rhsYieldOp = hlfir::YieldOp::create(builder, loc, rhs);5423 Fortran::lower::genCleanUpInRegionIfAny(5424 loc, builder, rhsYieldOp.getCleanup(), rhsContext);5425 // Lower LHS in its own region.5426 builder.createBlock(®ionAssignOp.getLhsRegion());5427 Fortran::lower::StatementContext lhsContext;5428 mlir::Value lhsYield = nullptr;5429 if (!lhsHasVectorSubscripts) {5430 hlfir::Entity lhs = evaluateLhs(lhsContext);5431 auto lhsYieldOp = hlfir::YieldOp::create(builder, loc, lhs);5432 Fortran::lower::genCleanUpInRegionIfAny(5433 loc, builder, lhsYieldOp.getCleanup(), lhsContext);5434 lhsYield = lhs;5435 } else {5436 hlfir::ElementalAddrOp elementalAddr =5437 Fortran::lower::convertVectorSubscriptedExprToElementalAddr(5438 loc, *this, assign.lhs, localSymbols, lhsContext);5439 Fortran::lower::genCleanUpInRegionIfAny(5440 loc, builder, elementalAddr.getCleanup(), lhsContext);5441 lhsYield = elementalAddr.getYieldOp().getEntity();5442 }5443 assert(lhsYield && "must have been set");5444 5445 // Add "realloc" flag to hlfir.region_assign.5446 if (isWholeAllocatableAssignment)5447 TODO(loc, "assignment to a whole allocatable inside FORALL");5448 5449 // Generate the hlfir.region_assign userDefinedAssignment region.5450 if (userDefinedAssignment) {5451 mlir::Type rhsType = rhs.getType();5452 mlir::Type lhsType = lhsYield.getType();5453 if (userDefinedAssignment->IsElemental()) {5454 rhsType = hlfir::getEntityElementType(rhs);5455 lhsType = hlfir::getEntityElementType(hlfir::Entity{lhsYield});5456 }5457 builder.createBlock(®ionAssignOp.getUserDefinedAssignment(),5458 mlir::Region::iterator{}, {rhsType, lhsType},5459 {loc, loc});5460 auto end = fir::FirEndOp::create(builder, loc);5461 builder.setInsertionPoint(end);5462 hlfir::Entity lhsBlockArg{regionAssignOp.getUserAssignmentLhs()};5463 hlfir::Entity rhsBlockArg{regionAssignOp.getUserAssignmentRhs()};5464 Fortran::lower::convertUserDefinedAssignmentToHLFIR(5465 loc, *this, *userDefinedAssignment, lhsBlockArg, rhsBlockArg,5466 localSymbols);5467 }5468 builder.setInsertionPointAfter(regionAssignOp);5469 }5470 5471 /// Shared for both assignments and pointer assignments.5472 void5473 genAssignment(const Fortran::evaluate::Assignment &assign,5474 const llvm::ArrayRef<const Fortran::parser::CompilerDirective *>5475 &dirs = {}) {5476 mlir::Location loc = toLocation();5477 if (lowerToHighLevelFIR()) {5478 Fortran::common::visit(5479 Fortran::common::visitors{5480 [&](const Fortran::evaluate::Assignment::Intrinsic &) {5481 genDataAssignment(assign, /*userDefinedAssignment=*/nullptr,5482 dirs);5483 },5484 [&](const Fortran::evaluate::ProcedureRef &procRef) {5485 genDataAssignment(assign, /*userDefinedAssignment=*/&procRef,5486 dirs);5487 },5488 [&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {5489 genPointerAssignment(loc, assign);5490 },5491 [&](const Fortran::evaluate::Assignment::BoundsRemapping5492 &boundExprs) { genPointerAssignment(loc, assign); },5493 },5494 assign.u);5495 return;5496 }5497 if (explicitIterationSpace()) {5498 Fortran::lower::createArrayLoads(*this, explicitIterSpace, localSymbols);5499 explicitIterSpace.genLoopNest();5500 }5501 Fortran::lower::StatementContext stmtCtx;5502 Fortran::common::visit(5503 Fortran::common::visitors{5504 // [1] Plain old assignment.5505 [&](const Fortran::evaluate::Assignment::Intrinsic &) {5506 const Fortran::semantics::Symbol *sym =5507 Fortran::evaluate::GetLastSymbol(assign.lhs);5508 5509 if (!sym)5510 TODO(loc, "assignment to pointer result of function reference");5511 5512 std::optional<Fortran::evaluate::DynamicType> lhsType =5513 assign.lhs.GetType();5514 assert(lhsType && "lhs cannot be typeless");5515 std::optional<Fortran::evaluate::DynamicType> rhsType =5516 assign.rhs.GetType();5517 5518 // Assignment to/from polymorphic entities are done with the5519 // runtime.5520 if (lhsType->IsPolymorphic() ||5521 lhsType->IsUnlimitedPolymorphic() ||5522 (rhsType && (rhsType->IsPolymorphic() ||5523 rhsType->IsUnlimitedPolymorphic()))) {5524 mlir::Value lhs;5525 if (Fortran::lower::isWholeAllocatable(assign.lhs))5526 lhs = genExprMutableBox(loc, assign.lhs).getAddr();5527 else5528 lhs = fir::getBase(genExprBox(loc, assign.lhs, stmtCtx));5529 mlir::Value rhs =5530 fir::getBase(genExprBox(loc, assign.rhs, stmtCtx));5531 if ((lhsType->IsPolymorphic() ||5532 lhsType->IsUnlimitedPolymorphic()) &&5533 Fortran::lower::isWholeAllocatable(assign.lhs))5534 fir::runtime::genAssignPolymorphic(*builder, loc, lhs, rhs);5535 else5536 fir::runtime::genAssign(*builder, loc, lhs, rhs);5537 return;5538 }5539 5540 // Note: No ad-hoc handling for pointers is required here. The5541 // target will be assigned as per 2018 10.2.1.3 p2. genExprAddr5542 // on a pointer returns the target address and not the address of5543 // the pointer variable.5544 5545 if (assign.lhs.Rank() > 0 || explicitIterationSpace()) {5546 if (isDerivedCategory(lhsType->category()) &&5547 Fortran::semantics::IsFinalizable(5548 lhsType->GetDerivedTypeSpec()))5549 TODO(loc, "derived-type finalization with array assignment");5550 // Array assignment5551 // See Fortran 2018 10.2.1.3 p5, p6, and p75552 genArrayAssignment(assign, stmtCtx);5553 return;5554 }5555 5556 // Scalar assignment5557 const bool isNumericScalar =5558 isNumericScalarCategory(lhsType->category());5559 const bool isVector =5560 isDerivedCategory(lhsType->category()) &&5561 lhsType->GetDerivedTypeSpec().IsVectorType();5562 fir::ExtendedValue rhs = (isNumericScalar || isVector)5563 ? genExprValue(assign.rhs, stmtCtx)5564 : genExprAddr(assign.rhs, stmtCtx);5565 const bool lhsIsWholeAllocatable =5566 Fortran::lower::isWholeAllocatable(assign.lhs);5567 std::optional<fir::factory::MutableBoxReallocation> lhsRealloc;5568 std::optional<fir::MutableBoxValue> lhsMutableBox;5569 5570 // Set flag to know if the LHS needs finalization. Polymorphic,5571 // unlimited polymorphic assignment will be done with genAssign.5572 // Assign runtime function performs the finalization.5573 bool needFinalization = !lhsType->IsPolymorphic() &&5574 !lhsType->IsUnlimitedPolymorphic() &&5575 (isDerivedCategory(lhsType->category()) &&5576 Fortran::semantics::IsFinalizable(5577 lhsType->GetDerivedTypeSpec()));5578 5579 auto lhs = [&]() -> fir::ExtendedValue {5580 if (lhsIsWholeAllocatable) {5581 lhsMutableBox = genExprMutableBox(loc, assign.lhs);5582 // Finalize if needed.5583 if (needFinalization) {5584 mlir::Value isAllocated =5585 fir::factory::genIsAllocatedOrAssociatedTest(5586 *builder, loc, *lhsMutableBox);5587 builder->genIfThen(loc, isAllocated)5588 .genThen([&]() {5589 fir::runtime::genDerivedTypeDestroy(5590 *builder, loc, fir::getBase(*lhsMutableBox));5591 })5592 .end();5593 needFinalization = false;5594 }5595 5596 llvm::SmallVector<mlir::Value> lengthParams;5597 if (const fir::CharBoxValue *charBox = rhs.getCharBox())5598 lengthParams.push_back(charBox->getLen());5599 else if (fir::isDerivedWithLenParameters(rhs))5600 TODO(loc, "assignment to derived type allocatable with "5601 "LEN parameters");5602 lhsRealloc = fir::factory::genReallocIfNeeded(5603 *builder, loc, *lhsMutableBox,5604 /*shape=*/{}, lengthParams);5605 return lhsRealloc->newValue;5606 }5607 return genExprAddr(assign.lhs, stmtCtx);5608 }();5609 5610 if (isNumericScalar || isVector) {5611 // Fortran 2018 10.2.1.3 p8 and p95612 // Conversions should have been inserted by semantic analysis,5613 // but they can be incorrect between the rhs and lhs. Correct5614 // that here.5615 mlir::Value addr = fir::getBase(lhs);5616 mlir::Value val = fir::getBase(rhs);5617 // A function with multiple entry points returning different5618 // types tags all result variables with one of the largest5619 // types to allow them to share the same storage. Assignment5620 // to a result variable of one of the other types requires5621 // conversion to the actual type.5622 mlir::Type toTy = genType(assign.lhs);5623 5624 // If Cray pointee, need to handle the address5625 // Array is handled in genCoordinateOp.5626 if (sym->test(Fortran::semantics::Symbol::Flag::CrayPointee) &&5627 sym->Rank() == 0) {5628 // get the corresponding Cray pointer5629 5630 const Fortran::semantics::Symbol &ptrSym =5631 Fortran::semantics::GetCrayPointer(*sym);5632 fir::ExtendedValue ptr =5633 getSymbolExtendedValue(ptrSym, nullptr);5634 mlir::Value ptrVal = fir::getBase(ptr);5635 mlir::Type ptrTy = genType(ptrSym);5636 5637 fir::ExtendedValue pte =5638 getSymbolExtendedValue(*sym, nullptr);5639 mlir::Value pteVal = fir::getBase(pte);5640 mlir::Value cnvrt = Fortran::lower::addCrayPointerInst(5641 loc, *builder, ptrVal, ptrTy, pteVal.getType());5642 addr = fir::LoadOp::create(*builder, loc, cnvrt);5643 }5644 mlir::Value cast =5645 isVector ? val5646 : builder->convertWithSemantics(loc, toTy, val);5647 if (fir::dyn_cast_ptrEleTy(addr.getType()) != toTy) {5648 assert(isFuncResultDesignator(assign.lhs) && "type mismatch");5649 addr = builder->createConvert(5650 toLocation(), builder->getRefType(toTy), addr);5651 }5652 fir::StoreOp::create(*builder, loc, cast, addr);5653 } else if (isCharacterCategory(lhsType->category())) {5654 // Fortran 2018 10.2.1.3 p10 and p115655 fir::factory::CharacterExprHelper{*builder, loc}.createAssign(5656 lhs, rhs);5657 } else if (isDerivedCategory(lhsType->category())) {5658 // Handle parent component.5659 if (Fortran::lower::isParentComponent(assign.lhs)) {5660 if (!mlir::isa<fir::BaseBoxType>(fir::getBase(lhs).getType()))5661 lhs = fir::getBase(builder->createBox(loc, lhs));5662 lhs = Fortran::lower::updateBoxForParentComponent(*this, lhs,5663 assign.lhs);5664 }5665 5666 // Fortran 2018 10.2.1.3 p13 and p145667 // Recursively gen an assignment on each element pair.5668 fir::factory::genRecordAssignment(*builder, loc, lhs, rhs,5669 needFinalization);5670 } else {5671 llvm_unreachable("unknown category");5672 }5673 if (lhsIsWholeAllocatable) {5674 assert(lhsRealloc.has_value());5675 fir::factory::finalizeRealloc(*builder, loc, *lhsMutableBox,5676 /*lbounds=*/{},5677 /*takeLboundsIfRealloc=*/false,5678 *lhsRealloc);5679 }5680 },5681 5682 // [2] User defined assignment. If the context is a scalar5683 // expression then call the procedure.5684 [&](const Fortran::evaluate::ProcedureRef &procRef) {5685 Fortran::lower::StatementContext &ctx =5686 explicitIterationSpace() ? explicitIterSpace.stmtContext()5687 : stmtCtx;5688 Fortran::lower::createSubroutineCall(5689 *this, procRef, explicitIterSpace, implicitIterSpace,5690 localSymbols, ctx, /*isUserDefAssignment=*/true);5691 },5692 5693 [&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {5694 return genNoHLFIRPointerAssignment(loc, assign, lbExprs);5695 },5696 [&](const Fortran::evaluate::Assignment::BoundsRemapping5697 &boundExprs) {5698 return genNoHLFIRPointerAssignment(loc, assign, boundExprs);5699 },5700 },5701 assign.u);5702 if (explicitIterationSpace())5703 Fortran::lower::createArrayMergeStores(*this, explicitIterSpace);5704 }5705 5706 // Is the insertion point of the builder directly or indirectly set5707 // inside any operation of type "Op"?5708 template <typename... Op>5709 bool isInsideOp() const {5710 mlir::Block *block = builder->getInsertionBlock();5711 mlir::Operation *op = block ? block->getParentOp() : nullptr;5712 while (op) {5713 if (mlir::isa<Op...>(op))5714 return true;5715 op = op->getParentOp();5716 }5717 return false;5718 }5719 bool isInsideHlfirForallOrWhere() const {5720 return isInsideOp<hlfir::ForallOp, hlfir::WhereOp>();5721 }5722 bool isInsideHlfirWhere() const { return isInsideOp<hlfir::WhereOp>(); }5723 5724 void genFIR(const Fortran::parser::WhereConstruct &c) {5725 mlir::Location loc = getCurrentLocation();5726 hlfir::WhereOp whereOp;5727 5728 if (!lowerToHighLevelFIR()) {5729 implicitIterSpace.growStack();5730 } else {5731 whereOp = hlfir::WhereOp::create(*builder, loc);5732 builder->createBlock(&whereOp.getMaskRegion());5733 }5734 5735 // Lower the where mask. For HLFIR, this is done in the hlfir.where mask5736 // region.5737 genNestedStatement(5738 std::get<5739 Fortran::parser::Statement<Fortran::parser::WhereConstructStmt>>(5740 c.t));5741 5742 // Lower WHERE body. For HLFIR, this is done in the hlfir.where body5743 // region.5744 if (whereOp)5745 builder->createBlock(&whereOp.getBody());5746 5747 for (const auto &body :5748 std::get<std::list<Fortran::parser::WhereBodyConstruct>>(c.t))5749 genFIR(body);5750 for (const auto &e :5751 std::get<std::list<Fortran::parser::WhereConstruct::MaskedElsewhere>>(5752 c.t))5753 genFIR(e);5754 if (const auto &e =5755 std::get<std::optional<Fortran::parser::WhereConstruct::Elsewhere>>(5756 c.t);5757 e.has_value())5758 genFIR(*e);5759 genNestedStatement(5760 std::get<Fortran::parser::Statement<Fortran::parser::EndWhereStmt>>(5761 c.t));5762 5763 if (whereOp) {5764 // For HLFIR, create fir.end terminator in the last hlfir.elsewhere, or5765 // in the hlfir.where if it had no elsewhere.5766 fir::FirEndOp::create(*builder, loc);5767 builder->setInsertionPointAfter(whereOp);5768 }5769 }5770 void genFIR(const Fortran::parser::WhereBodyConstruct &body) {5771 Fortran::common::visit(5772 Fortran::common::visitors{5773 [&](const Fortran::parser::Statement<5774 Fortran::parser::AssignmentStmt> &stmt) {5775 genNestedStatement(stmt);5776 },5777 [&](const Fortran::parser::Statement<Fortran::parser::WhereStmt>5778 &stmt) { genNestedStatement(stmt); },5779 [&](const Fortran::common::Indirection<5780 Fortran::parser::WhereConstruct> &c) { genFIR(c.value()); },5781 },5782 body.u);5783 }5784 5785 /// Lower a Where or Elsewhere mask into an hlfir mask region.5786 void lowerWhereMaskToHlfir(mlir::Location loc,5787 const Fortran::semantics::SomeExpr *maskExpr) {5788 assert(maskExpr && "mask semantic analysis failed");5789 Fortran::lower::StatementContext maskContext;5790 hlfir::Entity mask = Fortran::lower::convertExprToHLFIR(5791 loc, *this, *maskExpr, localSymbols, maskContext);5792 mask = hlfir::loadTrivialScalar(loc, *builder, mask);5793 auto yieldOp = hlfir::YieldOp::create(*builder, loc, mask);5794 Fortran::lower::genCleanUpInRegionIfAny(loc, *builder, yieldOp.getCleanup(),5795 maskContext);5796 }5797 void genFIR(const Fortran::parser::WhereConstructStmt &stmt) {5798 const Fortran::semantics::SomeExpr *maskExpr = Fortran::semantics::GetExpr(5799 std::get<Fortran::parser::LogicalExpr>(stmt.t));5800 if (lowerToHighLevelFIR())5801 lowerWhereMaskToHlfir(getCurrentLocation(), maskExpr);5802 else5803 implicitIterSpace.append(maskExpr);5804 }5805 void genFIR(const Fortran::parser::WhereConstruct::MaskedElsewhere &ew) {5806 mlir::Location loc = getCurrentLocation();5807 hlfir::ElseWhereOp elsewhereOp;5808 if (lowerToHighLevelFIR()) {5809 elsewhereOp = hlfir::ElseWhereOp::create(*builder, loc);5810 // Lower mask in the mask region.5811 builder->createBlock(&elsewhereOp.getMaskRegion());5812 }5813 genNestedStatement(5814 std::get<5815 Fortran::parser::Statement<Fortran::parser::MaskedElsewhereStmt>>(5816 ew.t));5817 5818 // For HLFIR, lower the body in the hlfir.elsewhere body region.5819 if (elsewhereOp)5820 builder->createBlock(&elsewhereOp.getBody());5821 5822 for (const auto &body :5823 std::get<std::list<Fortran::parser::WhereBodyConstruct>>(ew.t))5824 genFIR(body);5825 }5826 void genFIR(const Fortran::parser::MaskedElsewhereStmt &stmt) {5827 const auto *maskExpr = Fortran::semantics::GetExpr(5828 std::get<Fortran::parser::LogicalExpr>(stmt.t));5829 if (lowerToHighLevelFIR())5830 lowerWhereMaskToHlfir(getCurrentLocation(), maskExpr);5831 else5832 implicitIterSpace.append(maskExpr);5833 }5834 void genFIR(const Fortran::parser::WhereConstruct::Elsewhere &ew) {5835 if (lowerToHighLevelFIR()) {5836 auto elsewhereOp =5837 hlfir::ElseWhereOp::create(*builder, getCurrentLocation());5838 builder->createBlock(&elsewhereOp.getBody());5839 }5840 genNestedStatement(5841 std::get<Fortran::parser::Statement<Fortran::parser::ElsewhereStmt>>(5842 ew.t));5843 for (const auto &body :5844 std::get<std::list<Fortran::parser::WhereBodyConstruct>>(ew.t))5845 genFIR(body);5846 }5847 void genFIR(const Fortran::parser::ElsewhereStmt &stmt) {5848 if (!lowerToHighLevelFIR())5849 implicitIterSpace.append(nullptr);5850 }5851 void genFIR(const Fortran::parser::EndWhereStmt &) {5852 if (!lowerToHighLevelFIR())5853 implicitIterSpace.shrinkStack();5854 }5855 5856 void genFIR(const Fortran::parser::WhereStmt &stmt) {5857 Fortran::lower::StatementContext stmtCtx;5858 const auto &assign = std::get<Fortran::parser::AssignmentStmt>(stmt.t);5859 const auto *mask = Fortran::semantics::GetExpr(5860 std::get<Fortran::parser::LogicalExpr>(stmt.t));5861 if (lowerToHighLevelFIR()) {5862 mlir::Location loc = getCurrentLocation();5863 auto whereOp = hlfir::WhereOp::create(*builder, loc);5864 builder->createBlock(&whereOp.getMaskRegion());5865 lowerWhereMaskToHlfir(loc, mask);5866 builder->createBlock(&whereOp.getBody());5867 genAssignment(*assign.typedAssignment->v);5868 fir::FirEndOp::create(*builder, loc);5869 builder->setInsertionPointAfter(whereOp);5870 return;5871 }5872 implicitIterSpace.growStack();5873 implicitIterSpace.append(mask);5874 genAssignment(*assign.typedAssignment->v);5875 implicitIterSpace.shrinkStack();5876 }5877 5878 void genFIR(const Fortran::parser::PointerAssignmentStmt &stmt) {5879 genAssignment(*stmt.typedAssignment->v);5880 }5881 5882 void genFIR(const Fortran::parser::AssignmentStmt &stmt) {5883 Fortran::lower::pft::Evaluation &eval = getEval();5884 genAssignment(*stmt.typedAssignment->v, eval.dirs);5885 }5886 5887 void genFIR(const Fortran::parser::SyncAllStmt &stmt) {5888 genSyncAllStatement(*this, stmt);5889 }5890 5891 void genFIR(const Fortran::parser::SyncImagesStmt &stmt) {5892 genSyncImagesStatement(*this, stmt);5893 }5894 5895 void genFIR(const Fortran::parser::SyncMemoryStmt &stmt) {5896 genSyncMemoryStatement(*this, stmt);5897 }5898 5899 void genFIR(const Fortran::parser::SyncTeamStmt &stmt) {5900 genSyncTeamStatement(*this, stmt);5901 }5902 5903 void genFIR(const Fortran::parser::UnlockStmt &stmt) {5904 genUnlockStatement(*this, stmt);5905 }5906 5907 void genFIR(const Fortran::parser::AssignStmt &stmt) {5908 const Fortran::semantics::Symbol &symbol =5909 *std::get<Fortran::parser::Name>(stmt.t).symbol;5910 5911 mlir::Location loc = toLocation();5912 mlir::Type symbolType = genType(symbol);5913 mlir::Value addr = getSymbolAddress(symbol);5914 5915 // Handle the case where the assigned variable is declared as a pointer5916 if (auto eleTy = fir::dyn_cast_ptrOrBoxEleTy(symbolType)) {5917 if (auto ptrType = mlir::dyn_cast<fir::PointerType>(eleTy)) {5918 symbolType = ptrType.getEleTy();5919 } else {5920 symbolType = eleTy;5921 }5922 } else if (auto ptrType = mlir::dyn_cast<fir::PointerType>(symbolType)) {5923 symbolType = ptrType.getEleTy();5924 }5925 5926 mlir::Value labelValue = builder->createIntegerConstant(5927 loc, symbolType, std::get<Fortran::parser::Label>(stmt.t));5928 5929 // If the address points to a boxed pointer, we need to dereference it5930 if (auto refType = mlir::dyn_cast<fir::ReferenceType>(addr.getType())) {5931 if (auto boxType = mlir::dyn_cast<fir::BoxType>(refType.getEleTy())) {5932 mlir::Value boxValue = fir::LoadOp::create(*builder, loc, addr);5933 addr = fir::BoxAddrOp::create(*builder, loc, boxValue);5934 }5935 }5936 5937 fir::StoreOp::create(*builder, loc, labelValue, addr);5938 }5939 5940 void genFIR(const Fortran::parser::FormatStmt &) {5941 // do nothing.5942 5943 // FORMAT statements have no semantics. They may be lowered if used by a5944 // data transfer statement.5945 }5946 5947 void genFIR(const Fortran::parser::PauseStmt &stmt) {5948 genPauseStatement(*this, stmt);5949 }5950 5951 // call FAIL IMAGE in runtime5952 void genFIR(const Fortran::parser::FailImageStmt &stmt) {5953 genFailImageStatement(*this);5954 }5955 5956 // call STOP, ERROR STOP in runtime5957 void genFIR(const Fortran::parser::StopStmt &stmt) {5958 genStopStatement(*this, stmt);5959 }5960 5961 void genFIR(const Fortran::parser::ReturnStmt &stmt) {5962 Fortran::lower::pft::FunctionLikeUnit *funit =5963 getEval().getOwningProcedure();5964 assert(funit && "not inside main program, function or subroutine");5965 for (auto it = activeConstructStack.rbegin(),5966 rend = activeConstructStack.rend();5967 it != rend; ++it) {5968 it->stmtCtx.finalizeAndKeep();5969 }5970 if (funit->isMainProgram()) {5971 genExitRoutine(true);5972 return;5973 }5974 mlir::Location loc = toLocation();5975 if (stmt.v) {5976 // Alternate return statement - If this is a subroutine where some5977 // alternate entries have alternate returns, but the active entry point5978 // does not, ignore the alternate return value. Otherwise, assign it5979 // to the compiler-generated result variable.5980 const Fortran::semantics::Symbol &symbol = funit->getSubprogramSymbol();5981 if (Fortran::semantics::HasAlternateReturns(symbol)) {5982 Fortran::lower::StatementContext stmtCtx;5983 const Fortran::lower::SomeExpr *expr =5984 Fortran::semantics::GetExpr(*stmt.v);5985 assert(expr && "missing alternate return expression");5986 mlir::Value altReturnIndex = builder->createConvert(5987 loc, builder->getIndexType(), createFIRExpr(loc, expr, stmtCtx));5988 fir::StoreOp::create(*builder, loc, altReturnIndex,5989 getAltReturnResult(symbol));5990 }5991 }5992 // Branch to the last block of the SUBROUTINE, which has the actual return.5993 if (!funit->finalBlock) {5994 mlir::OpBuilder::InsertPoint insPt = builder->saveInsertionPoint();5995 Fortran::lower::setInsertionPointAfterOpenACCLoopIfInside(*builder);5996 funit->finalBlock = builder->createBlock(&builder->getRegion());5997 builder->restoreInsertionPoint(insPt);5998 }5999 6000 if (Fortran::lower::isInOpenACCLoop(*builder))6001 Fortran::lower::genEarlyReturnInOpenACCLoop(*builder, loc);6002 else6003 mlir::cf::BranchOp::create(*builder, loc, funit->finalBlock);6004 }6005 6006 void genFIR(const Fortran::parser::CycleStmt &) {6007 genConstructExitBranch(*getEval().controlSuccessor);6008 }6009 void genFIR(const Fortran::parser::ExitStmt &) {6010 genConstructExitBranch(*getEval().controlSuccessor);6011 }6012 void genFIR(const Fortran::parser::GotoStmt &) {6013 genConstructExitBranch(*getEval().controlSuccessor);6014 }6015 6016 // Nop statements - No code, or code is generated at the construct level.6017 // But note that the genFIR call immediately below that wraps one of these6018 // calls does block management, possibly starting a new block, and possibly6019 // generating a branch to end a block. So these calls may still be required6020 // for that functionality.6021 void genFIR(const Fortran::parser::AssociateStmt &) {} // nop6022 void genFIR(const Fortran::parser::BlockStmt &) {} // nop6023 void genFIR(const Fortran::parser::CaseStmt &) {} // nop6024 void genFIR(const Fortran::parser::ContinueStmt &) {} // nop6025 void genFIR(const Fortran::parser::ElseIfStmt &) {} // nop6026 void genFIR(const Fortran::parser::ElseStmt &) {} // nop6027 void genFIR(const Fortran::parser::EndAssociateStmt &) {} // nop6028 void genFIR(const Fortran::parser::EndBlockStmt &) {} // nop6029 void genFIR(const Fortran::parser::EndDoStmt &) {} // nop6030 void genFIR(const Fortran::parser::EndFunctionStmt &) {} // nop6031 void genFIR(const Fortran::parser::EndIfStmt &) {} // nop6032 void genFIR(const Fortran::parser::EndMpSubprogramStmt &) {} // nop6033 void genFIR(const Fortran::parser::EndProgramStmt &) {} // nop6034 void genFIR(const Fortran::parser::EndSelectStmt &) {} // nop6035 void genFIR(const Fortran::parser::EndSubroutineStmt &) {} // nop6036 void genFIR(const Fortran::parser::EntryStmt &) {} // nop6037 void genFIR(const Fortran::parser::IfStmt &) {} // nop6038 void genFIR(const Fortran::parser::IfThenStmt &) {} // nop6039 void genFIR(const Fortran::parser::NonLabelDoStmt &) {} // nop6040 void genFIR(const Fortran::parser::OmpEndLoopDirective &) {} // nop6041 void genFIR(const Fortran::parser::SelectTypeStmt &) {} // nop6042 void genFIR(const Fortran::parser::TypeGuardStmt &) {} // nop6043 6044 /// Generate FIR for Evaluation \p eval.6045 void genFIR(Fortran::lower::pft::Evaluation &eval,6046 bool unstructuredContext = true) {6047 // Start a new unstructured block when applicable. When transitioning6048 // from unstructured to structured code, unstructuredContext is true,6049 // which accounts for the possibility that the structured code could be6050 // a target that starts a new block.6051 if (unstructuredContext)6052 maybeStartBlock(eval.isConstruct() && eval.lowerAsStructured()6053 ? eval.getFirstNestedEvaluation().block6054 : eval.block);6055 6056 // Generate evaluation specific code. Even nop calls should usually reach6057 // here in case they start a new block or require generation of a generic6058 // end-of-block branch. An alternative is to add special case code6059 // elsewhere, such as in the genFIR code for a parent construct.6060 setCurrentEval(eval);6061 setCurrentPosition(eval.position);6062 eval.visit([&](const auto &stmt) { genFIR(stmt); });6063 }6064 6065 /// Map mlir function block arguments to the corresponding Fortran dummy6066 /// variables. When the result is passed as a hidden argument, the Fortran6067 /// result is also mapped. The symbol map is used to hold this mapping.6068 void mapDummiesAndResults(Fortran::lower::pft::FunctionLikeUnit &funit,6069 const Fortran::lower::CalleeInterface &callee) {6070 assert(builder && "require a builder object at this point");6071 using PassBy = Fortran::lower::CalleeInterface::PassEntityBy;6072 6073 // Track the source-level argument position (1-based)6074 unsigned argPosition = 0;6075 6076 auto mapPassedEntity = [&](const auto arg, bool isResult = false) {6077 // Count only actual source-level dummy arguments (not results or6078 // host assoc tuples)6079 if (!isResult && arg.entity.has_value())6080 argPosition++;6081 6082 if (arg.passBy == PassBy::AddressAndLength) {6083 if (callee.characterize().IsBindC())6084 return;6085 // TODO: now that fir call has some attributes regarding character6086 // return, PassBy::AddressAndLength should be retired.6087 mlir::Location loc = toLocation();6088 fir::factory::CharacterExprHelper charHelp{*builder, loc};6089 mlir::Value casted =6090 builder->createVolatileCast(loc, false, arg.firArgument);6091 mlir::Value box = charHelp.createEmboxChar(casted, arg.firLength);6092 mapBlockArgToDummyOrResult(arg.entity->get(), box, isResult,6093 isResult ? 0 : argPosition);6094 } else {6095 if (arg.entity.has_value()) {6096 mapBlockArgToDummyOrResult(arg.entity->get(), arg.firArgument,6097 isResult, isResult ? 0 : argPosition);6098 } else {6099 assert(funit.parentHasTupleHostAssoc() && "expect tuple argument");6100 }6101 }6102 };6103 for (const Fortran::lower::CalleeInterface::PassedEntity &arg :6104 callee.getPassedArguments())6105 mapPassedEntity(arg);6106 6107 // Always generate fir.dummy_scope even if there are no arguments.6108 // It is currently used to create proper TBAA forest.6109 if (lowerToHighLevelFIR()) {6110 mlir::Value scopeOp = fir::DummyScopeOp::create(*builder, toLocation());6111 setDummyArgsScope(scopeOp);6112 }6113 if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>6114 passedResult = callee.getPassedResult()) {6115 mapPassedEntity(*passedResult, /*isResult=*/true);6116 // FIXME: need to make sure things are OK here. addSymbol may not be OK6117 if (funit.primaryResult &&6118 passedResult->entity->get() != *funit.primaryResult)6119 mapBlockArgToDummyOrResult(6120 *funit.primaryResult, getSymbolAddress(passedResult->entity->get()),6121 /*isResult=*/true);6122 }6123 }6124 6125 /// Instantiate variable \p var and add it to the symbol map.6126 /// See ConvertVariable.cpp.6127 void instantiateVar(const Fortran::lower::pft::Variable &var,6128 Fortran::lower::AggregateStoreMap &storeMap) {6129 Fortran::lower::instantiateVariable(*this, var, localSymbols, storeMap);6130 if (var.hasSymbol())6131 genOpenMPSymbolProperties(*this, var);6132 }6133 6134 /// Where applicable, save the exception state and halting, rounding, and6135 /// underflow modes at function entry, and restore them at function exits.6136 void manageFPEnvironment(Fortran::lower::pft::FunctionLikeUnit &funit) {6137 mlir::Location loc = toLocation();6138 mlir::Location endLoc =6139 toLocation(Fortran::lower::pft::stmtSourceLoc(funit.endStmt));6140 if (funit.hasIeeeAccess) {6141 // Subject to F18 Clause 17.1p3, 17.3p3 states: If a flag is signaling6142 // on entry to a procedure [...], the processor will set it to quiet6143 // on entry and restore it to signaling on return. If a flag signals6144 // during execution of a procedure, the processor shall not set it to6145 // quiet on return.6146 mlir::func::FuncOp testExcept = fir::factory::getFetestexcept(*builder);6147 mlir::func::FuncOp clearExcept = fir::factory::getFeclearexcept(*builder);6148 mlir::func::FuncOp raiseExcept = fir::factory::getFeraiseexcept(*builder);6149 mlir::Value ones = builder->createIntegerConstant(6150 loc, testExcept.getFunctionType().getInput(0), -1);6151 mlir::Value exceptSet =6152 fir::CallOp::create(*builder, loc, testExcept, ones).getResult(0);6153 fir::CallOp::create(*builder, loc, clearExcept, exceptSet);6154 bridge.fctCtx().attachCleanup([=]() {6155 fir::CallOp::create(*builder, endLoc, raiseExcept, exceptSet);6156 });6157 }6158 if (funit.mayModifyHaltingMode) {6159 // F18 Clause 17.6p1: In a procedure [...], the processor shall not6160 // change the halting mode on entry, and on return shall ensure that6161 // the halting mode is the same as it was on entry.6162 mlir::func::FuncOp getExcept = fir::factory::getFegetexcept(*builder);6163 mlir::func::FuncOp disableExcept =6164 fir::factory::getFedisableexcept(*builder);6165 mlir::func::FuncOp enableExcept =6166 fir::factory::getFeenableexcept(*builder);6167 mlir::Value exceptSet =6168 fir::CallOp::create(*builder, loc, getExcept).getResult(0);6169 mlir::Value ones = builder->createIntegerConstant(6170 loc, disableExcept.getFunctionType().getInput(0), -1);6171 bridge.fctCtx().attachCleanup([=]() {6172 fir::CallOp::create(*builder, endLoc, disableExcept, ones);6173 fir::CallOp::create(*builder, endLoc, enableExcept, exceptSet);6174 });6175 }6176 if (funit.mayModifyRoundingMode) {6177 // F18 Clause 17.4p5: In a procedure [...], the processor shall not6178 // change the rounding modes on entry, and on return shall ensure that6179 // the rounding modes are the same as they were on entry.6180 mlir::func::FuncOp getRounding =6181 fir::factory::getLlvmGetRounding(*builder);6182 mlir::func::FuncOp setRounding =6183 fir::factory::getLlvmSetRounding(*builder);6184 mlir::Value roundingMode =6185 fir::CallOp::create(*builder, loc, getRounding).getResult(0);6186 bridge.fctCtx().attachCleanup([=]() {6187 fir::CallOp::create(*builder, endLoc, setRounding, roundingMode);6188 });6189 }6190 if ((funit.mayModifyUnderflowMode) &&6191 (bridge.getTargetCharacteristics().hasSubnormalFlushingControl(6192 /*any=*/true))) {6193 // F18 Clause 17.5p2: In a procedure [...], the processor shall not6194 // change the underflow mode on entry, and on return shall ensure that6195 // the underflow mode is the same as it was on entry.6196 mlir::Value underflowMode =6197 fir::runtime::genGetUnderflowMode(*builder, loc);6198 bridge.fctCtx().attachCleanup([=]() {6199 fir::runtime::genSetUnderflowMode(*builder, loc, {underflowMode});6200 });6201 }6202 }6203 6204 /// Start translation of a function.6205 void startNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {6206 assert(!builder && "expected nullptr");6207 bridge.fctCtx().pushScope();6208 bridge.openAccCtx().pushScope();6209 const Fortran::semantics::Scope &scope = funit.getScope();6210 LLVM_DEBUG(llvm::dbgs() << "\n[bridge - startNewFunction]";6211 if (auto *sym = scope.symbol()) llvm::dbgs() << " " << *sym;6212 llvm::dbgs() << "\n");6213 // Setting the builder is not necessary here, because callee6214 // always looks up the FuncOp from the module. If there was a function that6215 // was not declared yet, this call to callee will cause an assertion6216 // failure.6217 Fortran::lower::CalleeInterface callee(funit, *this);6218 mlir::func::FuncOp func = callee.addEntryBlockAndMapArguments();6219 builder =6220 new fir::FirOpBuilder(func, bridge.getKindMap(), &mlirSymbolTable);6221 assert(builder && "FirOpBuilder did not instantiate");6222 builder->setComplexDivisionToRuntimeFlag(6223 bridge.getLoweringOptions().getComplexDivisionToRuntime());6224 builder->setFastMathFlags(bridge.getLoweringOptions().getMathOptions());6225 builder->setInsertionPointToStart(&func.front());6226 if (funit.parent.isA<Fortran::lower::pft::FunctionLikeUnit>()) {6227 // Give internal linkage to internal functions. There are no name clash6228 // risks, but giving global linkage to internal procedure will break the6229 // static link register in shared libraries because of the system calls.6230 // Also, it should be possible to eliminate the procedure code if all the6231 // uses have been inlined.6232 fir::factory::setInternalLinkage(func);6233 } else {6234 func.setVisibility(mlir::SymbolTable::Visibility::Public);6235 }6236 assert(blockId == 0 && "invalid blockId");6237 assert(activeConstructStack.empty() && "invalid construct stack state");6238 6239 // Manage floating point exception, halting mode, and rounding mode6240 // settings at function entry and exit.6241 if (!funit.isMainProgram())6242 manageFPEnvironment(funit);6243 6244 mapDummiesAndResults(funit, callee);6245 6246 // Map host associated symbols from parent procedure if any.6247 if (funit.parentHasHostAssoc())6248 funit.parentHostAssoc().internalProcedureBindings(*this, localSymbols);6249 6250 // Non-primary results of a function with multiple entry points.6251 // These result values share storage with the primary result.6252 llvm::SmallVector<Fortran::lower::pft::Variable> deferredFuncResultList;6253 6254 // Backup actual argument for entry character results with different6255 // lengths. It needs to be added to the non-primary results symbol before6256 // mapSymbolAttributes is called.6257 Fortran::lower::SymbolBox resultArg;6258 if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>6259 passedResult = callee.getPassedResult())6260 resultArg = lookupSymbol(passedResult->entity->get());6261 6262 Fortran::lower::AggregateStoreMap storeMap;6263 6264 // Map all containing submodule and module equivalences and variables, in6265 // case they are referenced. It might be better to limit this to variables6266 // that are actually referenced, although that is more complicated when6267 // there are equivalenced variables.6268 auto &scopeVariableListMap =6269 Fortran::lower::pft::getScopeVariableListMap(funit);6270 for (auto *scp = &scope.parent(); !scp->IsGlobal(); scp = &scp->parent())6271 if (scp->kind() == Fortran::semantics::Scope::Kind::Module)6272 for (const auto &var : Fortran::lower::pft::getScopeVariableList(6273 *scp, scopeVariableListMap))6274 if (!var.isRuntimeTypeInfoData())6275 instantiateVar(var, storeMap);6276 6277 // Map function equivalences and variables.6278 mlir::Value primaryFuncResultStorage;6279 for (const Fortran::lower::pft::Variable &var :6280 Fortran::lower::pft::getScopeVariableList(scope)) {6281 // Always instantiate aggregate storage blocks.6282 if (var.isAggregateStore()) {6283 instantiateVar(var, storeMap);6284 continue;6285 }6286 const Fortran::semantics::Symbol &sym = var.getSymbol();6287 if (funit.parentHasHostAssoc()) {6288 // Never instantiate host associated variables, as they are already6289 // instantiated from an argument tuple. Instead, just bind the symbol6290 // to the host variable, which must be in the map.6291 const Fortran::semantics::Symbol &ultimate = sym.GetUltimate();6292 if (funit.parentHostAssoc().isAssociated(ultimate)) {6293 copySymbolBinding(ultimate, sym);6294 continue;6295 }6296 }6297 if (!sym.IsFuncResult() || !funit.primaryResult) {6298 instantiateVar(var, storeMap);6299 } else if (&sym == funit.primaryResult) {6300 instantiateVar(var, storeMap);6301 primaryFuncResultStorage = getSymbolAddress(sym);6302 } else {6303 deferredFuncResultList.push_back(var);6304 }6305 }6306 6307 // TODO: should use same mechanism as equivalence?6308 // One blocking point is character entry returns that need special handling6309 // since they are not locally allocated but come as argument. CHARACTER(*)6310 // is not something that fits well with equivalence lowering.6311 for (const Fortran::lower::pft::Variable &altResult :6312 deferredFuncResultList) {6313 Fortran::lower::StatementContext stmtCtx;6314 if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>6315 passedResult = callee.getPassedResult()) {6316 mapBlockArgToDummyOrResult(altResult.getSymbol(), resultArg.getAddr(),6317 /*isResult=*/true);6318 Fortran::lower::mapSymbolAttributes(*this, altResult, localSymbols,6319 stmtCtx);6320 } else {6321 // catch cases where the allocation for the function result storage type6322 // doesn't match the type of this symbol6323 mlir::Value preAlloc = primaryFuncResultStorage;6324 mlir::Type resTy = primaryFuncResultStorage.getType();6325 mlir::Type symTy = genType(altResult);6326 mlir::Type wrappedSymTy = fir::ReferenceType::get(symTy);6327 if (resTy != wrappedSymTy) {6328 // check size of the pointed to type so we can't overflow by writing6329 // double precision to a single precision allocation, etc6330 [[maybe_unused]] auto getBitWidth = [this](mlir::Type ty) {6331 // 15.6.2.6.3: differering result types should be integer, real,6332 // complex or logical6333 if (auto cmplx = mlir::dyn_cast_or_null<mlir::ComplexType>(ty))6334 return 2 * cmplx.getElementType().getIntOrFloatBitWidth();6335 if (auto logical = mlir::dyn_cast_or_null<fir::LogicalType>(ty)) {6336 fir::KindTy kind = logical.getFKind();6337 return builder->getKindMap().getLogicalBitsize(kind);6338 }6339 return ty.getIntOrFloatBitWidth();6340 };6341 assert(getBitWidth(fir::unwrapRefType(resTy)) >= getBitWidth(symTy));6342 6343 // convert the storage to the symbol type so that the hlfir.declare6344 // gets the correct type for this symbol6345 preAlloc = fir::ConvertOp::create(*builder, getCurrentLocation(),6346 wrappedSymTy, preAlloc);6347 }6348 6349 Fortran::lower::mapSymbolAttributes(*this, altResult, localSymbols,6350 stmtCtx, preAlloc);6351 }6352 }6353 6354 // If this is a host procedure with host associations, then create the tuple6355 // of pointers for passing to the internal procedures.6356 if (!funit.getHostAssoc().empty())6357 funit.getHostAssoc().hostProcedureBindings(*this, localSymbols);6358 6359 // Unregister all dummy symbols, so that their cloning (e.g. for OpenMP6360 // privatization) does not create the cloned hlfir.declare operations6361 // with dummy_scope operands.6362 resetRegisteredDummySymbols();6363 6364 // Create most function blocks in advance.6365 createEmptyBlocks(funit.evaluationList);6366 6367 // Reinstate entry block as the current insertion point.6368 builder->setInsertionPointToEnd(&func.front());6369 6370 if (callee.hasAlternateReturns()) {6371 // Create a local temp to hold the alternate return index.6372 // Give it an integer index type and the subroutine name (for dumps).6373 // Attach it to the subroutine symbol in the localSymbols map.6374 // Initialize it to zero, the "fallthrough" alternate return value.6375 const Fortran::semantics::Symbol &symbol = funit.getSubprogramSymbol();6376 mlir::Location loc = toLocation();6377 mlir::Type idxTy = builder->getIndexType();6378 mlir::Value altResult =6379 builder->createTemporary(loc, idxTy, toStringRef(symbol.name()));6380 addSymbol(symbol, altResult);6381 mlir::Value zero = builder->createIntegerConstant(loc, idxTy, 0);6382 fir::StoreOp::create(*builder, loc, zero, altResult);6383 }6384 6385 if (Fortran::lower::pft::Evaluation *alternateEntryEval =6386 funit.getEntryEval())6387 genBranch(alternateEntryEval->lexicalSuccessor->block);6388 }6389 6390 /// Create global blocks for the current function. This eliminates the6391 /// distinction between forward and backward targets when generating6392 /// branches. A block is "global" if it can be the target of a GOTO or6393 /// other source code branch. A block that can only be targeted by a6394 /// compiler generated branch is "local". For example, a DO loop preheader6395 /// block containing loop initialization code is global. A loop header6396 /// block, which is the target of the loop back edge, is local. Blocks6397 /// belong to a region. Any block within a nested region must be replaced6398 /// with a block belonging to that region. Branches may not cross region6399 /// boundaries.6400 void createEmptyBlocks(6401 std::list<Fortran::lower::pft::Evaluation> &evaluationList) {6402 mlir::Region *region = &builder->getRegion();6403 for (Fortran::lower::pft::Evaluation &eval : evaluationList) {6404 if (eval.isNewBlock)6405 eval.block = builder->createBlock(region);6406 if (eval.isConstruct() || eval.isDirective()) {6407 if (eval.lowerAsUnstructured()) {6408 createEmptyBlocks(eval.getNestedEvaluations());6409 } else if (eval.hasNestedEvaluations()) {6410 // A structured construct that is a target starts a new block.6411 Fortran::lower::pft::Evaluation &constructStmt =6412 eval.getFirstNestedEvaluation();6413 if (constructStmt.isNewBlock)6414 constructStmt.block = builder->createBlock(region);6415 }6416 }6417 }6418 }6419 6420 /// Return the predicate: "current block does not have a terminator branch".6421 bool blockIsUnterminated() {6422 mlir::Block *currentBlock = builder->getBlock();6423 return currentBlock->empty() ||6424 !currentBlock->back().hasTrait<mlir::OpTrait::IsTerminator>();6425 }6426 6427 /// Unconditionally switch code insertion to a new block.6428 void startBlock(mlir::Block *newBlock) {6429 assert(newBlock && "missing block");6430 // Default termination for the current block is a fallthrough branch to6431 // the new block.6432 if (blockIsUnterminated())6433 genBranch(newBlock);6434 // Some blocks may be re/started more than once, and might not be empty.6435 // If the new block already has (only) a terminator, set the insertion6436 // point to the start of the block. Otherwise set it to the end.6437 builder->setInsertionPointToStart(newBlock);6438 if (blockIsUnterminated())6439 builder->setInsertionPointToEnd(newBlock);6440 }6441 6442 /// Conditionally switch code insertion to a new block.6443 void maybeStartBlock(mlir::Block *newBlock) {6444 if (newBlock)6445 startBlock(newBlock);6446 }6447 6448 void eraseDeadCodeAndBlocks(mlir::RewriterBase &rewriter,6449 llvm::MutableArrayRef<mlir::Region> regions) {6450 // WARNING: Do not add passes that can do folding or code motion here6451 // because they might cross omp.target region boundaries, which can result6452 // in incorrect code. Optimization passes like these must be added after6453 // OMP early outlining has been done.6454 (void)mlir::eraseUnreachableBlocks(rewriter, regions);6455 (void)mlir::runRegionDCE(rewriter, regions);6456 }6457 6458 /// Finish translation of a function.6459 void endNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {6460 setCurrentPosition(Fortran::lower::pft::stmtSourceLoc(funit.endStmt));6461 if (funit.isMainProgram()) {6462 genExitRoutine(false);6463 } else {6464 genFIRProcedureExit(funit, funit.getSubprogramSymbol());6465 }6466 funit.finalBlock = nullptr;6467 LLVM_DEBUG(llvm::dbgs() << "\n[bridge - endNewFunction";6468 if (auto *sym = funit.scope->symbol()) llvm::dbgs()6469 << " " << sym->name();6470 llvm::dbgs() << "] generated IR:\n\n"6471 << *builder->getFunction() << '\n');6472 // Eliminate dead code as a prerequisite to calling other IR passes.6473 // FIXME: This simplification should happen in a normal pass, not here.6474 mlir::IRRewriter rewriter(*builder);6475 (void)eraseDeadCodeAndBlocks(rewriter, {builder->getRegion()});6476 delete builder;6477 builder = nullptr;6478 hostAssocTuple = mlir::Value{};6479 localSymbols.clear();6480 blockId = 0;6481 dummyArgsScope = mlir::Value{};6482 resetRegisteredDummySymbols();6483 }6484 6485 /// Helper to generate GlobalOps when the builder is not positioned in any6486 /// region block. This is required because the FirOpBuilder assumes it is6487 /// always positioned inside a region block when creating globals, the easiest6488 /// way to comply is to create a dummy function and to throw it away6489 /// afterwards.6490 void createBuilderOutsideOfFuncOpAndDo(6491 const std::function<void()> &createGlobals) {6492 // FIXME: get rid of the bogus function context and instantiate the6493 // globals directly into the module.6494 mlir::MLIRContext *context = &getMLIRContext();6495 mlir::SymbolTable *symbolTable = getMLIRSymbolTable();6496 mlir::func::FuncOp func = fir::FirOpBuilder::createFunction(6497 mlir::UnknownLoc::get(context), getModuleOp(),6498 fir::NameUniquer::doGenerated("Sham"),6499 mlir::FunctionType::get(context, {}, {}), symbolTable);6500 func.addEntryBlock();6501 CHECK(!builder && "Expected builder to be uninitialized");6502 builder = new fir::FirOpBuilder(func, bridge.getKindMap(), symbolTable);6503 assert(builder && "FirOpBuilder did not instantiate");6504 builder->setFastMathFlags(bridge.getLoweringOptions().getMathOptions());6505 createGlobals();6506 if (mlir::Region *region = func.getCallableRegion())6507 region->dropAllReferences();6508 func.erase();6509 delete builder;6510 builder = nullptr;6511 localSymbols.clear();6512 resetRegisteredDummySymbols();6513 }6514 6515 /// Instantiate the data from a BLOCK DATA unit.6516 void lowerBlockData(Fortran::lower::pft::BlockDataUnit &bdunit) {6517 createBuilderOutsideOfFuncOpAndDo([&]() {6518 Fortran::lower::AggregateStoreMap fakeMap;6519 for (const auto &[_, sym] : bdunit.symTab) {6520 if (sym->has<Fortran::semantics::ObjectEntityDetails>()) {6521 Fortran::lower::pft::Variable var(*sym, true);6522 instantiateVar(var, fakeMap);6523 }6524 }6525 });6526 }6527 6528 /// Create fir::Global for all the common blocks that appear in the program.6529 void6530 lowerCommonBlocks(const Fortran::semantics::CommonBlockList &commonBlocks) {6531 createBuilderOutsideOfFuncOpAndDo(6532 [&]() { Fortran::lower::defineCommonBlocks(*this, commonBlocks); });6533 }6534 6535 /// Create intrinsic module array constant definitions.6536 void createIntrinsicModuleDefinitions(Fortran::lower::pft::Program &pft) {6537 // The intrinsic module scope, if present, is the first scope.6538 const Fortran::semantics::Scope *intrinsicModuleScope = nullptr;6539 for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) {6540 Fortran::common::visit(6541 Fortran::common::visitors{6542 [&](Fortran::lower::pft::FunctionLikeUnit &f) {6543 intrinsicModuleScope = &f.getScope().parent();6544 },6545 [&](Fortran::lower::pft::ModuleLikeUnit &m) {6546 intrinsicModuleScope = &m.getScope().parent();6547 },6548 [&](Fortran::lower::pft::BlockDataUnit &b) {},6549 [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {},6550 [&](Fortran::lower::pft::OpenACCDirectiveUnit &d) {},6551 },6552 u);6553 if (intrinsicModuleScope) {6554 while (!intrinsicModuleScope->IsGlobal())6555 intrinsicModuleScope = &intrinsicModuleScope->parent();6556 intrinsicModuleScope = &intrinsicModuleScope->children().front();6557 break;6558 }6559 }6560 if (!intrinsicModuleScope || !intrinsicModuleScope->IsIntrinsicModules())6561 return;6562 for (const auto &scope : intrinsicModuleScope->children()) {6563 llvm::StringRef modName = toStringRef(scope.symbol()->name());6564 if (modName != "__fortran_ieee_exceptions")6565 continue;6566 for (auto &var : Fortran::lower::pft::getScopeVariableList(scope)) {6567 const Fortran::semantics::Symbol &sym = var.getSymbol();6568 if (sym.test(Fortran::semantics::Symbol::Flag::CompilerCreated))6569 continue;6570 const auto *object =6571 sym.detailsIf<Fortran::semantics::ObjectEntityDetails>();6572 if (object && object->IsArray() && object->init())6573 Fortran::lower::createIntrinsicModuleGlobal(*this, var);6574 }6575 }6576 }6577 6578 /// Lower a procedure (nest).6579 void lowerFunc(Fortran::lower::pft::FunctionLikeUnit &funit) {6580 setCurrentPosition(funit.getStartingSourceLoc());6581 setCurrentFunctionUnit(&funit);6582 for (int entryIndex = 0, last = funit.entryPointList.size();6583 entryIndex < last; ++entryIndex) {6584 funit.setActiveEntry(entryIndex);6585 startNewFunction(funit); // the entry point for lowering this procedure6586 for (Fortran::lower::pft::Evaluation &eval : funit.evaluationList)6587 genFIR(eval);6588 endNewFunction(funit);6589 }6590 funit.setActiveEntry(0);6591 setCurrentFunctionUnit(nullptr);6592 for (Fortran::lower::pft::ContainedUnit &unit : funit.containedUnitList)6593 if (auto *f = std::get_if<Fortran::lower::pft::FunctionLikeUnit>(&unit))6594 lowerFunc(*f); // internal procedure6595 }6596 6597 /// Lower module variable definitions to fir::globalOp and OpenMP/OpenACC6598 /// declarative construct.6599 void lowerModuleDeclScope(Fortran::lower::pft::ModuleLikeUnit &mod) {6600 setCurrentPosition(mod.getStartingSourceLoc());6601 auto &scopeVariableListMap =6602 Fortran::lower::pft::getScopeVariableListMap(mod);6603 for (const auto &var : Fortran::lower::pft::getScopeVariableList(6604 mod.getScope(), scopeVariableListMap)) {6605 6606 // Only define the variables owned by this module.6607 const Fortran::semantics::Scope *owningScope = var.getOwningScope();6608 if (owningScope && mod.getScope() != *owningScope)6609 continue;6610 6611 // Very special case: The value of numeric_storage_size depends on6612 // compilation options and therefore its value is not yet known when6613 // building the builtins runtime. Instead, the parameter is folding a6614 // __numeric_storage_size() expression which is loaded into the user6615 // program. For the iso_fortran_env object file, omit the symbol as it6616 // is never used.6617 if (var.hasSymbol()) {6618 const Fortran::semantics::Symbol &sym = var.getSymbol();6619 const Fortran::semantics::Scope &owner = sym.owner();6620 if (sym.name() == "numeric_storage_size" && owner.IsModule() &&6621 DEREF(owner.symbol()).name() == "iso_fortran_env")6622 continue;6623 }6624 6625 Fortran::lower::defineModuleVariable(*this, var);6626 }6627 for (auto &eval : mod.evaluationList)6628 genFIR(eval);6629 }6630 6631 /// Lower functions contained in a module.6632 void lowerMod(Fortran::lower::pft::ModuleLikeUnit &mod) {6633 for (Fortran::lower::pft::ContainedUnit &unit : mod.containedUnitList)6634 if (auto *f = std::get_if<Fortran::lower::pft::FunctionLikeUnit>(&unit))6635 lowerFunc(*f);6636 }6637 6638 void setCurrentPosition(const Fortran::parser::CharBlock &position) {6639 if (position != Fortran::parser::CharBlock{})6640 currentPosition = position;6641 }6642 6643 /// Set current position at the location of \p parseTreeNode. Note that the6644 /// position is updated automatically when visiting statements, but not when6645 /// entering higher level nodes like constructs or procedures. This helper is6646 /// intended to cover the latter cases.6647 template <typename A>6648 void setCurrentPositionAt(const A &parseTreeNode) {6649 setCurrentPosition(Fortran::parser::FindSourceLocation(parseTreeNode));6650 }6651 6652 //===--------------------------------------------------------------------===//6653 // Utility methods6654 //===--------------------------------------------------------------------===//6655 6656 /// Convert a parser CharBlock to a Location6657 mlir::Location toLocation(const Fortran::parser::CharBlock &cb) {6658 return genLocation(cb);6659 }6660 6661 mlir::Location toLocation() { return toLocation(currentPosition); }6662 void setCurrentEval(Fortran::lower::pft::Evaluation &eval) {6663 evalPtr = &eval;6664 }6665 Fortran::lower::pft::Evaluation &getEval() {6666 assert(evalPtr);6667 return *evalPtr;6668 }6669 6670 std::optional<Fortran::evaluate::Shape>6671 getShape(const Fortran::lower::SomeExpr &expr) {6672 return Fortran::evaluate::GetShape(foldingContext, expr);6673 }6674 6675 //===--------------------------------------------------------------------===//6676 // Analysis on a nested explicit iteration space.6677 //===--------------------------------------------------------------------===//6678 6679 void analyzeExplicitSpace(const Fortran::parser::ConcurrentHeader &header) {6680 explicitIterSpace.pushLevel();6681 for (const Fortran::parser::ConcurrentControl &ctrl :6682 std::get<std::list<Fortran::parser::ConcurrentControl>>(header.t)) {6683 const Fortran::semantics::Symbol *ctrlVar =6684 std::get<Fortran::parser::Name>(ctrl.t).symbol;6685 explicitIterSpace.addSymbol(ctrlVar);6686 }6687 if (const auto &mask =6688 std::get<std::optional<Fortran::parser::ScalarLogicalExpr>>(6689 header.t);6690 mask.has_value())6691 analyzeExplicitSpace(*Fortran::semantics::GetExpr(*mask));6692 }6693 template <bool LHS = false, typename A>6694 void analyzeExplicitSpace(const Fortran::evaluate::Expr<A> &e) {6695 explicitIterSpace.exprBase(&e, LHS);6696 }6697 void analyzeExplicitSpace(const Fortran::evaluate::Assignment *assign) {6698 auto analyzeAssign = [&](const Fortran::lower::SomeExpr &lhs,6699 const Fortran::lower::SomeExpr &rhs) {6700 analyzeExplicitSpace</*LHS=*/true>(lhs);6701 analyzeExplicitSpace(rhs);6702 };6703 Fortran::common::visit(6704 Fortran::common::visitors{6705 [&](const Fortran::evaluate::ProcedureRef &procRef) {6706 // Ensure the procRef expressions are the one being visited.6707 assert(procRef.arguments().size() == 2);6708 const Fortran::lower::SomeExpr *lhs =6709 procRef.arguments()[0].value().UnwrapExpr();6710 const Fortran::lower::SomeExpr *rhs =6711 procRef.arguments()[1].value().UnwrapExpr();6712 assert(lhs && rhs &&6713 "user defined assignment arguments must be expressions");6714 analyzeAssign(*lhs, *rhs);6715 },6716 [&](const auto &) { analyzeAssign(assign->lhs, assign->rhs); }},6717 assign->u);6718 explicitIterSpace.endAssign();6719 }6720 void analyzeExplicitSpace(const Fortran::parser::ForallAssignmentStmt &stmt) {6721 Fortran::common::visit([&](const auto &s) { analyzeExplicitSpace(s); },6722 stmt.u);6723 }6724 void analyzeExplicitSpace(const Fortran::parser::AssignmentStmt &s) {6725 analyzeExplicitSpace(s.typedAssignment->v.operator->());6726 }6727 void analyzeExplicitSpace(const Fortran::parser::PointerAssignmentStmt &s) {6728 analyzeExplicitSpace(s.typedAssignment->v.operator->());6729 }6730 void analyzeExplicitSpace(const Fortran::parser::WhereConstruct &c) {6731 analyzeExplicitSpace(6732 std::get<6733 Fortran::parser::Statement<Fortran::parser::WhereConstructStmt>>(6734 c.t)6735 .statement);6736 for (const Fortran::parser::WhereBodyConstruct &body :6737 std::get<std::list<Fortran::parser::WhereBodyConstruct>>(c.t))6738 analyzeExplicitSpace(body);6739 for (const Fortran::parser::WhereConstruct::MaskedElsewhere &e :6740 std::get<std::list<Fortran::parser::WhereConstruct::MaskedElsewhere>>(6741 c.t))6742 analyzeExplicitSpace(e);6743 if (const auto &e =6744 std::get<std::optional<Fortran::parser::WhereConstruct::Elsewhere>>(6745 c.t);6746 e.has_value())6747 analyzeExplicitSpace(e.operator->());6748 }6749 void analyzeExplicitSpace(const Fortran::parser::WhereConstructStmt &ws) {6750 const Fortran::lower::SomeExpr *exp = Fortran::semantics::GetExpr(6751 std::get<Fortran::parser::LogicalExpr>(ws.t));6752 addMaskVariable(exp);6753 analyzeExplicitSpace(*exp);6754 }6755 void analyzeExplicitSpace(6756 const Fortran::parser::WhereConstruct::MaskedElsewhere &ew) {6757 analyzeExplicitSpace(6758 std::get<6759 Fortran::parser::Statement<Fortran::parser::MaskedElsewhereStmt>>(6760 ew.t)6761 .statement);6762 for (const Fortran::parser::WhereBodyConstruct &e :6763 std::get<std::list<Fortran::parser::WhereBodyConstruct>>(ew.t))6764 analyzeExplicitSpace(e);6765 }6766 void analyzeExplicitSpace(const Fortran::parser::WhereBodyConstruct &body) {6767 Fortran::common::visit(6768 Fortran::common::visitors{6769 [&](const Fortran::common::Indirection<6770 Fortran::parser::WhereConstruct> &wc) {6771 analyzeExplicitSpace(wc.value());6772 },6773 [&](const auto &s) { analyzeExplicitSpace(s.statement); }},6774 body.u);6775 }6776 void analyzeExplicitSpace(const Fortran::parser::MaskedElsewhereStmt &stmt) {6777 const Fortran::lower::SomeExpr *exp = Fortran::semantics::GetExpr(6778 std::get<Fortran::parser::LogicalExpr>(stmt.t));6779 addMaskVariable(exp);6780 analyzeExplicitSpace(*exp);6781 }6782 void6783 analyzeExplicitSpace(const Fortran::parser::WhereConstruct::Elsewhere *ew) {6784 for (const Fortran::parser::WhereBodyConstruct &e :6785 std::get<std::list<Fortran::parser::WhereBodyConstruct>>(ew->t))6786 analyzeExplicitSpace(e);6787 }6788 void analyzeExplicitSpace(const Fortran::parser::WhereStmt &stmt) {6789 const Fortran::lower::SomeExpr *exp = Fortran::semantics::GetExpr(6790 std::get<Fortran::parser::LogicalExpr>(stmt.t));6791 addMaskVariable(exp);6792 analyzeExplicitSpace(*exp);6793 const std::optional<Fortran::evaluate::Assignment> &assign =6794 std::get<Fortran::parser::AssignmentStmt>(stmt.t).typedAssignment->v;6795 assert(assign.has_value() && "WHERE has no statement");6796 analyzeExplicitSpace(assign.operator->());6797 }6798 void analyzeExplicitSpace(const Fortran::parser::ForallStmt &forall) {6799 analyzeExplicitSpace(6800 std::get<6801 Fortran::common::Indirection<Fortran::parser::ConcurrentHeader>>(6802 forall.t)6803 .value());6804 analyzeExplicitSpace(std::get<Fortran::parser::UnlabeledStatement<6805 Fortran::parser::ForallAssignmentStmt>>(forall.t)6806 .statement);6807 analyzeExplicitSpacePop();6808 }6809 void6810 analyzeExplicitSpace(const Fortran::parser::ForallConstructStmt &forall) {6811 analyzeExplicitSpace(6812 std::get<6813 Fortran::common::Indirection<Fortran::parser::ConcurrentHeader>>(6814 forall.t)6815 .value());6816 }6817 void analyzeExplicitSpace(const Fortran::parser::ForallConstruct &forall) {6818 analyzeExplicitSpace(6819 std::get<6820 Fortran::parser::Statement<Fortran::parser::ForallConstructStmt>>(6821 forall.t)6822 .statement);6823 for (const Fortran::parser::ForallBodyConstruct &s :6824 std::get<std::list<Fortran::parser::ForallBodyConstruct>>(forall.t)) {6825 Fortran::common::visit(6826 Fortran::common::visitors{6827 [&](const Fortran::common::Indirection<6828 Fortran::parser::ForallConstruct> &b) {6829 analyzeExplicitSpace(b.value());6830 },6831 [&](const Fortran::parser::WhereConstruct &w) {6832 analyzeExplicitSpace(w);6833 },6834 [&](const auto &b) { analyzeExplicitSpace(b.statement); }},6835 s.u);6836 }6837 analyzeExplicitSpacePop();6838 }6839 6840 void analyzeExplicitSpacePop() { explicitIterSpace.popLevel(); }6841 6842 void addMaskVariable(Fortran::lower::FrontEndExpr exp) {6843 // Note: use i8 to store bool values. This avoids round-down behavior found6844 // with sequences of i1. That is, an array of i1 will be truncated in size6845 // and be too small. For example, a buffer of type fir.array<7xi1> will have6846 // 0 size.6847 mlir::Type i64Ty = builder->getIntegerType(64);6848 mlir::TupleType ty = fir::factory::getRaggedArrayHeaderType(*builder);6849 mlir::Type buffTy = ty.getType(1);6850 mlir::Type shTy = ty.getType(2);6851 mlir::Location loc = toLocation();6852 mlir::Value hdr = builder->createTemporary(loc, ty);6853 // FIXME: Is there a way to create a `zeroinitializer` in LLVM-IR dialect?6854 // For now, explicitly set lazy ragged header to all zeros.6855 // auto nilTup = builder->createNullConstant(loc, ty);6856 // fir::StoreOp::create(*builder, loc, nilTup, hdr);6857 mlir::Type i32Ty = builder->getIntegerType(32);6858 mlir::Value zero = builder->createIntegerConstant(loc, i32Ty, 0);6859 mlir::Value zero64 = builder->createIntegerConstant(loc, i64Ty, 0);6860 mlir::Value flags = fir::CoordinateOp::create(6861 *builder, loc, builder->getRefType(i64Ty), hdr, zero);6862 fir::StoreOp::create(*builder, loc, zero64, flags);6863 mlir::Value one = builder->createIntegerConstant(loc, i32Ty, 1);6864 mlir::Value nullPtr1 = builder->createNullConstant(loc, buffTy);6865 mlir::Value var = fir::CoordinateOp::create(6866 *builder, loc, builder->getRefType(buffTy), hdr, one);6867 fir::StoreOp::create(*builder, loc, nullPtr1, var);6868 mlir::Value two = builder->createIntegerConstant(loc, i32Ty, 2);6869 mlir::Value nullPtr2 = builder->createNullConstant(loc, shTy);6870 mlir::Value shape = fir::CoordinateOp::create(6871 *builder, loc, builder->getRefType(shTy), hdr, two);6872 fir::StoreOp::create(*builder, loc, nullPtr2, shape);6873 implicitIterSpace.addMaskVariable(exp, var, shape, hdr);6874 explicitIterSpace.outermostContext().attachCleanup(6875 [builder = this->builder, hdr, loc]() {6876 fir::runtime::genRaggedArrayDeallocate(loc, *builder, hdr);6877 });6878 }6879 6880 void createRuntimeTypeInfoGlobals() {}6881 6882 bool lowerToHighLevelFIR() const {6883 return bridge.getLoweringOptions().getLowerToHighLevelFIR();6884 }6885 6886 // Returns the mangling prefix for the given constant expression.6887 std::string getConstantExprManglePrefix(mlir::Location loc,6888 const Fortran::lower::SomeExpr &expr,6889 mlir::Type eleTy) {6890 return Fortran::common::visit(6891 [&](const auto &x) -> std::string {6892 using T = std::decay_t<decltype(x)>;6893 if constexpr (Fortran::common::HasMember<6894 T, Fortran::lower::CategoryExpression>) {6895 if constexpr (T::Result::category ==6896 Fortran::common::TypeCategory::Derived) {6897 if (const auto *constant =6898 std::get_if<Fortran::evaluate::Constant<6899 Fortran::evaluate::SomeDerived>>(&x.u))6900 return Fortran::lower::mangle::mangleArrayLiteral(eleTy,6901 *constant);6902 fir::emitFatalError(loc,6903 "non a constant derived type expression");6904 } else {6905 return Fortran::common::visit(6906 [&](const auto &someKind) -> std::string {6907 using T = std::decay_t<decltype(someKind)>;6908 using TK = Fortran::evaluate::Type<T::Result::category,6909 T::Result::kind>;6910 if (const auto *constant =6911 std::get_if<Fortran::evaluate::Constant<TK>>(6912 &someKind.u)) {6913 return Fortran::lower::mangle::mangleArrayLiteral(6914 nullptr, *constant);6915 }6916 fir::emitFatalError(6917 loc, "not a Fortran::evaluate::Constant<T> expression");6918 return {};6919 },6920 x.u);6921 }6922 } else {6923 fir::emitFatalError(loc, "unexpected expression");6924 }6925 },6926 expr.u);6927 }6928 6929 /// Performing OpenMP lowering actions that were deferred to the end of6930 /// lowering.6931 void finalizeOpenMPLowering(6932 const Fortran::semantics::Symbol *globalOmpRequiresSymbol) {6933 if (!ompDeferredDeclareTarget.empty()) {6934 bool deferredDeviceFuncFound =6935 Fortran::lower::markOpenMPDeferredDeclareTargetFunctions(6936 getModuleOp().getOperation(), ompDeferredDeclareTarget, *this);6937 ompDeviceCodeFound = ompDeviceCodeFound || deferredDeviceFuncFound;6938 }6939 6940 // Set the module attribute related to OpenMP requires directives6941 if (ompDeviceCodeFound)6942 Fortran::lower::genOpenMPRequires(getModuleOp().getOperation(),6943 globalOmpRequiresSymbol);6944 }6945 6946 /// Record fir.dummy_scope operation for this function.6947 /// It will be used to set dummy_scope operand of the hlfir.declare6948 /// operations.6949 void setDummyArgsScope(mlir::Value val) {6950 assert(!dummyArgsScope && val);6951 dummyArgsScope = val;6952 }6953 6954 /// Record the given symbol as a dummy argument of this function.6955 /// \param symRef The symbol representing the dummy argument6956 /// \param argNo The 1-based position of this argument in the source (0 =6957 /// unknown)6958 void registerDummySymbol(Fortran::semantics::SymbolRef symRef,6959 unsigned argNo = 0) {6960 auto *sym = &*symRef;6961 registeredDummySymbols.insert(sym);6962 if (argNo > 0)6963 dummyArgPositions[sym] = argNo;6964 }6965 6966 /// Reset all registered dummy symbols.6967 void resetRegisteredDummySymbols() {6968 registeredDummySymbols.clear();6969 dummyArgPositions.clear();6970 }6971 6972 void setCurrentFunctionUnit(Fortran::lower::pft::FunctionLikeUnit *unit) {6973 currentFunctionUnit = unit;6974 }6975 6976 //===--------------------------------------------------------------------===//6977 6978 Fortran::lower::LoweringBridge &bridge;6979 Fortran::evaluate::FoldingContext foldingContext;6980 fir::FirOpBuilder *builder = nullptr;6981 Fortran::lower::pft::Evaluation *evalPtr = nullptr;6982 Fortran::lower::pft::FunctionLikeUnit *currentFunctionUnit = nullptr;6983 Fortran::lower::SymMap localSymbols;6984 Fortran::parser::CharBlock currentPosition;6985 TypeInfoConverter typeInfoConverter;6986 6987 // Stack to manage object deallocation and finalization at construct exits.6988 llvm::SmallVector<ConstructContext> activeConstructStack;6989 6990 /// BLOCK name mangling component map6991 int blockId = 0;6992 Fortran::lower::mangle::ScopeBlockIdMap scopeBlockIdMap;6993 6994 /// FORALL statement/construct context6995 Fortran::lower::ExplicitIterSpace explicitIterSpace;6996 6997 /// WHERE statement/construct mask expression stack6998 Fortran::lower::ImplicitIterSpace implicitIterSpace;6999 7000 /// Tuple of host associated variables7001 mlir::Value hostAssocTuple;7002 7003 /// Value of fir.dummy_scope operation for this function.7004 mlir::Value dummyArgsScope;7005 7006 /// A set of dummy argument symbols for this function.7007 /// The set is only preserved during the instatiation7008 /// of variables for this function.7009 llvm::SmallPtrSet<const Fortran::semantics::Symbol *, 16>7010 registeredDummySymbols;7011 7012 /// Map from dummy symbols to their 1-based argument positions.7013 /// Used to generate debug info with correct argument numbers.7014 llvm::DenseMap<const Fortran::semantics::Symbol *, unsigned>7015 dummyArgPositions;7016 7017 /// A map of unique names for constant expressions.7018 /// The names are used for representing the constant expressions7019 /// with global constant initialized objects.7020 /// The names are usually prefixed by a mangling string based7021 /// on the element type of the constant expression, but the element7022 /// type is not used as a key into the map (so the assumption is that7023 /// the equivalent constant expressions are prefixed using the same7024 /// element type).7025 llvm::DenseMap<const Fortran::lower::SomeExpr *, std::string> literalNamesMap;7026 7027 /// Storage for Constant expressions used as keys for literalNamesMap.7028 llvm::SmallVector<std::unique_ptr<Fortran::lower::SomeExpr>>7029 literalExprsStorage;7030 7031 /// A counter for uniquing names in `literalNamesMap`.7032 std::uint64_t uniqueLitId = 0;7033 7034 /// Whether an OpenMP target region or declare target function/subroutine7035 /// intended for device offloading has been detected7036 bool ompDeviceCodeFound = false;7037 7038 /// Keeps track of symbols defined as declare target that could not be7039 /// processed at the time of lowering the declare target construct, such7040 /// as certain cases where interfaces are declared but not defined within7041 /// a module.7042 llvm::SmallVector<Fortran::lower::OMPDeferredDeclareTargetInfo>7043 ompDeferredDeclareTarget;7044 7045 const Fortran::lower::ExprToValueMap *exprValueOverrides{nullptr};7046 7047 /// Stack of derived type under construction to avoid infinite loops when7048 /// dealing with recursive derived types. This is held in the bridge because7049 /// the state needs to be maintained between data and function type lowering7050 /// utilities to deal with procedure pointer components whose arguments have7051 /// the type of the containing derived type.7052 Fortran::lower::TypeConstructionStack typeConstructionStack;7053 /// MLIR symbol table of the fir.global/func.func operations. Note that it is7054 /// not guaranteed to contain all operations of the ModuleOp with Symbol7055 /// attribute since mlirSymbolTable must pro-actively be maintained when7056 /// new Symbol operations are created.7057 mlir::SymbolTable mlirSymbolTable;7058 7059 /// Used to store context while recursing into regions during lowering.7060 mlir::StateStack stateStack;7061};7062 7063} // namespace7064 7065Fortran::evaluate::FoldingContext7066Fortran::lower::LoweringBridge::createFoldingContext() {7067 return {getDefaultKinds(), getIntrinsicTable(), getTargetCharacteristics(),7068 getLanguageFeatures(), tempNames};7069}7070 7071void Fortran::lower::LoweringBridge::lower(7072 const Fortran::parser::Program &prg,7073 const Fortran::semantics::SemanticsContext &semanticsContext) {7074 std::unique_ptr<Fortran::lower::pft::Program> pft =7075 Fortran::lower::createPFT(prg, semanticsContext);7076 FirConverter converter{*this};7077 converter.run(*pft);7078}7079 7080void Fortran::lower::LoweringBridge::parseSourceFile(llvm::SourceMgr &srcMgr) {7081 module = mlir::parseSourceFile<mlir::ModuleOp>(srcMgr, &context);7082}7083 7084Fortran::lower::LoweringBridge::LoweringBridge(7085 mlir::MLIRContext &context,7086 Fortran::semantics::SemanticsContext &semanticsContext,7087 const Fortran::common::IntrinsicTypeDefaultKinds &defaultKinds,7088 const Fortran::evaluate::IntrinsicProcTable &intrinsics,7089 const Fortran::evaluate::TargetCharacteristics &targetCharacteristics,7090 const Fortran::parser::AllCookedSources &cooked, llvm::StringRef triple,7091 fir::KindMapping &kindMap,7092 const Fortran::lower::LoweringOptions &loweringOptions,7093 const std::vector<Fortran::lower::EnvironmentDefault> &envDefaults,7094 const Fortran::common::LanguageFeatureControl &languageFeatures,7095 const llvm::TargetMachine &targetMachine,7096 const Fortran::frontend::TargetOptions &targetOpts,7097 const Fortran::frontend::CodeGenOptions &cgOpts)7098 : semanticsContext{semanticsContext}, defaultKinds{defaultKinds},7099 intrinsics{intrinsics}, targetCharacteristics{targetCharacteristics},7100 cooked{&cooked}, context{context}, kindMap{kindMap},7101 loweringOptions{loweringOptions}, envDefaults{envDefaults},7102 languageFeatures{languageFeatures} {7103 // Register the diagnostic handler.7104 if (loweringOptions.getRegisterMLIRDiagnosticsHandler()) {7105 diagHandlerID =7106 context.getDiagEngine().registerHandler([](mlir::Diagnostic &diag) {7107 llvm::raw_ostream &os = llvm::errs();7108 switch (diag.getSeverity()) {7109 case mlir::DiagnosticSeverity::Error:7110 os << "error: ";7111 break;7112 case mlir::DiagnosticSeverity::Remark:7113 os << "info: ";7114 break;7115 case mlir::DiagnosticSeverity::Warning:7116 os << "warning: ";7117 break;7118 default:7119 break;7120 }7121 if (!mlir::isa<mlir::UnknownLoc>(diag.getLocation()))7122 os << diag.getLocation() << ": ";7123 os << diag << '\n';7124 os.flush();7125 return mlir::success();7126 });7127 }7128 7129 auto getPathLocation = [&semanticsContext, &context]() -> mlir::Location {7130 std::optional<std::string> path;7131 const auto &allSources{semanticsContext.allCookedSources().allSources()};7132 if (auto initial{allSources.GetFirstFileProvenance()};7133 initial && !initial->empty()) {7134 if (const auto *sourceFile{allSources.GetSourceFile(initial->start())}) {7135 path = sourceFile->path();7136 }7137 }7138 7139 if (path.has_value()) {7140 llvm::SmallString<256> curPath(*path);7141 llvm::sys::fs::make_absolute(curPath);7142 llvm::sys::path::remove_dots(curPath);7143 return mlir::FileLineColLoc::get(&context, curPath.str(), /*line=*/0,7144 /*col=*/0);7145 } else {7146 return mlir::UnknownLoc::get(&context);7147 }7148 };7149 7150 // Create the module and attach the attributes.7151 module = mlir::OwningOpRef<mlir::ModuleOp>(7152 mlir::ModuleOp::create(getPathLocation()));7153 assert(*module && "module was not created");7154 fir::setTargetTriple(*module, triple);7155 fir::setKindMapping(*module, kindMap);7156 fir::setTargetCPU(*module, targetMachine.getTargetCPU());7157 fir::setTuneCPU(*module, targetOpts.cpuToTuneFor);7158 fir::setAtomicIgnoreDenormalMode(*module,7159 targetOpts.atomicIgnoreDenormalMode);7160 fir::setAtomicFineGrainedMemory(*module, targetOpts.atomicFineGrainedMemory);7161 fir::setAtomicRemoteMemory(*module, targetOpts.atomicRemoteMemory);7162 fir::setTargetFeatures(*module, targetMachine.getTargetFeatureString());7163 fir::support::setMLIRDataLayout(*module, targetMachine.createDataLayout());7164 fir::setIdent(*module, Fortran::common::getFlangFullVersion());7165 if (cgOpts.RecordCommandLine)7166 fir::setCommandline(*module, *cgOpts.RecordCommandLine);7167}7168 7169Fortran::lower::LoweringBridge::~LoweringBridge() {7170 if (diagHandlerID)7171 context.getDiagEngine().eraseHandler(*diagHandlerID);7172}7173 7174void Fortran::lower::genCleanUpInRegionIfAny(7175 mlir::Location loc, fir::FirOpBuilder &builder, mlir::Region ®ion,7176 Fortran::lower::StatementContext &context) {7177 if (!context.hasCode())7178 return;7179 mlir::OpBuilder::InsertPoint insertPt = builder.saveInsertionPoint();7180 if (region.empty())7181 builder.createBlock(®ion);7182 else7183 builder.setInsertionPointToEnd(®ion.front());7184 context.finalizeAndPop();7185 hlfir::YieldOp::ensureTerminator(region, builder, loc);7186 builder.restoreInsertionPoint(insertPt);7187}7188