| //===-- Bridge.cpp -- bridge to lower to MLIR -----------------------------===// |
| // |
| // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. |
| // See https://llvm.org/LICENSE.txt for license information. |
| // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception |
| // |
| //===----------------------------------------------------------------------===// |
| // |
| // Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ |
| // |
| //===----------------------------------------------------------------------===// |
| |
| #include "flang/Lower/Bridge.h" |
| #include "DirectivesCommon.h" |
| #include "flang/Common/Version.h" |
| #include "flang/Lower/Allocatable.h" |
| #include "flang/Lower/CallInterface.h" |
| #include "flang/Lower/Coarray.h" |
| #include "flang/Lower/ConvertCall.h" |
| #include "flang/Lower/ConvertExpr.h" |
| #include "flang/Lower/ConvertExprToHLFIR.h" |
| #include "flang/Lower/ConvertType.h" |
| #include "flang/Lower/ConvertVariable.h" |
| #include "flang/Lower/Cuda.h" |
| #include "flang/Lower/HostAssociations.h" |
| #include "flang/Lower/IO.h" |
| #include "flang/Lower/IterationSpace.h" |
| #include "flang/Lower/Mangler.h" |
| #include "flang/Lower/OpenACC.h" |
| #include "flang/Lower/OpenMP.h" |
| #include "flang/Lower/PFTBuilder.h" |
| #include "flang/Lower/Runtime.h" |
| #include "flang/Lower/StatementContext.h" |
| #include "flang/Lower/Support/Utils.h" |
| #include "flang/Optimizer/Builder/BoxValue.h" |
| #include "flang/Optimizer/Builder/Character.h" |
| #include "flang/Optimizer/Builder/FIRBuilder.h" |
| #include "flang/Optimizer/Builder/Runtime/Assign.h" |
| #include "flang/Optimizer/Builder/Runtime/Character.h" |
| #include "flang/Optimizer/Builder/Runtime/Derived.h" |
| #include "flang/Optimizer/Builder/Runtime/EnvironmentDefaults.h" |
| #include "flang/Optimizer/Builder/Runtime/Main.h" |
| #include "flang/Optimizer/Builder/Runtime/Ragged.h" |
| #include "flang/Optimizer/Builder/Runtime/Stop.h" |
| #include "flang/Optimizer/Builder/Todo.h" |
| #include "flang/Optimizer/Dialect/CUF/Attributes/CUFAttr.h" |
| #include "flang/Optimizer/Dialect/CUF/CUFOps.h" |
| #include "flang/Optimizer/Dialect/FIRAttr.h" |
| #include "flang/Optimizer/Dialect/FIRDialect.h" |
| #include "flang/Optimizer/Dialect/FIROps.h" |
| #include "flang/Optimizer/Dialect/Support/FIRContext.h" |
| #include "flang/Optimizer/HLFIR/HLFIROps.h" |
| #include "flang/Optimizer/Support/DataLayout.h" |
| #include "flang/Optimizer/Support/FatalError.h" |
| #include "flang/Optimizer/Support/InternalNames.h" |
| #include "flang/Optimizer/Transforms/Passes.h" |
| #include "flang/Parser/parse-tree.h" |
| #include "flang/Runtime/iostat.h" |
| #include "flang/Semantics/runtime-type-info.h" |
| #include "flang/Semantics/symbol.h" |
| #include "flang/Semantics/tools.h" |
| #include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h" |
| #include "mlir/IR/Matchers.h" |
| #include "mlir/IR/PatternMatch.h" |
| #include "mlir/Parser/Parser.h" |
| #include "mlir/Transforms/RegionUtils.h" |
| #include "llvm/ADT/SmallVector.h" |
| #include "llvm/ADT/StringSet.h" |
| #include "llvm/Support/CommandLine.h" |
| #include "llvm/Support/Debug.h" |
| #include "llvm/Support/ErrorHandling.h" |
| #include "llvm/Support/FileSystem.h" |
| #include "llvm/Support/Path.h" |
| #include "llvm/Target/TargetMachine.h" |
| #include <optional> |
| |
| #define DEBUG_TYPE "flang-lower-bridge" |
| |
| static llvm::cl::opt<bool> dumpBeforeFir( |
| "fdebug-dump-pre-fir", llvm::cl::init(false), |
| llvm::cl::desc("dump the Pre-FIR tree prior to FIR generation")); |
| |
| static llvm::cl::opt<bool> forceLoopToExecuteOnce( |
| "always-execute-loop-body", llvm::cl::init(false), |
| llvm::cl::desc("force the body of a loop to execute at least once")); |
| |
| namespace { |
| /// Information for generating a structured or unstructured increment loop. |
| struct IncrementLoopInfo { |
| template <typename T> |
| explicit IncrementLoopInfo(Fortran::semantics::Symbol &sym, const T &lower, |
| const T &upper, const std::optional<T> &step, |
| bool isUnordered = false) |
| : loopVariableSym{&sym}, lowerExpr{Fortran::semantics::GetExpr(lower)}, |
| upperExpr{Fortran::semantics::GetExpr(upper)}, |
| stepExpr{Fortran::semantics::GetExpr(step)}, isUnordered{isUnordered} {} |
| |
| IncrementLoopInfo(IncrementLoopInfo &&) = default; |
| IncrementLoopInfo &operator=(IncrementLoopInfo &&x) = default; |
| |
| bool isStructured() const { return !headerBlock; } |
| |
| mlir::Type getLoopVariableType() const { |
| assert(loopVariable && "must be set"); |
| return fir::unwrapRefType(loopVariable.getType()); |
| } |
| |
| bool hasLocalitySpecs() const { |
| return !localSymList.empty() || !localInitSymList.empty() || |
| !reduceSymList.empty() || !sharedSymList.empty(); |
| } |
| |
| // Data members common to both structured and unstructured loops. |
| const Fortran::semantics::Symbol *loopVariableSym; |
| const Fortran::lower::SomeExpr *lowerExpr; |
| const Fortran::lower::SomeExpr *upperExpr; |
| const Fortran::lower::SomeExpr *stepExpr; |
| const Fortran::lower::SomeExpr *maskExpr = nullptr; |
| bool isUnordered; // do concurrent, forall |
| llvm::SmallVector<const Fortran::semantics::Symbol *> localSymList; |
| llvm::SmallVector<const Fortran::semantics::Symbol *> localInitSymList; |
| llvm::SmallVector< |
| std::pair<fir::ReduceOperationEnum, const Fortran::semantics::Symbol *>> |
| reduceSymList; |
| llvm::SmallVector<const Fortran::semantics::Symbol *> sharedSymList; |
| mlir::Value loopVariable = nullptr; |
| |
| // Data members for structured loops. |
| fir::DoLoopOp doLoop = nullptr; |
| |
| // Data members for unstructured loops. |
| bool hasRealControl = false; |
| mlir::Value tripVariable = nullptr; |
| mlir::Value stepVariable = nullptr; |
| mlir::Block *headerBlock = nullptr; // loop entry and test block |
| mlir::Block *maskBlock = nullptr; // concurrent loop mask block |
| mlir::Block *bodyBlock = nullptr; // first loop body block |
| mlir::Block *exitBlock = nullptr; // loop exit target block |
| }; |
| |
| /// Information to support stack management, object deallocation, and |
| /// object finalization at early and normal construct exits. |
| struct ConstructContext { |
| explicit ConstructContext(Fortran::lower::pft::Evaluation &eval, |
| Fortran::lower::StatementContext &stmtCtx) |
| : eval{eval}, stmtCtx{stmtCtx} {} |
| |
| Fortran::lower::pft::Evaluation &eval; // construct eval |
| Fortran::lower::StatementContext &stmtCtx; // construct exit code |
| std::optional<hlfir::Entity> selector; // construct selector, if any. |
| bool pushedScope = false; // was a scoped pushed for this construct? |
| }; |
| |
| /// Helper to gather the lower bounds of array components with non deferred |
| /// shape when they are not all ones. Return an empty array attribute otherwise. |
| static mlir::DenseI64ArrayAttr |
| gatherComponentNonDefaultLowerBounds(mlir::Location loc, |
| mlir::MLIRContext *mlirContext, |
| const Fortran::semantics::Symbol &sym) { |
| if (Fortran::semantics::IsAllocatableOrObjectPointer(&sym)) |
| return {}; |
| mlir::DenseI64ArrayAttr lbs_attr; |
| if (const auto *objDetails = |
| sym.detailsIf<Fortran::semantics::ObjectEntityDetails>()) { |
| llvm::SmallVector<std::int64_t> lbs; |
| bool hasNonDefaultLbs = false; |
| for (const Fortran::semantics::ShapeSpec &bounds : objDetails->shape()) |
| if (auto lb = bounds.lbound().GetExplicit()) { |
| if (auto constant = Fortran::evaluate::ToInt64(*lb)) { |
| hasNonDefaultLbs |= (*constant != 1); |
| lbs.push_back(*constant); |
| } else { |
| TODO(loc, "generate fir.dt_component for length parametrized derived " |
| "types"); |
| } |
| } |
| if (hasNonDefaultLbs) { |
| assert(static_cast<int>(lbs.size()) == sym.Rank() && |
| "expected component bounds to be constant or deferred"); |
| lbs_attr = mlir::DenseI64ArrayAttr::get(mlirContext, lbs); |
| } |
| } |
| return lbs_attr; |
| } |
| |
| // Helper class to generate name of fir.global containing component explicit |
| // default value for objects, and initial procedure target for procedure pointer |
| // components. |
| static mlir::FlatSymbolRefAttr gatherComponentInit( |
| mlir::Location loc, Fortran::lower::AbstractConverter &converter, |
| const Fortran::semantics::Symbol &sym, fir::RecordType derivedType) { |
| mlir::MLIRContext *mlirContext = &converter.getMLIRContext(); |
| // Return procedure target mangled name for procedure pointer components. |
| if (const auto *procPtr = |
| sym.detailsIf<Fortran::semantics::ProcEntityDetails>()) { |
| if (std::optional<const Fortran::semantics::Symbol *> maybeInitSym = |
| procPtr->init()) { |
| // So far, do not make distinction between p => NULL() and p without init, |
| // f18 always initialize pointers to NULL anyway. |
| if (!*maybeInitSym) |
| return {}; |
| return mlir::FlatSymbolRefAttr::get(mlirContext, |
| converter.mangleName(**maybeInitSym)); |
| } |
| } |
| |
| const auto *objDetails = |
| sym.detailsIf<Fortran::semantics::ObjectEntityDetails>(); |
| if (!objDetails || !objDetails->init().has_value()) |
| return {}; |
| // Object component initial value. Semantic package component object default |
| // value into compiler generated symbols that are lowered as read-only |
| // fir.global. Get the name of this global. |
| std::string name = fir::NameUniquer::getComponentInitName( |
| derivedType.getName(), toStringRef(sym.name())); |
| return mlir::FlatSymbolRefAttr::get(mlirContext, name); |
| } |
| |
| /// Helper class to generate the runtime type info global data and the |
| /// fir.type_info operations that contain the dipatch tables (if any). |
| /// The type info global data is required to describe the derived type to the |
| /// runtime so that it can operate over it. |
| /// It must be ensured these operations will be generated for every derived type |
| /// lowered in the current translated unit. However, these operations |
| /// cannot be generated before FuncOp have been created for functions since the |
| /// initializers may take their address (e.g for type bound procedures). This |
| /// class allows registering all the required type info while it is not |
| /// possible to create GlobalOp/TypeInfoOp, and to generate this data afte |
| /// function lowering. |
| class TypeInfoConverter { |
| /// Store the location and symbols of derived type info to be generated. |
| /// The location of the derived type instantiation is also stored because |
| /// runtime type descriptor symbols are compiler generated and cannot be |
| /// mapped to user code on their own. |
| struct TypeInfo { |
| Fortran::semantics::SymbolRef symbol; |
| const Fortran::semantics::DerivedTypeSpec &typeSpec; |
| fir::RecordType type; |
| mlir::Location loc; |
| }; |
| |
| public: |
| void registerTypeInfo(Fortran::lower::AbstractConverter &converter, |
| mlir::Location loc, |
| Fortran::semantics::SymbolRef typeInfoSym, |
| const Fortran::semantics::DerivedTypeSpec &typeSpec, |
| fir::RecordType type) { |
| if (seen.contains(typeInfoSym)) |
| return; |
| seen.insert(typeInfoSym); |
| currentTypeInfoStack->emplace_back( |
| TypeInfo{typeInfoSym, typeSpec, type, loc}); |
| return; |
| } |
| |
| void createTypeInfo(Fortran::lower::AbstractConverter &converter) { |
| while (!registeredTypeInfoA.empty()) { |
| currentTypeInfoStack = ®isteredTypeInfoB; |
| for (const TypeInfo &info : registeredTypeInfoA) |
| createTypeInfoOpAndGlobal(converter, info); |
| registeredTypeInfoA.clear(); |
| currentTypeInfoStack = ®isteredTypeInfoA; |
| for (const TypeInfo &info : registeredTypeInfoB) |
| createTypeInfoOpAndGlobal(converter, info); |
| registeredTypeInfoB.clear(); |
| } |
| } |
| |
| private: |
| void createTypeInfoOpAndGlobal(Fortran::lower::AbstractConverter &converter, |
| const TypeInfo &info) { |
| Fortran::lower::createRuntimeTypeInfoGlobal(converter, info.symbol.get()); |
| createTypeInfoOp(converter, info); |
| } |
| |
| void createTypeInfoOp(Fortran::lower::AbstractConverter &converter, |
| const TypeInfo &info) { |
| fir::RecordType parentType{}; |
| if (const Fortran::semantics::DerivedTypeSpec *parent = |
| Fortran::evaluate::GetParentTypeSpec(info.typeSpec)) |
| parentType = mlir::cast<fir::RecordType>(converter.genType(*parent)); |
| |
| fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
| fir::TypeInfoOp dt; |
| mlir::OpBuilder::InsertPoint insertPointIfCreated; |
| std::tie(dt, insertPointIfCreated) = |
| builder.createTypeInfoOp(info.loc, info.type, parentType); |
| if (!insertPointIfCreated.isSet()) |
| return; // fir.type_info was already built in a previous call. |
| |
| // Set init, destroy, and nofinal attributes. |
| if (!info.typeSpec.HasDefaultInitialization(/*ignoreAllocatable=*/false, |
| /*ignorePointer=*/false)) |
| dt->setAttr(dt.getNoInitAttrName(), builder.getUnitAttr()); |
| if (!info.typeSpec.HasDestruction()) |
| dt->setAttr(dt.getNoDestroyAttrName(), builder.getUnitAttr()); |
| if (!Fortran::semantics::MayRequireFinalization(info.typeSpec)) |
| dt->setAttr(dt.getNoFinalAttrName(), builder.getUnitAttr()); |
| |
| const Fortran::semantics::Scope &derivedScope = |
| DEREF(info.typeSpec.GetScope()); |
| |
| // Fill binding table region if the derived type has bindings. |
| Fortran::semantics::SymbolVector bindings = |
| Fortran::semantics::CollectBindings(derivedScope); |
| if (!bindings.empty()) { |
| builder.createBlock(&dt.getDispatchTable()); |
| for (const Fortran::semantics::SymbolRef &binding : bindings) { |
| const auto &details = |
| binding.get().get<Fortran::semantics::ProcBindingDetails>(); |
| std::string tbpName = binding.get().name().ToString(); |
| if (details.numPrivatesNotOverridden() > 0) |
| tbpName += "."s + std::to_string(details.numPrivatesNotOverridden()); |
| std::string bindingName = converter.mangleName(details.symbol()); |
| builder.create<fir::DTEntryOp>( |
| info.loc, mlir::StringAttr::get(builder.getContext(), tbpName), |
| mlir::SymbolRefAttr::get(builder.getContext(), bindingName)); |
| } |
| builder.create<fir::FirEndOp>(info.loc); |
| } |
| // Gather info about components that is not reflected in fir.type and may be |
| // needed later: component initial values and array component non default |
| // lower bounds. |
| mlir::Block *componentInfo = nullptr; |
| for (const auto &componentName : |
| info.typeSpec.typeSymbol() |
| .get<Fortran::semantics::DerivedTypeDetails>() |
| .componentNames()) { |
| auto scopeIter = derivedScope.find(componentName); |
| assert(scopeIter != derivedScope.cend() && |
| "failed to find derived type component symbol"); |
| const Fortran::semantics::Symbol &component = scopeIter->second.get(); |
| mlir::FlatSymbolRefAttr init_val = |
| gatherComponentInit(info.loc, converter, component, info.type); |
| mlir::DenseI64ArrayAttr lbs = gatherComponentNonDefaultLowerBounds( |
| info.loc, builder.getContext(), component); |
| if (init_val || lbs) { |
| if (!componentInfo) |
| componentInfo = builder.createBlock(&dt.getComponentInfo()); |
| auto compName = mlir::StringAttr::get(builder.getContext(), |
| toStringRef(component.name())); |
| builder.create<fir::DTComponentOp>(info.loc, compName, lbs, init_val); |
| } |
| } |
| if (componentInfo) |
| builder.create<fir::FirEndOp>(info.loc); |
| builder.restoreInsertionPoint(insertPointIfCreated); |
| } |
| |
| /// Store the front-end data that will be required to generate the type info |
| /// for the derived types that have been converted to fir.type<>. There are |
| /// two stacks since the type info may visit new types, so the new types must |
| /// be added to a new stack. |
| llvm::SmallVector<TypeInfo> registeredTypeInfoA; |
| llvm::SmallVector<TypeInfo> registeredTypeInfoB; |
| llvm::SmallVector<TypeInfo> *currentTypeInfoStack = ®isteredTypeInfoA; |
| /// Track symbols symbols processed during and after the registration |
| /// to avoid infinite loops between type conversions and global variable |
| /// creation. |
| llvm::SmallSetVector<Fortran::semantics::SymbolRef, 32> seen; |
| }; |
| |
| using IncrementLoopNestInfo = llvm::SmallVector<IncrementLoopInfo, 8>; |
| } // namespace |
| |
| //===----------------------------------------------------------------------===// |
| // FirConverter |
| //===----------------------------------------------------------------------===// |
| |
| namespace { |
| |
| /// Traverse the pre-FIR tree (PFT) to generate the FIR dialect of MLIR. |
| class FirConverter : public Fortran::lower::AbstractConverter { |
| public: |
| explicit FirConverter(Fortran::lower::LoweringBridge &bridge) |
| : Fortran::lower::AbstractConverter(bridge.getLoweringOptions()), |
| bridge{bridge}, foldingContext{bridge.createFoldingContext()}, |
| mlirSymbolTable{bridge.getModule()} {} |
| virtual ~FirConverter() = default; |
| |
| /// Convert the PFT to FIR. |
| void run(Fortran::lower::pft::Program &pft) { |
| // Preliminary translation pass. |
| |
| // Lower common blocks, taking into account initialization and the largest |
| // size of all instances of each common block. This is done before lowering |
| // since the global definition may differ from any one local definition. |
| lowerCommonBlocks(pft.getCommonBlocks()); |
| |
| // - Declare all functions that have definitions so that definition |
| // signatures prevail over call site signatures. |
| // - Define module variables and OpenMP/OpenACC declarative constructs so |
| // they are available before lowering any function that may use them. |
| bool hasMainProgram = false; |
| const Fortran::semantics::Symbol *globalOmpRequiresSymbol = nullptr; |
| for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) { |
| Fortran::common::visit( |
| Fortran::common::visitors{ |
| [&](Fortran::lower::pft::FunctionLikeUnit &f) { |
| if (f.isMainProgram()) |
| hasMainProgram = true; |
| declareFunction(f); |
| if (!globalOmpRequiresSymbol) |
| globalOmpRequiresSymbol = f.getScope().symbol(); |
| }, |
| [&](Fortran::lower::pft::ModuleLikeUnit &m) { |
| lowerModuleDeclScope(m); |
| for (Fortran::lower::pft::ContainedUnit &unit : |
| m.containedUnitList) |
| if (auto *f = |
| std::get_if<Fortran::lower::pft::FunctionLikeUnit>( |
| &unit)) |
| declareFunction(*f); |
| }, |
| [&](Fortran::lower::pft::BlockDataUnit &b) { |
| if (!globalOmpRequiresSymbol) |
| globalOmpRequiresSymbol = b.symTab.symbol(); |
| }, |
| [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {}, |
| [&](Fortran::lower::pft::OpenACCDirectiveUnit &d) {}, |
| }, |
| u); |
| } |
| |
| // Create definitions of intrinsic module constants. |
| createGlobalOutsideOfFunctionLowering( |
| [&]() { createIntrinsicModuleDefinitions(pft); }); |
| |
| // Primary translation pass. |
| for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) { |
| Fortran::common::visit( |
| Fortran::common::visitors{ |
| [&](Fortran::lower::pft::FunctionLikeUnit &f) { lowerFunc(f); }, |
| [&](Fortran::lower::pft::ModuleLikeUnit &m) { lowerMod(m); }, |
| [&](Fortran::lower::pft::BlockDataUnit &b) {}, |
| [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {}, |
| [&](Fortran::lower::pft::OpenACCDirectiveUnit &d) { |
| builder = new fir::FirOpBuilder( |
| bridge.getModule(), bridge.getKindMap(), &mlirSymbolTable); |
| Fortran::lower::genOpenACCRoutineConstruct( |
| *this, bridge.getSemanticsContext(), bridge.getModule(), |
| d.routine, accRoutineInfos); |
| builder = nullptr; |
| }, |
| }, |
| u); |
| } |
| |
| // Once all the code has been translated, create global runtime type info |
| // data structures for the derived types that have been processed, as well |
| // as fir.type_info operations for the dispatch tables. |
| createGlobalOutsideOfFunctionLowering( |
| [&]() { typeInfoConverter.createTypeInfo(*this); }); |
| |
| // Generate the `main` entry point if necessary |
| if (hasMainProgram) |
| createGlobalOutsideOfFunctionLowering([&]() { |
| fir::runtime::genMain(*builder, toLocation(), |
| bridge.getEnvironmentDefaults()); |
| }); |
| |
| finalizeOpenACCLowering(); |
| finalizeOpenMPLowering(globalOmpRequiresSymbol); |
| } |
| |
| /// Declare a function. |
| void declareFunction(Fortran::lower::pft::FunctionLikeUnit &funit) { |
| setCurrentPosition(funit.getStartingSourceLoc()); |
| for (int entryIndex = 0, last = funit.entryPointList.size(); |
| entryIndex < last; ++entryIndex) { |
| funit.setActiveEntry(entryIndex); |
| // Calling CalleeInterface ctor will build a declaration |
| // mlir::func::FuncOp with no other side effects. |
| // TODO: when doing some compiler profiling on real apps, it may be worth |
| // to check it's better to save the CalleeInterface instead of recomputing |
| // it later when lowering the body. CalleeInterface ctor should be linear |
| // with the number of arguments, so it is not awful to do it that way for |
| // now, but the linear coefficient might be non negligible. Until |
| // measured, stick to the solution that impacts the code less. |
| Fortran::lower::CalleeInterface{funit, *this}; |
| } |
| funit.setActiveEntry(0); |
| |
| // Compute the set of host associated entities from the nested functions. |
| llvm::SetVector<const Fortran::semantics::Symbol *> escapeHost; |
| for (Fortran::lower::pft::ContainedUnit &unit : funit.containedUnitList) |
| if (auto *f = std::get_if<Fortran::lower::pft::FunctionLikeUnit>(&unit)) |
| collectHostAssociatedVariables(*f, escapeHost); |
| funit.setHostAssociatedSymbols(escapeHost); |
| |
| // Declare internal procedures |
| for (Fortran::lower::pft::ContainedUnit &unit : funit.containedUnitList) |
| if (auto *f = std::get_if<Fortran::lower::pft::FunctionLikeUnit>(&unit)) |
| declareFunction(*f); |
| } |
| |
| /// Get the scope that is defining or using \p sym. The returned scope is not |
| /// the ultimate scope, since this helper does not traverse use association. |
| /// This allows capturing module variables that are referenced in an internal |
| /// procedure but whose use statement is inside the host program. |
| const Fortran::semantics::Scope & |
| getSymbolHostScope(const Fortran::semantics::Symbol &sym) { |
| const Fortran::semantics::Symbol *hostSymbol = &sym; |
| while (const auto *details = |
| hostSymbol->detailsIf<Fortran::semantics::HostAssocDetails>()) |
| hostSymbol = &details->symbol(); |
| return hostSymbol->owner(); |
| } |
| |
| /// Collects the canonical list of all host associated symbols. These bindings |
| /// must be aggregated into a tuple which can then be added to each of the |
| /// internal procedure declarations and passed at each call site. |
| void collectHostAssociatedVariables( |
| Fortran::lower::pft::FunctionLikeUnit &funit, |
| llvm::SetVector<const Fortran::semantics::Symbol *> &escapees) { |
| const Fortran::semantics::Scope *internalScope = |
| funit.getSubprogramSymbol().scope(); |
| assert(internalScope && "internal procedures symbol must create a scope"); |
| auto addToListIfEscapee = [&](const Fortran::semantics::Symbol &sym) { |
| const Fortran::semantics::Symbol &ultimate = sym.GetUltimate(); |
| const auto *namelistDetails = |
| ultimate.detailsIf<Fortran::semantics::NamelistDetails>(); |
| if (ultimate.has<Fortran::semantics::ObjectEntityDetails>() || |
| Fortran::semantics::IsProcedurePointer(ultimate) || |
| Fortran::semantics::IsDummy(sym) || namelistDetails) { |
| const Fortran::semantics::Scope &symbolScope = getSymbolHostScope(sym); |
| if (symbolScope.kind() == |
| Fortran::semantics::Scope::Kind::MainProgram || |
| symbolScope.kind() == Fortran::semantics::Scope::Kind::Subprogram) |
| if (symbolScope != *internalScope && |
| symbolScope.Contains(*internalScope)) { |
| if (namelistDetails) { |
| // So far, namelist symbols are processed on the fly in IO and |
| // the related namelist data structure is not added to the symbol |
| // map, so it cannot be passed to the internal procedures. |
| // Instead, all the symbols of the host namelist used in the |
| // internal procedure must be considered as host associated so |
| // that IO lowering can find them when needed. |
| for (const auto &namelistObject : namelistDetails->objects()) |
| escapees.insert(&*namelistObject); |
| } else { |
| escapees.insert(&ultimate); |
| } |
| } |
| } |
| }; |
| Fortran::lower::pft::visitAllSymbols(funit, addToListIfEscapee); |
| } |
| |
| //===--------------------------------------------------------------------===// |
| // AbstractConverter overrides |
| //===--------------------------------------------------------------------===// |
| |
| mlir::Value getSymbolAddress(Fortran::lower::SymbolRef sym) override final { |
| return lookupSymbol(sym).getAddr(); |
| } |
| |
| fir::ExtendedValue |
| symBoxToExtendedValue(const Fortran::lower::SymbolBox &symBox) { |
| return symBox.match( |
| [](const Fortran::lower::SymbolBox::Intrinsic &box) |
| -> fir::ExtendedValue { return box.getAddr(); }, |
| [](const Fortran::lower::SymbolBox::None &) -> fir::ExtendedValue { |
| llvm::report_fatal_error("symbol not mapped"); |
| }, |
| [&](const fir::FortranVariableOpInterface &x) -> fir::ExtendedValue { |
| return hlfir::translateToExtendedValue(getCurrentLocation(), |
| getFirOpBuilder(), x); |
| }, |
| [](const auto &box) -> fir::ExtendedValue { return box; }); |
| } |
| |
| fir::ExtendedValue |
| getSymbolExtendedValue(const Fortran::semantics::Symbol &sym, |
| Fortran::lower::SymMap *symMap) override final { |
| Fortran::lower::SymbolBox sb = lookupSymbol(sym, symMap); |
| if (!sb) { |
| LLVM_DEBUG(llvm::dbgs() << "unknown symbol: " << sym << "\nmap: " |
| << (symMap ? *symMap : localSymbols) << '\n'); |
| fir::emitFatalError(getCurrentLocation(), |
| "symbol is not mapped to any IR value"); |
| } |
| return symBoxToExtendedValue(sb); |
| } |
| |
| mlir::Value impliedDoBinding(llvm::StringRef name) override final { |
| mlir::Value val = localSymbols.lookupImpliedDo(name); |
| if (!val) |
| fir::emitFatalError(toLocation(), "ac-do-variable has no binding"); |
| return val; |
| } |
| |
| void copySymbolBinding(Fortran::lower::SymbolRef src, |
| Fortran::lower::SymbolRef target) override final { |
| localSymbols.copySymbolBinding(src, target); |
| } |
| |
| /// Add the symbol binding to the inner-most level of the symbol map and |
| /// return true if it is not already present. Otherwise, return false. |
| bool bindIfNewSymbol(Fortran::lower::SymbolRef sym, |
| const fir::ExtendedValue &exval) { |
| if (shallowLookupSymbol(sym)) |
| return false; |
| bindSymbol(sym, exval); |
| return true; |
| } |
| |
| void bindSymbol(Fortran::lower::SymbolRef sym, |
| const fir::ExtendedValue &exval) override final { |
| addSymbol(sym, exval, /*forced=*/true); |
| } |
| |
| void |
| overrideExprValues(const Fortran::lower::ExprToValueMap *map) override final { |
| exprValueOverrides = map; |
| } |
| |
| const Fortran::lower::ExprToValueMap *getExprOverrides() override final { |
| return exprValueOverrides; |
| } |
| |
| bool lookupLabelSet(Fortran::lower::SymbolRef sym, |
| Fortran::lower::pft::LabelSet &labelSet) override final { |
| Fortran::lower::pft::FunctionLikeUnit &owningProc = |
| *getEval().getOwningProcedure(); |
| auto iter = owningProc.assignSymbolLabelMap.find(sym); |
| if (iter == owningProc.assignSymbolLabelMap.end()) |
| return false; |
| labelSet = iter->second; |
| return true; |
| } |
| |
| Fortran::lower::pft::Evaluation * |
| lookupLabel(Fortran::lower::pft::Label label) override final { |
| Fortran::lower::pft::FunctionLikeUnit &owningProc = |
| *getEval().getOwningProcedure(); |
| return owningProc.labelEvaluationMap.lookup(label); |
| } |
| |
| fir::ExtendedValue |
| genExprAddr(const Fortran::lower::SomeExpr &expr, |
| Fortran::lower::StatementContext &context, |
| mlir::Location *locPtr = nullptr) override final { |
| mlir::Location loc = locPtr ? *locPtr : toLocation(); |
| if (lowerToHighLevelFIR()) |
| return Fortran::lower::convertExprToAddress(loc, *this, expr, |
| localSymbols, context); |
| return Fortran::lower::createSomeExtendedAddress(loc, *this, expr, |
| localSymbols, context); |
| } |
| |
| fir::ExtendedValue |
| genExprValue(const Fortran::lower::SomeExpr &expr, |
| Fortran::lower::StatementContext &context, |
| mlir::Location *locPtr = nullptr) override final { |
| mlir::Location loc = locPtr ? *locPtr : toLocation(); |
| if (lowerToHighLevelFIR()) |
| return Fortran::lower::convertExprToValue(loc, *this, expr, localSymbols, |
| context); |
| return Fortran::lower::createSomeExtendedExpression(loc, *this, expr, |
| localSymbols, context); |
| } |
| |
| fir::ExtendedValue |
| genExprBox(mlir::Location loc, const Fortran::lower::SomeExpr &expr, |
| Fortran::lower::StatementContext &stmtCtx) override final { |
| if (lowerToHighLevelFIR()) |
| return Fortran::lower::convertExprToBox(loc, *this, expr, localSymbols, |
| stmtCtx); |
| return Fortran::lower::createBoxValue(loc, *this, expr, localSymbols, |
| stmtCtx); |
| } |
| |
| Fortran::evaluate::FoldingContext &getFoldingContext() override final { |
| return foldingContext; |
| } |
| |
| mlir::Type genType(const Fortran::lower::SomeExpr &expr) override final { |
| return Fortran::lower::translateSomeExprToFIRType(*this, expr); |
| } |
| mlir::Type genType(const Fortran::lower::pft::Variable &var) override final { |
| return Fortran::lower::translateVariableToFIRType(*this, var); |
| } |
| mlir::Type genType(Fortran::lower::SymbolRef sym) override final { |
| return Fortran::lower::translateSymbolToFIRType(*this, sym); |
| } |
| mlir::Type |
| genType(Fortran::common::TypeCategory tc, int kind, |
| llvm::ArrayRef<std::int64_t> lenParameters) override final { |
| return Fortran::lower::getFIRType(&getMLIRContext(), tc, kind, |
| lenParameters); |
| } |
| mlir::Type |
| genType(const Fortran::semantics::DerivedTypeSpec &tySpec) override final { |
| return Fortran::lower::translateDerivedTypeToFIRType(*this, tySpec); |
| } |
| mlir::Type genType(Fortran::common::TypeCategory tc) override final { |
| return Fortran::lower::getFIRType( |
| &getMLIRContext(), tc, bridge.getDefaultKinds().GetDefaultKind(tc), |
| std::nullopt); |
| } |
| |
| Fortran::lower::TypeConstructionStack & |
| getTypeConstructionStack() override final { |
| return typeConstructionStack; |
| } |
| |
| bool |
| isPresentShallowLookup(const Fortran::semantics::Symbol &sym) override final { |
| return bool(shallowLookupSymbol(sym)); |
| } |
| |
| bool createHostAssociateVarClone( |
| const Fortran::semantics::Symbol &sym) override final { |
| mlir::Location loc = genLocation(sym.name()); |
| mlir::Type symType = genType(sym); |
| const auto *details = sym.detailsIf<Fortran::semantics::HostAssocDetails>(); |
| assert(details && "No host-association found"); |
| const Fortran::semantics::Symbol &hsym = details->symbol(); |
| mlir::Type hSymType = genType(hsym.GetUltimate()); |
| Fortran::lower::SymbolBox hsb = |
| lookupSymbol(hsym, /*symMap=*/nullptr, /*forceHlfirBase=*/true); |
| |
| auto allocate = [&](llvm::ArrayRef<mlir::Value> shape, |
| llvm::ArrayRef<mlir::Value> typeParams) -> mlir::Value { |
| mlir::Value allocVal = builder->allocateLocal( |
| loc, |
| Fortran::semantics::IsAllocatableOrObjectPointer(&hsym.GetUltimate()) |
| ? hSymType |
| : symType, |
| mangleName(sym), toStringRef(sym.GetUltimate().name()), |
| /*pinned=*/true, shape, typeParams, |
| sym.GetUltimate().attrs().test(Fortran::semantics::Attr::TARGET)); |
| return allocVal; |
| }; |
| |
| fir::ExtendedValue hexv = symBoxToExtendedValue(hsb); |
| fir::ExtendedValue exv = hexv.match( |
| [&](const fir::BoxValue &box) -> fir::ExtendedValue { |
| const Fortran::semantics::DeclTypeSpec *type = sym.GetType(); |
| if (type && type->IsPolymorphic()) |
| TODO(loc, "create polymorphic host associated copy"); |
| // Create a contiguous temp with the same shape and length as |
| // the original variable described by a fir.box. |
| llvm::SmallVector<mlir::Value> extents = |
| fir::factory::getExtents(loc, *builder, hexv); |
| if (box.isDerivedWithLenParameters()) |
| TODO(loc, "get length parameters from derived type BoxValue"); |
| if (box.isCharacter()) { |
| mlir::Value len = fir::factory::readCharLen(*builder, loc, box); |
| mlir::Value temp = allocate(extents, {len}); |
| return fir::CharArrayBoxValue{temp, len, extents}; |
| } |
| return fir::ArrayBoxValue{allocate(extents, {}), extents}; |
| }, |
| [&](const fir::MutableBoxValue &box) -> fir::ExtendedValue { |
| // Allocate storage for a pointer/allocatble descriptor. |
| // No shape/lengths to be passed to the alloca. |
| return fir::MutableBoxValue(allocate({}, {}), {}, {}); |
| }, |
| [&](const auto &) -> fir::ExtendedValue { |
| mlir::Value temp = |
| allocate(fir::factory::getExtents(loc, *builder, hexv), |
| fir::factory::getTypeParams(loc, *builder, hexv)); |
| return fir::substBase(hexv, temp); |
| }); |
| |
| // Initialise cloned allocatable |
| hexv.match( |
| [&](const fir::MutableBoxValue &box) -> void { |
| // Do not process pointers |
| if (Fortran::semantics::IsPointer(sym.GetUltimate())) { |
| return; |
| } |
| // Allocate storage for a pointer/allocatble descriptor. |
| // No shape/lengths to be passed to the alloca. |
| const auto new_box = exv.getBoxOf<fir::MutableBoxValue>(); |
| |
| // allocate if allocated |
| mlir::Value isAllocated = |
| fir::factory::genIsAllocatedOrAssociatedTest(*builder, loc, box); |
| auto if_builder = builder->genIfThenElse(loc, isAllocated); |
| if_builder.genThen([&]() { |
| std::string name = mangleName(sym) + ".alloc"; |
| fir::ExtendedValue read = fir::factory::genMutableBoxRead( |
| *builder, loc, box, /*mayBePolymorphic=*/false); |
| if (auto read_arr_box = read.getBoxOf<fir::ArrayBoxValue>()) { |
| fir::factory::genInlinedAllocation( |
| *builder, loc, *new_box, read_arr_box->getLBounds(), |
| read_arr_box->getExtents(), |
| /*lenParams=*/std::nullopt, name, |
| /*mustBeHeap=*/true); |
| } else if (auto read_char_arr_box = |
| read.getBoxOf<fir::CharArrayBoxValue>()) { |
| fir::factory::genInlinedAllocation( |
| *builder, loc, *new_box, read_char_arr_box->getLBounds(), |
| read_char_arr_box->getExtents(), read_char_arr_box->getLen(), |
| name, |
| /*mustBeHeap=*/true); |
| } else if (auto read_char_box = |
| read.getBoxOf<fir::CharBoxValue>()) { |
| fir::factory::genInlinedAllocation(*builder, loc, *new_box, |
| /*lbounds=*/std::nullopt, |
| /*extents=*/std::nullopt, |
| read_char_box->getLen(), name, |
| /*mustBeHeap=*/true); |
| } else { |
| fir::factory::genInlinedAllocation( |
| *builder, loc, *new_box, box.getMutableProperties().lbounds, |
| box.getMutableProperties().extents, |
| box.nonDeferredLenParams(), name, |
| /*mustBeHeap=*/true); |
| } |
| }); |
| if_builder.genElse([&]() { |
| // nullify box |
| auto empty = fir::factory::createUnallocatedBox( |
| *builder, loc, new_box->getBoxTy(), |
| new_box->nonDeferredLenParams(), {}); |
| builder->create<fir::StoreOp>(loc, empty, new_box->getAddr()); |
| }); |
| if_builder.end(); |
| }, |
| [&](const auto &) -> void { |
| // Do nothing |
| }); |
| |
| return bindIfNewSymbol(sym, exv); |
| } |
| |
| void createHostAssociateVarCloneDealloc( |
| const Fortran::semantics::Symbol &sym) override final { |
| mlir::Location loc = genLocation(sym.name()); |
| Fortran::lower::SymbolBox hsb = |
| lookupSymbol(sym, /*symMap=*/nullptr, /*forceHlfirBase=*/true); |
| |
| fir::ExtendedValue hexv = symBoxToExtendedValue(hsb); |
| hexv.match( |
| [&](const fir::MutableBoxValue &new_box) -> void { |
| // Do not process pointers |
| if (Fortran::semantics::IsPointer(sym.GetUltimate())) { |
| return; |
| } |
| // deallocate allocated in createHostAssociateVarClone value |
| Fortran::lower::genDeallocateIfAllocated(*this, new_box, loc); |
| }, |
| [&](const auto &) -> void { |
| // Do nothing |
| }); |
| } |
| |
| void copyVar(mlir::Location loc, mlir::Value dst, mlir::Value src, |
| fir::FortranVariableFlagsEnum attrs) override final { |
| bool isAllocatable = |
| bitEnumContainsAny(attrs, fir::FortranVariableFlagsEnum::allocatable); |
| bool isPointer = |
| bitEnumContainsAny(attrs, fir::FortranVariableFlagsEnum::pointer); |
| |
| copyVarHLFIR(loc, Fortran::lower::SymbolBox::Intrinsic{dst}, |
| Fortran::lower::SymbolBox::Intrinsic{src}, isAllocatable, |
| isPointer, Fortran::semantics::Symbol::Flags()); |
| } |
| |
| void copyHostAssociateVar( |
| const Fortran::semantics::Symbol &sym, |
| mlir::OpBuilder::InsertPoint *copyAssignIP = nullptr) override final { |
| // 1) Fetch the original copy of the variable. |
| assert(sym.has<Fortran::semantics::HostAssocDetails>() && |
| "No host-association found"); |
| const Fortran::semantics::Symbol &hsym = sym.GetUltimate(); |
| Fortran::lower::SymbolBox hsb = lookupOneLevelUpSymbol(hsym); |
| assert(hsb && "Host symbol box not found"); |
| |
| // 2) Fetch the copied one that will mask the original. |
| Fortran::lower::SymbolBox sb = shallowLookupSymbol(sym); |
| assert(sb && "Host-associated symbol box not found"); |
| assert(hsb.getAddr() != sb.getAddr() && |
| "Host and associated symbol boxes are the same"); |
| |
| // 3) Perform the assignment. |
| mlir::OpBuilder::InsertPoint insPt = builder->saveInsertionPoint(); |
| if (copyAssignIP && copyAssignIP->isSet()) |
| builder->restoreInsertionPoint(*copyAssignIP); |
| else |
| builder->setInsertionPointAfter(sb.getAddr().getDefiningOp()); |
| |
| Fortran::lower::SymbolBox *lhs_sb, *rhs_sb; |
| if (copyAssignIP && copyAssignIP->isSet() && |
| sym.test(Fortran::semantics::Symbol::Flag::OmpLastPrivate)) { |
| // lastprivate case |
| lhs_sb = &hsb; |
| rhs_sb = &sb; |
| } else { |
| lhs_sb = &sb; |
| rhs_sb = &hsb; |
| } |
| |
| copyVar(sym, *lhs_sb, *rhs_sb, sym.flags()); |
| |
| if (copyAssignIP && copyAssignIP->isSet() && |
| sym.test(Fortran::semantics::Symbol::Flag::OmpLastPrivate)) { |
| builder->restoreInsertionPoint(insPt); |
| } |
| } |
| |
| void genEval(Fortran::lower::pft::Evaluation &eval, |
| bool unstructuredContext) override final { |
| genFIR(eval, unstructuredContext); |
| } |
| |
| //===--------------------------------------------------------------------===// |
| // Utility methods |
| //===--------------------------------------------------------------------===// |
| |
| void collectSymbolSet( |
| Fortran::lower::pft::Evaluation &eval, |
| llvm::SetVector<const Fortran::semantics::Symbol *> &symbolSet, |
| Fortran::semantics::Symbol::Flag flag, bool collectSymbols, |
| bool checkHostAssociatedSymbols) override final { |
| auto addToList = [&](const Fortran::semantics::Symbol &sym) { |
| std::function<void(const Fortran::semantics::Symbol &, bool)> |
| insertSymbols = [&](const Fortran::semantics::Symbol &oriSymbol, |
| bool collectSymbol) { |
| if (collectSymbol && oriSymbol.test(flag)) |
| symbolSet.insert(&oriSymbol); |
| else if (checkHostAssociatedSymbols) |
| if (const auto *details{ |
| oriSymbol |
| .detailsIf<Fortran::semantics::HostAssocDetails>()}) |
| insertSymbols(details->symbol(), true); |
| }; |
| insertSymbols(sym, collectSymbols); |
| }; |
| Fortran::lower::pft::visitAllSymbols(eval, addToList); |
| } |
| |
| mlir::Location getCurrentLocation() override final { return toLocation(); } |
| |
| /// Generate a dummy location. |
| mlir::Location genUnknownLocation() override final { |
| // Note: builder may not be instantiated yet |
| return mlir::UnknownLoc::get(&getMLIRContext()); |
| } |
| |
| static mlir::Location genLocation(Fortran::parser::SourcePosition pos, |
| mlir::MLIRContext &ctx) { |
| llvm::SmallString<256> path(*pos.path); |
| llvm::sys::fs::make_absolute(path); |
| llvm::sys::path::remove_dots(path); |
| return mlir::FileLineColLoc::get(&ctx, path.str(), pos.line, pos.column); |
| } |
| |
| /// Generate a `Location` from the `CharBlock`. |
| mlir::Location |
| genLocation(const Fortran::parser::CharBlock &block) override final { |
| mlir::Location mainLocation = genUnknownLocation(); |
| if (const Fortran::parser::AllCookedSources *cooked = |
| bridge.getCookedSource()) { |
| if (std::optional<Fortran::parser::ProvenanceRange> provenance = |
| cooked->GetProvenanceRange(block)) { |
| if (std::optional<Fortran::parser::SourcePosition> filePos = |
| cooked->allSources().GetSourcePosition(provenance->start())) |
| mainLocation = genLocation(*filePos, getMLIRContext()); |
| |
| llvm::SmallVector<mlir::Location> locs; |
| locs.push_back(mainLocation); |
| |
| llvm::SmallVector<fir::LocationKindAttr> locAttrs; |
| locAttrs.push_back(fir::LocationKindAttr::get(&getMLIRContext(), |
| fir::LocationKind::Base)); |
| |
| // Gather include location information if any. |
| Fortran::parser::ProvenanceRange *prov = &*provenance; |
| while (prov) { |
| if (std::optional<Fortran::parser::ProvenanceRange> include = |
| cooked->allSources().GetInclusionInfo(*prov)) { |
| if (std::optional<Fortran::parser::SourcePosition> incPos = |
| cooked->allSources().GetSourcePosition(include->start())) { |
| locs.push_back(genLocation(*incPos, getMLIRContext())); |
| locAttrs.push_back(fir::LocationKindAttr::get( |
| &getMLIRContext(), fir::LocationKind::Inclusion)); |
| } |
| prov = &*include; |
| } else { |
| prov = nullptr; |
| } |
| } |
| if (locs.size() > 1) { |
| assert(locs.size() == locAttrs.size() && |
| "expect as many attributes as locations"); |
| return mlir::FusedLocWith<fir::LocationKindArrayAttr>::get( |
| &getMLIRContext(), locs, |
| fir::LocationKindArrayAttr::get(&getMLIRContext(), locAttrs)); |
| } |
| } |
| } |
| return mainLocation; |
| } |
| |
| const Fortran::semantics::Scope &getCurrentScope() override final { |
| return bridge.getSemanticsContext().FindScope(currentPosition); |
| } |
| |
| fir::FirOpBuilder &getFirOpBuilder() override final { return *builder; } |
| |
| mlir::ModuleOp &getModuleOp() override final { return bridge.getModule(); } |
| |
| mlir::MLIRContext &getMLIRContext() override final { |
| return bridge.getMLIRContext(); |
| } |
| std::string |
| mangleName(const Fortran::semantics::Symbol &symbol) override final { |
| return Fortran::lower::mangle::mangleName( |
| symbol, scopeBlockIdMap, /*keepExternalInScope=*/false, |
| getLoweringOptions().getUnderscoring()); |
| } |
| std::string mangleName( |
| const Fortran::semantics::DerivedTypeSpec &derivedType) override final { |
| return Fortran::lower::mangle::mangleName(derivedType, scopeBlockIdMap); |
| } |
| std::string mangleName(std::string &name) override final { |
| return Fortran::lower::mangle::mangleName(name, getCurrentScope(), |
| scopeBlockIdMap); |
| } |
| std::string getRecordTypeFieldName( |
| const Fortran::semantics::Symbol &component) override final { |
| return Fortran::lower::mangle::getRecordTypeFieldName(component, |
| scopeBlockIdMap); |
| } |
| const fir::KindMapping &getKindMap() override final { |
| return bridge.getKindMap(); |
| } |
| |
| /// Return the current function context, which may be a nested BLOCK context |
| /// or a full subprogram context. |
| Fortran::lower::StatementContext &getFctCtx() override final { |
| if (!activeConstructStack.empty() && |
| activeConstructStack.back().eval.isA<Fortran::parser::BlockConstruct>()) |
| return activeConstructStack.back().stmtCtx; |
| return bridge.fctCtx(); |
| } |
| |
| mlir::Value hostAssocTupleValue() override final { return hostAssocTuple; } |
| |
| /// Record a binding for the ssa-value of the tuple for this function. |
| void bindHostAssocTuple(mlir::Value val) override final { |
| assert(!hostAssocTuple && val); |
| hostAssocTuple = val; |
| } |
| |
| mlir::Value dummyArgsScopeValue() const override final { |
| return dummyArgsScope; |
| } |
| |
| bool isRegisteredDummySymbol( |
| Fortran::semantics::SymbolRef symRef) const override final { |
| auto *sym = &*symRef; |
| return registeredDummySymbols.contains(sym); |
| } |
| |
| void registerTypeInfo(mlir::Location loc, |
| Fortran::lower::SymbolRef typeInfoSym, |
| const Fortran::semantics::DerivedTypeSpec &typeSpec, |
| fir::RecordType type) override final { |
| typeInfoConverter.registerTypeInfo(*this, loc, typeInfoSym, typeSpec, type); |
| } |
| |
| llvm::StringRef |
| getUniqueLitName(mlir::Location loc, |
| std::unique_ptr<Fortran::lower::SomeExpr> expr, |
| mlir::Type eleTy) override final { |
| std::string namePrefix = |
| getConstantExprManglePrefix(loc, *expr.get(), eleTy); |
| auto [it, inserted] = literalNamesMap.try_emplace( |
| expr.get(), namePrefix + std::to_string(uniqueLitId)); |
| const auto &name = it->second; |
| if (inserted) { |
| // Keep ownership of the expr key. |
| literalExprsStorage.push_back(std::move(expr)); |
| |
| // If we've just added a new name, we have to make sure |
| // there is no global object with the same name in the module. |
| fir::GlobalOp global = builder->getNamedGlobal(name); |
| if (global) |
| fir::emitFatalError(loc, llvm::Twine("global object with name '") + |
| llvm::Twine(name) + |
| llvm::Twine("' already exists")); |
| ++uniqueLitId; |
| return name; |
| } |
| |
| // The name already exists. Verify that the prefix is the same. |
| if (!llvm::StringRef(name).starts_with(namePrefix)) |
| fir::emitFatalError(loc, llvm::Twine("conflicting prefixes: '") + |
| llvm::Twine(name) + |
| llvm::Twine("' does not start with '") + |
| llvm::Twine(namePrefix) + llvm::Twine("'")); |
| |
| return name; |
| } |
| |
| private: |
| FirConverter() = delete; |
| FirConverter(const FirConverter &) = delete; |
| FirConverter &operator=(const FirConverter &) = delete; |
| |
| //===--------------------------------------------------------------------===// |
| // Helper member functions |
| //===--------------------------------------------------------------------===// |
| |
| mlir::Value createFIRExpr(mlir::Location loc, |
| const Fortran::lower::SomeExpr *expr, |
| Fortran::lower::StatementContext &stmtCtx) { |
| return fir::getBase(genExprValue(*expr, stmtCtx, &loc)); |
| } |
| |
| /// Find the symbol in the local map or return null. |
| Fortran::lower::SymbolBox |
| lookupSymbol(const Fortran::semantics::Symbol &sym, |
| Fortran::lower::SymMap *symMap = nullptr, |
| bool forceHlfirBase = false) { |
| symMap = symMap ? symMap : &localSymbols; |
| if (lowerToHighLevelFIR()) { |
| if (std::optional<fir::FortranVariableOpInterface> var = |
| symMap->lookupVariableDefinition(sym)) { |
| auto exv = hlfir::translateToExtendedValue(toLocation(), *builder, *var, |
| forceHlfirBase); |
| return exv.match( |
| [](mlir::Value x) -> Fortran::lower::SymbolBox { |
| return Fortran::lower::SymbolBox::Intrinsic{x}; |
| }, |
| [](auto x) -> Fortran::lower::SymbolBox { return x; }); |
| } |
| |
| // Entry character result represented as an argument pair |
| // needs to be represented in the symbol table even before |
| // we can create DeclareOp for it. The temporary mapping |
| // is EmboxCharOp that conveys the address and length information. |
| // After mapSymbolAttributes is done, the mapping is replaced |
| // with the new DeclareOp, and the following table lookups |
| // do not reach here. |
| if (sym.IsFuncResult()) |
| if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType()) |
| if (declTy->category() == |
| Fortran::semantics::DeclTypeSpec::Category::Character) |
| return symMap->lookupSymbol(sym); |
| |
| // Procedure dummies are not mapped with an hlfir.declare because |
| // they are not "variable" (cannot be assigned to), and it would |
| // make hlfir.declare more complex than it needs to to allow this. |
| // Do a regular lookup. |
| if (Fortran::semantics::IsProcedure(sym)) |
| return symMap->lookupSymbol(sym); |
| |
| // Commonblock names are not variables, but in some lowerings (like |
| // OpenMP) it is useful to maintain the address of the commonblock in an |
| // MLIR value and query it. hlfir.declare need not be created for these. |
| if (sym.detailsIf<Fortran::semantics::CommonBlockDetails>()) |
| return symMap->lookupSymbol(sym); |
| |
| // For symbols to be privatized in OMP, the symbol is mapped to an |
| // instance of `SymbolBox::Intrinsic` (i.e. a direct mapping to an MLIR |
| // SSA value). This MLIR SSA value is the block argument to the |
| // `omp.private`'s `alloc` block. If this is the case, we return this |
| // `SymbolBox::Intrinsic` value. |
| if (Fortran::lower::SymbolBox v = symMap->lookupSymbol(sym)) |
| return v; |
| |
| return {}; |
| } |
| if (Fortran::lower::SymbolBox v = symMap->lookupSymbol(sym)) |
| return v; |
| return {}; |
| } |
| |
| /// Find the symbol in the inner-most level of the local map or return null. |
| Fortran::lower::SymbolBox |
| shallowLookupSymbol(const Fortran::semantics::Symbol &sym) { |
| if (Fortran::lower::SymbolBox v = localSymbols.shallowLookupSymbol(sym)) |
| return v; |
| return {}; |
| } |
| |
| /// Find the symbol in one level up of symbol map such as for host-association |
| /// in OpenMP code or return null. |
| Fortran::lower::SymbolBox |
| lookupOneLevelUpSymbol(const Fortran::semantics::Symbol &sym) override { |
| if (Fortran::lower::SymbolBox v = localSymbols.lookupOneLevelUpSymbol(sym)) |
| return v; |
| return {}; |
| } |
| |
| mlir::SymbolTable *getMLIRSymbolTable() override { return &mlirSymbolTable; } |
| |
| /// Add the symbol to the local map and return `true`. If the symbol is |
| /// already in the map and \p forced is `false`, the map is not updated. |
| /// Instead the value `false` is returned. |
| bool addSymbol(const Fortran::semantics::SymbolRef sym, |
| fir::ExtendedValue val, bool forced = false) { |
| if (!forced && lookupSymbol(sym)) |
| return false; |
| if (lowerToHighLevelFIR()) { |
| Fortran::lower::genDeclareSymbol(*this, localSymbols, sym, val, |
| fir::FortranVariableFlagsEnum::None, |
| forced); |
| } else { |
| localSymbols.addSymbol(sym, val, forced); |
| } |
| return true; |
| } |
| |
| void copyVar(const Fortran::semantics::Symbol &sym, |
| const Fortran::lower::SymbolBox &lhs_sb, |
| const Fortran::lower::SymbolBox &rhs_sb, |
| Fortran::semantics::Symbol::Flags flags) { |
| mlir::Location loc = genLocation(sym.name()); |
| if (lowerToHighLevelFIR()) |
| copyVarHLFIR(loc, lhs_sb, rhs_sb, flags); |
| else |
| copyVarFIR(loc, sym, lhs_sb, rhs_sb); |
| } |
| |
| void copyVarHLFIR(mlir::Location loc, Fortran::lower::SymbolBox dst, |
| Fortran::lower::SymbolBox src, |
| Fortran::semantics::Symbol::Flags flags) { |
| assert(lowerToHighLevelFIR()); |
| |
| bool isBoxAllocatable = dst.match( |
| [](const fir::MutableBoxValue &box) { return box.isAllocatable(); }, |
| [](const fir::FortranVariableOpInterface &box) { |
| return fir::FortranVariableOpInterface(box).isAllocatable(); |
| }, |
| [](const auto &box) { return false; }); |
| |
| bool isBoxPointer = dst.match( |
| [](const fir::MutableBoxValue &box) { return box.isPointer(); }, |
| [](const fir::FortranVariableOpInterface &box) { |
| return fir::FortranVariableOpInterface(box).isPointer(); |
| }, |
| [](const auto &box) { return false; }); |
| |
| copyVarHLFIR(loc, dst, src, isBoxAllocatable, isBoxPointer, flags); |
| } |
| |
| void copyVarHLFIR(mlir::Location loc, Fortran::lower::SymbolBox dst, |
| Fortran::lower::SymbolBox src, bool isAllocatable, |
| bool isPointer, Fortran::semantics::Symbol::Flags flags) { |
| assert(lowerToHighLevelFIR()); |
| hlfir::Entity lhs{dst.getAddr()}; |
| hlfir::Entity rhs{src.getAddr()}; |
| |
| auto copyData = [&](hlfir::Entity l, hlfir::Entity r) { |
| // Dereference RHS and load it if trivial scalar. |
| r = hlfir::loadTrivialScalar(loc, *builder, r); |
| builder->create<hlfir::AssignOp>(loc, r, l, isAllocatable); |
| }; |
| |
| if (isPointer) { |
| // Set LHS target to the target of RHS (do not copy the RHS |
| // target data into the LHS target storage). |
| auto loadVal = builder->create<fir::LoadOp>(loc, rhs); |
| builder->create<fir::StoreOp>(loc, loadVal, lhs); |
| } else if (isAllocatable && |
| (flags.test(Fortran::semantics::Symbol::Flag::OmpFirstPrivate) || |
| flags.test(Fortran::semantics::Symbol::Flag::OmpCopyIn))) { |
| // For firstprivate and copyin allocatable variables, RHS must be copied |
| // only when LHS is allocated. |
| hlfir::Entity temp = |
| hlfir::derefPointersAndAllocatables(loc, *builder, lhs); |
| mlir::Value addr = hlfir::genVariableRawAddress(loc, *builder, temp); |
| mlir::Value isAllocated = builder->genIsNotNullAddr(loc, addr); |
| builder->genIfThen(loc, isAllocated) |
| .genThen([&]() { copyData(lhs, rhs); }) |
| .end(); |
| } else { |
| copyData(lhs, rhs); |
| } |
| } |
| |
| void copyVarFIR(mlir::Location loc, const Fortran::semantics::Symbol &sym, |
| const Fortran::lower::SymbolBox &lhs_sb, |
| const Fortran::lower::SymbolBox &rhs_sb) { |
| assert(!lowerToHighLevelFIR()); |
| fir::ExtendedValue lhs = symBoxToExtendedValue(lhs_sb); |
| fir::ExtendedValue rhs = symBoxToExtendedValue(rhs_sb); |
| mlir::Type symType = genType(sym); |
| if (auto seqTy = mlir::dyn_cast<fir::SequenceType>(symType)) { |
| Fortran::lower::StatementContext stmtCtx; |
| Fortran::lower::createSomeArrayAssignment(*this, lhs, rhs, localSymbols, |
| stmtCtx); |
| stmtCtx.finalizeAndReset(); |
| } else if (lhs.getBoxOf<fir::CharBoxValue>()) { |
| fir::factory::CharacterExprHelper{*builder, loc}.createAssign(lhs, rhs); |
| } else { |
| auto loadVal = builder->create<fir::LoadOp>(loc, fir::getBase(rhs)); |
| builder->create<fir::StoreOp>(loc, loadVal, fir::getBase(lhs)); |
| } |
| } |
| |
| /// Map a block argument to a result or dummy symbol. This is not the |
| /// definitive mapping. The specification expression have not been lowered |
| /// yet. The final mapping will be done using this pre-mapping in |
| /// Fortran::lower::mapSymbolAttributes. |
| bool mapBlockArgToDummyOrResult(const Fortran::semantics::SymbolRef sym, |
| mlir::Value val, bool isResult) { |
| localSymbols.addSymbol(sym, val); |
| if (!isResult) |
| registerDummySymbol(sym); |
| |
| return true; |
| } |
| |
| /// Generate the address of loop variable \p sym. |
| /// If \p sym is not mapped yet, allocate local storage for it. |
| mlir::Value genLoopVariableAddress(mlir::Location loc, |
| const Fortran::semantics::Symbol &sym, |
| bool isUnordered) { |
| if (isUnordered || sym.has<Fortran::semantics::HostAssocDetails>() || |
| sym.has<Fortran::semantics::UseDetails>()) { |
| if (!shallowLookupSymbol(sym) && |
| !sym.test(Fortran::semantics::Symbol::Flag::OmpShared)) { |
| // Do concurrent loop variables are not mapped yet since they are local |
| // to the Do concurrent scope (same for OpenMP loops). |
| mlir::OpBuilder::InsertPoint insPt = builder->saveInsertionPoint(); |
| builder->setInsertionPointToStart(builder->getAllocaBlock()); |
| mlir::Type tempTy = genType(sym); |
| mlir::Value temp = |
| builder->createTemporaryAlloc(loc, tempTy, toStringRef(sym.name())); |
| bindIfNewSymbol(sym, temp); |
| builder->restoreInsertionPoint(insPt); |
| } |
| } |
| auto entry = lookupSymbol(sym); |
| (void)entry; |
| assert(entry && "loop control variable must already be in map"); |
| Fortran::lower::StatementContext stmtCtx; |
| return fir::getBase( |
| genExprAddr(Fortran::evaluate::AsGenericExpr(sym).value(), stmtCtx)); |
| } |
| |
| static bool isNumericScalarCategory(Fortran::common::TypeCategory cat) { |
| return cat == Fortran::common::TypeCategory::Integer || |
| cat == Fortran::common::TypeCategory::Real || |
| cat == Fortran::common::TypeCategory::Complex || |
| cat == Fortran::common::TypeCategory::Logical; |
| } |
| static bool isLogicalCategory(Fortran::common::TypeCategory cat) { |
| return cat == Fortran::common::TypeCategory::Logical; |
| } |
| static bool isCharacterCategory(Fortran::common::TypeCategory cat) { |
| return cat == Fortran::common::TypeCategory::Character; |
| } |
| static bool isDerivedCategory(Fortran::common::TypeCategory cat) { |
| return cat == Fortran::common::TypeCategory::Derived; |
| } |
| |
| /// Insert a new block before \p block. Leave the insertion point unchanged. |
| mlir::Block *insertBlock(mlir::Block *block) { |
| mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint(); |
| mlir::Block *newBlock = builder->createBlock(block); |
| builder->restoreInsertionPoint(insertPt); |
| return newBlock; |
| } |
| |
| Fortran::lower::pft::Evaluation &evalOfLabel(Fortran::parser::Label label) { |
| const Fortran::lower::pft::LabelEvalMap &labelEvaluationMap = |
| getEval().getOwningProcedure()->labelEvaluationMap; |
| const auto iter = labelEvaluationMap.find(label); |
| assert(iter != labelEvaluationMap.end() && "label missing from map"); |
| return *iter->second; |
| } |
| |
| void genBranch(mlir::Block *targetBlock) { |
| assert(targetBlock && "missing unconditional target block"); |
| builder->create<mlir::cf::BranchOp>(toLocation(), targetBlock); |
| } |
| |
| void genConditionalBranch(mlir::Value cond, mlir::Block *trueTarget, |
| mlir::Block *falseTarget) { |
| assert(trueTarget && "missing conditional branch true block"); |
| assert(falseTarget && "missing conditional branch false block"); |
| mlir::Location loc = toLocation(); |
| mlir::Value bcc = builder->createConvert(loc, builder->getI1Type(), cond); |
| builder->create<mlir::cf::CondBranchOp>(loc, bcc, trueTarget, std::nullopt, |
| falseTarget, std::nullopt); |
| } |
| void genConditionalBranch(mlir::Value cond, |
| Fortran::lower::pft::Evaluation *trueTarget, |
| Fortran::lower::pft::Evaluation *falseTarget) { |
| genConditionalBranch(cond, trueTarget->block, falseTarget->block); |
| } |
| void genConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr, |
| mlir::Block *trueTarget, mlir::Block *falseTarget) { |
| Fortran::lower::StatementContext stmtCtx; |
| mlir::Value cond = |
| createFIRExpr(toLocation(), Fortran::semantics::GetExpr(expr), stmtCtx); |
| stmtCtx.finalizeAndReset(); |
| genConditionalBranch(cond, trueTarget, falseTarget); |
| } |
| void genConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr, |
| Fortran::lower::pft::Evaluation *trueTarget, |
| Fortran::lower::pft::Evaluation *falseTarget) { |
| Fortran::lower::StatementContext stmtCtx; |
| mlir::Value cond = |
| createFIRExpr(toLocation(), Fortran::semantics::GetExpr(expr), stmtCtx); |
| stmtCtx.finalizeAndReset(); |
| genConditionalBranch(cond, trueTarget->block, falseTarget->block); |
| } |
| |
| /// Return the nearest active ancestor construct of \p eval, or nullptr. |
| Fortran::lower::pft::Evaluation * |
| getActiveAncestor(const Fortran::lower::pft::Evaluation &eval) { |
| Fortran::lower::pft::Evaluation *ancestor = eval.parentConstruct; |
| for (; ancestor; ancestor = ancestor->parentConstruct) |
| if (ancestor->activeConstruct) |
| break; |
| return ancestor; |
| } |
| |
| /// Return the predicate: "a branch to \p targetEval has exit code". |
| bool hasExitCode(const Fortran::lower::pft::Evaluation &targetEval) { |
| Fortran::lower::pft::Evaluation *activeAncestor = |
| getActiveAncestor(targetEval); |
| for (auto it = activeConstructStack.rbegin(), |
| rend = activeConstructStack.rend(); |
| it != rend; ++it) { |
| if (&it->eval == activeAncestor) |
| break; |
| if (it->stmtCtx.hasCode()) |
| return true; |
| } |
| return false; |
| } |
| |
| /// Generate a branch to \p targetEval after generating on-exit code for |
| /// any enclosing construct scopes that are exited by taking the branch. |
| void |
| genConstructExitBranch(const Fortran::lower::pft::Evaluation &targetEval) { |
| Fortran::lower::pft::Evaluation *activeAncestor = |
| getActiveAncestor(targetEval); |
| for (auto it = activeConstructStack.rbegin(), |
| rend = activeConstructStack.rend(); |
| it != rend; ++it) { |
| if (&it->eval == activeAncestor) |
| break; |
| it->stmtCtx.finalizeAndKeep(); |
| } |
| genBranch(targetEval.block); |
| } |
| |
| /// A construct contains nested evaluations. Some of these evaluations |
| /// may start a new basic block, others will add code to an existing |
| /// block. |
| /// Collect the list of nested evaluations that are last in their block, |
| /// organize them into two sets: |
| /// 1. Exiting evaluations: they may need a branch exiting from their |
| /// parent construct, |
| /// 2. Fall-through evaluations: they will continue to the following |
| /// evaluation. They may still need a branch, but they do not exit |
| /// the construct. They appear in cases where the following evaluation |
| /// is a target of some branch. |
| void collectFinalEvaluations( |
| Fortran::lower::pft::Evaluation &construct, |
| llvm::SmallVector<Fortran::lower::pft::Evaluation *> &exits, |
| llvm::SmallVector<Fortran::lower::pft::Evaluation *> &fallThroughs) { |
| Fortran::lower::pft::EvaluationList &nested = |
| construct.getNestedEvaluations(); |
| if (nested.empty()) |
| return; |
| |
| Fortran::lower::pft::Evaluation *exit = construct.constructExit; |
| Fortran::lower::pft::Evaluation *previous = &nested.front(); |
| |
| for (auto it = ++nested.begin(), end = nested.end(); it != end; |
| previous = &*it++) { |
| if (it->block == nullptr) |
| continue; |
| // "*it" starts a new block, check what to do with "previous" |
| if (it->isIntermediateConstructStmt() && previous != exit) |
| exits.push_back(previous); |
| else if (previous->lexicalSuccessor && previous->lexicalSuccessor->block) |
| fallThroughs.push_back(previous); |
| } |
| if (previous != exit) |
| exits.push_back(previous); |
| } |
| |
| /// Generate a SelectOp or branch sequence that compares \p selector against |
| /// values in \p valueList and targets corresponding labels in \p labelList. |
| /// If no value matches the selector, branch to \p defaultEval. |
| /// |
| /// Three cases require special processing. |
| /// |
| /// An empty \p valueList indicates an ArithmeticIfStmt context that requires |
| /// two comparisons against 0 or 0.0. The selector may have either INTEGER |
| /// or REAL type. |
| /// |
| /// A nonpositive \p valuelist value indicates an IO statement context |
| /// (0 for ERR, -1 for END, -2 for EOR). An ERR branch must be taken for |
| /// any positive (IOSTAT) value. A missing (zero) label requires a branch |
| /// to \p defaultEval for that value. |
| /// |
| /// A non-null \p errorBlock indicates an AssignedGotoStmt context that |
| /// must always branch to an explicit target. There is no valid defaultEval |
| /// in this case. Generate a branch to \p errorBlock for an AssignedGotoStmt |
| /// that violates this program requirement. |
| /// |
| /// If this is not an ArithmeticIfStmt and no targets have exit code, |
| /// generate a SelectOp. Otherwise, for each target, if it has exit code, |
| /// branch to a new block, insert exit code, and then branch to the target. |
| /// Otherwise, branch directly to the target. |
| void genMultiwayBranch(mlir::Value selector, |
| llvm::SmallVector<int64_t> valueList, |
| llvm::SmallVector<Fortran::parser::Label> labelList, |
| const Fortran::lower::pft::Evaluation &defaultEval, |
| mlir::Block *errorBlock = nullptr) { |
| bool inArithmeticIfContext = valueList.empty(); |
| assert(((inArithmeticIfContext && labelList.size() == 2) || |
| (valueList.size() && labelList.size() == valueList.size())) && |
| "mismatched multiway branch targets"); |
| mlir::Block *defaultBlock = errorBlock ? errorBlock : defaultEval.block; |
| bool defaultHasExitCode = !errorBlock && hasExitCode(defaultEval); |
| bool hasAnyExitCode = defaultHasExitCode; |
| if (!hasAnyExitCode) |
| for (auto label : labelList) |
| if (label && hasExitCode(evalOfLabel(label))) { |
| hasAnyExitCode = true; |
| break; |
| } |
| mlir::Location loc = toLocation(); |
| size_t branchCount = labelList.size(); |
| if (!inArithmeticIfContext && !hasAnyExitCode && |
| !getEval().forceAsUnstructured()) { // from -no-structured-fir option |
| // Generate a SelectOp. |
| llvm::SmallVector<mlir::Block *> blockList; |
| for (auto label : labelList) { |
| mlir::Block *block = |
| label ? evalOfLabel(label).block : defaultEval.block; |
| assert(block && "missing multiway branch block"); |
| blockList.push_back(block); |
| } |
| blockList.push_back(defaultBlock); |
| if (valueList[branchCount - 1] == 0) // Swap IO ERR and default blocks. |
| std::swap(blockList[branchCount - 1], blockList[branchCount]); |
| builder->create<fir::SelectOp>(loc, selector, valueList, blockList); |
| return; |
| } |
| mlir::Type selectorType = selector.getType(); |
| bool realSelector = mlir::isa<mlir::FloatType>(selectorType); |
| assert((inArithmeticIfContext || !realSelector) && "invalid selector type"); |
| mlir::Value zero; |
| if (inArithmeticIfContext) |
| zero = |
| realSelector |
| ? builder->create<mlir::arith::ConstantOp>( |
| loc, selectorType, builder->getFloatAttr(selectorType, 0.0)) |
| : builder->createIntegerConstant(loc, selectorType, 0); |
| for (auto label : llvm::enumerate(labelList)) { |
| mlir::Value cond; |
| if (realSelector) // inArithmeticIfContext |
| cond = builder->create<mlir::arith::CmpFOp>( |
| loc, |
| label.index() == 0 ? mlir::arith::CmpFPredicate::OLT |
| : mlir::arith::CmpFPredicate::OGT, |
| selector, zero); |
| else if (inArithmeticIfContext) // INTEGER selector |
| cond = builder->create<mlir::arith::CmpIOp>( |
| loc, |
| label.index() == 0 ? mlir::arith::CmpIPredicate::slt |
| : mlir::arith::CmpIPredicate::sgt, |
| selector, zero); |
| else // A value of 0 is an IO ERR branch: invert comparison. |
| cond = builder->create<mlir::arith::CmpIOp>( |
| loc, |
| valueList[label.index()] == 0 ? mlir::arith::CmpIPredicate::ne |
| : mlir::arith::CmpIPredicate::eq, |
| selector, |
| builder->createIntegerConstant(loc, selectorType, |
| valueList[label.index()])); |
| // Branch to a new block with exit code and then to the target, or branch |
| // directly to the target. defaultBlock is the "else" target. |
| bool lastBranch = label.index() == branchCount - 1; |
| mlir::Block *nextBlock = |
| lastBranch && !defaultHasExitCode |
| ? defaultBlock |
| : builder->getBlock()->splitBlock(builder->getInsertionPoint()); |
| const Fortran::lower::pft::Evaluation &targetEval = |
| label.value() ? evalOfLabel(label.value()) : defaultEval; |
| if (hasExitCode(targetEval)) { |
| mlir::Block *jumpBlock = |
| builder->getBlock()->splitBlock(builder->getInsertionPoint()); |
| genConditionalBranch(cond, jumpBlock, nextBlock); |
| startBlock(jumpBlock); |
| genConstructExitBranch(targetEval); |
| } else { |
| genConditionalBranch(cond, targetEval.block, nextBlock); |
| } |
| if (!lastBranch) { |
| startBlock(nextBlock); |
| } else if (defaultHasExitCode) { |
| startBlock(nextBlock); |
| genConstructExitBranch(defaultEval); |
| } |
| } |
| } |
| |
| void pushActiveConstruct(Fortran::lower::pft::Evaluation &eval, |
| Fortran::lower::StatementContext &stmtCtx) { |
| activeConstructStack.push_back(ConstructContext{eval, stmtCtx}); |
| eval.activeConstruct = true; |
| } |
| void popActiveConstruct() { |
| assert(!activeConstructStack.empty() && "invalid active construct stack"); |
| activeConstructStack.back().eval.activeConstruct = false; |
| if (activeConstructStack.back().pushedScope) |
| localSymbols.popScope(); |
| activeConstructStack.pop_back(); |
| } |
| |
| //===--------------------------------------------------------------------===// |
| // Termination of symbolically referenced execution units |
| //===--------------------------------------------------------------------===// |
| |
| /// END of program |
| /// |
| /// Generate the cleanup block before the program exits |
| void genExitRoutine() { |
| |
| if (blockIsUnterminated()) |
| builder->create<mlir::func::ReturnOp>(toLocation()); |
| } |
| |
| /// END of procedure-like constructs |
| /// |
| /// Generate the cleanup block before the procedure exits |
| void genReturnSymbol(const Fortran::semantics::Symbol &functionSymbol) { |
| const Fortran::semantics::Symbol &resultSym = |
| functionSymbol.get<Fortran::semantics::SubprogramDetails>().result(); |
| Fortran::lower::SymbolBox resultSymBox = lookupSymbol(resultSym); |
| mlir::Location loc = toLocation(); |
| if (!resultSymBox) { |
| mlir::emitError(loc, "internal error when processing function return"); |
| return; |
| } |
| mlir::Value resultVal = resultSymBox.match( |
| [&](const fir::CharBoxValue &x) -> mlir::Value { |
| if (Fortran::semantics::IsBindCProcedure(functionSymbol)) |
| return builder->create<fir::LoadOp>(loc, x.getBuffer()); |
| return fir::factory::CharacterExprHelper{*builder, loc} |
| .createEmboxChar(x.getBuffer(), x.getLen()); |
| }, |
| [&](const fir::MutableBoxValue &x) -> mlir::Value { |
| mlir::Value resultRef = resultSymBox.getAddr(); |
| mlir::Value load = builder->create<fir::LoadOp>(loc, resultRef); |
| unsigned rank = x.rank(); |
| if (x.isAllocatable() && rank > 0) { |
| // ALLOCATABLE array result must have default lower bounds. |
| // At the call site the result box of a function reference |
| // might be considered having default lower bounds, but |
| // the runtime box should probably comply with this assumption |
| // as well. If the result box has proper lbounds in runtime, |
| // this may improve the debugging experience of Fortran apps. |
| // We may consider removing this, if the overhead of setting |
| // default lower bounds is too big. |
| mlir::Value one = |
| builder->createIntegerConstant(loc, builder->getIndexType(), 1); |
| llvm::SmallVector<mlir::Value> lbounds{rank, one}; |
| auto shiftTy = fir::ShiftType::get(builder->getContext(), rank); |
| mlir::Value shiftOp = |
| builder->create<fir::ShiftOp>(loc, shiftTy, lbounds); |
| load = builder->create<fir::ReboxOp>( |
| loc, load.getType(), load, shiftOp, /*slice=*/mlir::Value{}); |
| } |
| return load; |
| }, |
| [&](const auto &) -> mlir::Value { |
| mlir::Value resultRef = resultSymBox.getAddr(); |
| mlir::Type resultType = genType(resultSym); |
| mlir::Type resultRefType = builder->getRefType(resultType); |
| // A function with multiple entry points returning different types |
| // tags all result variables with one of the largest types to allow |
| // them to share the same storage. Convert this to the actual type. |
| if (resultRef.getType() != resultRefType) |
| resultRef = builder->createConvert(loc, resultRefType, resultRef); |
| return builder->create<fir::LoadOp>(loc, resultRef); |
| }); |
| bridge.openAccCtx().finalizeAndPop(); |
| bridge.fctCtx().finalizeAndPop(); |
| builder->create<mlir::func::ReturnOp>(loc, resultVal); |
| } |
| |
| /// Get the return value of a call to \p symbol, which is a subroutine entry |
| /// point that has alternative return specifiers. |
| const mlir::Value |
| getAltReturnResult(const Fortran::semantics::Symbol &symbol) { |
| assert(Fortran::semantics::HasAlternateReturns(symbol) && |
| "subroutine does not have alternate returns"); |
| return getSymbolAddress(symbol); |
| } |
| |
| void genFIRProcedureExit(Fortran::lower::pft::FunctionLikeUnit &funit, |
| const Fortran::semantics::Symbol &symbol) { |
| if (mlir::Block *finalBlock = funit.finalBlock) { |
| // The current block must end with a terminator. |
| if (blockIsUnterminated()) |
| builder->create<mlir::cf::BranchOp>(toLocation(), finalBlock); |
| // Set insertion point to final block. |
| builder->setInsertionPoint(finalBlock, finalBlock->end()); |
| } |
| if (Fortran::semantics::IsFunction(symbol)) { |
| genReturnSymbol(symbol); |
| } else if (Fortran::semantics::HasAlternateReturns(symbol)) { |
| mlir::Value retval = builder->create<fir::LoadOp>( |
| toLocation(), getAltReturnResult(symbol)); |
| bridge.openAccCtx().finalizeAndPop(); |
| bridge.fctCtx().finalizeAndPop(); |
| builder->create<mlir::func::ReturnOp>(toLocation(), retval); |
| } else { |
| bridge.openAccCtx().finalizeAndPop(); |
| bridge.fctCtx().finalizeAndPop(); |
| genExitRoutine(); |
| } |
| } |
| |
| // |
| // Statements that have control-flow semantics |
| // |
| |
| /// Generate an If[Then]Stmt condition or its negation. |
| template <typename A> |
| mlir::Value genIfCondition(const A *stmt, bool negate = false) { |
| mlir::Location loc = toLocation(); |
| Fortran::lower::StatementContext stmtCtx; |
| mlir::Value condExpr = createFIRExpr( |
| loc, |
| Fortran::semantics::GetExpr( |
| std::get<Fortran::parser::ScalarLogicalExpr>(stmt->t)), |
| stmtCtx); |
| stmtCtx.finalizeAndReset(); |
| mlir::Value cond = |
| builder->createConvert(loc, builder->getI1Type(), condExpr); |
| if (negate) |
| cond = builder->create<mlir::arith::XOrIOp>( |
| loc, cond, builder->createIntegerConstant(loc, cond.getType(), 1)); |
| return cond; |
| } |
| |
| mlir::func::FuncOp getFunc(llvm::StringRef name, mlir::FunctionType ty) { |
| if (mlir::func::FuncOp func = builder->getNamedFunction(name)) { |
| assert(func.getFunctionType() == ty); |
| return func; |
| } |
| return builder->createFunction(toLocation(), name, ty); |
| } |
| |
| /// Lowering of CALL statement |
| void genFIR(const Fortran::parser::CallStmt &stmt) { |
| Fortran::lower::StatementContext stmtCtx; |
| Fortran::lower::pft::Evaluation &eval = getEval(); |
| setCurrentPosition(stmt.source); |
| assert(stmt.typedCall && "Call was not analyzed"); |
| mlir::Value res{}; |
| if (lowerToHighLevelFIR()) { |
| std::optional<mlir::Type> resultType; |
| if (stmt.typedCall->hasAlternateReturns()) |
| resultType = builder->getIndexType(); |
| auto hlfirRes = Fortran::lower::convertCallToHLFIR( |
| toLocation(), *this, *stmt.typedCall, resultType, localSymbols, |
| stmtCtx); |
| if (hlfirRes) |
| res = *hlfirRes; |
| } else { |
| // Call statement lowering shares code with function call lowering. |
| res = Fortran::lower::createSubroutineCall( |
| *this, *stmt.typedCall, explicitIterSpace, implicitIterSpace, |
| localSymbols, stmtCtx, /*isUserDefAssignment=*/false); |
| } |
| stmtCtx.finalizeAndReset(); |
| if (!res) |
| return; // "Normal" subroutine call. |
| // Call with alternate return specifiers. |
| // The call returns an index that selects an alternate return branch target. |
| llvm::SmallVector<int64_t> indexList; |
| llvm::SmallVector<Fortran::parser::Label> labelList; |
| int64_t index = 0; |
| for (const Fortran::parser::ActualArgSpec &arg : |
| std::get<std::list<Fortran::parser::ActualArgSpec>>(stmt.call.t)) { |
| const auto &actual = std::get<Fortran::parser::ActualArg>(arg.t); |
| if (const auto *altReturn = |
| std::get_if<Fortran::parser::AltReturnSpec>(&actual.u)) { |
| indexList.push_back(++index); |
| labelList.push_back(altReturn->v); |
| } |
| } |
| genMultiwayBranch(res, indexList, labelList, eval.nonNopSuccessor()); |
| } |
| |
| void genFIR(const Fortran::parser::ComputedGotoStmt &stmt) { |
| Fortran::lower::StatementContext stmtCtx; |
| Fortran::lower::pft::Evaluation &eval = getEval(); |
| mlir::Value selectExpr = |
| createFIRExpr(toLocation(), |
| Fortran::semantics::GetExpr( |
| std::get<Fortran::parser::ScalarIntExpr>(stmt.t)), |
| stmtCtx); |
| stmtCtx.finalizeAndReset(); |
| llvm::SmallVector<int64_t> indexList; |
| llvm::SmallVector<Fortran::parser::Label> labelList; |
| int64_t index = 0; |
| for (Fortran::parser::Label label : |
| std::get<std::list<Fortran::parser::Label>>(stmt.t)) { |
| indexList.push_back(++index); |
| labelList.push_back(label); |
| } |
| genMultiwayBranch(selectExpr, indexList, labelList, eval.nonNopSuccessor()); |
| } |
| |
| void genFIR(const Fortran::parser::ArithmeticIfStmt &stmt) { |
| Fortran::lower::StatementContext stmtCtx; |
| mlir::Value expr = createFIRExpr( |
| toLocation(), |
| Fortran::semantics::GetExpr(std::get<Fortran::parser::Expr>(stmt.t)), |
| stmtCtx); |
| stmtCtx.finalizeAndReset(); |
| // Raise an exception if REAL expr is a NaN. |
| if (mlir::isa<mlir::FloatType>(expr.getType())) |
| expr = builder->create<mlir::arith::AddFOp>(toLocation(), expr, expr); |
| // An empty valueList indicates to genMultiwayBranch that the branch is |
| // an ArithmeticIfStmt that has two branches on value 0 or 0.0. |
| llvm::SmallVector<int64_t> valueList; |
| llvm::SmallVector<Fortran::parser::Label> labelList; |
| labelList.push_back(std::get<1>(stmt.t)); |
| labelList.push_back(std::get<3>(stmt.t)); |
| const Fortran::lower::pft::LabelEvalMap &labelEvaluationMap = |
| getEval().getOwningProcedure()->labelEvaluationMap; |
| const auto iter = labelEvaluationMap.find(std::get<2>(stmt.t)); |
| assert(iter != labelEvaluationMap.end() && "label missing from map"); |
| genMultiwayBranch(expr, valueList, labelList, *iter->second); |
| } |
| |
| void genFIR(const Fortran::parser::AssignedGotoStmt &stmt) { |
| // See Fortran 90 Clause 8.2.4. |
| // Relax the requirement that the GOTO variable must have a value in the |
| // label list when a list is present, and allow a branch to any non-format |
| // target that has an ASSIGN statement for the variable. |
| mlir::Location loc = toLocation(); |
| Fortran::lower::pft::Evaluation &eval = getEval(); |
| Fortran::lower::pft::FunctionLikeUnit &owningProc = |
| *eval.getOwningProcedure(); |
| const Fortran::lower::pft::SymbolLabelMap &symbolLabelMap = |
| owningProc.assignSymbolLabelMap; |
| const Fortran::lower::pft::LabelEvalMap &labelEvalMap = |
| owningProc.labelEvaluationMap; |
| const Fortran::semantics::Symbol &symbol = |
| *std::get<Fortran::parser::Name>(stmt.t).symbol; |
| auto labelSetIter = symbolLabelMap.find(symbol); |
| llvm::SmallVector<int64_t> valueList; |
| llvm::SmallVector<Fortran::parser::Label> labelList; |
| if (labelSetIter != symbolLabelMap.end()) { |
| for (auto &label : labelSetIter->second) { |
| const auto evalIter = labelEvalMap.find(label); |
| assert(evalIter != labelEvalMap.end() && "assigned goto label missing"); |
| if (evalIter->second->block) { // non-format statement |
| valueList.push_back(label); // label as an integer |
| labelList.push_back(label); |
| } |
| } |
| } |
| if (!labelList.empty()) { |
| auto selectExpr = |
| builder->create<fir::LoadOp>(loc, getSymbolAddress(symbol)); |
| // Add a default error target in case the goto is nonconforming. |
| mlir::Block *errorBlock = |
| builder->getBlock()->splitBlock(builder->getInsertionPoint()); |
| genMultiwayBranch(selectExpr, valueList, labelList, |
| eval.nonNopSuccessor(), errorBlock); |
| startBlock(errorBlock); |
| } |
| fir::runtime::genReportFatalUserError( |
| *builder, loc, |
| "Assigned GOTO variable '" + symbol.name().ToString() + |
| "' does not have a valid target label value"); |
| builder->create<fir::UnreachableOp>(loc); |
| } |
| |
| fir::ReduceOperationEnum |
| getReduceOperationEnum(const Fortran::parser::ReductionOperator &rOpr) { |
| switch (rOpr.v) { |
| case Fortran::parser::ReductionOperator::Operator::Plus: |
| return fir::ReduceOperationEnum::Add; |
| case Fortran::parser::ReductionOperator::Operator::Multiply: |
| return fir::ReduceOperationEnum::Multiply; |
| case Fortran::parser::ReductionOperator::Operator::And: |
| return fir::ReduceOperationEnum::AND; |
| case Fortran::parser::ReductionOperator::Operator::Or: |
| return fir::ReduceOperationEnum::OR; |
| case Fortran::parser::ReductionOperator::Operator::Eqv: |
| return fir::ReduceOperationEnum::EQV; |
| case Fortran::parser::ReductionOperator::Operator::Neqv: |
| return fir::ReduceOperationEnum::NEQV; |
| case Fortran::parser::ReductionOperator::Operator::Max: |
| return fir::ReduceOperationEnum::MAX; |
| case Fortran::parser::ReductionOperator::Operator::Min: |
| return fir::ReduceOperationEnum::MIN; |
| case Fortran::parser::ReductionOperator::Operator::Iand: |
| return fir::ReduceOperationEnum::IAND; |
| case Fortran::parser::ReductionOperator::Operator::Ior: |
| return fir::ReduceOperationEnum::IOR; |
| case Fortran::parser::ReductionOperator::Operator::Ieor: |
| return fir::ReduceOperationEnum::EIOR; |
| } |
| llvm_unreachable("illegal reduction operator"); |
| } |
| |
| /// Collect DO CONCURRENT or FORALL loop control information. |
| IncrementLoopNestInfo getConcurrentControl( |
| const Fortran::parser::ConcurrentHeader &header, |
| const std::list<Fortran::parser::LocalitySpec> &localityList = {}) { |
| IncrementLoopNestInfo incrementLoopNestInfo; |
| for (const Fortran::parser::ConcurrentControl &control : |
| std::get<std::list<Fortran::parser::ConcurrentControl>>(header.t)) |
| incrementLoopNestInfo.emplace_back( |
| *std::get<0>(control.t).symbol, std::get<1>(control.t), |
| std::get<2>(control.t), std::get<3>(control.t), /*isUnordered=*/true); |
| IncrementLoopInfo &info = incrementLoopNestInfo.back(); |
| info.maskExpr = Fortran::semantics::GetExpr( |
| std::get<std::optional<Fortran::parser::ScalarLogicalExpr>>(header.t)); |
| for (const Fortran::parser::LocalitySpec &x : localityList) { |
| if (const auto *localList = |
| std::get_if<Fortran::parser::LocalitySpec::Local>(&x.u)) |
| for (const Fortran::parser::Name &x : localList->v) |
| info.localSymList.push_back(x.symbol); |
| if (const auto *localInitList = |
| std::get_if<Fortran::parser::LocalitySpec::LocalInit>(&x.u)) |
| for (const Fortran::parser::Name &x : localInitList->v) |
| info.localInitSymList.push_back(x.symbol); |
| for (IncrementLoopInfo &info : incrementLoopNestInfo) { |
| if (const auto *reduceList = |
| std::get_if<Fortran::parser::LocalitySpec::Reduce>(&x.u)) { |
| fir::ReduceOperationEnum reduce_operation = getReduceOperationEnum( |
| std::get<Fortran::parser::ReductionOperator>(reduceList->t)); |
| for (const Fortran::parser::Name &x : |
| std::get<std::list<Fortran::parser::Name>>(reduceList->t)) { |
| info.reduceSymList.push_back( |
| std::make_pair(reduce_operation, x.symbol)); |
| } |
| } |
| } |
| if (const auto *sharedList = |
| std::get_if<Fortran::parser::LocalitySpec::Shared>(&x.u)) |
| for (const Fortran::parser::Name &x : sharedList->v) |
| info.sharedSymList.push_back(x.symbol); |
| } |
| return incrementLoopNestInfo; |
| } |
| |
| /// Create DO CONCURRENT construct symbol bindings and generate LOCAL_INIT |
| /// assignments. |
| void handleLocalitySpecs(const IncrementLoopInfo &info) { |
| Fortran::semantics::SemanticsContext &semanticsContext = |
| bridge.getSemanticsContext(); |
| for (const Fortran::semantics::Symbol *sym : info.localSymList) |
| createHostAssociateVarClone(*sym); |
| for (const Fortran::semantics::Symbol *sym : info.localInitSymList) { |
| createHostAssociateVarClone(*sym); |
| const auto *hostDetails = |
| sym->detailsIf<Fortran::semantics::HostAssocDetails>(); |
| assert(hostDetails && "missing locality spec host symbol"); |
| const Fortran::semantics::Symbol *hostSym = &hostDetails->symbol(); |
| Fortran::evaluate::ExpressionAnalyzer ea{semanticsContext}; |
| Fortran::evaluate::Assignment assign{ |
| ea.Designate(Fortran::evaluate::DataRef{*sym}).value(), |
| ea.Designate(Fortran::evaluate::DataRef{*hostSym}).value()}; |
| if (Fortran::semantics::IsPointer(*sym)) |
| assign.u = Fortran::evaluate::Assignment::BoundsSpec{}; |
| genAssignment(assign); |
| } |
| for (const Fortran::semantics::Symbol *sym : info.sharedSymList) { |
| const auto *hostDetails = |
| sym->detailsIf<Fortran::semantics::HostAssocDetails>(); |
| copySymbolBinding(hostDetails->symbol(), *sym); |
| } |
| } |
| |
| /// Generate FIR for a DO construct. There are six variants: |
| /// - unstructured infinite and while loops |
| /// - structured and unstructured increment loops |
| /// - structured and unstructured concurrent loops |
| void genFIR(const Fortran::parser::DoConstruct &doConstruct) { |
| setCurrentPositionAt(doConstruct); |
| // Collect loop nest information. |
| // Generate begin loop code directly for infinite and while loops. |
| Fortran::lower::pft::Evaluation &eval = getEval(); |
| bool unstructuredContext = eval.lowerAsUnstructured(); |
| Fortran::lower::pft::Evaluation &doStmtEval = |
| eval.getFirstNestedEvaluation(); |
| auto *doStmt = doStmtEval.getIf<Fortran::parser::NonLabelDoStmt>(); |
| const auto &loopControl = |
| std::get<std::optional<Fortran::parser::LoopControl>>(doStmt->t); |
| mlir::Block *preheaderBlock = doStmtEval.block; |
| mlir::Block *beginBlock = |
| preheaderBlock ? preheaderBlock : builder->getBlock(); |
| auto createNextBeginBlock = [&]() { |
| // Step beginBlock through unstructured preheader, header, and mask |
| // blocks, created in outermost to innermost order. |
| return beginBlock = beginBlock->splitBlock(beginBlock->end()); |
| }; |
| mlir::Block *headerBlock = |
| unstructuredContext ? createNextBeginBlock() : nullptr; |
| mlir::Block *bodyBlock = doStmtEval.lexicalSuccessor->block; |
| mlir::Block *exitBlock = doStmtEval.parentConstruct->constructExit->block; |
| IncrementLoopNestInfo incrementLoopNestInfo; |
| const Fortran::parser::ScalarLogicalExpr *whileCondition = nullptr; |
| bool infiniteLoop = !loopControl.has_value(); |
| if (infiniteLoop) { |
| assert(unstructuredContext && "infinite loop must be unstructured"); |
| startBlock(headerBlock); |
| } else if ((whileCondition = |
| std::get_if<Fortran::parser::ScalarLogicalExpr>( |
| &loopControl->u))) { |
| assert(unstructuredContext && "while loop must be unstructured"); |
| maybeStartBlock(preheaderBlock); // no block or empty block |
| startBlock(headerBlock); |
| genConditionalBranch(*whileCondition, bodyBlock, exitBlock); |
| } else if (const auto *bounds = |
| std::get_if<Fortran::parser::LoopControl::Bounds>( |
| &loopControl->u)) { |
| // Non-concurrent increment loop. |
| IncrementLoopInfo &info = incrementLoopNestInfo.emplace_back( |
| *bounds->name.thing.symbol, bounds->lower, bounds->upper, |
| bounds->step); |
| if (unstructuredContext) { |
| maybeStartBlock(preheaderBlock); |
| info.hasRealControl = info.loopVariableSym->GetType()->IsNumeric( |
| Fortran::common::TypeCategory::Real); |
| info.headerBlock = headerBlock; |
| info.bodyBlock = bodyBlock; |
| info.exitBlock = exitBlock; |
| } |
| } else { |
| const auto *concurrent = |
| std::get_if<Fortran::parser::LoopControl::Concurrent>( |
| &loopControl->u); |
| assert(concurrent && "invalid DO loop variant"); |
| incrementLoopNestInfo = getConcurrentControl( |
| std::get<Fortran::parser::ConcurrentHeader>(concurrent->t), |
| std::get<std::list<Fortran::parser::LocalitySpec>>(concurrent->t)); |
| if (unstructuredContext) { |
| maybeStartBlock(preheaderBlock); |
| for (IncrementLoopInfo &info : incrementLoopNestInfo) { |
| // The original loop body provides the body and latch blocks of the |
| // innermost dimension. The (first) body block of a non-innermost |
| // dimension is the preheader block of the immediately enclosed |
| // dimension. The latch block of a non-innermost dimension is the |
| // exit block of the immediately enclosed dimension. |
| auto createNextExitBlock = [&]() { |
| // Create unstructured loop exit blocks, outermost to innermost. |
| return exitBlock = insertBlock(exitBlock); |
| }; |
| bool isInnermost = &info == &incrementLoopNestInfo.back(); |
| bool isOutermost = &info == &incrementLoopNestInfo.front(); |
| info.headerBlock = isOutermost ? headerBlock : createNextBeginBlock(); |
| info.bodyBlock = isInnermost ? bodyBlock : createNextBeginBlock(); |
| info.exitBlock = isOutermost ? exitBlock : createNextExitBlock(); |
| if (info.maskExpr) |
| info.maskBlock = createNextBeginBlock(); |
| } |
| } |
| } |
| |
| // Increment loop begin code. (Infinite/while code was already generated.) |
| if (!infiniteLoop && !whileCondition) |
| genFIRIncrementLoopBegin(incrementLoopNestInfo, doStmtEval.dirs); |
| |
| // Loop body code. |
| auto iter = eval.getNestedEvaluations().begin(); |
| for (auto end = --eval.getNestedEvaluations().end(); iter != end; ++iter) |
| genFIR(*iter, unstructuredContext); |
| |
| // An EndDoStmt in unstructured code may start a new block. |
| Fortran::lower::pft::Evaluation &endDoEval = *iter; |
| assert(endDoEval.getIf<Fortran::parser::EndDoStmt>() && "no enddo stmt"); |
| if (unstructuredContext) |
| maybeStartBlock(endDoEval.block); |
| |
| // Loop end code. |
| if (infiniteLoop || whileCondition) |
| genBranch(headerBlock); |
| else |
| genFIRIncrementLoopEnd(incrementLoopNestInfo); |
| |
| // This call may generate a branch in some contexts. |
| genFIR(endDoEval, unstructuredContext); |
| } |
| |
| /// Generate FIR to evaluate loop control values (lower, upper and step). |
| mlir::Value genControlValue(const Fortran::lower::SomeExpr *expr, |
| const IncrementLoopInfo &info, |
| bool *isConst = nullptr) { |
| mlir::Location loc = toLocation(); |
| mlir::Type controlType = info.isStructured() ? builder->getIndexType() |
| : info.getLoopVariableType(); |
| Fortran::lower::StatementContext stmtCtx; |
| if (expr) { |
| if (isConst) |
| *isConst = Fortran::evaluate::IsConstantExpr(*expr); |
| return builder->createConvert(loc, controlType, |
| createFIRExpr(loc, expr, stmtCtx)); |
| } |
| |
| if (isConst) |
| *isConst = true; |
| if (info.hasRealControl) |
| return builder->createRealConstant(loc, controlType, 1u); |
| return builder->createIntegerConstant(loc, controlType, 1); // step |
| } |
| |
| void addLoopAnnotationAttr(IncrementLoopInfo &info) { |
| mlir::BoolAttr f = mlir::BoolAttr::get(builder->getContext(), false); |
| mlir::LLVM::LoopVectorizeAttr va = mlir::LLVM::LoopVectorizeAttr::get( |
| builder->getContext(), /*disable=*/f, {}, {}, {}, {}, {}, {}); |
| mlir::LLVM::LoopAnnotationAttr la = mlir::LLVM::LoopAnnotationAttr::get( |
| builder->getContext(), {}, /*vectorize=*/va, {}, {}, {}, {}, {}, {}, {}, |
| {}, {}, {}, {}, {}, {}); |
| info.doLoop.setLoopAnnotationAttr(la); |
| } |
| |
| /// Generate FIR to begin a structured or unstructured increment loop nest. |
| void genFIRIncrementLoopBegin( |
| IncrementLoopNestInfo &incrementLoopNestInfo, |
| llvm::SmallVectorImpl<const Fortran::parser::CompilerDirective *> &dirs) { |
| assert(!incrementLoopNestInfo.empty() && "empty loop nest"); |
| mlir::Location loc = toLocation(); |
| mlir::Operation *boundsAndStepIP = nullptr; |
| |
| for (IncrementLoopInfo &info : incrementLoopNestInfo) { |
| mlir::Value lowerValue; |
| mlir::Value upperValue; |
| mlir::Value stepValue; |
| |
| { |
| mlir::OpBuilder::InsertionGuard guard(*builder); |
| |
| // Set the IP before the first loop in the nest so that all nest bounds |
| // and step values are created outside the nest. |
| if (boundsAndStepIP) |
| builder->setInsertionPointAfter(boundsAndStepIP); |
| |
| info.loopVariable = genLoopVariableAddress(loc, *info.loopVariableSym, |
| info.isUnordered); |
| lowerValue = genControlValue(info.lowerExpr, info); |
| upperValue = genControlValue(info.upperExpr, info); |
| bool isConst = true; |
| stepValue = genControlValue(info.stepExpr, info, |
| info.isStructured() ? nullptr : &isConst); |
| boundsAndStepIP = stepValue.getDefiningOp(); |
| |
| // Use a temp variable for unstructured loops with non-const step. |
| if (!isConst) { |
| info.stepVariable = |
| builder->createTemporary(loc, stepValue.getType()); |
| boundsAndStepIP = |
| builder->create<fir::StoreOp>(loc, stepValue, info.stepVariable); |
| } |
| } |
| |
| // Structured loop - generate fir.do_loop. |
| if (info.isStructured()) { |
| mlir::Type loopVarType = info.getLoopVariableType(); |
| mlir::Value loopValue; |
| if (info.isUnordered) { |
| llvm::SmallVector<mlir::Value> reduceOperands; |
| llvm::SmallVector<mlir::Attribute> reduceAttrs; |
| // Create DO CONCURRENT reduce operands and attributes |
| for (const auto &reduceSym : info.reduceSymList) { |
| const fir::ReduceOperationEnum reduce_operation = reduceSym.first; |
| const Fortran::semantics::Symbol *sym = reduceSym.second; |
| fir::ExtendedValue exv = getSymbolExtendedValue(*sym, nullptr); |
| reduceOperands.push_back(fir::getBase(exv)); |
| auto reduce_attr = |
| fir::ReduceAttr::get(builder->getContext(), reduce_operation); |
| reduceAttrs.push_back(reduce_attr); |
| } |
| // The loop variable value is explicitly updated. |
| info.doLoop = builder->create<fir::DoLoopOp>( |
| loc, lowerValue, upperValue, stepValue, /*unordered=*/true, |
| /*finalCountValue=*/false, /*iterArgs=*/std::nullopt, |
| llvm::ArrayRef<mlir::Value>(reduceOperands), reduceAttrs); |
| builder->setInsertionPointToStart(info.doLoop.getBody()); |
| loopValue = builder->createConvert(loc, loopVarType, |
| info.doLoop.getInductionVar()); |
| } else { |
| // The loop variable is a doLoop op argument. |
| info.doLoop = builder->create<fir::DoLoopOp>( |
| loc, lowerValue, upperValue, stepValue, /*unordered=*/false, |
| /*finalCountValue=*/true, |
| builder->createConvert(loc, loopVarType, lowerValue)); |
| builder->setInsertionPointToStart(info.doLoop.getBody()); |
| loopValue = info.doLoop.getRegionIterArgs()[0]; |
| } |
| // Update the loop variable value in case it has non-index references. |
| builder->create<fir::StoreOp>(loc, loopValue, info.loopVariable); |
| if (info.maskExpr) { |
| Fortran::lower::StatementContext stmtCtx; |
| mlir::Value maskCond = createFIRExpr(loc, info.maskExpr, stmtCtx); |
| stmtCtx.finalizeAndReset(); |
| mlir::Value maskCondCast = |
| builder->createConvert(loc, builder->getI1Type(), maskCond); |
| auto ifOp = builder->create<fir::IfOp>(loc, maskCondCast, |
| /*withElseRegion=*/false); |
| builder->setInsertionPointToStart(&ifOp.getThenRegion().front()); |
| } |
| if (info.hasLocalitySpecs()) |
| handleLocalitySpecs(info); |
| |
| for (const auto *dir : dirs) { |
| Fortran::common::visit( |
| Fortran::common::visitors{ |
| [&](const Fortran::parser::CompilerDirective::VectorAlways |
| &d) { addLoopAnnotationAttr(info); }, |
| [&](const auto &) {}}, |
| dir->u); |
| } |
| continue; |
| } |
| |
| // Unstructured loop preheader - initialize tripVariable and loopVariable. |
| mlir::Value tripCount; |
| if (info.hasRealControl) { |
| auto diff1 = |
| builder->create<mlir::arith::SubFOp>(loc, upperValue, lowerValue); |
| auto diff2 = |
| builder->create<mlir::arith::AddFOp>(loc, diff1, stepValue); |
| tripCount = builder->create<mlir::arith::DivFOp>(loc, diff2, stepValue); |
| tripCount = |
| builder->createConvert(loc, builder->getIndexType(), tripCount); |
| } else { |
| auto diff1 = |
| builder->create<mlir::arith::SubIOp>(loc, upperValue, lowerValue); |
| auto diff2 = |
| builder->create<mlir::arith::AddIOp>(loc, diff1, stepValue); |
| tripCount = |
| builder->create<mlir::arith::DivSIOp>(loc, diff2, stepValue); |
| } |
| if (forceLoopToExecuteOnce) { // minimum tripCount is 1 |
| mlir::Value one = |
| builder->createIntegerConstant(loc, tripCount.getType(), 1); |
| auto cond = builder->create<mlir::arith::CmpIOp>( |
| loc, mlir::arith::CmpIPredicate::slt, tripCount, one); |
| tripCount = |
| builder->create<mlir::arith::SelectOp>(loc, cond, one, tripCount); |
| } |
| info.tripVariable = builder->createTemporary(loc, tripCount.getType()); |
| builder->create<fir::StoreOp>(loc, tripCount, info.tripVariable); |
| builder->create<fir::StoreOp>(loc, lowerValue, info.loopVariable); |
| |
| // Unstructured loop header - generate loop condition and mask. |
| // Note - Currently there is no way to tag a loop as a concurrent loop. |
| startBlock(info.headerBlock); |
| tripCount = builder->create<fir::LoadOp>(loc, info.tripVariable); |
| mlir::Value zero = |
| builder->createIntegerConstant(loc, tripCount.getType(), 0); |
| auto cond = builder->create<mlir::arith::CmpIOp>( |
| loc, mlir::arith::CmpIPredicate::sgt, tripCount, zero); |
| if (info.maskExpr) { |
| genConditionalBranch(cond, info.maskBlock, info.exitBlock); |
| startBlock(info.maskBlock); |
| mlir::Block *latchBlock = getEval().getLastNestedEvaluation().block; |
| assert(latchBlock && "missing masked concurrent loop latch block"); |
| Fortran::lower::StatementContext stmtCtx; |
| mlir::Value maskCond = createFIRExpr(loc, info.maskExpr, stmtCtx); |
| stmtCtx.finalizeAndReset(); |
| genConditionalBranch(maskCond, info.bodyBlock, latchBlock); |
| } else { |
| genConditionalBranch(cond, info.bodyBlock, info.exitBlock); |
| if (&info != &incrementLoopNestInfo.back()) // not innermost |
| startBlock(info.bodyBlock); // preheader block of enclosed dimension |
| } |
| if (info.hasLocalitySpecs()) { |
| mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint(); |
| builder->setInsertionPointToStart(info.bodyBlock); |
| handleLocalitySpecs(info); |
| builder->restoreInsertionPoint(insertPt); |
| } |
| } |
| } |
| |
| /// Generate FIR to end a structured or unstructured increment loop nest. |
| void genFIRIncrementLoopEnd(IncrementLoopNestInfo &incrementLoopNestInfo) { |
| assert(!incrementLoopNestInfo.empty() && "empty loop nest"); |
| mlir::Location loc = toLocation(); |
| mlir::arith::IntegerOverflowFlags flags{}; |
| if (getLoweringOptions().getNSWOnLoopVarInc()) |
| flags = bitEnumSet(flags, mlir::arith::IntegerOverflowFlags::nsw); |
| auto iofAttr = mlir::arith::IntegerOverflowFlagsAttr::get( |
| builder->getContext(), flags); |
| for (auto it = incrementLoopNestInfo.rbegin(), |
| rend = incrementLoopNestInfo.rend(); |
| it != rend; ++it) { |
| IncrementLoopInfo &info = *it; |
| if (info.isStructured()) { |
| // End fir.do_loop. |
| if (info.isUnordered) { |
| builder->setInsertionPointAfter(info.doLoop); |
| continue; |
| } |
| // Decrement tripVariable. |
| builder->setInsertionPointToEnd(info.doLoop.getBody()); |
| llvm::SmallVector<mlir::Value, 2> results; |
| results.push_back(builder->create<mlir::arith::AddIOp>( |
| loc, info.doLoop.getInductionVar(), info.doLoop.getStep(), |
| iofAttr)); |
| // Step loopVariable to help optimizations such as vectorization. |
| // Induction variable elimination will clean up as necessary. |
| mlir::Value step = builder->createConvert( |
| loc, info.getLoopVariableType(), info.doLoop.getStep()); |
| mlir::Value loopVar = |
| builder->create<fir::LoadOp>(loc, info.loopVariable); |
| results.push_back( |
| builder->create<mlir::arith::AddIOp>(loc, loopVar, step, iofAttr)); |
| builder->create<fir::ResultOp>(loc, results); |
| builder->setInsertionPointAfter(info.doLoop); |
| // The loop control variable may be used after the loop. |
| builder->create<fir::StoreOp>(loc, info.doLoop.getResult(1), |
| info.loopVariable); |
| continue; |
| } |
| |
| // Unstructured loop - decrement tripVariable and step loopVariable. |
| mlir::Value tripCount = |
| builder->create<fir::LoadOp>(loc, info.tripVariable); |
| mlir::Value one = |
| builder->createIntegerConstant(loc, tripCount.getType(), 1); |
| tripCount = builder->create<mlir::arith::SubIOp>(loc, tripCount, one); |
| builder->create<fir::StoreOp>(loc, tripCount, info.tripVariable); |
| mlir::Value value = builder->create<fir::LoadOp>(loc, info.loopVariable); |
| mlir::Value step; |
| if (info.stepVariable) |
| step = builder->create<fir::LoadOp>(loc, info.stepVariable); |
| else |
| step = genControlValue(info.stepExpr, info); |
| if (info.hasRealControl) |
| value = builder->create<mlir::arith::AddFOp>(loc, value, step); |
| else |
| value = builder->create<mlir::arith::AddIOp>(loc, value, step, iofAttr); |
| builder->create<fir::StoreOp>(loc, value, info.loopVariable); |
| |
| genBranch(info.headerBlock); |
| if (&info != &incrementLoopNestInfo.front()) // not outermost |
| startBlock(info.exitBlock); // latch block of enclosing dimension |
| } |
| } |
| |
| /// Generate structured or unstructured FIR for an IF construct. |
| /// The initial statement may be either an IfStmt or an IfThenStmt. |
| void genFIR(const Fortran::parser::IfConstruct &) { |
| Fortran::lower::pft::Evaluation &eval = getEval(); |
| |
| // Structured fir.if nest. |
| if (eval.lowerAsStructured()) { |
| fir::IfOp topIfOp, currentIfOp; |
| for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) { |
| auto genIfOp = [&](mlir::Value cond) { |
| Fortran::lower::pft::Evaluation &succ = *e.controlSuccessor; |
| bool hasElse = succ.isA<Fortran::parser::ElseIfStmt>() || |
| succ.isA<Fortran::parser::ElseStmt>(); |
| auto ifOp = builder->create<fir::IfOp>(toLocation(), cond, |
| /*withElseRegion=*/hasElse); |
| builder->setInsertionPointToStart(&ifOp.getThenRegion().front()); |
| return ifOp; |
| }; |
| setCurrentPosition(e.position); |
| if (auto *s = e.getIf<Fortran::parser::IfThenStmt>()) { |
| topIfOp = currentIfOp = genIfOp(genIfCondition(s, e.negateCondition)); |
| } else if (auto *s = e.getIf<Fortran::parser::IfStmt>()) { |
| topIfOp = currentIfOp = genIfOp(genIfCondition(s, e.negateCondition)); |
| } else if (auto *s = e.getIf<Fortran::parser::ElseIfStmt>()) { |
| builder->setInsertionPointToStart( |
| ¤tIfOp.getElseRegion().front()); |
| currentIfOp = genIfOp(genIfCondition(s)); |
| } else if (e.isA<Fortran::parser::ElseStmt>()) { |
| builder->setInsertionPointToStart( |
| ¤tIfOp.getElseRegion().front()); |
| } else if (e.isA<Fortran::parser::EndIfStmt>()) { |
| builder->setInsertionPointAfter(topIfOp); |
| genFIR(e, /*unstructuredContext=*/false); // may generate branch |
| } else { |
| genFIR(e, /*unstructuredContext=*/false); |
| } |
| } |
| return; |
| } |
| |
| // Unstructured branch sequence. |
| llvm::SmallVector<Fortran::lower::pft::Evaluation *> exits, fallThroughs; |
| collectFinalEvaluations(eval, exits, fallThroughs); |
| |
| for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) { |
| auto genIfBranch = [&](mlir::Value cond) { |
| if (e.lexicalSuccessor == e.controlSuccessor) // empty block -> exit |
| genConditionalBranch(cond, e.parentConstruct->constructExit, |
| e.controlSuccessor); |
| else // non-empty block |
| genConditionalBranch(cond, e.lexicalSuccessor, e.controlSuccessor); |
| }; |
| setCurrentPosition(e.position); |
| if (auto *s = e.getIf<Fortran::parser::IfThenStmt>()) { |
| maybeStartBlock(e.block); |
| genIfBranch(genIfCondition(s, e.negateCondition)); |
| } else if (auto *s = e.getIf<Fortran::parser::IfStmt>()) { |
| maybeStartBlock(e.block); |
| genIfBranch(genIfCondition(s, e.negateCondition)); |
| } else if (auto *s = e.getIf<Fortran::parser::ElseIfStmt>()) { |
| startBlock(e.block); |
| genIfBranch(genIfCondition(s)); |
| } else { |
| genFIR(e); |
| if (blockIsUnterminated()) { |
| if (llvm::is_contained(exits, &e)) |
| genConstructExitBranch(*eval.constructExit); |
| else if (llvm::is_contained(fallThroughs, &e)) |
| genBranch(e.lexicalSuccessor->block); |
| } |
| } |
| } |
| } |
| |
| void genCaseOrRankConstruct() { |
| Fortran::lower::pft::Evaluation &eval = getEval(); |
| Fortran::lower::StatementContext stmtCtx; |
| pushActiveConstruct(eval, stmtCtx); |
| |
| llvm::SmallVector<Fortran::lower::pft::Evaluation *> exits, fallThroughs; |
| collectFinalEvaluations(eval, exits, fallThroughs); |
| |
| for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) { |
| if (e.getIf<Fortran::parser::EndSelectStmt>()) |
| maybeStartBlock(e.block); |
| else |
| genFIR(e); |
| if (blockIsUnterminated()) { |
| if (llvm::is_contained(exits, &e)) |
| genConstructExitBranch(*eval.constructExit); |
| else if (llvm::is_contained(fallThroughs, &e)) |
| genBranch(e.lexicalSuccessor->block); |
| } |
| } |
| popActiveConstruct(); |
| } |
| void genFIR(const Fortran::parser::CaseConstruct &) { |
| genCaseOrRankConstruct(); |
| } |
| |
| template <typename A> |
| void genNestedStatement(const Fortran::parser::Statement<A> &stmt) { |
| setCurrentPosition(stmt.source); |
| genFIR(stmt.statement); |
| } |
| |
| /// Force the binding of an explicit symbol. This is used to bind and re-bind |
| /// a concurrent control symbol to its value. |
| void forceControlVariableBinding(const Fortran::semantics::Symbol *sym, |
| mlir::Value inducVar) { |
| mlir::Location loc = toLocation(); |
| assert(sym && "There must be a symbol to bind"); |
| mlir::Type toTy = genType(*sym); |
| // FIXME: this should be a "per iteration" temporary. |
| mlir::Value tmp = |
| builder->createTemporary(loc, toTy, toStringRef(sym->name()), |
| llvm::ArrayRef<mlir::NamedAttribute>{ |
| fir::getAdaptToByRefAttr(*builder)}); |
| mlir::Value cast = builder->createConvert(loc, toTy, inducVar); |
| builder->create<fir::StoreOp>(loc, cast, tmp); |
| addSymbol(*sym, tmp, /*force=*/true); |
| } |
| |
| /// Process a concurrent header for a FORALL. (Concurrent headers for DO |
| /// CONCURRENT loops are lowered elsewhere.) |
| void genFIR(const Fortran::parser::ConcurrentHeader &header) { |
| llvm::SmallVector<mlir::Value> lows; |
| llvm::SmallVector<mlir::Value> highs; |
| llvm::SmallVector<mlir::Value> steps; |
| if (explicitIterSpace.isOutermostForall()) { |
| // For the outermost forall, we evaluate the bounds expressions once. |
| // Contrastingly, if this forall is nested, the bounds expressions are |
| // assumed to be pure, possibly dependent on outer concurrent control |
| // variables, possibly variant with respect to arguments, and will be |
| // re-evaluated. |
| mlir::Location loc = toLocation(); |
| mlir::Type idxTy = builder->getIndexType(); |
| Fortran::lower::StatementContext &stmtCtx = |
| explicitIterSpace.stmtContext(); |
| auto lowerExpr = [&](auto &e) { |
| return fir::getBase(genExprValue(e, stmtCtx)); |
| }; |
| for (const Fortran::parser::ConcurrentControl &ctrl : |
| std::get<std::list<Fortran::parser::ConcurrentControl>>(header.t)) { |
| const Fortran::lower::SomeExpr *lo = |
| Fortran::semantics::GetExpr(std::get<1>(ctrl.t)); |
| const Fortran::lower::SomeExpr *hi = |
| Fortran::semantics::GetExpr(std::get<2>(ctrl.t)); |
| auto &optStep = |
| std::get<std::optional<Fortran::parser::ScalarIntExpr>>(ctrl.t); |
| lows.push_back(builder->createConvert(loc, idxTy, lowerExpr(*lo))); |
| highs.push_back(builder->createConvert(loc |