+<!--===- docs/Aliasing.md
+
+ Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+ See https://llvm.org/LICENSE.txt for license information.
+ SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+
+-->
+
# Bijective Internal Name Uniquing
```eval_rst
: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:
```
_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:
The uniqued name in case of `blank common block` becomes:
```
- _QB
+ _QC
```
## Module scope global data
_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
_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.
class FirOpBuilder;
} // namespace fir
-namespace fir {
-class KindMapping;
-class FirOpBuilder;
-} // namespace fir
-
namespace Fortran {
namespace common {
template <typename>
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;
assert(!empty());
stack.pop_back();
if (empty()) {
- stmtCtx.finalize();
+ stmtCtx.finalizeAndReset();
vmap.clear();
}
}
const ExplicitIterSpace &);
/// Finalize the current body statement context.
- void finalizeContext() { stmtCtx.finalize(); }
+ void finalizeContext() { stmtCtx.finalizeAndReset(); }
void appendLoops(const llvm::SmallVector<fir::DoLoopOp> &loops) {
loopStack.push_back(loops);
}
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<Fortran::semantics::Scope *, std::int64_t>;
+
+/// 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);
/// from EvaluationTuple type (std::tuple<A, B, ...>).
using EvaluationVariant = MakeReferenceVariant<EvaluationTuple>;
-/// 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 {
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;
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
};
LabelEvalMap labelEvaluationMap;
SymbolLabelMap assignSymbolLabelMap;
std::list<FunctionLikeUnit> nestedFunctions;
- /// <Symbol, Evaluation> pairs for each entry point. The pair at index 0
+ /// <Symbol, Evaluation> 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<std::pair<const semantics::Symbol *, Evaluation *>, 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)
///
/// 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<pft::Program>
createPFT(const parser::Program &root,
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) {
}
}
- /// 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:
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<std::string> modules,
- std::optional<std::string> host, llvm::StringRef name,
- llvm::ArrayRef<std::int64_t> kinds)
- : modules{modules.begin(), modules.end()}, host{host}, name{name},
- kinds{kinds.begin(), kinds.end()} {}
+ llvm::ArrayRef<std::string> procs, std::int64_t blockId,
+ llvm::StringRef name, llvm::ArrayRef<std::int64_t> kinds)
+ : modules{modules.begin(), modules.end()}, procs{procs.begin(),
+ procs.end()},
+ blockId{blockId}, name{name}, kinds{kinds.begin(), kinds.end()} {}
llvm::SmallVector<std::string> modules;
- std::optional<std::string> host;
+ llvm::SmallVector<std::string> procs;
+ std::int64_t blockId;
std::string name;
llvm::SmallVector<std::int64_t> kinds;
};
/// 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<llvm::StringRef> modules,
- std::optional<llvm::StringRef> host,
- llvm::StringRef name);
+ llvm::ArrayRef<llvm::StringRef> procs,
+ std::int64_t block, llvm::StringRef name);
/// Unique a dispatch table name
static std::string doDispatchTable(llvm::ArrayRef<llvm::StringRef> modules,
- std::optional<llvm::StringRef> host,
- llvm::StringRef name,
+ llvm::ArrayRef<llvm::StringRef> procs,
+ std::int64_t block, llvm::StringRef name,
llvm::ArrayRef<std::int64_t> kinds);
/// Unique a compiler generated name
/// Unique an intrinsic type descriptor
static std::string
doIntrinsicTypeDescriptor(llvm::ArrayRef<llvm::StringRef> modules,
- std::optional<llvm::StringRef> host,
- IntrinsicType type, std::int64_t kind);
+ llvm::ArrayRef<llvm::StringRef> procs,
+ std::int64_t block, IntrinsicType type,
+ std::int64_t kind);
/// Unique a procedure name
static std::string doProcedure(llvm::ArrayRef<llvm::StringRef> modules,
- std::optional<llvm::StringRef> host,
+ llvm::ArrayRef<llvm::StringRef> procs,
llvm::StringRef name);
/// Unique a derived type name
static std::string doType(llvm::ArrayRef<llvm::StringRef> modules,
- std::optional<llvm::StringRef> host,
- llvm::StringRef name,
+ llvm::ArrayRef<llvm::StringRef> procs,
+ std::int64_t block, llvm::StringRef name,
llvm::ArrayRef<std::int64_t> kinds);
/// Unique a (derived) type descriptor name
static std::string doTypeDescriptor(llvm::ArrayRef<llvm::StringRef> modules,
- std::optional<llvm::StringRef> host,
- llvm::StringRef name,
+ llvm::ArrayRef<llvm::StringRef> procs,
+ std::int64_t block, llvm::StringRef name,
llvm::ArrayRef<std::int64_t> kinds);
static std::string doTypeDescriptor(llvm::ArrayRef<std::string> modules,
- std::optional<std::string> host,
- llvm::StringRef name,
+ llvm::ArrayRef<std::string> procs,
+ std::int64_t block, llvm::StringRef name,
llvm::ArrayRef<std::int64_t> 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<llvm::StringRef> modules,
- std::optional<llvm::StringRef> host,
- llvm::StringRef name);
+ llvm::ArrayRef<llvm::StringRef> procs,
+ std::int64_t block, llvm::StringRef name);
/// Unique a namelist group name
static std::string doNamelistGroup(llvm::ArrayRef<llvm::StringRef> modules,
- std::optional<llvm::StringRef> host,
+ llvm::ArrayRef<llvm::StringRef> procs,
llvm::StringRef name);
/// Entry point for the PROGRAM (called by the runtime)
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
};
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);
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)
for (const Fortran::semantics::SymbolRef &binding : bindings) {
const auto *details =
binding.get().detailsIf<Fortran::semantics::ProcBindingDetails>();
- std::string bindingName =
- Fortran::lower::mangle::mangleName(details->symbol());
+ std::string bindingName = converter.mangleName(details->symbol());
builder.create<fir::DTEntryOp>(
info.loc,
mlir::StringAttr::get(builder.getContext(),
Fortran::lower::StatementContext stmtCtx;
Fortran::lower::createSomeArrayAssignment(*this, lhs, rhs, localSymbols,
stmtCtx);
- stmtCtx.finalize();
+ stmtCtx.finalizeAndReset();
} else if (hexv.getBoxOf<fir::CharBoxValue>()) {
fir::factory::CharacterExprHelper{*builder, loc}.createAssign(lhs, rhs);
} else if (hexv.getBoxOf<fir::MutableBoxValue>()) {
}
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<Fortran::parser::BlockConstruct>())
+ return activeConstructStack.back().stmtCtx;
return bridge.fctCtx();
}
void registerDispatchTableInfo(
mlir::Location loc,
const Fortran::semantics::DerivedTypeSpec *typeSpec) override final {
- dispatchTableConverter.registerTypeSpec(loc, typeSpec);
+ dispatchTableConverter.registerTypeSpec(*this, loc, typeSpec);
}
private:
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);
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<mlir::cf::BranchOp>(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();
builder->create<mlir::cf::CondBranchOp>(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<int64_t> valueList,
+ llvm::SmallVector<Fortran::parser::Label> 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<mlir::Block *> 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<fir::SelectOp>(loc, selector, valueList, blockList);
+ return;
+ }
+ mlir::Type selectorType = selector.getType();
+ bool realSelector = selectorType.isa<mlir::FloatType>();
+ assert((inArithmeticIfContext || !realSelector) && "invalid selector type");
+ mlir::Value zero;
+ if (inArithmeticIfContext)
+ zero =
+ realSelector
+ ? builder->create<mlir::arith::ConstantOp>(
+ loc, selectorType, builder->getFloatAttr(selectorType, 0.0))
+ : builder->createIntegerConstant(loc, selectorType, 0);
+ for (auto label : llvm::enumerate(labelList)) {
+ mlir::Value cond;
+ if (realSelector) // inArithmeticIfContext
+ cond = builder->create<mlir::arith::CmpFOp>(
+ loc,
+ label.index() == 0 ? mlir::arith::CmpFPredicate::OLT
+ : mlir::arith::CmpFPredicate::OGT,
+ selector, zero);
+ else if (inArithmeticIfContext)
+ cond = builder->create<mlir::arith::CmpIOp>(
+ loc,
+ label.index() == 0 ? mlir::arith::CmpIPredicate::slt
+ : mlir::arith::CmpIPredicate::sgt,
+ selector, zero);
+ else
+ cond = builder->create<mlir::arith::CmpIOp>(
+ 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();
}
//===--------------------------------------------------------------------===//
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<fir::LoadOp>(loc, resultRef);
Fortran::semantics::GetExpr(
std::get<Fortran::parser::ScalarLogicalExpr>(stmt->t)),
stmtCtx);
- stmtCtx.finalize();
+ stmtCtx.finalizeAndReset();
mlir::Value cond =
builder->createConvert(loc, builder->getI1Type(), condExpr);
if (negate)
*this, *stmt.typedCall, explicitIterSpace, implicitIterSpace,
localSymbols, stmtCtx, /*isUserDefAssignment=*/false);
}
+ stmtCtx.finalizeAndReset();
if (!res)
return; // "Normal" subroutine call.
// Call with alternate return specifiers.
// The call returns an index that selects an alternate return branch target.
llvm::SmallVector<int64_t> indexList;
- llvm::SmallVector<mlir::Block *> blockList;
+ llvm::SmallVector<Fortran::parser::Label> labelList;
int64_t index = 0;
for (const Fortran::parser::ActualArgSpec &arg :
std::get<std::list<Fortran::parser::ActualArgSpec>>(stmt.v.t)) {
if (const auto *altReturn =
std::get_if<Fortran::parser::AltReturnSpec>(&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<fir::SelectOp>(toLocation(), res, indexList, blockList);
+ genMultiwayBranch(res, indexList, labelList, eval.nonNopSuccessor());
}
void genFIR(const Fortran::parser::ComputedGotoStmt &stmt) {
Fortran::semantics::GetExpr(
std::get<Fortran::parser::ScalarIntExpr>(stmt.t)),
stmtCtx);
- stmtCtx.finalize();
+ stmtCtx.finalizeAndReset();
llvm::SmallVector<int64_t> indexList;
- llvm::SmallVector<mlir::Block *> blockList;
+ llvm::SmallVector<Fortran::parser::Label> labelList;
int64_t index = 0;
for (Fortran::parser::Label label :
std::get<std::list<Fortran::parser::Label>>(stmt.t)) {
indexList.push_back(++index);
- blockList.push_back(blockOfLabel(eval, label));
+ labelList.push_back(label);
}
- blockList.push_back(eval.nonNopSuccessor().block); // default
- builder->create<fir::SelectOp>(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<Fortran::parser::Expr>(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<mlir::Attribute> attrList;
- llvm::SmallVector<mlir::Value> valueList;
- llvm::SmallVector<mlir::Block *> 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<fir::SelectCaseOp>(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<mlir::arith::AddFOp>(loc, expr, expr);
- auto zero = builder->create<mlir::arith::ConstantOp>(
- loc, exprType, builder->getFloatAttr(exprType, 0.0));
- auto cond1 = builder->create<mlir::arith::CmpFOp>(
- 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<mlir::arith::CmpFOp>(
- 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<mlir::FloatType>())
+ expr = builder->create<mlir::arith::AddFOp>(toLocation(), expr, expr);
+ llvm::SmallVector<int64_t> valueList;
+ llvm::SmallVector<Fortran::parser::Label> labelList;
+ labelList.push_back(std::get<1>(stmt.t));
+ labelList.push_back(std::get<3>(stmt.t));
+ const Fortran::lower::pft::LabelEvalMap &labelEvaluationMap =
+ getEval().getOwningProcedure()->labelEvaluationMap;
+ const auto iter = labelEvaluationMap.find(std::get<2>(stmt.t));
+ assert(iter != labelEvaluationMap.end() && "label missing from map");
+ genMultiwayBranch(expr, valueList, labelList, *iter->second);
}
void genFIR(const Fortran::parser::AssignedGotoStmt &stmt) {
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<int64_t> indexList;
- llvm::SmallVector<mlir::Block *> 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<int64_t> valueList;
+ llvm::SmallVector<Fortran::parser::Label> labelList;
+ // Add labels from an explicit list. The list may have duplicates.
for (Fortran::parser::Label label :
std::get<std::list<Fortran::parser::Label>>(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<fir::SelectOp>(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.
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
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<Fortran::parser::LoopControl::Bounds>(
&loopControl->u)) {
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.
}
}
- // 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);
// Loop end code.
if (infiniteLoop || whileCondition)
- genFIRBranch(headerBlock);
+ genBranch(headerBlock);
else
genFIRIncrementLoopEnd(incrementLoopNestInfo);
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<fir::IfOp>(loc, maskCondCast,
builder->create<mlir::arith::DivFOp>(loc, diff2, info.stepValue);
tripCount =
builder->createConvert(loc, builder->getIndexType(), tripCount);
-
} else {
auto diff1 =
builder->create<mlir::arith::SubIOp>(loc, upperValue, lowerValue);
auto cond = builder->create<mlir::arith::CmpIOp>(
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
}
builder->create<mlir::arith::AddIOp>(loc, value, info.stepValue);
builder->create<fir::StoreOp>(loc, value, info.loopVariable);
- genFIRBranch(info.headerBlock);
+ genBranch(info.headerBlock);
if (&info != &incrementLoopNestInfo.front()) // not outermost
startBlock(info.exitBlock); // latch block of enclosing dimension
}
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<Fortran::parser::IfThenStmt>()) {
maybeStartBlock(e.block);
}
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 <typename A>
}
/// 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<Fortran::parser::Scalar<Fortran::parser::Expr>>(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(
llvm::SmallVector<mlir::Attribute> attrList;
llvm::SmallVector<mlir::Value> valueList;
llvm::SmallVector<mlir::Block *> blockList;
- mlir::Block *defaultBlock = eval.parentConstruct->constructExit->block;
+ mlir::Block *defaultBlock = parentConstruct->constructExit->block;
using CaseValue = Fortran::parser::Scalar<Fortran::parser::ConstantExpr>;
auto addValue = [&](const CaseValue &caseValue) {
const Fortran::lower::SomeExpr *expr =
}
// 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<fir::SelectCaseOp>(loc, selector, attrList, valueList,
blockList);
return;
// 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<mlir::UnitAttr>()) {
- if (attrList.size() == 1)
- stmtCtx.finalize();
- genFIRBranch(*caseBlock++);
+ for (mlir::Attribute attr : attrList) {
+ if (attr.isa<mlir::UnitAttr>()) {
+ genBranch(*caseBlock++);
break;
}
auto genCond = [&](mlir::Value rhs,
fir::factory::CharacterExprHelper charHelper{*builder, loc};
std::pair<mlir::Value, mlir::Value> lhsVal =
charHelper.createUnboxChar(selector);
- mlir::Value &lhsAddr = lhsVal.first;
- mlir::Value &lhsLen = lhsVal.second;
std::pair<mlir::Value, mlir::Value> 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<fir::IfOp>(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<fir::ClosedIntervalAttr>()) {
+ if (attr.isa<fir::ClosedIntervalAttr>()) {
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<fir::PointIntervalAttr>()) {
+ if (attr.isa<fir::PointIntervalAttr>()) {
pred = mlir::arith::CmpIPredicate::eq;
- } else if (attr.value().isa<fir::LowerBoundAttr>()) {
+ } else if (attr.isa<fir::LowerBoundAttr>()) {
pred = mlir::arith::CmpIPredicate::sge;
} else {
- assert(attr.value().isa<fir::UpperBoundAttr>() &&
- "unexpected predicate");
+ assert(attr.isa<fir::UpperBoundAttr>() && "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
}
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<Fortran::parser::AssociateStmt>()) {
if (eval.lowerAsUnstructured())
} else if (e.getIf<Fortran::parser::EndAssociateStmt>()) {
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<Fortran::parser::BlockStmt>()) {
+ 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<fir::CallOp>(toLocation(), stackSave).getResult(0);
+ mlir::Location endLoc = genLocation(endPosition);
+ stmtCtx.attachCleanup([=]() {
+ builder->create<fir::CallOp>(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<Fortran::parser::EndBlockStmt>()) {
+ if (eval.lowerAsUnstructured())
+ maybeStartBlock(e.block);
+ setCurrentPosition(e.position);
+ localSymbols.popScope();
+ } else {
+ genFIR(e);
+ }
+ }
+ popActiveConstruct();
}
void genFIR(const Fortran::parser::ChangeTeamConstruct &construct) {
typeCaseScopes.push_back(&scope);
}
+ pushActiveConstruct(getEval(), stmtCtx);
for (Fortran::lower::pft::Evaluation &eval :
getEval().getNestedEvaluations()) {
if (auto *selectTypeStmt =
genFIR(eval);
if (hasLocalScope)
localSymbols.popScope();
- stmtCtx.finalize();
} else {
genFIR(eval);
}
}
+ popActiveConstruct();
}
//===--------------------------------------------------------------------===//
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<int64_t> indexList;
- llvm::SmallVector<mlir::Block *> blockList;
- if (eorBlock) {
+ llvm::SmallVector<Fortran::parser::Label> 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<fir::SelectOp>(loc, selector, indexList, blockList);
+ genMultiwayBranch(selector, indexList, labelList, eval.nonNopSuccessor(),
+ /*inIoErrContext=*/errLabel != Fortran::parser::Label{});
}
//===--------------------------------------------------------------------===//
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);
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();
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)) {
}
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.
// 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
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);
}
}
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);
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<Fortran::lower::pft::Evaluation> &evaluationList) {
// 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);
builder = nullptr;
hostAssocTuple = mlir::Value{};
localSymbols.clear();
+ blockId = 0;
}
/// Helper to generate GlobalOps when the builder is not positioned in any
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<ConstructContext> 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;
};
//===----------------------------------------------------------------------===//
// 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) {
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();
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 *
}
//===----------------------------------------------------------------------===//
-// 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,
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);
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<fir::SequenceType>() && sym.Rank() == 1 &&
!Fortran::semantics::IsAllocatableOrPointer(sym)) {
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);
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();
/// 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.
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();
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.
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;
llvm::SmallVector<mlir::Value> 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<hlfir::DeclareOp>(
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);
}
/// 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,
}
// 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 = [&]() {
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;
}
} 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);
}
}
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
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);
} // 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 {
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;
}
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,
/// 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,
// 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;
/// 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,
llvm::SmallVector<mlir::Value> inputFuncArgs = {cookie};
if (argType.isa<fir::BaseBoxType>()) {
mlir::Value box = fir::getBase(item);
- assert(box.getType().isa<fir::BaseBoxType>() && "must be previously emboxed");
+ assert(box.getType().isa<fir::BaseBoxType>() &&
+ "must be previously emboxed");
inputFuncArgs.push_back(builder.createConvert(loc, argType, box));
} else {
mlir::Value itemAddr = fir::getBase(item);
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<mlir::Value, mlir::Value, mlir::Value>
genFormat(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
}
// Generate end statement call/s.
mlir::Value result = genEndIO(converter, loc, cookie, csi, stmtCtx);
- stmtCtx.finalize();
+ stmtCtx.finalizeAndReset();
return result;
}
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();
#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 <optional>
-
-// recursively build the vector of module scopes
-static void moduleNames(const Fortran::semantics::Scope &scope,
- llvm::SmallVector<llvm::StringRef> &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<llvm::StringRef>
-moduleNames(const Fortran::semantics::Symbol &symbol) {
- const Fortran::semantics::Scope &scope = symbol.owner();
- llvm::SmallVector<llvm::StringRef> result;
- moduleNames(scope, result);
- return result;
-}
-static std::optional<llvm::StringRef>
-hostName(const Fortran::semantics::Symbol &symbol) {
- const Fortran::semantics::Scope *scope = &symbol.owner();
- if (symbol.has<Fortran::semantics::AssocEntityDetails>())
- // 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<llvm::StringRef>,
+ llvm::SmallVector<llvm::StringRef>, std::int64_t>
+ancestors(const Fortran::semantics::Symbol &symbol,
+ Fortran::lower::mangle::ScopeBlockIdMap &scopeBlockIdMap) {
+ llvm::SmallVector<const Fortran::semantics::Scope *> scopes;
+ for (auto *scp = &symbol.owner(); !scp->IsGlobal(); scp = &scp->parent())
+ scopes.push_back(scp);
+ llvm::SmallVector<llvm::StringRef> modules;
+ llvm::SmallVector<llvm::StringRef> 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<llvm::StringRef> modules;
+ llvm::SmallVector<llvm::StringRef> procs;
+ std::int64_t blockId;
+
// mangle ObjectEntityDetails or AssocEntityDetails symbols.
auto mangleObject = [&]() -> std::string {
- llvm::SmallVector<llvm::StringRef> modNames = moduleNames(ultimateSymbol);
- std::optional<llvm::StringRef> 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(
interface->owner().IsSubmodule() && !subpDetails.isInterface())
interface = subpDetails.moduleInterface();
assert(interface && "Separate module procedure must be declared");
- llvm::SmallVector<llvm::StringRef> 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);
},
return mangleObject();
},
[&](const Fortran::semantics::NamelistDetails &) {
- llvm::SmallVector<llvm::StringRef> modNames =
- moduleNames(ultimateSymbol);
- std::optional<llvm::StringRef> 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<llvm::StringRef> modNames = moduleNames(ultimateSymbol);
- std::optional<llvm::StringRef> optHost = hostName(ultimateSymbol);
+ llvm::SmallVector<llvm::StringRef> modules;
+ llvm::SmallVector<llvm::StringRef> procs;
+ std::int64_t blockId;
+ std::tie(modules, procs, blockId) =
+ ancestors(ultimateSymbol, scopeBlockIdMap);
llvm::SmallVector<std::int64_t> kinds;
for (const auto ¶m :
Fortran::semantics::OrderParameterDeclarations(ultimateSymbol)) {
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) {
#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:
/// first statement of the construct.
void convertIfStmt(const parser::IfStmt &ifStmt, parser::CharBlock position,
std::optional<parser::Label> 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<parser::IfThenStmt>{
}
/// 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:
///
/// <<IfConstruct>>
/// <<End IfConstruct>>
/// 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() {
},
[&](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);
},
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<lower::pft::FunctionLikeUnit> *functionList{};
std::vector<lower::pft::Evaluation *> constructAndDirectiveStack{};
std::vector<lower::pft::Evaluation *> doConstructStack{};
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())
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{
(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();
inline std::string prefix() { return "_Q"; }
-static std::string doModules(llvm::ArrayRef<llvm::StringRef> 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<llvm::StringRef> modules,
+ llvm::ArrayRef<llvm::StringRef> 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<llvm::StringRef> mods,
- std::optional<llvm::StringRef> 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<llvm::StringRef>
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<llvm::StringRef> modules,
- std::optional<llvm::StringRef> host,
- llvm::StringRef name) {
+ llvm::ArrayRef<llvm::StringRef> 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<llvm::StringRef> modules,
- std::optional<llvm::StringRef> host,
- llvm::StringRef name,
+ llvm::ArrayRef<llvm::StringRef> procs,
+ std::int64_t blockId, llvm::StringRef name,
llvm::ArrayRef<std::int64_t> 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));
}
std::string fir::NameUniquer::doIntrinsicTypeDescriptor(
llvm::ArrayRef<llvm::StringRef> modules,
- std::optional<llvm::StringRef> host, IntrinsicType type,
- std::int64_t kind) {
+ llvm::ArrayRef<llvm::StringRef> procs, std::int64_t blockId,
+ IntrinsicType type, std::int64_t kind) {
const char *name = nullptr;
switch (type) {
case IntrinsicType::CHARACTER:
}
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<llvm::StringRef> modules,
- std::optional<llvm::StringRef> host,
+ llvm::ArrayRef<llvm::StringRef> 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<llvm::StringRef> modules,
- std::optional<llvm::StringRef> host,
- llvm::StringRef name,
+ llvm::ArrayRef<llvm::StringRef> procs,
+ std::int64_t blockId, llvm::StringRef name,
llvm::ArrayRef<std::int64_t> 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<llvm::StringRef> modules,
- std::optional<llvm::StringRef> host,
- llvm::StringRef name,
+ llvm::ArrayRef<llvm::StringRef> procs,
+ std::int64_t blockId, llvm::StringRef name,
llvm::ArrayRef<std::int64_t> 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<std::string> modules, std::optional<std::string> host,
- llvm::StringRef name, llvm::ArrayRef<std::int64_t> kinds) {
+std::string
+fir::NameUniquer::doTypeDescriptor(llvm::ArrayRef<std::string> modules,
+ llvm::ArrayRef<std::string> procs,
+ std::int64_t blockId, llvm::StringRef name,
+ llvm::ArrayRef<std::int64_t> 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<llvm::StringRef> modules,
- std::optional<llvm::StringRef> host,
- llvm::StringRef name) {
+ llvm::ArrayRef<llvm::StringRef> 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<llvm::StringRef> modules,
- std::optional<llvm::StringRef> host,
+ llvm::ArrayRef<llvm::StringRef> 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));
}
fir::NameUniquer::deconstruct(llvm::StringRef uniq) {
if (uniq.startswith("_Q")) {
llvm::SmallVector<std::string> modules;
- std::optional<std::string> host;
+ llvm::SmallVector<std::string> procs;
+ std::int64_t blockId = 0;
std::string name;
llvm::SmallVector<std::int64_t> 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)};
}
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) {
llvm::SmallVector<llvm::StringRef> modules;
for (const std::string &mod : result.second.modules)
modules.push_back(mod);
- std::optional<llvm::StringRef> host;
- if (result.second.host)
- host = *result.second.host;
- return fir::NameUniquer::doVariable(modules, host, varName);
+ llvm::SmallVector<llvm::StringRef> 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
func.func @_QPfoo() {
%c0 = arith.constant 0 : index
- %0 = fir.address_of(@_QBa) : !fir.ref<!fir.array<4xi8>>
+ %0 = fir.address_of(@_QCa) : !fir.ref<!fir.array<4xi8>>
%1 = fir.convert %0 : (!fir.ref<!fir.array<4xi8>>) -> !fir.ref<!fir.array<?xi8>>
%2 = fir.coordinate_of %1, %c0 : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8>
%3 = fir.convert %2 : (!fir.ref<i8>) -> !fir.ref<i32>
- %4 = fir.address_of(@_QB) : !fir.ref<!fir.array<4xi8>>
+ %4 = fir.address_of(@_QC) : !fir.ref<!fir.array<4xi8>>
%5 = fir.convert %4 : (!fir.ref<!fir.array<4xi8>>) -> !fir.ref<!fir.array<?xi8>>
%6 = fir.coordinate_of %5, %c0 : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8>
%7 = fir.convert %6 : (!fir.ref<i8>) -> !fir.ref<f32>
fir.call @_QPbar2(%7) : (!fir.ref<f32>) -> ()
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<i32>)
func.func private @_QPbar2(!fir.ref<f32>)
! 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<?xf32>, %[[VAL_11]] {fir.must_be_heap = true, uniq_name = "_QEa.alloc"}
+! CHECK: %[[VAL_12:.*]] = fir.allocmem !fir.array<?xf32>, %[[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.array<?xf32>>, !fir.shape<1>) -> !fir.box<!fir.heap<!fir.array<?xf32>>>
! CHECK: fir.store %[[VAL_14]] to %[[VAL_6]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>
! 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<!fir.char<1,?>>, i32) -> (!fir.boxchar<1>, !fir.ref<!fir.char<1,?>>)
+! CHECK: %[[VAL_18:.*]]:2 = hlfir.declare %[[VAL_13]]#0 typeparams %[[VAL_17]] {uniq_name = "_QFchar_testFstmt_funcEchar_stmt_func_dummy_arg"} : (!fir.ref<!fir.char<1,?>>, i32) -> (!fir.boxchar<1>, !fir.ref<!fir.char<1,?>>)
! 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<!fir.char<1,10>>
!$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<!fir.array<103xi8>>
+!CHECK: [[ADDR0:%.*]] = fir.address_of(@_QCblk) : !fir.ref<!fir.array<103xi8>>
!CHECK: [[NEWADDR0:%.*]] = omp.threadprivate [[ADDR0]] : !fir.ref<!fir.array<103xi8>> -> !fir.ref<!fir.array<103xi8>>
!CHECK-DAG: [[ADDR1:%.*]] = fir.convert [[NEWADDR0]] : (!fir.ref<!fir.array<103xi8>>) -> !fir.ref<!fir.array<?xi8>>
!CHECK-DAG: [[C0:%.*]] = arith.constant 0 : index
!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
contains
subroutine sub()
! CHECK-LABEL: @_QMtestPsub
-!CHECK-DAG: [[ADDR0:%.*]] = fir.address_of(@_QBblk) : !fir.ref<!fir.array<24xi8>>
+!CHECK-DAG: [[ADDR0:%.*]] = fir.address_of(@_QCblk) : !fir.ref<!fir.array<24xi8>>
!CHECK-DAG: [[NEWADDR0:%.*]] = omp.threadprivate [[ADDR0]] : !fir.ref<!fir.array<24xi8>> -> !fir.ref<!fir.array<24xi8>>
!CHECK-DAG: [[ADDR1:%.*]] = fir.address_of(@_QMtestEy) : !fir.ref<f32>
!CHECK-DAG: [[NEWADDR1:%.*]] = omp.threadprivate [[ADDR1]] : !fir.ref<f32> -> !fir.ref<f32>
call sub()
! CHECK-LABEL: @_QQmain()
-!CHECK-DAG: [[ADDR0:%.*]] = fir.address_of(@_QBblk) : !fir.ref<!fir.array<24xi8>>
+!CHECK-DAG: [[ADDR0:%.*]] = fir.address_of(@_QCblk) : !fir.ref<!fir.array<24xi8>>
!CHECK-DAG: [[NEWADDR0:%.*]] = omp.threadprivate [[ADDR0]] : !fir.ref<!fir.array<24xi8>> -> !fir.ref<!fir.array<24xi8>>
-!CHECK-DAG: [[ADDR1:%.*]] = fir.address_of(@_QBblk) : !fir.ref<!fir.array<24xi8>>
+!CHECK-DAG: [[ADDR1:%.*]] = fir.address_of(@_QCblk) : !fir.ref<!fir.array<24xi8>>
!CHECK-DAG: [[NEWADDR1:%.*]] = omp.threadprivate [[ADDR1]] : !fir.ref<!fir.array<24xi8>> -> !fir.ref<!fir.array<24xi8>>
!CHECK-DAG: [[ADDR2:%.*]] = fir.address_of(@_QMtestEy) : !fir.ref<f32>
!CHECK-DAG: [[NEWADDR2:%.*]] = omp.threadprivate [[ADDR2]] : !fir.ref<f32> -> !fir.ref<f32>
! 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<i32>
+ ! 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<i32>
+ ! CHECK: cf.br ^bb5
+ ! CHECK: ^bb3: // pred: ^bb1
+ ! CHECK: fir.store %c2{{.*}} to %[[V_0]] : !fir.ref<i32>
+ ! CHECK: cf.br ^bb5
+ ! CHECK: ^bb4: // pred: ^bb1
+ ! CHECK: fir.store %c3{{.*}} to %[[V_0]] : !fir.ref<i32>
+ ! CHECK: cf.br ^bb5
+ ! CHECK: ^bb5: // 3 preds: ^bb2, ^bb3, ^bb4
+ ! CHECK: %[[V_4:[0-9]+]] = fir.load %[[V_0]] : !fir.ref<i32>
+ ! CHECK: return %[[V_4]] : i32
if (index) 7, 8, 9
kagi = 0; return
7 kagi = 1; return
! 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<f32>
+ ! CHECK: %[[V_2:[0-9]+]] = fir.load %arg0 : !fir.ref<f32>
+ ! 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<i32>
+ ! CHECK: cf.br ^bb5
+ ! CHECK: ^bb3: // pred: ^bb1
+ ! CHECK: fir.store %c2{{.*}} to %[[V_0]] : !fir.ref<i32>
+ ! CHECK: cf.br ^bb5
+ ! CHECK: ^bb4: // pred: ^bb1
+ ! CHECK: fir.store %c3{{.*}} to %[[V_0]] : !fir.ref<i32>
+ ! CHECK: cf.br ^bb5
+ ! CHECK: ^bb5: // 3 preds: ^bb2, ^bb3, ^bb4
+ ! CHECK: %[[V_7:[0-9]+]] = fir.load %[[V_0]] : !fir.ref<i32>
+ ! CHECK: return %[[V_7]] : i32
if (findex+findex) 7, 8, 9
kagf = 0; return
7 kagf = 1; return
! 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
--- /dev/null
+! 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<i32>
+ i = 0
+ ! CHECK: %[[V_3:[0-9]+]] = fir.call @llvm.stacksave()
+ ! CHECK: fir.store %{{.*}} to %[[V_1]] : !fir.ref<i32>
+ ! 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<i32>
+ ! CHECK: cond_br %{{.*}}, ^bb3, ^bb4
+ ! CHECK: ^bb3: // pred: ^bb2
+ ! CHECK: br ^bb10
+ ! CHECK: ^bb4: // pred: ^bb2
+ ! CHECK: fir.store %{{.*}} to %[[V_1]] : !fir.ref<i32>
+ ! CHECK: cond_br %{{.*}}, ^bb5, ^bb6
+ ! CHECK: ^bb5: // pred: ^bb4
+ ! CHECK: br ^bb7
+ ! CHECK: ^bb6: // pred: ^bb4
+ ! CHECK: fir.store %{{.*}} to %[[V_1]] : !fir.ref<i32>
+ ! 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<i32>
+ ! 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<i32>
+ ! 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<i32>
+ ! 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<i32>
+ ! CHECK: br ^bb15
+ ! CHECK: ^bb15: // 2 preds: ^bb9, ^bb14
+ ! CHECK: br ^bb1
+ ! CHECK: ^bb16: // pred: ^bb1
+ ! CHECK: fir.store %{{.*}} to %[[V_1]] : !fir.ref<i32>
+ ! 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
! - A blank common that is initialized
! - A common block that is initialized outside of a BLOCK DATA.
-! CHECK-LABEL: fir.global @_QB : tuple<i32, !fir.array<8xi8>> {
+! CHECK-LABEL: fir.global @_QC : tuple<i32, !fir.array<8xi8>> {
! CHECK: %[[undef:.*]] = fir.undefined tuple<i32, !fir.array<8xi8>>
! CHECK: %[[init:.*]] = fir.insert_value %[[undef]], %c42{{.*}}, [0 : index] : (tuple<i32, !fir.array<8xi8>>, i32) -> tuple<i32, !fir.array<8xi8>>
! CHECK: fir.has_value %[[init]] : tuple<i32, !fir.array<8xi8>>
-! CHECK-LABEL: fir.global @_QBa : tuple<i32, !fir.array<8xi8>> {
+! CHECK-LABEL: fir.global @_QCa : tuple<i32, !fir.array<8xi8>> {
! CHECK: %[[undef:.*]] = fir.undefined tuple<i32, !fir.array<8xi8>>
! CHECK: %[[init:.*]] = fir.insert_value %[[undef]], %c42{{.*}}, [0 : index] : (tuple<i32, !fir.array<8xi8>>, i32) -> tuple<i32, !fir.array<8xi8>>
! CHECK: fir.has_value %[[init]] : tuple<i32, !fir.array<8xi8>>
! 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
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
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
! 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
! 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<i32>
+ ! 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<i32>
+ ! CHECK: cf.br ^bb7
+ ! CHECK: ^bb2: // pred: ^bb0
+ ! CHECK: fir.store %c1{{.*}} to %[[V_0]] : !fir.ref<i32>
+ ! CHECK: cf.br ^bb7
+ ! CHECK: ^bb3: // pred: ^bb0
+ ! CHECK: fir.store %c3{{.*}} to %[[V_0]] : !fir.ref<i32>
+ ! CHECK: cf.br ^bb7
+ ! CHECK: ^bb4: // pred: ^bb0
+ ! CHECK: fir.store %c5{{.*}} to %[[V_0]] : !fir.ref<i32>
+ ! CHECK: cf.br ^bb7
+ ! CHECK: ^bb5: // pred: ^bb0
+ ! CHECK: fir.store %c7{{.*}} to %[[V_0]] : !fir.ref<i32>
+ ! CHECK: cf.br ^bb7
+ ! CHECK: ^bb6: // pred: ^bb0
+ ! CHECK: fir.store %c9{{.*}} to %[[V_0]] : !fir.ref<i32>
+ ! 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<i32>
+ ! 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<i32>
+ ! 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<i32>
+ ! CHECK: cf.br ^bb4
+ ! CHECK: ^bb3: // pred: ^bb1
+ ! CHECK: fir.store %c10{{.*}} to %[[V_0]] : !fir.ref<i32>
+ ! CHECK: cf.br ^bb4
+ ! CHECK: ^bb4: // 2 preds: ^bb2, ^bb3
+ ! CHECK: %[[V_4:[0-9]+]] = fir.load %[[V_0]] : !fir.ref<i32>
+ ! 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<i32>
+ ! 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<i32>
+ ! CHECK: cf.br ^bb7
+ ! CHECK: ^bb5: // pred: ^bb1
+ ! CHECK: fir.store %c10{{.*}} to %[[V_0]] : !fir.ref<i32>
+ ! CHECK: cf.br ^bb7
+ ! CHECK: ^bb6: // pred: ^bb3
+ ! CHECK: fir.store %c20{{.*}} to %[[V_0]] : !fir.ref<i32>
+ ! CHECK: cf.br ^bb7
+ ! CHECK: ^bb7: // 3 preds: ^bb4, ^bb5, ^bb6
+ ! CHECK: %[[V_5:[0-9]+]] = fir.load %[[V_0]] : !fir.ref<i32>
+ ! 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<i32>
+ ! 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<i32>
+ ! CHECK: cf.br ^bb10
+ ! CHECK: ^bb7: // pred: ^bb1
+ ! CHECK: fir.store %c10{{.*}} to %[[V_0]] : !fir.ref<i32>
+ ! CHECK: cf.br ^bb10
+ ! CHECK: ^bb8: // pred: ^bb3
+ ! CHECK: fir.store %c20{{.*}} to %[[V_0]] : !fir.ref<i32>
+ ! CHECK: cf.br ^bb10
+ ! CHECK: ^bb9: // pred: ^bb5
+ ! CHECK: fir.store %c30{{.*}} to %[[V_0]] : !fir.ref<i32>
+ ! CHECK: cf.br ^bb10
+ ! CHECK: ^bb10: // 4 preds: ^bb6, ^bb7, ^bb8, ^bb9
+ ! CHECK: %[[V_6:[0-9]+]] = fir.load %[[V_0]] : !fir.ref<i32>
+ ! 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
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<!fir.array<1064xi8>>
+ ! CHECK: %[[mcbAddr:.*]] = fir.address_of(@_QCmy_common_block) : !fir.ref<!fir.array<1064xi8>>
! CHECK: %[[mcbCast:.*]] = fir.convert %[[mcbAddr]] : (!fir.ref<!fir.array<1064xi8>>) -> !fir.ref<!fir.array<?xi8>>
! CHECK: %[[c0:.*]] = arith.constant 0 : index
! CHECK: %[[mcbCoor:.*]] = fir.coordinate_of %[[mcbCast]], %[[c0]] : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8>
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<!fir.array<4xi8>>
+! CHECK: %[[VAL_2:.*]] = fir.address_of(@_QCmycom) : !fir.ref<!fir.array<4xi8>>
! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.ref<!fir.array<4xi8>>) -> !fir.ref<!fir.array<?xi8>>
! CHECK: %[[VAL_4:.*]] = fir.coordinate_of %[[VAL_3]], %[[VAL_0]] : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8>
! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.ref<i8>) -> !fir.ref<i32>
implicit none
call takes_array(return_array())
! CHECK: %[[VAL_0:.*]] = arith.constant 0 : index
-! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QBmycom) : !fir.ref<!fir.array<4xi8>>
+! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QCmycom) : !fir.ref<!fir.array<4xi8>>
! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]] : (!fir.ref<!fir.array<4xi8>>) -> !fir.ref<!fir.array<?xi8>>
! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_0]] : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8>
! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.ref<i8>) -> !fir.ref<i32>
! 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<!fir.array<4xi8>>
+! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QCmycom) : !fir.ref<!fir.array<4xi8>>
! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]] : (!fir.ref<!fir.array<4xi8>>) -> !fir.ref<!fir.array<?xi8>>
! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_0]] : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8>
! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.ref<i8>) -> !fir.ref<i32>
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<!fir.array<4xi8>>
+! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QCmycom) : !fir.ref<!fir.array<4xi8>>
! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]] : (!fir.ref<!fir.array<4xi8>>) -> !fir.ref<!fir.array<?xi8>>
! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_0]] : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8>
! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.ref<i8>) -> !fir.ref<i32>
! CHECK-LABEL: func @_QFac1Pfunc(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.box<!fir.array<?xi32>> {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
! CHECK-LABEL: func @_QFac2Pfunc(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.box<!fir.array<?xi32>> {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.array<3xi32>>, !fir.shape<1>) -> !fir.array<3xi32>
! CHECK: %[[VAL_5:.*]] = arith.constant 1 : i64
end subroutine
end subroutine
! CHECK-LABEL: func.func @_QFtest_commonPbar() attributes {fir.internal_proc} {
-! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QBx) : !fir.ref<!fir.array<12xi8>>
+! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QCx) : !fir.ref<!fir.array<12xi8>>
! CHECK: %[[VAL_1:.*]] = fir.convert %[[VAL_0]] : (!fir.ref<!fir.array<12xi8>>) -> !fir.ref<!fir.array<?xi8>>
! CHECK: %[[VAL_2:.*]] = arith.constant 4 : index
! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_1]], %[[VAL_2]] : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8>
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<i32> {
+! CHECK-LABEL: fir.global @_QCnamed2 : tuple<i32> {
! CHECK: %[[init:.*]] = fir.insert_value %{{.*}}, %c42{{.*}}, [0 : index] : (tuple<i32>, i32) -> tuple<i32>
! CHECK: fir.has_value %[[init]] : tuple<i32>
! 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()
real function modCommon1Use()
use modCommonInit1
use modCommonNoInit1
- ! CHECK-DAG: fir.address_of(@_QBnamed2) : !fir.ref<!fir.array<4xi8>>
- ! CHECK-DAG: fir.address_of(@_QB) : !fir.ref<!fir.array<4xi8>>
- ! CHECK-DAG: fir.address_of(@_QBnamed1) : !fir.ref<!fir.array<4xi8>>
+ ! CHECK-DAG: fir.address_of(@_QCnamed2) : !fir.ref<!fir.array<4xi8>>
+ ! CHECK-DAG: fir.address_of(@_QC) : !fir.ref<!fir.array<4xi8>>
+ ! CHECK-DAG: fir.address_of(@_QCnamed1) : !fir.ref<!fir.array<4xi8>>
modCommon1Use = x_blank + x_named1 + i_named2
end function
contains
! CHECK-LABEL: func @_QMmodcommon2Pfoo()
real function foo()
- ! CHECK-DAG: fir.address_of(@_QBnamed2) : !fir.ref<tuple<i32>>
- ! CHECK-DAG: fir.address_of(@_QB) : !fir.ref<!fir.array<4xi8>>
- ! CHECK-DAG: fir.address_of(@_QBnamed1) : !fir.ref<!fir.array<40xi8>>
+ ! CHECK-DAG: fir.address_of(@_QCnamed2) : !fir.ref<tuple<i32>>
+ ! CHECK-DAG: fir.address_of(@_QC) : !fir.ref<!fir.array<4xi8>>
+ ! CHECK-DAG: fir.address_of(@_QCnamed1) : !fir.ref<!fir.array<40xi8>>
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<tuple<i32>>
- ! CHECK-DAG: fir.address_of(@_QB) : !fir.ref<!fir.array<4xi8>>
- ! CHECK-DAG: fir.address_of(@_QBnamed1) : !fir.ref<!fir.array<40xi8>>
+ ! CHECK-DAG: fir.address_of(@_QCnamed2) : !fir.ref<tuple<i32>>
+ ! CHECK-DAG: fir.address_of(@_QC) : !fir.ref<!fir.array<4xi8>>
+ ! CHECK-DAG: fir.address_of(@_QCnamed1) : !fir.ref<!fir.array<40xi8>>
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<tuple<i32>>
- ! CHECK-DAG: fir.address_of(@_QB) : !fir.ref<!fir.array<4xi8>>
- ! CHECK-DAG: fir.address_of(@_QBnamed1) : !fir.ref<!fir.array<40xi8>>
+ ! CHECK-DAG: fir.address_of(@_QCnamed2) : !fir.ref<tuple<i32>>
+ ! CHECK-DAG: fir.address_of(@_QC) : !fir.ref<!fir.array<4xi8>>
+ ! CHECK-DAG: fir.address_of(@_QCnamed1) : !fir.ref<!fir.array<40xi8>>
modCommon2use_rename = renamed0 + renamed1(5) + renamed2
end function
end subroutine
end
-! CHECK-LABEL: fir.global linkonce @_QFGt.list constant : !fir.array<2xtuple<!fir.ref<i8>, !fir.ref<!fir.box<none>>>> {
-! CHECK: %[[CB_ADDR:.*]] = fir.address_of(@_QBc) : !fir.ref<!fir.array<56xi8>>
+! CHECK-LABEL: fir.global linkonce @_QFNt.list constant : !fir.array<2xtuple<!fir.ref<i8>, !fir.ref<!fir.box<none>>>> {
+! CHECK: %[[CB_ADDR:.*]] = fir.address_of(@_QCc) : !fir.ref<!fir.array<56xi8>>
! CHECK: %[[CB_CAST:.*]] = fir.convert %[[CB_ADDR]] : (!fir.ref<!fir.array<56xi8>>) -> !fir.ref<!fir.array<?xi8>>
! CHECK: %[[OFFSET:.*]] = arith.constant 8 : index
! CHECK: %[[COORD:.*]] = fir.coordinate_of %[[CB_CAST]], %[[OFFSET]] : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8>
! CHECK: %[[CAST_BOX_NONE:.*]] = fir.convert %[[CAST_BOX]] : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: %[[RES:.*]] = fir.insert_value %{{.*}}, %[[CAST_BOX_NONE]], [1 : index, 1 : index] : (!fir.array<2xtuple<!fir.ref<i8>, !fir.ref<!fir.box<none>>>>, !fir.ref<!fir.box<none>>) -> !fir.array<2xtuple<!fir.ref<i8>, !fir.ref<!fir.box<none>>>>
! CHECK: fir.has_value %[[RES]] : !fir.array<2xtuple<!fir.ref<i8>, !fir.ref<!fir.box<none>>>>
-
print*,y(:)%p
end subroutine
! CHECK-LABEL: func.func @_QFPinit_with_slice()
- ! CHECK: %[[Y:.*]] = fir.address_of(@_QFinit_with_sliceEy) : !fir.ref<!fir.array<2x!fir.type<_QFTc{a:i32,b:i32}>>>
+ ! CHECK: %[[Y:.*]] = fir.address_of(@_QFFinit_with_sliceEy) : !fir.ref<!fir.array<2x!fir.type<_QFTc{a:i32,b:i32}>>>
! CHECK: %[[C2:.*]] = arith.constant 2 : index
! CHECK: %[[C1:.*]] = arith.constant 1 : index
! CHECK: %[[C1_I64:.*]] = arith.constant 1 : i64
print*,y%p
end subroutine
! CHECK-LABEL: func.func @_QFPinit_no_slice()
- ! CHECK: %[[Y:.*]] = fir.address_of(@_QFinit_no_sliceEy) : !fir.ref<!fir.array<2x!fir.type<_QFTc{a:i32,b:i32}>>>
+ ! CHECK: %[[Y:.*]] = fir.address_of(@_QFFinit_no_sliceEy) : !fir.ref<!fir.array<2x!fir.type<_QFTc{a:i32,b:i32}>>>
! 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}>
end subroutine
! CHECK-LABEL: func.func @_QFPinit_allocatable()
- ! CHECK: %[[ALLOC:.*]] = fir.alloca !fir.heap<!fir.array<?x!fir.type<_QFTc{a:i32,b:i32}>>> {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<!fir.array<?x!fir.type<_QFTc{a:i32,b:i32}>>> {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<index>
! CHECK: %[[LOAD_EXT0:.*]] = fir.load %[[EXT0]] : !fir.ref<index>
end subroutine
! CHECK-LABEL: func.func @_QFPinit_scalar()
- ! CHECK: %[[S:.*]] = fir.address_of(@_QFinit_scalarEs) : !fir.ref<!fir.type<_QFTc{a:i32,b:i32}>>
+ ! CHECK: %[[S:.*]] = fir.address_of(@_QFFinit_scalarEs) : !fir.ref<!fir.type<_QFTc{a:i32,b:i32}>>
! CHECK: %[[CAST:.*]] = fir.convert %[[S]] : (!fir.ref<!fir.type<_QFTc{a:i32,b:i32}>>) -> !fir.ref<!fir.type<_QFTp{a:i32}>>
! CHECK: fir.call @_QFPprint_scalar(%[[CAST]]) {{.*}}: (!fir.ref<!fir.type<_QFTp{a:i32}>>) -> ()
! 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
integer, target :: x
integer, pointer :: p
common /some_common/ p
- ! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QBsome_common) : !fir.ref<!fir.array<24xi8>>
+ ! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QCsome_common) : !fir.ref<!fir.array<24xi8>>
! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]] : (!fir.ref<!fir.array<24xi8>>) -> !fir.ref<!fir.array<?xi8>>
! CHECK: %[[VAL_3:.*]] = arith.constant 0 : index
! CHECK: %[[VAL_4:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_3]] : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8>
real, save, target :: b
common /a/ p
data p /b/
-! CHECK-LABEL: fir.global @_QBa : tuple<!fir.box<!fir.ptr<f32>>>
+! CHECK-LABEL: fir.global @_QCa : tuple<!fir.box<!fir.ptr<f32>>>
! CHECK: %[[undef:.*]] = fir.undefined tuple<!fir.box<!fir.ptr<f32>>>
! CHECK: %[[b:.*]] = fir.address_of(@_QEb) : !fir.ref<f32>
! CHECK: %[[box:.*]] = fir.embox %[[b]] : (!fir.ref<f32>) -> !fir.box<f32>
real, pointer :: p2 => x1
common /c1/ x1, p1
common /c2/ x2, p2
-! CHECK-LABEL: fir.global @_QBc1 : tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>
- ! CHECK: fir.address_of(@_QBc2) : !fir.ref<tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>>
-! CHECK-LABEL: fir.global @_QBc2 : tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>
- ! CHECK: fir.address_of(@_QBc1) : !fir.ref<tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>>
+! CHECK-LABEL: fir.global @_QCc1 : tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>
+ ! CHECK: fir.address_of(@_QCc2) : !fir.ref<tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>>
+! CHECK-LABEL: fir.global @_QCc2 : tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>
+ ! CHECK: fir.address_of(@_QCc1) : !fir.ref<tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>>
end block data
! Test pointer in a common with initial target in the same common.
integer, target :: b = 42
integer, pointer :: p => b
common /snake/ p, b
-! CHECK-LABEL: fir.global @_QBsnake : tuple<!fir.box<!fir.ptr<i32>>, i32>
+! CHECK-LABEL: fir.global @_QCsnake : tuple<!fir.box<!fir.ptr<i32>>, i32>
! CHECK: %[[tuple0:.*]] = fir.undefined tuple<!fir.box<!fir.ptr<i32>>, i32>
- ! CHECK: %[[snakeAddr:.*]] = fir.address_of(@_QBsnake) : !fir.ref<tuple<!fir.box<!fir.ptr<i32>>, i32>>
+ ! CHECK: %[[snakeAddr:.*]] = fir.address_of(@_QCsnake) : !fir.ref<tuple<!fir.box<!fir.ptr<i32>>, i32>>
! CHECK: %[[byteView:.*]] = fir.convert %[[snakeAddr:.*]] : (!fir.ref<tuple<!fir.box<!fir.ptr<i32>>, i32>>) -> !fir.ref<!fir.array<?xi8>>
! CHECK: %[[coor:.*]] = fir.coordinate_of %[[byteView]], %c24{{.*}} : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8>
! CHECK: %[[bAddr:.*]] = fir.convert %[[coor]] : (!fir.ref<i8>) -> !fir.ref<i32>
save :: /com/
real, pointer :: p(:) => y
! CHECK-LABEL: fir.global @_QMsome_mod_2Ep : !fir.box<!fir.ptr<!fir.array<?xf32>>> {
- ! CHECK: %[[c:.*]] = fir.address_of(@_QBcom) : !fir.ref<!fir.array<1200xi8>>
+ ! CHECK: %[[c:.*]] = fir.address_of(@_QCcom) : !fir.ref<!fir.array<1200xi8>>
! CHECK: %[[com:.*]] = fir.convert %[[c]] : (!fir.ref<!fir.array<1200xi8>>) -> !fir.ref<!fir.array<?xi8>>
! CHECK: %[[yRaw:.*]] = fir.coordinate_of %[[com]], %c400{{.*}} : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8>
! CHECK: %[[y:.*]] = fir.convert %[[yRaw]] : (!fir.ref<i8>) -> !fir.ref<!fir.array<200xf32>>
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()
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<i32>
+ 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<i32>
+ integer, save :: kk = 77
+ print*, 'ss:inner', kk
+ end
+end
+
! CHECK-LABEL: fir.global internal @_QFfooEpi : f32 {
! CHECK: %[[V_20:[0-9]+]] = fir.box_addr %[[V_18]] : (!fir.box<!fir.heap<!fir.char<1,?>>>) -> !fir.heap<!fir.char<1,?>>
! 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<!fir.char<1,?>>
- ! CHECK: }
! CHECK: cond_br %[[V_43]], ^bb3, ^bb2
! CHECK: ^bb2: // pred: ^bb1
select case(trim(s))
! 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<!fir.char<1,?>>
- ! CHECK: }
! CHECK: cond_br %[[V_49]], ^bb6, ^bb5
! CHECK: ^bb3: // pred: ^bb1
! CHECK: fir.store %c1{{.*}} to %[[V_1]] : !fir.ref<i32>
! 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<!fir.char<1,?>>
- ! CHECK: }
! CHECK: cond_br %[[V_55]], ^bb8, ^bb7
! CHECK: ^bb6: // pred: ^bb2
! CHECK: fir.store %c2{{.*}} to %[[V_1]] : !fir.ref<i32>
! 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<!fir.char<1,?>>
- ! CHECK: }
! CHECK: cond_br %[[V_67]], ^bb14, ^bb10
! CHECK: ^bb10: // 2 preds: ^bb7, ^bb9
! CHECK: %[[V_72:[0-9]+]] = fir.call @_FortranACharacterCompareScalar1
! 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<!fir.char<1,?>>
- ! 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<!fir.char<1,?>>
! 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<i32>
! CHECK: ^bb15: // 5 preds: ^bb3, ^bb4, ^bb6, ^bb8, ^bb14
+ ! CHECK: fir.freemem %[[V_20]] : !fir.heap<!fir.char<1,?>>
end select
end if
! CHECK: %[[V_89:[0-9]+]] = fir.load %[[V_1]] : !fir.ref<i32>
! CHECK-DAG: %[[V_0:[0-9]+]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,?>>>
! CHECK: %[[V_1:[0-9]+]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,?>>>
character(len=3) :: s
- n = 0
+ n = -10
! CHECK: %[[V_12:[0-9]+]] = fir.load %[[V_1]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
! CHECK: %[[V_13:[0-9]+]] = fir.box_addr %[[V_12]] : (!fir.box<!fir.heap<!fir.char<1,?>>>) -> !fir.heap<!fir.char<1,?>>
- ! CHECK: fir.freemem %[[V_13]] : !fir.heap<!fir.char<1,?>>
! 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<!fir.char<1,?>>
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<!fir.box<!fir.heap<!fir.char<1,?>>>>
! CHECK: %[[V_29:[0-9]+]] = fir.box_addr %[[V_28]] : (!fir.box<!fir.heap<!fir.char<1,?>>>) -> !fir.heap<!fir.char<1,?>>
- ! CHECK: fir.freemem %[[V_29]] : !fir.heap<!fir.char<1,?>>
! CHECK: br ^bb3
! CHECK: ^bb3: // pred: ^bb2
- n = -2
+ ! CHECK: fir.freemem %[[V_29]] : !fir.heap<!fir.char<1,?>>
select case(trim(s))
end select
print*, n
using llvm::StringRef;
struct DeconstructedName {
+ DeconstructedName(llvm::StringRef name) : name{name} {}
DeconstructedName(llvm::ArrayRef<std::string> modules,
- std::optional<std::string> host, llvm::StringRef name,
- llvm::ArrayRef<std::int64_t> kinds)
- : modules{modules.begin(), modules.end()}, host{host}, name{name},
- kinds{kinds.begin(), kinds.end()} {}
+ llvm::ArrayRef<std::string> procs, std::int64_t blockId,
+ llvm::StringRef name, llvm::ArrayRef<std::int64_t> 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<std::string> modules;
- std::optional<std::string> host;
+ llvm::SmallVector<std::string> procs;
+ std::int64_t blockId;
std::string name;
llvm::SmallVector<std::int64_t> kinds;
};
<< "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);
}
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);
}
}
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);
}
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);
}
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);
}
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) {
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));
}
projects / platform / upstream / llvm.git / commitdiff