Index: flang/docs/BijectiveInternalNameUniquing.md =================================================================== --- flang/docs/BijectiveInternalNameUniquing.md +++ flang/docs/BijectiveInternalNameUniquing.md @@ -1,3 +1,11 @@ + + # Bijective Internal Name Uniquing ```eval_rst @@ -5,35 +13,33 @@ :local: ``` -FIR has a flat namespace. No two objects may have the same name at -the module level. (These would be functions, globals, etc.) -This necessitates some sort of encoding scheme to unique -symbols from the front-end into FIR. +FIR has a flat namespace. No two objects may have the same name at the module +level. (These would be functions, globals, etc.) This necessitates some sort +of encoding scheme to unique symbols from the front-end into FIR. -Another requirement is -to be able to reverse these unique names and recover the associated -symbol in the symbol table. +Another requirement is to be able to reverse these unique names and recover +the associated symbol in the symbol table. -Fortran is case insensitive, which allows the compiler to convert the -user's identifiers to all lower case. Such a universal conversion implies -that all upper case letters are available for use in uniquing. +Fortran is case insensitive, which allows the compiler to convert the user's +identifiers to all lower case. Such a universal conversion implies that all +upper case letters are available for use in uniquing. ## Prefix `_Q` -All uniqued names have the prefix sequence `_Q` to indicate the name has -been uniqued. (Q is chosen because it is a -[low frequency letter](http://pi.math.cornell.edu/~mec/2003-2004/cryptography/subs/frequencies.html) +All uniqued names have the prefix sequence `_Q` to indicate the name has been +uniqued. (Q is chosen because it is a [low frequency letter](http://pi.math.cornell.edu/~mec/2003-2004/cryptography/subs/frequencies.html) in English.) ## Scope Building -Symbols can be scoped by the module, submodule, or procedure that contains -that symbol. After the `_Q` sigil, names are constructed from outermost to -innermost scope as +Symbols are scoped by any module, submodule, procedure, and block that +contains that symbol. After the `_Q` sigil, names are constructed from +outermost to innermost scope as * Module name prefixed with `M` - * Submodule name prefixed with `S` - * Procedure name prefixed with `F` + * Submodule name/s prefixed with `S` + * Procedure name/s prefixed with `F` + * Innermost block index prefixed with `B` Given: ``` @@ -50,18 +56,39 @@ _QMmodSs1modSs2modFsubPfun ``` +## Prefix tag summary + +| Tag | Description +| ----| --------------------------------------------------------- | +| B | Block ("name" is a compiler generated integer index) +| C | Common block +| D | Dispatch table (compiler internal) +| E | variable Entity +| EC | Constant Entity +| F | procedure/Function (as a prefix) +| K | Kind +| KN | Negative Kind +| M | Module +| N | Namelist group +| P | Procedure/function (as itself) +| Q | uniQue mangled name tag +| S | Submodule +| T | derived Type +| Y | tYpe descriptor (compiler internal) +| YI | tYpe descriptor for an Intrinsic type (compiler internal) + ## Common blocks - * A common block name will be prefixed with `B` + * A common block name will be prefixed with `C` Given: ``` - common /variables/ i, j + common /work/ i, j ``` -The uniqued name of `variables` becomes: +The uniqued name of `work` becomes: ``` - _QBvariables + _QCwork ``` Given: @@ -71,7 +98,7 @@ The uniqued name in case of `blank common block` becomes: ``` - _QB + _QC ``` ## Module scope global data @@ -97,20 +124,70 @@ _QMmodECpi ``` -## Procedures/Subprograms +## Procedures - * A procedure/subprogram is prefixed with `P` + * A procedure/subprogram as itself is prefixed with `P` + * A procedure/subprogram as an ancestor name is prefixed with `F` + +Procedures are the only names that are themselves uniqued, as well as +appearing as a prefix component of other uniqued names. Given: ``` subroutine sub + real, save :: x(1000) + ... ``` The uniqued name of `sub` becomes: ``` _QPsub ``` +The uniqued name of `x` becomes: +``` + _QFsubEx +``` + +## Blocks + + * A block is prefixed with `B`; the block "name" is a compiler generated + index + +Each block has a per-procedure preorder index. The prefix for the immediately +containing block construct is unique within the procedure. + +Given: +``` + subroutine sub + block + block + real, save :: x(1000) + ... + end block + ... + end block +``` +The uniqued name of `x` becomes: +``` + _QFsubB2Ex +``` + +## Namelist groups + + * A namelist group is prefixed with `N` + +Given: +``` + subroutine sub + real, save :: x(1000) + namelist /temps/ x + ... +``` +The uniqued name of `temps` becomes: +``` + _QFsubNtemps +``` -## Derived types and related +## Derived types * A derived type is prefixed with `T` * If a derived type has KIND parameters, they are listed in a consistent @@ -146,16 +223,15 @@ _QTyourtypeK4KN6 ``` - * A derived type dispatch table is prefixed with `D`. The dispatch table + * A derived type dispatch table is prefixed with `D`. The dispatch table for `type t` would be `_QDTt` - * A type descriptor instance is prefixed with `C`. Intrinsic types can - be encoded with their names and kinds. The type descriptor for the - type `yourtype` above would be `_QCTyourtypeK4KN6`. The type + * A type descriptor instance is prefixed with `C`. Intrinsic types can + be encoded with their names and kinds. The type descriptor for the + type `yourtype` above would be `_QCTyourtypeK4KN6`. The type descriptor for `REAL(4)` would be `_QCrealK4`. -## Compiler generated names +## Compiler internal names -Compiler generated names do not have to be mapped back to Fortran. These -names will be prefixed with `_QQ` and followed by a unique compiler -generated identifier. There is, of course, no mapping back to a symbol -derived from the input source in this case as no such symbol exists. +Compiler generated names do not have to be mapped back to Fortran. This +includes names prefixed with `_QQ`, tag `D` for a type bound procedure +dispatch table, and tags `Y` and `YI` for runtime type descriptors. Index: flang/include/flang/Lower/AbstractConverter.h =================================================================== --- flang/include/flang/Lower/AbstractConverter.h +++ flang/include/flang/Lower/AbstractConverter.h @@ -28,11 +28,6 @@ class FirOpBuilder; } // namespace fir -namespace fir { -class KindMapping; -class FirOpBuilder; -} // namespace fir - namespace Fortran { namespace common { template @@ -233,6 +228,9 @@ virtual mlir::MLIRContext &getMLIRContext() = 0; /// Unique a symbol virtual std::string mangleName(const Fortran::semantics::Symbol &) = 0; + /// Unique a derived type + virtual std::string + mangleName(const Fortran::semantics::DerivedTypeSpec &) = 0; /// Get the KindMap. virtual const fir::KindMapping &getKindMap() = 0; Index: flang/include/flang/Lower/IterationSpace.h =================================================================== --- flang/include/flang/Lower/IterationSpace.h +++ flang/include/flang/Lower/IterationSpace.h @@ -191,7 +191,7 @@ assert(!empty()); stack.pop_back(); if (empty()) { - stmtCtx.finalize(); + stmtCtx.finalizeAndReset(); vmap.clear(); } } @@ -522,7 +522,7 @@ const ExplicitIterSpace &); /// Finalize the current body statement context. - void finalizeContext() { stmtCtx.finalize(); } + void finalizeContext() { stmtCtx.finalizeAndReset(); } void appendLoops(const llvm::SmallVector &loops) { loopStack.push_back(loops); Index: flang/include/flang/Lower/Mangler.h =================================================================== --- flang/include/flang/Lower/Mangler.h +++ flang/include/flang/Lower/Mangler.h @@ -26,22 +26,29 @@ } namespace semantics { +class Scope; class Symbol; class DerivedTypeSpec; } // namespace semantics namespace lower::mangle { -/// Convert a front-end Symbol to an internal name. -/// If \p keepExternalInScope is true, the mangling of external symbols -/// retains the scope of the symbol declaring externals. Otherwise, -/// external symbols are mangled outside of any scope. Keeping the scope is -/// useful in attributes where all the Fortran context is to be maintained. +using ScopeBlockIdMap = + llvm::DenseMap; + +/// Convert a front-end symbol to a unique internal name. +/// A symbol that could be in a block scope must provide a ScopeBlockIdMap. +/// If \p keepExternalInScope is true, mangling an external symbol retains +/// the scope of the symbol. This is useful when setting the attributes of +/// a symbol where all the Fortran context is needed. Otherwise, external +/// symbols are mangled outside of any scope. +std::string mangleName(const semantics::Symbol &, ScopeBlockIdMap &, + bool keepExternalInScope = false); std::string mangleName(const semantics::Symbol &, bool keepExternalInScope = false); /// Convert a derived type instance to an internal name. -std::string mangleName(const semantics::DerivedTypeSpec &); +std::string mangleName(const semantics::DerivedTypeSpec &, ScopeBlockIdMap &); /// Recover the bare name of the original symbol from an internal name. std::string demangleName(llvm::StringRef name); Index: flang/include/flang/Lower/PFTBuilder.h =================================================================== --- flang/include/flang/Lower/PFTBuilder.h +++ flang/include/flang/Lower/PFTBuilder.h @@ -205,7 +205,7 @@ /// from EvaluationTuple type (std::tuple). using EvaluationVariant = MakeReferenceVariant; -/// Function-like units contain lists of evaluations. These can be simple +/// Function-like units contain lists of evaluations. These can be simple /// statements or constructs, where a construct contains its own evaluations. struct Evaluation : EvaluationVariant { @@ -308,35 +308,36 @@ bool lowerAsStructured() const; bool lowerAsUnstructured() const; + bool forceAsUnstructured() const; // FIR generation looks primarily at PFT ActionStmt and ConstructStmt leaf - // nodes. Members such as lexicalSuccessor and block are applicable only - // to these nodes, plus some directives. The controlSuccessor member is - // used for nonlexical successors, such as linking to a GOTO target. For - // multiway branches, it is set to the first target. Successor and exit - // links always target statements or directives. An internal Construct + // nodes. Members such as lexicalSuccessor and block are applicable only + // to these nodes, plus some directives. The controlSuccessor member is + // used for nonlexical successors, such as linking to a GOTO target. For + // multiway branches, it is set to the first target. Successor and exit + // links always target statements or directives. An internal Construct // node has a constructExit link that applies to exits from anywhere within // the construct. // - // An unstructured construct is one that contains some form of goto. This + // An unstructured construct is one that contains some form of goto. This // is indicated by the isUnstructured member flag, which may be set on a - // statement and propagated to enclosing constructs. This distinction allows + // statement and propagated to enclosing constructs. This distinction allows // a structured IF or DO statement to be materialized with custom structured - // FIR operations. An unstructured statement is materialized as mlir + // FIR operations. An unstructured statement is materialized as mlir // operation sequences that include explicit branches. // - // The block member is set for statements that begin a new block. This - // block is the target of any branch to the statement. Statements may have + // The block member is set for statements that begin a new block. This + // block is the target of any branch to the statement. Statements may have // additional (unstructured) "local" blocks, but such blocks cannot be the - // target of any explicit branch. The primary example of an (unstructured) + // target of any explicit branch. The primary example of an (unstructured) // statement that may have multiple associated blocks is NonLabelDoStmt, // which may have a loop preheader block for loop initialization code (the // block member), and always has a "local" header block that is the target - // of the loop back edge. If the NonLabelDoStmt is a concurrent loop, it + // of the loop back edge. If the NonLabelDoStmt is a concurrent loop, it // may be associated with an arbitrary number of nested preheader, header, // and mask blocks. // - // The printIndex member is only set for statements. It is used for dumps + // The printIndex member is only set for statements. It is used for dumps // (and debugging) and does not affect FIR generation. PftNode parent; @@ -350,6 +351,7 @@ bool isNewBlock{false}; // evaluation begins a new basic block bool isUnstructured{false}; // evaluation has unstructured control flow bool negateCondition{false}; // If[Then]Stmt condition must be negated + bool activeConstruct{false}; // temporarily set for some constructs mlir::Block *block{nullptr}; // isNewBlock block (ActionStmt, ConstructStmt) int printIndex{0}; // (ActionStmt, ConstructStmt) evaluation index for dumps }; @@ -692,16 +694,16 @@ LabelEvalMap labelEvaluationMap; SymbolLabelMap assignSymbolLabelMap; std::list nestedFunctions; - /// pairs for each entry point. The pair at index 0 + /// pairs for each entry point. The pair at index 0 /// is the primary entry point; remaining pairs are alternate entry points. /// The primary entry point symbol is Null for an anonymous program. - /// A named program symbol has MainProgramDetails. Other symbols have - /// SubprogramDetails. Evaluations are filled in for alternate entries. + /// A named program symbol has MainProgramDetails. Other symbols have + /// SubprogramDetails. Evaluations are filled in for alternate entries. llvm::SmallVector, 1> entryPointList{std::pair{nullptr, nullptr}}; - /// Current index into entryPointList. Index 0 is the primary entry point. + /// Current index into entryPointList. Index 0 is the primary entry point. int activeEntry = 0; - /// Primary result for function subprograms with alternate entries. This + /// Primary result for function subprograms with alternate entries. This /// is one of the largest result values, not necessarily the first one. const semantics::Symbol *primaryResult{nullptr}; /// Terminal basic block (if any) @@ -830,9 +832,9 @@ /// /// A PFT is a light weight tree over the parse tree that is used to create FIR. /// The PFT captures pointers back into the parse tree, so the parse tree must -/// not be changed between the construction of the PFT and its last use. The -/// PFT captures a structured view of a program. A program is a list of units. -/// A function like unit contains a list of evaluations. An evaluation is +/// not be changed between the construction of the PFT and its last use. The +/// PFT captures a structured view of a program. A program is a list of units. +/// A function like unit contains a list of evaluations. An evaluation is /// either a statement, or a construct with a nested list of evaluations. std::unique_ptr createPFT(const parser::Program &root, Index: flang/include/flang/Lower/StatementContext.h =================================================================== --- flang/include/flang/Lower/StatementContext.h +++ flang/include/flang/Lower/StatementContext.h @@ -21,11 +21,19 @@ namespace Fortran::lower { /// When lowering a statement, temporaries for intermediate results may be -/// allocated on the heap. A StatementContext enables their deallocation -/// either explicitly with finalize() calls, or implicitly at the end of -/// the context. A context may prohibit temporary allocation. Otherwise, -/// an initial "outer" context scope may have nested context scopes, which -/// must make explicit subscope finalize() calls. +/// allocated on the heap. A StatementContext enables their deallocation +/// with one of several explicit finalize calls, or with an implicit +/// call to finalizeAndPop() at the end of the context. A context may prohibit +/// temporary allocation. Otherwise, an initial "outer" context scope may have +/// nested context scopes, which must make explicit subscope finalize calls. +/// +/// In addition to being useful for individual action statement contexts, a +/// StatementContext is also useful for construct blocks delimited by a pair +/// of statements such as (block-stmt, end-block-stmt), or a program unit +/// delimited by a pair of statements such as (subroutine-stmt, end-subroutine- +/// stmt). Attached cleanup code for these contexts may include stack +/// management code, deallocation code, and finalization of derived type +/// entities in the context. class StatementContext { public: explicit StatementContext(bool cleanupProhibited = false) { @@ -62,29 +70,29 @@ } } - /// Make cleanup calls. Retain the stack top list for a repeat call. + /// Make cleanup calls. Retain the stack top list for a repeat call. void finalizeAndKeep() { assert(!cufs.empty() && "invalid finalize statement context"); if (cufs.back()) (*cufs.back())(); } - /// Make cleanup calls. Pop the stack top list. - void finalizeAndPop() { + /// Make cleanup calls. Clear the stack top list. + void finalizeAndReset() { finalizeAndKeep(); - cufs.pop_back(); + cufs.back().reset(); } - /// Make cleanup calls. Clear the stack top list. - void finalize() { + /// Make cleanup calls. Pop the stack top list. + void finalizeAndPop() { finalizeAndKeep(); - cufs.back().reset(); + cufs.pop_back(); } - bool workListIsEmpty() const { - return cufs.empty() || llvm::all_of(cufs, [](auto &opt) -> bool { - return !opt.has_value(); - }); + bool hasCode() const { + return !cufs.empty() && llvm::any_of(cufs, [](auto &opt) -> bool { + return opt.has_value(); + }); } private: Index: flang/include/flang/Optimizer/Support/InternalNames.h =================================================================== --- flang/include/flang/Optimizer/Support/InternalNames.h +++ flang/include/flang/Optimizer/Support/InternalNames.h @@ -43,23 +43,25 @@ DISPATCH_TABLE, GENERATED, INTRINSIC_TYPE_DESC, + NAMELIST_GROUP, PROCEDURE, TYPE_DESC, - VARIABLE, - NAMELIST_GROUP + VARIABLE }; /// Components of an unparsed unique name struct DeconstructedName { DeconstructedName(llvm::StringRef name) : name{name} {} DeconstructedName(llvm::ArrayRef modules, - std::optional host, llvm::StringRef name, - llvm::ArrayRef kinds) - : modules{modules.begin(), modules.end()}, host{host}, name{name}, - kinds{kinds.begin(), kinds.end()} {} + llvm::ArrayRef procs, std::int64_t blockId, + llvm::StringRef name, llvm::ArrayRef kinds) + : modules{modules.begin(), modules.end()}, procs{procs.begin(), + procs.end()}, + blockId{blockId}, name{name}, kinds{kinds.begin(), kinds.end()} {} llvm::SmallVector modules; - std::optional host; + llvm::SmallVector procs; + std::int64_t blockId; std::string name; llvm::SmallVector kinds; }; @@ -67,18 +69,15 @@ /// Unique a common block name static std::string doCommonBlock(llvm::StringRef name); - /// Unique a block data unit name - static std::string doBlockData(llvm::StringRef name); - /// Unique a (global) constant name static std::string doConstant(llvm::ArrayRef modules, - std::optional host, - llvm::StringRef name); + llvm::ArrayRef procs, + std::int64_t block, llvm::StringRef name); /// Unique a dispatch table name static std::string doDispatchTable(llvm::ArrayRef modules, - std::optional host, - llvm::StringRef name, + llvm::ArrayRef procs, + std::int64_t block, llvm::StringRef name, llvm::ArrayRef kinds); /// Unique a compiler generated name @@ -87,39 +86,40 @@ /// Unique an intrinsic type descriptor static std::string doIntrinsicTypeDescriptor(llvm::ArrayRef modules, - std::optional host, - IntrinsicType type, std::int64_t kind); + llvm::ArrayRef procs, + std::int64_t block, IntrinsicType type, + std::int64_t kind); /// Unique a procedure name static std::string doProcedure(llvm::ArrayRef modules, - std::optional host, + llvm::ArrayRef procs, llvm::StringRef name); /// Unique a derived type name static std::string doType(llvm::ArrayRef modules, - std::optional host, - llvm::StringRef name, + llvm::ArrayRef procs, + std::int64_t block, llvm::StringRef name, llvm::ArrayRef kinds); /// Unique a (derived) type descriptor name static std::string doTypeDescriptor(llvm::ArrayRef modules, - std::optional host, - llvm::StringRef name, + llvm::ArrayRef procs, + std::int64_t block, llvm::StringRef name, llvm::ArrayRef kinds); static std::string doTypeDescriptor(llvm::ArrayRef modules, - std::optional host, - llvm::StringRef name, + llvm::ArrayRef procs, + std::int64_t block, llvm::StringRef name, llvm::ArrayRef kinds); /// Unique a (global) variable name. A variable with save attribute /// defined inside a subprogram also needs to be handled here static std::string doVariable(llvm::ArrayRef modules, - std::optional host, - llvm::StringRef name); + llvm::ArrayRef procs, + std::int64_t block, llvm::StringRef name); /// Unique a namelist group name static std::string doNamelistGroup(llvm::ArrayRef modules, - std::optional host, + llvm::ArrayRef procs, llvm::StringRef name); /// Entry point for the PROGRAM (called by the runtime) Index: flang/lib/Lower/Bridge.cpp =================================================================== --- flang/lib/Lower/Bridge.cpp +++ flang/lib/Lower/Bridge.cpp @@ -118,6 +118,17 @@ 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 +}; + /// Helper class to generate the runtime type info global data. This data /// is required to describe the derived type to the runtime so that it can /// operate over it. It must be ensured this data will be generated for every @@ -185,10 +196,11 @@ }; public: - void registerTypeSpec(mlir::Location loc, + void registerTypeSpec(Fortran::lower::AbstractConverter &converter, + mlir::Location loc, const Fortran::semantics::DerivedTypeSpec *typeSpec) { assert(typeSpec && "type spec is null"); - std::string dtName = Fortran::lower::mangle::mangleName(*typeSpec); + std::string dtName = converter.mangleName(*typeSpec); if (seen.contains(dtName) || dtName.find("__fortran") != std::string::npos) return; seen.insert(dtName); @@ -197,13 +209,12 @@ void createDispatchTableOps(Fortran::lower::AbstractConverter &converter) { for (const DispatchTableInfo &info : registeredDispatchTableInfo) { - std::string dtName = Fortran::lower::mangle::mangleName(*info.typeSpec); + std::string dtName = converter.mangleName(*info.typeSpec); const Fortran::semantics::DerivedTypeSpec *parent = Fortran::evaluate::GetParentTypeSpec(*info.typeSpec); fir::FirOpBuilder &builder = converter.getFirOpBuilder(); fir::DispatchTableOp dt = builder.createDispatchTableOp( - info.loc, dtName, - parent ? Fortran::lower::mangle::mangleName(*parent) : ""); + info.loc, dtName, parent ? converter.mangleName(*parent) : ""); auto insertPt = builder.saveInsertionPoint(); const Fortran::semantics::Scope *scope = info.typeSpec->scope(); if (!scope) @@ -217,8 +228,7 @@ for (const Fortran::semantics::SymbolRef &binding : bindings) { const auto *details = binding.get().detailsIf(); - std::string bindingName = - Fortran::lower::mangle::mangleName(details->symbol()); + std::string bindingName = converter.mangleName(details->symbol()); builder.create( info.loc, mlir::StringAttr::get(builder.getContext(), @@ -667,7 +677,7 @@ Fortran::lower::StatementContext stmtCtx; Fortran::lower::createSomeArrayAssignment(*this, lhs, rhs, localSymbols, stmtCtx); - stmtCtx.finalize(); + stmtCtx.finalizeAndReset(); } else if (hexv.getBoxOf()) { fir::factory::CharacterExprHelper{*builder, loc}.createAssign(lhs, rhs); } else if (hexv.getBoxOf()) { @@ -745,14 +755,24 @@ } std::string mangleName(const Fortran::semantics::Symbol &symbol) override final { - return Fortran::lower::mangle::mangleName(symbol); + return Fortran::lower::mangle::mangleName(symbol, scopeBlockIdMap); + } + std::string mangleName( + const Fortran::semantics::DerivedTypeSpec &derivedType) override final { + return Fortran::lower::mangle::mangleName(derivedType, 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()) + return activeConstructStack.back().stmtCtx; return bridge.fctCtx(); } @@ -773,7 +793,7 @@ void registerDispatchTableInfo( mlir::Location loc, const Fortran::semantics::DerivedTypeSpec *typeSpec) override final { - dispatchTableConverter.registerTypeSpec(loc, typeSpec); + dispatchTableConverter.registerTypeSpec(*this, loc, typeSpec); } private: @@ -913,7 +933,7 @@ return cat == Fortran::common::TypeCategory::Derived; } - /// Insert a new block before \p block. Leave the insertion point unchanged. + /// 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); @@ -921,24 +941,21 @@ return newBlock; } - mlir::Block *blockOfLabel(Fortran::lower::pft::Evaluation &eval, - Fortran::parser::Label label) { + Fortran::lower::pft::Evaluation &evalOfLabel(Fortran::parser::Label label) { const Fortran::lower::pft::LabelEvalMap &labelEvaluationMap = - eval.getOwningProcedure()->labelEvaluationMap; + getEval().getOwningProcedure()->labelEvaluationMap; const auto iter = labelEvaluationMap.find(label); assert(iter != labelEvaluationMap.end() && "label missing from map"); - mlir::Block *block = iter->second->block; - assert(block && "missing labeled evaluation block"); - return block; + return *iter->second; } - void genFIRBranch(mlir::Block *targetBlock) { + void genBranch(mlir::Block *targetBlock) { assert(targetBlock && "missing unconditional target block"); builder->create(toLocation(), targetBlock); } - void genFIRConditionalBranch(mlir::Value cond, mlir::Block *trueTarget, - mlir::Block *falseTarget) { + 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(); @@ -946,28 +963,183 @@ builder->create(loc, bcc, trueTarget, std::nullopt, falseTarget, std::nullopt); } - void genFIRConditionalBranch(mlir::Value cond, - Fortran::lower::pft::Evaluation *trueTarget, - Fortran::lower::pft::Evaluation *falseTarget) { - genFIRConditionalBranch(cond, trueTarget->block, falseTarget->block); + void genConditionalBranch(mlir::Value cond, + Fortran::lower::pft::Evaluation *trueTarget, + Fortran::lower::pft::Evaluation *falseTarget) { + genConditionalBranch(cond, trueTarget->block, falseTarget->block); } - void genFIRConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr, - mlir::Block *trueTarget, - mlir::Block *falseTarget) { + 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.finalize(); - genFIRConditionalBranch(cond, trueTarget, falseTarget); + stmtCtx.finalizeAndReset(); + genConditionalBranch(cond, trueTarget, falseTarget); } - void genFIRConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr, - Fortran::lower::pft::Evaluation *trueTarget, - Fortran::lower::pft::Evaluation *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.finalize(); - genFIRConditionalBranch(cond, trueTarget->block, falseTarget->block); + 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); + } + + /// 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. + /// + /// There are two special cases. If \p inIoErrContext, the ERR label branch + /// is an inverted comparison (ne vs. eq 0). An empty \p valueList indicates + /// an ArithmeticIfStmt context that requires two comparisons against 0, + /// and the selector may have either INTEGER or REAL type. + /// + /// 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 valueList, + llvm::SmallVector labelList, + const Fortran::lower::pft::Evaluation &defaultEval, + bool inIoErrContext = false) { + bool inArithmeticIfContext = valueList.empty(); + assert(((inArithmeticIfContext && labelList.size() == 2) || + (valueList.size() && labelList.size() == valueList.size())) && + "mismatched multiway branch targets"); + bool defaultHasExitCode = hasExitCode(defaultEval); + bool hasAnyExitCode = defaultHasExitCode; + if (!hasAnyExitCode) + for (auto label : labelList) + if (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 blockList; + for (auto label : labelList) + blockList.push_back(evalOfLabel(label).block); + blockList.push_back(defaultEval.block); + if (inIoErrContext) { // Swap ERR and default fallthrough blocks. + assert(!valueList[branchCount - 1] && "invalid IO ERR value"); + std::swap(blockList[branchCount - 1], blockList[branchCount]); + } + builder->create(loc, selector, valueList, blockList); + return; + } + mlir::Type selectorType = selector.getType(); + bool realSelector = selectorType.isa(); + assert((inArithmeticIfContext || !realSelector) && "invalid selector type"); + mlir::Value zero; + if (inArithmeticIfContext) + zero = + realSelector + ? builder->create( + 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( + loc, + label.index() == 0 ? mlir::arith::CmpFPredicate::OLT + : mlir::arith::CmpFPredicate::OGT, + selector, zero); + else if (inArithmeticIfContext) + cond = builder->create( + loc, + label.index() == 0 ? mlir::arith::CmpIPredicate::slt + : mlir::arith::CmpIPredicate::sgt, + selector, zero); + else + cond = builder->create( + loc, + inIoErrContext && 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. defaultEval acts as an "else" target. + bool lastBranch = label.index() == branchCount - 1; + mlir::Block *nextBlock = + lastBranch && !defaultHasExitCode + ? defaultEval.block + : builder->getBlock()->splitBlock(builder->getInsertionPoint()); + if (hasExitCode(evalOfLabel(label.value()))) { + mlir::Block *jumpBlock = + builder->getBlock()->splitBlock(builder->getInsertionPoint()); + genConditionalBranch(cond, jumpBlock, nextBlock); + startBlock(jumpBlock); + genConstructExitBranch(evalOfLabel(label.value())); + } else { + genConditionalBranch(cond, evalOfLabel(label.value()).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; + activeConstructStack.pop_back(); } //===--------------------------------------------------------------------===// @@ -1008,7 +1180,7 @@ 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. + // 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(loc, resultRef); @@ -1062,7 +1234,7 @@ Fortran::semantics::GetExpr( std::get(stmt->t)), stmtCtx); - stmtCtx.finalize(); + stmtCtx.finalizeAndReset(); mlir::Value cond = builder->createConvert(loc, builder->getI1Type(), condExpr); if (negate) @@ -1101,12 +1273,13 @@ *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 indexList; - llvm::SmallVector blockList; + llvm::SmallVector labelList; int64_t index = 0; for (const Fortran::parser::ActualArgSpec &arg : std::get>(stmt.v.t)) { @@ -1114,12 +1287,10 @@ if (const auto *altReturn = std::get_if(&actual.u)) { indexList.push_back(++index); - blockList.push_back(blockOfLabel(eval, altReturn->v)); + labelList.push_back(altReturn->v); } } - blockList.push_back(eval.nonNopSuccessor().block); // default = fallthrough - stmtCtx.finalize(); - builder->create(toLocation(), res, indexList, blockList); + genMultiwayBranch(res, indexList, labelList, eval.nonNopSuccessor()); } void genFIR(const Fortran::parser::ComputedGotoStmt &stmt) { @@ -1130,66 +1301,37 @@ Fortran::semantics::GetExpr( std::get(stmt.t)), stmtCtx); - stmtCtx.finalize(); + stmtCtx.finalizeAndReset(); llvm::SmallVector indexList; - llvm::SmallVector blockList; + llvm::SmallVector labelList; int64_t index = 0; for (Fortran::parser::Label label : std::get>(stmt.t)) { indexList.push_back(++index); - blockList.push_back(blockOfLabel(eval, label)); + labelList.push_back(label); } - blockList.push_back(eval.nonNopSuccessor().block); // default - builder->create(toLocation(), selectExpr, indexList, - blockList); + genMultiwayBranch(selectExpr, indexList, labelList, eval.nonNopSuccessor()); } void genFIR(const Fortran::parser::ArithmeticIfStmt &stmt) { Fortran::lower::StatementContext stmtCtx; - Fortran::lower::pft::Evaluation &eval = getEval(); mlir::Value expr = createFIRExpr( toLocation(), Fortran::semantics::GetExpr(std::get(stmt.t)), stmtCtx); - stmtCtx.finalize(); - mlir::Type exprType = expr.getType(); - mlir::Location loc = toLocation(); - if (exprType.isSignlessInteger()) { - // Arithmetic expression has Integer type. Generate a SelectCaseOp - // with ranges {(-inf:-1], 0=default, [1:inf)}. - mlir::MLIRContext *context = builder->getContext(); - llvm::SmallVector attrList; - llvm::SmallVector valueList; - llvm::SmallVector blockList; - attrList.push_back(fir::UpperBoundAttr::get(context)); - valueList.push_back(builder->createIntegerConstant(loc, exprType, -1)); - blockList.push_back(blockOfLabel(eval, std::get<1>(stmt.t))); - attrList.push_back(fir::LowerBoundAttr::get(context)); - valueList.push_back(builder->createIntegerConstant(loc, exprType, 1)); - blockList.push_back(blockOfLabel(eval, std::get<3>(stmt.t))); - attrList.push_back(mlir::UnitAttr::get(context)); // 0 is the "default" - blockList.push_back(blockOfLabel(eval, std::get<2>(stmt.t))); - builder->create(loc, expr, attrList, valueList, - blockList); - return; - } - // Arithmetic expression has Real type. Generate - // sum = expr + expr [ raise an exception if expr is a NaN ] - // if (sum < 0.0) goto L1 else if (sum > 0.0) goto L3 else goto L2 - auto sum = builder->create(loc, expr, expr); - auto zero = builder->create( - loc, exprType, builder->getFloatAttr(exprType, 0.0)); - auto cond1 = builder->create( - loc, mlir::arith::CmpFPredicate::OLT, sum, zero); - mlir::Block *elseIfBlock = - builder->getBlock()->splitBlock(builder->getInsertionPoint()); - genFIRConditionalBranch(cond1, blockOfLabel(eval, std::get<1>(stmt.t)), - elseIfBlock); - startBlock(elseIfBlock); - auto cond2 = builder->create( - loc, mlir::arith::CmpFPredicate::OGT, sum, zero); - genFIRConditionalBranch(cond2, blockOfLabel(eval, std::get<3>(stmt.t)), - blockOfLabel(eval, std::get<2>(stmt.t))); + stmtCtx.finalizeAndReset(); + // Raise an exception if REAL expr is a NaN. + if (expr.getType().isa()) + expr = builder->create(toLocation(), expr, expr); + llvm::SmallVector valueList; + llvm::SmallVector 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) { @@ -1213,33 +1355,30 @@ auto iter = symbolLabelMap.find(symbol); if (iter == symbolLabelMap.end()) { // Fail for a nonconforming program unit that does not have any ASSIGN - // statements. The front end should check for this. + // statements. The front end should check for this. mlir::emitError(loc, "(semantics issue) no assigned goto targets"); exit(1); } auto labelSet = iter->second; - llvm::SmallVector indexList; - llvm::SmallVector blockList; - auto addLabel = [&](Fortran::parser::Label label) { - indexList.push_back(label); - blockList.push_back(blockOfLabel(eval, label)); - }; - // Add labels from an explicit list. The list may have duplicates. + llvm::SmallVector valueList; + llvm::SmallVector labelList; + // Add labels from an explicit list. The list may have duplicates. for (Fortran::parser::Label label : std::get>(stmt.t)) { - if (labelSet.count(label) && - !llvm::is_contained(indexList, label)) { // ignore duplicates - addLabel(label); + // Ignore duplicates. + if (labelSet.count(label) && !llvm::is_contained(labelList, label)) { + valueList.push_back(label); // label as an integer + labelList.push_back(label); } } // Absent an explicit list, add all possible label targets. - if (indexList.empty()) - for (auto &label : labelSet) - addLabel(label); - // Add a nop/fallthrough branch to the switch for a nonconforming program - // unit that violates the program requirement above. - blockList.push_back(eval.nonNopSuccessor().block); // default - builder->create(loc, selectExpr, indexList, blockList); + if (labelList.empty()) + for (auto &label : labelSet) { + valueList.push_back(label); // label as an integer + labelList.push_back(label); + } + // Add a nop/fallthrough branch for a nonconforming program. + genMultiwayBranch(selectExpr, valueList, labelList, eval.nonNopSuccessor()); } /// Collect DO CONCURRENT or FORALL loop control information. @@ -1270,7 +1409,7 @@ return incrementLoopNestInfo; } - /// Generate FIR for a DO construct. There are six variants: + /// 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 @@ -1309,7 +1448,7 @@ assert(unstructuredContext && "while loop must be unstructured"); maybeStartBlock(preheaderBlock); // no block or empty block startBlock(headerBlock); - genFIRConditionalBranch(*whileCondition, bodyBlock, exitBlock); + genConditionalBranch(*whileCondition, bodyBlock, exitBlock); } else if (const auto *bounds = std::get_if( &loopControl->u)) { @@ -1337,9 +1476,9 @@ 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 + // 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 + // 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. @@ -1356,7 +1495,7 @@ } } - // Increment loop begin code. (Infinite/while code was already generated.) + // Increment loop begin code. (Infinite/while code was already generated.) if (!infiniteLoop && !whileCondition) genFIRIncrementLoopBegin(incrementLoopNestInfo); @@ -1373,7 +1512,7 @@ // Loop end code. if (infiniteLoop || whileCondition) - genFIRBranch(headerBlock); + genBranch(headerBlock); else genFIRIncrementLoopEnd(incrementLoopNestInfo); @@ -1449,7 +1588,7 @@ if (info.maskExpr) { Fortran::lower::StatementContext stmtCtx; mlir::Value maskCond = createFIRExpr(loc, info.maskExpr, stmtCtx); - stmtCtx.finalize(); + stmtCtx.finalizeAndReset(); mlir::Value maskCondCast = builder->createConvert(loc, builder->getI1Type(), maskCond); auto ifOp = builder->create(loc, maskCondCast, @@ -1471,7 +1610,6 @@ builder->create(loc, diff2, info.stepValue); tripCount = builder->createConvert(loc, builder->getIndexType(), tripCount); - } else { auto diff1 = builder->create(loc, upperValue, lowerValue); @@ -1501,16 +1639,16 @@ auto cond = builder->create( loc, mlir::arith::CmpIPredicate::sgt, tripCount, zero); if (info.maskExpr) { - genFIRConditionalBranch(cond, info.maskBlock, info.exitBlock); + 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.finalize(); - genFIRConditionalBranch(maskCond, info.bodyBlock, latchBlock); + stmtCtx.finalizeAndReset(); + genConditionalBranch(maskCond, info.bodyBlock, latchBlock); } else { - genFIRConditionalBranch(cond, info.bodyBlock, info.exitBlock); + genConditionalBranch(cond, info.bodyBlock, info.exitBlock); if (&info != &incrementLoopNestInfo.back()) // not innermost startBlock(info.bodyBlock); // preheader block of enclosed dimension } @@ -1574,7 +1712,7 @@ builder->create(loc, value, info.stepValue); builder->create(loc, value, info.loopVariable); - genFIRBranch(info.headerBlock); + genBranch(info.headerBlock); if (&info != &incrementLoopNestInfo.front()) // not outermost startBlock(info.exitBlock); // latch block of enclosing dimension } @@ -1619,10 +1757,10 @@ for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) { auto genIfBranch = [&](mlir::Value cond) { if (e.lexicalSuccessor == e.controlSuccessor) // empty block -> exit - genFIRConditionalBranch(cond, e.parentConstruct->constructExit, - e.controlSuccessor); + genConditionalBranch(cond, e.parentConstruct->constructExit, + e.controlSuccessor); else // non-empty block - genFIRConditionalBranch(cond, e.lexicalSuccessor, e.controlSuccessor); + genConditionalBranch(cond, e.lexicalSuccessor, e.controlSuccessor); }; if (auto *s = e.getIf()) { maybeStartBlock(e.block); @@ -1640,8 +1778,12 @@ } void genFIR(const Fortran::parser::CaseConstruct &) { + Fortran::lower::pft::Evaluation &eval = getEval(); + Fortran::lower::StatementContext stmtCtx; + pushActiveConstruct(eval, stmtCtx); for (Fortran::lower::pft::Evaluation &e : getEval().getNestedEvaluations()) genFIR(e); + popActiveConstruct(); } template @@ -1912,16 +2054,21 @@ } /// Generate FIR for a SELECT CASE statement. - /// The type may be CHARACTER, INTEGER, or LOGICAL. + /// The selector may have CHARACTER, INTEGER, or LOGICAL type. void genFIR(const Fortran::parser::SelectCaseStmt &stmt) { Fortran::lower::pft::Evaluation &eval = getEval(); - mlir::MLIRContext *context = builder->getContext(); - mlir::Location loc = toLocation(); - Fortran::lower::StatementContext stmtCtx; + Fortran::lower::pft::Evaluation *parentConstruct = eval.parentConstruct; + assert(!activeConstructStack.empty() && + &activeConstructStack.back().eval == parentConstruct && + "select case construct is not active"); + Fortran::lower::StatementContext &stmtCtx = + activeConstructStack.back().stmtCtx; const Fortran::lower::SomeExpr *expr = Fortran::semantics::GetExpr( std::get>(stmt.t)); bool isCharSelector = isCharacterCategory(expr->GetType()->category()); bool isLogicalSelector = isLogicalCategory(expr->GetType()->category()); + mlir::MLIRContext *context = builder->getContext(); + mlir::Location loc = toLocation(); auto charValue = [&](const Fortran::lower::SomeExpr *expr) { fir::ExtendedValue exv = genExprAddr(*expr, stmtCtx, &loc); return exv.match( @@ -1946,7 +2093,7 @@ llvm::SmallVector attrList; llvm::SmallVector valueList; llvm::SmallVector blockList; - mlir::Block *defaultBlock = eval.parentConstruct->constructExit->block; + mlir::Block *defaultBlock = parentConstruct->constructExit->block; using CaseValue = Fortran::parser::Scalar; auto addValue = [&](const CaseValue &caseValue) { const Fortran::lower::SomeExpr *expr = @@ -1998,20 +2145,19 @@ } // Skip a logical default block that can never be referenced. if (isLogicalSelector && attrList.size() == 2) - defaultBlock = eval.parentConstruct->constructExit->block; + defaultBlock = parentConstruct->constructExit->block; attrList.push_back(mlir::UnitAttr::get(context)); blockList.push_back(defaultBlock); - // Generate a fir::SelectCaseOp. - // Explicit branch code is better for the LOGICAL type. The CHARACTER type - // does not yet have downstream support, and also uses explicit branch code. - // The -no-structured-fir option can be used to force generation of INTEGER - // type branch code. - if (!isLogicalSelector && !isCharSelector && eval.lowerAsStructured()) { - // Numeric selector is a ssa register, all temps that may have - // been generated while evaluating it can be cleaned-up before the - // fir.select_case. - stmtCtx.finalize(); + // Generate a fir::SelectCaseOp. Explicit branch code is better for the + // LOGICAL type. The CHARACTER type does not have downstream SelectOp + // support. The -no-structured-fir option can be used to force generation + // of INTEGER type branch code. + if (!isLogicalSelector && !isCharSelector && + !getEval().forceAsUnstructured()) { + // The selector is in an ssa register. Any temps that may have been + // generated while evaluating it can be cleaned up now. + stmtCtx.finalizeAndReset(); builder->create(loc, selector, attrList, valueList, blockList); return; @@ -2020,12 +2166,9 @@ // Generate a sequence of case value comparisons and branches. auto caseValue = valueList.begin(); auto caseBlock = blockList.begin(); - bool skipFinalization = false; - for (const auto &attr : llvm::enumerate(attrList)) { - if (attr.value().isa()) { - if (attrList.size() == 1) - stmtCtx.finalize(); - genFIRBranch(*caseBlock++); + for (mlir::Attribute attr : attrList) { + if (attr.isa()) { + genBranch(*caseBlock++); break; } auto genCond = [&](mlir::Value rhs, @@ -2035,59 +2178,40 @@ fir::factory::CharacterExprHelper charHelper{*builder, loc}; std::pair lhsVal = charHelper.createUnboxChar(selector); - mlir::Value &lhsAddr = lhsVal.first; - mlir::Value &lhsLen = lhsVal.second; std::pair rhsVal = charHelper.createUnboxChar(rhs); - mlir::Value &rhsAddr = rhsVal.first; - mlir::Value &rhsLen = rhsVal.second; - mlir::Value result = fir::runtime::genCharCompare( - *builder, loc, pred, lhsAddr, lhsLen, rhsAddr, rhsLen); - if (stmtCtx.workListIsEmpty() || skipFinalization) - return result; - if (attr.index() == attrList.size() - 2) { - stmtCtx.finalize(); - return result; - } - fir::IfOp ifOp = builder->create(loc, result, - /*withElseRegion=*/false); - builder->setInsertionPointToStart(&ifOp.getThenRegion().front()); - stmtCtx.finalizeAndKeep(); - builder->setInsertionPointAfter(ifOp); - return result; + return fir::runtime::genCharCompare(*builder, loc, pred, lhsVal.first, + lhsVal.second, rhsVal.first, + rhsVal.second); }; mlir::Block *newBlock = insertBlock(*caseBlock); - if (attr.value().isa()) { + if (attr.isa()) { mlir::Block *newBlock2 = insertBlock(*caseBlock); - skipFinalization = true; mlir::Value cond = genCond(*caseValue++, mlir::arith::CmpIPredicate::sge); - genFIRConditionalBranch(cond, newBlock, newBlock2); + genConditionalBranch(cond, newBlock, newBlock2); builder->setInsertionPointToEnd(newBlock); - skipFinalization = false; mlir::Value cond2 = genCond(*caseValue++, mlir::arith::CmpIPredicate::sle); - genFIRConditionalBranch(cond2, *caseBlock++, newBlock2); + genConditionalBranch(cond2, *caseBlock++, newBlock2); builder->setInsertionPointToEnd(newBlock2); continue; } mlir::arith::CmpIPredicate pred; - if (attr.value().isa()) { + if (attr.isa()) { pred = mlir::arith::CmpIPredicate::eq; - } else if (attr.value().isa()) { + } else if (attr.isa()) { pred = mlir::arith::CmpIPredicate::sge; } else { - assert(attr.value().isa() && - "unexpected predicate"); + assert(attr.isa() && "unexpected predicate"); pred = mlir::arith::CmpIPredicate::sle; } mlir::Value cond = genCond(*caseValue++, pred); - genFIRConditionalBranch(cond, *caseBlock++, newBlock); + genConditionalBranch(cond, *caseBlock++, newBlock); builder->setInsertionPointToEnd(newBlock); } assert(caseValue == valueList.end() && caseBlock == blockList.end() && "select case list mismatch"); - assert(stmtCtx.workListIsEmpty() && "statement context must be empty"); } fir::ExtendedValue @@ -2102,8 +2226,9 @@ } void genFIR(const Fortran::parser::AssociateConstruct &) { - Fortran::lower::StatementContext stmtCtx; Fortran::lower::pft::Evaluation &eval = getEval(); + Fortran::lower::StatementContext stmtCtx; + pushActiveConstruct(eval, stmtCtx); for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) { if (auto *stmt = e.getIf()) { if (eval.lowerAsUnstructured()) @@ -2120,23 +2245,52 @@ } else if (e.getIf()) { if (eval.lowerAsUnstructured()) maybeStartBlock(e.block); - stmtCtx.finalize(); localSymbols.popScope(); } else { genFIR(e); } } + popActiveConstruct(); } void genFIR(const Fortran::parser::BlockConstruct &blockConstruct) { - setCurrentPositionAt(blockConstruct); - TODO(toLocation(), "BlockConstruct implementation"); - } - void genFIR(const Fortran::parser::BlockStmt &) { - TODO(toLocation(), "BlockStmt implementation"); - } - void genFIR(const Fortran::parser::EndBlockStmt &) { - TODO(toLocation(), "EndBlockStmt implementation"); + Fortran::lower::pft::Evaluation &eval = getEval(); + Fortran::lower::StatementContext stmtCtx; + pushActiveConstruct(eval, stmtCtx); + for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) { + if (e.getIf()) { + if (eval.lowerAsUnstructured()) + maybeStartBlock(e.block); + setCurrentPosition(e.position); + const Fortran::parser::CharBlock &endPosition = + eval.getLastNestedEvaluation().position; + localSymbols.pushScope(); + mlir::func::FuncOp stackSave = fir::factory::getLlvmStackSave(*builder); + mlir::func::FuncOp stackRestore = + fir::factory::getLlvmStackRestore(*builder); + mlir::Value stackPtr = + builder->create(toLocation(), stackSave).getResult(0); + mlir::Location endLoc = genLocation(endPosition); + stmtCtx.attachCleanup([=]() { + builder->create(endLoc, stackRestore, stackPtr); + }); + Fortran::semantics::Scope &scope = + bridge.getSemanticsContext().FindScope(endPosition); + scopeBlockIdMap.try_emplace(&scope, ++blockId); + Fortran::lower::AggregateStoreMap storeMap; + for (const Fortran::lower::pft::Variable &var : + Fortran::lower::pft::getScopeVariableList(scope)) + instantiateVar(var, storeMap); + } else if (e.getIf()) { + if (eval.lowerAsUnstructured()) + maybeStartBlock(e.block); + setCurrentPosition(e.position); + localSymbols.popScope(); + } else { + genFIR(e); + } + } + popActiveConstruct(); } void genFIR(const Fortran::parser::ChangeTeamConstruct &construct) { @@ -2195,6 +2349,7 @@ typeCaseScopes.push_back(&scope); } + pushActiveConstruct(getEval(), stmtCtx); for (Fortran::lower::pft::Evaluation &eval : getEval().getNestedEvaluations()) { if (auto *selectTypeStmt = @@ -2385,11 +2540,11 @@ genFIR(eval); if (hasLocalScope) localSymbols.popScope(); - stmtCtx.finalize(); } else { genFIR(eval); } } + popActiveConstruct(); } //===--------------------------------------------------------------------===// @@ -2448,49 +2603,47 @@ if (!iostat) return; - mlir::Block *endBlock = nullptr; - mlir::Block *eorBlock = nullptr; - mlir::Block *errBlock = nullptr; + Fortran::parser::Label endLabel{}; + Fortran::parser::Label eorLabel{}; + Fortran::parser::Label errLabel{}; for (const auto &spec : specList) { std::visit(Fortran::common::visitors{ [&](const Fortran::parser::EndLabel &label) { - endBlock = blockOfLabel(eval, label.v); + endLabel = label.v; }, [&](const Fortran::parser::EorLabel &label) { - eorBlock = blockOfLabel(eval, label.v); + eorLabel = label.v; }, [&](const Fortran::parser::ErrLabel &label) { - errBlock = blockOfLabel(eval, label.v); + errLabel = label.v; }, [](const auto &) {}}, spec.u); } - if (!endBlock && !eorBlock && !errBlock) + if (!endLabel && !eorLabel && !errLabel) return; - mlir::Location loc = toLocation(); - mlir::Type indexType = builder->getIndexType(); - mlir::Value selector = builder->createConvert(loc, indexType, iostat); + mlir::Value selector = + builder->createConvert(toLocation(), builder->getIndexType(), iostat); llvm::SmallVector indexList; - llvm::SmallVector blockList; - if (eorBlock) { + llvm::SmallVector labelList; + if (eorLabel) { indexList.push_back(Fortran::runtime::io::IostatEor); - blockList.push_back(eorBlock); + labelList.push_back(eorLabel); } - if (endBlock) { + if (endLabel) { indexList.push_back(Fortran::runtime::io::IostatEnd); - blockList.push_back(endBlock); + labelList.push_back(endLabel); } - if (errBlock) { + if (errLabel) { + // IostatEor and IostatEnd are fixed negative values. IOSTAT ERR values + // are positive. Placing the ERR value last allows recognition of an + // unexpected negative value as an error. indexList.push_back(0); - blockList.push_back(eval.nonNopSuccessor().block); - // ERR label statement is the default successor. - blockList.push_back(errBlock); - } else { - // Fallthrough successor statement is the default successor. - blockList.push_back(eval.nonNopSuccessor().block); + labelList.push_back(errLabel); } - builder->create(loc, selector, indexList, blockList); + genMultiwayBranch(selector, indexList, labelList, eval.nonNopSuccessor(), + /*inIoErrContext=*/errLabel != Fortran::parser::Label{}); } //===--------------------------------------------------------------------===// @@ -2966,7 +3119,7 @@ mlir::Value val = fir::getBase(rhs); // 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. Assignment + // types to allow them to share the same storage. Assignment // to a result variable of one of the other types requires // conversion to the actual type. mlir::Type toTy = genType(assign.lhs); @@ -3163,6 +3316,11 @@ Fortran::lower::pft::FunctionLikeUnit *funit = getEval().getOwningProcedure(); assert(funit && "not inside main program, function or subroutine"); + for (auto it = activeConstructStack.rbegin(), + rend = activeConstructStack.rend(); + it != rend; ++it) { + it->stmtCtx.finalizeAndKeep(); + } if (funit->isMainProgram()) { bridge.fctCtx().finalizeAndKeep(); genExitRoutine(); @@ -3172,7 +3330,7 @@ if (stmt.v) { // Alternate return statement - If this is a subroutine where some // alternate entries have alternate returns, but the active entry point - // does not, ignore the alternate return value. Otherwise, assign it + // does not, ignore the alternate return value. Otherwise, assign it // to the compiler-generated result variable. const Fortran::semantics::Symbol &symbol = funit->getSubprogramSymbol(); if (Fortran::semantics::HasAlternateReturns(symbol)) { @@ -3196,13 +3354,13 @@ } void genFIR(const Fortran::parser::CycleStmt &) { - genFIRBranch(getEval().controlSuccessor->block); + genConstructExitBranch(*getEval().controlSuccessor); } void genFIR(const Fortran::parser::ExitStmt &) { - genFIRBranch(getEval().controlSuccessor->block); + genConstructExitBranch(*getEval().controlSuccessor); } void genFIR(const Fortran::parser::GotoStmt &) { - genFIRBranch(getEval().controlSuccessor->block); + genConstructExitBranch(*getEval().controlSuccessor); } // Nop statements - No code, or code is generated at the construct level. @@ -3211,11 +3369,13 @@ // generating a branch to end a block. So these calls may still be required // for that functionality. void genFIR(const Fortran::parser::AssociateStmt &) {} // nop + void genFIR(const Fortran::parser::BlockStmt &) {} // nop void genFIR(const Fortran::parser::CaseStmt &) {} // nop void genFIR(const Fortran::parser::ContinueStmt &) {} // nop void genFIR(const Fortran::parser::ElseIfStmt &) {} // nop void genFIR(const Fortran::parser::ElseStmt &) {} // nop void genFIR(const Fortran::parser::EndAssociateStmt &) {} // nop + void genFIR(const Fortran::parser::EndBlockStmt &) {} // nop void genFIR(const Fortran::parser::EndDoStmt &) {} // nop void genFIR(const Fortran::parser::EndFunctionStmt &) {} // nop void genFIR(const Fortran::parser::EndIfStmt &) {} // nop @@ -3262,11 +3422,11 @@ if (successor->isIntermediateConstructStmt() && successor->parentConstruct->lowerAsUnstructured()) // Exit from an intermediate unstructured IF or SELECT construct block. - genFIRBranch(successor->parentConstruct->constructExit->block); + genBranch(successor->parentConstruct->constructExit->block); else if (unstructuredContext && eval.isConstructStmt() && successor == eval.controlSuccessor) // Exit from a degenerate, empty construct block. - genFIRBranch(eval.parentConstruct->constructExit->block); + genBranch(eval.parentConstruct->constructExit->block); } } @@ -3337,6 +3497,8 @@ builder->setFastMathFlags(bridge.getLoweringOptions().getMathOptions()); builder->setInsertionPointToStart(&func.front()); func.setVisibility(mlir::SymbolTable::Visibility::Public); + assert(blockId == 0 && "invalid blockId"); + assert(activeConstructStack.empty() && "invalid construct stack state"); mapDummiesAndResults(funit, callee); @@ -3446,18 +3608,18 @@ if (Fortran::lower::pft::Evaluation *alternateEntryEval = funit.getEntryEval()) - genFIRBranch(alternateEntryEval->lexicalSuccessor->block); + genBranch(alternateEntryEval->lexicalSuccessor->block); } - /// Create global blocks for the current function. This eliminates the + /// Create global blocks for the current function. This eliminates the /// distinction between forward and backward targets when generating - /// branches. A block is "global" if it can be the target of a GOTO or - /// other source code branch. A block that can only be targeted by a - /// compiler generated branch is "local". For example, a DO loop preheader - /// block containing loop initialization code is global. A loop header - /// block, which is the target of the loop back edge, is local. Blocks - /// belong to a region. Any block within a nested region must be replaced - /// with a block belonging to that region. Branches may not cross region + /// branches. A block is "global" if it can be the target of a GOTO or + /// other source code branch. A block that can only be targeted by a + /// compiler generated branch is "local". For example, a DO loop preheader + /// block containing loop initialization code is global. A loop header + /// block, which is the target of the loop back edge, is local. Blocks + /// belong to a region. Any block within a nested region must be replaced + /// with a block belonging to that region. Branches may not cross region /// boundaries. void createEmptyBlocks( std::list &evaluationList) { @@ -3492,10 +3654,10 @@ // Default termination for the current block is a fallthrough branch to // the new block. if (blockIsUnterminated()) - genFIRBranch(newBlock); + genBranch(newBlock); // Some blocks may be re/started more than once, and might not be empty. // If the new block already has (only) a terminator, set the insertion - // point to the start of the block. Otherwise set it to the end. + // point to the start of the block. Otherwise set it to the end. builder->setInsertionPointToStart(newBlock); if (blockIsUnterminated()) builder->setInsertionPointToEnd(newBlock); @@ -3530,6 +3692,7 @@ builder = nullptr; hostAssocTuple = mlir::Value{}; localSymbols.clear(); + blockId = 0; } /// Helper to generate GlobalOps when the builder is not positioned in any @@ -3874,13 +4037,20 @@ RuntimeTypeInfoConverter runtimeTypeInfoConverter; DispatchTableConverter dispatchTableConverter; - /// WHERE statement/construct mask expression stack. - Fortran::lower::ImplicitIterSpace implicitIterSpace; + // Stack to manage object deallocation and finalization at construct exits. + llvm::SmallVector activeConstructStack; + + /// BLOCK name mangling component map + int blockId = 0; + Fortran::lower::mangle::ScopeBlockIdMap scopeBlockIdMap; - /// FORALL context + /// FORALL statement/construct context Fortran::lower::ExplicitIterSpace explicitIterSpace; - /// Tuple of host assoicated variables. + /// WHERE statement/construct mask expression stack + Fortran::lower::ImplicitIterSpace implicitIterSpace; + + /// Tuple of host associated variables mlir::Value hostAssocTuple; }; Index: flang/lib/Lower/CallInterface.cpp =================================================================== --- flang/lib/Lower/CallInterface.cpp +++ flang/lib/Lower/CallInterface.cpp @@ -28,15 +28,15 @@ //===----------------------------------------------------------------------===// // Return the binding label (from BIND(C...)) or the mangled name of a symbol. -static std::string getMangledName(mlir::Location loc, +static std::string getMangledName(Fortran::lower::AbstractConverter &converter, const Fortran::semantics::Symbol &symbol) { const std::string *bindName = symbol.GetBindName(); // TODO: update GetBindName so that it does not return a label for internal // procedures. if (bindName && Fortran::semantics::ClassifyProcedure(symbol) == Fortran::semantics::ProcedureDefinitionClass::Internal) - TODO(loc, "BIND(C) internal procedures"); - return bindName ? *bindName : Fortran::lower::mangle::mangleName(symbol); + TODO(converter.getCurrentLocation(), "BIND(C) internal procedures"); + return bindName ? *bindName : converter.mangleName(symbol); } mlir::Type Fortran::lower::getUntypedBoxProcType(mlir::MLIRContext *context) { @@ -73,8 +73,7 @@ std::string Fortran::lower::CallerInterface::getMangledName() const { const Fortran::evaluate::ProcedureDesignator &proc = procRef.proc(); if (const Fortran::semantics::Symbol *symbol = proc.GetSymbol()) - return ::getMangledName(converter.getCurrentLocation(), - symbol->GetUltimate()); + return ::getMangledName(converter, symbol->GetUltimate()); assert(proc.GetSpecificIntrinsic() && "expected intrinsic procedure in designator"); return proc.GetName(); @@ -421,8 +420,7 @@ std::string Fortran::lower::CalleeInterface::getMangledName() const { if (funit.isMainProgram()) return fir::NameUniquer::doProgramEntry().str(); - return ::getMangledName(converter.getCurrentLocation(), - funit.getSubprogramSymbol()); + return ::getMangledName(converter, funit.getSubprogramSymbol()); } const Fortran::semantics::Symbol * @@ -490,8 +488,7 @@ } //===----------------------------------------------------------------------===// -// CallInterface implementation: this part is common to both caller and caller -// sides. +// CallInterface implementation: this part is common to both caller and callee. //===----------------------------------------------------------------------===// static void addSymbolAttribute(mlir::func::FuncOp func, Index: flang/lib/Lower/ConvertType.cpp =================================================================== --- flang/lib/Lower/ConvertType.cpp +++ flang/lib/Lower/ConvertType.cpp @@ -315,8 +315,7 @@ if (mlir::Type ty = getTypeIfDerivedAlreadyInConstruction(typeSymbol)) return ty; - auto rec = fir::RecordType::get(context, - Fortran::lower::mangle::mangleName(tySpec)); + auto rec = fir::RecordType::get(context, converter.mangleName(tySpec)); // Maintain the stack of types for recursive references. derivedTypeInConstruction.emplace_back(typeSymbol, rec); Index: flang/lib/Lower/ConvertVariable.cpp =================================================================== --- flang/lib/Lower/ConvertVariable.cpp +++ flang/lib/Lower/ConvertVariable.cpp @@ -417,13 +417,13 @@ TODO(loc, "procedure pointer globals"); // If this is an array, check to see if we can use a dense attribute - // with a tensor mlir type. This optimization currently only supports + // with a tensor mlir type. This optimization currently only supports // rank-1 Fortran arrays of integer, real, or logical. The tensor // type does not support nested structures which are needed for // complex numbers. // To get multidimensional arrays to work, we will have to use column major // array ordering with the tensor type (so it matches column major ordering - // with the Fortran fir.array). By default, tensor types assume row major + // with the Fortran fir.array). By default, tensor types assume row major // ordering. How to create this tensor type is to be determined. if (symTy.isa() && sym.Rank() == 1 && !Fortran::semantics::IsAllocatableOrPointer(sym)) { @@ -543,7 +543,7 @@ const Fortran::semantics::Symbol &sym = var.getSymbol(); assert(!var.isAlias() && "must be handled in instantiateAlias"); fir::FirOpBuilder &builder = converter.getFirOpBuilder(); - std::string globalName = Fortran::lower::mangle::mangleName(sym); + std::string globalName = converter.mangleName(sym); mlir::Location loc = genLocation(converter, sym); fir::GlobalOp global = builder.getNamedGlobal(globalName); mlir::StringAttr linkage = getLinkageAttribute(builder, var); @@ -576,7 +576,7 @@ if (preAlloc) return preAlloc; fir::FirOpBuilder &builder = converter.getFirOpBuilder(); - std::string nm = Fortran::lower::mangle::mangleName(var.getSymbol()); + std::string nm = converter.mangleName(var.getSymbol()); mlir::Type ty = converter.genType(var); const Fortran::semantics::Symbol &ultimateSymbol = var.getSymbol().GetUltimate(); @@ -814,8 +814,9 @@ /// Build the name for the storage of a global equivalence. static std::string mangleGlobalAggregateStore( + Fortran::lower::AbstractConverter &converter, const Fortran::lower::pft::Variable::AggregateStore &st) { - return Fortran::lower::mangle::mangleName(st.getNamingSymbol()); + return converter.mangleName(st.getNamingSymbol()); } /// Build the type for the storage of an equivalence. @@ -907,7 +908,8 @@ fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::IntegerType i8Ty = builder.getIntegerType(8); mlir::Location loc = converter.getCurrentLocation(); - std::string aggName = mangleGlobalAggregateStore(var.getAggregateStore()); + std::string aggName = + mangleGlobalAggregateStore(converter, var.getAggregateStore()); if (var.isGlobal()) { fir::GlobalOp global; auto &aggregate = var.getAggregateStore(); @@ -1084,7 +1086,7 @@ getCommonBlockGlobal(Fortran::lower::AbstractConverter &converter, const Fortran::semantics::Symbol &common) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); - std::string commonName = Fortran::lower::mangle::mangleName(common); + std::string commonName = converter.mangleName(common); fir::GlobalOp global = builder.getNamedGlobal(commonName); // Common blocks are lowered before any subprograms to deal with common // whose size may not be the same in every subprograms. @@ -1104,7 +1106,7 @@ const Fortran::semantics::Symbol &common, std::size_t commonSize) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); - std::string commonName = Fortran::lower::mangle::mangleName(common); + std::string commonName = converter.mangleName(common); fir::GlobalOp global = builder.getNamedGlobal(commonName); if (global) return std::nullopt; @@ -1461,7 +1463,7 @@ llvm::SmallVector lenParams; if (len) lenParams.emplace_back(len); - auto name = Fortran::lower::mangle::mangleName(sym); + auto name = converter.mangleName(sym); fir::FortranVariableFlagsAttr attributes = Fortran::lower::translateSymbolAttributes(builder.getContext(), sym); auto newBase = builder.create( @@ -1503,7 +1505,7 @@ const mlir::Location loc = genLocation(converter, sym); fir::FortranVariableFlagsAttr attributes = Fortran::lower::translateSymbolAttributes(builder.getContext(), sym); - auto name = Fortran::lower::mangle::mangleName(sym); + auto name = converter.mangleName(sym); hlfir::EntityWithAttributes declare = hlfir::genDeclare(loc, builder, exv, name, attributes); symMap.addVariableDefinition(sym, declare.getIfVariableInterface(), force); @@ -1558,10 +1560,10 @@ } /// Lower specification expressions and attributes of variable \p var and -/// add it to the symbol map. For a global or an alias, the address must be -/// pre-computed and provided in \p preAlloc. A dummy argument for the current +/// add it to the symbol map. For a global or an alias, the address must be +/// pre-computed and provided in \p preAlloc. A dummy argument for the current /// entry point has already been mapped to an mlir block argument in -/// mapDummiesAndResults. Its mapping may be updated here. +/// mapDummiesAndResults. Its mapping may be updated here. void Fortran::lower::mapSymbolAttributes( AbstractConverter &converter, const Fortran::lower::pft::Variable &var, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, @@ -1658,24 +1660,24 @@ } // A dummy from another entry point that is not declared in the current - // entry point requires a skeleton definition. Most such "unused" dummies - // will not survive into final generated code, but some will. It is illegal - // to reference one at run time if it does. Such a dummy is mapped to a + // entry point requires a skeleton definition. Most such "unused" dummies + // will not survive into final generated code, but some will. It is illegal + // to reference one at run time if it does. Such a dummy is mapped to a // value in one of three ways: // - // - Generate a fir::UndefOp value. This is lightweight, easy to clean up, + // - Generate a fir::UndefOp value. This is lightweight, easy to clean up, // and often valid, but it may fail for a dummy with dynamic bounds, - // or a dummy used to define another dummy. Information to distinguish + // or a dummy used to define another dummy. Information to distinguish // valid cases is not generally available here, with the exception of - // dummy procedures. See the first function exit above. + // dummy procedures. See the first function exit above. // - // - Allocate an uninitialized stack slot. This is an intermediate-weight - // solution that is harder to clean up. It is often valid, but may fail - // for an object with dynamic bounds. This option is "automatically" + // - Allocate an uninitialized stack slot. This is an intermediate-weight + // solution that is harder to clean up. It is often valid, but may fail + // for an object with dynamic bounds. This option is "automatically" // used by default for cases that do not use one of the other options. // - // - Allocate a heap box/descriptor, initialized to zero. This always - // works, but is more heavyweight and harder to clean up. It is used + // - Allocate a heap box/descriptor, initialized to zero. This always + // works, but is more heavyweight and harder to clean up. It is used // for dynamic objects via calls to genUnusedEntryPointBox. auto genUnusedEntryPointBox = [&]() { @@ -1911,7 +1913,7 @@ if (var.isAggregateStore()) { const Fortran::lower::pft::Variable::AggregateStore &aggregate = var.getAggregateStore(); - std::string aggName = mangleGlobalAggregateStore(aggregate); + std::string aggName = mangleGlobalAggregateStore(converter, aggregate); defineGlobalAggregateStore(converter, aggregate, aggName, linkage); return; } @@ -1924,7 +1926,7 @@ } else if (var.isAlias()) { // Do nothing. Mapping will be done on user side. } else { - std::string globalName = Fortran::lower::mangle::mangleName(sym); + std::string globalName = converter.mangleName(sym); defineGlobal(converter, var, globalName, linkage); } } @@ -1975,7 +1977,7 @@ if (hostDetails && !var.isModuleOrSubmoduleVariable()) { // The callee is an internal procedure `A` whose result properties // depend on host variables. The caller may be the host, or another - // internal procedure `B` contained in the same host. In the first + // internal procedure `B` contained in the same host. In the first // case, the host symbol is obviously mapped, in the second case, it // must also be mapped because // HostAssociations::internalProcedureBindings that was called when @@ -2015,7 +2017,7 @@ Fortran::lower::AbstractConverter &converter, mlir::Location loc, const Fortran::semantics::Symbol &typeInfoSym) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); - std::string globalName = Fortran::lower::mangle::mangleName(typeInfoSym); + std::string globalName = converter.mangleName(typeInfoSym); auto var = Fortran::lower::pft::Variable(typeInfoSym, /*global=*/true); mlir::StringAttr linkage = getLinkageAttribute(builder, var); defineGlobal(converter, var, globalName, linkage); Index: flang/lib/Lower/IO.cpp =================================================================== --- flang/lib/Lower/IO.cpp +++ flang/lib/Lower/IO.cpp @@ -108,9 +108,9 @@ } // namespace Fortran::lower namespace { -/// IO statements may require exceptional condition handling. A statement that +/// IO statements may require exceptional condition handling. A statement that /// encounters an exceptional condition may branch to a label given on an ERR -/// (error), END (end-of-file), or EOR (end-of-record) specifier. An IOSTAT +/// (error), END (end-of-file), or EOR (end-of-record) specifier. An IOSTAT /// specifier variable may be set to a value that indicates some condition, /// and an IOMSG specifier variable may be set to a description of a condition. struct ConditionSpecInfo { @@ -125,7 +125,7 @@ bool hasErrorConditionSpec() const { return ioStatExpr != nullptr || hasErr; } /// Check for any condition specifier that applies to data transfer items - /// in a PRINT, READ, WRITE, or WAIT statement. (WAIT may be irrelevant.) + /// in a PRINT, READ, WRITE, or WAIT statement. (WAIT may be irrelevant.) bool hasTransferConditionSpec() const { return hasErrorConditionSpec() || hasEnd || hasEor; } @@ -176,7 +176,7 @@ return func; } -/// Generate calls to end an IO statement. Return the IOSTAT value, if any. +/// Generate calls to end an IO statement. Return the IOSTAT value, if any. /// It is the caller's responsibility to generate branches on that value. static mlir::Value genEndIO(Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, @@ -218,7 +218,7 @@ /// Make the next call in the IO statement conditional on runtime result `ok`. /// If a call returns `ok==false`, further suboperation calls for an IO -/// statement will be skipped. This may generate branch heavy, deeply nested +/// statement will be skipped. This may generate branch heavy, deeply nested /// conditionals for IO statements with a large number of suboperations. static void makeNextConditionalOn(fir::FirOpBuilder &builder, mlir::Location loc, bool checkResult, @@ -227,7 +227,7 @@ // Either no IO calls need to be checked, or this will be the first call. return; - // A previous IO call for a statement returned the bool `ok`. If this call + // A previous IO call for a statement returned the bool `ok`. If this call // is in a fir.iterate_while loop, the result must be propagated up to the // loop scope as an extra ifOp result. (The propagation is done in genIoLoop.) mlir::TypeRange resTy; @@ -241,7 +241,7 @@ /// Retrieve or generate a runtime description of NAMELIST group `symbol`. /// The form of the description is defined in runtime header file namelist.h. /// Static descriptors are generated for global objects; local descriptors for -/// local objects. If all descriptors are static, the NamelistGroup is static. +/// local objects. If all descriptors are static, the NamelistGroup is static. static mlir::Value getNamelistGroup(Fortran::lower::AbstractConverter &converter, const Fortran::semantics::Symbol &symbol, @@ -605,7 +605,8 @@ llvm::SmallVector inputFuncArgs = {cookie}; if (argType.isa()) { mlir::Value box = fir::getBase(item); - assert(box.getType().isa() && "must be previously emboxed"); + assert(box.getType().isa() && + "must be previously emboxed"); inputFuncArgs.push_back(builder.createConvert(loc, argType, box)); } else { mlir::Value itemAddr = fir::getBase(item); @@ -1493,9 +1494,9 @@ return {buff, len, mlir::Value{}}; } -/// Generate a reference to a format string. There are four cases - a format +/// Generate a reference to a format string. There are four cases - a format /// statement label, a character format expression, an integer that holds the -/// label of a format statement, and the * case. The first three are done here. +/// label of a format statement, and the * case. The first three are done here. /// The * case is done elsewhere. static std::tuple genFormat(Fortran::lower::AbstractConverter &converter, mlir::Location loc, @@ -2022,7 +2023,7 @@ } // Generate end statement call/s. mlir::Value result = genEndIO(converter, loc, cookie, csi, stmtCtx); - stmtCtx.finalize(); + stmtCtx.finalizeAndReset(); return result; } Index: flang/lib/Lower/IterationSpace.cpp =================================================================== --- flang/lib/Lower/IterationSpace.cpp +++ flang/lib/Lower/IterationSpace.cpp @@ -847,7 +847,7 @@ if (forallContextOpen == 0) { // Exiting the outermost FORALL context. // Cleanup any residual mask buffers. - outermostContext().finalize(); + outermostContext().finalizeAndReset(); // Clear and reset all the cached information. symbolStack.clear(); lhsBases.clear(); Index: flang/lib/Lower/Mangler.cpp =================================================================== --- flang/lib/Lower/Mangler.cpp +++ flang/lib/Lower/Mangler.cpp @@ -16,85 +16,87 @@ #include "llvm/ADT/ArrayRef.h" #include "llvm/ADT/SmallVector.h" #include "llvm/ADT/StringRef.h" -#include "llvm/ADT/Twine.h" #include "llvm/Support/MD5.h" -#include - -// recursively build the vector of module scopes -static void moduleNames(const Fortran::semantics::Scope &scope, - llvm::SmallVector &result) { - if (scope.IsTopLevel()) - return; - moduleNames(scope.parent(), result); - if (scope.kind() == Fortran::semantics::Scope::Kind::Module) - if (const Fortran::semantics::Symbol *symbol = scope.symbol()) - result.emplace_back(toStringRef(symbol->name())); -} - -static llvm::SmallVector -moduleNames(const Fortran::semantics::Symbol &symbol) { - const Fortran::semantics::Scope &scope = symbol.owner(); - llvm::SmallVector result; - moduleNames(scope, result); - return result; -} -static std::optional -hostName(const Fortran::semantics::Symbol &symbol) { - const Fortran::semantics::Scope *scope = &symbol.owner(); - if (symbol.has()) - // Associate/Select construct scopes are not part of the mangling. This can - // result in different construct selector being mangled with the same name. - // This is not an issue since these are not global symbols. - while (!scope->IsTopLevel() && - (scope->kind() != Fortran::semantics::Scope::Kind::Subprogram && - scope->kind() != Fortran::semantics::Scope::Kind::MainProgram)) - scope = &scope->parent(); - if (scope->kind() == Fortran::semantics::Scope::Kind::Subprogram) { - assert(scope->symbol() && "subprogram scope must have a symbol"); - return toStringRef(scope->symbol()->name()); +/// Return all ancestor module and submodule scope names; all host procedure +/// and statement function scope names; and the innermost blockId containing +/// \p symbol. +static std::tuple, + llvm::SmallVector, std::int64_t> +ancestors(const Fortran::semantics::Symbol &symbol, + Fortran::lower::mangle::ScopeBlockIdMap &scopeBlockIdMap) { + llvm::SmallVector scopes; + for (auto *scp = &symbol.owner(); !scp->IsGlobal(); scp = &scp->parent()) + scopes.push_back(scp); + llvm::SmallVector modules; + llvm::SmallVector procs; + std::int64_t blockId = 0; + for (auto iter = scopes.rbegin(), rend = scopes.rend(); iter != rend; + ++iter) { + auto *scp = *iter; + switch (scp->kind()) { + case Fortran::semantics::Scope::Kind::Module: + modules.emplace_back(toStringRef(scp->symbol()->name())); + break; + case Fortran::semantics::Scope::Kind::Subprogram: + procs.emplace_back(toStringRef(scp->symbol()->name())); + break; + case Fortran::semantics::Scope::Kind::MainProgram: + // Do not use the main program name, if any, because it may collide + // with a procedure of the same name in another compilation unit. + // This is nonconformant, but universally allowed. + procs.emplace_back(llvm::StringRef("")); + break; + case Fortran::semantics::Scope::Kind::BlockConstruct: { + auto it = scopeBlockIdMap.find(scp); + assert(it != scopeBlockIdMap.end() && it->second && + "invalid block identifier"); + blockId = it->second; + } break; + default: + break; + } } - if (scope->kind() == Fortran::semantics::Scope::Kind::MainProgram) - // Do not use the main program name, if any, because it may lead to name - // collision with procedures with the same name in other compilation units - // (technically illegal, but all compilers are able to compile and link - // properly these programs). - return llvm::StringRef(""); - return {}; + return {modules, procs, blockId}; } -// Mangle the name of `symbol` to make it unique within FIR's symbol table using -// the FIR name mangler, `mangler` +// Mangle the name of \p symbol to make it globally unique. std::string Fortran::lower::mangle::mangleName(const Fortran::semantics::Symbol &symbol, + ScopeBlockIdMap &scopeBlockIdMap, bool keepExternalInScope) { - // Resolve host and module association before mangling + // Resolve module and host associations before mangling. const auto &ultimateSymbol = symbol.GetUltimate(); - auto symbolName = toStringRef(ultimateSymbol.name()); - // The Fortran and BIND(C) namespaces are counterintuitive. A - // BIND(C) name is substituted early having precedence over the - // Fortran name of the subprogram. By side-effect, this allows - // multiple subprocedures with identical Fortran names to be legally - // present in the program. Assume the BIND(C) name is unique. + // The Fortran and BIND(C) namespaces are counterintuitive. A BIND(C) name is + // substituted early, and has precedence over the Fortran name. This allows + // multiple procedures or objects with identical Fortran names to legally + // coexist. The BIND(C) name is unique. if (auto *overrideName = ultimateSymbol.GetBindName()) return *overrideName; - // TODO: the case of procedure that inherits the BIND(C) through another - // interface (procedure(iface)), should be dealt within GetBindName() - // directly, or some semantics wrapper. + + // TODO: A procedure that inherits BIND(C) through another interface + // (procedure(iface)) should be dealt with in GetBindName() or some wrapper. if (!Fortran::semantics::IsPointer(ultimateSymbol) && Fortran::semantics::IsBindCProcedure(ultimateSymbol) && Fortran::semantics::ClassifyProcedure(symbol) != Fortran::semantics::ProcedureDefinitionClass::Internal) return ultimateSymbol.name().ToString(); + llvm::StringRef symbolName = toStringRef(ultimateSymbol.name()); + llvm::SmallVector modules; + llvm::SmallVector procs; + std::int64_t blockId; + // mangle ObjectEntityDetails or AssocEntityDetails symbols. auto mangleObject = [&]() -> std::string { - llvm::SmallVector modNames = moduleNames(ultimateSymbol); - std::optional optHost = hostName(ultimateSymbol); + std::tie(modules, procs, blockId) = + ancestors(ultimateSymbol, scopeBlockIdMap); if (Fortran::semantics::IsNamedConstant(ultimateSymbol)) - return fir::NameUniquer::doConstant(modNames, optHost, symbolName); - return fir::NameUniquer::doVariable(modNames, optHost, symbolName); + return fir::NameUniquer::doConstant(modules, procs, blockId, + symbolName); + return fir::NameUniquer::doVariable(modules, procs, blockId, + symbolName); }; return std::visit( @@ -115,21 +117,21 @@ interface->owner().IsSubmodule() && !subpDetails.isInterface()) interface = subpDetails.moduleInterface(); assert(interface && "Separate module procedure must be declared"); - llvm::SmallVector modNames = - moduleNames(*interface); - return fir::NameUniquer::doProcedure(modNames, hostName(*interface), - symbolName); + std::tie(modules, procs, blockId) = + ancestors(*interface, scopeBlockIdMap); + return fir::NameUniquer::doProcedure(modules, procs, symbolName); }, [&](const Fortran::semantics::ProcEntityDetails &) { - // Mangle procedure pointers and dummy procedures as variables + // Mangle procedure pointers and dummy procedures as variables. if (Fortran::semantics::IsPointer(ultimateSymbol) || - Fortran::semantics::IsDummy(ultimateSymbol)) - return fir::NameUniquer::doVariable(moduleNames(ultimateSymbol), - hostName(ultimateSymbol), + Fortran::semantics::IsDummy(ultimateSymbol)) { + std::tie(modules, procs, blockId) = + ancestors(ultimateSymbol, scopeBlockIdMap); + return fir::NameUniquer::doVariable(modules, procs, blockId, symbolName); - // Otherwise, this is an external procedure, even if it does not - // have an explicit EXTERNAL attribute. Mangle it without any - // prefix. + } + // Otherwise, this is an external procedure, with or without an + // explicit EXTERNAL attribute. Mangle it without any prefix. return fir::NameUniquer::doProcedure(std::nullopt, std::nullopt, symbolName); }, @@ -140,38 +142,52 @@ return mangleObject(); }, [&](const Fortran::semantics::NamelistDetails &) { - llvm::SmallVector modNames = - moduleNames(ultimateSymbol); - std::optional optHost = hostName(ultimateSymbol); - return fir::NameUniquer::doNamelistGroup(modNames, optHost, + std::tie(modules, procs, blockId) = + ancestors(ultimateSymbol, scopeBlockIdMap); + return fir::NameUniquer::doNamelistGroup(modules, procs, symbolName); }, [&](const Fortran::semantics::CommonBlockDetails &) { return fir::NameUniquer::doCommonBlock(symbolName); }, + [&](const Fortran::semantics::ProcBindingDetails &procBinding) { + return mangleName(procBinding.symbol(), scopeBlockIdMap, + keepExternalInScope); + }, [&](const Fortran::semantics::DerivedTypeDetails &) -> std::string { - // Derived type mangling must used mangleName(DerivedTypeSpec&) so + // Derived type mangling must use mangleName(DerivedTypeSpec) so // that kind type parameter values can be mangled. llvm::report_fatal_error( "only derived type instances can be mangled"); }, - [&](const Fortran::semantics::ProcBindingDetails &procBinding) - -> std::string { - return mangleName(procBinding.symbol(), keepExternalInScope); - }, [](const auto &) -> std::string { TODO_NOLOC("symbol mangling"); }, }, ultimateSymbol.details()); } +std::string +Fortran::lower::mangle::mangleName(const Fortran::semantics::Symbol &symbol, + bool keepExternalInScope) { + assert(symbol.owner().kind() != + Fortran::semantics::Scope::Kind::BlockConstruct && + "block object mangling must specify a scopeBlockIdMap"); + ScopeBlockIdMap scopeBlockIdMap; + return mangleName(symbol, scopeBlockIdMap, keepExternalInScope); +} + std::string Fortran::lower::mangle::mangleName( - const Fortran::semantics::DerivedTypeSpec &derivedType) { - // Resolve host and module association before mangling + const Fortran::semantics::DerivedTypeSpec &derivedType, + ScopeBlockIdMap &scopeBlockIdMap) { + // Resolve module and host associations before mangling. const Fortran::semantics::Symbol &ultimateSymbol = derivedType.typeSymbol().GetUltimate(); + llvm::StringRef symbolName = toStringRef(ultimateSymbol.name()); - llvm::SmallVector modNames = moduleNames(ultimateSymbol); - std::optional optHost = hostName(ultimateSymbol); + llvm::SmallVector modules; + llvm::SmallVector procs; + std::int64_t blockId; + std::tie(modules, procs, blockId) = + ancestors(ultimateSymbol, scopeBlockIdMap); llvm::SmallVector kinds; for (const auto ¶m : Fortran::semantics::OrderParameterDeclarations(ultimateSymbol)) { @@ -190,7 +206,7 @@ kinds.emplace_back(*init); } } - return fir::NameUniquer::doType(modNames, optHost, symbolName, kinds); + return fir::NameUniquer::doType(modules, procs, blockId, symbolName, kinds); } std::string Fortran::lower::mangle::demangleName(llvm::StringRef name) { Index: flang/lib/Lower/PFTBuilder.cpp =================================================================== --- flang/lib/Lower/PFTBuilder.cpp +++ flang/lib/Lower/PFTBuilder.cpp @@ -69,7 +69,7 @@ #endif /// The instantiation of a parse tree visitor (Pre and Post) is extremely -/// expensive in terms of compile and link time. So one goal here is to +/// expensive in terms of compile and link time. So one goal here is to /// limit the bridge to one such instantiation. class PFTBuilder { public: @@ -126,10 +126,10 @@ /// first statement of the construct. void convertIfStmt(const parser::IfStmt &ifStmt, parser::CharBlock position, std::optional label) { - // Generate a skeleton IfConstruct parse node. Its components are never - // referenced. The actual components are available via the IfConstruct + // Generate a skeleton IfConstruct parse node. Its components are never + // referenced. The actual components are available via the IfConstruct // evaluation's nested evaluationList, with the ifStmt in the position of - // the otherwise normal IfThenStmt. Caution: All other PFT nodes reference + // the otherwise normal IfThenStmt. Caution: All other PFT nodes reference // front end generated parse nodes; this is an exceptional case. static const auto ifConstruct = parser::IfConstruct{ parser::Statement{ @@ -445,7 +445,7 @@ } /// Rewrite IfConstructs containing a GotoStmt or CycleStmt to eliminate an - /// unstructured branch and a trivial basic block. The pre-branch-analysis + /// unstructured branch and a trivial basic block. The pre-branch-analysis /// code: /// /// <> @@ -467,20 +467,20 @@ /// <> /// 6 Statement: L ... /// - /// The If[Then]Stmt condition is implicitly negated. It is not modified - /// in the PFT. It must be negated when generating FIR. The GotoStmt or + /// The If[Then]Stmt condition is implicitly negated. It is not modified + /// in the PFT. It must be negated when generating FIR. The GotoStmt or /// CycleStmt is deleted. /// /// The transformation is only valid for forward branch targets at the same - /// construct nesting level as the IfConstruct. The result must not violate - /// construct nesting requirements or contain an EntryStmt. The result - /// is subject to normal un/structured code classification analysis. The + /// construct nesting level as the IfConstruct. The result must not violate + /// construct nesting requirements or contain an EntryStmt. The result + /// is subject to normal un/structured code classification analysis. The /// result is allowed to violate the F18 Clause 11.1.2.1 prohibition on /// transfer of control into the interior of a construct block, as that does - /// not compromise correct code generation. When two transformation - /// candidates overlap, at least one must be disallowed. In such cases, + /// not compromise correct code generation. When two transformation + /// candidates overlap, at least one must be disallowed. In such cases, /// the current heuristic favors simple code generation, which happens to - /// favor later candidates over earlier candidates. That choice is probably + /// favor later candidates over earlier candidates. That choice is probably /// not significant, but could be changed. /// void rewriteIfGotos() { @@ -799,8 +799,8 @@ }, [&](const parser::AssignedGotoStmt &) { // Although this statement is a branch, it doesn't have any - // explicit control successors. So the code at the end of the - // loop won't mark the successor. Do that here. + // explicit control successors. So the code at the end of the + // loop won't mark the successor. Do that here. eval.isUnstructured = true; markSuccessorAsNewBlock(eval); }, @@ -1022,7 +1022,7 @@ const semantics::SemanticsContext &semanticsContext; /// functionList points to the internal or module procedure function list - /// of a FunctionLikeUnit or a ModuleLikeUnit. It may be null. + /// of a FunctionLikeUnit or a ModuleLikeUnit. It may be null. std::list *functionList{}; std::vector constructAndDirectiveStack{}; std::vector doConstructStack{}; @@ -1059,7 +1059,10 @@ LLVM_DEBUG(llvm::dbgs() << "IntrinsicModules (no detail)\n"); return; } - LLVM_DEBUG(llvm::dbgs() << "[anonymous]\n"); + if (scope->kind() == Fortran::semantics::Scope::Kind::BlockConstruct) + LLVM_DEBUG(llvm::dbgs() << "[block]\n"); + else + LLVM_DEBUG(llvm::dbgs() << "[anonymous]\n"); } } for (const auto &scp : scope->children()) @@ -1312,6 +1315,10 @@ return isUnstructured || clDisableStructuredFir; } +bool Fortran::lower::pft::Evaluation::forceAsUnstructured() const { + return clDisableStructuredFir; +} + lower::pft::FunctionLikeUnit * Fortran::lower::pft::Evaluation::getOwningProcedure() const { return parent.visit(common::visitors{ @@ -1441,7 +1448,7 @@ (semantics::IsProcedure(sym) && IsDummy(sym)); // A procedure argument in a subprogram with multiple entry points might // need a layeredVarList entry to trigger creation of a symbol map entry - // in some cases. Non-dummy procedures don't. + // in some cases. Non-dummy procedures don't. if (semantics::IsProcedure(sym) && !isProcedurePointerOrDummy) return 0; semantics::Symbol ultimate = sym.GetUltimate(); Index: flang/lib/Optimizer/Support/InternalNames.cpp =================================================================== --- flang/lib/Optimizer/Support/InternalNames.cpp +++ flang/lib/Optimizer/Support/InternalNames.cpp @@ -26,22 +26,22 @@ inline std::string prefix() { return "_Q"; } -static std::string doModules(llvm::ArrayRef mods) { - std::string result; - auto *token = "M"; - for (auto mod : mods) { - result.append(token).append(mod.lower()); - token = "S"; +/// Generate a mangling prefix from module, submodule, procedure, and +/// statement function names, plus an (innermost) block scope id. +static std::string doAncestors(llvm::ArrayRef modules, + llvm::ArrayRef procs, + std::int64_t blockId = 0) { + std::string prefix; + const char *tag = "M"; + for (auto mod : modules) { + prefix.append(tag).append(mod.lower()); + tag = "S"; } - return result; -} - -static std::string doModulesHost(llvm::ArrayRef mods, - std::optional host) { - std::string result = doModules(mods); - if (host) - result.append("F").append(host->lower()); - return result; + for (auto proc : procs) + prefix.append("F").append(proc.lower()); + if (blockId) + prefix.append("B").append(std::to_string(blockId)); + return prefix; } inline llvm::SmallVector @@ -101,30 +101,25 @@ std::string fir::NameUniquer::doCommonBlock(llvm::StringRef name) { std::string result = prefix(); - return result.append("B").append(toLower(name)); -} - -std::string fir::NameUniquer::doBlockData(llvm::StringRef name) { - std::string result = prefix(); - return result.append("L").append(toLower(name)); + return result.append("C").append(toLower(name)); } std::string fir::NameUniquer::doConstant(llvm::ArrayRef modules, - std::optional host, - llvm::StringRef name) { + llvm::ArrayRef procs, + std::int64_t blockId, llvm::StringRef name) { std::string result = prefix(); - result.append(doModulesHost(modules, host)).append("EC"); + result.append(doAncestors(modules, procs, blockId)).append("EC"); return result.append(toLower(name)); } std::string fir::NameUniquer::doDispatchTable(llvm::ArrayRef modules, - std::optional host, - llvm::StringRef name, + llvm::ArrayRef procs, + std::int64_t blockId, llvm::StringRef name, llvm::ArrayRef kinds) { std::string result = prefix(); - result.append(doModulesHost(modules, host)).append("DT"); + result.append(doAncestors(modules, procs, blockId)).append("DT"); return result.append(toLower(name)).append(doKinds(kinds)); } @@ -135,8 +130,8 @@ std::string fir::NameUniquer::doIntrinsicTypeDescriptor( llvm::ArrayRef modules, - std::optional host, IntrinsicType type, - std::int64_t kind) { + llvm::ArrayRef procs, std::int64_t blockId, + IntrinsicType type, std::int64_t kind) { const char *name = nullptr; switch (type) { case IntrinsicType::CHARACTER: @@ -157,61 +152,63 @@ } assert(name && "unknown intrinsic type"); std::string result = prefix(); - result.append(doModulesHost(modules, host)).append("C"); + result.append(doAncestors(modules, procs, blockId)).append("YI"); return result.append(name).append(doKind(kind)); } std::string fir::NameUniquer::doProcedure(llvm::ArrayRef modules, - std::optional host, + llvm::ArrayRef procs, llvm::StringRef name) { std::string result = prefix(); - result.append(doModulesHost(modules, host)).append("P"); + result.append(doAncestors(modules, procs)).append("P"); return result.append(toLower(name)); } std::string fir::NameUniquer::doType(llvm::ArrayRef modules, - std::optional host, - llvm::StringRef name, + llvm::ArrayRef procs, + std::int64_t blockId, llvm::StringRef name, llvm::ArrayRef kinds) { std::string result = prefix(); - result.append(doModulesHost(modules, host)).append("T"); + result.append(doAncestors(modules, procs, blockId)).append("T"); return result.append(toLower(name)).append(doKinds(kinds)); } std::string fir::NameUniquer::doTypeDescriptor(llvm::ArrayRef modules, - std::optional host, - llvm::StringRef name, + llvm::ArrayRef procs, + std::int64_t blockId, llvm::StringRef name, llvm::ArrayRef kinds) { std::string result = prefix(); - result.append(doModulesHost(modules, host)).append("CT"); + result.append(doAncestors(modules, procs, blockId)).append("CT"); return result.append(toLower(name)).append(doKinds(kinds)); } -std::string fir::NameUniquer::doTypeDescriptor( - llvm::ArrayRef modules, std::optional host, - llvm::StringRef name, llvm::ArrayRef kinds) { +std::string +fir::NameUniquer::doTypeDescriptor(llvm::ArrayRef modules, + llvm::ArrayRef procs, + std::int64_t blockId, llvm::StringRef name, + llvm::ArrayRef kinds) { auto rmodules = convertToStringRef(modules); - auto rhost = convertToStringRef(host); - return doTypeDescriptor(rmodules, rhost, name, kinds); + auto rprocs = convertToStringRef(procs); + return doTypeDescriptor(rmodules, rprocs, blockId, name, kinds); } std::string fir::NameUniquer::doVariable(llvm::ArrayRef modules, - std::optional host, - llvm::StringRef name) { + llvm::ArrayRef procs, + std::int64_t blockId, llvm::StringRef name) { std::string result = prefix(); - result.append(doModulesHost(modules, host)).append("E"); + result.append(doAncestors(modules, procs, blockId)).append("E"); return result.append(toLower(name)); } std::string fir::NameUniquer::doNamelistGroup(llvm::ArrayRef modules, - std::optional host, + llvm::ArrayRef procs, llvm::StringRef name) { std::string result = prefix(); - result.append(doModulesHost(modules, host)).append("G"); + result.append(doAncestors(modules, procs)).append("N"); return result.append(toLower(name)); } @@ -225,81 +222,79 @@ fir::NameUniquer::deconstruct(llvm::StringRef uniq) { if (uniq.startswith("_Q")) { llvm::SmallVector modules; - std::optional host; + llvm::SmallVector procs; + std::int64_t blockId = 0; std::string name; llvm::SmallVector kinds; NameKind nk = NameKind::NOT_UNIQUED; for (std::size_t i = 2, end{uniq.size()}; i != end;) { switch (uniq[i]) { - case 'B': + case 'B': // Block + blockId = readInt(uniq, i, i + 1, end); + break; + case 'C': // Common block nk = NameKind::COMMON; name = readName(uniq, i, i + 1, end); break; - case 'C': - if (uniq[i + 1] == 'T') { - nk = NameKind::TYPE_DESC; - name = readName(uniq, i, i + 2, end); - } else { - nk = NameKind::INTRINSIC_TYPE_DESC; - name = readName(uniq, i, i + 1, end); - } - break; - case 'D': + case 'D': // Dispatch table nk = NameKind::DISPATCH_TABLE; assert(uniq[i + 1] == 'T'); name = readName(uniq, i, i + 2, end); break; case 'E': - if (uniq[i + 1] == 'C') { + if (uniq[i + 1] == 'C') { // Constant Entity nk = NameKind::CONSTANT; name = readName(uniq, i, i + 2, end); - } else { + } else { // variable Entity nk = NameKind::VARIABLE; name = readName(uniq, i, i + 1, end); } break; - case 'L': - nk = NameKind::BLOCK_DATA_NAME; + case 'F': // procedure/Function ancestor component of a mangled prefix + procs.push_back(readName(uniq, i, i + 1, end)); + break; + case 'K': + if (uniq[i + 1] == 'N') // Negative Kind + kinds.push_back(-readInt(uniq, i, i + 2, end)); + else // [positive] Kind + kinds.push_back(readInt(uniq, i, i + 1, end)); + break; + case 'M': // Module + case 'S': // Submodule + modules.push_back(readName(uniq, i, i + 1, end)); + break; + case 'N': // Namelist group + nk = NameKind::NAMELIST_GROUP; name = readName(uniq, i, i + 1, end); break; - case 'P': + case 'P': // Procedure/function (itself) nk = NameKind::PROCEDURE; name = readName(uniq, i, i + 1, end); break; - case 'Q': + case 'Q': // UniQue mangle name tag nk = NameKind::GENERATED; name = uniq; i = end; break; - case 'T': + case 'T': // derived Type nk = NameKind::DERIVED_TYPE; name = readName(uniq, i, i + 1, end); break; - - case 'M': - case 'S': - modules.push_back(readName(uniq, i, i + 1, end)); - break; - case 'F': - host = readName(uniq, i, i + 1, end); - break; - case 'K': - if (uniq[i + 1] == 'N') - kinds.push_back(-readInt(uniq, i, i + 2, end)); - else - kinds.push_back(readInt(uniq, i, i + 1, end)); - break; - case 'G': - nk = NameKind::NAMELIST_GROUP; - name = readName(uniq, i, i + 1, end); + case 'Y': + if (uniq[i + 1] == 'I') { // tYpe descriptor for an Intrinsic type + nk = NameKind::INTRINSIC_TYPE_DESC; + name = readName(uniq, i, i + 1, end); + } else { // tYpe descriptor + nk = NameKind::TYPE_DESC; + name = readName(uniq, i, i + 2, end); + } break; - default: assert(false && "unknown uniquing code"); break; } } - return {nk, DeconstructedName(modules, host, name, kinds)}; + return {nk, DeconstructedName(modules, procs, blockId, name, kinds)}; } return {NameKind::NOT_UNIQUED, DeconstructedName(uniq)}; } @@ -310,7 +305,7 @@ return (deconstructResult.first == NameKind::PROCEDURE || deconstructResult.first == NameKind::COMMON) && deconstructResult.second.modules.empty() && - !deconstructResult.second.host; + deconstructResult.second.procs.empty(); } bool fir::NameUniquer::needExternalNameMangling(llvm::StringRef uniquedName) { @@ -348,10 +343,11 @@ llvm::SmallVector modules; for (const std::string &mod : result.second.modules) modules.push_back(mod); - std::optional host; - if (result.second.host) - host = *result.second.host; - return fir::NameUniquer::doVariable(modules, host, varName); + llvm::SmallVector procs; + for (const std::string &proc : result.second.procs) + procs.push_back(proc); + return fir::NameUniquer::doVariable(modules, procs, result.second.blockId, + varName); } std::string Index: flang/test/Fir/external-mangling.fir =================================================================== --- flang/test/Fir/external-mangling.fir +++ flang/test/Fir/external-mangling.fir @@ -7,11 +7,11 @@ func.func @_QPfoo() { %c0 = arith.constant 0 : index - %0 = fir.address_of(@_QBa) : !fir.ref> + %0 = fir.address_of(@_QCa) : !fir.ref> %1 = fir.convert %0 : (!fir.ref>) -> !fir.ref> %2 = fir.coordinate_of %1, %c0 : (!fir.ref>, index) -> !fir.ref %3 = fir.convert %2 : (!fir.ref) -> !fir.ref - %4 = fir.address_of(@_QB) : !fir.ref> + %4 = fir.address_of(@_QC) : !fir.ref> %5 = fir.convert %4 : (!fir.ref>) -> !fir.ref> %6 = fir.coordinate_of %5, %c0 : (!fir.ref>, index) -> !fir.ref %7 = fir.convert %6 : (!fir.ref) -> !fir.ref @@ -19,8 +19,8 @@ fir.call @_QPbar2(%7) : (!fir.ref) -> () return } -fir.global common @_QBa(dense<0> : vector<4xi8>) : !fir.array<4xi8> -fir.global common @_QB(dense<0> : vector<4xi8>) : !fir.array<4xi8> +fir.global common @_QCa(dense<0> : vector<4xi8>) : !fir.array<4xi8> +fir.global common @_QC(dense<0> : vector<4xi8>) : !fir.array<4xi8> func.func private @_QPbar(!fir.ref) func.func private @_QPbar2(!fir.ref) Index: flang/test/Lower/HLFIR/allocatable-and-pointer-status-change.f90 =================================================================== --- flang/test/Lower/HLFIR/allocatable-and-pointer-status-change.f90 +++ flang/test/Lower/HLFIR/allocatable-and-pointer-status-change.f90 @@ -84,7 +84,7 @@ ! CHECK: %[[VAL_9:.*]] = arith.constant 0 : index ! CHECK: %[[VAL_10:.*]] = arith.cmpi sgt, %[[VAL_8]], %[[VAL_9]] : index ! CHECK: %[[VAL_11:.*]] = arith.select %[[VAL_10]], %[[VAL_8]], %[[VAL_9]] : index -! CHECK: %[[VAL_12:.*]] = fir.allocmem !fir.array, %[[VAL_11]] {fir.must_be_heap = true, uniq_name = "_QEa.alloc"} +! CHECK: %[[VAL_12:.*]] = fir.allocmem !fir.array, %[[VAL_11]] {fir.must_be_heap = true, uniq_name = "_QFalloc_compEa.alloc"} ! CHECK: %[[VAL_13:.*]] = fir.shape %[[VAL_11]] : (index) -> !fir.shape<1> ! CHECK: %[[VAL_14:.*]] = fir.embox %[[VAL_12]](%[[VAL_13]]) : (!fir.heap>, !fir.shape<1>) -> !fir.box>> ! CHECK: fir.store %[[VAL_14]] to %[[VAL_6]] : !fir.ref>>> Index: flang/test/Lower/HLFIR/statement-functions.f90 =================================================================== --- flang/test/Lower/HLFIR/statement-functions.f90 +++ flang/test/Lower/HLFIR/statement-functions.f90 @@ -30,6 +30,6 @@ ! CHECK: %[[VAL_15:.*]] = arith.constant 0 : i32 ! CHECK: %[[VAL_16:.*]] = arith.cmpi sgt, %[[VAL_14]], %[[VAL_15]] : i32 ! CHECK: %[[VAL_17:.*]] = arith.select %[[VAL_16]], %[[VAL_14]], %[[VAL_15]] : i32 -! CHECK: %[[VAL_18:.*]]:2 = hlfir.declare %[[VAL_13]]#0 typeparams %[[VAL_17]] {uniq_name = "_QFstmt_funcEchar_stmt_func_dummy_arg"} : (!fir.ref>, i32) -> (!fir.boxchar<1>, !fir.ref>) +! CHECK: %[[VAL_18:.*]]:2 = hlfir.declare %[[VAL_13]]#0 typeparams %[[VAL_17]] {uniq_name = "_QFchar_testFstmt_funcEchar_stmt_func_dummy_arg"} : (!fir.ref>, i32) -> (!fir.boxchar<1>, !fir.ref>) ! CHECK: %[[VAL_19:.*]] = arith.constant 10 : i64 ! CHECK: %[[VAL_20:.*]] = hlfir.set_length %[[VAL_18]]#0 len %[[VAL_19]] : (!fir.boxchar<1>, i64) -> !hlfir.expr> Index: flang/test/Lower/OpenMP/threadprivate-commonblock.f90 =================================================================== --- flang/test/Lower/OpenMP/threadprivate-commonblock.f90 +++ flang/test/Lower/OpenMP/threadprivate-commonblock.f90 @@ -12,11 +12,11 @@ !$omp threadprivate(/blk/) -!CHECK: fir.global common @_QBblk(dense<0> : vector<103xi8>) : !fir.array<103xi8> +!CHECK: fir.global common @_QCblk(dense<0> : vector<103xi8>) : !fir.array<103xi8> contains subroutine sub() -!CHECK: [[ADDR0:%.*]] = fir.address_of(@_QBblk) : !fir.ref> +!CHECK: [[ADDR0:%.*]] = fir.address_of(@_QCblk) : !fir.ref> !CHECK: [[NEWADDR0:%.*]] = omp.threadprivate [[ADDR0]] : !fir.ref> -> !fir.ref> !CHECK-DAG: [[ADDR1:%.*]] = fir.convert [[NEWADDR0]] : (!fir.ref>) -> !fir.ref> !CHECK-DAG: [[C0:%.*]] = arith.constant 0 : index Index: flang/test/Lower/OpenMP/threadprivate-use-association.f90 =================================================================== --- flang/test/Lower/OpenMP/threadprivate-use-association.f90 +++ flang/test/Lower/OpenMP/threadprivate-use-association.f90 @@ -3,7 +3,7 @@ !RUN: %flang_fc1 -emit-fir -fopenmp %s -o - | FileCheck %s -!CHECK-DAG: fir.global common @_QBblk(dense<0> : vector<24xi8>) : !fir.array<24xi8> +!CHECK-DAG: fir.global common @_QCblk(dense<0> : vector<24xi8>) : !fir.array<24xi8> !CHECK-DAG: fir.global @_QMtestEy : f32 { module test @@ -16,7 +16,7 @@ contains subroutine sub() ! CHECK-LABEL: @_QMtestPsub -!CHECK-DAG: [[ADDR0:%.*]] = fir.address_of(@_QBblk) : !fir.ref> +!CHECK-DAG: [[ADDR0:%.*]] = fir.address_of(@_QCblk) : !fir.ref> !CHECK-DAG: [[NEWADDR0:%.*]] = omp.threadprivate [[ADDR0]] : !fir.ref> -> !fir.ref> !CHECK-DAG: [[ADDR1:%.*]] = fir.address_of(@_QMtestEy) : !fir.ref !CHECK-DAG: [[NEWADDR1:%.*]] = omp.threadprivate [[ADDR1]] : !fir.ref -> !fir.ref @@ -49,9 +49,9 @@ call sub() ! CHECK-LABEL: @_QQmain() -!CHECK-DAG: [[ADDR0:%.*]] = fir.address_of(@_QBblk) : !fir.ref> +!CHECK-DAG: [[ADDR0:%.*]] = fir.address_of(@_QCblk) : !fir.ref> !CHECK-DAG: [[NEWADDR0:%.*]] = omp.threadprivate [[ADDR0]] : !fir.ref> -> !fir.ref> -!CHECK-DAG: [[ADDR1:%.*]] = fir.address_of(@_QBblk) : !fir.ref> +!CHECK-DAG: [[ADDR1:%.*]] = fir.address_of(@_QCblk) : !fir.ref> !CHECK-DAG: [[NEWADDR1:%.*]] = omp.threadprivate [[ADDR1]] : !fir.ref> -> !fir.ref> !CHECK-DAG: [[ADDR2:%.*]] = fir.address_of(@_QMtestEy) : !fir.ref !CHECK-DAG: [[NEWADDR2:%.*]] = omp.threadprivate [[ADDR2]] : !fir.ref -> !fir.ref Index: flang/test/Lower/arithmetic-goto.f90 =================================================================== --- flang/test/Lower/arithmetic-goto.f90 +++ flang/test/Lower/arithmetic-goto.f90 @@ -2,7 +2,25 @@ ! CHECK-LABEL: func @_QPkagi function kagi(index) - ! CHECK: fir.select_case %{{.}} : i32 [#fir.upper, %c-1_i32, ^bb{{.}}, #fir.lower, %c1_i32, ^bb{{.}}, unit, ^bb{{.}}] + ! CHECK: %[[V_0:[0-9]+]] = fir.alloca i32 {bindc_name = "kagi" + ! CHECK: %[[V_1:[0-9]+]] = fir.load %arg0 : !fir.ref + ! CHECK: %[[V_2:[0-9]+]] = arith.cmpi slt, %[[V_1]], %c0{{.*}} : i32 + ! CHECK: cf.cond_br %[[V_2]], ^bb2, ^bb1 + ! CHECK: ^bb1: // pred: ^bb0 + ! CHECK: %[[V_3:[0-9]+]] = arith.cmpi sgt, %[[V_1]], %c0{{.*}} : i32 + ! CHECK: cf.cond_br %[[V_3]], ^bb4, ^bb3 + ! CHECK: ^bb2: // pred: ^bb0 + ! CHECK: fir.store %c1{{.*}} to %[[V_0]] : !fir.ref + ! CHECK: cf.br ^bb5 + ! CHECK: ^bb3: // pred: ^bb1 + ! CHECK: fir.store %c2{{.*}} to %[[V_0]] : !fir.ref + ! CHECK: cf.br ^bb5 + ! CHECK: ^bb4: // pred: ^bb1 + ! CHECK: fir.store %c3{{.*}} to %[[V_0]] : !fir.ref + ! CHECK: cf.br ^bb5 + ! CHECK: ^bb5: // 3 preds: ^bb2, ^bb3, ^bb4 + ! CHECK: %[[V_4:[0-9]+]] = fir.load %[[V_0]] : !fir.ref + ! CHECK: return %[[V_4]] : i32 if (index) 7, 8, 9 kagi = 0; return 7 kagi = 1; return @@ -12,12 +30,29 @@ ! CHECK-LABEL: func @_QPkagf function kagf(findex) - ! CHECK: %[[zero:.+]] = arith.constant 0.0 - ! CHECK: %{{.+}} = arith.cmpf olt, %{{.+}}, %[[zero]] : f32 - ! CHECK: cond_br % - ! CHECK: %{{.+}} = arith.cmpf ogt, %{{.+}}, %[[zero]] : f32 - ! CHECK: cond_br % - ! CHECK: br ^ + ! CHECK: %[[V_0:[0-9]+]] = fir.alloca i32 {bindc_name = "kagf" + ! CHECK: %[[V_1:[0-9]+]] = fir.load %arg0 : !fir.ref + ! CHECK: %[[V_2:[0-9]+]] = fir.load %arg0 : !fir.ref + ! CHECK: %[[V_3:[0-9]+]] = arith.addf %[[V_1]], %[[V_2]] {{.*}} : f32 + ! CHECK: %[[V_4:[0-9]+]] = arith.addf %[[V_3]], %[[V_3]] {{.*}} : f32 + ! CHECK: %cst = arith.constant 0.000000e+00 : f32 + ! CHECK: %[[V_5:[0-9]+]] = arith.cmpf olt, %[[V_4]], %cst : f32 + ! CHECK: cf.cond_br %[[V_5]], ^bb2, ^bb1 + ! CHECK: ^bb1: // pred: ^bb0 + ! CHECK: %[[V_6:[0-9]+]] = arith.cmpf ogt, %[[V_4]], %cst : f32 + ! CHECK: cf.cond_br %[[V_6]], ^bb4, ^bb3 + ! CHECK: ^bb2: // pred: ^bb0 + ! CHECK: fir.store %c1{{.*}} to %[[V_0]] : !fir.ref + ! CHECK: cf.br ^bb5 + ! CHECK: ^bb3: // pred: ^bb1 + ! CHECK: fir.store %c2{{.*}} to %[[V_0]] : !fir.ref + ! CHECK: cf.br ^bb5 + ! CHECK: ^bb4: // pred: ^bb1 + ! CHECK: fir.store %c3{{.*}} to %[[V_0]] : !fir.ref + ! CHECK: cf.br ^bb5 + ! CHECK: ^bb5: // 3 preds: ^bb2, ^bb3, ^bb4 + ! CHECK: %[[V_7:[0-9]+]] = fir.load %[[V_0]] : !fir.ref + ! CHECK: return %[[V_7]] : i32 if (findex+findex) 7, 8, 9 kagf = 0; return 7 kagf = 1; return Index: flang/test/Lower/array.f90 =================================================================== --- flang/test/Lower/array.f90 +++ flang/test/Lower/array.f90 @@ -1,6 +1,6 @@ ! RUN: bbc -o - %s | FileCheck %s -! CHECK-LABEL: fir.global @_QBblock +! CHECK-LABEL: fir.global @_QCblock ! CHECK-DAG: %[[VAL_1:.*]] = arith.constant 1.000000e+00 : f32 ! CHECK-DAG: %[[VAL_2:.*]] = arith.constant 2.400000e+00 : f32 ! CHECK-DAG: %[[VAL_3:.*]] = arith.constant 0.000000e+00 : f32 Index: flang/test/Lower/block.f90 =================================================================== --- /dev/null +++ flang/test/Lower/block.f90 @@ -0,0 +1,79 @@ +! RUN: bbc -emit-fir -o - %s | FileCheck %s + +! CHECK-LABEL: func @_QQmain +program bb ! block stack management and exits + ! CHECK: %[[V_1:[0-9]+]] = fir.alloca i32 {bindc_name = "i", uniq_name = "_QFEi"} + integer :: i, j + ! CHECK: fir.store %c0{{.*}} to %[[V_1]] : !fir.ref + i = 0 + ! CHECK: %[[V_3:[0-9]+]] = fir.call @llvm.stacksave() + ! CHECK: fir.store %{{.*}} to %[[V_1]] : !fir.ref + ! CHECK: br ^bb1 + ! CHECK: ^bb1: // 2 preds: ^bb0, ^bb15 + ! CHECK: cond_br %{{.*}}, ^bb2, ^bb16 + ! CHECK: ^bb2: // pred: ^bb1 + ! CHECK: %[[V_11:[0-9]+]] = fir.call @llvm.stacksave() + ! CHECK: fir.store %{{.*}} to %[[V_1]] : !fir.ref + ! CHECK: cond_br %{{.*}}, ^bb3, ^bb4 + ! CHECK: ^bb3: // pred: ^bb2 + ! CHECK: br ^bb10 + ! CHECK: ^bb4: // pred: ^bb2 + ! CHECK: fir.store %{{.*}} to %[[V_1]] : !fir.ref + ! CHECK: cond_br %{{.*}}, ^bb5, ^bb6 + ! CHECK: ^bb5: // pred: ^bb4 + ! CHECK: br ^bb7 + ! CHECK: ^bb6: // pred: ^bb4 + ! CHECK: fir.store %{{.*}} to %[[V_1]] : !fir.ref + ! CHECK: cond_br %{{.*}}, ^bb7, ^bb8 + ! CHECK: ^bb7: // 3 preds: ^bb5, ^bb6, ^bb12 + ! CHECK: fir.call @llvm.stackrestore(%[[V_11]]) + ! CHECK: br ^bb14 + ! CHECK: ^bb8: // pred: ^bb6 + ! CHECK: fir.store %{{.*}} to %[[V_1]] : !fir.ref + ! CHECK: cond_br %{{.*}}, ^bb9, ^bb10 + ! CHECK: ^bb9: // pred: ^bb8 + ! CHECK: fir.call @llvm.stackrestore(%[[V_11]]) + ! CHECK: br ^bb15 + ! CHECK: ^bb10: // 2 preds: ^bb3, ^bb8 + ! CHECK: fir.store %{{.*}} to %[[V_1]] : !fir.ref + ! CHECK: cond_br %{{.*}}, ^bb11, ^bb12 + ! CHECK: ^bb11: // pred: ^bb10 + ! CHECK: fir.call @llvm.stackrestore(%[[V_11]]) + ! CHECK: br ^bb17 + ! CHECK: ^bb12: // pred: ^bb10 + ! CHECK: fir.store %{{.*}} to %[[V_1]] : !fir.ref + ! CHECK: cond_br %{{.*}}, ^bb13, ^bb7 + ! CHECK: ^bb13: // pred: ^bb12 + ! CHECK: fir.call @llvm.stackrestore(%[[V_11]]) + ! CHECK: fir.call @llvm.stackrestore(%[[V_3]]) + ! CHECK: br ^bb18 + ! CHECK: ^bb14: // pred: ^bb7 + ! CHECK: fir.store %{{.*}} to %[[V_1]] : !fir.ref + ! CHECK: br ^bb15 + ! CHECK: ^bb15: // 2 preds: ^bb9, ^bb14 + ! CHECK: br ^bb1 + ! CHECK: ^bb16: // pred: ^bb1 + ! CHECK: fir.store %{{.*}} to %[[V_1]] : !fir.ref + ! CHECK: br ^bb17 + ! CHECK: ^bb17: // 2 preds: ^bb11, ^bb16 + ! CHECK: fir.call @llvm.stackrestore(%[[V_3]]) + ! CHECK: br ^bb18 + ! CHECK: ^bb18: // 2 preds: ^bb13, ^bb17 + ! CHECK: return + block + i = i + 1 ! 1 increment + do j = 1, 5 + block + i = i + 1; if (j == 1) goto 1 ! inner block - 5 increments, 1 goto + i = i + 1; if (j == 2) goto 2 ! inner block - 4 increments, 1 goto + i = i + 1; if (j == 3) goto 10 ! outer block - 3 increments, 1 goto + i = i + 1; if (j == 4) goto 11 ! outer block - 2 increments, 1 goto +1 i = i + 1; if (j == 5) goto 12 ! outer block - 2 increments, 1 goto + i = i + 1; if (j == 6) goto 100 ! program - 1 increment +2 end block +10 i = i + 1 ! 3 increments +11 end do + i = i + 1 ! 0 increments +12 end block +100 print*, i ! expect 21 +end Index: flang/test/Lower/common-block-2.f90 =================================================================== --- flang/test/Lower/common-block-2.f90 +++ flang/test/Lower/common-block-2.f90 @@ -5,12 +5,12 @@ ! - A blank common that is initialized ! - A common block that is initialized outside of a BLOCK DATA. -! CHECK-LABEL: fir.global @_QB : tuple> { +! CHECK-LABEL: fir.global @_QC : tuple> { ! CHECK: %[[undef:.*]] = fir.undefined tuple> ! CHECK: %[[init:.*]] = fir.insert_value %[[undef]], %c42{{.*}}, [0 : index] : (tuple>, i32) -> tuple> ! CHECK: fir.has_value %[[init]] : tuple> -! CHECK-LABEL: fir.global @_QBa : tuple> { +! CHECK-LABEL: fir.global @_QCa : tuple> { ! CHECK: %[[undef:.*]] = fir.undefined tuple> ! CHECK: %[[init:.*]] = fir.insert_value %[[undef]], %c42{{.*}}, [0 : index] : (tuple>, i32) -> tuple> ! CHECK: fir.has_value %[[init]] : tuple> Index: flang/test/Lower/common-block.f90 =================================================================== --- flang/test/Lower/common-block.f90 +++ flang/test/Lower/common-block.f90 @@ -1,18 +1,18 @@ ! RUN: bbc %s -o - | tco | FileCheck %s ! RUN: %flang -emit-llvm -S -mmlir -disable-external-name-interop %s -o - | FileCheck %s -! CHECK: @_QB = common global [8 x i8] zeroinitializer -! CHECK: @_QBrien = common global [1 x i8] zeroinitializer -! CHECK: @_QBwith_empty_equiv = common global [8 x i8] zeroinitializer -! CHECK: @_QBx = global { float, float } { float 1.0{{.*}}, float 2.0{{.*}} } -! CHECK: @_QBy = common global [12 x i8] zeroinitializer -! CHECK: @_QBz = global { i32, [4 x i8], float } { i32 42, [4 x i8] undef, float 3.000000e+00 } +! CHECK: @_QC = common global [8 x i8] zeroinitializer +! CHECK: @_QCrien = common global [1 x i8] zeroinitializer +! CHECK: @_QCwith_empty_equiv = common global [8 x i8] zeroinitializer +! CHECK: @_QCx = global { float, float } { float 1.0{{.*}}, float 2.0{{.*}} } +! CHECK: @_QCy = common global [12 x i8] zeroinitializer +! CHECK: @_QCz = global { i32, [4 x i8], float } { i32 42, [4 x i8] undef, float 3.000000e+00 } ! CHECK-LABEL: _QPs0 subroutine s0 common // a0, b0 - ! CHECK: call void @_QPs(ptr @_QB, ptr getelementptr (i8, ptr @_QB, i64 4)) + ! CHECK: call void @_QPs(ptr @_QC, ptr getelementptr (i8, ptr @_QC, i64 4)) call s(a0, b0) end subroutine s0 @@ -21,7 +21,7 @@ common /x/ a1, b1 data a1 /1.0/, b1 /2.0/ - ! CHECK: call void @_QPs(ptr @_QBx, ptr getelementptr (i8, ptr @_QBx, i64 4)) + ! CHECK: call void @_QPs(ptr @_QCx, ptr getelementptr (i8, ptr @_QCx, i64 4)) call s(a1, b1) end subroutine s1 @@ -29,7 +29,7 @@ subroutine s2 common /y/ a2, b2, c2 - ! CHECK: call void @_QPs(ptr @_QBy, ptr getelementptr (i8, ptr @_QBy, i64 4)) + ! CHECK: call void @_QPs(ptr @_QCy, ptr getelementptr (i8, ptr @_QCy, i64 4)) call s(a2, b2) end subroutine s2 @@ -54,9 +54,9 @@ ! CHECK-LABEL: _QPs4 subroutine s4 use mod_with_common - ! CHECK: load i32, ptr @_QBc_in_mod + ! CHECK: load i32, ptr @_QCc_in_mod print *, i - ! CHECK: load i32, ptr getelementptr (i8, ptr @_QBc_in_mod, i64 4) + ! CHECK: load i32, ptr getelementptr (i8, ptr @_QCc_in_mod, i64 4) print *, j end subroutine s4 Index: flang/test/Lower/computed-goto.f90 =================================================================== --- flang/test/Lower/computed-goto.f90 +++ flang/test/Lower/computed-goto.f90 @@ -2,17 +2,153 @@ ! CHECK-LABEL: func @_QPm function m(index) - ! CHECK: fir.select %{{.}} : i32 [1, ^bb{{.}}, 2, ^bb{{.}}, 3, ^bb{{.}}, 4, ^bb{{.}}, 5, ^bb{{.}}, unit, ^bb{{.}}] - goto (9,7,5,3,1) index ! + 1 - m = 0; return -1 m = 1; return -3 m = 3; return -5 m = 5; return -7 m = 7; return -9 m = 9; return + ! CHECK: %[[V_0:[0-9]+]] = fir.alloca i32 {bindc_name = "m" + ! CHECK: %[[V_1:[0-9]+]] = fir.load %arg0 : !fir.ref + ! CHECK: fir.select %[[V_1]] : i32 [1, ^bb6, 2, ^bb5, 3, ^bb4, 4, ^bb3, 5, ^bb2, unit, ^bb1] + ! CHECK: ^bb1: // pred: ^bb0 + ! CHECK: fir.store %c0{{.*}} to %[[V_0]] : !fir.ref + ! CHECK: cf.br ^bb7 + ! CHECK: ^bb2: // pred: ^bb0 + ! CHECK: fir.store %c1{{.*}} to %[[V_0]] : !fir.ref + ! CHECK: cf.br ^bb7 + ! CHECK: ^bb3: // pred: ^bb0 + ! CHECK: fir.store %c3{{.*}} to %[[V_0]] : !fir.ref + ! CHECK: cf.br ^bb7 + ! CHECK: ^bb4: // pred: ^bb0 + ! CHECK: fir.store %c5{{.*}} to %[[V_0]] : !fir.ref + ! CHECK: cf.br ^bb7 + ! CHECK: ^bb5: // pred: ^bb0 + ! CHECK: fir.store %c7{{.*}} to %[[V_0]] : !fir.ref + ! CHECK: cf.br ^bb7 + ! CHECK: ^bb6: // pred: ^bb0 + ! CHECK: fir.store %c9{{.*}} to %[[V_0]] : !fir.ref + ! CHECK: cf.br ^bb7 + ! CHECK: ^bb7: // 6 preds: ^bb1, ^bb2, ^bb3, ^bb4, ^bb5, ^bb6 + ! CHECK: %[[V_2:[0-9]+]] = fir.load %[[V_0]] : !fir.ref + ! CHECK: return %[[V_2]] : i32 + goto (9,7,5,3,1) index ! + 1 + m = 0; return +1 m = 1; return +3 m = 3; return +5 m = 5; return +7 m = 7; return +9 m = 9; return end -! print*, m(-3); print*, m(0) -! print*, m(1); print*, m(2); print*, m(3); print*, m(4); print*, m(5) -! print*, m(6); print*, m(9) +! CHECK-LABEL: func @_QPm1 +function m1(index) + ! CHECK: %[[V_0:[0-9]+]] = fir.alloca i32 {bindc_name = "m1" + ! CHECK: %[[V_1:[0-9]+]] = fir.call @llvm.stacksave() + ! CHECK: %[[V_2:[0-9]+]] = fir.load %arg0 : !fir.ref + ! CHECK: %[[V_3:[0-9]+]] = arith.cmpi eq, %[[V_2]], %c1{{.*}} : i32 + ! CHECK: cf.cond_br %[[V_3]], ^bb1, ^bb2 + ! CHECK: ^bb1: // pred: ^bb0 + ! CHECK: fir.call @llvm.stackrestore(%[[V_1]]) + ! CHECK: cf.br ^bb3 + ! CHECK: ^bb2: // pred: ^bb0 + ! CHECK: fir.call @llvm.stackrestore(%[[V_1]]) + ! CHECK: fir.store %c0{{.*}} to %[[V_0]] : !fir.ref + ! CHECK: cf.br ^bb4 + ! CHECK: ^bb3: // pred: ^bb1 + ! CHECK: fir.store %c10{{.*}} to %[[V_0]] : !fir.ref + ! CHECK: cf.br ^bb4 + ! CHECK: ^bb4: // 2 preds: ^bb2, ^bb3 + ! CHECK: %[[V_4:[0-9]+]] = fir.load %[[V_0]] : !fir.ref + ! CHECK: return %[[V_4]] : i32 + block + goto (10) index + end block + m1 = 0; return +10 m1 = 10; return +end + +! CHECK-LABEL: func @_QPm2 +function m2(index) + ! CHECK: %[[V_0:[0-9]+]] = fir.alloca i32 {bindc_name = "m2" + ! CHECK: %[[V_1:[0-9]+]] = fir.call @llvm.stacksave() + ! CHECK: %[[V_2:[0-9]+]] = fir.load %arg0 : !fir.ref + ! CHECK: %[[V_3:[0-9]+]] = arith.cmpi eq, %[[V_2]], %c1{{.*}} : i32 + ! CHECK: cf.cond_br %[[V_3]], ^bb1, ^bb2 + ! CHECK: ^bb1: // pred: ^bb0 + ! CHECK: fir.call @llvm.stackrestore(%[[V_1]]) + ! CHECK: cf.br ^bb5 + ! CHECK: ^bb2: // pred: ^bb0 + ! CHECK: %[[V_4:[0-9]+]] = arith.cmpi eq, %[[V_2]], %c2{{.*}} : i32 + ! CHECK: cf.cond_br %[[V_4]], ^bb3, ^bb4 + ! CHECK: ^bb3: // pred: ^bb2 + ! CHECK: fir.call @llvm.stackrestore(%[[V_1]]) + ! CHECK: cf.br ^bb6 + ! CHECK: ^bb4: // pred: ^bb2 + ! CHECK: fir.call @llvm.stackrestore(%[[V_1]]) + ! CHECK: fir.store %c0{{.*}} to %[[V_0]] : !fir.ref + ! CHECK: cf.br ^bb7 + ! CHECK: ^bb5: // pred: ^bb1 + ! CHECK: fir.store %c10{{.*}} to %[[V_0]] : !fir.ref + ! CHECK: cf.br ^bb7 + ! CHECK: ^bb6: // pred: ^bb3 + ! CHECK: fir.store %c20{{.*}} to %[[V_0]] : !fir.ref + ! CHECK: cf.br ^bb7 + ! CHECK: ^bb7: // 3 preds: ^bb4, ^bb5, ^bb6 + ! CHECK: %[[V_5:[0-9]+]] = fir.load %[[V_0]] : !fir.ref + ! CHECK: return %[[V_5]] : i32 + block + goto (10,20) index + end block + m2 = 0; return +10 m2 = 10; return +20 m2 = 20; return +end + +! CHECK-LABEL: func @_QPm3 +function m3(index) + ! CHECK: %[[V_0:[0-9]+]] = fir.alloca i32 {bindc_name = "m3" + ! CHECK: %[[V_1:[0-9]+]] = fir.call @llvm.stacksave() + ! CHECK: %[[V_2:[0-9]+]] = fir.load %arg0 : !fir.ref + ! CHECK: %[[V_3:[0-9]+]] = arith.cmpi eq, %[[V_2]], %c1{{.*}} : i32 + ! CHECK: cf.cond_br %[[V_3]], ^bb1, ^bb2 + ! CHECK: ^bb1: // pred: ^bb0 + ! CHECK: fir.call @llvm.stackrestore(%[[V_1]]) + ! CHECK: cf.br ^bb7 + ! CHECK: ^bb2: // pred: ^bb0 + ! CHECK: %[[V_4:[0-9]+]] = arith.cmpi eq, %[[V_2]], %c2{{.*}} : i32 + ! CHECK: cf.cond_br %[[V_4]], ^bb3, ^bb4 + ! CHECK: ^bb3: // pred: ^bb2 + ! CHECK: fir.call @llvm.stackrestore(%[[V_1]]) + ! CHECK: cf.br ^bb8 + ! CHECK: ^bb4: // pred: ^bb2 + ! CHECK: %[[V_5:[0-9]+]] = arith.cmpi eq, %[[V_2]], %c3{{.*}} : i32 + ! CHECK: cf.cond_br %[[V_5]], ^bb5, ^bb6 + ! CHECK: ^bb5: // pred: ^bb4 + ! CHECK: fir.call @llvm.stackrestore(%[[V_1]]) + ! CHECK: cf.br ^bb9 + ! CHECK: ^bb6: // pred: ^bb4 + ! CHECK: fir.call @llvm.stackrestore(%[[V_1]]) + ! CHECK: fir.store %c0{{.*}} to %[[V_0]] : !fir.ref + ! CHECK: cf.br ^bb10 + ! CHECK: ^bb7: // pred: ^bb1 + ! CHECK: fir.store %c10{{.*}} to %[[V_0]] : !fir.ref + ! CHECK: cf.br ^bb10 + ! CHECK: ^bb8: // pred: ^bb3 + ! CHECK: fir.store %c20{{.*}} to %[[V_0]] : !fir.ref + ! CHECK: cf.br ^bb10 + ! CHECK: ^bb9: // pred: ^bb5 + ! CHECK: fir.store %c30{{.*}} to %[[V_0]] : !fir.ref + ! CHECK: cf.br ^bb10 + ! CHECK: ^bb10: // 4 preds: ^bb6, ^bb7, ^bb8, ^bb9 + ! CHECK: %[[V_6:[0-9]+]] = fir.load %[[V_0]] : !fir.ref + ! CHECK: return %[[V_6]] : i32 + block + goto (10,20,30) index + end block + m3 = 0; return +10 m3 = 10; return +20 m3 = 20; return +30 m3 = 30; return +end + +program cg + print*, m(-3), m(1), m(2), m(3), m(4), m(5), m(9) ! 0 9 7 5 3 1 0 + print*, m1(0), m1(1), m1(2) ! 0 10 0 + print*, m2(0), m2(1), m2(2), m2(3) ! 0 10 20 0 + print*, m3(0), m3(1), m3(2), m3(3), m3(4) ! 0 10 20 30 0 end Index: flang/test/Lower/equivalence-2.f90 =================================================================== --- flang/test/Lower/equivalence-2.f90 +++ flang/test/Lower/equivalence-2.f90 @@ -111,7 +111,7 @@ equivalence(arr3,arr4) ! CHECK: %[[arr4Store:.*]] = fir.alloca !fir.array<70756xi8> {uniq_name = "_QFeq_and_comm_same_offsetEarr3"} - ! CHECK: %[[mcbAddr:.*]] = fir.address_of(@_QBmy_common_block) : !fir.ref> + ! CHECK: %[[mcbAddr:.*]] = fir.address_of(@_QCmy_common_block) : !fir.ref> ! CHECK: %[[mcbCast:.*]] = fir.convert %[[mcbAddr]] : (!fir.ref>) -> !fir.ref> ! CHECK: %[[c0:.*]] = arith.constant 0 : index ! CHECK: %[[mcbCoor:.*]] = fir.coordinate_of %[[mcbCast]], %[[c0]] : (!fir.ref>, index) -> !fir.ref Index: flang/test/Lower/explicit-interface-results-2.f90 =================================================================== --- flang/test/Lower/explicit-interface-results-2.f90 +++ flang/test/Lower/explicit-interface-results-2.f90 @@ -140,7 +140,7 @@ common /mycom/ n_common call takes_array(return_array()) ! CHECK: %[[VAL_0:.*]] = arith.constant 0 : index -! CHECK: %[[VAL_2:.*]] = fir.address_of(@_QBmycom) : !fir.ref> +! CHECK: %[[VAL_2:.*]] = fir.address_of(@_QCmycom) : !fir.ref> ! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.ref>) -> !fir.ref> ! CHECK: %[[VAL_4:.*]] = fir.coordinate_of %[[VAL_3]], %[[VAL_0]] : (!fir.ref>, index) -> !fir.ref ! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.ref) -> !fir.ref @@ -162,7 +162,7 @@ implicit none call takes_array(return_array()) ! CHECK: %[[VAL_0:.*]] = arith.constant 0 : index -! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QBmycom) : !fir.ref> +! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QCmycom) : !fir.ref> ! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]] : (!fir.ref>) -> !fir.ref> ! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_0]] : (!fir.ref>, index) -> !fir.ref ! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.ref) -> !fir.ref @@ -190,7 +190,7 @@ ! CHECK-LABEL: func @_QFhost9Pinternal_proc_a subroutine internal_proc_a() ! CHECK: %[[VAL_0:.*]] = arith.constant 0 : index -! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QBmycom) : !fir.ref> +! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QCmycom) : !fir.ref> ! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]] : (!fir.ref>) -> !fir.ref> ! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_0]] : (!fir.ref>, index) -> !fir.ref ! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.ref) -> !fir.ref @@ -217,7 +217,7 @@ subroutine internal_proc_a() call takes_array(return_array()) ! CHECK: %[[VAL_0:.*]] = arith.constant 0 : index -! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QBmycom) : !fir.ref> +! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QCmycom) : !fir.ref> ! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]] : (!fir.ref>) -> !fir.ref> ! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_0]] : (!fir.ref>, index) -> !fir.ref ! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.ref) -> !fir.ref Index: flang/test/Lower/forall/array-constructor.f90 =================================================================== --- flang/test/Lower/forall/array-constructor.f90 +++ flang/test/Lower/forall/array-constructor.f90 @@ -116,7 +116,7 @@ ! CHECK-LABEL: func @_QFac1Pfunc( ! CHECK-SAME: %[[VAL_0:.*]]: !fir.box> {fir.bindc_name = "a"}) -> i32 { -! CHECK: %[[VAL_1:.*]] = fir.alloca i32 {bindc_name = "func", uniq_name = "_QFfuncEfunc"} +! CHECK: %[[VAL_1:.*]] = fir.alloca i32 {bindc_name = "func", uniq_name = "_QFac1FfuncEfunc"} ! CHECK: %[[VAL_2:.*]] = arith.constant 1 : i64 ! CHECK: %[[VAL_3:.*]] = arith.constant 1 : i64 ! CHECK: %[[VAL_4:.*]] = arith.subi %[[VAL_2]], %[[VAL_3]] : i64 @@ -262,7 +262,7 @@ ! CHECK-LABEL: func @_QFac2Pfunc( ! CHECK-SAME: %[[VAL_0:.*]]: !fir.box> {fir.bindc_name = "a"}) -> !fir.array<3xi32> { ! CHECK: %[[VAL_1:.*]] = arith.constant 3 : index -! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.array<3xi32> {bindc_name = "func", uniq_name = "_QFfuncEfunc"} +! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.array<3xi32> {bindc_name = "func", uniq_name = "_QFac2FfuncEfunc"} ! CHECK: %[[VAL_3:.*]] = fir.shape %[[VAL_1]] : (index) -> !fir.shape<1> ! CHECK: %[[VAL_4:.*]] = fir.array_load %[[VAL_2]](%[[VAL_3]]) : (!fir.ref>, !fir.shape<1>) -> !fir.array<3xi32> ! CHECK: %[[VAL_5:.*]] = arith.constant 1 : i64 Index: flang/test/Lower/host-associated-globals.f90 =================================================================== --- flang/test/Lower/host-associated-globals.f90 +++ flang/test/Lower/host-associated-globals.f90 @@ -38,7 +38,7 @@ end subroutine end subroutine ! CHECK-LABEL: func.func @_QFtest_commonPbar() attributes {fir.internal_proc} { -! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QBx) : !fir.ref> +! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QCx) : !fir.ref> ! CHECK: %[[VAL_1:.*]] = fir.convert %[[VAL_0]] : (!fir.ref>) -> !fir.ref> ! CHECK: %[[VAL_2:.*]] = arith.constant 4 : index ! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_1]], %[[VAL_2]] : (!fir.ref>, index) -> !fir.ref Index: flang/test/Lower/module_definition.f90 =================================================================== --- flang/test/Lower/module_definition.f90 +++ flang/test/Lower/module_definition.f90 @@ -12,15 +12,15 @@ real :: x_named1 common /named1/ x_named1 end module -! CHECK-LABEL: fir.global common @_QB(dense<0> : vector<4xi8>) : !fir.array<4xi8> -! CHECK-LABEL: fir.global common @_QBnamed1(dense<0> : vector<4xi8>) : !fir.array<4xi8> +! CHECK-LABEL: fir.global common @_QC(dense<0> : vector<4xi8>) : !fir.array<4xi8> +! CHECK-LABEL: fir.global common @_QCnamed1(dense<0> : vector<4xi8>) : !fir.array<4xi8> ! Module defines variable in common block with initialization module modCommonInit1 integer :: i_named2 = 42 common /named2/ i_named2 end module -! CHECK-LABEL: fir.global @_QBnamed2 : tuple { +! CHECK-LABEL: fir.global @_QCnamed2 : tuple { ! CHECK: %[[init:.*]] = fir.insert_value %{{.*}}, %c42{{.*}}, [0 : index] : (tuple, i32) -> tuple ! CHECK: fir.has_value %[[init]] : tuple Index: flang/test/Lower/module_use.f90 =================================================================== --- flang/test/Lower/module_use.f90 +++ flang/test/Lower/module_use.f90 @@ -5,9 +5,9 @@ ! The modules are defined in module_definition.f90 ! The first runs ensures the module file is generated. -! CHECK: fir.global common @_QB(dense<0> : vector<4xi8>) : !fir.array<4xi8> -! CHECK-NEXT: fir.global common @_QBnamed1(dense<0> : vector<4xi8>) : !fir.array<4xi8> -! CHECK-NEXT: fir.global common @_QBnamed2(dense<0> : vector<4xi8>) : !fir.array<4xi8> +! CHECK: fir.global common @_QC(dense<0> : vector<4xi8>) : !fir.array<4xi8> +! CHECK-NEXT: fir.global common @_QCnamed1(dense<0> : vector<4xi8>) : !fir.array<4xi8> +! CHECK-NEXT: fir.global common @_QCnamed2(dense<0> : vector<4xi8>) : !fir.array<4xi8> ! CHECK-LABEL: func @_QPm1use() real function m1use() @@ -32,9 +32,9 @@ real function modCommon1Use() use modCommonInit1 use modCommonNoInit1 - ! CHECK-DAG: fir.address_of(@_QBnamed2) : !fir.ref> - ! CHECK-DAG: fir.address_of(@_QB) : !fir.ref> - ! CHECK-DAG: fir.address_of(@_QBnamed1) : !fir.ref> + ! CHECK-DAG: fir.address_of(@_QCnamed2) : !fir.ref> + ! CHECK-DAG: fir.address_of(@_QC) : !fir.ref> + ! CHECK-DAG: fir.address_of(@_QCnamed1) : !fir.ref> modCommon1Use = x_blank + x_named1 + i_named2 end function Index: flang/test/Lower/module_use_in_same_file.f90 =================================================================== --- flang/test/Lower/module_use_in_same_file.f90 +++ flang/test/Lower/module_use_in_same_file.f90 @@ -79,26 +79,26 @@ contains ! CHECK-LABEL: func @_QMmodcommon2Pfoo() real function foo() - ! CHECK-DAG: fir.address_of(@_QBnamed2) : !fir.ref> - ! CHECK-DAG: fir.address_of(@_QB) : !fir.ref> - ! CHECK-DAG: fir.address_of(@_QBnamed1) : !fir.ref> + ! CHECK-DAG: fir.address_of(@_QCnamed2) : !fir.ref> + ! CHECK-DAG: fir.address_of(@_QC) : !fir.ref> + ! CHECK-DAG: fir.address_of(@_QCnamed1) : !fir.ref> foo = x_blank + x_named1(5) + i_named2 end function end module ! CHECK-LABEL: func @_QPmodcommon2use() real function modCommon2use() use modCommon2 - ! CHECK-DAG: fir.address_of(@_QBnamed2) : !fir.ref> - ! CHECK-DAG: fir.address_of(@_QB) : !fir.ref> - ! CHECK-DAG: fir.address_of(@_QBnamed1) : !fir.ref> + ! CHECK-DAG: fir.address_of(@_QCnamed2) : !fir.ref> + ! CHECK-DAG: fir.address_of(@_QC) : !fir.ref> + ! CHECK-DAG: fir.address_of(@_QCnamed1) : !fir.ref> modCommon2use = x_blank + x_named1(5) + i_named2 end function ! CHECK-LABEL: func @_QPmodcommon2use_rename() real function modCommon2use_rename() use modCommon2, only : renamed0 => x_blank, renamed1 => x_named1, renamed2 => i_named2 - ! CHECK-DAG: fir.address_of(@_QBnamed2) : !fir.ref> - ! CHECK-DAG: fir.address_of(@_QB) : !fir.ref> - ! CHECK-DAG: fir.address_of(@_QBnamed1) : !fir.ref> + ! CHECK-DAG: fir.address_of(@_QCnamed2) : !fir.ref> + ! CHECK-DAG: fir.address_of(@_QC) : !fir.ref> + ! CHECK-DAG: fir.address_of(@_QCnamed1) : !fir.ref> modCommon2use_rename = renamed0 + renamed1(5) + renamed2 end function Index: flang/test/Lower/namelist-common-block.f90 =================================================================== --- flang/test/Lower/namelist-common-block.f90 +++ flang/test/Lower/namelist-common-block.f90 @@ -17,8 +17,8 @@ end subroutine end -! CHECK-LABEL: fir.global linkonce @_QFGt.list constant : !fir.array<2xtuple, !fir.ref>>> { -! CHECK: %[[CB_ADDR:.*]] = fir.address_of(@_QBc) : !fir.ref> +! CHECK-LABEL: fir.global linkonce @_QFNt.list constant : !fir.array<2xtuple, !fir.ref>>> { +! CHECK: %[[CB_ADDR:.*]] = fir.address_of(@_QCc) : !fir.ref> ! CHECK: %[[CB_CAST:.*]] = fir.convert %[[CB_ADDR]] : (!fir.ref>) -> !fir.ref> ! CHECK: %[[OFFSET:.*]] = arith.constant 8 : index ! CHECK: %[[COORD:.*]] = fir.coordinate_of %[[CB_CAST]], %[[OFFSET]] : (!fir.ref>, index) -> !fir.ref @@ -26,4 +26,3 @@ ! CHECK: %[[CAST_BOX_NONE:.*]] = fir.convert %[[CAST_BOX]] : (!fir.ref>>>) -> !fir.ref> ! CHECK: %[[RES:.*]] = fir.insert_value %{{.*}}, %[[CAST_BOX_NONE]], [1 : index, 1 : index] : (!fir.array<2xtuple, !fir.ref>>>, !fir.ref>) -> !fir.array<2xtuple, !fir.ref>>> ! CHECK: fir.has_value %[[RES]] : !fir.array<2xtuple, !fir.ref>>> - Index: flang/test/Lower/parent-component.f90 =================================================================== --- flang/test/Lower/parent-component.f90 +++ flang/test/Lower/parent-component.f90 @@ -43,7 +43,7 @@ print*,y(:)%p end subroutine ! CHECK-LABEL: func.func @_QFPinit_with_slice() - ! CHECK: %[[Y:.*]] = fir.address_of(@_QFinit_with_sliceEy) : !fir.ref>> + ! CHECK: %[[Y:.*]] = fir.address_of(@_QFFinit_with_sliceEy) : !fir.ref>> ! CHECK: %[[C2:.*]] = arith.constant 2 : index ! CHECK: %[[C1:.*]] = arith.constant 1 : index ! CHECK: %[[C1_I64:.*]] = arith.constant 1 : i64 @@ -81,7 +81,7 @@ print*,y%p end subroutine ! CHECK-LABEL: func.func @_QFPinit_no_slice() - ! CHECK: %[[Y:.*]] = fir.address_of(@_QFinit_no_sliceEy) : !fir.ref>> + ! CHECK: %[[Y:.*]] = fir.address_of(@_QFFinit_no_sliceEy) : !fir.ref>> ! CHECK: %[[C2:.*]] = arith.constant 2 : index ! CHECK: %[[SHAPE:.*]] = fir.shape %[[C2]] : (index) -> !fir.shape<1> ! CHECK: %[[FIELD:.*]] = fir.field_index a, !fir.type<_QFTc{a:i32,b:i32}> @@ -119,9 +119,9 @@ end subroutine ! CHECK-LABEL: func.func @_QFPinit_allocatable() - ! CHECK: %[[ALLOC:.*]] = fir.alloca !fir.heap>> {uniq_name = "_QFinit_allocatableEy.addr"} - ! CHECK: %[[LB0:.*]] = fir.alloca index {uniq_name = "_QFinit_allocatableEy.lb0"} - ! CHECK: %[[EXT0:.*]] = fir.alloca index {uniq_name = "_QFinit_allocatableEy.ext0"} + ! CHECK: %[[ALLOC:.*]] = fir.alloca !fir.heap>> {uniq_name = "_QFFinit_allocatableEy.addr"} + ! CHECK: %[[LB0:.*]] = fir.alloca index {uniq_name = "_QFFinit_allocatableEy.lb0"} + ! CHECK: %[[EXT0:.*]] = fir.alloca index {uniq_name = "_QFFinit_allocatableEy.ext0"} ! CHECK-COUNT-6: %{{.*}} = fir.field_index a, !fir.type<_QFTc{a:i32,b:i32}> ! CHECK: %[[LOAD_LB0:.*]] = fir.load %[[LB0]] : !fir.ref ! CHECK: %[[LOAD_EXT0:.*]] = fir.load %[[EXT0]] : !fir.ref @@ -166,7 +166,7 @@ end subroutine ! CHECK-LABEL: func.func @_QFPinit_scalar() - ! CHECK: %[[S:.*]] = fir.address_of(@_QFinit_scalarEs) : !fir.ref> + ! CHECK: %[[S:.*]] = fir.address_of(@_QFFinit_scalarEs) : !fir.ref> ! CHECK: %[[CAST:.*]] = fir.convert %[[S]] : (!fir.ref>) -> !fir.ref> ! CHECK: fir.call @_QFPprint_scalar(%[[CAST]]) {{.*}}: (!fir.ref>) -> () @@ -207,7 +207,7 @@ ! CHECK-LABEL: func.func @_QFPinit_existing_field ! CHECK: %[[C2:.*]] = arith.constant 2 : index - ! CHECK: %[[ALLOCA:.*]] = fir.alloca !fir.array<2x!fir.type<_QFTz{k:i32,c:!fir.type<_QFTc{a:i32,b:i32}>}>> {bindc_name = "y", uniq_name = "_QFinit_existing_fieldEy"} + ! CHECK: %[[ALLOCA:.*]] = fir.alloca !fir.array<2x!fir.type<_QFTz{k:i32,c:!fir.type<_QFTc{a:i32,b:i32}>}>> {bindc_name = "y", uniq_name = "_QFFinit_existing_fieldEy"} ! CHECK: %[[FIELD_C:.*]] = fir.field_index c, !fir.type<_QFTz{k:i32,c:!fir.type<_QFTc{a:i32,b:i32}>}> ! CHECK: %[[SHAPE:.*]] = fir.shape %[[C2]] : (index) -> !fir.shape<1> ! CHECK: %[[C1:.*]] = arith.constant 1 : index Index: flang/test/Lower/pointer-assignments.f90 =================================================================== --- flang/test/Lower/pointer-assignments.f90 +++ flang/test/Lower/pointer-assignments.f90 @@ -364,7 +364,7 @@ integer, target :: x integer, pointer :: p common /some_common/ p - ! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QBsome_common) : !fir.ref> + ! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QCsome_common) : !fir.ref> ! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]] : (!fir.ref>) -> !fir.ref> ! CHECK: %[[VAL_3:.*]] = arith.constant 0 : index ! CHECK: %[[VAL_4:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_3]] : (!fir.ref>, index) -> !fir.ref Index: flang/test/Lower/pointer-initial-target-2.f90 =================================================================== --- flang/test/Lower/pointer-initial-target-2.f90 +++ flang/test/Lower/pointer-initial-target-2.f90 @@ -11,7 +11,7 @@ real, save, target :: b common /a/ p data p /b/ -! CHECK-LABEL: fir.global @_QBa : tuple>> +! CHECK-LABEL: fir.global @_QCa : tuple>> ! CHECK: %[[undef:.*]] = fir.undefined tuple>> ! CHECK: %[[b:.*]] = fir.address_of(@_QEb) : !fir.ref ! CHECK: %[[box:.*]] = fir.embox %[[b]] : (!fir.ref) -> !fir.box @@ -29,10 +29,10 @@ real, pointer :: p2 => x1 common /c1/ x1, p1 common /c2/ x2, p2 -! CHECK-LABEL: fir.global @_QBc1 : tuple, !fir.box>> - ! CHECK: fir.address_of(@_QBc2) : !fir.ref, !fir.box>>> -! CHECK-LABEL: fir.global @_QBc2 : tuple, !fir.box>> - ! CHECK: fir.address_of(@_QBc1) : !fir.ref, !fir.box>>> +! CHECK-LABEL: fir.global @_QCc1 : tuple, !fir.box>> + ! CHECK: fir.address_of(@_QCc2) : !fir.ref, !fir.box>>> +! CHECK-LABEL: fir.global @_QCc2 : tuple, !fir.box>> + ! CHECK: fir.address_of(@_QCc1) : !fir.ref, !fir.box>>> end block data ! Test pointer in a common with initial target in the same common. @@ -40,9 +40,9 @@ integer, target :: b = 42 integer, pointer :: p => b common /snake/ p, b -! CHECK-LABEL: fir.global @_QBsnake : tuple>, i32> +! CHECK-LABEL: fir.global @_QCsnake : tuple>, i32> ! CHECK: %[[tuple0:.*]] = fir.undefined tuple>, i32> - ! CHECK: %[[snakeAddr:.*]] = fir.address_of(@_QBsnake) : !fir.ref>, i32>> + ! CHECK: %[[snakeAddr:.*]] = fir.address_of(@_QCsnake) : !fir.ref>, i32>> ! CHECK: %[[byteView:.*]] = fir.convert %[[snakeAddr:.*]] : (!fir.ref>, i32>>) -> !fir.ref> ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[byteView]], %c24{{.*}} : (!fir.ref>, index) -> !fir.ref ! CHECK: %[[bAddr:.*]] = fir.convert %[[coor]] : (!fir.ref) -> !fir.ref @@ -72,7 +72,7 @@ save :: /com/ real, pointer :: p(:) => y ! CHECK-LABEL: fir.global @_QMsome_mod_2Ep : !fir.box>> { - ! CHECK: %[[c:.*]] = fir.address_of(@_QBcom) : !fir.ref> + ! CHECK: %[[c:.*]] = fir.address_of(@_QCcom) : !fir.ref> ! CHECK: %[[com:.*]] = fir.convert %[[c]] : (!fir.ref>) -> !fir.ref> ! CHECK: %[[yRaw:.*]] = fir.coordinate_of %[[com]], %c400{{.*}} : (!fir.ref>, index) -> !fir.ref ! CHECK: %[[y:.*]] = fir.convert %[[yRaw]] : (!fir.ref) -> !fir.ref> Index: flang/test/Lower/program-units-fir-mangling.f90 =================================================================== --- flang/test/Lower/program-units-fir-mangling.f90 +++ flang/test/Lower/program-units-fir-mangling.f90 @@ -92,34 +92,32 @@ end interface end module color_points -! We don't handle lowering of submodules yet. The following tests are -! commented out and "CHECK" is changed to "xHECK" to not trigger FileCheck. -!submodule (color_points) color_points_a -!contains -! ! xHECK-LABEL: func @_QMcolor_pointsScolor_points_aPsub() { -! subroutine sub -! end subroutine -! ! xHECK: } -!end submodule -! -!submodule (color_points:color_points_a) impl -!contains -! ! xHECK-LABEL: func @_QMcolor_pointsScolor_points_aSimplPfoo() -! subroutine foo -! contains -! ! xHECK-LABEL: func @_QMcolor_pointsScolor_points_aSimplFfooPbar() { -! subroutine bar -! ! xHECK: } -! end subroutine -! end subroutine -! ! xHECK-LABEL: func @_QMcolor_pointsPdraw() { -! module subroutine draw() -! end subroutine -! !FIXME func @_QMcolor_pointsPerase() -> i32 { -! module procedure erase -! ! xHECK: } -! end procedure -!end submodule +submodule (color_points) color_points_a +contains + ! CHECK-LABEL: func @_QMcolor_pointsScolor_points_aPsub() { + subroutine sub + end subroutine + ! CHECK: } +end submodule + +submodule (color_points:color_points_a) impl +contains + ! CHECK-LABEL: func @_QMcolor_pointsScolor_points_aSimplPfoo() + subroutine foo + contains + ! CHECK-LABEL: func @_QMcolor_pointsScolor_points_aSimplFfooPbar() { + subroutine bar + ! CHECK: } + end subroutine + end subroutine + ! CHECK-LABEL: func @_QMcolor_pointsPdraw() { + module subroutine draw() + end subroutine + !FIXME func @_QMcolor_pointsPerase() -> i32 { + module procedure erase + ! CHECK: } + end procedure +end submodule ! CHECK-LABEL: func @_QPshould_not_collide() { subroutine should_not_collide() @@ -222,4 +220,31 @@ end subroutine end module + +! CHECK-LABEL: func @_QPnest1 +subroutine nest1 + ! CHECK: fir.call @_QFnest1Pinner() + call inner +contains + ! CHECK-LABEL: func @_QFnest1Pinner + subroutine inner + ! CHECK: %[[V_0:[0-9]+]] = fir.address_of(@_QFnest1FinnerEkk) : !fir.ref + integer, save :: kk = 1 + print*, 'qq:inner', kk + end +end + +! CHECK-LABEL: func @_QPnest2 +subroutine nest2 + ! CHECK: fir.call @_QFnest2Pinner() + call inner +contains + ! CHECK-LABEL: func @_QFnest2Pinner + subroutine inner + ! CHECK: %[[V_0:[0-9]+]] = fir.address_of(@_QFnest2FinnerEkk) : !fir.ref + integer, save :: kk = 77 + print*, 'ss:inner', kk + end +end + ! CHECK-LABEL: fir.global internal @_QFfooEpi : f32 { Index: flang/test/Lower/select-case-statement.f90 =================================================================== --- flang/test/Lower/select-case-statement.f90 +++ flang/test/Lower/select-case-statement.f90 @@ -176,9 +176,6 @@ ! CHECK: %[[V_20:[0-9]+]] = fir.box_addr %[[V_18]] : (!fir.box>>) -> !fir.heap> ! CHECK: %[[V_42:[0-9]+]] = fir.call @_FortranACharacterCompareScalar1 ! CHECK: %[[V_43:[0-9]+]] = arith.cmpi eq, %[[V_42]], %c0{{.*}} : i32 - ! CHECK: fir.if %[[V_43]] { - ! CHECK: fir.freemem %[[V_20]] : !fir.heap> - ! CHECK: } ! CHECK: cond_br %[[V_43]], ^bb3, ^bb2 ! CHECK: ^bb2: // pred: ^bb1 select case(trim(s)) @@ -190,9 +187,6 @@ ! CHECK: %[[V_48:[0-9]+]] = fir.call @_FortranACharacterCompareScalar1 ! CHECK: %[[V_49:[0-9]+]] = arith.cmpi eq, %[[V_48]], %c0{{.*}} : i32 - ! CHECK: fir.if %[[V_49]] { - ! CHECK: fir.freemem %[[V_20]] : !fir.heap> - ! CHECK: } ! CHECK: cond_br %[[V_49]], ^bb6, ^bb5 ! CHECK: ^bb3: // pred: ^bb1 ! CHECK: fir.store %c1{{.*}} to %[[V_1]] : !fir.ref @@ -203,9 +197,6 @@ ! CHECK: %[[V_54:[0-9]+]] = fir.call @_FortranACharacterCompareScalar1 ! CHECK: %[[V_55:[0-9]+]] = arith.cmpi eq, %[[V_54]], %c0{{.*}} : i32 - ! CHECK: fir.if %[[V_55]] { - ! CHECK: fir.freemem %[[V_20]] : !fir.heap> - ! CHECK: } ! CHECK: cond_br %[[V_55]], ^bb8, ^bb7 ! CHECK: ^bb6: // pred: ^bb2 ! CHECK: fir.store %c2{{.*}} to %[[V_1]] : !fir.ref @@ -223,9 +214,6 @@ ! CHECK: ^bb9: // pred: ^bb7 ! CHECK: %[[V_66:[0-9]+]] = fir.call @_FortranACharacterCompareScalar1 ! CHECK: %[[V_67:[0-9]+]] = arith.cmpi sle, %[[V_66]], %c0{{.*}} : i32 - ! CHECK: fir.if %[[V_67]] { - ! CHECK: fir.freemem %[[V_20]] : !fir.heap> - ! CHECK: } ! CHECK: cond_br %[[V_67]], ^bb14, ^bb10 ! CHECK: ^bb10: // 2 preds: ^bb7, ^bb9 ! CHECK: %[[V_72:[0-9]+]] = fir.call @_FortranACharacterCompareScalar1 @@ -234,18 +222,15 @@ ! CHECK: ^bb11: // pred: ^bb10 ! CHECK: %[[V_78:[0-9]+]] = fir.call @_FortranACharacterCompareScalar1 ! CHECK: %[[V_79:[0-9]+]] = arith.cmpi sle, %[[V_78]], %c0{{.*}} : i32 - ! CHECK: fir.if %[[V_79]] { - ! CHECK: fir.freemem %[[V_20]] : !fir.heap> - ! CHECK: } ! CHECK: ^bb12: // 2 preds: ^bb10, ^bb11 ! CHECK: %[[V_84:[0-9]+]] = fir.call @_FortranACharacterCompareScalar1 ! CHECK: %[[V_85:[0-9]+]] = arith.cmpi sge, %[[V_84]], %c0{{.*}} : i32 - ! CHECK: fir.freemem %[[V_20]] : !fir.heap> ! CHECK: cond_br %[[V_85]], ^bb14, ^bb13 ! CHECK: ^bb13: // pred: ^bb12 ! CHECK: ^bb14: // 3 preds: ^bb9, ^bb11, ^bb12 ! CHECK: fir.store %c4{{.*}} to %[[V_1]] : !fir.ref ! CHECK: ^bb15: // 5 preds: ^bb3, ^bb4, ^bb6, ^bb8, ^bb14 + ! CHECK: fir.freemem %[[V_20]] : !fir.heap> end select end if ! CHECK: %[[V_89:[0-9]+]] = fir.load %[[V_1]] : !fir.ref @@ -257,28 +242,28 @@ ! CHECK-DAG: %[[V_0:[0-9]+]] = fir.alloca !fir.box>> ! CHECK: %[[V_1:[0-9]+]] = fir.alloca !fir.box>> character(len=3) :: s - n = 0 + n = -10 ! CHECK: %[[V_12:[0-9]+]] = fir.load %[[V_1]] : !fir.ref>>> ! CHECK: %[[V_13:[0-9]+]] = fir.box_addr %[[V_12]] : (!fir.box>>) -> !fir.heap> - ! CHECK: fir.freemem %[[V_13]] : !fir.heap> ! CHECK: br ^bb1 ! CHECK: ^bb1: // pred: ^bb0 + ! CHECK: fir.store %c9{{.*}} ! CHECK: br ^bb2 - n = -10 + ! CHECK: ^bb2: // pred: ^bb1 + ! CHECK: fir.freemem %[[V_13]] : !fir.heap> select case(trim(s)) case default n = 9 end select print*, n - ! CHECK: ^bb2: // pred: ^bb1 + n = -2 ! CHECK: %[[V_28:[0-9]+]] = fir.load %[[V_0]] : !fir.ref>>> ! CHECK: %[[V_29:[0-9]+]] = fir.box_addr %[[V_28]] : (!fir.box>>) -> !fir.heap> - ! CHECK: fir.freemem %[[V_29]] : !fir.heap> ! CHECK: br ^bb3 ! CHECK: ^bb3: // pred: ^bb2 - n = -2 + ! CHECK: fir.freemem %[[V_29]] : !fir.heap> select case(trim(s)) end select print*, n Index: flang/unittests/Optimizer/InternalNamesTest.cpp =================================================================== --- flang/unittests/Optimizer/InternalNamesTest.cpp +++ flang/unittests/Optimizer/InternalNamesTest.cpp @@ -16,23 +16,23 @@ using llvm::StringRef; struct DeconstructedName { + DeconstructedName(llvm::StringRef name) : name{name} {} DeconstructedName(llvm::ArrayRef modules, - std::optional host, llvm::StringRef name, - llvm::ArrayRef kinds) - : modules{modules.begin(), modules.end()}, host{host}, name{name}, - kinds{kinds.begin(), kinds.end()} {} + llvm::ArrayRef procs, std::int64_t blockId, + llvm::StringRef name, llvm::ArrayRef kinds) + : modules{modules.begin(), modules.end()}, procs{procs.begin(), + procs.end()}, + blockId{blockId}, name{name}, kinds{kinds.begin(), kinds.end()} {} bool isObjEqual(const NameUniquer::DeconstructedName &actualObj) { - if ((actualObj.name == name) && (actualObj.modules == modules) && - (actualObj.host == host) && (actualObj.kinds == kinds)) { - return true; - } - return false; + return actualObj.modules == modules && actualObj.procs == procs && + actualObj.blockId == blockId && actualObj.name == name && + actualObj.kinds == kinds; } -private: llvm::SmallVector modules; - std::optional host; + llvm::SmallVector procs; + std::int64_t blockId; std::string name; llvm::SmallVector kinds; }; @@ -47,20 +47,11 @@ << "Possible error: DeconstructedName mismatch"; } -TEST(InternalNamesTest, doBlockDataTest) { - std::string actual = NameUniquer::doBlockData("blockdatatest"); - std::string actualBlank = NameUniquer::doBlockData(""); - std::string expectedMangledName = "_QLblockdatatest"; - std::string expectedMangledNameBlank = "_QL"; - ASSERT_EQ(actual, expectedMangledName); - ASSERT_EQ(actualBlank, expectedMangledNameBlank); -} - TEST(InternalNamesTest, doCommonBlockTest) { std::string actual = NameUniquer::doCommonBlock("hello"); std::string actualBlank = NameUniquer::doCommonBlock(""); - std::string expectedMangledName = "_QBhello"; - std::string expectedMangledNameBlank = "_QB"; + std::string expectedMangledName = "_QChello"; + std::string expectedMangledNameBlank = "_QC"; ASSERT_EQ(actual, expectedMangledName); ASSERT_EQ(actualBlank, expectedMangledNameBlank); } @@ -81,7 +72,7 @@ TEST(InternalNamesTest, doConstantTest) { std::string actual = - NameUniquer::doConstant({"mod1", "mod2"}, {"foo"}, "Hello"); + NameUniquer::doConstant({"mod1", "mod2"}, {"foo"}, 0, "Hello"); std::string expectedMangledName = "_QMmod1Smod2FfooEChello"; ASSERT_EQ(actual, expectedMangledName); } @@ -93,66 +84,59 @@ } TEST(InternalNamesTest, doTypeTest) { - std::string actual = NameUniquer::doType({}, {}, "mytype", {4, -1}); + std::string actual = NameUniquer::doType({}, {}, 0, "mytype", {4, -1}); std::string expectedMangledName = "_QTmytypeK4KN1"; ASSERT_EQ(actual, expectedMangledName); } TEST(InternalNamesTest, doIntrinsicTypeDescriptorTest) { using IntrinsicType = fir::NameUniquer::IntrinsicType; - std::string actual = - NameUniquer::doIntrinsicTypeDescriptor({}, {}, IntrinsicType::REAL, 42); - std::string expectedMangledName = "_QCrealK42"; + std::string actual = NameUniquer::doIntrinsicTypeDescriptor( + {}, {}, 0, IntrinsicType::REAL, 42); + std::string expectedMangledName = "_QYIrealK42"; ASSERT_EQ(actual, expectedMangledName); - actual = - NameUniquer::doIntrinsicTypeDescriptor({}, {}, IntrinsicType::REAL, {}); - expectedMangledName = "_QCrealK0"; + actual = NameUniquer::doIntrinsicTypeDescriptor( + {}, {}, 0, IntrinsicType::REAL, {}); + expectedMangledName = "_QYIrealK0"; ASSERT_EQ(actual, expectedMangledName); - actual = - NameUniquer::doIntrinsicTypeDescriptor({}, {}, IntrinsicType::INTEGER, 3); - expectedMangledName = "_QCintegerK3"; + actual = NameUniquer::doIntrinsicTypeDescriptor( + {}, {}, 0, IntrinsicType::INTEGER, 3); + expectedMangledName = "_QYIintegerK3"; ASSERT_EQ(actual, expectedMangledName); - actual = - NameUniquer::doIntrinsicTypeDescriptor({}, {}, IntrinsicType::LOGICAL, 2); - expectedMangledName = "_QClogicalK2"; + actual = NameUniquer::doIntrinsicTypeDescriptor( + {}, {}, 0, IntrinsicType::LOGICAL, 2); + expectedMangledName = "_QYIlogicalK2"; ASSERT_EQ(actual, expectedMangledName); actual = NameUniquer::doIntrinsicTypeDescriptor( - {}, {}, IntrinsicType::CHARACTER, 4); - expectedMangledName = "_QCcharacterK4"; + {}, {}, 0, IntrinsicType::CHARACTER, 4); + expectedMangledName = "_QYIcharacterK4"; ASSERT_EQ(actual, expectedMangledName); - actual = - NameUniquer::doIntrinsicTypeDescriptor({}, {}, IntrinsicType::COMPLEX, 4); - expectedMangledName = "_QCcomplexK4"; + actual = NameUniquer::doIntrinsicTypeDescriptor( + {}, {}, 0, IntrinsicType::COMPLEX, 4); + expectedMangledName = "_QYIcomplexK4"; ASSERT_EQ(actual, expectedMangledName); } TEST(InternalNamesTest, doDispatchTableTest) { std::string actual = - NameUniquer::doDispatchTable({}, {}, "MyTYPE", {2, 8, 18}); + NameUniquer::doDispatchTable({}, {}, 0, "MyTYPE", {2, 8, 18}); std::string expectedMangledName = "_QDTmytypeK2K8K18"; ASSERT_EQ(actual, expectedMangledName); } -TEST(InternalNamesTest, doTypeDescriptorTest) { - std::string actual = NameUniquer::doTypeDescriptor( - {StringRef("moD1")}, {StringRef("foo")}, "MyTYPE", {2, 8}); - std::string expectedMangledName = "_QMmod1FfooCTmytypeK2K8"; - ASSERT_EQ(actual, expectedMangledName); -} - TEST(InternalNamesTest, doVariableTest) { std::string actual = NameUniquer::doVariable( - {"mod1", "mod2"}, {""}, "intvar"); // Function is present and is blank. + {"mod1", "mod2"}, {""}, 0, "intvar"); // Function is present and is blank. std::string expectedMangledName = "_QMmod1Smod2FEintvar"; ASSERT_EQ(actual, expectedMangledName); std::string actual2 = NameUniquer::doVariable( - {"mod1", "mod2"}, {}, "intVariable"); // Function is not present. + {"mod1", "mod2"}, {}, 0, "intVariable"); // Function is not present. std::string expectedMangledName2 = "_QMmod1Smod2Eintvariable"; ASSERT_EQ(actual2, expectedMangledName2); } @@ -165,15 +149,15 @@ TEST(InternalNamesTest, doNamelistGroup) { std::string actual = NameUniquer::doNamelistGroup({"mod1"}, {}, "nlg"); - std::string expectedMangledName = "_QMmod1Gnlg"; + std::string expectedMangledName = "_QMmod1Nnlg"; ASSERT_EQ(actual, expectedMangledName); } TEST(InternalNamesTest, deconstructTest) { - std::pair actual = NameUniquer::deconstruct("_QBhello"); + std::pair actual = NameUniquer::deconstruct("_QChello"); auto expectedNameKind = NameUniquer::NameKind::COMMON; struct DeconstructedName expectedComponents { - {}, {}, "hello", {} + {}, {}, 0, "hello", {} }; validateDeconstructedName(actual, expectedNameKind, expectedComponents); } @@ -183,42 +167,42 @@ std::pair actual = NameUniquer::deconstruct("_QMmodSs1modSs2modFsubPfun"); auto expectedNameKind = NameKind::PROCEDURE; struct DeconstructedName expectedComponents = { - {"mod", "s1mod", "s2mod"}, {"sub"}, "fun", {}}; + {"mod", "s1mod", "s2mod"}, {"sub"}, 0, "fun", {}}; validateDeconstructedName(actual, expectedNameKind, expectedComponents); actual = NameUniquer::deconstruct("_QPsub"); expectedNameKind = NameKind::PROCEDURE; - expectedComponents = {{}, {}, "sub", {}}; + expectedComponents = {{}, {}, 0, "sub", {}}; validateDeconstructedName(actual, expectedNameKind, expectedComponents); - actual = NameUniquer::deconstruct("_QBvariables"); + actual = NameUniquer::deconstruct("_QCvariables"); expectedNameKind = NameKind::COMMON; - expectedComponents = {{}, {}, "variables", {}}; + expectedComponents = {{}, {}, 0, "variables", {}}; validateDeconstructedName(actual, expectedNameKind, expectedComponents); actual = NameUniquer::deconstruct("_QMmodEintvar"); expectedNameKind = NameKind::VARIABLE; - expectedComponents = {{"mod"}, {}, "intvar", {}}; + expectedComponents = {{"mod"}, {}, 0, "intvar", {}}; validateDeconstructedName(actual, expectedNameKind, expectedComponents); actual = NameUniquer::deconstruct("_QMmodECpi"); expectedNameKind = NameKind::CONSTANT; - expectedComponents = {{"mod"}, {}, "pi", {}}; + expectedComponents = {{"mod"}, {}, 0, "pi", {}}; validateDeconstructedName(actual, expectedNameKind, expectedComponents); actual = NameUniquer::deconstruct("_QTyourtypeK4KN6"); expectedNameKind = NameKind::DERIVED_TYPE; - expectedComponents = {{}, {}, "yourtype", {4, -6}}; + expectedComponents = {{}, {}, 0, "yourtype", {4, -6}}; validateDeconstructedName(actual, expectedNameKind, expectedComponents); actual = NameUniquer::deconstruct("_QDTt"); expectedNameKind = NameKind::DISPATCH_TABLE; - expectedComponents = {{}, {}, "t", {}}; + expectedComponents = {{}, {}, 0, "t", {}}; validateDeconstructedName(actual, expectedNameKind, expectedComponents); - actual = NameUniquer::deconstruct("_QFmstartGmpitop"); + actual = NameUniquer::deconstruct("_QFmstartNmpitop"); expectedNameKind = NameKind::NAMELIST_GROUP; - expectedComponents = {{}, {"mstart"}, "mpitop", {}}; + expectedComponents = {{}, {"mstart"}, 0, "mpitop", {}}; validateDeconstructedName(actual, expectedNameKind, expectedComponents); } @@ -230,10 +214,10 @@ ASSERT_FALSE(NameUniquer::needExternalNameMangling("_QDTmytypeK2K8K18")); ASSERT_FALSE(NameUniquer::needExternalNameMangling("exit_")); ASSERT_FALSE(NameUniquer::needExternalNameMangling("_QFfooEx")); - ASSERT_FALSE(NameUniquer::needExternalNameMangling("_QFmstartGmpitop")); + ASSERT_FALSE(NameUniquer::needExternalNameMangling("_QFmstartNmpitop")); ASSERT_TRUE(NameUniquer::needExternalNameMangling("_QPfoo")); ASSERT_TRUE(NameUniquer::needExternalNameMangling("_QPbar")); - ASSERT_TRUE(NameUniquer::needExternalNameMangling("_QBa")); + ASSERT_TRUE(NameUniquer::needExternalNameMangling("_QCa")); } TEST(InternalNamesTest, isExternalFacingUniquedName) { @@ -252,7 +236,7 @@ ASSERT_TRUE(NameUniquer::isExternalFacingUniquedName(result)); result = NameUniquer::deconstruct("_QPbar"); ASSERT_TRUE(NameUniquer::isExternalFacingUniquedName(result)); - result = NameUniquer::deconstruct("_QBa"); + result = NameUniquer::deconstruct("_QCa"); ASSERT_TRUE(NameUniquer::isExternalFacingUniquedName(result)); }