diff --git a/flang/include/flang/Lower/Bridge.h b/flang/include/flang/Lower/Bridge.h new file mode 100644 --- /dev/null +++ b/flang/include/flang/Lower/Bridge.h @@ -0,0 +1,117 @@ +//===-- Lower/Bridge.h -- main interface to lowering ------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// +/// +/// \file +/// Implements lowering. Convert Fortran source to +/// [MLIR](https://github.com/tensorflow/mlir). +/// +/// [Coding style](https://llvm.org/docs/CodingStandards.html) +/// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_BRIDGE_H +#define FORTRAN_LOWER_BRIDGE_H + +#include "flang/Common/Fortran.h" +#include "flang/Lower/AbstractConverter.h" +#include "flang/Optimizer/Support/KindMapping.h" +#include "mlir/IR/Module.h" + +namespace fir { +struct NameUniquer; +} + +namespace Fortran { +namespace common { +class IntrinsicTypeDefaultKinds; +} // namespace common +namespace evaluate { +class IntrinsicProcTable; +} // namespace evaluate +namespace parser { +class CookedSource; +struct Program; +} // namespace parser +namespace semantics { +class SemanticsContext; +} // namespace semantics + +namespace lower { + +//===----------------------------------------------------------------------===// +// Lowering bridge +//===----------------------------------------------------------------------===// + +/// The lowering bridge converts the front-end parse trees and semantics +/// checking residual to MLIR (FIR dialect) code. +class LoweringBridge { +public: + /// Create a lowering bridge instance. + static LoweringBridge + create(const Fortran::common::IntrinsicTypeDefaultKinds &defaultKinds, + const Fortran::evaluate::IntrinsicProcTable &intrinsics, + const Fortran::parser::CookedSource &cooked) { + return LoweringBridge{defaultKinds, intrinsics, cooked}; + } + + //===--------------------------------------------------------------------===// + // Getters + //===--------------------------------------------------------------------===// + + mlir::MLIRContext &getMLIRContext() { return *context.get(); } + mlir::ModuleOp &getModule() { return *module.get(); } + const Fortran::common::IntrinsicTypeDefaultKinds &getDefaultKinds() const { + return defaultKinds; + } + const Fortran::evaluate::IntrinsicProcTable &getIntrinsicTable() const { + return intrinsics; + } + const Fortran::parser::CookedSource *getCookedSource() const { + return cooked; + } + + /// Get the kind map. + const fir::KindMapping &getKindMap() const { return kindMap; } + + /// Create a folding context. Careful: this is very expensive. + Fortran::evaluate::FoldingContext createFoldingContext() const; + + bool validModule() { return getModule(); } + + //===--------------------------------------------------------------------===// + // Perform the creation of an mlir::ModuleOp + //===--------------------------------------------------------------------===// + + /// Read in an MLIR input file rather than lowering Fortran sources. + /// This is intended to be used for testing. + void parseSourceFile(llvm::SourceMgr &); + + /// Cross the bridge from the Fortran parse-tree, etc. to MLIR dialects + void lower(const Fortran::parser::Program &program, fir::NameUniquer &uniquer, + const Fortran::semantics::SemanticsContext &semanticsContext); + +private: + explicit LoweringBridge( + const Fortran::common::IntrinsicTypeDefaultKinds &defaultKinds, + const Fortran::evaluate::IntrinsicProcTable &intrinsics, + const Fortran::parser::CookedSource &cooked); + LoweringBridge() = delete; + LoweringBridge(const LoweringBridge &) = delete; + + const Fortran::common::IntrinsicTypeDefaultKinds &defaultKinds; + const Fortran::evaluate::IntrinsicProcTable &intrinsics; + const Fortran::parser::CookedSource *cooked; + std::unique_ptr context; + std::unique_ptr module; + fir::KindMapping kindMap; +}; + +} // namespace lower +} // namespace Fortran + +#endif // FORTRAN_LOWER_BRIDGE_H diff --git a/flang/include/flang/Lower/CharacterExpr.h b/flang/include/flang/Lower/CharacterExpr.h new file mode 100644 --- /dev/null +++ b/flang/include/flang/Lower/CharacterExpr.h @@ -0,0 +1,140 @@ +//===-- Lower/CharacterExpr.h -- lowering of characters ---------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_CHARACTEREXPR_H +#define FORTRAN_LOWER_CHARACTEREXPR_H + +#include "flang/Lower/FIRBuilder.h" +#include "flang/Lower/Support/BoxValue.h" + +namespace Fortran::lower { + +/// Helper to facilitate lowering of CHARACTER in FIR. +class CharacterExprHelper { +public: + /// Constructor. + explicit CharacterExprHelper(FirOpBuilder &builder, mlir::Location loc) + : builder{builder}, loc{loc} {} + CharacterExprHelper(const CharacterExprHelper &) = delete; + + /// Unless otherwise stated, all mlir::Value inputs of these pseudo-fir ops + /// must be of type: + /// - fir.boxchar (dynamic length character), + /// - fir.ref>> (character with compile time + /// constant length), + /// - fir.array> (compile time constant character) + + /// Copy the \p count first characters of \p src into \p dest. + /// \p count can have any integer type. + void createCopy(mlir::Value dest, mlir::Value src, mlir::Value count); + + /// Set characters of \p str at position [\p lower, \p upper) to blanks. + /// \p lower and \upper bounds are zero based. + /// If \p upper <= \p lower, no padding is done. + /// \p upper and \p lower can have any integer type. + void createPadding(mlir::Value str, mlir::Value lower, mlir::Value upper); + + /// Create str(lb:ub), lower bounds must always be specified, upper + /// bound is optional. + mlir::Value createSubstring(mlir::Value str, + llvm::ArrayRef bounds); + + /// Return blank character of given \p type !fir.char + mlir::Value createBlankConstant(fir::CharacterType type); + + /// Lower \p lhs = \p rhs where \p lhs and \p rhs are scalar characters. + /// It handles cases where \p lhs and \p rhs may overlap. + void createAssign(mlir::Value lhs, mlir::Value rhs); + + /// Lower an assignment where the buffer and LEN parameter are known and do + /// not need to be unboxed. + void createAssign(mlir::Value lptr, mlir::Value llen, mlir::Value rptr, + mlir::Value rlen); + + /// Create lhs // rhs in temp obtained with fir.alloca + mlir::Value createConcatenate(mlir::Value lhs, mlir::Value rhs); + + /// LEN_TRIM intrinsic. + mlir::Value createLenTrim(mlir::Value str); + + /// Embox \p addr and \p len and return fir.boxchar. + /// Take care of type conversions before emboxing. + /// \p len is converted to the integer type for character lengths if needed. + mlir::Value createEmboxChar(mlir::Value addr, mlir::Value len); + + /// Unbox \p boxchar into (fir.ref>, getLengthType()). + std::pair createUnboxChar(mlir::Value boxChar); + + /// Allocate a temp of fir::CharacterType type and length len. + /// Returns related fir.ref>. + mlir::Value createCharacterTemp(mlir::Type type, mlir::Value len); + + /// Allocate a temp of compile time constant length. + /// Returns related fir.ref>>. + mlir::Value createCharacterTemp(mlir::Type type, int len) { + return createTemp(type, len); + } + + /// Return buffer/length pair of character str, if str is a constant, + /// it is allocated into a temp, otherwise, its memory reference is + /// returned as the buffer. + /// The buffer type of str is of type: + /// - fir.ref>> if str has compile time + /// constant length. + /// - fir.ref> if str has dynamic length. + std::pair materializeCharacter(mlir::Value str); + + /// Return true if \p type is a character literal type (is + /// fir.array>).; + static bool isCharacterLiteral(mlir::Type type); + + /// Return true if \p type is one of the following type + /// - fir.boxchar + /// - fir.ref>> + /// - fir.array> + static bool isCharacter(mlir::Type type); + + /// Extract the kind of a character type + static int getCharacterKind(mlir::Type type); + + /// Return the integer type that must be used to manipulate + /// Character lengths. TODO: move this to FirOpBuilder? + mlir::Type getLengthType() { return builder.getIndexType(); } + +private: + fir::CharBoxValue materializeValue(const fir::CharBoxValue &str); + fir::CharBoxValue toDataLengthPair(mlir::Value character); + mlir::Type getReferenceType(const fir::CharBoxValue &c) const; + mlir::Value createEmbox(const fir::CharBoxValue &str); + mlir::Value createLoadCharAt(const fir::CharBoxValue &str, mlir::Value index); + void createStoreCharAt(const fir::CharBoxValue &str, mlir::Value index, + mlir::Value c); + void createCopy(const fir::CharBoxValue &dest, const fir::CharBoxValue &src, + mlir::Value count); + void createPadding(const fir::CharBoxValue &str, mlir::Value lower, + mlir::Value upper); + fir::CharBoxValue createTemp(mlir::Type type, mlir::Value len); + void createLengthOneAssign(const fir::CharBoxValue &lhs, + const fir::CharBoxValue &rhs); + void createAssign(const fir::CharBoxValue &lhs, const fir::CharBoxValue &rhs); + fir::CharBoxValue createConcatenate(const fir::CharBoxValue &lhs, + const fir::CharBoxValue &rhs); + fir::CharBoxValue createSubstring(const fir::CharBoxValue &str, + llvm::ArrayRef bounds); + mlir::Value createLenTrim(const fir::CharBoxValue &str); + mlir::Value createTemp(mlir::Type type, int len); + mlir::Value createBlankConstantCode(fir::CharacterType type); + +private: + FirOpBuilder &builder; + mlir::Location loc; +}; + +} // namespace Fortran::lower + +#endif // FORTRAN_LOWER_CHARACTEREXPR_H diff --git a/flang/include/flang/Lower/CharacterRuntime.h b/flang/include/flang/Lower/CharacterRuntime.h new file mode 100644 --- /dev/null +++ b/flang/include/flang/Lower/CharacterRuntime.h @@ -0,0 +1,36 @@ +//===-- Lower/CharacterRuntime.h -- lower CHARACTER operations --*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_CHARACTERRUNTIME_H +#define FORTRAN_LOWER_CHARACTERRUNTIME_H + +#include "mlir/Dialect/StandardOps/IR/Ops.h" + +namespace Fortran { +namespace lower { +class AbstractConverter; + +/// Generate call to a character comparison for two ssa-values of type +/// `boxchar`. +mlir::Value genBoxCharCompare(AbstractConverter &converter, mlir::Location loc, + mlir::CmpIPredicate cmp, mlir::Value lhs, + mlir::Value rhs); + +/// Generate call to a character comparison op for two unboxed variables. There +/// are 4 arguments, 2 for the lhs and 2 for the rhs. Each CHARACTER must pass a +/// reference to its buffer (`ref>`) and its LEN type parameter (some +/// integral type). +mlir::Value genRawCharCompare(AbstractConverter &converter, mlir::Location loc, + mlir::CmpIPredicate cmp, mlir::Value lhsBuff, + mlir::Value lhsLen, mlir::Value rhsBuff, + mlir::Value rhsLen); + +} // namespace lower +} // namespace Fortran + +#endif // FORTRAN_LOWER_CHARACTERRUNTIME_H diff --git a/flang/include/flang/Lower/FIRBuilder.h b/flang/include/flang/Lower/FIRBuilder.h --- a/flang/include/flang/Lower/FIRBuilder.h +++ b/flang/include/flang/Lower/FIRBuilder.h @@ -70,6 +70,10 @@ /// Safely create a reference type to the type `eleTy`. mlir::Type getRefType(mlir::Type eleTy); + /// Create a null constant of type RefType and value 0. Need to pass in the + /// Location information. + mlir::Value createNullConstant(mlir::Location loc); + /// Create an integer constant of type \p type and value \p i. mlir::Value createIntegerConstant(mlir::Location loc, mlir::Type integerType, std::int64_t i); diff --git a/flang/include/flang/Lower/IntrinsicCall.h b/flang/include/flang/Lower/IntrinsicCall.h new file mode 100644 --- /dev/null +++ b/flang/include/flang/Lower/IntrinsicCall.h @@ -0,0 +1,66 @@ +//===-- Lower/IntrinsicCall.h -- lowering of intrinsics ---------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_INTRINSICCALL_H +#define FORTRAN_LOWER_INTRINSICCALL_H + +#include "flang/Lower/FIRBuilder.h" + +namespace fir { +class ExtendedValue; +} + +namespace Fortran::lower { + +// TODO: Expose interface to get specific intrinsic function address. +// TODO: Handle intrinsic subroutine. +// TODO: Intrinsics that do not require their arguments to be defined +// (e.g shape inquiries) might not fit in the current interface that +// requires mlir::Value to be provided. +// TODO: Error handling interface ? +// TODO: Implementation is incomplete. Many intrinsics to tbd. + +/// Helper for building calls to intrinsic functions in the runtime support +/// libraries. +class IntrinsicCallOpsHelper { +public: + explicit IntrinsicCallOpsHelper(FirOpBuilder &builder, mlir::Location loc) + : builder(builder), loc(loc) {} + IntrinsicCallOpsHelper(const IntrinsicCallOpsHelper &) = delete; + + /// Generate the FIR+MLIR operations for the generic intrinsic \p name + /// with arguments \p args and expected result type \p resultType. + /// Returned mlir::Value is the returned Fortran intrinsic value. + fir::ExtendedValue genIntrinsicCall(llvm::StringRef name, + mlir::Type resultType, + llvm::ArrayRef args); + + //===--------------------------------------------------------------------===// + // Direct access to intrinsics that may be used by lowering outside + // of intrinsic call lowering. + //===--------------------------------------------------------------------===// + + /// Generate maximum. There must be at least one argument and all arguments + /// must have the same type. + mlir::Value genMax(llvm::ArrayRef args); + + /// Generate minimum. Same constraints as genMax. + mlir::Value genMin(llvm::ArrayRef args); + + /// Generate power function x**y with given the expected + /// result type. + mlir::Value genPow(mlir::Type resultType, mlir::Value x, mlir::Value y); + +private: + FirOpBuilder &builder; + mlir::Location loc; +}; + +} // namespace Fortran::lower + +#endif // FORTRAN_LOWER_INTRINSICCALL_H diff --git a/flang/include/flang/Lower/PFTBuilder.h b/flang/include/flang/Lower/PFTBuilder.h --- a/flang/include/flang/Lower/PFTBuilder.h +++ b/flang/include/flang/Lower/PFTBuilder.h @@ -234,6 +234,12 @@ return visit(common::visitors{ [](auto &r) { return pft::isDirective>; }}); } + constexpr bool isNopConstructStmt() const { + return visit(common::visitors{[](auto &r) { + return pft::isNopConstructStmt>; + }}); + } + /// Return the predicate: "This is a non-initial, non-terminal construct /// statement." For an IfConstruct, this is ElseIfStmt and ElseStmt. constexpr bool isIntermediateConstructStmt() const { @@ -241,14 +247,40 @@ return pft::isIntermediateConstructStmt>; }}); } - constexpr bool isNopConstructStmt() const { - return visit(common::visitors{[](auto &r) { - return pft::isNopConstructStmt>; - }}); + + /// Return the first non-nop successor of an evaluation, possibly exiting + /// from one or more enclosing constructs. + Evaluation &nonNopSuccessor() const { + Evaluation *successor = lexicalSuccessor; + if (successor && successor->isNopConstructStmt()) { + successor = successor->parentConstruct->constructExit; + } + assert(successor && "missing successor"); + return *successor; } - /// Return FunctionLikeUnit to which this evaluation - /// belongs. Nullptr if it does not belong to such unit. + /// Return true if this Evaluation has at least one nested evaluation. + bool hasNestedEvaluations() const { + return evaluationList && !evaluationList->empty(); + } + + /// Return nested evaluation list. + EvaluationList &getNestedEvaluations() { + assert(evaluationList && "no nested evaluations"); + return *evaluationList; + } + + Evaluation &getFirstNestedEvaluation() { + assert(hasNestedEvaluations() && "no nested evaluations"); + return evaluationList->front(); + } + + Evaluation &getLastNestedEvaluation() { + assert(hasNestedEvaluations() && "no nested evaluations"); + return evaluationList->back(); + } + + /// Return the FunctionLikeUnit containing this evaluation (or nullptr). FunctionLikeUnit *getOwningProcedure() const; bool lowerAsStructured() const; @@ -297,9 +329,9 @@ Evaluation *controlSuccessor{nullptr}; // set for some statements Evaluation *constructExit{nullptr}; // set for constructs bool isNewBlock{false}; // evaluation begins a new basic block - bool isUnstructured{false}; // evaluation has unstructured control flow - bool skip{false}; // evaluation has been processed in advance - class mlir::Block *block{nullptr}; // isNewBlock block + bool isUnstructured{false}; // evaluation has unstructured control flow + bool skip{false}; // evaluation has been processed in advance + mlir::Block *block{nullptr}; // isNewBlock block llvm::SmallVector localBlocks{}; // construct local blocks int printIndex{0}; // (ActionStmt, ConstructStmt) evaluation index for dumps }; @@ -333,13 +365,13 @@ : sym{&sym}, depth{depth}, global{global} {} const Fortran::semantics::Symbol &getSymbol() const { return *sym; } - + bool isGlobal() const { return global; } bool isHeapAlloc() const { return heapAlloc; } bool isPointer() const { return pointer; } bool isTarget() const { return target; } int getDepth() const { return depth; } - + void setHeapAlloc(bool to = true) { heapAlloc = to; } void setPointer(bool to = true) { pointer = to; } void setTarget(bool to = true) { target = to; } diff --git a/flang/include/flang/Lower/Support/BoxValue.h b/flang/include/flang/Lower/Support/BoxValue.h --- a/flang/include/flang/Lower/Support/BoxValue.h +++ b/flang/include/flang/Lower/Support/BoxValue.h @@ -11,6 +11,7 @@ #include "mlir/IR/Value.h" #include "llvm/ADT/SmallVector.h" +#include "llvm/Support/Compiler.h" #include "llvm/Support/raw_ostream.h" #include #include @@ -67,7 +68,7 @@ friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, const CharBoxValue &); - void dump() const { llvm::errs() << *this; } + LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this; } protected: mlir::Value len; @@ -117,7 +118,7 @@ friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, const ArrayBoxValue &); - void dump() const { operator<<(llvm::errs(), *this); } + LLVM_DUMP_METHOD void dump() const { operator<<(llvm::errs(), *this); } }; /// Expressions of type CHARACTER and with rank > 0. @@ -134,7 +135,7 @@ friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, const CharArrayBoxValue &); - void dump() const { operator<<(llvm::errs(), *this); } + LLVM_DUMP_METHOD void dump() const { operator<<(llvm::errs(), *this); } }; /// Expressions that are procedure POINTERs may need a set of references to @@ -152,7 +153,7 @@ friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, const ProcBoxValue &); - void dump() const { operator<<(llvm::errs(), *this); } + LLVM_DUMP_METHOD void dump() const { operator<<(llvm::errs(), *this); } protected: mlir::Value hostContext; @@ -185,7 +186,7 @@ } friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, const BoxValue &); - void dump() const { operator<<(llvm::errs(), *this); } + LLVM_DUMP_METHOD void dump() const { operator<<(llvm::errs(), *this); } protected: mlir::Value len; @@ -220,7 +221,7 @@ } /// LLVM style debugging of extended values - void dump() const { llvm::errs() << *this << '\n'; } + LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this << '\n'; } friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, const ExtendedValue &); diff --git a/flang/include/flang/Optimizer/Support/KindMapping.h b/flang/include/flang/Optimizer/Support/KindMapping.h --- a/flang/include/flang/Optimizer/Support/KindMapping.h +++ b/flang/include/flang/Optimizer/Support/KindMapping.h @@ -1,4 +1,4 @@ -//===-- Optimizer/Support/KindMapping.h -------------------------*- C++ -*-===// +//===-- Optimizer/Support/KindMapping.h -- support kind mapping -*- C++ -*-===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. @@ -14,15 +14,9 @@ #include "llvm/IR/Type.h" namespace llvm { -template -class Optional; struct fltSemantics; } // namespace llvm -namespace mlir { -class MLIRContext; -} // namespace mlir - namespace fir { /// The kind mapping is an encoded string that informs FIR how the Fortran KIND @@ -57,24 +51,27 @@ explicit KindMapping(mlir::MLIRContext *context, llvm::StringRef map); /// Get the size in bits of !fir.char - Bitsize getCharacterBitsize(KindTy kind); + Bitsize getCharacterBitsize(KindTy kind) const; /// Get the size in bits of !fir.int - Bitsize getIntegerBitsize(KindTy kind); + Bitsize getIntegerBitsize(KindTy kind) const; /// Get the size in bits of !fir.logical - Bitsize getLogicalBitsize(KindTy kind); + Bitsize getLogicalBitsize(KindTy kind) const; + + /// Get the size in bits of !fir.real + Bitsize getRealBitsize(KindTy kind) const; /// Get the LLVM Type::TypeID of !fir.real - LLVMTypeID getRealTypeID(KindTy kind); + LLVMTypeID getRealTypeID(KindTy kind) const; /// Get the LLVM Type::TypeID of !fir.complex - LLVMTypeID getComplexTypeID(KindTy kind); + LLVMTypeID getComplexTypeID(KindTy kind) const; mlir::MLIRContext *getContext() const { return context; } /// Get the float semantics of !fir.real - const llvm::fltSemantics &getFloatSemantics(KindTy kind); + const llvm::fltSemantics &getFloatSemantics(KindTy kind) const; private: MatchResult badMapString(const llvm::Twine &ptr); diff --git a/flang/lib/Lower/CMakeLists.txt b/flang/lib/Lower/CMakeLists.txt --- a/flang/lib/Lower/CMakeLists.txt +++ b/flang/lib/Lower/CMakeLists.txt @@ -2,6 +2,8 @@ get_property(dialect_libs GLOBAL PROPERTY MLIR_DIALECT_LIBS) add_flang_library(FortranLower + CharacterExpr.cpp + CharacterRuntime.cpp ComplexExpr.cpp ConvertType.cpp DoLoopHelper.cpp diff --git a/flang/lib/Lower/CharacterExpr.cpp b/flang/lib/Lower/CharacterExpr.cpp new file mode 100644 --- /dev/null +++ b/flang/lib/Lower/CharacterExpr.cpp @@ -0,0 +1,453 @@ +//===-- CharacterExpr.cpp -------------------------------------------------===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +#include "flang/Lower/CharacterExpr.h" +#include "flang/Lower/ConvertType.h" +#include "flang/Lower/DoLoopHelper.h" +#include "flang/Lower/IntrinsicCall.h" + +//===----------------------------------------------------------------------===// +// CharacterExprHelper implementation +//===----------------------------------------------------------------------===// + +/// Get fir.char type with the same kind as inside str. +static fir::CharacterType getCharacterType(mlir::Type type) { + if (auto boxType = type.dyn_cast()) + return boxType.getEleTy(); + if (auto refType = type.dyn_cast()) + type = refType.getEleTy(); + if (auto seqType = type.dyn_cast()) + type = seqType.getEleTy(); + if (auto charType = type.dyn_cast()) + return charType; + llvm_unreachable("Invalid character value type"); +} + +static fir::CharacterType getCharacterType(const fir::CharBoxValue &box) { + return getCharacterType(box.getBuffer().getType()); +} + +static bool needToMaterialize(const fir::CharBoxValue &box) { + return box.getBuffer().getType().isa() || + box.getBuffer().getType().isa(); +} + +static std::optional +getCompileTimeLength(const fir::CharBoxValue &box) { + // FIXME: should this just return box.getLen() ?? + auto type = box.getBuffer().getType(); + if (type.isa()) + return 1; + if (auto refType = type.dyn_cast()) + type = refType.getEleTy(); + if (auto seqType = type.dyn_cast()) { + auto shape = seqType.getShape(); + assert(shape.size() == 1 && "only scalar character supported"); + if (shape[0] != fir::SequenceType::getUnknownExtent()) + return shape[0]; + } + return {}; +} + +fir::CharBoxValue Fortran::lower::CharacterExprHelper::materializeValue( + const fir::CharBoxValue &str) { + if (!needToMaterialize(str)) + return str; + auto variable = builder.create(loc, str.getBuffer().getType()); + builder.create(loc, str.getBuffer(), variable); + return {variable, str.getLen()}; +} + +fir::CharBoxValue +Fortran::lower::CharacterExprHelper::toDataLengthPair(mlir::Value character) { + auto lenType = getLengthType(); + auto type = character.getType(); + if (auto boxCharType = type.dyn_cast()) { + auto refType = builder.getRefType(boxCharType.getEleTy()); + auto unboxed = + builder.create(loc, refType, lenType, character); + return {unboxed.getResult(0), unboxed.getResult(1)}; + } + if (auto seqType = type.dyn_cast()) { + // Materialize length for usage into character manipulations. + auto len = builder.createIntegerConstant(loc, lenType, 1); + return {character, len}; + } + if (auto refType = type.dyn_cast()) + type = refType.getEleTy(); + if (auto seqType = type.dyn_cast()) { + assert(seqType.hasConstantShape() && + "ssa array value must have constant length"); + auto shape = seqType.getShape(); + assert(shape.size() == 1 && "only scalar character supported"); + // Materialize length for usage into character manipulations. + auto len = builder.createIntegerConstant(loc, lenType, shape[0]); + // FIXME: this seems to work for tests, but don't think it is correct + if (auto load = dyn_cast(character.getDefiningOp())) + return {load.memref(), len}; + return {character, len}; + } + if (auto charTy = type.dyn_cast()) { + auto len = builder.createIntegerConstant(loc, lenType, 1); + return {character, len}; + } + llvm::report_fatal_error("unexpected character type"); +} + +/// Get fir.ref> type. +mlir::Type Fortran::lower::CharacterExprHelper::getReferenceType( + const fir::CharBoxValue &box) const { + return builder.getRefType(getCharacterType(box)); +} + +mlir::Value +Fortran::lower::CharacterExprHelper::createEmbox(const fir::CharBoxValue &box) { + // BoxChar require a reference. + auto str = box; + if (needToMaterialize(box)) + str = materializeValue(box); + auto kind = getCharacterType(str).getFKind(); + auto boxCharType = fir::BoxCharType::get(builder.getContext(), kind); + auto refType = getReferenceType(str); + // So far, fir.emboxChar fails lowering to llvm when it is given + // fir.data>> types, so convert to + // fir.data> if needed. + auto buff = str.getBuffer(); + if (refType != str.getBuffer().getType()) + buff = builder.createConvert(loc, refType, buff); + // Convert in case the provided length is not of the integer type that must + // be used in boxchar. + auto lenType = getLengthType(); + auto len = str.getLen(); + if (str.getLen().getType() != lenType) + len = builder.createConvert(loc, lenType, len); + return builder.create(loc, boxCharType, buff, len); +} + +mlir::Value Fortran::lower::CharacterExprHelper::createLoadCharAt( + const fir::CharBoxValue &str, mlir::Value index) { + // In case this is addressing a length one character scalar simply return + // the single character. + if (str.getBuffer().getType().isa()) + return str.getBuffer(); + auto addr = builder.create(loc, getReferenceType(str), + str.getBuffer(), index); + return builder.create(loc, addr); +} + +void Fortran::lower::CharacterExprHelper::createStoreCharAt( + const fir::CharBoxValue &str, mlir::Value index, mlir::Value c) { + assert(!needToMaterialize(str) && "not in memory"); + auto addr = builder.create(loc, getReferenceType(str), + str.getBuffer(), index); + builder.create(loc, c, addr); +} + +void Fortran::lower::CharacterExprHelper::createCopy( + const fir::CharBoxValue &dest, const fir::CharBoxValue &src, + mlir::Value count) { + Fortran::lower::DoLoopHelper{builder, loc}.createLoop( + count, [&](Fortran::lower::FirOpBuilder &, mlir::Value index) { + auto charVal = createLoadCharAt(src, index); + createStoreCharAt(dest, index, charVal); + }); +} + +void Fortran::lower::CharacterExprHelper::createPadding( + const fir::CharBoxValue &str, mlir::Value lower, mlir::Value upper) { + auto blank = createBlankConstant(getCharacterType(str)); + // Always create the loop, if upper < lower, no iteration will be + // executed. + Fortran::lower::DoLoopHelper{builder, loc}.createLoop( + lower, upper, [&](Fortran::lower::FirOpBuilder &, mlir::Value index) { + createStoreCharAt(str, index, blank); + }); +} + +fir::CharBoxValue +Fortran::lower::CharacterExprHelper::createTemp(mlir::Type type, + mlir::Value len) { + assert(type.isa() && "expected fir character type"); + llvm::SmallVector sizes{len}; + auto ref = builder.allocateLocal(loc, type, llvm::StringRef{}, sizes); + return {ref, len}; +} + +// Simple length one character assignment without loops. +void Fortran::lower::CharacterExprHelper::createLengthOneAssign( + const fir::CharBoxValue &lhs, const fir::CharBoxValue &rhs) { + auto addr = lhs.getBuffer(); + auto refType = getReferenceType(lhs); + addr = builder.createConvert(loc, refType, addr); + + auto val = rhs.getBuffer(); + if (!needToMaterialize(rhs)) { + mlir::Value rhsAddr = rhs.getBuffer(); + rhsAddr = builder.createConvert(loc, refType, rhsAddr); + val = builder.create(loc, rhsAddr); + } + + builder.create(loc, val, addr); +} + +void Fortran::lower::CharacterExprHelper::createAssign( + const fir::CharBoxValue &lhs, const fir::CharBoxValue &rhs) { + auto rhsCstLen = getCompileTimeLength(rhs); + auto lhsCstLen = getCompileTimeLength(lhs); + bool compileTimeSameLength = + lhsCstLen && rhsCstLen && *lhsCstLen == *rhsCstLen; + + if (compileTimeSameLength && *lhsCstLen == 1) { + createLengthOneAssign(lhs, rhs); + return; + } + + // Copy the minimum of the lhs and rhs lengths and pad the lhs remainder + // if needed. + mlir::Value copyCount = lhs.getLen(); + if (!compileTimeSameLength) + copyCount = Fortran::lower::IntrinsicCallOpsHelper{builder, loc}.genMin( + {lhs.getLen(), rhs.getLen()}); + + fir::CharBoxValue safeRhs = rhs; + if (needToMaterialize(rhs)) { + // TODO: revisit now that character constant handling changed. + // Need to materialize the constant to get its elements. + // (No equivalent of fir.coordinate_of for array value). + safeRhs = materializeValue(rhs); + } else { + // If rhs is in memory, always assumes rhs might overlap with lhs + // in a way that require a temp for the copy. That can be optimize later. + // Only create a temp of copyCount size because we do not need more from + // rhs. + auto temp = createTemp(getCharacterType(rhs), copyCount); + createCopy(temp, rhs, copyCount); + safeRhs = temp; + } + + // Actual copy + createCopy(lhs, safeRhs, copyCount); + + // Pad if needed. + if (!compileTimeSameLength) { + auto one = builder.createIntegerConstant(loc, lhs.getLen().getType(), 1); + auto maxPadding = builder.create(loc, lhs.getLen(), one); + createPadding(lhs, copyCount, maxPadding); + } +} + +fir::CharBoxValue Fortran::lower::CharacterExprHelper::createConcatenate( + const fir::CharBoxValue &lhs, const fir::CharBoxValue &rhs) { + mlir::Value len = + builder.create(loc, lhs.getLen(), rhs.getLen()); + auto temp = createTemp(getCharacterType(rhs), len); + createCopy(temp, lhs, lhs.getLen()); + auto one = builder.createIntegerConstant(loc, len.getType(), 1); + auto upperBound = builder.create(loc, len, one); + auto lhsLen = + builder.createConvert(loc, builder.getIndexType(), lhs.getLen()); + Fortran::lower::DoLoopHelper{builder, loc}.createLoop( + lhs.getLen(), upperBound, one, + [&](Fortran::lower::FirOpBuilder &bldr, mlir::Value index) { + auto rhsIndex = bldr.create(loc, index, lhsLen); + auto charVal = createLoadCharAt(rhs, rhsIndex); + createStoreCharAt(temp, index, charVal); + }); + return temp; +} + +fir::CharBoxValue Fortran::lower::CharacterExprHelper::createSubstring( + const fir::CharBoxValue &box, llvm::ArrayRef bounds) { + // Constant need to be materialize in memory to use fir.coordinate_of. + auto str = box; + if (needToMaterialize(box)) + str = materializeValue(box); + + auto nbounds{bounds.size()}; + if (nbounds < 1 || nbounds > 2) { + mlir::emitError(loc, "Incorrect number of bounds in substring"); + return {mlir::Value{}, mlir::Value{}}; + } + mlir::SmallVector castBounds; + // Convert bounds to length type to do safe arithmetic on it. + for (auto bound : bounds) + castBounds.push_back(builder.createConvert(loc, getLengthType(), bound)); + auto lowerBound = castBounds[0]; + // FIR CoordinateOp is zero based but Fortran substring are one based. + auto one = builder.createIntegerConstant(loc, lowerBound.getType(), 1); + auto offset = builder.create(loc, lowerBound, one).getResult(); + auto idxType = builder.getIndexType(); + if (offset.getType() != idxType) + offset = builder.createConvert(loc, idxType, offset); + auto substringRef = builder.create( + loc, getReferenceType(str), str.getBuffer(), offset); + + // Compute the length. + mlir::Value substringLen{}; + if (nbounds < 2) { + substringLen = + builder.create(loc, str.getLen(), castBounds[0]); + } else { + substringLen = + builder.create(loc, castBounds[1], castBounds[0]); + } + substringLen = builder.create(loc, substringLen, one); + + // Set length to zero if bounds were reversed (Fortran 2018 9.4.1) + auto zero = builder.createIntegerConstant(loc, substringLen.getType(), 0); + auto cdt = builder.create(loc, mlir::CmpIPredicate::slt, + substringLen, zero); + substringLen = builder.create(loc, cdt, zero, substringLen); + + return {substringRef, substringLen}; +} + +mlir::Value Fortran::lower::CharacterExprHelper::createLenTrim( + const fir::CharBoxValue &str) { + // Note: Runtime for LEN_TRIM should also be available at some + // point. For now use an inlined implementation. + auto indexType = builder.getIndexType(); + auto len = builder.createConvert(loc, indexType, str.getLen()); + auto one = builder.createIntegerConstant(loc, indexType, 1); + auto minusOne = builder.createIntegerConstant(loc, indexType, -1); + auto zero = builder.createIntegerConstant(loc, indexType, 0); + auto trueVal = builder.createIntegerConstant(loc, builder.getI1Type(), 1); + auto blank = createBlankConstantCode(getCharacterType(str)); + mlir::Value lastChar = builder.create(loc, len, one); + + auto iterWhile = builder.create( + loc, lastChar, zero, minusOne, trueVal, lastChar); + auto insPt = builder.saveInsertionPoint(); + builder.setInsertionPointToStart(iterWhile.getBody()); + auto index = iterWhile.getInductionVar(); + // Look for first non-blank from the right of the character. + auto c = createLoadCharAt(str, index); + c = builder.createConvert(loc, blank.getType(), c); + auto isBlank = + builder.create(loc, mlir::CmpIPredicate::eq, blank, c); + llvm::SmallVector results = {isBlank, index}; + builder.create(loc, results); + builder.restoreInsertionPoint(insPt); + // Compute length after iteration (zero if all blanks) + mlir::Value newLen = + builder.create(loc, iterWhile.getResult(1), one); + auto result = + builder.create(loc, iterWhile.getResult(0), zero, newLen); + return builder.createConvert(loc, getLengthType(), result); +} + +mlir::Value Fortran::lower::CharacterExprHelper::createTemp(mlir::Type type, + int len) { + assert(type.isa() && "expected fir character type"); + assert(len >= 0 && "expected positive length"); + fir::SequenceType::Shape shape{len}; + auto seqType = fir::SequenceType::get(shape, type); + return builder.create(loc, seqType); +} + +// Returns integer with code for blank. The integer has the same +// size as the character. Blank has ascii space code for all kinds. +mlir::Value Fortran::lower::CharacterExprHelper::createBlankConstantCode( + fir::CharacterType type) { + auto bits = builder.getKindMap().getCharacterBitsize(type.getFKind()); + auto intType = builder.getIntegerType(bits); + return builder.createIntegerConstant(loc, intType, ' '); +} + +mlir::Value Fortran::lower::CharacterExprHelper::createBlankConstant( + fir::CharacterType type) { + return builder.createConvert(loc, type, createBlankConstantCode(type)); +} + +void Fortran::lower::CharacterExprHelper::createCopy(mlir::Value dest, + mlir::Value src, + mlir::Value count) { + createCopy(toDataLengthPair(dest), toDataLengthPair(src), count); +} + +void Fortran::lower::CharacterExprHelper::createPadding(mlir::Value str, + mlir::Value lower, + mlir::Value upper) { + createPadding(toDataLengthPair(str), lower, upper); +} + +mlir::Value Fortran::lower::CharacterExprHelper::createSubstring( + mlir::Value str, llvm::ArrayRef bounds) { + return createEmbox(createSubstring(toDataLengthPair(str), bounds)); +} + +void Fortran::lower::CharacterExprHelper::createAssign(mlir::Value lhs, + mlir::Value rhs) { + createAssign(toDataLengthPair(lhs), toDataLengthPair(rhs)); +} + +mlir::Value +Fortran::lower::CharacterExprHelper::createLenTrim(mlir::Value str) { + return createLenTrim(toDataLengthPair(str)); +} + +void Fortran::lower::CharacterExprHelper::createAssign(mlir::Value lptr, + mlir::Value llen, + mlir::Value rptr, + mlir::Value rlen) { + createAssign(fir::CharBoxValue{lptr, llen}, fir::CharBoxValue{rptr, rlen}); +} + +mlir::Value +Fortran::lower::CharacterExprHelper::createConcatenate(mlir::Value lhs, + mlir::Value rhs) { + return createEmbox( + createConcatenate(toDataLengthPair(lhs), toDataLengthPair(rhs))); +} + +mlir::Value +Fortran::lower::CharacterExprHelper::createEmboxChar(mlir::Value addr, + mlir::Value len) { + return createEmbox(fir::CharBoxValue{addr, len}); +} + +std::pair +Fortran::lower::CharacterExprHelper::createUnboxChar(mlir::Value boxChar) { + auto box = toDataLengthPair(boxChar); + return {box.getBuffer(), box.getLen()}; +} + +mlir::Value +Fortran::lower::CharacterExprHelper::createCharacterTemp(mlir::Type type, + mlir::Value len) { + return createEmbox(createTemp(type, len)); +} + +std::pair +Fortran::lower::CharacterExprHelper::materializeCharacter(mlir::Value str) { + auto box = toDataLengthPair(str); + if (needToMaterialize(box)) + box = materializeValue(box); + return {box.getBuffer(), box.getLen()}; +} + +bool Fortran::lower::CharacterExprHelper::isCharacterLiteral(mlir::Type type) { + if (auto seqType = type.dyn_cast()) + return seqType.getEleTy().isa(); + return false; +} + +bool Fortran::lower::CharacterExprHelper::isCharacter(mlir::Type type) { + if (type.isa()) + return true; + if (auto refType = type.dyn_cast()) + type = refType.getEleTy(); + if (auto seqType = type.dyn_cast()) { + type = seqType.getEleTy(); + } + return type.isa(); +} + +int Fortran::lower::CharacterExprHelper::getCharacterKind(mlir::Type type) { + return getCharacterType(type).getFKind(); +} diff --git a/flang/lib/Lower/CharacterRuntime.cpp b/flang/lib/Lower/CharacterRuntime.cpp new file mode 100644 --- /dev/null +++ b/flang/lib/Lower/CharacterRuntime.cpp @@ -0,0 +1,129 @@ +//===-- CharacterRuntime.cpp -- runtime for CHARACTER type entities -------===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +#include "flang/Lower/CharacterRuntime.h" +#include "../../runtime/character.h" +#include "RTBuilder.h" +#include "flang/Lower/Bridge.h" +#include "flang/Lower/CharacterExpr.h" +#include "flang/Lower/FIRBuilder.h" +#include "mlir/Dialect/StandardOps/IR/Ops.h" + +using namespace Fortran::runtime; + +#define NAMIFY_HELPER(X) #X +#define NAMIFY(X) NAMIFY_HELPER(IONAME(X)) +#define mkRTKey(X) mkKey(RTNAME(X)) + +namespace Fortran::lower { +/// Static table of CHARACTER runtime calls +/// +/// This logical map contains the name and type builder function for each +/// runtime function listed in the tuple. This table is fully constructed at +/// compile-time. Use the `mkRTKey` macro to access the table. +static constexpr std::tuple< + mkRTKey(CharacterCompareScalar), mkRTKey(CharacterCompareScalar1), + mkRTKey(CharacterCompareScalar2), mkRTKey(CharacterCompareScalar4), + mkRTKey(CharacterCompare)> + newCharRTTable; +} // namespace Fortran::lower + +using namespace Fortran::lower; + +/// Helper function to retrieve the name of the IO function given the key `A` +template +static constexpr const char *getName() { + return std::get(newCharRTTable).name; +} + +/// Helper function to retrieve the type model signature builder of the IO +/// function as defined by the key `A` +template +static constexpr FuncTypeBuilderFunc getTypeModel() { + return std::get(newCharRTTable).getTypeModel(); +} + +inline int64_t getLength(mlir::Type argTy) { + return argTy.cast().getShape()[0]; +} + +/// Get (or generate) the MLIR FuncOp for a given runtime function. +template +static mlir::FuncOp getRuntimeFunc(mlir::Location loc, + Fortran::lower::FirOpBuilder &builder) { + auto name = getName(); + auto func = builder.getNamedFunction(name); + if (func) + return func; + auto funTy = getTypeModel()(builder.getContext()); + func = builder.createFunction(loc, name, funTy); + func.setAttr("fir.runtime", builder.getUnitAttr()); + return func; +} + +/// Helper function to recover the KIND from the FIR type. +static int discoverKind(mlir::Type ty) { + if (auto charTy = ty.dyn_cast()) + return charTy.getFKind(); + if (auto eleTy = fir::dyn_cast_ptrEleTy(ty)) + return discoverKind(eleTy); + if (auto arrTy = ty.dyn_cast()) + return discoverKind(arrTy.getEleTy()); + if (auto boxTy = ty.dyn_cast()) + return discoverKind(boxTy.getEleTy()); + if (auto boxTy = ty.dyn_cast()) + return discoverKind(boxTy.getEleTy()); + llvm_unreachable("unexpected character type"); +} + +//===----------------------------------------------------------------------===// +// Lower character operations +//===----------------------------------------------------------------------===// + +mlir::Value +Fortran::lower::genRawCharCompare(Fortran::lower::AbstractConverter &converter, + mlir::Location loc, mlir::CmpIPredicate cmp, + mlir::Value lhsBuff, mlir::Value lhsLen, + mlir::Value rhsBuff, mlir::Value rhsLen) { + auto &builder = converter.getFirOpBuilder(); + mlir::FuncOp beginFunc; + switch (discoverKind(lhsBuff.getType())) { + case 1: + beginFunc = getRuntimeFunc(loc, builder); + break; + case 2: + beginFunc = getRuntimeFunc(loc, builder); + break; + case 4: + beginFunc = getRuntimeFunc(loc, builder); + break; + default: + llvm_unreachable("runtime does not support CHARACTER KIND"); + } + auto fTy = beginFunc.getType(); + auto lptr = builder.createConvert(loc, fTy.getInput(0), lhsBuff); + auto llen = builder.createConvert(loc, fTy.getInput(2), lhsLen); + auto rptr = builder.createConvert(loc, fTy.getInput(1), rhsBuff); + auto rlen = builder.createConvert(loc, fTy.getInput(3), rhsLen); + llvm::SmallVector args = {lptr, rptr, llen, rlen}; + auto tri = builder.create(loc, beginFunc, args).getResult(0); + auto zero = builder.createIntegerConstant(loc, tri.getType(), 0); + return builder.create(loc, cmp, tri, zero); +} + +mlir::Value +Fortran::lower::genBoxCharCompare(Fortran::lower::AbstractConverter &converter, + mlir::Location loc, mlir::CmpIPredicate cmp, + mlir::Value lhs, mlir::Value rhs) { + auto &builder = converter.getFirOpBuilder(); + Fortran::lower::CharacterExprHelper helper{builder, loc}; + auto lhsPair = helper.materializeCharacter(lhs); + auto rhsPair = helper.materializeCharacter(rhs); + return genRawCharCompare(converter, loc, cmp, lhsPair.first, lhsPair.second, + rhsPair.first, rhsPair.second); +} diff --git a/flang/lib/Lower/OpenMP.cpp b/flang/lib/Lower/OpenMP.cpp --- a/flang/lib/Lower/OpenMP.cpp +++ b/flang/lib/Lower/OpenMP.cpp @@ -7,7 +7,7 @@ //===----------------------------------------------------------------------===// #include "flang/Lower/OpenMP.h" -#include "flang/Lower/AbstractConverter.h" +#include "flang/Lower/Bridge.h" #include "flang/Lower/PFTBuilder.h" #include "flang/Parser/parse-tree.h" diff --git a/flang/lib/Lower/PFTBuilder.cpp b/flang/lib/Lower/PFTBuilder.cpp --- a/flang/lib/Lower/PFTBuilder.cpp +++ b/flang/lib/Lower/PFTBuilder.cpp @@ -170,13 +170,24 @@ void exitModule() { parentVariantStack.pop_back(); - resetFunctionList(); + resetFunctionState(); + } + + /// Ensure that a function has a branch target after the last user statement. + void endFunctionBody() { + if (lastLexicalEvaluation) { + static const parser::ContinueStmt endTarget{}; + addEvaluation( + lower::pft::Evaluation{endTarget, parentVariantStack.back(), {}, {}}); + lastLexicalEvaluation = nullptr; + } } /// Initialize a new function-like unit and make it the builder's focus. template bool enterFunction(const A &func, const semantics::SemanticsContext &semanticsContext) { + endFunctionBody(); // enclosing host subprogram body, if any auto &unit = addFunction(lower::pft::FunctionLikeUnit{ func, parentVariantStack.back(), semanticsContext}); labelEvaluationMap = &unit.labelEvaluationMap; @@ -188,17 +199,13 @@ } void exitFunction() { - // Guarantee that there is a branch target after the last user statement. - static const parser::ContinueStmt endTarget{}; - addEvaluation( - lower::pft::Evaluation{endTarget, parentVariantStack.back(), {}, {}}); - lastLexicalEvaluation = nullptr; + endFunctionBody(); analyzeBranches(nullptr, *evaluationListStack.back()); // add branch links popEvaluationList(); labelEvaluationMap = nullptr; assignSymbolLabelMap = nullptr; parentVariantStack.pop_back(); - resetFunctionList(); + resetFunctionState(); } /// Initialize a new construct and make it the builder's focus. @@ -219,12 +226,14 @@ constructAndDirectiveStack.pop_back(); } - /// Reset functionList to an enclosing function's functionList. - void resetFunctionList() { + /// Reset function state to that of an enclosing host function. + void resetFunctionState() { if (!parentVariantStack.empty()) { parentVariantStack.back().visit(common::visitors{ [&](lower::pft::FunctionLikeUnit &p) { functionList = &p.nestedFunctions; + labelEvaluationMap = &p.labelEvaluationMap; + assignSymbolLabelMap = &p.assignSymbolLabelMap; }, [&](lower::pft::ModuleLikeUnit &p) { functionList = &p.nestedFunctions; @@ -346,13 +355,10 @@ /// Set the exit of a construct, possibly from multiple enclosing constructs. void setConstructExit(lower::pft::Evaluation &eval) { - eval.constructExit = eval.evaluationList->back().lexicalSuccessor; - if (eval.constructExit && eval.constructExit->isNopConstructStmt()) { - eval.constructExit = eval.constructExit->parentConstruct->constructExit; - } - assert(eval.constructExit && "missing construct exit"); + eval.constructExit = &eval.evaluationList->back().nonNopSuccessor(); } + /// Mark the target of a branch as a new block. void markBranchTarget(lower::pft::Evaluation &sourceEvaluation, lower::pft::Evaluation &targetEvaluation) { sourceEvaluation.isUnstructured = true; @@ -360,6 +366,22 @@ sourceEvaluation.controlSuccessor = &targetEvaluation; } targetEvaluation.isNewBlock = true; + // If this is a branch into the body of a construct (usually illegal, + // but allowed in some legacy cases), then the targetEvaluation and its + // ancestors must be marked as unstructured. + auto *sourceConstruct = sourceEvaluation.parentConstruct; + auto *targetConstruct = targetEvaluation.parentConstruct; + if (targetEvaluation.isConstructStmt() && + &targetConstruct->getFirstNestedEvaluation() == &targetEvaluation) + // A branch to an initial constructStmt is a branch to the construct. + targetConstruct = targetConstruct->parentConstruct; + if (targetConstruct) { + while (sourceConstruct && sourceConstruct != targetConstruct) + sourceConstruct = sourceConstruct->parentConstruct; + if (sourceConstruct != targetConstruct) + for (auto *eval = &targetEvaluation; eval; eval = eval->parentConstruct) + eval->isUnstructured = true; + } } void markBranchTarget(lower::pft::Evaluation &sourceEvaluation, parser::Label label) { @@ -370,20 +392,9 @@ markBranchTarget(sourceEvaluation, *targetEvaluation); } - /// Return the first non-nop successor of an evaluation, possibly exiting - /// from one or more enclosing constructs. - lower::pft::Evaluation *exitSuccessor(lower::pft::Evaluation &eval) { - lower::pft::Evaluation *successor{eval.lexicalSuccessor}; - if (successor && successor->isNopConstructStmt()) { - successor = successor->parentConstruct->constructExit; - } - assert(successor && "missing exit successor"); - return successor; - } - - /// Mark the exit successor of an Evaluation as a new block. + /// Mark the successor of an Evaluation as a new block. void markSuccessorAsNewBlock(lower::pft::Evaluation &eval) { - exitSuccessor(eval)->isNewBlock = true; + eval.nonNopSuccessor().isNewBlock = true; } template @@ -521,7 +532,8 @@ [&](const parser::AssignedGotoStmt &) { // Although this statement is a branch, it doesn't have any // explicit control successors. So the code at the end of the - // loop won't mark the exit successor. Do that here. + // loop won't mark the successor. Do that here. + eval.isUnstructured = true; markSuccessorAsNewBlock(eval); }, @@ -542,7 +554,7 @@ lastConstructStmtEvaluation = &eval; }, [&](const parser::EndSelectStmt &) { - eval.lexicalSuccessor->isNewBlock = true; + eval.nonNopSuccessor().isNewBlock = true; lastConstructStmtEvaluation = nullptr; }, [&](const parser::ChangeTeamStmt &s) { @@ -563,7 +575,7 @@ eval.isUnstructured = true; // infinite loop return; } - eval.lexicalSuccessor->isNewBlock = true; + eval.nonNopSuccessor().isNewBlock = true; eval.controlSuccessor = &evaluationList.back(); if (std::holds_alternative(control->u)) { eval.isUnstructured = true; // while loop @@ -702,7 +714,7 @@ markSuccessorAsNewBlock(eval); lastIfStmtEvaluation->isUnstructured = true; } - lastIfStmtEvaluation->controlSuccessor = exitSuccessor(eval); + lastIfStmtEvaluation->controlSuccessor = &eval.nonNopSuccessor(); lastIfStmtEvaluation = nullptr; } @@ -718,7 +730,7 @@ parentConstruct->isUnstructured = true; } - // The lexical successor of a branch starts a new block. + // The successor of a branch starts a new block. if (eval.controlSuccessor && eval.isActionStmt() && eval.lowerAsUnstructured()) { markSuccessorAsNewBlock(eval); @@ -1041,6 +1053,16 @@ void Fortran::lower::pft::FunctionLikeUnit::processSymbolTable( const semantics::Scope &scope) { + // TODO: handle equivalence and common blocks + if (!scope.equivalenceSets().empty()) { + llvm::errs() << "TODO: equivalence not yet handled in lowering.\n" + << "note: equivalence used in " + << (scope.GetName() && !scope.GetName()->empty() + ? scope.GetName()->ToString() + : "unnamed program"s) + << "\n"; + exit(1); + } SymbolDependenceDepth sdd{varList}; for (const auto &iter : scope) sdd.analyze(iter.second.get()); diff --git a/flang/lib/Lower/RTBuilder.h b/flang/lib/Lower/RTBuilder.h --- a/flang/lib/Lower/RTBuilder.h +++ b/flang/lib/Lower/RTBuilder.h @@ -212,22 +212,41 @@ // Runtime table building (constexpr folded) //===----------------------------------------------------------------------===// -#if defined(__clang__) -#pragma clang diagnostic push -#pragma clang diagnostic ignored "-Wgnu-string-literal-operator-template" -#endif - -// clang++ generates warnings about usage of a GNU extension, ignore them template using RuntimeIdentifier = std::integer_sequence; -template -static constexpr RuntimeIdentifier operator""_rt_ident() { + +namespace details { +template +static constexpr std::integer_sequence +concat(std::integer_sequence, std::integer_sequence) { return {}; } - -#if defined(__clang__) -#pragma clang diagnostic pop -#endif +template +static constexpr auto concat(std::integer_sequence, + std::integer_sequence, Cs...) { + return concat(std::integer_sequence{}, Cs{}...); +} +template +static constexpr std::integer_sequence concat(std::integer_sequence) { + return {}; +} +template +static constexpr auto filterZero(std::integer_sequence) { + if constexpr (a != 0) { + return std::integer_sequence{}; + } else { + return std::integer_sequence{}; + } +} +template +static constexpr auto filter(std::integer_sequence) { + if constexpr (sizeof...(b) > 0) { + return details::concat(filterZero(std::integer_sequence{})...); + } else { + return std::integer_sequence{}; + } +} +} // namespace details template struct RuntimeTableEntry; @@ -239,11 +258,23 @@ static constexpr const char name[sizeof...(Cs) + 1] = {Cs..., '\0'}; }; -#define QuoteKey(X) #X##_rt_ident -#define ExpandKey(X) QuoteKey(X) +#undef E +#define E(L, I) (I < sizeof(L) / sizeof(*L) ? L[I] : 0) +#define QuoteKey(X) #X +#define MacroExpandKey(X) \ + E(X, 0), E(X, 1), E(X, 2), E(X, 3), E(X, 4), E(X, 5), E(X, 6), E(X, 7), \ + E(X, 8), E(X, 9), E(X, 10), E(X, 11), E(X, 12), E(X, 13), E(X, 14), \ + E(X, 15), E(X, 16), E(X, 17), E(X, 18), E(X, 19), E(X, 20), E(X, 21), \ + E(X, 22), E(X, 23), E(X, 24), E(X, 25), E(X, 26), E(X, 27), E(X, 28), \ + E(X, 29), E(X, 30), E(X, 31), E(X, 32), E(X, 33), E(X, 34), E(X, 35), \ + E(X, 36), E(X, 37), E(X, 38), E(X, 39), E(X, 40), E(X, 41), E(X, 42), \ + E(X, 43), E(X, 44), E(X, 45), E(X, 46), E(X, 47), E(X, 48), E(X, 49) +#define ExpandKey(X) MacroExpandKey(QuoteKey(X)) +#define FullSeq(X) std::integer_sequence +#define AsSequence(X) decltype(Fortran::lower::details::filter(FullSeq(X){})) #define mkKey(X) \ Fortran::lower::RuntimeTableEntry< \ - Fortran::lower::RuntimeTableKey, decltype(ExpandKey(X))> + Fortran::lower::RuntimeTableKey, AsSequence(X)> } // namespace Fortran::lower diff --git a/flang/lib/Lower/SymbolMap.h b/flang/lib/Lower/SymbolMap.h --- a/flang/lib/Lower/SymbolMap.h +++ b/flang/lib/Lower/SymbolMap.h @@ -19,6 +19,7 @@ #include "llvm/ADT/DenseMap.h" #include "llvm/ADT/Optional.h" #include "llvm/ADT/SmallVector.h" +#include "llvm/Support/Compiler.h" namespace Fortran::lower { @@ -238,7 +239,7 @@ void clear() { symbolMap.clear(); } /// Dump the map. For debugging. - void dump() const; + LLVM_DUMP_METHOD void dump() const; private: /// Add `symbol` to the current map and bind a `box`. diff --git a/flang/lib/Optimizer/Support/KindMapping.cpp b/flang/lib/Optimizer/Support/KindMapping.cpp --- a/flang/lib/Optimizer/Support/KindMapping.cpp +++ b/flang/lib/Optimizer/Support/KindMapping.cpp @@ -8,7 +8,6 @@ #include "flang/Optimizer/Support/KindMapping.h" #include "mlir/Dialect/LLVMIR/LLVMDialect.h" -#include "llvm/ADT/Optional.h" #include "llvm/Support/CommandLine.h" /// Allow the user to set the FIR intrinsic type kind value to LLVM type @@ -219,26 +218,33 @@ return mlir::success(); } -Bitsize fir::KindMapping::getCharacterBitsize(KindTy kind) { +Bitsize fir::KindMapping::getCharacterBitsize(KindTy kind) const { return getIntegerLikeBitsize<'a'>(kind, intMap); } -Bitsize fir::KindMapping::getIntegerBitsize(KindTy kind) { +Bitsize fir::KindMapping::getIntegerBitsize(KindTy kind) const { return getIntegerLikeBitsize<'i'>(kind, intMap); } -Bitsize fir::KindMapping::getLogicalBitsize(KindTy kind) { +Bitsize fir::KindMapping::getLogicalBitsize(KindTy kind) const { return getIntegerLikeBitsize<'l'>(kind, intMap); } -LLVMTypeID fir::KindMapping::getRealTypeID(KindTy kind) { +LLVMTypeID fir::KindMapping::getRealTypeID(KindTy kind) const { return getFloatLikeTypeID<'r'>(kind, floatMap); } -LLVMTypeID fir::KindMapping::getComplexTypeID(KindTy kind) { +LLVMTypeID fir::KindMapping::getComplexTypeID(KindTy kind) const { return getFloatLikeTypeID<'c'>(kind, floatMap); } -const llvm::fltSemantics &fir::KindMapping::getFloatSemantics(KindTy kind) { +Bitsize fir::KindMapping::getRealBitsize(KindTy kind) const { + auto typeId = getFloatLikeTypeID<'r'>(kind, floatMap); + llvm::LLVMContext llCtxt; // FIXME + return llvm::Type::getPrimitiveType(llCtxt, typeId)->getPrimitiveSizeInBits(); +} + +const llvm::fltSemantics & +fir::KindMapping::getFloatSemantics(KindTy kind) const { return getFloatSemanticsOfKind<'r'>(kind, floatMap); }