From fe252f8ed6369acdb13d4e290d3b9dfe2ec4eb8e Mon Sep 17 00:00:00 2001 From: Valentin Clement Date: Tue, 22 Mar 2022 15:40:32 +0100 Subject: [PATCH] [flang] Lower boxed procedure In FIR, we want to wrap function pointers in a special box known as a boxproc value. Fortran has a limited form of dynamic scoping [https://tinyurl.com/2p8v2hw7] between "host procedures" and "internal procedures". There are a number of implementations possible. Boxproc typed values abstract away the implementation details of when a function pointer can be passed directly (as a raw address) and when a function pointer has to account for the presence of a dynamic scope. When lowering Fortran syntax to FIR, all function pointers are emboxed as boxproc values. When creating LLVM IR, we must strip away the abstraction and produce low-level LLVM "assembly" code. This patch implements that transformation as converting the boxproc values to either raw function pointers or executable trampolines on the stack as needed. The trampoline then captures the dynamic scope context within an executable thunk that can be passed instead of the function's raw address. Some extra handling is required for Fortran functions that return a character value to deal with LEN values here. Some of the code in Bridge.cpp and ConvertExpr.cpp and be re-arranged to faciliate the upstreaming effort. This patch is part of the upstreaming effort from fir-dev branch. Reviewed By: jeanPerier, PeteSteinfeld Differential Revision: https://reviews.llvm.org/D122223 Co-authored-by: mleair Co-authored-by: Jean Perier Co-authored-by: Eric Schweitz Co-authored-by: V Donaldson Co-authored-by: Kiran Chandramohan --- flang/include/flang/Lower/Bridge.h | 12 +- flang/include/flang/Lower/CallInterface.h | 48 +- flang/include/flang/Lower/ConvertExpr.h | 76 +- flang/include/flang/Lower/IntrinsicCall.h | 4 + .../flang/Optimizer/Builder/Character.h | 30 +- .../flang/Optimizer/Builder/FIRBuilder.h | 34 +- .../Optimizer/Builder/LowLevelIntrinsics.h | 18 + .../flang/Optimizer/CodeGen/CGPasses.td | 10 + .../include/flang/Optimizer/CodeGen/CodeGen.h | 6 + .../include/flang/Optimizer/Dialect/FIROps.td | 21 +- .../flang/Optimizer/Dialect/FIROpsSupport.h | 8 +- .../include/flang/Optimizer/Dialect/FIRType.h | 30 +- .../flang/Optimizer/Dialect/FIRTypes.td | 5 + flang/include/flang/Tools/CLOptions.inc | 8 + flang/lib/Lower/Bridge.cpp | 1376 +++++------ flang/lib/Lower/CallInterface.cpp | 34 +- flang/lib/Lower/ConvertExpr.cpp | 2092 +++++++++-------- flang/lib/Lower/ConvertVariable.cpp | 6 +- flang/lib/Lower/IntrinsicCall.cpp | 9 + flang/lib/Optimizer/Builder/Character.cpp | 145 +- flang/lib/Optimizer/Builder/FIRBuilder.cpp | 74 +- .../Optimizer/Builder/LowLevelIntrinsics.cpp | 53 + flang/lib/Optimizer/Builder/MutableBox.cpp | 77 +- .../lib/Optimizer/CodeGen/BoxedProcedure.cpp | 326 +++ flang/lib/Optimizer/CodeGen/CMakeLists.txt | 1 + flang/lib/Optimizer/CodeGen/TargetRewrite.cpp | 34 +- flang/lib/Optimizer/CodeGen/TypeConverter.h | 10 + flang/lib/Optimizer/Dialect/FIROps.cpp | 52 +- .../Transforms/ExternalNameConversion.cpp | 27 +- flang/test/Fir/Todo/emboxproc.fir | 11 - .../test/Fir/external-mangling-emboxproc.fir | 5 +- flang/test/Fir/fir-ops.fir | 19 +- flang/test/Lower/Intrinsics/len.f90 | 177 +- flang/test/Lower/allocatable-assignment.f90 | 221 +- flang/test/Lower/allocatable-callee.f90 | 10 +- flang/test/Lower/allocatable-runtime.f90 | 314 +-- flang/test/Lower/allocatables.f90 | 7 +- .../test/Lower/dummy-procedure-character.f90 | 254 ++ flang/test/Lower/dummy-procedure.f90 | 175 ++ flang/test/Lower/host-associated.f90 | 559 ++++- flang/test/Lower/procedure-declarations.f90 | 60 + 41 files changed, 4192 insertions(+), 2246 deletions(-) create mode 100644 flang/lib/Optimizer/CodeGen/BoxedProcedure.cpp delete mode 100644 flang/test/Fir/Todo/emboxproc.fir create mode 100644 flang/test/Lower/dummy-procedure-character.f90 create mode 100644 flang/test/Lower/dummy-procedure.f90 diff --git a/flang/include/flang/Lower/Bridge.h b/flang/include/flang/Lower/Bridge.h index d659581cab9f..fe2b5b287077 100644 --- a/flang/include/flang/Lower/Bridge.h +++ b/flang/include/flang/Lower/Bridge.h @@ -5,13 +5,9 @@ // 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) -/// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// //===----------------------------------------------------------------------===// #ifndef FORTRAN_LOWER_BRIDGE_H @@ -84,6 +80,8 @@ public: /// 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 //===--------------------------------------------------------------------===// diff --git a/flang/include/flang/Lower/CallInterface.h b/flang/include/flang/Lower/CallInterface.h index a1ec396d59bc..97a60df3f4c8 100644 --- a/flang/include/flang/Lower/CallInterface.h +++ b/flang/include/flang/Lower/CallInterface.h @@ -12,10 +12,10 @@ // // Utility that defines fir call interface for procedure both on caller and // and callee side and get the related FuncOp. -// It does not emit any FIR code but for the created mlir::FuncOp, instead it -// provides back a container of Symbol (callee side)/ActualArgument (caller +// It does not emit any FIR code but for the created mlir::func::FuncOp, instead +// it provides back a container of Symbol (callee side)/ActualArgument (caller // side) with additional information for each element describing how it must be -// plugged with the mlir::FuncOp. +// plugged with the mlir::func::FuncOp. // It handles the fact that hidden arguments may be inserted for the result. // while lowering. // @@ -76,8 +76,8 @@ template class CallInterfaceImpl; /// CallInterface defines all the logic to determine FIR function interfaces -/// from a characteristic, build the mlir::FuncOp and describe back the argument -/// mapping to its user. +/// from a characteristic, build the mlir::func::FuncOp and describe back the +/// argument mapping to its user. /// The logic is shared between the callee and caller sides that it accepts as /// a curiously recursive template to handle the few things that cannot be /// shared between both sides (getting characteristics, mangled name, location). @@ -131,7 +131,7 @@ public: using FirValue = typename PassedEntityTypes::FirValue; /// FirPlaceHolder are place holders for the mlir inputs and outputs that are - /// created during the first pass before the mlir::FuncOp is created. + /// created during the first pass before the mlir::func::FuncOp is created. struct FirPlaceHolder { FirPlaceHolder(mlir::Type t, int passedPosition, Property p, llvm::ArrayRef attrs) @@ -162,8 +162,8 @@ public: /// How entity is passed by. PassEntityBy passBy; /// What is the entity (SymbolRef for callee/ActualArgument* for caller) - /// What is the related mlir::FuncOp argument(s) (mlir::Value for callee / - /// index for the caller). + /// What is the related mlir::func::FuncOp argument(s) (mlir::Value for + /// callee / index for the caller). FortranEntity entity; FirValue firArgument; FirValue firLength; /* only for AddressAndLength */ @@ -173,9 +173,9 @@ public: nullptr; }; - /// Return the mlir::FuncOp. Note that front block is added by this + /// Return the mlir::func::FuncOp. Note that front block is added by this /// utility if callee side. - mlir::FuncOp getFuncOp() const { return func; } + mlir::func::FuncOp getFuncOp() const { return func; } /// Number of MLIR inputs/outputs of the created FuncOp. std::size_t getNumFIRArguments() const { return inputs.size(); } std::size_t getNumFIRResults() const { return outputs.size(); } @@ -183,7 +183,7 @@ public: llvm::SmallVector getResultType() const; /// Return a container of Symbol/ActualArgument* and how they must - /// be plugged with the mlir::FuncOp. + /// be plugged with the mlir::func::FuncOp. llvm::ArrayRef getPassedArguments() const { return passedArguments; } @@ -194,7 +194,7 @@ public: mlir::FunctionType genFunctionType(); /// determineInterface is the entry point of the first pass that defines the - /// interface and is required to get the mlir::FuncOp. + /// interface and is required to get the mlir::func::FuncOp. void determineInterface(bool isImplicit, const Fortran::evaluate::characteristics::Procedure &); @@ -219,16 +219,16 @@ protected: /// CRTP handle. T &side() { return *static_cast(this); } /// Entry point to be called by child ctor to analyze the signature and - /// create/find the mlir::FuncOp. Child needs to be initialized first. + /// create/find the mlir::func::FuncOp. Child needs to be initialized first. void declare(); - /// Second pass entry point, once the mlir::FuncOp is created. + /// Second pass entry point, once the mlir::func::FuncOp is created. /// Nothing is done if it was already called. void mapPassedEntities(); void mapBackInputToPassedEntity(const FirPlaceHolder &, FirValue); llvm::SmallVector outputs; llvm::SmallVector inputs; - mlir::FuncOp func; + mlir::func::FuncOp func; llvm::SmallVector passedArguments; std::optional passedResult; bool saveResult = false; @@ -270,6 +270,10 @@ public: return procRef; } + /// Get the SubprogramDetails that defines the interface of this call if it is + /// known at the call site. Return nullptr if it is not known. + const Fortran::semantics::SubprogramDetails *getInterfaceDetails() const; + bool isMainProgram() const { return false; } /// Returns true if this is a call to a procedure pointer of a dummy @@ -368,9 +372,9 @@ public: /// procedure. const Fortran::semantics::Symbol *getProcedureSymbol() const; - /// Add mlir::FuncOp entry block and map fir block arguments to Fortran dummy - /// argument symbols. - mlir::FuncOp addEntryBlockAndMapArguments(); + /// Add mlir::func::FuncOp entry block and map fir block arguments to Fortran + /// dummy argument symbols. + mlir::func::FuncOp addEntryBlockAndMapArguments(); bool hasHostAssociated() const; mlir::Type getHostAssociatedTy() const; @@ -385,13 +389,13 @@ mlir::FunctionType translateSignature(const Fortran::evaluate::ProcedureDesignator &, Fortran::lower::AbstractConverter &); -/// Declare or find the mlir::FuncOp named \p name. If the mlir::FuncOp does -/// not exist yet, declare it with the signature translated from the -/// ProcedureDesignator argument. +/// Declare or find the mlir::func::FuncOp named \p name. If the +/// mlir::func::FuncOp does not exist yet, declare it with the signature +/// translated from the ProcedureDesignator argument. /// Due to Fortran implicit function typing rules, the returned FuncOp is not /// guaranteed to have the signature from ProcedureDesignator if the FuncOp was /// already declared. -mlir::FuncOp +mlir::func::FuncOp getOrDeclareFunction(llvm::StringRef name, const Fortran::evaluate::ProcedureDesignator &, Fortran::lower::AbstractConverter &); diff --git a/flang/include/flang/Lower/ConvertExpr.h b/flang/include/flang/Lower/ConvertExpr.h index 12af639daceb..773f06a23dee 100644 --- a/flang/include/flang/Lower/ConvertExpr.h +++ b/flang/include/flang/Lower/ConvertExpr.h @@ -23,24 +23,22 @@ namespace mlir { class Location; -} +class Value; +} // namespace mlir -namespace Fortran::evaluate { -template -class Expr; -struct SomeType; -} // namespace Fortran::evaluate +namespace fir { +class AllocMemOp; +class ArrayLoadOp; +class ShapeOp; +} // namespace fir namespace Fortran::lower { class AbstractConverter; -class StatementContext; -class SymMap; class ExplicitIterSpace; class ImplicitIterSpace; class StatementContext; - -using SomeExpr = Fortran::evaluate::Expr; +class SymMap; /// Create an extended expression value. fir::ExtendedValue createSomeExtendedExpression(mlir::Location loc, @@ -87,30 +85,6 @@ fir::MutableBoxValue createMutableBox(mlir::Location loc, AbstractConverter &converter, const SomeExpr &expr, SymMap &symMap); -/// Lower an array expression to a value of type box. The expression must be a -/// variable. -fir::ExtendedValue createSomeArrayBox(AbstractConverter &converter, - const SomeExpr &expr, SymMap &symMap, - StatementContext &stmtCtx); - -/// Lower a subroutine call. This handles both elemental and non elemental -/// subroutines. \p isUserDefAssignment must be set if this is called in the -/// context of a user defined assignment. For subroutines with alternate -/// returns, the returned value indicates which label the code should jump to. -/// The returned value is null otherwise. -mlir::Value createSubroutineCall(AbstractConverter &converter, - const evaluate::ProcedureRef &call, - ExplicitIterSpace &explicitIterSpace, - ImplicitIterSpace &implicitIterSpace, - SymMap &symMap, StatementContext &stmtCtx, - bool isUserDefAssignment); - -/// Create the address of the box. -/// \p expr must be the designator of an allocatable/pointer entity. -fir::MutableBoxValue createMutableBox(mlir::Location loc, - AbstractConverter &converter, - const SomeExpr &expr, SymMap &symMap); - /// Create a fir::BoxValue describing the value of \p expr. /// If \p expr is a variable without vector subscripts, the fir::BoxValue /// described the variable storage. Otherwise, the created fir::BoxValue @@ -190,6 +164,22 @@ void createAnyMaskedArrayAssignment(AbstractConverter &converter, ImplicitIterSpace &implicitIterSpace, SymMap &symMap, StatementContext &stmtCtx); +/// In the context of a FORALL, a pointer assignment is allowed. The pointer +/// assignment can be elementwise on an array of pointers. The bounds +/// expressions as well as the component path may contain references to the +/// concurrent control variables. The explicit iteration space must be defined. +void createAnyArrayPointerAssignment( + AbstractConverter &converter, const SomeExpr &lhs, const SomeExpr &rhs, + const evaluate::Assignment::BoundsSpec &bounds, + ExplicitIterSpace &explicitIterSpace, ImplicitIterSpace &implicitIterSpace, + SymMap &symMap); +/// Support the bounds remapping flavor of pointer assignment. +void createAnyArrayPointerAssignment( + AbstractConverter &converter, const SomeExpr &lhs, const SomeExpr &rhs, + const evaluate::Assignment::BoundsRemapping &bounds, + ExplicitIterSpace &explicitIterSpace, ImplicitIterSpace &implicitIterSpace, + SymMap &symMap); + /// Lower an assignment to an allocatable array, allocating the array if /// it is not allocated yet or reallocation it if it does not conform /// with the right hand side. @@ -220,6 +210,24 @@ void createLazyArrayTempValue(AbstractConverter &converter, const SomeExpr &expr, mlir::Value raggedHeader, SymMap &symMap, StatementContext &stmtCtx); +/// Lower an array expression to a value of type box. The expression must be a +/// variable. +fir::ExtendedValue createSomeArrayBox(AbstractConverter &converter, + const SomeExpr &expr, SymMap &symMap, + StatementContext &stmtCtx); + +/// Lower a subroutine call. This handles both elemental and non elemental +/// subroutines. \p isUserDefAssignment must be set if this is called in the +/// context of a user defined assignment. For subroutines with alternate +/// returns, the returned value indicates which label the code should jump to. +/// The returned value is null otherwise. +mlir::Value createSubroutineCall(AbstractConverter &converter, + const evaluate::ProcedureRef &call, + ExplicitIterSpace &explicitIterSpace, + ImplicitIterSpace &implicitIterSpace, + SymMap &symMap, StatementContext &stmtCtx, + bool isUserDefAssignment); + // Attribute for an alloca that is a trivial adaptor for converting a value to // pass-by-ref semantics for a VALUE parameter. The optimizer may be able to // eliminate these. diff --git a/flang/include/flang/Lower/IntrinsicCall.h b/flang/include/flang/Lower/IntrinsicCall.h index 19b339bae15b..2267e2c22579 100644 --- a/flang/include/flang/Lower/IntrinsicCall.h +++ b/flang/include/flang/Lower/IntrinsicCall.h @@ -100,6 +100,10 @@ getUnrestrictedIntrinsicSymbolRefAttr(fir::FirOpBuilder &, mlir::Location, mlir::Value genMax(fir::FirOpBuilder &, mlir::Location, llvm::ArrayRef args); +/// Generate minimum. Same constraints as genMax. +mlir::Value genMin(fir::FirOpBuilder &, mlir::Location, + llvm::ArrayRef args); + /// Generate power function x**y with the given expected /// result type. mlir::Value genPow(fir::FirOpBuilder &, mlir::Location, mlir::Type resultType, diff --git a/flang/include/flang/Optimizer/Builder/Character.h b/flang/include/flang/Optimizer/Builder/Character.h index d1b5964a6b6b..e64a7044aec8 100644 --- a/flang/include/flang/Optimizer/Builder/Character.h +++ b/flang/include/flang/Optimizer/Builder/Character.h @@ -14,7 +14,11 @@ #define FORTRAN_OPTIMIZER_BUILDER_CHARACTER_H #include "flang/Optimizer/Builder/BoxValue.h" -#include "flang/Optimizer/Builder/FIRBuilder.h" +#include "flang/Optimizer/Builder/LowLevelIntrinsics.h" + +namespace fir { +class FirOpBuilder; +} namespace fir::factory { @@ -22,7 +26,7 @@ namespace fir::factory { class CharacterExprHelper { public: /// Constructor. - explicit CharacterExprHelper(fir::FirOpBuilder &builder, mlir::Location loc) + explicit CharacterExprHelper(FirOpBuilder &builder, mlir::Location loc) : builder{builder}, loc{loc} {} CharacterExprHelper(const CharacterExprHelper &) = delete; @@ -107,11 +111,15 @@ public: /// Extract the kind of a character or array of character type. static fir::KindTy getCharacterOrSequenceKind(mlir::Type type); + // TODO: Do we really need all these flavors of unwrapping to get the fir.char + // type? Or can we merge these? It would be better to merge them and eliminate + // the confusion. + /// Determine the inner character type. Unwraps references, boxes, and /// sequences to find the !fir.char element type. static fir::CharacterType getCharType(mlir::Type type); - /// Determine the base character type + /// Get fir.char type with the same kind as inside str. static fir::CharacterType getCharacterType(mlir::Type type); static fir::CharacterType getCharacterType(const fir::CharBoxValue &box); static fir::CharacterType getCharacterType(mlir::Value str); @@ -181,16 +189,11 @@ private: void createAssign(const fir::CharBoxValue &lhs, const fir::CharBoxValue &rhs); mlir::Value createBlankConstantCode(fir::CharacterType type); +private: FirOpBuilder &builder; mlir::Location loc; }; -// FIXME: Move these to Optimizer -mlir::FuncOp getLlvmMemcpy(FirOpBuilder &builder); -mlir::FuncOp getLlvmMemmove(FirOpBuilder &builder); -mlir::FuncOp getLlvmMemset(FirOpBuilder &builder); -mlir::FuncOp getRealloc(FirOpBuilder &builder); - //===----------------------------------------------------------------------===// // Tools to work with Character dummy procedures //===----------------------------------------------------------------------===// @@ -200,15 +203,6 @@ mlir::FuncOp getRealloc(FirOpBuilder &builder); /// one provided by \p funcPointerType. mlir::Type getCharacterProcedureTupleType(mlir::Type funcPointerType); -/// Is this tuple type holding a character function and its result length ? -bool isCharacterProcedureTuple(mlir::Type type); - -/// Is \p tuple a value holding a character function address and its result -/// length ? -inline bool isCharacterProcedureTuple(mlir::Value tuple) { - return isCharacterProcedureTuple(tuple.getType()); -} - /// Create a tuple given \p addr and \p len as well as the tuple /// type \p argTy. \p addr must be any function address, and \p len must be /// any integer. Converts will be inserted if needed if \addr and \p len diff --git a/flang/include/flang/Optimizer/Builder/FIRBuilder.h b/flang/include/flang/Optimizer/Builder/FIRBuilder.h index 9c7761d503dc..c2d42547f5eb 100644 --- a/flang/include/flang/Optimizer/Builder/FIRBuilder.h +++ b/flang/include/flang/Optimizer/Builder/FIRBuilder.h @@ -19,9 +19,10 @@ #include "flang/Optimizer/Dialect/FIROps.h" #include "flang/Optimizer/Dialect/FIRType.h" #include "flang/Optimizer/Support/KindMapping.h" -#include "mlir/Dialect/Func/IR/FuncOps.h" #include "mlir/IR/Builders.h" #include "mlir/IR/BuiltinOps.h" +#include "llvm/ADT/DenseMap.h" +#include "llvm/ADT/Optional.h" namespace fir { class AbstractArrayBox; @@ -104,7 +105,7 @@ public: return mlir::SymbolRefAttr::get(getContext(), str); } - /// Get the mlir real type that implements fortran REAL(kind). + /// Get the mlir float type that implements Fortran REAL(kind). mlir::Type getRealType(int kind); fir::BoxProcType getBoxProcType(mlir::FunctionType funcTy) { @@ -224,7 +225,6 @@ public: mlir::FuncOp getNamedFunction(llvm::StringRef name) { return getNamedFunction(getModule(), name); } - static mlir::FuncOp getNamedFunction(mlir::ModuleOp module, llvm::StringRef name); @@ -382,6 +382,9 @@ public: mlir::Value ub, mlir::Value step, mlir::Type type); + /// Dump the current function. (debug) + LLVM_DUMP_METHOD void dumpFunc(); + private: const KindMapping &kindMap; }; @@ -462,26 +465,15 @@ llvm::SmallVector createExtents(fir::FirOpBuilder &builder, mlir::Location loc, fir::SequenceType seqTy); -//===----------------------------------------------------------------------===// +//===--------------------------------------------------------------------===// // Location helpers -//===----------------------------------------------------------------------===// +//===--------------------------------------------------------------------===// /// Generate a string literal containing the file name and return its address mlir::Value locationToFilename(fir::FirOpBuilder &, mlir::Location); - /// Generate a constant of the given type with the location line number mlir::Value locationToLineNo(fir::FirOpBuilder &, mlir::Location, mlir::Type); -/// Builds and returns the type of a ragged array header used to cache mask -/// evaluations. RaggedArrayHeader is defined in -/// flang/include/flang/Runtime/ragged.h. -mlir::TupleType getRaggedArrayHeaderType(fir::FirOpBuilder &builder); - -/// Create the zero value of a given the numerical or logical \p type (`false` -/// for logical types). -mlir::Value createZeroValue(fir::FirOpBuilder &builder, mlir::Location loc, - mlir::Type type); - //===--------------------------------------------------------------------===// // ExtendedValue helpers //===--------------------------------------------------------------------===// @@ -523,6 +515,11 @@ void genRecordAssignment(fir::FirOpBuilder &builder, mlir::Location loc, const fir::ExtendedValue &lhs, const fir::ExtendedValue &rhs); +/// Builds and returns the type of a ragged array header used to cache mask +/// evaluations. RaggedArrayHeader is defined in +/// flang/include/flang/Runtime/ragged.h. +mlir::TupleType getRaggedArrayHeaderType(fir::FirOpBuilder &builder); + /// Generate the, possibly dynamic, LEN of a CHARACTER. \p arrLoad determines /// the base array. After applying \p path, the result must be a reference to a /// `!fir.char` type object. \p substring must have 0, 1, or 2 members. The @@ -537,6 +534,11 @@ mlir::Value genLenOfCharacter(fir::FirOpBuilder &builder, mlir::Location loc, llvm::ArrayRef path, llvm::ArrayRef substring); +/// Create the zero value of a given the numerical or logical \p type (`false` +/// for logical types). +mlir::Value createZeroValue(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Type type); + } // namespace fir::factory #endif // FORTRAN_OPTIMIZER_BUILDER_FIRBUILDER_H diff --git a/flang/include/flang/Optimizer/Builder/LowLevelIntrinsics.h b/flang/include/flang/Optimizer/Builder/LowLevelIntrinsics.h index edfb1e8e48ed..d59325b7218e 100644 --- a/flang/include/flang/Optimizer/Builder/LowLevelIntrinsics.h +++ b/flang/include/flang/Optimizer/Builder/LowLevelIntrinsics.h @@ -24,12 +24,30 @@ class FirOpBuilder; namespace fir::factory { +/// Get the LLVM intrinsic for `memcpy`. Use the 64 bit version. +mlir::func::FuncOp getLlvmMemcpy(FirOpBuilder &builder); + +/// Get the LLVM intrinsic for `memmove`. Use the 64 bit version. +mlir::func::FuncOp getLlvmMemmove(FirOpBuilder &builder); + +/// Get the LLVM intrinsic for `memset`. Use the 64 bit version. +mlir::func::FuncOp getLlvmMemset(FirOpBuilder &builder); + +/// Get the C standard library `realloc` function. +mlir::func::FuncOp getRealloc(FirOpBuilder &builder); + /// Get the `llvm.stacksave` intrinsic. mlir::func::FuncOp getLlvmStackSave(FirOpBuilder &builder); /// Get the `llvm.stackrestore` intrinsic. mlir::func::FuncOp getLlvmStackRestore(FirOpBuilder &builder); +/// Get the `llvm.init.trampoline` intrinsic. +mlir::func::FuncOp getLlvmInitTrampoline(FirOpBuilder &builder); + +/// Get the `llvm.adjust.trampoline` intrinsic. +mlir::func::FuncOp getLlvmAdjustTrampoline(FirOpBuilder &builder); + } // namespace fir::factory #endif // FLANG_OPTIMIZER_BUILDER_LOWLEVELINTRINSICS_H diff --git a/flang/include/flang/Optimizer/CodeGen/CGPasses.td b/flang/include/flang/Optimizer/CodeGen/CGPasses.td index 8aa75d1cb771..71e130a636dd 100644 --- a/flang/include/flang/Optimizer/CodeGen/CGPasses.td +++ b/flang/include/flang/Optimizer/CodeGen/CGPasses.td @@ -64,4 +64,14 @@ def TargetRewrite : Pass<"target-rewrite", "mlir::ModuleOp"> { ]; } +def BoxedProcedurePass : Pass<"boxed-procedure", "mlir::ModuleOp"> { + let constructor = "::fir::createBoxedProcedurePass()"; + let options = [ + Option<"useThunks", "use-thunks", + "bool", /*default=*/"true", + "Convert procedure pointer abstractions to a single code pointer, " + "deploying thunks wherever required."> + ]; +} + #endif // FORTRAN_OPTIMIZER_CODEGEN_FIR_PASSES diff --git a/flang/include/flang/Optimizer/CodeGen/CodeGen.h b/flang/include/flang/Optimizer/CodeGen/CodeGen.h index d7928974cfed..d89c6137e4a6 100644 --- a/flang/include/flang/Optimizer/CodeGen/CodeGen.h +++ b/flang/include/flang/Optimizer/CodeGen/CodeGen.h @@ -55,12 +55,18 @@ std::unique_ptr createFIRToLLVMPass(FIRToLLVMPassOptions options); using LLVMIRLoweringPrinter = std::function; + /// Convert the LLVM IR dialect to LLVM-IR proper std::unique_ptr createLLVMDialectToLLVMPass( llvm::raw_ostream &output, LLVMIRLoweringPrinter printer = [](llvm::Module &m, llvm::raw_ostream &out) { m.print(out, nullptr); }); +/// Convert boxproc values to a lower level representation. The default is to +/// use function pointers and thunks. +std::unique_ptr createBoxedProcedurePass(); +std::unique_ptr createBoxedProcedurePass(bool useThunks); + // declarative passes #define GEN_PASS_REGISTRATION #include "flang/Optimizer/CodeGen/CGPasses.h.inc" diff --git a/flang/include/flang/Optimizer/Dialect/FIROps.td b/flang/include/flang/Optimizer/Dialect/FIROps.td index b1cc2852487e..f66770983623 100644 --- a/flang/include/flang/Optimizer/Dialect/FIROps.td +++ b/flang/include/flang/Optimizer/Dialect/FIROps.td @@ -885,7 +885,8 @@ def fir_EmboxProcOp : fir_Op<"emboxproc", [NoSideEffect]> { then the form takes only the procedure's symbol. ```mlir - %0 = fir.emboxproc @f : ((i32) -> i32) -> !fir.boxproc<(i32) -> i32> + %f = ... : (i32) -> i32 + %0 = fir.emboxproc %f : ((i32) -> i32) -> !fir.boxproc<(i32) -> i32> ``` An internal procedure requiring a host instance for correct execution uses @@ -895,16 +896,20 @@ def fir_EmboxProcOp : fir_Op<"emboxproc", [NoSideEffect]> { promotion of local values. ```mlir - %4 = ... : !fir.ref> - %5 = fir.emboxproc @g, %4 : ((i32) -> i32, !fir.ref>) -> !fir.boxproc<(i32) -> i32> + %4 = ... : !fir.ref, !fir.ref>> + %g = ... : (i32) -> i32 + %5 = fir.emboxproc %g, %4 : ((i32) -> i32, !fir.ref, !fir.ref>>) -> !fir.boxproc<(i32) -> i32> ``` }]; - let arguments = (ins SymbolRefAttr:$funcname, AnyReferenceLike:$host); + let arguments = (ins FuncType:$func, Optional:$host); let results = (outs fir_BoxProcType); - let hasCustomAssemblyFormat = 1; + let assemblyFormat = [{ + $func (`,` $host^)? attr-dict `:` functional-type(operands, results) + }]; + let hasVerifier = 1; } @@ -958,13 +963,13 @@ def fir_BoxAddrOp : fir_SimpleOneResultOp<"box_addr", [NoSideEffect]> { ```mlir %51 = fir.box_addr %box : (!fir.box) -> !fir.ref %52 = fir.box_addr %boxchar : (!fir.boxchar<1>) -> !fir.ref> - %53 = fir.box_addr %boxproc : (!fir.boxproc) -> !fir.ref + %53 = fir.box_addr %boxproc : (!fir.boxproc) -> !P ``` }]; - let arguments = (ins fir_BoxType:$val); + let arguments = (ins AnyBoxLike:$val); - let results = (outs AnyReferenceLike); + let results = (outs AnyCodeOrDataRefLike); let hasFolder = 1; } diff --git a/flang/include/flang/Optimizer/Dialect/FIROpsSupport.h b/flang/include/flang/Optimizer/Dialect/FIROpsSupport.h index 59a82f2ad279..2324b28de684 100644 --- a/flang/include/flang/Optimizer/Dialect/FIROpsSupport.h +++ b/flang/include/flang/Optimizer/Dialect/FIROpsSupport.h @@ -15,16 +15,18 @@ namespace fir { -/// return true iff the Operation is a non-volatile LoadOp +/// Return true iff the Operation is a non-volatile LoadOp or ArrayLoadOp. inline bool nonVolatileLoad(mlir::Operation *op) { if (auto load = mlir::dyn_cast(op)) return !load->getAttr("volatile"); + if (auto arrLoad = mlir::dyn_cast(op)) + return !arrLoad->getAttr("volatile"); return false; } -/// return true iff the Operation is a call +/// Return true iff the Operation is a call. inline bool isaCall(mlir::Operation *op) { - return mlir::isa(op) || llvm::isa(op) || + return mlir::isa(op) || mlir::isa(op) || mlir::isa(op) || mlir::isa(op); } diff --git a/flang/include/flang/Optimizer/Dialect/FIRType.h b/flang/include/flang/Optimizer/Dialect/FIRType.h index a8bb67980a0b..70ad63d4e1db 100644 --- a/flang/include/flang/Optimizer/Dialect/FIRType.h +++ b/flang/include/flang/Optimizer/Dialect/FIRType.h @@ -78,9 +78,9 @@ inline bool isa_passbyref_type(mlir::Type t) { /// Is `t` a type that can conform to be pass-by-reference? Depending on the /// context, these types may simply demote to pass-by-reference or a reference -/// to them may have to be passed instead. +/// to them may have to be passed instead. Functions are always referent. inline bool conformsWithPassByRef(mlir::Type t) { - return isa_ref_type(t) || isa_box_type(t); + return isa_ref_type(t) || isa_box_type(t) || t.isa(); } /// Is `t` a derived (record) type? @@ -162,6 +162,16 @@ inline bool sequenceWithNonConstantShape(fir::SequenceType seqTy) { /// Returns true iff the type `t` does not have a constant size. bool hasDynamicSize(mlir::Type t); +inline unsigned getRankOfShapeType(mlir::Type t) { + if (auto shTy = t.dyn_cast()) + return shTy.getRank(); + if (auto shTy = t.dyn_cast()) + return shTy.getRank(); + if (auto shTy = t.dyn_cast()) + return shTy.getRank(); + return 0; +} + /// If `t` is a SequenceType return its element type, otherwise return `t`. inline mlir::Type unwrapSequenceType(mlir::Type t) { if (auto seqTy = t.dyn_cast()) @@ -183,6 +193,22 @@ inline mlir::Type unwrapPassByRefType(mlir::Type t) { return t; } +/// Unwrap all pointer and box types and return the element type if it is a +/// sequence type, otherwise return null. +inline fir::SequenceType unwrapUntilSeqType(mlir::Type t) { + while (true) { + if (!t) + return {}; + if (auto ty = dyn_cast_ptrOrBoxEleTy(t)) { + t = ty; + continue; + } + if (auto seqTy = t.dyn_cast()) + return seqTy; + return {}; + } +} + #ifndef NDEBUG // !fir.ptr and !fir.heap where X is !fir.ptr, !fir.heap, or !fir.ref // is undefined and disallowed. diff --git a/flang/include/flang/Optimizer/Dialect/FIRTypes.td b/flang/include/flang/Optimizer/Dialect/FIRTypes.td index 4db44bfb9262..2152a056f0d5 100644 --- a/flang/include/flang/Optimizer/Dialect/FIRTypes.td +++ b/flang/include/flang/Optimizer/Dialect/FIRTypes.td @@ -567,6 +567,11 @@ def AnyReferenceLike : TypeConstraint, "any reference">; +def FuncType : TypeConstraint; + +def AnyCodeOrDataRefLike : TypeConstraint, "any code or data reference">; + def RefOrLLVMPtr : TypeConstraint, "fir.ref or fir.llvm_ptr">; diff --git a/flang/include/flang/Tools/CLOptions.inc b/flang/include/flang/Tools/CLOptions.inc index adda9b410793..c81c1caa45e0 100644 --- a/flang/include/flang/Tools/CLOptions.inc +++ b/flang/include/flang/Tools/CLOptions.inc @@ -62,6 +62,8 @@ DisableOption(CodeGenRewrite, "codegen-rewrite", "rewrite FIR for codegen"); DisableOption(TargetRewrite, "target-rewrite", "rewrite FIR for target"); DisableOption(FirToLlvmIr, "fir-to-llvmir", "FIR to LLVM-IR dialect"); DisableOption(LlvmIrToLlvm, "llvm", "conversion to LLVM"); +DisableOption(BoxedProcedureRewrite, "boxed-procedure-rewrite", + "rewrite boxed procedures"); #endif /// Generic for adding a pass to the pass manager if it is not disabled. @@ -130,6 +132,11 @@ inline void addLLVMDialectToLLVMPass( addPassConditionally(pm, disableLlvmIrToLlvm, [&]() { return fir::createLLVMDialectToLLVMPass(output); }); } + +inline void addBoxedProcedurePass(mlir::PassManager &pm) { + addPassConditionally(pm, disableBoxedProcedureRewrite, + [&]() { return fir::createBoxedProcedurePass(); }); +} #endif /// Create a pass pipeline for running default optimization passes for @@ -163,6 +170,7 @@ inline void createDefaultFIROptimizerPassPipeline(mlir::PassManager &pm) { #if !defined(FLANG_EXCLUDE_CODEGEN) inline void createDefaultFIRCodeGenPassPipeline(mlir::PassManager &pm) { + fir::addBoxedProcedurePass(pm); pm.addNestedPass(fir::createAbstractResultOptPass()); fir::addCodeGenRewritePass(pm); fir::addTargetRewritePass(pm); diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp index a4185a47318c..0db94d47ee33 100644 --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -11,45 +11,56 @@ //===----------------------------------------------------------------------===// #include "flang/Lower/Bridge.h" -#include "flang/Evaluate/tools.h" #include "flang/Lower/Allocatable.h" #include "flang/Lower/CallInterface.h" +#include "flang/Lower/Coarray.h" #include "flang/Lower/ConvertExpr.h" #include "flang/Lower/ConvertType.h" #include "flang/Lower/ConvertVariable.h" +#include "flang/Lower/HostAssociations.h" #include "flang/Lower/IO.h" #include "flang/Lower/IterationSpace.h" #include "flang/Lower/Mangler.h" +#include "flang/Lower/OpenACC.h" #include "flang/Lower/OpenMP.h" #include "flang/Lower/PFTBuilder.h" #include "flang/Lower/Runtime.h" #include "flang/Lower/StatementContext.h" -#include "flang/Lower/SymbolMap.h" +#include "flang/Lower/Support/Utils.h" #include "flang/Lower/Todo.h" #include "flang/Optimizer/Builder/BoxValue.h" #include "flang/Optimizer/Builder/Character.h" -#include "flang/Optimizer/Builder/MutableBox.h" +#include "flang/Optimizer/Builder/FIRBuilder.h" #include "flang/Optimizer/Builder/Runtime/Character.h" #include "flang/Optimizer/Builder/Runtime/Ragged.h" #include "flang/Optimizer/Dialect/FIRAttr.h" +#include "flang/Optimizer/Dialect/FIRDialect.h" +#include "flang/Optimizer/Dialect/FIROps.h" #include "flang/Optimizer/Support/FIRContext.h" +#include "flang/Optimizer/Support/FatalError.h" #include "flang/Optimizer/Support/InternalNames.h" +#include "flang/Optimizer/Transforms/Passes.h" +#include "flang/Parser/parse-tree.h" #include "flang/Runtime/iostat.h" #include "flang/Semantics/tools.h" #include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h" #include "mlir/IR/PatternMatch.h" +#include "mlir/Parser/Parser.h" #include "mlir/Transforms/RegionUtils.h" #include "llvm/Support/CommandLine.h" #include "llvm/Support/Debug.h" +#include "llvm/Support/ErrorHandling.h" #define DEBUG_TYPE "flang-lower-bridge" -using namespace mlir; - static llvm::cl::opt dumpBeforeFir( "fdebug-dump-pre-fir", llvm::cl::init(false), llvm::cl::desc("dump the Pre-FIR tree prior to FIR generation")); +static llvm::cl::opt forceLoopToExecuteOnce( + "always-execute-loop-body", llvm::cl::init(false), + llvm::cl::desc("force the body of a loop to execute at least once")); + namespace { /// 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 @@ -110,6 +121,7 @@ private: /// creation. llvm::SmallSetVector seen; }; + } // namespace //===----------------------------------------------------------------------===// @@ -160,7 +172,12 @@ public: [&](Fortran::lower::pft::FunctionLikeUnit &f) { lowerFunc(f); }, [&](Fortran::lower::pft::ModuleLikeUnit &m) { lowerMod(m); }, [&](Fortran::lower::pft::BlockDataUnit &b) {}, - [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {}, + [&](Fortran::lower::pft::CompilerDirectiveUnit &d) { + setCurrentPosition( + d.get().source); + mlir::emitWarning(toLocation(), + "ignoring all compiler directives"); + }, }, u); } @@ -300,15 +317,15 @@ public: fir::ExtendedValue genExprAddr(const Fortran::lower::SomeExpr &expr, Fortran::lower::StatementContext &context, mlir::Location *loc = nullptr) override final { - return createSomeExtendedAddress(loc ? *loc : toLocation(), *this, expr, - localSymbols, context); + return Fortran::lower::createSomeExtendedAddress( + loc ? *loc : toLocation(), *this, expr, localSymbols, context); } fir::ExtendedValue genExprValue(const Fortran::lower::SomeExpr &expr, Fortran::lower::StatementContext &context, mlir::Location *loc = nullptr) override final { - return createSomeExtendedExpression(loc ? *loc : toLocation(), *this, expr, - localSymbols, context); + return Fortran::lower::createSomeExtendedExpression( + loc ? *loc : toLocation(), *this, expr, localSymbols, context); } fir::MutableBoxValue genExprMutableBox(mlir::Location loc, @@ -329,6 +346,9 @@ public: mlir::Type genType(const Fortran::lower::SomeExpr &expr) override final { return Fortran::lower::translateSomeExprToFIRType(*this, expr); } + mlir::Type genType(const Fortran::lower::pft::Variable &var) override final { + return Fortran::lower::translateVariableToFIRType(*this, var); + } mlir::Type genType(Fortran::lower::SymbolRef sym) override final { return Fortran::lower::translateSymbolToFIRType(*this, sym); } @@ -343,34 +363,9 @@ public: return Fortran::lower::translateDerivedTypeToFIRType(*this, tySpec); } mlir::Type genType(Fortran::common::TypeCategory tc) override final { - TODO_NOLOC("Not implemented genType TypeCategory. Needed for more complex " - "expression lowering"); - } - mlir::Type genType(const Fortran::lower::pft::Variable &var) override final { - return Fortran::lower::translateVariableToFIRType(*this, var); - } - - void setCurrentPosition(const Fortran::parser::CharBlock &position) { - if (position != Fortran::parser::CharBlock{}) - currentPosition = position; - } - - //===--------------------------------------------------------------------===// - // Utility methods - //===--------------------------------------------------------------------===// - - /// Convert a parser CharBlock to a Location - mlir::Location toLocation(const Fortran::parser::CharBlock &cb) { - return genLocation(cb); - } - - mlir::Location toLocation() { return toLocation(currentPosition); } - void setCurrentEval(Fortran::lower::pft::Evaluation &eval) { - evalPtr = &eval; - } - Fortran::lower::pft::Evaluation &getEval() { - assert(evalPtr && "current evaluation not set"); - return *evalPtr; + return Fortran::lower::getFIRType( + &getMLIRContext(), tc, bridge.getDefaultKinds().GetDefaultKind(tc), + llvm::None); } mlir::Location getCurrentLocation() override final { return toLocation(); } @@ -414,342 +409,6 @@ public: return bridge.getKindMap(); } - /// Return the predicate: "current block does not have a terminator branch". - bool blockIsUnterminated() { - mlir::Block *currentBlock = builder->getBlock(); - return currentBlock->empty() || - !currentBlock->back().hasTrait(); - } - - /// Unconditionally switch code insertion to a new block. - void startBlock(mlir::Block *newBlock) { - assert(newBlock && "missing block"); - // Default termination for the current block is a fallthrough branch to - // the new block. - if (blockIsUnterminated()) - genFIRBranch(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. - // Note that setting the insertion point causes the subsequent function - // call to check the existence of terminator in the newBlock. - builder->setInsertionPointToStart(newBlock); - if (blockIsUnterminated()) - builder->setInsertionPointToEnd(newBlock); - } - - /// Conditionally switch code insertion to a new block. - void maybeStartBlock(mlir::Block *newBlock) { - if (newBlock) - startBlock(newBlock); - } - - /// Emit return and cleanup after the function has been translated. - void endNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) { - setCurrentPosition(Fortran::lower::pft::stmtSourceLoc(funit.endStmt)); - if (funit.isMainProgram()) - genExitRoutine(); - else - genFIRProcedureExit(funit, funit.getSubprogramSymbol()); - funit.finalBlock = nullptr; - LLVM_DEBUG(llvm::dbgs() << "*** Lowering result:\n\n" - << *builder->getFunction() << '\n'); - // FIXME: Simplification should happen in a normal pass, not here. - mlir::IRRewriter rewriter(*builder); - (void)mlir::simplifyRegions(rewriter, - {builder->getRegion()}); // remove dead code - delete builder; - builder = nullptr; - hostAssocTuple = mlir::Value{}; - localSymbols.clear(); - } - - /// Helper to generate GlobalOps when the builder is not positioned in any - /// region block. This is required because the FirOpBuilder assumes it is - /// always positioned inside a region block when creating globals, the easiest - /// way comply is to create a dummy function and to throw it afterwards. - void createGlobalOutsideOfFunctionLowering( - const std::function &createGlobals) { - // FIXME: get rid of the bogus function context and instantiate the - // globals directly into the module. - MLIRContext *context = &getMLIRContext(); - mlir::FuncOp func = fir::FirOpBuilder::createFunction( - mlir::UnknownLoc::get(context), getModuleOp(), - fir::NameUniquer::doGenerated("Sham"), - mlir::FunctionType::get(context, llvm::None, llvm::None)); - func.addEntryBlock(); - builder = new fir::FirOpBuilder(func, bridge.getKindMap()); - createGlobals(); - if (mlir::Region *region = func.getCallableRegion()) - region->dropAllReferences(); - func.erase(); - delete builder; - builder = nullptr; - localSymbols.clear(); - } - /// Instantiate the data from a BLOCK DATA unit. - void lowerBlockData(Fortran::lower::pft::BlockDataUnit &bdunit) { - createGlobalOutsideOfFunctionLowering([&]() { - Fortran::lower::AggregateStoreMap fakeMap; - for (const auto &[_, sym] : bdunit.symTab) { - if (sym->has()) { - Fortran::lower::pft::Variable var(*sym, true); - instantiateVar(var, fakeMap); - } - } - }); - } - - /// Map mlir function block arguments to the corresponding Fortran dummy - /// variables. When the result is passed as a hidden argument, the Fortran - /// result is also mapped. The symbol map is used to hold this mapping. - void mapDummiesAndResults(Fortran::lower::pft::FunctionLikeUnit &funit, - const Fortran::lower::CalleeInterface &callee) { - assert(builder && "require a builder object at this point"); - using PassBy = Fortran::lower::CalleeInterface::PassEntityBy; - auto mapPassedEntity = [&](const auto arg) -> void { - if (arg.passBy == PassBy::AddressAndLength) { - // TODO: now that fir call has some attributes regarding character - // return, PassBy::AddressAndLength should be retired. - mlir::Location loc = toLocation(); - fir::factory::CharacterExprHelper charHelp{*builder, loc}; - mlir::Value box = - charHelp.createEmboxChar(arg.firArgument, arg.firLength); - addSymbol(arg.entity->get(), box); - } else { - if (arg.entity.has_value()) { - addSymbol(arg.entity->get(), arg.firArgument); - } else { - assert(funit.parentHasHostAssoc()); - funit.parentHostAssoc().internalProcedureBindings(*this, - localSymbols); - } - } - }; - for (const Fortran::lower::CalleeInterface::PassedEntity &arg : - callee.getPassedArguments()) - mapPassedEntity(arg); - - // Allocate local skeleton instances of dummies from other entry points. - // Most of these locals will not survive into final generated code, but - // some will. It is illegal to reference them at run time if they do. - for (const Fortran::semantics::Symbol *arg : - funit.nonUniversalDummyArguments) { - if (lookupSymbol(*arg)) - continue; - mlir::Type type = genType(*arg); - // TODO: Account for VALUE arguments (and possibly other variants). - type = builder->getRefType(type); - addSymbol(*arg, builder->create(toLocation(), type)); - } - if (std::optional - passedResult = callee.getPassedResult()) { - mapPassedEntity(*passedResult); - // FIXME: need to make sure things are OK here. addSymbol may not be OK - if (funit.primaryResult && - passedResult->entity->get() != *funit.primaryResult) - addSymbol(*funit.primaryResult, - getSymbolAddress(passedResult->entity->get())); - } - } - - /// Instantiate variable \p var and add it to the symbol map. - /// See ConvertVariable.cpp. - void instantiateVar(const Fortran::lower::pft::Variable &var, - Fortran::lower::AggregateStoreMap &storeMap) { - Fortran::lower::instantiateVariable(*this, var, localSymbols, storeMap); - } - - /// Prepare to translate a new function - void startNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) { - assert(!builder && "expected nullptr"); - Fortran::lower::CalleeInterface callee(funit, *this); - mlir::FuncOp func = callee.addEntryBlockAndMapArguments(); - func.setVisibility(mlir::SymbolTable::Visibility::Public); - builder = new fir::FirOpBuilder(func, bridge.getKindMap()); - assert(builder && "FirOpBuilder did not instantiate"); - builder->setInsertionPointToStart(&func.front()); - - mapDummiesAndResults(funit, callee); - - // Note: not storing Variable references because getOrderedSymbolTable - // below returns a temporary. - llvm::SmallVector deferredFuncResultList; - - // Backup actual argument for entry character results - // with different lengths. It needs to be added to the non - // primary results symbol before mapSymbolAttributes is called. - Fortran::lower::SymbolBox resultArg; - if (std::optional - passedResult = callee.getPassedResult()) - resultArg = lookupSymbol(passedResult->entity->get()); - - Fortran::lower::AggregateStoreMap storeMap; - // The front-end is currently not adding module variables referenced - // in a module procedure as host associated. As a result we need to - // instantiate all module variables here if this is a module procedure. - // It is likely that the front-end behavior should change here. - // This also applies to internal procedures inside module procedures. - if (auto *module = Fortran::lower::pft::getAncestor< - Fortran::lower::pft::ModuleLikeUnit>(funit)) - for (const Fortran::lower::pft::Variable &var : - module->getOrderedSymbolTable()) - instantiateVar(var, storeMap); - - mlir::Value primaryFuncResultStorage; - for (const Fortran::lower::pft::Variable &var : - funit.getOrderedSymbolTable()) { - // Always instantiate aggregate storage blocks. - if (var.isAggregateStore()) { - instantiateVar(var, storeMap); - continue; - } - const Fortran::semantics::Symbol &sym = var.getSymbol(); - if (funit.parentHasHostAssoc()) { - // Never instantitate host associated variables, as they are already - // instantiated from an argument tuple. Instead, just bind the symbol to - // the reference to the host variable, which must be in the map. - const Fortran::semantics::Symbol &ultimate = sym.GetUltimate(); - if (funit.parentHostAssoc().isAssociated(ultimate)) { - Fortran::lower::SymbolBox hostBox = - localSymbols.lookupSymbol(ultimate); - assert(hostBox && "host association is not in map"); - localSymbols.addSymbol(sym, hostBox.toExtendedValue()); - continue; - } - } - if (!sym.IsFuncResult() || !funit.primaryResult) { - instantiateVar(var, storeMap); - } else if (&sym == funit.primaryResult) { - instantiateVar(var, storeMap); - primaryFuncResultStorage = getSymbolAddress(sym); - } else { - deferredFuncResultList.push_back(var); - } - } - - // If this is a host procedure with host associations, then create the tuple - // of pointers for passing to the internal procedures. - if (!funit.getHostAssoc().empty()) - funit.getHostAssoc().hostProcedureBindings(*this, localSymbols); - - /// TODO: should use same mechanism as equivalence? - /// One blocking point is character entry returns that need special handling - /// since they are not locally allocated but come as argument. CHARACTER(*) - /// is not something that fit wells with equivalence lowering. - for (const Fortran::lower::pft::Variable &altResult : - deferredFuncResultList) { - if (std::optional - passedResult = callee.getPassedResult()) - addSymbol(altResult.getSymbol(), resultArg.getAddr()); - Fortran::lower::StatementContext stmtCtx; - Fortran::lower::mapSymbolAttributes(*this, altResult, localSymbols, - stmtCtx, primaryFuncResultStorage); - } - - // Create most function blocks in advance. - createEmptyGlobalBlocks(funit.evaluationList); - - // Reinstate entry block as the current insertion point. - builder->setInsertionPointToEnd(&func.front()); - - if (callee.hasAlternateReturns()) { - // Create a local temp to hold the alternate return index. - // Give it an integer index type and the subroutine name (for dumps). - // Attach it to the subroutine symbol in the localSymbols map. - // Initialize it to zero, the "fallthrough" alternate return value. - const Fortran::semantics::Symbol &symbol = funit.getSubprogramSymbol(); - mlir::Location loc = toLocation(); - mlir::Type idxTy = builder->getIndexType(); - mlir::Value altResult = - builder->createTemporary(loc, idxTy, toStringRef(symbol.name())); - addSymbol(symbol, altResult); - mlir::Value zero = builder->createIntegerConstant(loc, idxTy, 0); - builder->create(loc, zero, altResult); - } - - if (Fortran::lower::pft::Evaluation *alternateEntryEval = - funit.getEntryEval()) - genFIRBranch(alternateEntryEval->lexicalSuccessor->block); - } - - /// 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 - /// boundaries. - void createEmptyGlobalBlocks( - std::list &evaluationList) { - mlir::Region *region = &builder->getRegion(); - for (Fortran::lower::pft::Evaluation &eval : evaluationList) { - if (eval.isNewBlock) - eval.block = builder->createBlock(region); - if (eval.isConstruct() || eval.isDirective()) { - if (eval.lowerAsUnstructured()) { - createEmptyGlobalBlocks(eval.getNestedEvaluations()); - } else if (eval.hasNestedEvaluations()) { - // A structured construct that is a target starts a new block. - Fortran::lower::pft::Evaluation &constructStmt = - eval.getFirstNestedEvaluation(); - if (constructStmt.isNewBlock) - constructStmt.block = builder->createBlock(region); - } - } - } - } - - /// Lower a procedure (nest). - void lowerFunc(Fortran::lower::pft::FunctionLikeUnit &funit) { - if (!funit.isMainProgram()) { - const Fortran::semantics::Symbol &procSymbol = - funit.getSubprogramSymbol(); - if (procSymbol.owner().IsSubmodule()) { - TODO(toLocation(), "support submodules"); - return; - } - } - setCurrentPosition(funit.getStartingSourceLoc()); - for (int entryIndex = 0, last = funit.entryPointList.size(); - entryIndex < last; ++entryIndex) { - funit.setActiveEntry(entryIndex); - startNewFunction(funit); // the entry point for lowering this procedure - for (Fortran::lower::pft::Evaluation &eval : funit.evaluationList) - genFIR(eval); - endNewFunction(funit); - } - funit.setActiveEntry(0); - for (Fortran::lower::pft::FunctionLikeUnit &f : funit.nestedFunctions) - lowerFunc(f); // internal procedure - } - - /// Lower module variable definitions to fir::globalOp and OpenMP/OpenACC - /// declarative construct. - void lowerModuleDeclScope(Fortran::lower::pft::ModuleLikeUnit &mod) { - setCurrentPosition(mod.getStartingSourceLoc()); - createGlobalOutsideOfFunctionLowering([&]() { - for (const Fortran::lower::pft::Variable &var : - mod.getOrderedSymbolTable()) { - // Only define the variables owned by this module. - const Fortran::semantics::Scope *owningScope = var.getOwningScope(); - if (!owningScope || mod.getScope() == *owningScope) - Fortran::lower::defineModuleVariable(*this, var); - } - for (auto &eval : mod.evaluationList) - genFIR(eval); - }); - } - - /// Lower functions contained in a module. - void lowerMod(Fortran::lower::pft::ModuleLikeUnit &mod) { - for (Fortran::lower::pft::FunctionLikeUnit &f : mod.nestedFunctions) - lowerFunc(f); - } - mlir::Value hostAssocTupleValue() override final { return hostAssocTuple; } /// Record a binding for the ssa-value of the tuple for this function. @@ -806,7 +465,26 @@ private: return true; } - bool isNumericScalarCategory(Fortran::common::TypeCategory cat) { + bool addCharSymbol(const Fortran::semantics::SymbolRef sym, mlir::Value val, + mlir::Value len, bool forced = false) { + if (!forced && lookupSymbol(sym)) + return false; + // TODO: ensure val type is fir.array> like. Insert + // cast if needed. + localSymbols.addCharSymbol(sym, val, len, forced); + return true; + } + + fir::ExtendedValue getExtendedValue(Fortran::lower::SymbolBox sb) { + return sb.match( + [&](const Fortran::lower::SymbolBox::PointerOrAllocatable &box) { + return fir::factory::genMutableBoxRead(*builder, getCurrentLocation(), + box); + }, + [&sb](auto &) { return sb.toExtendedValue(); }); + } + + static bool isNumericScalarCategory(Fortran::common::TypeCategory cat) { return cat == Fortran::common::TypeCategory::Integer || cat == Fortran::common::TypeCategory::Real || cat == Fortran::common::TypeCategory::Complex || @@ -815,10 +493,10 @@ private: static bool isLogicalCategory(Fortran::common::TypeCategory cat) { return cat == Fortran::common::TypeCategory::Logical; } - bool isCharacterCategory(Fortran::common::TypeCategory cat) { + static bool isCharacterCategory(Fortran::common::TypeCategory cat) { return cat == Fortran::common::TypeCategory::Character; } - bool isDerivedCategory(Fortran::common::TypeCategory cat) { + static bool isDerivedCategory(Fortran::common::TypeCategory cat) { return cat == Fortran::common::TypeCategory::Derived; } @@ -843,7 +521,7 @@ private: void genFIRBranch(mlir::Block *targetBlock) { assert(targetBlock && "missing unconditional target block"); - builder->create(toLocation(), targetBlock); + builder->create(toLocation(), targetBlock); } void genFIRConditionalBranch(mlir::Value cond, mlir::Block *trueTarget, @@ -975,227 +653,12 @@ private: return cond; } - static bool - isArraySectionWithoutVectorSubscript(const Fortran::lower::SomeExpr &expr) { - return expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) && - !Fortran::evaluate::UnwrapWholeSymbolDataRef(expr) && - !Fortran::evaluate::HasVectorSubscript(expr); - } - - [[maybe_unused]] static bool - isFuncResultDesignator(const Fortran::lower::SomeExpr &expr) { - const Fortran::semantics::Symbol *sym = - Fortran::evaluate::GetFirstSymbol(expr); - return sym && sym->IsFuncResult(); - } - - static bool isWholeAllocatable(const Fortran::lower::SomeExpr &expr) { - const Fortran::semantics::Symbol *sym = - Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr); - return sym && Fortran::semantics::IsAllocatable(*sym); - } - - /// Shared for both assignments and pointer assignments. - void genAssignment(const Fortran::evaluate::Assignment &assign) { - Fortran::lower::StatementContext stmtCtx; - mlir::Location loc = toLocation(); - if (explicitIterationSpace()) { - Fortran::lower::createArrayLoads(*this, explicitIterSpace, localSymbols); - explicitIterSpace.genLoopNest(); + mlir::FuncOp getFunc(llvm::StringRef name, mlir::FunctionType ty) { + if (mlir::FuncOp func = builder->getNamedFunction(name)) { + assert(func.getFunctionType() == ty); + return func; } - std::visit( - Fortran::common::visitors{ - // [1] Plain old assignment. - [&](const Fortran::evaluate::Assignment::Intrinsic &) { - const Fortran::semantics::Symbol *sym = - Fortran::evaluate::GetLastSymbol(assign.lhs); - - if (!sym) - TODO(loc, "assignment to pointer result of function reference"); - - std::optional lhsType = - assign.lhs.GetType(); - assert(lhsType && "lhs cannot be typeless"); - // Assignment to polymorphic allocatables may require changing the - // variable dynamic type (See Fortran 2018 10.2.1.3 p3). - if (lhsType->IsPolymorphic() && isWholeAllocatable(assign.lhs)) - TODO(loc, "assignment to polymorphic allocatable"); - - // Note: No ad-hoc handling for pointers is required here. The - // target will be assigned as per 2018 10.2.1.3 p2. genExprAddr - // on a pointer returns the target address and not the address of - // the pointer variable. - - if (assign.lhs.Rank() > 0 || explicitIterationSpace()) { - // Array assignment - // See Fortran 2018 10.2.1.3 p5, p6, and p7 - genArrayAssignment(assign, stmtCtx); - return; - } - - // Scalar assignment - const bool isNumericScalar = - isNumericScalarCategory(lhsType->category()); - fir::ExtendedValue rhs = isNumericScalar - ? genExprValue(assign.rhs, stmtCtx) - : genExprAddr(assign.rhs, stmtCtx); - bool lhsIsWholeAllocatable = isWholeAllocatable(assign.lhs); - llvm::Optional lhsRealloc; - llvm::Optional lhsMutableBox; - auto lhs = [&]() -> fir::ExtendedValue { - if (lhsIsWholeAllocatable) { - lhsMutableBox = genExprMutableBox(loc, assign.lhs); - llvm::SmallVector lengthParams; - if (const fir::CharBoxValue *charBox = rhs.getCharBox()) - lengthParams.push_back(charBox->getLen()); - else if (fir::isDerivedWithLengthParameters(rhs)) - TODO(loc, "assignment to derived type allocatable with " - "length parameters"); - lhsRealloc = fir::factory::genReallocIfNeeded( - *builder, loc, *lhsMutableBox, - /*shape=*/llvm::None, lengthParams); - return lhsRealloc->newValue; - } - return genExprAddr(assign.lhs, stmtCtx); - }(); - - if (isNumericScalar) { - // Fortran 2018 10.2.1.3 p8 and p9 - // Conversions should have been inserted by semantic analysis, - // but they can be incorrect between the rhs and lhs. Correct - // that here. - mlir::Value addr = fir::getBase(lhs); - 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 - // to a result variable of one of the other types requires - // conversion to the actual type. - mlir::Type toTy = genType(assign.lhs); - mlir::Value cast = - builder->convertWithSemantics(loc, toTy, val); - if (fir::dyn_cast_ptrEleTy(addr.getType()) != toTy) { - assert(isFuncResultDesignator(assign.lhs) && "type mismatch"); - addr = builder->createConvert( - toLocation(), builder->getRefType(toTy), addr); - } - builder->create(loc, cast, addr); - } else if (isCharacterCategory(lhsType->category())) { - // Fortran 2018 10.2.1.3 p10 and p11 - fir::factory::CharacterExprHelper{*builder, loc}.createAssign( - lhs, rhs); - } else if (isDerivedCategory(lhsType->category())) { - // Fortran 2018 10.2.1.3 p13 and p14 - // Recursively gen an assignment on each element pair. - fir::factory::genRecordAssignment(*builder, loc, lhs, rhs); - } else { - llvm_unreachable("unknown category"); - } - if (lhsIsWholeAllocatable) - fir::factory::finalizeRealloc( - *builder, loc, lhsMutableBox.getValue(), - /*lbounds=*/llvm::None, /*takeLboundsIfRealloc=*/false, - lhsRealloc.getValue()); - }, - - // [2] User defined assignment. If the context is a scalar - // expression then call the procedure. - [&](const Fortran::evaluate::ProcedureRef &procRef) { - Fortran::lower::StatementContext &ctx = - explicitIterationSpace() ? explicitIterSpace.stmtContext() - : stmtCtx; - Fortran::lower::createSubroutineCall( - *this, procRef, explicitIterSpace, implicitIterSpace, - localSymbols, ctx, /*isUserDefAssignment=*/true); - }, - - // [3] Pointer assignment with possibly empty bounds-spec. R1035: a - // bounds-spec is a lower bound value. - [&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) { - if (IsProcedure(assign.rhs)) - TODO(loc, "procedure pointer assignment"); - std::optional lhsType = - assign.lhs.GetType(); - std::optional rhsType = - assign.rhs.GetType(); - // Polymorphic lhs/rhs may need more care. See F2018 10.2.2.3. - if ((lhsType && lhsType->IsPolymorphic()) || - (rhsType && rhsType->IsPolymorphic())) - TODO(loc, "pointer assignment involving polymorphic entity"); - - // FIXME: in the explicit space context, we want to use - // ScalarArrayExprLowering here. - fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs); - llvm::SmallVector lbounds; - for (const Fortran::evaluate::ExtentExpr &lbExpr : lbExprs) - lbounds.push_back( - fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx))); - Fortran::lower::associateMutableBox(*this, loc, lhs, assign.rhs, - lbounds, stmtCtx); - if (explicitIterationSpace()) { - mlir::ValueRange inners = explicitIterSpace.getInnerArgs(); - if (!inners.empty()) { - // TODO: should force a copy-in/copy-out here. - // e.g., obj%ptr(i+1) => obj%ptr(i) - builder->create(loc, inners); - } - } - }, - - // [4] Pointer assignment with bounds-remapping. R1036: a - // bounds-remapping is a pair, lower bound and upper bound. - [&](const Fortran::evaluate::Assignment::BoundsRemapping - &boundExprs) { - std::optional lhsType = - assign.lhs.GetType(); - std::optional rhsType = - assign.rhs.GetType(); - // Polymorphic lhs/rhs may need more care. See F2018 10.2.2.3. - if ((lhsType && lhsType->IsPolymorphic()) || - (rhsType && rhsType->IsPolymorphic())) - TODO(loc, "pointer assignment involving polymorphic entity"); - - // FIXME: in the explicit space context, we want to use - // ScalarArrayExprLowering here. - fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs); - if (Fortran::evaluate::UnwrapExpr( - assign.rhs)) { - fir::factory::disassociateMutableBox(*builder, loc, lhs); - return; - } - llvm::SmallVector lbounds; - llvm::SmallVector ubounds; - for (const std::pair &pair : - boundExprs) { - const Fortran::evaluate::ExtentExpr &lbExpr = pair.first; - const Fortran::evaluate::ExtentExpr &ubExpr = pair.second; - lbounds.push_back( - fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx))); - ubounds.push_back( - fir::getBase(genExprValue(toEvExpr(ubExpr), stmtCtx))); - } - // Do not generate a temp in case rhs is an array section. - fir::ExtendedValue rhs = - isArraySectionWithoutVectorSubscript(assign.rhs) - ? Fortran::lower::createSomeArrayBox( - *this, assign.rhs, localSymbols, stmtCtx) - : genExprAddr(assign.rhs, stmtCtx); - fir::factory::associateMutableBoxWithRemap(*builder, loc, lhs, - rhs, lbounds, ubounds); - if (explicitIterationSpace()) { - mlir::ValueRange inners = explicitIterSpace.getInnerArgs(); - if (!inners.empty()) { - // TODO: should force a copy-in/copy-out here. - // e.g., obj%ptr(i+1) => obj%ptr(i) - builder->create(loc, inners); - } - } - }, - }, - assign.u); - if (explicitIterationSpace()) - Fortran::lower::createArrayMergeStores(*this, explicitIterSpace); + return builder->createFunction(toLocation(), name, ty); } /// Lowering of CALL statement @@ -1264,7 +727,7 @@ private: if (exprType.isSignlessInteger()) { // Arithmetic expression has Integer type. Generate a SelectCaseOp // with ranges {(-inf:-1], 0=default, [1:inf)}. - MLIRContext *context = builder->getContext(); + mlir::MLIRContext *context = builder->getContext(); llvm::SmallVector attrList; llvm::SmallVector valueList; llvm::SmallVector blockList; @@ -1350,10 +813,16 @@ private: builder->create(loc, selectExpr, indexList, blockList); } + /// Generate FIR for a DO construct. There are six variants: + /// - unstructured infinite and while loops + /// - structured and unstructured increment loops + /// - structured and unstructured concurrent loops void genFIR(const Fortran::parser::DoConstruct &doConstruct) { TODO(toLocation(), "DoConstruct lowering"); } + /// Generate structured or unstructured FIR for an IF construct. + /// The initial statement may be either an IfStmt or an IfThenStmt. void genFIR(const Fortran::parser::IfConstruct &) { mlir::Location loc = toLocation(); Fortran::lower::pft::Evaluation &eval = getEval(); @@ -1639,7 +1108,7 @@ private: builder->restoreInsertionPoint(insertPt); } - void genFIR(const Fortran::parser::OpenMPDeclarativeConstruct &) { + void genFIR(const Fortran::parser::OpenMPDeclarativeConstruct &ompDecl) { TODO(toLocation(), "OpenMPDeclarativeConstruct lowering"); } @@ -1647,7 +1116,7 @@ private: /// The type may be CHARACTER, INTEGER, or LOGICAL. void genFIR(const Fortran::parser::SelectCaseStmt &stmt) { Fortran::lower::pft::Evaluation &eval = getEval(); - MLIRContext *context = builder->getContext(); + mlir::MLIRContext *context = builder->getContext(); mlir::Location loc = toLocation(); Fortran::lower::StatementContext stmtCtx; const Fortran::lower::SomeExpr *expr = Fortran::semantics::GetExpr( @@ -1846,13 +1315,12 @@ private: } void genFIR(const Fortran::parser::BlockConstruct &blockConstruct) { + setCurrentPositionAt(blockConstruct); TODO(toLocation(), "BlockConstruct lowering"); } - void genFIR(const Fortran::parser::BlockStmt &) { TODO(toLocation(), "BlockStmt lowering"); } - void genFIR(const Fortran::parser::EndBlockStmt &) { TODO(toLocation(), "EndBlockStmt lowering"); } @@ -1860,47 +1328,42 @@ private: void genFIR(const Fortran::parser::ChangeTeamConstruct &construct) { TODO(toLocation(), "ChangeTeamConstruct lowering"); } - void genFIR(const Fortran::parser::ChangeTeamStmt &stmt) { TODO(toLocation(), "ChangeTeamStmt lowering"); } - void genFIR(const Fortran::parser::EndChangeTeamStmt &stmt) { TODO(toLocation(), "EndChangeTeamStmt lowering"); } void genFIR(const Fortran::parser::CriticalConstruct &criticalConstruct) { + setCurrentPositionAt(criticalConstruct); TODO(toLocation(), "CriticalConstruct lowering"); } - void genFIR(const Fortran::parser::CriticalStmt &) { TODO(toLocation(), "CriticalStmt lowering"); } - void genFIR(const Fortran::parser::EndCriticalStmt &) { TODO(toLocation(), "EndCriticalStmt lowering"); } void genFIR(const Fortran::parser::SelectRankConstruct &selectRankConstruct) { + setCurrentPositionAt(selectRankConstruct); TODO(toLocation(), "SelectRankConstruct lowering"); } - void genFIR(const Fortran::parser::SelectRankStmt &) { TODO(toLocation(), "SelectRankStmt lowering"); } - void genFIR(const Fortran::parser::SelectRankCaseStmt &) { TODO(toLocation(), "SelectRankCaseStmt lowering"); } void genFIR(const Fortran::parser::SelectTypeConstruct &selectTypeConstruct) { + setCurrentPositionAt(selectTypeConstruct); TODO(toLocation(), "SelectTypeConstruct lowering"); } - void genFIR(const Fortran::parser::SelectTypeStmt &) { TODO(toLocation(), "SelectTypeStmt lowering"); } - void genFIR(const Fortran::parser::TypeGuardStmt &) { TODO(toLocation(), "TypeGuardStmt lowering"); } @@ -1913,53 +1376,43 @@ private: mlir::Value iostat = genBackspaceStatement(*this, stmt); genIoConditionBranches(getEval(), stmt.v, iostat); } - void genFIR(const Fortran::parser::CloseStmt &stmt) { mlir::Value iostat = genCloseStatement(*this, stmt); genIoConditionBranches(getEval(), stmt.v, iostat); } - void genFIR(const Fortran::parser::EndfileStmt &stmt) { mlir::Value iostat = genEndfileStatement(*this, stmt); genIoConditionBranches(getEval(), stmt.v, iostat); } - void genFIR(const Fortran::parser::FlushStmt &stmt) { mlir::Value iostat = genFlushStatement(*this, stmt); genIoConditionBranches(getEval(), stmt.v, iostat); } - void genFIR(const Fortran::parser::InquireStmt &stmt) { mlir::Value iostat = genInquireStatement(*this, stmt); if (const auto *specs = std::get_if>(&stmt.u)) genIoConditionBranches(getEval(), *specs, iostat); } - void genFIR(const Fortran::parser::OpenStmt &stmt) { mlir::Value iostat = genOpenStatement(*this, stmt); genIoConditionBranches(getEval(), stmt.v, iostat); } - void genFIR(const Fortran::parser::PrintStmt &stmt) { genPrintStatement(*this, stmt); } - void genFIR(const Fortran::parser::ReadStmt &stmt) { mlir::Value iostat = genReadStatement(*this, stmt); genIoConditionBranches(getEval(), stmt.controls, iostat); } - void genFIR(const Fortran::parser::RewindStmt &stmt) { mlir::Value iostat = genRewindStatement(*this, stmt); genIoConditionBranches(getEval(), stmt.v, iostat); } - void genFIR(const Fortran::parser::WaitStmt &stmt) { mlir::Value iostat = genWaitStatement(*this, stmt); genIoConditionBranches(getEval(), stmt.v, iostat); } - void genFIR(const Fortran::parser::WriteStmt &stmt) { mlir::Value iostat = genWriteStatement(*this, stmt); genIoConditionBranches(getEval(), stmt.controls, iostat); @@ -2061,6 +1514,13 @@ private: TODO(toLocation(), "LockStmt lowering"); } + fir::ExtendedValue + genInitializerExprValue(const Fortran::lower::SomeExpr &expr, + Fortran::lower::StatementContext &stmtCtx) { + return Fortran::lower::createSomeInitializerExpression( + toLocation(), *this, expr, localSymbols, stmtCtx); + } + /// Return true if the current context is a conditionalized and implied /// iteration space. bool implicitIterationSpace() { return !implicitIterSpace.empty(); } @@ -2108,6 +1568,230 @@ private: : implicitIterSpace.stmtContext()); } + static bool + isArraySectionWithoutVectorSubscript(const Fortran::lower::SomeExpr &expr) { + return expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) && + !Fortran::evaluate::UnwrapWholeSymbolDataRef(expr) && + !Fortran::evaluate::HasVectorSubscript(expr); + } + +#if !defined(NDEBUG) + static bool isFuncResultDesignator(const Fortran::lower::SomeExpr &expr) { + const Fortran::semantics::Symbol *sym = + Fortran::evaluate::GetFirstSymbol(expr); + return sym && sym->IsFuncResult(); + } +#endif + + static bool isWholeAllocatable(const Fortran::lower::SomeExpr &expr) { + const Fortran::semantics::Symbol *sym = + Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr); + return sym && Fortran::semantics::IsAllocatable(*sym); + } + + /// Shared for both assignments and pointer assignments. + void genAssignment(const Fortran::evaluate::Assignment &assign) { + Fortran::lower::StatementContext stmtCtx; + mlir::Location loc = toLocation(); + if (explicitIterationSpace()) { + Fortran::lower::createArrayLoads(*this, explicitIterSpace, localSymbols); + explicitIterSpace.genLoopNest(); + } + std::visit( + Fortran::common::visitors{ + // [1] Plain old assignment. + [&](const Fortran::evaluate::Assignment::Intrinsic &) { + const Fortran::semantics::Symbol *sym = + Fortran::evaluate::GetLastSymbol(assign.lhs); + + if (!sym) + TODO(loc, "assignment to pointer result of function reference"); + + std::optional lhsType = + assign.lhs.GetType(); + assert(lhsType && "lhs cannot be typeless"); + // Assignment to polymorphic allocatables may require changing the + // variable dynamic type (See Fortran 2018 10.2.1.3 p3). + if (lhsType->IsPolymorphic() && isWholeAllocatable(assign.lhs)) + TODO(loc, "assignment to polymorphic allocatable"); + + // Note: No ad-hoc handling for pointers is required here. The + // target will be assigned as per 2018 10.2.1.3 p2. genExprAddr + // on a pointer returns the target address and not the address of + // the pointer variable. + + if (assign.lhs.Rank() > 0 || explicitIterationSpace()) { + // Array assignment + // See Fortran 2018 10.2.1.3 p5, p6, and p7 + genArrayAssignment(assign, stmtCtx); + return; + } + + // Scalar assignment + const bool isNumericScalar = + isNumericScalarCategory(lhsType->category()); + fir::ExtendedValue rhs = isNumericScalar + ? genExprValue(assign.rhs, stmtCtx) + : genExprAddr(assign.rhs, stmtCtx); + bool lhsIsWholeAllocatable = isWholeAllocatable(assign.lhs); + llvm::Optional lhsRealloc; + llvm::Optional lhsMutableBox; + auto lhs = [&]() -> fir::ExtendedValue { + if (lhsIsWholeAllocatable) { + lhsMutableBox = genExprMutableBox(loc, assign.lhs); + llvm::SmallVector lengthParams; + if (const fir::CharBoxValue *charBox = rhs.getCharBox()) + lengthParams.push_back(charBox->getLen()); + else if (fir::isDerivedWithLengthParameters(rhs)) + TODO(loc, "assignment to derived type allocatable with " + "length parameters"); + lhsRealloc = fir::factory::genReallocIfNeeded( + *builder, loc, *lhsMutableBox, + /*shape=*/llvm::None, lengthParams); + return lhsRealloc->newValue; + } + return genExprAddr(assign.lhs, stmtCtx); + }(); + + if (isNumericScalar) { + // Fortran 2018 10.2.1.3 p8 and p9 + // Conversions should have been inserted by semantic analysis, + // but they can be incorrect between the rhs and lhs. Correct + // that here. + mlir::Value addr = fir::getBase(lhs); + 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 + // to a result variable of one of the other types requires + // conversion to the actual type. + mlir::Type toTy = genType(assign.lhs); + mlir::Value cast = + builder->convertWithSemantics(loc, toTy, val); + if (fir::dyn_cast_ptrEleTy(addr.getType()) != toTy) { + assert(isFuncResultDesignator(assign.lhs) && "type mismatch"); + addr = builder->createConvert( + toLocation(), builder->getRefType(toTy), addr); + } + builder->create(loc, cast, addr); + } else if (isCharacterCategory(lhsType->category())) { + // Fortran 2018 10.2.1.3 p10 and p11 + fir::factory::CharacterExprHelper{*builder, loc}.createAssign( + lhs, rhs); + } else if (isDerivedCategory(lhsType->category())) { + // Fortran 2018 10.2.1.3 p13 and p14 + // Recursively gen an assignment on each element pair. + fir::factory::genRecordAssignment(*builder, loc, lhs, rhs); + } else { + llvm_unreachable("unknown category"); + } + if (lhsIsWholeAllocatable) + fir::factory::finalizeRealloc( + *builder, loc, lhsMutableBox.getValue(), + /*lbounds=*/llvm::None, /*takeLboundsIfRealloc=*/false, + lhsRealloc.getValue()); + }, + + // [2] User defined assignment. If the context is a scalar + // expression then call the procedure. + [&](const Fortran::evaluate::ProcedureRef &procRef) { + Fortran::lower::StatementContext &ctx = + explicitIterationSpace() ? explicitIterSpace.stmtContext() + : stmtCtx; + Fortran::lower::createSubroutineCall( + *this, procRef, explicitIterSpace, implicitIterSpace, + localSymbols, ctx, /*isUserDefAssignment=*/true); + }, + + // [3] Pointer assignment with possibly empty bounds-spec. R1035: a + // bounds-spec is a lower bound value. + [&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) { + if (IsProcedure(assign.rhs)) + TODO(loc, "procedure pointer assignment"); + std::optional lhsType = + assign.lhs.GetType(); + std::optional rhsType = + assign.rhs.GetType(); + // Polymorphic lhs/rhs may need more care. See F2018 10.2.2.3. + if ((lhsType && lhsType->IsPolymorphic()) || + (rhsType && rhsType->IsPolymorphic())) + TODO(loc, "pointer assignment involving polymorphic entity"); + + // FIXME: in the explicit space context, we want to use + // ScalarArrayExprLowering here. + fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs); + llvm::SmallVector lbounds; + for (const Fortran::evaluate::ExtentExpr &lbExpr : lbExprs) + lbounds.push_back( + fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx))); + Fortran::lower::associateMutableBox(*this, loc, lhs, assign.rhs, + lbounds, stmtCtx); + if (explicitIterationSpace()) { + mlir::ValueRange inners = explicitIterSpace.getInnerArgs(); + if (!inners.empty()) { + // TODO: should force a copy-in/copy-out here. + // e.g., obj%ptr(i+1) => obj%ptr(i) + builder->create(loc, inners); + } + } + }, + + // [4] Pointer assignment with bounds-remapping. R1036: a + // bounds-remapping is a pair, lower bound and upper bound. + [&](const Fortran::evaluate::Assignment::BoundsRemapping + &boundExprs) { + std::optional lhsType = + assign.lhs.GetType(); + std::optional rhsType = + assign.rhs.GetType(); + // Polymorphic lhs/rhs may need more care. See F2018 10.2.2.3. + if ((lhsType && lhsType->IsPolymorphic()) || + (rhsType && rhsType->IsPolymorphic())) + TODO(loc, "pointer assignment involving polymorphic entity"); + + // FIXME: in the explicit space context, we want to use + // ScalarArrayExprLowering here. + fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs); + if (Fortran::evaluate::UnwrapExpr( + assign.rhs)) { + fir::factory::disassociateMutableBox(*builder, loc, lhs); + return; + } + llvm::SmallVector lbounds; + llvm::SmallVector ubounds; + for (const std::pair &pair : + boundExprs) { + const Fortran::evaluate::ExtentExpr &lbExpr = pair.first; + const Fortran::evaluate::ExtentExpr &ubExpr = pair.second; + lbounds.push_back( + fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx))); + ubounds.push_back( + fir::getBase(genExprValue(toEvExpr(ubExpr), stmtCtx))); + } + // Do not generate a temp in case rhs is an array section. + fir::ExtendedValue rhs = + isArraySectionWithoutVectorSubscript(assign.rhs) + ? Fortran::lower::createSomeArrayBox( + *this, assign.rhs, localSymbols, stmtCtx) + : genExprAddr(assign.rhs, stmtCtx); + fir::factory::associateMutableBoxWithRemap(*builder, loc, lhs, + rhs, lbounds, ubounds); + if (explicitIterationSpace()) { + mlir::ValueRange inners = explicitIterSpace.getInnerArgs(); + if (!inners.empty()) { + // TODO: should force a copy-in/copy-out here. + // e.g., obj%ptr(i+1) => obj%ptr(i) + builder->create(loc, inners); + } + } + }, + }, + assign.u); + if (explicitIterationSpace()) + Fortran::lower::createArrayMergeStores(*this, explicitIterSpace); + } + void genFIR(const Fortran::parser::WhereConstruct &c) { implicitIterSpace.growStack(); genNestedStatement( @@ -2234,6 +1918,7 @@ private: genPauseStatement(*this, stmt); } + // call FAIL IMAGE in runtime void genFIR(const Fortran::parser::FailImageStmt &stmt) { TODO(toLocation(), "FailImageStmt lowering"); } @@ -2279,51 +1964,34 @@ private: } void genFIR(const Fortran::parser::CycleStmt &) { - TODO(toLocation(), "CycleStmt lowering"); - } - - void genFIR(const Fortran::parser::ExitStmt &) { - TODO(toLocation(), "ExitStmt lowering"); - } - - void genFIR(const Fortran::parser::GotoStmt &) { genFIRBranch(getEval().controlSuccessor->block); } - - void genFIR(const Fortran::parser::ElseIfStmt &) { - TODO(toLocation(), "ElseIfStmt lowering"); + void genFIR(const Fortran::parser::ExitStmt &) { + genFIRBranch(getEval().controlSuccessor->block); } - - void genFIR(const Fortran::parser::ElseStmt &) { - TODO(toLocation(), "ElseStmt lowering"); + void genFIR(const Fortran::parser::GotoStmt &) { + genFIRBranch(getEval().controlSuccessor->block); } void genFIR(const Fortran::parser::EndDoStmt &) { TODO(toLocation(), "EndDoStmt lowering"); } - void genFIR(const Fortran::parser::EndMpSubprogramStmt &) { - TODO(toLocation(), "EndMpSubprogramStmt lowering"); - } - // Nop statements - No code, or code is generated at the construct level. - void genFIR(const Fortran::parser::AssociateStmt &) {} // nop - void genFIR(const Fortran::parser::CaseStmt &) {} // nop - void genFIR(const Fortran::parser::ContinueStmt &) {} // nop - void genFIR(const Fortran::parser::EndAssociateStmt &) {} // nop - void genFIR(const Fortran::parser::EndFunctionStmt &) {} // nop - void genFIR(const Fortran::parser::EndIfStmt &) {} // nop - void genFIR(const Fortran::parser::EndSelectStmt &) {} // nop - void genFIR(const Fortran::parser::EndSubroutineStmt &) {} // nop - void genFIR(const Fortran::parser::EntryStmt &) {} // nop - - void genFIR(const Fortran::parser::IfStmt &) { - TODO(toLocation(), "IfStmt lowering"); - } - - void genFIR(const Fortran::parser::IfThenStmt &) { - TODO(toLocation(), "IfThenStmt lowering"); - } + void genFIR(const Fortran::parser::AssociateStmt &) {} // 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::EndFunctionStmt &) {} // nop + void genFIR(const Fortran::parser::EndIfStmt &) {} // nop + void genFIR(const Fortran::parser::EndMpSubprogramStmt &) {} // nop + void genFIR(const Fortran::parser::EndSelectStmt &) {} // nop + void genFIR(const Fortran::parser::EndSubroutineStmt &) {} // nop + void genFIR(const Fortran::parser::EntryStmt &) {} // nop + void genFIR(const Fortran::parser::IfStmt &) {} // nop + void genFIR(const Fortran::parser::IfThenStmt &) {} // nop void genFIR(const Fortran::parser::NonLabelDoStmt &) { TODO(toLocation(), "NonLabelDoStmt lowering"); @@ -2366,6 +2034,377 @@ private: } } + /// Map mlir function block arguments to the corresponding Fortran dummy + /// variables. When the result is passed as a hidden argument, the Fortran + /// result is also mapped. The symbol map is used to hold this mapping. + void mapDummiesAndResults(Fortran::lower::pft::FunctionLikeUnit &funit, + const Fortran::lower::CalleeInterface &callee) { + assert(builder && "require a builder object at this point"); + using PassBy = Fortran::lower::CalleeInterface::PassEntityBy; + auto mapPassedEntity = [&](const auto arg) -> void { + if (arg.passBy == PassBy::AddressAndLength) { + // TODO: now that fir call has some attributes regarding character + // return, PassBy::AddressAndLength should be retired. + mlir::Location loc = toLocation(); + fir::factory::CharacterExprHelper charHelp{*builder, loc}; + mlir::Value box = + charHelp.createEmboxChar(arg.firArgument, arg.firLength); + addSymbol(arg.entity->get(), box); + } else { + if (arg.entity.has_value()) { + addSymbol(arg.entity->get(), arg.firArgument); + } else { + assert(funit.parentHasHostAssoc()); + funit.parentHostAssoc().internalProcedureBindings(*this, + localSymbols); + } + } + }; + for (const Fortran::lower::CalleeInterface::PassedEntity &arg : + callee.getPassedArguments()) + mapPassedEntity(arg); + + // Allocate local skeleton instances of dummies from other entry points. + // Most of these locals will not survive into final generated code, but + // some will. It is illegal to reference them at run time if they do. + for (const Fortran::semantics::Symbol *arg : + funit.nonUniversalDummyArguments) { + if (lookupSymbol(*arg)) + continue; + mlir::Type type = genType(*arg); + // TODO: Account for VALUE arguments (and possibly other variants). + type = builder->getRefType(type); + addSymbol(*arg, builder->create(toLocation(), type)); + } + if (std::optional + passedResult = callee.getPassedResult()) { + mapPassedEntity(*passedResult); + // FIXME: need to make sure things are OK here. addSymbol may not be OK + if (funit.primaryResult && + passedResult->entity->get() != *funit.primaryResult) + addSymbol(*funit.primaryResult, + getSymbolAddress(passedResult->entity->get())); + } + } + + /// Instantiate variable \p var and add it to the symbol map. + /// See ConvertVariable.cpp. + void instantiateVar(const Fortran::lower::pft::Variable &var, + Fortran::lower::AggregateStoreMap &storeMap) { + Fortran::lower::instantiateVariable(*this, var, localSymbols, storeMap); + } + + /// Prepare to translate a new function + void startNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) { + assert(!builder && "expected nullptr"); + Fortran::lower::CalleeInterface callee(funit, *this); + mlir::FuncOp func = callee.addEntryBlockAndMapArguments(); + builder = new fir::FirOpBuilder(func, bridge.getKindMap()); + assert(builder && "FirOpBuilder did not instantiate"); + builder->setInsertionPointToStart(&func.front()); + func.setVisibility(mlir::SymbolTable::Visibility::Public); + + mapDummiesAndResults(funit, callee); + + // Note: not storing Variable references because getOrderedSymbolTable + // below returns a temporary. + llvm::SmallVector deferredFuncResultList; + + // Backup actual argument for entry character results + // with different lengths. It needs to be added to the non + // primary results symbol before mapSymbolAttributes is called. + Fortran::lower::SymbolBox resultArg; + if (std::optional + passedResult = callee.getPassedResult()) + resultArg = lookupSymbol(passedResult->entity->get()); + + Fortran::lower::AggregateStoreMap storeMap; + // The front-end is currently not adding module variables referenced + // in a module procedure as host associated. As a result we need to + // instantiate all module variables here if this is a module procedure. + // It is likely that the front-end behavior should change here. + // This also applies to internal procedures inside module procedures. + if (auto *module = Fortran::lower::pft::getAncestor< + Fortran::lower::pft::ModuleLikeUnit>(funit)) + for (const Fortran::lower::pft::Variable &var : + module->getOrderedSymbolTable()) + instantiateVar(var, storeMap); + + mlir::Value primaryFuncResultStorage; + for (const Fortran::lower::pft::Variable &var : + funit.getOrderedSymbolTable()) { + // Always instantiate aggregate storage blocks. + if (var.isAggregateStore()) { + instantiateVar(var, storeMap); + continue; + } + const Fortran::semantics::Symbol &sym = var.getSymbol(); + if (funit.parentHasHostAssoc()) { + // Never instantitate host associated variables, as they are already + // instantiated from an argument tuple. Instead, just bind the symbol to + // the reference to the host variable, which must be in the map. + const Fortran::semantics::Symbol &ultimate = sym.GetUltimate(); + if (funit.parentHostAssoc().isAssociated(ultimate)) { + Fortran::lower::SymbolBox hostBox = + localSymbols.lookupSymbol(ultimate); + assert(hostBox && "host association is not in map"); + localSymbols.addSymbol(sym, hostBox.toExtendedValue()); + continue; + } + } + if (!sym.IsFuncResult() || !funit.primaryResult) { + instantiateVar(var, storeMap); + } else if (&sym == funit.primaryResult) { + instantiateVar(var, storeMap); + primaryFuncResultStorage = getSymbolAddress(sym); + } else { + deferredFuncResultList.push_back(var); + } + } + + // If this is a host procedure with host associations, then create the tuple + // of pointers for passing to the internal procedures. + if (!funit.getHostAssoc().empty()) + funit.getHostAssoc().hostProcedureBindings(*this, localSymbols); + + /// TODO: should use same mechanism as equivalence? + /// One blocking point is character entry returns that need special handling + /// since they are not locally allocated but come as argument. CHARACTER(*) + /// is not something that fit wells with equivalence lowering. + for (const Fortran::lower::pft::Variable &altResult : + deferredFuncResultList) { + if (std::optional + passedResult = callee.getPassedResult()) + addSymbol(altResult.getSymbol(), resultArg.getAddr()); + Fortran::lower::StatementContext stmtCtx; + Fortran::lower::mapSymbolAttributes(*this, altResult, localSymbols, + stmtCtx, primaryFuncResultStorage); + } + + // Create most function blocks in advance. + createEmptyBlocks(funit.evaluationList); + + // Reinstate entry block as the current insertion point. + builder->setInsertionPointToEnd(&func.front()); + + if (callee.hasAlternateReturns()) { + // Create a local temp to hold the alternate return index. + // Give it an integer index type and the subroutine name (for dumps). + // Attach it to the subroutine symbol in the localSymbols map. + // Initialize it to zero, the "fallthrough" alternate return value. + const Fortran::semantics::Symbol &symbol = funit.getSubprogramSymbol(); + mlir::Location loc = toLocation(); + mlir::Type idxTy = builder->getIndexType(); + mlir::Value altResult = + builder->createTemporary(loc, idxTy, toStringRef(symbol.name())); + addSymbol(symbol, altResult); + mlir::Value zero = builder->createIntegerConstant(loc, idxTy, 0); + builder->create(loc, zero, altResult); + } + + if (Fortran::lower::pft::Evaluation *alternateEntryEval = + funit.getEntryEval()) + genFIRBranch(alternateEntryEval->lexicalSuccessor->block); + } + + /// 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 + /// boundaries. + void createEmptyBlocks( + std::list &evaluationList) { + mlir::Region *region = &builder->getRegion(); + for (Fortran::lower::pft::Evaluation &eval : evaluationList) { + if (eval.isNewBlock) + eval.block = builder->createBlock(region); + if (eval.isConstruct() || eval.isDirective()) { + if (eval.lowerAsUnstructured()) { + createEmptyBlocks(eval.getNestedEvaluations()); + } else if (eval.hasNestedEvaluations()) { + // A structured construct that is a target starts a new block. + Fortran::lower::pft::Evaluation &constructStmt = + eval.getFirstNestedEvaluation(); + if (constructStmt.isNewBlock) + constructStmt.block = builder->createBlock(region); + } + } + } + } + + /// Return the predicate: "current block does not have a terminator branch". + bool blockIsUnterminated() { + mlir::Block *currentBlock = builder->getBlock(); + return currentBlock->empty() || + !currentBlock->back().hasTrait(); + } + + /// Unconditionally switch code insertion to a new block. + void startBlock(mlir::Block *newBlock) { + assert(newBlock && "missing block"); + // Default termination for the current block is a fallthrough branch to + // the new block. + if (blockIsUnterminated()) + genFIRBranch(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. + builder->setInsertionPointToStart(newBlock); + if (blockIsUnterminated()) + builder->setInsertionPointToEnd(newBlock); + } + + /// Conditionally switch code insertion to a new block. + void maybeStartBlock(mlir::Block *newBlock) { + if (newBlock) + startBlock(newBlock); + } + + /// Emit return and cleanup after the function has been translated. + void endNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) { + setCurrentPosition(Fortran::lower::pft::stmtSourceLoc(funit.endStmt)); + if (funit.isMainProgram()) + genExitRoutine(); + else + genFIRProcedureExit(funit, funit.getSubprogramSymbol()); + funit.finalBlock = nullptr; + LLVM_DEBUG(llvm::dbgs() << "*** Lowering result:\n\n" + << *builder->getFunction() << '\n'); + // FIXME: Simplification should happen in a normal pass, not here. + mlir::IRRewriter rewriter(*builder); + (void)mlir::simplifyRegions(rewriter, + {builder->getRegion()}); // remove dead code + delete builder; + builder = nullptr; + hostAssocTuple = mlir::Value{}; + localSymbols.clear(); + } + + /// Helper to generate GlobalOps when the builder is not positioned in any + /// region block. This is required because the FirOpBuilder assumes it is + /// always positioned inside a region block when creating globals, the easiest + /// way comply is to create a dummy function and to throw it afterwards. + void createGlobalOutsideOfFunctionLowering( + const std::function &createGlobals) { + // FIXME: get rid of the bogus function context and instantiate the + // globals directly into the module. + mlir::MLIRContext *context = &getMLIRContext(); + mlir::FuncOp func = fir::FirOpBuilder::createFunction( + mlir::UnknownLoc::get(context), getModuleOp(), + fir::NameUniquer::doGenerated("Sham"), + mlir::FunctionType::get(context, llvm::None, llvm::None)); + func.addEntryBlock(); + builder = new fir::FirOpBuilder(func, bridge.getKindMap()); + createGlobals(); + if (mlir::Region *region = func.getCallableRegion()) + region->dropAllReferences(); + func.erase(); + delete builder; + builder = nullptr; + localSymbols.clear(); + } + /// Instantiate the data from a BLOCK DATA unit. + void lowerBlockData(Fortran::lower::pft::BlockDataUnit &bdunit) { + createGlobalOutsideOfFunctionLowering([&]() { + Fortran::lower::AggregateStoreMap fakeMap; + for (const auto &[_, sym] : bdunit.symTab) { + if (sym->has()) { + Fortran::lower::pft::Variable var(*sym, true); + instantiateVar(var, fakeMap); + } + } + }); + } + + /// Lower a procedure (nest). + void lowerFunc(Fortran::lower::pft::FunctionLikeUnit &funit) { + if (!funit.isMainProgram()) { + const Fortran::semantics::Symbol &procSymbol = + funit.getSubprogramSymbol(); + if (procSymbol.owner().IsSubmodule()) { + TODO(toLocation(), "support submodules"); + return; + } + } + setCurrentPosition(funit.getStartingSourceLoc()); + for (int entryIndex = 0, last = funit.entryPointList.size(); + entryIndex < last; ++entryIndex) { + funit.setActiveEntry(entryIndex); + startNewFunction(funit); // the entry point for lowering this procedure + for (Fortran::lower::pft::Evaluation &eval : funit.evaluationList) + genFIR(eval); + endNewFunction(funit); + } + funit.setActiveEntry(0); + for (Fortran::lower::pft::FunctionLikeUnit &f : funit.nestedFunctions) + lowerFunc(f); // internal procedure + } + + /// Lower module variable definitions to fir::globalOp and OpenMP/OpenACC + /// declarative construct. + void lowerModuleDeclScope(Fortran::lower::pft::ModuleLikeUnit &mod) { + setCurrentPosition(mod.getStartingSourceLoc()); + createGlobalOutsideOfFunctionLowering([&]() { + for (const Fortran::lower::pft::Variable &var : + mod.getOrderedSymbolTable()) { + // Only define the variables owned by this module. + const Fortran::semantics::Scope *owningScope = var.getOwningScope(); + if (!owningScope || mod.getScope() == *owningScope) + Fortran::lower::defineModuleVariable(*this, var); + } + for (auto &eval : mod.evaluationList) + genFIR(eval); + }); + } + + /// Lower functions contained in a module. + void lowerMod(Fortran::lower::pft::ModuleLikeUnit &mod) { + for (Fortran::lower::pft::FunctionLikeUnit &f : mod.nestedFunctions) + lowerFunc(f); + } + + void setCurrentPosition(const Fortran::parser::CharBlock &position) { + if (position != Fortran::parser::CharBlock{}) + currentPosition = position; + } + + /// Set current position at the location of \p parseTreeNode. Note that the + /// position is updated automatically when visiting statements, but not when + /// entering higher level nodes like constructs or procedures. This helper is + /// intended to cover the latter cases. + template + void setCurrentPositionAt(const A &parseTreeNode) { + setCurrentPosition(Fortran::parser::FindSourceLocation(parseTreeNode)); + } + + //===--------------------------------------------------------------------===// + // Utility methods + //===--------------------------------------------------------------------===// + + /// Convert a parser CharBlock to a Location + mlir::Location toLocation(const Fortran::parser::CharBlock &cb) { + return genLocation(cb); + } + + mlir::Location toLocation() { return toLocation(currentPosition); } + void setCurrentEval(Fortran::lower::pft::Evaluation &eval) { + evalPtr = &eval; + } + Fortran::lower::pft::Evaluation &getEval() { + assert(evalPtr); + return *evalPtr; + } + + std::optional + getShape(const Fortran::lower::SomeExpr &expr) { + return Fortran::evaluate::GetShape(foldingContext, expr); + } + //===--------------------------------------------------------------------===// // Analysis on a nested explicit iteration space. //===--------------------------------------------------------------------===// @@ -2568,6 +2607,8 @@ private: }); } + void createRuntimeTypeInfoGlobals() {} + //===--------------------------------------------------------------------===// Fortran::lower::LoweringBridge &bridge; @@ -2578,10 +2619,16 @@ private: Fortran::parser::CharBlock currentPosition; RuntimeTypeInfoConverter runtimeTypeInfoConverter; + /// WHERE statement/construct mask expression stack. + Fortran::lower::ImplicitIterSpace implicitIterSpace; + + /// FORALL context + Fortran::lower::ExplicitIterSpace explicitIterSpace; + /// Tuple of host assoicated variables. mlir::Value hostAssocTuple; - Fortran::lower::ImplicitIterSpace implicitIterSpace; - Fortran::lower::ExplicitIterSpace explicitIterSpace; + + std::size_t constructDepth = 0; }; } // namespace @@ -2602,6 +2649,13 @@ void Fortran::lower::LoweringBridge::lower( converter.run(*pft); } +void Fortran::lower::LoweringBridge::parseSourceFile(llvm::SourceMgr &srcMgr) { + mlir::OwningOpRef owningRef = + mlir::parseSourceFile(srcMgr, &context); + module.reset(new mlir::ModuleOp(owningRef.get().getOperation())); + owningRef.release(); +} + Fortran::lower::LoweringBridge::LoweringBridge( mlir::MLIRContext &context, const Fortran::common::IntrinsicTypeDefaultKinds &defaultKinds, @@ -2626,7 +2680,7 @@ Fortran::lower::LoweringBridge::LoweringBridge( default: break; } - if (!diag.getLocation().isa()) + if (!diag.getLocation().isa()) os << diag.getLocation() << ": "; os << diag << '\n'; os.flush(); @@ -2637,6 +2691,6 @@ Fortran::lower::LoweringBridge::LoweringBridge( module = std::make_unique( mlir::ModuleOp::create(mlir::UnknownLoc::get(&context))); assert(module.get() && "module was not created"); - fir::setTargetTriple(getModule(), triple); - fir::setKindMapping(getModule(), kindMap); + fir::setTargetTriple(*module.get(), triple); + fir::setKindMapping(*module.get(), kindMap); } diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp index adb6593902fb..a62e53dafebd 100644 --- a/flang/lib/Lower/CallInterface.cpp +++ b/flang/lib/Lower/CallInterface.cpp @@ -239,11 +239,10 @@ void Fortran::lower::CallerInterface::walkResultExtents( ExprVisitor visitor) const { // Walk directly the result symbol shape (the characteristic shape may contain // descriptor inquiries to it that would fail to lower on the caller side). - const Fortran::semantics::Symbol *interfaceSymbol = - procRef.proc().GetInterfaceSymbol(); - if (interfaceSymbol) { - const Fortran::semantics::Symbol &result = - interfaceSymbol->get().result(); + const Fortran::semantics::SubprogramDetails *interfaceDetails = + getInterfaceDetails(); + if (interfaceDetails) { + const Fortran::semantics::Symbol &result = interfaceDetails->result(); if (const auto *objectDetails = result.detailsIf()) if (objectDetails->shape().IsExplicitShape()) @@ -263,7 +262,7 @@ bool Fortran::lower::CallerInterface::mustMapInterfaceSymbols() const { const std::optional &result = characteristic->functionResult; if (!result || result->CanBeReturnedViaImplicitInterface() || - !procRef.proc().GetInterfaceSymbol()) + !getInterfaceDetails()) return false; bool allResultSpecExprConstant = true; auto visitor = [&](const Fortran::lower::SomeExpr &e) { @@ -277,12 +276,13 @@ bool Fortran::lower::CallerInterface::mustMapInterfaceSymbols() const { mlir::Value Fortran::lower::CallerInterface::getArgumentValue( const semantics::Symbol &sym) const { mlir::Location loc = converter.getCurrentLocation(); - const Fortran::semantics::Symbol *iface = procRef.proc().GetInterfaceSymbol(); - if (!iface) + const Fortran::semantics::SubprogramDetails *ifaceDetails = + getInterfaceDetails(); + if (!ifaceDetails) fir::emitFatalError( loc, "mapping actual and dummy arguments requires an interface"); const std::vector &dummies = - iface->get().dummyArgs(); + ifaceDetails->dummyArgs(); auto it = std::find(dummies.begin(), dummies.end(), &sym); if (it == dummies.end()) fir::emitFatalError(loc, "symbol is not a dummy in this call"); @@ -300,11 +300,21 @@ mlir::Type Fortran::lower::CallerInterface::getResultStorageType() const { const Fortran::semantics::Symbol & Fortran::lower::CallerInterface::getResultSymbol() const { mlir::Location loc = converter.getCurrentLocation(); - const Fortran::semantics::Symbol *iface = procRef.proc().GetInterfaceSymbol(); - if (!iface) + const Fortran::semantics::SubprogramDetails *ifaceDetails = + getInterfaceDetails(); + if (!ifaceDetails) fir::emitFatalError( loc, "mapping actual and dummy arguments requires an interface"); - return iface->get().result(); + return ifaceDetails->result(); +} + +const Fortran::semantics::SubprogramDetails * +Fortran::lower::CallerInterface::getInterfaceDetails() const { + if (const Fortran::semantics::Symbol *iface = + procRef.proc().GetInterfaceSymbol()) + return iface->GetUltimate() + .detailsIf(); + return nullptr; } //===----------------------------------------------------------------------===// diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp index d27b01f6142f..68cd69da958f 100644 --- a/flang/lib/Lower/ConvertExpr.cpp +++ b/flang/lib/Lower/ConvertExpr.cpp @@ -11,12 +11,16 @@ //===----------------------------------------------------------------------===// #include "flang/Lower/ConvertExpr.h" +#include "flang/Common/default-kinds.h" +#include "flang/Common/unwrap.h" #include "flang/Evaluate/fold.h" +#include "flang/Evaluate/real.h" #include "flang/Evaluate/traverse.h" -#include "flang/Lower/AbstractConverter.h" #include "flang/Lower/Allocatable.h" +#include "flang/Lower/Bridge.h" #include "flang/Lower/BuiltinModules.h" #include "flang/Lower/CallInterface.h" +#include "flang/Lower/Coarray.h" #include "flang/Lower/ComponentPath.h" #include "flang/Lower/ConvertType.h" #include "flang/Lower/ConvertVariable.h" @@ -24,19 +28,19 @@ #include "flang/Lower/DumpEvaluateExpr.h" #include "flang/Lower/IntrinsicCall.h" #include "flang/Lower/Mangler.h" -#include "flang/Lower/StatementContext.h" -#include "flang/Lower/SymbolMap.h" +#include "flang/Lower/Runtime.h" +#include "flang/Lower/Support/Utils.h" #include "flang/Lower/Todo.h" #include "flang/Optimizer/Builder/Character.h" #include "flang/Optimizer/Builder/Complex.h" #include "flang/Optimizer/Builder/Factory.h" -#include "flang/Optimizer/Builder/LowLevelIntrinsics.h" -#include "flang/Optimizer/Builder/MutableBox.h" #include "flang/Optimizer/Builder/Runtime/Character.h" #include "flang/Optimizer/Builder/Runtime/RTBuilder.h" #include "flang/Optimizer/Builder/Runtime/Ragged.h" +#include "flang/Optimizer/Dialect/FIRAttr.h" +#include "flang/Optimizer/Dialect/FIRDialect.h" #include "flang/Optimizer/Dialect/FIROpsSupport.h" -#include "flang/Optimizer/Support/Matcher.h" +#include "flang/Optimizer/Support/FatalError.h" #include "flang/Semantics/expression.h" #include "flang/Semantics/symbol.h" #include "flang/Semantics/tools.h" @@ -44,6 +48,9 @@ #include "mlir/Dialect/Func/IR/FuncOps.h" #include "llvm/Support/CommandLine.h" #include "llvm/Support/Debug.h" +#include "llvm/Support/ErrorHandling.h" +#include "llvm/Support/raw_ostream.h" +#include #define DEBUG_TYPE "flang-lower-expr" @@ -665,6 +672,14 @@ public: return builder.createRealConstant(getLoc(), fltTy, value); } + mlir::Type getSomeKindInteger() { return builder.getIndexType(); } + + mlir::FuncOp getFunction(llvm::StringRef name, mlir::FunctionType funTy) { + if (mlir::FuncOp func = builder.getNamedFunction(name)) + return func; + return builder.createFunction(getLoc(), name, funTy); + } + template mlir::Value createCompareOp(mlir::arith::CmpIPredicate pred, const ExtValue &left, const ExtValue &right) { @@ -746,7 +761,7 @@ public: } ExtValue genval(const Fortran::evaluate::BOZLiteralConstant &) { - TODO(getLoc(), "genval BOZ"); + TODO(getLoc(), "BOZ"); } /// Return indirection to function designated in ProcedureDesignator. @@ -1024,12 +1039,17 @@ public: } ExtValue genval(const Fortran::evaluate::TypeParamInquiry &) { - TODO(getLoc(), "genval TypeParamInquiry"); + TODO(getLoc(), "type parameter inquiry"); + } + + mlir::Value extractComplexPart(mlir::Value cplx, bool isImagPart) { + return fir::factory::Complex{builder, getLoc()}.extractComplexPart( + cplx, isImagPart); } template ExtValue genval(const Fortran::evaluate::ComplexComponent &part) { - TODO(getLoc(), "genval ComplexComponent"); + return extractComplexPart(genunbox(part.left()), part.isImaginaryPart); } template @@ -1040,7 +1060,6 @@ public: mlir::Value zero = genIntegerConstant(builder.getContext(), 0); return builder.create(getLoc(), zero, input); } - template ExtValue genval(const Fortran::evaluate::Negate> &op) { @@ -1131,7 +1150,19 @@ public: ExtValue genval(const Fortran::evaluate::Extremum> &op) { - TODO(getLoc(), "genval Extremum"); + mlir::Value lhs = genunbox(op.left()); + mlir::Value rhs = genunbox(op.right()); + switch (op.ordering) { + case Fortran::evaluate::Ordering::Greater: + return Fortran::lower::genMax(builder, getLoc(), + llvm::ArrayRef{lhs, rhs}); + case Fortran::evaluate::Ordering::Less: + return Fortran::lower::genMin(builder, getLoc(), + llvm::ArrayRef{lhs, rhs}); + case Fortran::evaluate::Ordering::Equal: + llvm_unreachable("Equal is not a valid ordering in this context"); + } + llvm_unreachable("unknown ordering"); } // Change the dynamic length information without actually changing the @@ -1180,7 +1211,7 @@ public: template ExtValue genval(const Fortran::evaluate::Relational> &op) { - TODO(getLoc(), "genval complex comparison"); + return createFltCmpOp(op, translateFloatRelational(op.opr)); } template ExtValue genval(const Fortran::evaluate::Relational, TC2> &convert) { mlir::Type ty = converter.genType(TC1, KIND); - mlir::Value operand = genunbox(convert.left()); - return builder.convertWithSemantics(getLoc(), ty, operand); + auto fromExpr = genval(convert.left()); + auto loc = getLoc(); + return fromExpr.match( + [&](const fir::CharBoxValue &boxchar) -> ExtValue { + if constexpr (TC1 == Fortran::common::TypeCategory::Character && + TC2 == TC1) { + // Use char_convert. Each code point is translated from a + // narrower/wider encoding to the target encoding. For example, 'A' + // may be translated from 0x41 : i8 to 0x0041 : i16. The symbol + // for euro (0x20AC : i16) may be translated from a wide character + // to "0xE2 0x82 0xAC" : UTF-8. + mlir::Value bufferSize = boxchar.getLen(); + auto kindMap = builder.getKindMap(); + auto fromBits = kindMap.getCharacterBitsize( + fir::unwrapRefType(boxchar.getAddr().getType()) + .cast() + .getFKind()); + auto toBits = kindMap.getCharacterBitsize( + ty.cast().getFKind()); + if (toBits < fromBits) { + // Scale by relative ratio to give a buffer of the same length. + auto ratio = builder.createIntegerConstant( + loc, bufferSize.getType(), fromBits / toBits); + bufferSize = + builder.create(loc, bufferSize, ratio); + } + auto dest = builder.create( + loc, ty, mlir::ValueRange{bufferSize}); + builder.create(loc, boxchar.getAddr(), + boxchar.getLen(), dest); + return fir::CharBoxValue{dest, boxchar.getLen()}; + } else { + fir::emitFatalError( + loc, "unsupported evaluate::Convert between CHARACTER type " + "category and non-CHARACTER category"); + } + }, + [&](const fir::UnboxedValue &value) -> ExtValue { + return builder.convertWithSemantics(loc, ty, value); + }, + [&](auto &) -> ExtValue { + fir::emitFatalError(loc, "unsupported evaluate::Convert"); + }); } template ExtValue genval(const Fortran::evaluate::Parentheses &op) { - TODO(getLoc(), "genval parentheses"); + ExtValue input = genval(op.left()); + mlir::Value base = fir::getBase(input); + mlir::Value newBase = + builder.create(getLoc(), base.getType(), base); + return fir::substBase(input, newBase); } template @@ -1527,7 +1603,6 @@ public: return genScalarLit(opt.value()); } } - fir::ExtendedValue genval( const Fortran::evaluate::Constant &con) { if (con.Rank() > 0) @@ -1540,14 +1615,27 @@ public: template ExtValue genval(const Fortran::evaluate::ArrayConstructor &) { - TODO(getLoc(), "genval ArrayConstructor"); + fir::emitFatalError(getLoc(), + "array constructor: lowering should not reach here"); } ExtValue gen(const Fortran::evaluate::ComplexPart &x) { - TODO(getLoc(), "gen ComplexPart"); + mlir::Location loc = getLoc(); + auto idxTy = builder.getI32Type(); + ExtValue exv = gen(x.complex()); + mlir::Value base = fir::getBase(exv); + fir::factory::Complex helper{builder, loc}; + mlir::Type eleTy = + helper.getComplexPartType(fir::dyn_cast_ptrEleTy(base.getType())); + mlir::Value offset = builder.createIntegerConstant( + loc, idxTy, + x.part() == Fortran::evaluate::ComplexPart::Part::RE ? 0 : 1); + mlir::Value result = builder.create( + loc, builder.getRefType(eleTy), base, mlir::ValueRange{offset}); + return {result}; } ExtValue genval(const Fortran::evaluate::ComplexPart &x) { - TODO(getLoc(), "genval ComplexPart"); + return genLoad(gen(x)); } /// Reference to a substring. @@ -1607,7 +1695,6 @@ public: } fir::emitFatalError(getLoc(), "subscript triple notation is not scalar"); } - ExtValue genSubscript(const Fortran::evaluate::Subscript &subs) { return genval(subs); } @@ -1629,13 +1716,12 @@ public: static Fortran::evaluate::DataRef const * reverseComponents(const Fortran::evaluate::Component &cmpt, std::list &list) { - if (!cmpt.GetLastSymbol().test( - Fortran::semantics::Symbol::Flag::ParentComp)) + if (!getLastSym(cmpt).test(Fortran::semantics::Symbol::Flag::ParentComp)) list.push_front(&cmpt); return std::visit( Fortran::common::visitors{ [&](const Fortran::evaluate::Component &x) { - if (Fortran::semantics::IsAllocatableOrPointer(x.GetLastSymbol())) + if (Fortran::semantics::IsAllocatableOrPointer(getLastSym(x))) return &cmpt.base(); return reverseComponents(x, list); }, @@ -1656,7 +1742,7 @@ public: // FIXME: need to thread the LEN type parameters here. for (const Fortran::evaluate::Component *field : list) { auto recTy = ty.cast(); - const Fortran::semantics::Symbol &sym = field->GetLastSymbol(); + const Fortran::semantics::Symbol &sym = getLastSym(*field); llvm::StringRef name = toStringRef(sym.name()); coorArgs.push_back(builder.create( loc, fldTy, name, recTy, fir::getTypeParams(obj))); @@ -1684,18 +1770,34 @@ public: return genLoad(gen(cmpt)); } - ExtValue genval(const Fortran::semantics::Bound &bound) { - TODO(getLoc(), "genval Bound"); + // Determine the result type after removing `dims` dimensions from the array + // type `arrTy` + mlir::Type genSubType(mlir::Type arrTy, unsigned dims) { + mlir::Type unwrapTy = fir::dyn_cast_ptrOrBoxEleTy(arrTy); + assert(unwrapTy && "must be a pointer or box type"); + auto seqTy = unwrapTy.cast(); + llvm::ArrayRef shape = seqTy.getShape(); + assert(shape.size() > 0 && "removing columns for sequence sans shape"); + assert(dims <= shape.size() && "removing more columns than exist"); + fir::SequenceType::Shape newBnds; + // follow Fortran semantics and remove columns (from right) + std::size_t e = shape.size() - dims; + for (decltype(e) i = 0; i < e; ++i) + newBnds.push_back(shape[i]); + if (!newBnds.empty()) + return fir::SequenceType::get(newBnds, seqTy.getEleTy()); + return seqTy.getEleTy(); } - /// Return lower bounds of \p box in dimension \p dim. The returned value - /// has type \ty. - mlir::Value getLBound(const ExtValue &box, unsigned dim, mlir::Type ty) { - assert(box.rank() > 0 && "must be an array"); - mlir::Location loc = getLoc(); - mlir::Value one = builder.createIntegerConstant(loc, ty, 1); - mlir::Value lb = fir::factory::readLowerBound(builder, loc, box, dim, one); - return builder.createConvert(loc, ty, lb); + // Generate the code for a Bound value. + ExtValue genval(const Fortran::semantics::Bound &bound) { + if (bound.isExplicit()) { + Fortran::semantics::MaybeSubscriptIntExpr sub = bound.GetExplicit(); + if (sub.has_value()) + return genval(*sub); + return genIntegerConstant<8>(builder.getContext(), 1); + } + TODO(getLoc(), "non explicit semantics::Bound lowering"); } static bool isSlice(const Fortran::evaluate::ArrayRef &aref) { @@ -1866,15 +1968,28 @@ public: return genCoordinateOp(base, aref); } + /// Return lower bounds of \p box in dimension \p dim. The returned value + /// has type \ty. + mlir::Value getLBound(const ExtValue &box, unsigned dim, mlir::Type ty) { + assert(box.rank() > 0 && "must be an array"); + mlir::Location loc = getLoc(); + mlir::Value one = builder.createIntegerConstant(loc, ty, 1); + mlir::Value lb = fir::factory::readLowerBound(builder, loc, box, dim, one); + return builder.createConvert(loc, ty, lb); + } + ExtValue genval(const Fortran::evaluate::ArrayRef &aref) { return genLoad(gen(aref)); } ExtValue gen(const Fortran::evaluate::CoarrayRef &coref) { - TODO(getLoc(), "gen CoarrayRef"); + return Fortran::lower::CoarrayExprHelper{converter, getLoc(), symMap} + .genAddr(coref); } + ExtValue genval(const Fortran::evaluate::CoarrayRef &coref) { - TODO(getLoc(), "genval CoarrayRef"); + return Fortran::lower::CoarrayExprHelper{converter, getLoc(), symMap} + .genValue(coref); } template @@ -1910,6 +2025,144 @@ public: return placeScalarValueInMemory(builder, getLoc(), retVal, resultType); } + /// Helper to lower intrinsic arguments for inquiry intrinsic. + ExtValue + lowerIntrinsicArgumentAsInquired(const Fortran::lower::SomeExpr &expr) { + if (Fortran::evaluate::IsAllocatableOrPointerObject( + expr, converter.getFoldingContext())) + return genMutableBoxValue(expr); + /// Do not create temps for array sections whose properties only need to be + /// inquired: create a descriptor that will be inquired. + if (Fortran::evaluate::IsVariable(expr) && isArray(expr) && + !Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr)) + return lowerIntrinsicArgumentAsBox(expr); + return gen(expr); + } + + /// Helper to lower intrinsic arguments to a fir::BoxValue. + /// It preserves all the non default lower bounds/non deferred length + /// parameter information. + ExtValue lowerIntrinsicArgumentAsBox(const Fortran::lower::SomeExpr &expr) { + mlir::Location loc = getLoc(); + ExtValue exv = genBoxArg(expr); + mlir::Value box = builder.createBox(loc, exv); + return fir::BoxValue( + box, fir::factory::getNonDefaultLowerBounds(builder, loc, exv), + fir::factory::getNonDeferredLengthParams(exv)); + } + + /// Generate a call to an intrinsic function. + ExtValue + genIntrinsicRef(const Fortran::evaluate::ProcedureRef &procRef, + const Fortran::evaluate::SpecificIntrinsic &intrinsic, + llvm::Optional resultType) { + llvm::SmallVector operands; + + llvm::StringRef name = intrinsic.name; + mlir::Location loc = getLoc(); + if (Fortran::lower::intrinsicRequiresCustomOptionalHandling( + procRef, intrinsic, converter)) { + using ExvAndPresence = std::pair>; + llvm::SmallVector operands; + auto prepareOptionalArg = [&](const Fortran::lower::SomeExpr &expr) { + ExtValue optionalArg = lowerIntrinsicArgumentAsInquired(expr); + mlir::Value isPresent = + genActualIsPresentTest(builder, loc, optionalArg); + operands.emplace_back(optionalArg, isPresent); + }; + auto prepareOtherArg = [&](const Fortran::lower::SomeExpr &expr) { + operands.emplace_back(genval(expr), llvm::None); + }; + Fortran::lower::prepareCustomIntrinsicArgument( + procRef, intrinsic, resultType, prepareOptionalArg, prepareOtherArg, + converter); + + auto getArgument = [&](std::size_t i) -> ExtValue { + if (fir::conformsWithPassByRef( + fir::getBase(operands[i].first).getType())) + return genLoad(operands[i].first); + return operands[i].first; + }; + auto isPresent = [&](std::size_t i) -> llvm::Optional { + return operands[i].second; + }; + return Fortran::lower::lowerCustomIntrinsic( + builder, loc, name, resultType, isPresent, getArgument, + operands.size(), stmtCtx); + } + + const Fortran::lower::IntrinsicArgumentLoweringRules *argLowering = + Fortran::lower::getIntrinsicArgumentLowering(name); + for (const auto &[arg, dummy] : + llvm::zip(procRef.arguments(), + intrinsic.characteristics.value().dummyArguments)) { + auto *expr = Fortran::evaluate::UnwrapExpr(arg); + if (!expr) { + // Absent optional. + operands.emplace_back(Fortran::lower::getAbsentIntrinsicArgument()); + continue; + } + if (!argLowering) { + // No argument lowering instruction, lower by value. + operands.emplace_back(genval(*expr)); + continue; + } + // Ad-hoc argument lowering handling. + Fortran::lower::ArgLoweringRule argRules = + Fortran::lower::lowerIntrinsicArgumentAs(loc, *argLowering, + dummy.name); + if (argRules.handleDynamicOptional && + Fortran::evaluate::MayBePassedAsAbsentOptional( + *expr, converter.getFoldingContext())) { + ExtValue optional = lowerIntrinsicArgumentAsInquired(*expr); + mlir::Value isPresent = genActualIsPresentTest(builder, loc, optional); + switch (argRules.lowerAs) { + case Fortran::lower::LowerIntrinsicArgAs::Value: + operands.emplace_back( + genOptionalValue(builder, loc, optional, isPresent)); + continue; + case Fortran::lower::LowerIntrinsicArgAs::Addr: + operands.emplace_back( + genOptionalAddr(builder, loc, optional, isPresent)); + continue; + case Fortran::lower::LowerIntrinsicArgAs::Box: + operands.emplace_back( + genOptionalBox(builder, loc, optional, isPresent)); + continue; + case Fortran::lower::LowerIntrinsicArgAs::Inquired: + operands.emplace_back(optional); + continue; + } + llvm_unreachable("bad switch"); + } + switch (argRules.lowerAs) { + case Fortran::lower::LowerIntrinsicArgAs::Value: + operands.emplace_back(genval(*expr)); + continue; + case Fortran::lower::LowerIntrinsicArgAs::Addr: + operands.emplace_back(gen(*expr)); + continue; + case Fortran::lower::LowerIntrinsicArgAs::Box: + operands.emplace_back(lowerIntrinsicArgumentAsBox(*expr)); + continue; + case Fortran::lower::LowerIntrinsicArgAs::Inquired: + operands.emplace_back(lowerIntrinsicArgumentAsInquired(*expr)); + continue; + } + llvm_unreachable("bad switch"); + } + // Let the intrinsic library lower the intrinsic procedure call + return Fortran::lower::genIntrinsicCall(builder, getLoc(), name, resultType, + operands, stmtCtx); + } + + template + bool isCharacterType(const A &exp) { + if (auto type = exp.GetType()) + return type->category() == Fortran::common::TypeCategory::Character; + return false; + } + /// helper to detect statement functions static bool isStatementFunctionCall(const Fortran::evaluate::ProcedureRef &procRef) { @@ -2330,12 +2583,13 @@ public: // variable could also be modified by other means during the call. if (!isParenthesizedVariable(expr)) return genExtAddr(expr); - mlir::Location loc = getLoc(); if (expr.Rank() > 0) - TODO(loc, "genTempExtAddr array"); + return asArray(expr); + mlir::Location loc = getLoc(); return genExtValue(expr).match( [&](const fir::CharBoxValue &boxChar) -> ExtValue { - TODO(loc, "genTempExtAddr CharBoxValue"); + return fir::factory::CharacterExprHelper{builder, loc}.createTempFrom( + boxChar); }, [&](const fir::UnboxedValue &v) -> ExtValue { mlir::Type type = v.getType(); @@ -2763,132 +3017,6 @@ public: return genProcedureRef(procRef, resTy); } - /// Helper to lower intrinsic arguments for inquiry intrinsic. - ExtValue - lowerIntrinsicArgumentAsInquired(const Fortran::lower::SomeExpr &expr) { - if (Fortran::evaluate::IsAllocatableOrPointerObject( - expr, converter.getFoldingContext())) - return genMutableBoxValue(expr); - return gen(expr); - } - - /// Helper to lower intrinsic arguments to a fir::BoxValue. - /// It preserves all the non default lower bounds/non deferred length - /// parameter information. - ExtValue lowerIntrinsicArgumentAsBox(const Fortran::lower::SomeExpr &expr) { - mlir::Location loc = getLoc(); - ExtValue exv = genBoxArg(expr); - mlir::Value box = builder.createBox(loc, exv); - return fir::BoxValue( - box, fir::factory::getNonDefaultLowerBounds(builder, loc, exv), - fir::factory::getNonDeferredLengthParams(exv)); - } - - /// Generate a call to an intrinsic function. - ExtValue - genIntrinsicRef(const Fortran::evaluate::ProcedureRef &procRef, - const Fortran::evaluate::SpecificIntrinsic &intrinsic, - llvm::Optional resultType) { - llvm::SmallVector operands; - - llvm::StringRef name = intrinsic.name; - mlir::Location loc = getLoc(); - if (Fortran::lower::intrinsicRequiresCustomOptionalHandling( - procRef, intrinsic, converter)) { - using ExvAndPresence = std::pair>; - llvm::SmallVector operands; - auto prepareOptionalArg = [&](const Fortran::lower::SomeExpr &expr) { - ExtValue optionalArg = lowerIntrinsicArgumentAsInquired(expr); - mlir::Value isPresent = - genActualIsPresentTest(builder, loc, optionalArg); - operands.emplace_back(optionalArg, isPresent); - }; - auto prepareOtherArg = [&](const Fortran::lower::SomeExpr &expr) { - operands.emplace_back(genval(expr), llvm::None); - }; - Fortran::lower::prepareCustomIntrinsicArgument( - procRef, intrinsic, resultType, prepareOptionalArg, prepareOtherArg, - converter); - - auto getArgument = [&](std::size_t i) -> ExtValue { - if (fir::conformsWithPassByRef( - fir::getBase(operands[i].first).getType())) - return genLoad(operands[i].first); - return operands[i].first; - }; - auto isPresent = [&](std::size_t i) -> llvm::Optional { - return operands[i].second; - }; - return Fortran::lower::lowerCustomIntrinsic( - builder, loc, name, resultType, isPresent, getArgument, - operands.size(), stmtCtx); - } - - const Fortran::lower::IntrinsicArgumentLoweringRules *argLowering = - Fortran::lower::getIntrinsicArgumentLowering(name); - for (const auto &[arg, dummy] : - llvm::zip(procRef.arguments(), - intrinsic.characteristics.value().dummyArguments)) { - auto *expr = Fortran::evaluate::UnwrapExpr(arg); - if (!expr) { - // Absent optional. - operands.emplace_back(Fortran::lower::getAbsentIntrinsicArgument()); - continue; - } - if (!argLowering) { - // No argument lowering instruction, lower by value. - operands.emplace_back(genval(*expr)); - continue; - } - // Ad-hoc argument lowering handling. - Fortran::lower::ArgLoweringRule argRules = - Fortran::lower::lowerIntrinsicArgumentAs(loc, *argLowering, - dummy.name); - if (argRules.handleDynamicOptional && - Fortran::evaluate::MayBePassedAsAbsentOptional( - *expr, converter.getFoldingContext())) { - ExtValue optional = lowerIntrinsicArgumentAsInquired(*expr); - mlir::Value isPresent = genActualIsPresentTest(builder, loc, optional); - switch (argRules.lowerAs) { - case Fortran::lower::LowerIntrinsicArgAs::Value: - operands.emplace_back( - genOptionalValue(builder, loc, optional, isPresent)); - continue; - case Fortran::lower::LowerIntrinsicArgAs::Addr: - operands.emplace_back( - genOptionalAddr(builder, loc, optional, isPresent)); - continue; - case Fortran::lower::LowerIntrinsicArgAs::Box: - operands.emplace_back( - genOptionalBox(builder, loc, optional, isPresent)); - continue; - case Fortran::lower::LowerIntrinsicArgAs::Inquired: - operands.emplace_back(optional); - continue; - } - llvm_unreachable("bad switch"); - } - switch (argRules.lowerAs) { - case Fortran::lower::LowerIntrinsicArgAs::Value: - operands.emplace_back(genval(*expr)); - continue; - case Fortran::lower::LowerIntrinsicArgAs::Addr: - operands.emplace_back(gen(*expr)); - continue; - case Fortran::lower::LowerIntrinsicArgAs::Box: - operands.emplace_back(lowerIntrinsicArgumentAsBox(*expr)); - continue; - case Fortran::lower::LowerIntrinsicArgAs::Inquired: - operands.emplace_back(lowerIntrinsicArgumentAsInquired(*expr)); - continue; - } - llvm_unreachable("bad switch"); - } - // Let the intrinsic library lower the intrinsic procedure call - return Fortran::lower::genIntrinsicCall(builder, getLoc(), name, resultType, - operands, stmtCtx); - } - template bool isScalar(const A &x) { return x.Rank() == 0; @@ -3025,24 +3153,8 @@ static bool elementTypeWasAdjusted(mlir::Type t) { return isAdjustedArrayElementType(ty.getEleTy()); return false; } - -/// Build an ExtendedValue from a fir.array without actually setting -/// the actual extents and lengths. This is only to allow their propagation as -/// ExtendedValue without triggering verifier failures when propagating -/// character/arrays as unboxed values. Only the base of the resulting -/// ExtendedValue should be used, it is undefined to use the length or extents -/// of the extended value returned, -inline static fir::ExtendedValue -convertToArrayBoxValue(mlir::Location loc, fir::FirOpBuilder &builder, - mlir::Value val, mlir::Value len) { - mlir::Type ty = fir::unwrapRefType(val.getType()); - mlir::IndexType idxTy = builder.getIndexType(); - auto seqTy = ty.cast(); - auto undef = builder.create(loc, idxTy); - llvm::SmallVector extents(seqTy.getDimension(), undef); - if (fir::isa_char(seqTy.getEleTy())) - return fir::CharArrayBoxValue(val, len ? len : undef, extents); - return fir::ArrayBoxValue(val, extents); +static mlir::Type adjustedArrayElementType(mlir::Type t) { + return isAdjustedArrayElementType(t) ? fir::ReferenceType::get(t) : t; } /// Helper to generate calls to scalar user defined assignment procedures. @@ -3162,6 +3274,25 @@ createCharArrayAmend(mlir::Location loc, fir::FirOpBuilder &builder, return amend; } +/// Build an ExtendedValue from a fir.array without actually setting +/// the actual extents and lengths. This is only to allow their propagation as +/// ExtendedValue without triggering verifier failures when propagating +/// character/arrays as unboxed values. Only the base of the resulting +/// ExtendedValue should be used, it is undefined to use the length or extents +/// of the extended value returned, +inline static fir::ExtendedValue +convertToArrayBoxValue(mlir::Location loc, fir::FirOpBuilder &builder, + mlir::Value val, mlir::Value len) { + mlir::Type ty = fir::unwrapRefType(val.getType()); + mlir::IndexType idxTy = builder.getIndexType(); + auto seqTy = ty.cast(); + auto undef = builder.create(loc, idxTy); + llvm::SmallVector extents(seqTy.getDimension(), undef); + if (fir::isa_char(seqTy.getEleTy())) + return fir::CharArrayBoxValue(val, len ? len : undef, extents); + return fir::ArrayBoxValue(val, extents); +} + //===----------------------------------------------------------------------===// // // Lowering of array expressions. @@ -3657,6 +3788,274 @@ public: return lexv; } +private: + void determineShapeOfDest(const fir::ExtendedValue &lhs) { + destShape = fir::factory::getExtents(builder, getLoc(), lhs); + } + + void determineShapeOfDest(const Fortran::lower::SomeExpr &lhs) { + if (!destShape.empty()) + return; + if (explicitSpaceIsActive() && determineShapeWithSlice(lhs)) + return; + mlir::Type idxTy = builder.getIndexType(); + mlir::Location loc = getLoc(); + if (std::optional constantShape = + Fortran::evaluate::GetConstantExtents(converter.getFoldingContext(), + lhs)) + for (Fortran::common::ConstantSubscript extent : *constantShape) + destShape.push_back(builder.createIntegerConstant(loc, idxTy, extent)); + } + + bool genShapeFromDataRef(const Fortran::semantics::Symbol &x) { + return false; + } + bool genShapeFromDataRef(const Fortran::evaluate::CoarrayRef &) { + TODO(getLoc(), "coarray ref"); + return false; + } + bool genShapeFromDataRef(const Fortran::evaluate::Component &x) { + return x.base().Rank() > 0 ? genShapeFromDataRef(x.base()) : false; + } + bool genShapeFromDataRef(const Fortran::evaluate::ArrayRef &x) { + if (x.Rank() == 0) + return false; + if (x.base().Rank() > 0) + if (genShapeFromDataRef(x.base())) + return true; + // x has rank and x.base did not produce a shape. + ExtValue exv = x.base().IsSymbol() ? asScalarRef(getFirstSym(x.base())) + : asScalarRef(x.base().GetComponent()); + mlir::Location loc = getLoc(); + mlir::IndexType idxTy = builder.getIndexType(); + llvm::SmallVector definedShape = + fir::factory::getExtents(builder, loc, exv); + mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1); + for (auto ss : llvm::enumerate(x.subscript())) { + std::visit(Fortran::common::visitors{ + [&](const Fortran::evaluate::Triplet &trip) { + // For a subscript of triple notation, we compute the + // range of this dimension of the iteration space. + auto lo = [&]() { + if (auto optLo = trip.lower()) + return fir::getBase(asScalar(*optLo)); + return getLBound(exv, ss.index(), one); + }(); + auto hi = [&]() { + if (auto optHi = trip.upper()) + return fir::getBase(asScalar(*optHi)); + return getUBound(exv, ss.index(), one); + }(); + auto step = builder.createConvert( + loc, idxTy, fir::getBase(asScalar(trip.stride()))); + auto extent = builder.genExtentFromTriplet(loc, lo, hi, + step, idxTy); + destShape.push_back(extent); + }, + [&](auto) {}}, + ss.value().u); + } + return true; + } + bool genShapeFromDataRef(const Fortran::evaluate::NamedEntity &x) { + if (x.IsSymbol()) + return genShapeFromDataRef(getFirstSym(x)); + return genShapeFromDataRef(x.GetComponent()); + } + bool genShapeFromDataRef(const Fortran::evaluate::DataRef &x) { + return std::visit([&](const auto &v) { return genShapeFromDataRef(v); }, + x.u); + } + + /// When in an explicit space, the ranked component must be evaluated to + /// determine the actual number of iterations when slicing triples are + /// present. Lower these expressions here. + bool determineShapeWithSlice(const Fortran::lower::SomeExpr &lhs) { + LLVM_DEBUG(Fortran::lower::DumpEvaluateExpr::dump( + llvm::dbgs() << "determine shape of:\n", lhs)); + // FIXME: We may not want to use ExtractDataRef here since it doesn't deal + // with substrings, etc. + std::optional dref = + Fortran::evaluate::ExtractDataRef(lhs); + return dref.has_value() ? genShapeFromDataRef(*dref) : false; + } + + /// CHARACTER and derived type elements are treated as memory references. The + /// numeric types are treated as values. + static mlir::Type adjustedArraySubtype(mlir::Type ty, + mlir::ValueRange indices) { + mlir::Type pathTy = fir::applyPathToType(ty, indices); + assert(pathTy && "indices failed to apply to type"); + return adjustedArrayElementType(pathTy); + } + + ExtValue lowerArrayExpression(const Fortran::lower::SomeExpr &exp) { + mlir::Type resTy = converter.genType(exp); + return std::visit( + [&](const auto &e) { return lowerArrayExpression(genarr(e), resTy); }, + exp.u); + } + ExtValue lowerArrayExpression(const ExtValue &exv) { + assert(!explicitSpace); + mlir::Type resTy = fir::unwrapPassByRefType(fir::getBase(exv).getType()); + return lowerArrayExpression(genarr(exv), resTy); + } + + void populateBounds(llvm::SmallVectorImpl &bounds, + const Fortran::evaluate::Substring *substring) { + if (!substring) + return; + bounds.push_back(fir::getBase(asScalar(substring->lower()))); + if (auto upper = substring->upper()) + bounds.push_back(fir::getBase(asScalar(*upper))); + } + + /// Default store to destination implementation. + /// This implements the default case, which is to assign the value in + /// `iters.element` into the destination array, `iters.innerArgument`. Handles + /// by value and by reference assignment. + CC defaultStoreToDestination(const Fortran::evaluate::Substring *substring) { + return [=](IterSpace iterSpace) -> ExtValue { + mlir::Location loc = getLoc(); + mlir::Value innerArg = iterSpace.innerArgument(); + fir::ExtendedValue exv = iterSpace.elementExv(); + mlir::Type arrTy = innerArg.getType(); + mlir::Type eleTy = fir::applyPathToType(arrTy, iterSpace.iterVec()); + if (isAdjustedArrayElementType(eleTy)) { + // The elemental update is in the memref domain. Under this semantics, + // we must always copy the computed new element from its location in + // memory into the destination array. + mlir::Type resRefTy = builder.getRefType(eleTy); + // Get a reference to the array element to be amended. + auto arrayOp = builder.create( + loc, resRefTy, innerArg, iterSpace.iterVec(), + destination.getTypeparams()); + if (auto charTy = eleTy.dyn_cast()) { + llvm::SmallVector substringBounds; + populateBounds(substringBounds, substring); + mlir::Value dstLen = fir::factory::genLenOfCharacter( + builder, loc, destination, iterSpace.iterVec(), substringBounds); + fir::ArrayAmendOp amend = createCharArrayAmend( + loc, builder, arrayOp, dstLen, exv, innerArg, substringBounds); + return abstractArrayExtValue(amend, dstLen); + } + if (fir::isa_derived(eleTy)) { + fir::ArrayAmendOp amend = createDerivedArrayAmend( + loc, destination, builder, arrayOp, exv, eleTy, innerArg); + return abstractArrayExtValue(amend /*FIXME: typeparams?*/); + } + assert(eleTy.isa() && "must be an array"); + TODO(loc, "array (as element) assignment"); + } + // By value semantics. The element is being assigned by value. + mlir::Value ele = builder.createConvert(loc, eleTy, fir::getBase(exv)); + auto update = builder.create( + loc, arrTy, innerArg, ele, iterSpace.iterVec(), + destination.getTypeparams()); + return abstractArrayExtValue(update); + }; + } + + /// For an elemental array expression. + /// 1. Lower the scalars and array loads. + /// 2. Create the iteration space. + /// 3. Create the element-by-element computation in the loop. + /// 4. Return the resulting array value. + /// If no destination was set in the array context, a temporary of + /// \p resultTy will be created to hold the evaluated expression. + /// Otherwise, \p resultTy is ignored and the expression is evaluated + /// in the destination. \p f is a continuation built from an + /// evaluate::Expr or an ExtendedValue. + ExtValue lowerArrayExpression(CC f, mlir::Type resultTy) { + mlir::Location loc = getLoc(); + auto [iterSpace, insPt] = genIterSpace(resultTy); + auto exv = f(iterSpace); + iterSpace.setElement(std::move(exv)); + auto lambda = ccStoreToDest.hasValue() + ? ccStoreToDest.getValue() + : defaultStoreToDestination(/*substring=*/nullptr); + mlir::Value updVal = fir::getBase(lambda(iterSpace)); + finalizeElementCtx(); + builder.create(loc, updVal); + builder.restoreInsertionPoint(insPt); + return abstractArrayExtValue(iterSpace.outerResult()); + } + + /// Compute the shape of a slice. + llvm::SmallVector computeSliceShape(mlir::Value slice) { + llvm::SmallVector slicedShape; + auto slOp = mlir::cast(slice.getDefiningOp()); + mlir::Operation::operand_range triples = slOp.getTriples(); + mlir::IndexType idxTy = builder.getIndexType(); + mlir::Location loc = getLoc(); + for (unsigned i = 0, end = triples.size(); i < end; i += 3) { + if (!mlir::isa_and_nonnull( + triples[i + 1].getDefiningOp())) { + // (..., lb:ub:step, ...) case: extent = max((ub-lb+step)/step, 0) + // See Fortran 2018 9.5.3.3.2 section for more details. + mlir::Value res = builder.genExtentFromTriplet( + loc, triples[i], triples[i + 1], triples[i + 2], idxTy); + slicedShape.emplace_back(res); + } else { + // do nothing. `..., i, ...` case, so dimension is dropped. + } + } + return slicedShape; + } + + /// Get the shape from an ArrayOperand. The shape of the array is adjusted if + /// the array was sliced. + llvm::SmallVector getShape(ArrayOperand array) { + if (array.slice) + return computeSliceShape(array.slice); + if (array.memref.getType().isa()) + return fir::factory::readExtents(builder, getLoc(), + fir::BoxValue{array.memref}); + std::vector> extents = + fir::factory::getExtents(array.shape); + return {extents.begin(), extents.end()}; + } + + /// Get the shape from an ArrayLoad. + llvm::SmallVector getShape(fir::ArrayLoadOp arrayLoad) { + return getShape(ArrayOperand{arrayLoad.getMemref(), arrayLoad.getShape(), + arrayLoad.getSlice()}); + } + + /// Returns the first array operand that may not be absent. If all + /// array operands may be absent, return the first one. + const ArrayOperand &getInducingShapeArrayOperand() const { + assert(!arrayOperands.empty()); + for (const ArrayOperand &op : arrayOperands) + if (!op.mayBeAbsent) + return op; + // If all arrays operand appears in optional position, then none of them + // is allowed to be absent as per 15.5.2.12 point 3. (6). Just pick the + // first operands. + // TODO: There is an opportunity to add a runtime check here that + // this array is present as required. + return arrayOperands[0]; + } + + /// Generate the shape of the iteration space over the array expression. The + /// iteration space may be implicit, explicit, or both. If it is implied it is + /// based on the destination and operand array loads, or an optional + /// Fortran::evaluate::Shape from the front end. If the shape is explicit, + /// this returns any implicit shape component, if it exists. + llvm::SmallVector genIterationShape() { + // Use the precomputed destination shape. + if (!destShape.empty()) + return destShape; + // Otherwise, use the destination's shape. + if (destination) + return getShape(destination); + // Otherwise, use the first ArrayLoad operand shape. + if (!arrayOperands.empty()) + return getShape(getInducingShapeArrayOperand()); + fir::emitFatalError(getLoc(), + "failed to compute the array expression shape"); + } + bool explicitSpaceIsActive() const { return explicitSpace && explicitSpace->isActive(); } @@ -3952,7 +4351,7 @@ public: builder.create(loc, innerArg); builder.setInsertionPointToStart(&ifOp.getThenRegion().front()); }; - for (std::size_t i = 0; i < size; ++i) + for (std::remove_const_t i = 0; i < size; ++i) if (const auto *e = maskExprs[i]) genFalseBlock(e, genCond(e, iters)); @@ -4046,12 +4445,6 @@ public: .lowerIntrinsicArgumentAsInquired(x); } - // An expression with non-zero rank is an array expression. - template - bool isArray(const A &x) const { - return x.Rank() != 0; - } - /// Some temporaries are allocated on an element-by-element basis during the /// array expression evaluation. Collect the cleanups here so the resources /// can be freed before the next loop iteration, avoiding memory leaks. etc. @@ -4411,12 +4804,20 @@ public: procRef, retTy)); } + CC genarr(const Fortran::evaluate::ProcedureDesignator &) { + TODO(getLoc(), "procedure designator"); + } + CC genarr(const Fortran::evaluate::ProcedureRef &x) { + if (x.hasAlternateReturns()) + fir::emitFatalError(getLoc(), + "array procedure reference with alt-return"); + return genProcRef(x, llvm::None); + } template CC genScalarAndForwardValue(const A &x) { ExtValue result = asScalar(x); return [=](IterSpace) { return result; }; } - template >> CC genarr(const A &x) { @@ -4471,7 +4872,14 @@ public: template CC genarr(const Fortran::evaluate::ComplexComponent &x) { - TODO(getLoc(), "ComplexComponent"); + mlir::Location loc = getLoc(); + auto lambda = genarr(x.left()); + bool isImagPart = x.isImaginaryPart; + return [=](IterSpace iters) -> ExtValue { + mlir::Value lhs = fir::getBase(lambda(iters)); + return fir::factory::Complex{builder, loc}.extractComplexPart(lhs, + isImagPart); + }; } template @@ -4578,17 +4986,53 @@ public: template CC genarr( const Fortran::evaluate::Extremum> &x) { - TODO(getLoc(), "genarr Extremum>"); + mlir::Location loc = getLoc(); + auto lf = genarr(x.left()); + auto rf = genarr(x.right()); + switch (x.ordering) { + case Fortran::evaluate::Ordering::Greater: + return [=](IterSpace iters) -> ExtValue { + mlir::Value lhs = fir::getBase(lf(iters)); + mlir::Value rhs = fir::getBase(rf(iters)); + return Fortran::lower::genMax(builder, loc, + llvm::ArrayRef{lhs, rhs}); + }; + case Fortran::evaluate::Ordering::Less: + return [=](IterSpace iters) -> ExtValue { + mlir::Value lhs = fir::getBase(lf(iters)); + mlir::Value rhs = fir::getBase(rf(iters)); + return Fortran::lower::genMin(builder, loc, + llvm::ArrayRef{lhs, rhs}); + }; + case Fortran::evaluate::Ordering::Equal: + llvm_unreachable("Equal is not a valid ordering in this context"); + } + llvm_unreachable("unknown ordering"); } template CC genarr( const Fortran::evaluate::RealToIntPower> &x) { - TODO(getLoc(), "genarr RealToIntPower>"); + mlir::Location loc = getLoc(); + auto ty = converter.genType(TC, KIND); + auto lf = genarr(x.left()); + auto rf = genarr(x.right()); + return [=](IterSpace iters) { + mlir::Value lhs = fir::getBase(lf(iters)); + mlir::Value rhs = fir::getBase(rf(iters)); + return Fortran::lower::genPow(builder, loc, ty, lhs, rhs); + }; } template CC genarr(const Fortran::evaluate::ComplexConstructor &x) { - TODO(getLoc(), "genarr ComplexConstructor"); + mlir::Location loc = getLoc(); + auto lf = genarr(x.left()); + auto rf = genarr(x.right()); + return [=](IterSpace iters) -> ExtValue { + mlir::Value lhs = fir::getBase(lf(iters)); + mlir::Value rhs = fir::getBase(rf(iters)); + return fir::factory::Complex{builder, loc}.createComplex(KIND, lhs, rhs); + }; } /// Fortran's concatenation operator `//`. @@ -4748,7 +5192,7 @@ public: template ExtValue genArrayBase(const A &base) { ScalarExprLowering sel{getLoc(), converter, symMap, stmtCtx}; - return base.IsSymbol() ? sel.gen(base.GetFirstSymbol()) + return base.IsSymbol() ? sel.gen(getFirstSym(base)) : sel.gen(base.GetComponent()); } @@ -4966,6 +5410,26 @@ public: trips.clear(); } + static mlir::Type unwrapBoxEleTy(mlir::Type ty) { + if (auto boxTy = ty.dyn_cast()) + return fir::unwrapRefType(boxTy.getEleTy()); + return ty; + } + + llvm::SmallVector getShape(mlir::Type ty) { + llvm::SmallVector result; + ty = unwrapBoxEleTy(ty); + mlir::Location loc = getLoc(); + mlir::IndexType idxTy = builder.getIndexType(); + for (auto extent : ty.cast().getShape()) { + auto v = extent == fir::SequenceType::getUnknownExtent() + ? builder.create(loc, idxTy).getResult() + : builder.createIntegerConstant(loc, idxTy, extent); + result.push_back(v); + } + return result; + } + CC genarr(const Fortran::semantics::SymbolRef &sym, ComponentPath &components) { return genarr(sym.get(), components); @@ -4980,6 +5444,407 @@ public: return genarr(extMemref, dummy); } + /// Base case of generating an array reference, + CC genarr(const ExtValue &extMemref, ComponentPath &components) { + mlir::Location loc = getLoc(); + mlir::Value memref = fir::getBase(extMemref); + mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(memref.getType()); + assert(arrTy.isa() && "memory ref must be an array"); + mlir::Value shape = builder.createShape(loc, extMemref); + mlir::Value slice; + if (components.isSlice()) { + if (isBoxValue() && components.substring) { + // Append the substring operator to emboxing Op as it will become an + // interior adjustment (add offset, adjust LEN) to the CHARACTER value + // being referenced in the descriptor. + llvm::SmallVector substringBounds; + populateBounds(substringBounds, components.substring); + // Convert to (offset, size) + mlir::Type iTy = substringBounds[0].getType(); + if (substringBounds.size() != 2) { + fir::CharacterType charTy = + fir::factory::CharacterExprHelper::getCharType(arrTy); + if (charTy.hasConstantLen()) { + mlir::IndexType idxTy = builder.getIndexType(); + fir::CharacterType::LenType charLen = charTy.getLen(); + mlir::Value lenValue = + builder.createIntegerConstant(loc, idxTy, charLen); + substringBounds.push_back(lenValue); + } else { + llvm::SmallVector typeparams = + fir::getTypeParams(extMemref); + substringBounds.push_back(typeparams.back()); + } + } + // Convert the lower bound to 0-based substring. + mlir::Value one = + builder.createIntegerConstant(loc, substringBounds[0].getType(), 1); + substringBounds[0] = + builder.create(loc, substringBounds[0], one); + // Convert the upper bound to a length. + mlir::Value cast = builder.createConvert(loc, iTy, substringBounds[1]); + mlir::Value zero = builder.createIntegerConstant(loc, iTy, 0); + auto size = + builder.create(loc, cast, substringBounds[0]); + auto cmp = builder.create( + loc, mlir::arith::CmpIPredicate::sgt, size, zero); + // size = MAX(upper - (lower - 1), 0) + substringBounds[1] = + builder.create(loc, cmp, size, zero); + slice = builder.create(loc, components.trips, + components.suffixComponents, + substringBounds); + } else { + slice = builder.createSlice(loc, extMemref, components.trips, + components.suffixComponents); + } + if (components.hasComponents()) { + auto seqTy = arrTy.cast(); + mlir::Type eleTy = + fir::applyPathToType(seqTy.getEleTy(), components.suffixComponents); + if (!eleTy) + fir::emitFatalError(loc, "slicing path is ill-formed"); + if (auto realTy = eleTy.dyn_cast()) + eleTy = Fortran::lower::convertReal(realTy.getContext(), + realTy.getFKind()); + + // create the type of the projected array. + arrTy = fir::SequenceType::get(seqTy.getShape(), eleTy); + LLVM_DEBUG(llvm::dbgs() + << "type of array projection from component slicing: " + << eleTy << ", " << arrTy << '\n'); + } + } + arrayOperands.push_back(ArrayOperand{memref, shape, slice}); + if (destShape.empty()) + destShape = getShape(arrayOperands.back()); + if (isBoxValue()) { + // Semantics are a reference to a boxed array. + // This case just requires that an embox operation be created to box the + // value. The value of the box is forwarded in the continuation. + mlir::Type reduceTy = reduceRank(arrTy, slice); + auto boxTy = fir::BoxType::get(reduceTy); + if (components.substring) { + // Adjust char length to substring size. + fir::CharacterType charTy = + fir::factory::CharacterExprHelper::getCharType(reduceTy); + auto seqTy = reduceTy.cast(); + // TODO: Use a constant for fir.char LEN if we can compute it. + boxTy = fir::BoxType::get( + fir::SequenceType::get(fir::CharacterType::getUnknownLen( + builder.getContext(), charTy.getFKind()), + seqTy.getDimension())); + } + mlir::Value embox = + memref.getType().isa() + ? builder.create(loc, boxTy, memref, shape, slice) + .getResult() + : builder + .create(loc, boxTy, memref, shape, slice, + fir::getTypeParams(extMemref)) + .getResult(); + return [=](IterSpace) -> ExtValue { return fir::BoxValue(embox); }; + } + auto eleTy = arrTy.cast().getEleTy(); + if (isReferentiallyOpaque()) { + // Semantics are an opaque reference to an array. + // This case forwards a continuation that will generate the address + // arithmetic to the array element. This does not have copy-in/copy-out + // semantics. No attempt to copy the array value will be made during the + // interpretation of the Fortran statement. + mlir::Type refEleTy = builder.getRefType(eleTy); + return [=](IterSpace iters) -> ExtValue { + // ArrayCoorOp does not expect zero based indices. + llvm::SmallVector indices = fir::factory::originateIndices( + loc, builder, memref.getType(), shape, iters.iterVec()); + mlir::Value coor = builder.create( + loc, refEleTy, memref, shape, slice, indices, + fir::getTypeParams(extMemref)); + if (auto charTy = eleTy.dyn_cast()) { + llvm::SmallVector substringBounds; + populateBounds(substringBounds, components.substring); + if (!substringBounds.empty()) { + mlir::Value dstLen = fir::factory::genLenOfCharacter( + builder, loc, arrTy.cast(), memref, + fir::getTypeParams(extMemref), iters.iterVec(), + substringBounds); + fir::CharBoxValue dstChar(coor, dstLen); + return fir::factory::CharacterExprHelper{builder, loc} + .createSubstring(dstChar, substringBounds); + } + } + return fir::factory::arraySectionElementToExtendedValue( + builder, loc, extMemref, coor, slice); + }; + } + auto arrLoad = builder.create( + loc, arrTy, memref, shape, slice, fir::getTypeParams(extMemref)); + mlir::Value arrLd = arrLoad.getResult(); + if (isProjectedCopyInCopyOut()) { + // Semantics are projected copy-in copy-out. + // The backing store of the destination of an array expression may be + // partially modified. These updates are recorded in FIR by forwarding a + // continuation that generates an `array_update` Op. The destination is + // always loaded at the beginning of the statement and merged at the + // end. + destination = arrLoad; + auto lambda = ccStoreToDest.hasValue() + ? ccStoreToDest.getValue() + : defaultStoreToDestination(components.substring); + return [=](IterSpace iters) -> ExtValue { return lambda(iters); }; + } + if (isCustomCopyInCopyOut()) { + // Create an array_modify to get the LHS element address and indicate + // the assignment, the actual assignment must be implemented in + // ccStoreToDest. + destination = arrLoad; + return [=](IterSpace iters) -> ExtValue { + mlir::Value innerArg = iters.innerArgument(); + mlir::Type resTy = innerArg.getType(); + mlir::Type eleTy = fir::applyPathToType(resTy, iters.iterVec()); + mlir::Type refEleTy = + fir::isa_ref_type(eleTy) ? eleTy : builder.getRefType(eleTy); + auto arrModify = builder.create( + loc, mlir::TypeRange{refEleTy, resTy}, innerArg, iters.iterVec(), + destination.getTypeparams()); + return abstractArrayExtValue(arrModify.getResult(1)); + }; + } + if (isCopyInCopyOut()) { + // Semantics are copy-in copy-out. + // The continuation simply forwards the result of the `array_load` Op, + // which is the value of the array as it was when loaded. All data + // references with rank > 0 in an array expression typically have + // copy-in copy-out semantics. + return [=](IterSpace) -> ExtValue { return arrLd; }; + } + mlir::Operation::operand_range arrLdTypeParams = arrLoad.getTypeparams(); + if (isValueAttribute()) { + // Semantics are value attribute. + // Here the continuation will `array_fetch` a value from an array and + // then store that value in a temporary. One can thus imitate pass by + // value even when the call is pass by reference. + return [=](IterSpace iters) -> ExtValue { + mlir::Value base; + mlir::Type eleTy = fir::applyPathToType(arrTy, iters.iterVec()); + if (isAdjustedArrayElementType(eleTy)) { + mlir::Type eleRefTy = builder.getRefType(eleTy); + base = builder.create( + loc, eleRefTy, arrLd, iters.iterVec(), arrLdTypeParams); + } else { + base = builder.create( + loc, eleTy, arrLd, iters.iterVec(), arrLdTypeParams); + } + mlir::Value temp = builder.createTemporary( + loc, base.getType(), + llvm::ArrayRef{ + Fortran::lower::getAdaptToByRefAttr(builder)}); + builder.create(loc, base, temp); + return fir::factory::arraySectionElementToExtendedValue( + builder, loc, extMemref, temp, slice); + }; + } + // In the default case, the array reference forwards an `array_fetch` or + // `array_access` Op in the continuation. + return [=](IterSpace iters) -> ExtValue { + mlir::Type eleTy = fir::applyPathToType(arrTy, iters.iterVec()); + if (isAdjustedArrayElementType(eleTy)) { + mlir::Type eleRefTy = builder.getRefType(eleTy); + mlir::Value arrayOp = builder.create( + loc, eleRefTy, arrLd, iters.iterVec(), arrLdTypeParams); + if (auto charTy = eleTy.dyn_cast()) { + llvm::SmallVector substringBounds; + populateBounds(substringBounds, components.substring); + if (!substringBounds.empty()) { + mlir::Value dstLen = fir::factory::genLenOfCharacter( + builder, loc, arrLoad, iters.iterVec(), substringBounds); + fir::CharBoxValue dstChar(arrayOp, dstLen); + return fir::factory::CharacterExprHelper{builder, loc} + .createSubstring(dstChar, substringBounds); + } + } + return fir::factory::arraySectionElementToExtendedValue( + builder, loc, extMemref, arrayOp, slice); + } + auto arrFetch = builder.create( + loc, eleTy, arrLd, iters.iterVec(), arrLdTypeParams); + return fir::factory::arraySectionElementToExtendedValue( + builder, loc, extMemref, arrFetch, slice); + }; + } + + /// Given an optional fir.box, returns an fir.box that is the original one if + /// it is present and it otherwise an unallocated box. + /// Absent fir.box are implemented as a null pointer descriptor. Generated + /// code may need to unconditionally read a fir.box that can be absent. + /// This helper allows creating a fir.box that can be read in all cases + /// outside of a fir.if (isPresent) region. However, the usages of the value + /// read from such box should still only be done in a fir.if(isPresent). + static fir::ExtendedValue + absentBoxToUnalllocatedBox(fir::FirOpBuilder &builder, mlir::Location loc, + const fir::ExtendedValue &exv, + mlir::Value isPresent) { + mlir::Value box = fir::getBase(exv); + mlir::Type boxType = box.getType(); + assert(boxType.isa() && "argument must be a fir.box"); + mlir::Value emptyBox = + fir::factory::createUnallocatedBox(builder, loc, boxType, llvm::None); + auto safeToReadBox = + builder.create(loc, isPresent, box, emptyBox); + return fir::substBase(exv, safeToReadBox); + } + + std::tuple + genOptionalArrayFetch(const Fortran::lower::SomeExpr &expr) { + assert(expr.Rank() > 0 && "expr must be an array"); + mlir::Location loc = getLoc(); + ExtValue optionalArg = asInquired(expr); + mlir::Value isPresent = genActualIsPresentTest(builder, loc, optionalArg); + // Generate an array load and access to an array that may be an absent + // optional or an unallocated optional. + mlir::Value base = getBase(optionalArg); + const bool hasOptionalAttr = + fir::valueHasFirAttribute(base, fir::getOptionalAttrName()); + mlir::Type baseType = fir::unwrapRefType(base.getType()); + const bool isBox = baseType.isa(); + const bool isAllocOrPtr = Fortran::evaluate::IsAllocatableOrPointerObject( + expr, converter.getFoldingContext()); + mlir::Type arrType = fir::unwrapPassByRefType(baseType); + mlir::Type eleType = fir::unwrapSequenceType(arrType); + ExtValue exv = optionalArg; + if (hasOptionalAttr && isBox && !isAllocOrPtr) { + // Elemental argument cannot be allocatable or pointers (C15100). + // Hence, per 15.5.2.12 3 (8) and (9), the provided Allocatable and + // Pointer optional arrays cannot be absent. The only kind of entities + // that can get here are optional assumed shape and polymorphic entities. + exv = absentBoxToUnalllocatedBox(builder, loc, exv, isPresent); + } + // All the properties can be read from any fir.box but the read values may + // be undefined and should only be used inside a fir.if (canBeRead) region. + if (const auto *mutableBox = exv.getBoxOf()) + exv = fir::factory::genMutableBoxRead(builder, loc, *mutableBox); + + mlir::Value memref = fir::getBase(exv); + mlir::Value shape = builder.createShape(loc, exv); + mlir::Value noSlice; + auto arrLoad = builder.create( + loc, arrType, memref, shape, noSlice, fir::getTypeParams(exv)); + mlir::Operation::operand_range arrLdTypeParams = arrLoad.getTypeparams(); + mlir::Value arrLd = arrLoad.getResult(); + // Mark the load to tell later passes it is unsafe to use this array_load + // shape unconditionally. + arrLoad->setAttr(fir::getOptionalAttrName(), builder.getUnitAttr()); + + // Place the array as optional on the arrayOperands stack so that its + // shape will only be used as a fallback to induce the implicit loop nest + // (that is if there is no non optional array arguments). + arrayOperands.push_back( + ArrayOperand{memref, shape, noSlice, /*mayBeAbsent=*/true}); + + // By value semantics. + auto cc = [=](IterSpace iters) -> ExtValue { + auto arrFetch = builder.create( + loc, eleType, arrLd, iters.iterVec(), arrLdTypeParams); + return fir::factory::arraySectionElementToExtendedValue( + builder, loc, exv, arrFetch, noSlice); + }; + return {cc, isPresent, eleType}; + } + + /// Generate a continuation to pass \p expr to an OPTIONAL argument of an + /// elemental procedure. This is meant to handle the cases where \p expr might + /// be dynamically absent (i.e. when it is a POINTER, an ALLOCATABLE or an + /// OPTIONAL variable). If p\ expr is guaranteed to be present genarr() can + /// directly be called instead. + CC genarrForwardOptionalArgumentToCall(const Fortran::lower::SomeExpr &expr) { + mlir::Location loc = getLoc(); + // Only by-value numerical and logical so far. + if (semant != ConstituentSemantics::RefTransparent) + TODO(loc, "optional arguments in user defined elemental procedures"); + + // Handle scalar argument case (the if-then-else is generated outside of the + // implicit loop nest). + if (expr.Rank() == 0) { + ExtValue optionalArg = asInquired(expr); + mlir::Value isPresent = genActualIsPresentTest(builder, loc, optionalArg); + mlir::Value elementValue = + fir::getBase(genOptionalValue(builder, loc, optionalArg, isPresent)); + return [=](IterSpace iters) -> ExtValue { return elementValue; }; + } + + CC cc; + mlir::Value isPresent; + mlir::Type eleType; + std::tie(cc, isPresent, eleType) = genOptionalArrayFetch(expr); + return [=](IterSpace iters) -> ExtValue { + mlir::Value elementValue = + builder + .genIfOp(loc, {eleType}, isPresent, + /*withElseRegion=*/true) + .genThen([&]() { + builder.create(loc, fir::getBase(cc(iters))); + }) + .genElse([&]() { + mlir::Value zero = + fir::factory::createZeroValue(builder, loc, eleType); + builder.create(loc, zero); + }) + .getResults()[0]; + return elementValue; + }; + } + + /// Reduce the rank of a array to be boxed based on the slice's operands. + static mlir::Type reduceRank(mlir::Type arrTy, mlir::Value slice) { + if (slice) { + auto slOp = mlir::dyn_cast(slice.getDefiningOp()); + assert(slOp && "expected slice op"); + auto seqTy = arrTy.dyn_cast(); + assert(seqTy && "expected array type"); + mlir::Operation::operand_range triples = slOp.getTriples(); + fir::SequenceType::Shape shape; + // reduce the rank for each invariant dimension + for (unsigned i = 1, end = triples.size(); i < end; i += 3) + if (!mlir::isa_and_nonnull(triples[i].getDefiningOp())) + shape.push_back(fir::SequenceType::getUnknownExtent()); + return fir::SequenceType::get(shape, seqTy.getEleTy()); + } + // not sliced, so no change in rank + return arrTy; + } + + /// Example: array%RE + CC genarr(const Fortran::evaluate::ComplexPart &x, + ComponentPath &components) { + components.reversePath.push_back(&x); + return genarr(x.complex(), components); + } + + template + CC genSlicePath(const A &x, ComponentPath &components) { + return genarr(x, components); + } + + CC genarr(const Fortran::evaluate::StaticDataObject::Pointer &, + ComponentPath &components) { + fir::emitFatalError(getLoc(), "substring of static array object"); + } + + /// Substrings (see 9.4.1) + CC genarr(const Fortran::evaluate::Substring &x, ComponentPath &components) { + components.substring = &x; + return std::visit([&](const auto &v) { return genarr(v, components); }, + x.parent()); + } + + template + CC genarr(const Fortran::evaluate::FunctionRef &funRef) { + // Note that it's possible that the function being called returns either an + // array or a scalar. In the first case, use the element type of the array. + return genProcRef( + funRef, fir::unwrapSequenceType(converter.genType(toEvExpr(funRef)))); + } + //===--------------------------------------------------------------------===// // Array construction //===--------------------------------------------------------------------===// @@ -5387,19 +6252,19 @@ public: } CC genarr(const Fortran::evaluate::ImpliedDoIndex &) { - TODO(getLoc(), "genarr ImpliedDoIndex"); + fir::emitFatalError(getLoc(), "implied do index cannot have rank > 0"); } - CC genarr(const Fortran::evaluate::TypeParamInquiry &x) { - TODO(getLoc(), "genarr TypeParamInquiry"); + TODO(getLoc(), "array expr type parameter inquiry"); + return [](IterSpace iters) -> ExtValue { return mlir::Value{}; }; } - CC genarr(const Fortran::evaluate::DescriptorInquiry &x) { - TODO(getLoc(), "genarr DescriptorInquiry"); + TODO(getLoc(), "array expr descriptor inquiry"); + return [](IterSpace iters) -> ExtValue { return mlir::Value{}; }; } - CC genarr(const Fortran::evaluate::StructureConstructor &x) { - TODO(getLoc(), "genarr StructureConstructor"); + TODO(getLoc(), "structure constructor"); + return [](IterSpace iters) -> ExtValue { return mlir::Value{}; }; } //===--------------------------------------------------------------------===// @@ -5524,12 +6389,12 @@ public: des.u); } - template - CC genarr(const Fortran::evaluate::FunctionRef &funRef) { - // Note that it's possible that the function being called returns either an - // array or a scalar. In the first case, use the element type of the array. - return genProcRef( - funRef, fir::unwrapSequenceType(converter.genType(toEvExpr(funRef)))); + /// Is the path component rank > 0? + static bool ranked(const PathComponent &x) { + return std::visit(Fortran::common::visitors{ + [](const ImplicitSubscripts &) { return false; }, + [](const auto *v) { return v->Rank() > 0; }}, + x); } //===-------------------------------------------------------------------===// @@ -5765,7 +6630,7 @@ public: CC genImplicitArrayAccess(const Fortran::evaluate::NamedEntity &x, ComponentPath &components) { if (x.IsSymbol()) - return genImplicitArrayAccess(x.GetFirstSymbol(), components); + return genImplicitArrayAccess(getFirstSym(x), components); return genImplicitArrayAccess(x.GetComponent(), components); } @@ -5780,7 +6645,8 @@ public: mlir::Type eleTy = fir::unwrapRefType(val.getType()); if (isAdjustedArrayElementType(eleTy)) { if (fir::isa_char(eleTy)) { - TODO(getLoc(), "assignment of character type"); + fir::factory::CharacterExprHelper{*builder, loc}.createAssign( + exv, iters.elementExv()); } else if (fir::isa_derived(eleTy)) { TODO(loc, "assignment of derived type"); } else { @@ -5884,7 +6750,7 @@ public: CC genarr(const Fortran::evaluate::NamedEntity &x, ComponentPath &components) { - return x.IsSymbol() ? genarr(x.GetFirstSymbol(), components) + return x.IsSymbol() ? genarr(getFirstSym(x), components) : genarr(x.GetComponent(), components); } @@ -5897,652 +6763,6 @@ public: return components.reversePath.empty(); } - /// Given an optional fir.box, returns an fir.box that is the original one if - /// it is present and it otherwise an unallocated box. - /// Absent fir.box are implemented as a null pointer descriptor. Generated - /// code may need to unconditionally read a fir.box that can be absent. - /// This helper allows creating a fir.box that can be read in all cases - /// outside of a fir.if (isPresent) region. However, the usages of the value - /// read from such box should still only be done in a fir.if(isPresent). - static fir::ExtendedValue - absentBoxToUnalllocatedBox(fir::FirOpBuilder &builder, mlir::Location loc, - const fir::ExtendedValue &exv, - mlir::Value isPresent) { - mlir::Value box = fir::getBase(exv); - mlir::Type boxType = box.getType(); - assert(boxType.isa() && "argument must be a fir.box"); - mlir::Value emptyBox = - fir::factory::createUnallocatedBox(builder, loc, boxType, llvm::None); - auto safeToReadBox = - builder.create(loc, isPresent, box, emptyBox); - return fir::substBase(exv, safeToReadBox); - } - - std::tuple - genOptionalArrayFetch(const Fortran::lower::SomeExpr &expr) { - assert(expr.Rank() > 0 && "expr must be an array"); - mlir::Location loc = getLoc(); - ExtValue optionalArg = asInquired(expr); - mlir::Value isPresent = genActualIsPresentTest(builder, loc, optionalArg); - // Generate an array load and access to an array that may be an absent - // optional or an unallocated optional. - mlir::Value base = getBase(optionalArg); - const bool hasOptionalAttr = - fir::valueHasFirAttribute(base, fir::getOptionalAttrName()); - mlir::Type baseType = fir::unwrapRefType(base.getType()); - const bool isBox = baseType.isa(); - const bool isAllocOrPtr = Fortran::evaluate::IsAllocatableOrPointerObject( - expr, converter.getFoldingContext()); - mlir::Type arrType = fir::unwrapPassByRefType(baseType); - mlir::Type eleType = fir::unwrapSequenceType(arrType); - ExtValue exv = optionalArg; - if (hasOptionalAttr && isBox && !isAllocOrPtr) { - // Elemental argument cannot be allocatable or pointers (C15100). - // Hence, per 15.5.2.12 3 (8) and (9), the provided Allocatable and - // Pointer optional arrays cannot be absent. The only kind of entities - // that can get here are optional assumed shape and polymorphic entities. - exv = absentBoxToUnalllocatedBox(builder, loc, exv, isPresent); - } - // All the properties can be read from any fir.box but the read values may - // be undefined and should only be used inside a fir.if (canBeRead) region. - if (const auto *mutableBox = exv.getBoxOf()) - exv = fir::factory::genMutableBoxRead(builder, loc, *mutableBox); - - mlir::Value memref = fir::getBase(exv); - mlir::Value shape = builder.createShape(loc, exv); - mlir::Value noSlice; - auto arrLoad = builder.create( - loc, arrType, memref, shape, noSlice, fir::getTypeParams(exv)); - mlir::Operation::operand_range arrLdTypeParams = arrLoad.getTypeparams(); - mlir::Value arrLd = arrLoad.getResult(); - // Mark the load to tell later passes it is unsafe to use this array_load - // shape unconditionally. - arrLoad->setAttr(fir::getOptionalAttrName(), builder.getUnitAttr()); - - // Place the array as optional on the arrayOperands stack so that its - // shape will only be used as a fallback to induce the implicit loop nest - // (that is if there is no non optional array arguments). - arrayOperands.push_back( - ArrayOperand{memref, shape, noSlice, /*mayBeAbsent=*/true}); - - // By value semantics. - auto cc = [=](IterSpace iters) -> ExtValue { - auto arrFetch = builder.create( - loc, eleType, arrLd, iters.iterVec(), arrLdTypeParams); - return fir::factory::arraySectionElementToExtendedValue( - builder, loc, exv, arrFetch, noSlice); - }; - return {cc, isPresent, eleType}; - } - - /// Generate a continuation to pass \p expr to an OPTIONAL argument of an - /// elemental procedure. This is meant to handle the cases where \p expr might - /// be dynamically absent (i.e. when it is a POINTER, an ALLOCATABLE or an - /// OPTIONAL variable). If p\ expr is guaranteed to be present genarr() can - /// directly be called instead. - CC genarrForwardOptionalArgumentToCall(const Fortran::lower::SomeExpr &expr) { - mlir::Location loc = getLoc(); - // Only by-value numerical and logical so far. - if (semant != ConstituentSemantics::RefTransparent) - TODO(loc, "optional arguments in user defined elemental procedures"); - - // Handle scalar argument case (the if-then-else is generated outside of the - // implicit loop nest). - if (expr.Rank() == 0) { - ExtValue optionalArg = asInquired(expr); - mlir::Value isPresent = genActualIsPresentTest(builder, loc, optionalArg); - mlir::Value elementValue = - fir::getBase(genOptionalValue(builder, loc, optionalArg, isPresent)); - return [=](IterSpace iters) -> ExtValue { return elementValue; }; - } - - CC cc; - mlir::Value isPresent; - mlir::Type eleType; - std::tie(cc, isPresent, eleType) = genOptionalArrayFetch(expr); - return [=](IterSpace iters) -> ExtValue { - mlir::Value elementValue = - builder - .genIfOp(loc, {eleType}, isPresent, - /*withElseRegion=*/true) - .genThen([&]() { - builder.create(loc, fir::getBase(cc(iters))); - }) - .genElse([&]() { - mlir::Value zero = - fir::factory::createZeroValue(builder, loc, eleType); - builder.create(loc, zero); - }) - .getResults()[0]; - return elementValue; - }; - } - - /// Reduce the rank of a array to be boxed based on the slice's operands. - static mlir::Type reduceRank(mlir::Type arrTy, mlir::Value slice) { - if (slice) { - auto slOp = mlir::dyn_cast(slice.getDefiningOp()); - assert(slOp && "expected slice op"); - auto seqTy = arrTy.dyn_cast(); - assert(seqTy && "expected array type"); - mlir::Operation::operand_range triples = slOp.getTriples(); - fir::SequenceType::Shape shape; - // reduce the rank for each invariant dimension - for (unsigned i = 1, end = triples.size(); i < end; i += 3) - if (!mlir::isa_and_nonnull(triples[i].getDefiningOp())) - shape.push_back(fir::SequenceType::getUnknownExtent()); - return fir::SequenceType::get(shape, seqTy.getEleTy()); - } - // not sliced, so no change in rank - return arrTy; - } - - CC genarr(const Fortran::evaluate::ComplexPart &x, - ComponentPath &components) { - components.reversePath.push_back(&x); - return genarr(x.complex(), components); - } - - CC genarr(const Fortran::evaluate::StaticDataObject::Pointer &, - ComponentPath &components) { - TODO(getLoc(), "genarr StaticDataObject::Pointer"); - } - - /// Substrings (see 9.4.1) - CC genarr(const Fortran::evaluate::Substring &x, ComponentPath &components) { - components.substring = &x; - return std::visit([&](const auto &v) { return genarr(v, components); }, - x.parent()); - } - - /// Base case of generating an array reference, - CC genarr(const ExtValue &extMemref, ComponentPath &components) { - mlir::Location loc = getLoc(); - mlir::Value memref = fir::getBase(extMemref); - mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(memref.getType()); - assert(arrTy.isa() && "memory ref must be an array"); - mlir::Value shape = builder.createShape(loc, extMemref); - mlir::Value slice; - if (components.isSlice()) { - if (isBoxValue() && components.substring) { - // Append the substring operator to emboxing Op as it will become an - // interior adjustment (add offset, adjust LEN) to the CHARACTER value - // being referenced in the descriptor. - llvm::SmallVector substringBounds; - populateBounds(substringBounds, components.substring); - // Convert to (offset, size) - mlir::Type iTy = substringBounds[0].getType(); - if (substringBounds.size() != 2) { - fir::CharacterType charTy = - fir::factory::CharacterExprHelper::getCharType(arrTy); - if (charTy.hasConstantLen()) { - mlir::IndexType idxTy = builder.getIndexType(); - fir::CharacterType::LenType charLen = charTy.getLen(); - mlir::Value lenValue = - builder.createIntegerConstant(loc, idxTy, charLen); - substringBounds.push_back(lenValue); - } else { - llvm::SmallVector typeparams = - fir::getTypeParams(extMemref); - substringBounds.push_back(typeparams.back()); - } - } - // Convert the lower bound to 0-based substring. - mlir::Value one = - builder.createIntegerConstant(loc, substringBounds[0].getType(), 1); - substringBounds[0] = - builder.create(loc, substringBounds[0], one); - // Convert the upper bound to a length. - mlir::Value cast = builder.createConvert(loc, iTy, substringBounds[1]); - mlir::Value zero = builder.createIntegerConstant(loc, iTy, 0); - auto size = - builder.create(loc, cast, substringBounds[0]); - auto cmp = builder.create( - loc, mlir::arith::CmpIPredicate::sgt, size, zero); - // size = MAX(upper - (lower - 1), 0) - substringBounds[1] = - builder.create(loc, cmp, size, zero); - slice = builder.create(loc, components.trips, - components.suffixComponents, - substringBounds); - } else { - slice = builder.createSlice(loc, extMemref, components.trips, - components.suffixComponents); - } - if (components.hasComponents()) { - auto seqTy = arrTy.cast(); - mlir::Type eleTy = - fir::applyPathToType(seqTy.getEleTy(), components.suffixComponents); - if (!eleTy) - fir::emitFatalError(loc, "slicing path is ill-formed"); - if (auto realTy = eleTy.dyn_cast()) - eleTy = Fortran::lower::convertReal(realTy.getContext(), - realTy.getFKind()); - - // create the type of the projected array. - arrTy = fir::SequenceType::get(seqTy.getShape(), eleTy); - LLVM_DEBUG(llvm::dbgs() - << "type of array projection from component slicing: " - << eleTy << ", " << arrTy << '\n'); - } - } - arrayOperands.push_back(ArrayOperand{memref, shape, slice}); - if (destShape.empty()) - destShape = getShape(arrayOperands.back()); - if (isBoxValue()) { - // Semantics are a reference to a boxed array. - // This case just requires that an embox operation be created to box the - // value. The value of the box is forwarded in the continuation. - mlir::Type reduceTy = reduceRank(arrTy, slice); - auto boxTy = fir::BoxType::get(reduceTy); - if (components.substring) { - // Adjust char length to substring size. - fir::CharacterType charTy = - fir::factory::CharacterExprHelper::getCharType(reduceTy); - auto seqTy = reduceTy.cast(); - // TODO: Use a constant for fir.char LEN if we can compute it. - boxTy = fir::BoxType::get( - fir::SequenceType::get(fir::CharacterType::getUnknownLen( - builder.getContext(), charTy.getFKind()), - seqTy.getDimension())); - } - mlir::Value embox = - memref.getType().isa() - ? builder.create(loc, boxTy, memref, shape, slice) - .getResult() - : builder - .create(loc, boxTy, memref, shape, slice, - fir::getTypeParams(extMemref)) - .getResult(); - return [=](IterSpace) -> ExtValue { return fir::BoxValue(embox); }; - } - auto eleTy = arrTy.cast().getEleTy(); - if (isReferentiallyOpaque()) { - // Semantics are an opaque reference to an array. - // This case forwards a continuation that will generate the address - // arithmetic to the array element. This does not have copy-in/copy-out - // semantics. No attempt to copy the array value will be made during the - // interpretation of the Fortran statement. - mlir::Type refEleTy = builder.getRefType(eleTy); - return [=](IterSpace iters) -> ExtValue { - // ArrayCoorOp does not expect zero based indices. - llvm::SmallVector indices = fir::factory::originateIndices( - loc, builder, memref.getType(), shape, iters.iterVec()); - mlir::Value coor = builder.create( - loc, refEleTy, memref, shape, slice, indices, - fir::getTypeParams(extMemref)); - if (auto charTy = eleTy.dyn_cast()) { - llvm::SmallVector substringBounds; - populateBounds(substringBounds, components.substring); - if (!substringBounds.empty()) { - mlir::Value dstLen = fir::factory::genLenOfCharacter( - builder, loc, arrTy.cast(), memref, - fir::getTypeParams(extMemref), iters.iterVec(), - substringBounds); - fir::CharBoxValue dstChar(coor, dstLen); - return fir::factory::CharacterExprHelper{builder, loc} - .createSubstring(dstChar, substringBounds); - } - } - return fir::factory::arraySectionElementToExtendedValue( - builder, loc, extMemref, coor, slice); - }; - } - auto arrLoad = builder.create( - loc, arrTy, memref, shape, slice, fir::getTypeParams(extMemref)); - mlir::Value arrLd = arrLoad.getResult(); - if (isProjectedCopyInCopyOut()) { - // Semantics are projected copy-in copy-out. - // The backing store of the destination of an array expression may be - // partially modified. These updates are recorded in FIR by forwarding a - // continuation that generates an `array_update` Op. The destination is - // always loaded at the beginning of the statement and merged at the - // end. - destination = arrLoad; - auto lambda = ccStoreToDest.hasValue() - ? ccStoreToDest.getValue() - : defaultStoreToDestination(components.substring); - return [=](IterSpace iters) -> ExtValue { return lambda(iters); }; - } - if (isCustomCopyInCopyOut()) { - // Create an array_modify to get the LHS element address and indicate - // the assignment, the actual assignment must be implemented in - // ccStoreToDest. - destination = arrLoad; - return [=](IterSpace iters) -> ExtValue { - mlir::Value innerArg = iters.innerArgument(); - mlir::Type resTy = innerArg.getType(); - mlir::Type eleTy = fir::applyPathToType(resTy, iters.iterVec()); - mlir::Type refEleTy = - fir::isa_ref_type(eleTy) ? eleTy : builder.getRefType(eleTy); - auto arrModify = builder.create( - loc, mlir::TypeRange{refEleTy, resTy}, innerArg, iters.iterVec(), - destination.getTypeparams()); - return abstractArrayExtValue(arrModify.getResult(1)); - }; - } - if (isCopyInCopyOut()) { - // Semantics are copy-in copy-out. - // The continuation simply forwards the result of the `array_load` Op, - // which is the value of the array as it was when loaded. All data - // references with rank > 0 in an array expression typically have - // copy-in copy-out semantics. - return [=](IterSpace) -> ExtValue { return arrLd; }; - } - mlir::Operation::operand_range arrLdTypeParams = arrLoad.getTypeparams(); - if (isValueAttribute()) { - // Semantics are value attribute. - // Here the continuation will `array_fetch` a value from an array and - // then store that value in a temporary. One can thus imitate pass by - // value even when the call is pass by reference. - return [=](IterSpace iters) -> ExtValue { - mlir::Value base; - mlir::Type eleTy = fir::applyPathToType(arrTy, iters.iterVec()); - if (isAdjustedArrayElementType(eleTy)) { - mlir::Type eleRefTy = builder.getRefType(eleTy); - base = builder.create( - loc, eleRefTy, arrLd, iters.iterVec(), arrLdTypeParams); - } else { - base = builder.create( - loc, eleTy, arrLd, iters.iterVec(), arrLdTypeParams); - } - mlir::Value temp = builder.createTemporary( - loc, base.getType(), - llvm::ArrayRef{ - Fortran::lower::getAdaptToByRefAttr(builder)}); - builder.create(loc, base, temp); - return fir::factory::arraySectionElementToExtendedValue( - builder, loc, extMemref, temp, slice); - }; - } - // In the default case, the array reference forwards an `array_fetch` or - // `array_access` Op in the continuation. - return [=](IterSpace iters) -> ExtValue { - mlir::Type eleTy = fir::applyPathToType(arrTy, iters.iterVec()); - if (isAdjustedArrayElementType(eleTy)) { - mlir::Type eleRefTy = builder.getRefType(eleTy); - mlir::Value arrayOp = builder.create( - loc, eleRefTy, arrLd, iters.iterVec(), arrLdTypeParams); - if (auto charTy = eleTy.dyn_cast()) { - llvm::SmallVector substringBounds; - populateBounds(substringBounds, components.substring); - if (!substringBounds.empty()) { - mlir::Value dstLen = fir::factory::genLenOfCharacter( - builder, loc, arrLoad, iters.iterVec(), substringBounds); - fir::CharBoxValue dstChar(arrayOp, dstLen); - return fir::factory::CharacterExprHelper{builder, loc} - .createSubstring(dstChar, substringBounds); - } - } - return fir::factory::arraySectionElementToExtendedValue( - builder, loc, extMemref, arrayOp, slice); - } - auto arrFetch = builder.create( - loc, eleTy, arrLd, iters.iterVec(), arrLdTypeParams); - return fir::factory::arraySectionElementToExtendedValue( - builder, loc, extMemref, arrFetch, slice); - }; - } - -private: - void determineShapeOfDest(const fir::ExtendedValue &lhs) { - destShape = fir::factory::getExtents(builder, getLoc(), lhs); - } - - void determineShapeOfDest(const Fortran::lower::SomeExpr &lhs) { - if (!destShape.empty()) - return; - if (explicitSpaceIsActive() && determineShapeWithSlice(lhs)) - return; - mlir::Type idxTy = builder.getIndexType(); - mlir::Location loc = getLoc(); - if (std::optional constantShape = - Fortran::evaluate::GetConstantExtents(converter.getFoldingContext(), - lhs)) - for (Fortran::common::ConstantSubscript extent : *constantShape) - destShape.push_back(builder.createIntegerConstant(loc, idxTy, extent)); - } - - bool genShapeFromDataRef(const Fortran::semantics::Symbol &x) { - return false; - } - bool genShapeFromDataRef(const Fortran::evaluate::CoarrayRef &) { - TODO(getLoc(), "coarray ref"); - return false; - } - bool genShapeFromDataRef(const Fortran::evaluate::Component &x) { - return x.base().Rank() > 0 ? genShapeFromDataRef(x.base()) : false; - } - bool genShapeFromDataRef(const Fortran::evaluate::ArrayRef &x) { - if (x.Rank() == 0) - return false; - if (x.base().Rank() > 0) - if (genShapeFromDataRef(x.base())) - return true; - // x has rank and x.base did not produce a shape. - ExtValue exv = x.base().IsSymbol() ? asScalarRef(getFirstSym(x.base())) - : asScalarRef(x.base().GetComponent()); - mlir::Location loc = getLoc(); - mlir::IndexType idxTy = builder.getIndexType(); - llvm::SmallVector definedShape = - fir::factory::getExtents(builder, loc, exv); - mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1); - for (auto ss : llvm::enumerate(x.subscript())) { - std::visit(Fortran::common::visitors{ - [&](const Fortran::evaluate::Triplet &trip) { - // For a subscript of triple notation, we compute the - // range of this dimension of the iteration space. - auto lo = [&]() { - if (auto optLo = trip.lower()) - return fir::getBase(asScalar(*optLo)); - return getLBound(exv, ss.index(), one); - }(); - auto hi = [&]() { - if (auto optHi = trip.upper()) - return fir::getBase(asScalar(*optHi)); - return getUBound(exv, ss.index(), one); - }(); - auto step = builder.createConvert( - loc, idxTy, fir::getBase(asScalar(trip.stride()))); - auto extent = builder.genExtentFromTriplet(loc, lo, hi, - step, idxTy); - destShape.push_back(extent); - }, - [&](auto) {}}, - ss.value().u); - } - return true; - } - bool genShapeFromDataRef(const Fortran::evaluate::NamedEntity &x) { - if (x.IsSymbol()) - return genShapeFromDataRef(getFirstSym(x)); - return genShapeFromDataRef(x.GetComponent()); - } - bool genShapeFromDataRef(const Fortran::evaluate::DataRef &x) { - return std::visit([&](const auto &v) { return genShapeFromDataRef(v); }, - x.u); - } - - /// When in an explicit space, the ranked component must be evaluated to - /// determine the actual number of iterations when slicing triples are - /// present. Lower these expressions here. - bool determineShapeWithSlice(const Fortran::lower::SomeExpr &lhs) { - LLVM_DEBUG(Fortran::lower::DumpEvaluateExpr::dump( - llvm::dbgs() << "determine shape of:\n", lhs)); - // FIXME: We may not want to use ExtractDataRef here since it doesn't deal - // with substrings, etc. - std::optional dref = - Fortran::evaluate::ExtractDataRef(lhs); - return dref.has_value() ? genShapeFromDataRef(*dref) : false; - } - - ExtValue lowerArrayExpression(const Fortran::lower::SomeExpr &exp) { - mlir::Type resTy = converter.genType(exp); - return std::visit( - [&](const auto &e) { return lowerArrayExpression(genarr(e), resTy); }, - exp.u); - } - ExtValue lowerArrayExpression(const ExtValue &exv) { - assert(!explicitSpace); - mlir::Type resTy = fir::unwrapPassByRefType(fir::getBase(exv).getType()); - return lowerArrayExpression(genarr(exv), resTy); - } - - void populateBounds(llvm::SmallVectorImpl &bounds, - const Fortran::evaluate::Substring *substring) { - if (!substring) - return; - bounds.push_back(fir::getBase(asScalar(substring->lower()))); - if (auto upper = substring->upper()) - bounds.push_back(fir::getBase(asScalar(*upper))); - } - - /// Default store to destination implementation. - /// This implements the default case, which is to assign the value in - /// `iters.element` into the destination array, `iters.innerArgument`. Handles - /// by value and by reference assignment. - CC defaultStoreToDestination(const Fortran::evaluate::Substring *substring) { - return [=](IterSpace iterSpace) -> ExtValue { - mlir::Location loc = getLoc(); - mlir::Value innerArg = iterSpace.innerArgument(); - fir::ExtendedValue exv = iterSpace.elementExv(); - mlir::Type arrTy = innerArg.getType(); - mlir::Type eleTy = fir::applyPathToType(arrTy, iterSpace.iterVec()); - if (isAdjustedArrayElementType(eleTy)) { - // The elemental update is in the memref domain. Under this semantics, - // we must always copy the computed new element from its location in - // memory into the destination array. - mlir::Type resRefTy = builder.getRefType(eleTy); - // Get a reference to the array element to be amended. - auto arrayOp = builder.create( - loc, resRefTy, innerArg, iterSpace.iterVec(), - destination.getTypeparams()); - if (auto charTy = eleTy.dyn_cast()) { - llvm::SmallVector substringBounds; - populateBounds(substringBounds, substring); - mlir::Value dstLen = fir::factory::genLenOfCharacter( - builder, loc, destination, iterSpace.iterVec(), substringBounds); - fir::ArrayAmendOp amend = createCharArrayAmend( - loc, builder, arrayOp, dstLen, exv, innerArg, substringBounds); - return abstractArrayExtValue(amend, dstLen); - } - if (fir::isa_derived(eleTy)) { - fir::ArrayAmendOp amend = createDerivedArrayAmend( - loc, destination, builder, arrayOp, exv, eleTy, innerArg); - return abstractArrayExtValue(amend /*FIXME: typeparams?*/); - } - assert(eleTy.isa() && "must be an array"); - TODO(loc, "array (as element) assignment"); - } - // By value semantics. The element is being assigned by value. - mlir::Value ele = builder.createConvert(loc, eleTy, fir::getBase(exv)); - auto update = builder.create( - loc, arrTy, innerArg, ele, iterSpace.iterVec(), - destination.getTypeparams()); - return abstractArrayExtValue(update); - }; - } - - /// For an elemental array expression. - /// 1. Lower the scalars and array loads. - /// 2. Create the iteration space. - /// 3. Create the element-by-element computation in the loop. - /// 4. Return the resulting array value. - /// If no destination was set in the array context, a temporary of - /// \p resultTy will be created to hold the evaluated expression. - /// Otherwise, \p resultTy is ignored and the expression is evaluated - /// in the destination. \p f is a continuation built from an - /// evaluate::Expr or an ExtendedValue. - ExtValue lowerArrayExpression(CC f, mlir::Type resultTy) { - mlir::Location loc = getLoc(); - auto [iterSpace, insPt] = genIterSpace(resultTy); - auto exv = f(iterSpace); - iterSpace.setElement(std::move(exv)); - auto lambda = ccStoreToDest.hasValue() - ? ccStoreToDest.getValue() - : defaultStoreToDestination(/*substring=*/nullptr); - mlir::Value updVal = fir::getBase(lambda(iterSpace)); - finalizeElementCtx(); - builder.create(loc, updVal); - builder.restoreInsertionPoint(insPt); - return abstractArrayExtValue(iterSpace.outerResult()); - } - - /// Compute the shape of a slice. - llvm::SmallVector computeSliceShape(mlir::Value slice) { - llvm::SmallVector slicedShape; - auto slOp = mlir::cast(slice.getDefiningOp()); - mlir::Operation::operand_range triples = slOp.getTriples(); - mlir::IndexType idxTy = builder.getIndexType(); - mlir::Location loc = getLoc(); - for (unsigned i = 0, end = triples.size(); i < end; i += 3) { - if (!mlir::isa_and_nonnull( - triples[i + 1].getDefiningOp())) { - // (..., lb:ub:step, ...) case: extent = max((ub-lb+step)/step, 0) - // See Fortran 2018 9.5.3.3.2 section for more details. - mlir::Value res = builder.genExtentFromTriplet( - loc, triples[i], triples[i + 1], triples[i + 2], idxTy); - slicedShape.emplace_back(res); - } else { - // do nothing. `..., i, ...` case, so dimension is dropped. - } - } - return slicedShape; - } - - /// Get the shape from an ArrayOperand. The shape of the array is adjusted if - /// the array was sliced. - llvm::SmallVector getShape(ArrayOperand array) { - if (array.slice) - return computeSliceShape(array.slice); - if (array.memref.getType().isa()) - return fir::factory::readExtents(builder, getLoc(), - fir::BoxValue{array.memref}); - std::vector> extents = - fir::factory::getExtents(array.shape); - return {extents.begin(), extents.end()}; - } - - /// Get the shape from an ArrayLoad. - llvm::SmallVector getShape(fir::ArrayLoadOp arrayLoad) { - return getShape(ArrayOperand{arrayLoad.getMemref(), arrayLoad.getShape(), - arrayLoad.getSlice()}); - } - - /// Returns the first array operand that may not be absent. If all - /// array operands may be absent, return the first one. - const ArrayOperand &getInducingShapeArrayOperand() const { - assert(!arrayOperands.empty()); - for (const ArrayOperand &op : arrayOperands) - if (!op.mayBeAbsent) - return op; - // If all arrays operand appears in optional position, then none of them - // is allowed to be absent as per 15.5.2.12 point 3. (6). Just pick the - // first operands. - // TODO: There is an opportunity to add a runtime check here that - // this array is present as required. - return arrayOperands[0]; - } - - /// Generate the shape of the iteration space over the array expression. The - /// iteration space may be implicit, explicit, or both. If it is implied it is - /// based on the destination and operand array loads, or an optional - /// Fortran::evaluate::Shape from the front end. If the shape is explicit, - /// this returns any implicit shape component, if it exists. - llvm::SmallVector genIterationShape() { - // Use the precomputed destination shape. - if (!destShape.empty()) - return destShape; - // Otherwise, use the destination's shape. - if (destination) - return getShape(destination); - // Otherwise, use the first ArrayLoad operand shape. - if (!arrayOperands.empty()) - return getShape(getInducingShapeArrayOperand()); - fir::emitFatalError(getLoc(), - "failed to compute the array expression shape"); - } - explicit ArrayExprLowering(Fortran::lower::AbstractConverter &converter, Fortran::lower::StatementContext &stmtCtx, Fortran::lower::SymMap &symMap) @@ -6587,6 +6807,7 @@ private: return semant == ConstituentSemantics::ProjectedCopyInCopyOut; } + // ???: Do we still need this? inline bool isCustomCopyInCopyOut() { return semant == ConstituentSemantics::CustomCopyInCopyOut; } @@ -6689,7 +6910,7 @@ fir::ExtendedValue Fortran::lower::createSomeExtendedAddress( const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "address: ") << '\n'); - return ScalarExprLowering{loc, converter, symMap, stmtCtx}.gen(expr); + return ScalarExprLowering(loc, converter, symMap, stmtCtx).gen(expr); } fir::ExtendedValue Fortran::lower::createInitializerAddress( @@ -6701,6 +6922,80 @@ fir::ExtendedValue Fortran::lower::createInitializerAddress( return ScalarExprLowering(loc, converter, symMap, stmtCtx, &init).gen(expr); } +void Fortran::lower::createSomeArrayAssignment( + Fortran::lower::AbstractConverter &converter, + const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "onto array: ") << '\n'; + rhs.AsFortran(llvm::dbgs() << "assign expression: ") << '\n';); + ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs); +} + +void Fortran::lower::createSomeArrayAssignment( + Fortran::lower::AbstractConverter &converter, const fir::ExtendedValue &lhs, + const Fortran::lower::SomeExpr &rhs, Fortran::lower::SymMap &symMap, + Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(llvm::dbgs() << "onto array: " << lhs << '\n'; + rhs.AsFortran(llvm::dbgs() << "assign expression: ") << '\n';); + ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs); +} +void Fortran::lower::createSomeArrayAssignment( + Fortran::lower::AbstractConverter &converter, const fir::ExtendedValue &lhs, + const fir::ExtendedValue &rhs, Fortran::lower::SymMap &symMap, + Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(llvm::dbgs() << "onto array: " << lhs << '\n'; + llvm::dbgs() << "assign expression: " << rhs << '\n';); + ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs); +} + +void Fortran::lower::createAnyMaskedArrayAssignment( + Fortran::lower::AbstractConverter &converter, + const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs, + Fortran::lower::ExplicitIterSpace &explicitSpace, + Fortran::lower::ImplicitIterSpace &implicitSpace, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "onto array: ") << '\n'; + rhs.AsFortran(llvm::dbgs() << "assign expression: ") + << " given the explicit iteration space:\n" + << explicitSpace << "\n and implied mask conditions:\n" + << implicitSpace << '\n';); + ArrayExprLowering::lowerAnyMaskedArrayAssignment( + converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace); +} + +void Fortran::lower::createAllocatableArrayAssignment( + Fortran::lower::AbstractConverter &converter, + const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs, + Fortran::lower::ExplicitIterSpace &explicitSpace, + Fortran::lower::ImplicitIterSpace &implicitSpace, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "defining array: ") << '\n'; + rhs.AsFortran(llvm::dbgs() << "assign expression: ") + << " given the explicit iteration space:\n" + << explicitSpace << "\n and implied mask conditions:\n" + << implicitSpace << '\n';); + ArrayExprLowering::lowerAllocatableArrayAssignment( + converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace); +} + +fir::ExtendedValue Fortran::lower::createSomeArrayTempValue( + Fortran::lower::AbstractConverter &converter, + const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap, + Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "array value: ") << '\n'); + return ArrayExprLowering::lowerNewArrayExpression(converter, symMap, stmtCtx, + expr); +} + +void Fortran::lower::createLazyArrayTempValue( + Fortran::lower::AbstractConverter &converter, + const Fortran::lower::SomeExpr &expr, mlir::Value raggedHeader, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "array value: ") << '\n'); + ArrayExprLowering::lowerLazyArrayExpression(converter, symMap, stmtCtx, expr, + raggedHeader); +} + fir::ExtendedValue Fortran::lower::createSomeArrayBox(Fortran::lower::AbstractConverter &converter, const Fortran::lower::SomeExpr &expr, @@ -6814,8 +7109,8 @@ genArrayLoad(mlir::Location loc, Fortran::lower::AbstractConverter &converter, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { if (x->base().IsSymbol()) - return genArrayLoad(loc, converter, builder, &x->base().GetLastSymbol(), - symMap, stmtCtx); + return genArrayLoad(loc, converter, builder, &getLastSym(x->base()), symMap, + stmtCtx); return genArrayLoad(loc, converter, builder, &x->base().GetComponent(), symMap, stmtCtx); } @@ -6867,81 +7162,6 @@ void Fortran::lower::createArrayMergeStores( esp.incrementCounter(); } -void Fortran::lower::createSomeArrayAssignment( - Fortran::lower::AbstractConverter &converter, - const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs, - Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { - LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "onto array: ") << '\n'; - rhs.AsFortran(llvm::dbgs() << "assign expression: ") << '\n';); - ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs); -} - -void Fortran::lower::createSomeArrayAssignment( - Fortran::lower::AbstractConverter &converter, const fir::ExtendedValue &lhs, - const Fortran::lower::SomeExpr &rhs, Fortran::lower::SymMap &symMap, - Fortran::lower::StatementContext &stmtCtx) { - LLVM_DEBUG(llvm::dbgs() << "onto array: " << lhs << '\n'; - rhs.AsFortran(llvm::dbgs() << "assign expression: ") << '\n';); - ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs); -} - -void Fortran::lower::createSomeArrayAssignment( - Fortran::lower::AbstractConverter &converter, const fir::ExtendedValue &lhs, - const fir::ExtendedValue &rhs, Fortran::lower::SymMap &symMap, - Fortran::lower::StatementContext &stmtCtx) { - LLVM_DEBUG(llvm::dbgs() << "onto array: " << lhs << '\n'; - llvm::dbgs() << "assign expression: " << rhs << '\n';); - ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs); -} - -void Fortran::lower::createAnyMaskedArrayAssignment( - Fortran::lower::AbstractConverter &converter, - const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs, - Fortran::lower::ExplicitIterSpace &explicitSpace, - Fortran::lower::ImplicitIterSpace &implicitSpace, - Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { - LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "onto array: ") << '\n'; - rhs.AsFortran(llvm::dbgs() << "assign expression: ") - << " given the explicit iteration space:\n" - << explicitSpace << "\n and implied mask conditions:\n" - << implicitSpace << '\n';); - ArrayExprLowering::lowerAnyMaskedArrayAssignment( - converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace); -} - -void Fortran::lower::createAllocatableArrayAssignment( - Fortran::lower::AbstractConverter &converter, - const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs, - Fortran::lower::ExplicitIterSpace &explicitSpace, - Fortran::lower::ImplicitIterSpace &implicitSpace, - Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { - LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "defining array: ") << '\n'; - rhs.AsFortran(llvm::dbgs() << "assign expression: ") - << " given the explicit iteration space:\n" - << explicitSpace << "\n and implied mask conditions:\n" - << implicitSpace << '\n';); - ArrayExprLowering::lowerAllocatableArrayAssignment( - converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace); -} - -fir::ExtendedValue Fortran::lower::createSomeArrayTempValue( - Fortran::lower::AbstractConverter &converter, - const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap, - Fortran::lower::StatementContext &stmtCtx) { - LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "array value: ") << '\n'); - return ArrayExprLowering::lowerNewArrayExpression(converter, symMap, stmtCtx, - expr); -} - -void Fortran::lower::createLazyArrayTempValue( - Fortran::lower::AbstractConverter &converter, - const Fortran::lower::SomeExpr &expr, mlir::Value raggedHeader, - Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { - LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "array value: ") << '\n'); - ArrayExprLowering::lowerLazyArrayExpression(converter, symMap, stmtCtx, expr, - raggedHeader); -} - mlir::Value Fortran::lower::genMaxWithZero(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value value) { diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp index b421a03ed54d..7bb238b57381 100644 --- a/flang/lib/Lower/ConvertVariable.cpp +++ b/flang/lib/Lower/ConvertVariable.cpp @@ -1119,7 +1119,11 @@ lowerExplicitCharLen(Fortran::lower::AbstractConverter &converter, if (llvm::Optional len = box.getCharLenConst()) return builder.createIntegerConstant(loc, lenTy, *len); if (llvm::Optional lenExpr = box.getCharLenExpr()) - return genScalarValue(converter, loc, *lenExpr, symMap, stmtCtx); + // If the length expression is negative, the length is zero. See F2018 + // 7.4.4.2 point 5. + return Fortran::lower::genMaxWithZero( + builder, loc, + genScalarValue(converter, loc, *lenExpr, symMap, stmtCtx)); return mlir::Value{}; } diff --git a/flang/lib/Lower/IntrinsicCall.cpp b/flang/lib/Lower/IntrinsicCall.cpp index be32c4d04a50..efc4f5132794 100644 --- a/flang/lib/Lower/IntrinsicCall.cpp +++ b/flang/lib/Lower/IntrinsicCall.cpp @@ -3688,6 +3688,15 @@ mlir::Value Fortran::lower::genMax(fir::FirOpBuilder &builder, args); } +mlir::Value Fortran::lower::genMin(fir::FirOpBuilder &builder, + mlir::Location loc, + llvm::ArrayRef args) { + assert(args.size() > 0 && "min requires at least one argument"); + return IntrinsicLibrary{builder, loc} + .genExtremum(args[0].getType(), + args); +} + mlir::Value Fortran::lower::genPow(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Type type, mlir::Value x, mlir::Value y) { diff --git a/flang/lib/Optimizer/Builder/Character.cpp b/flang/lib/Optimizer/Builder/Character.cpp index 47b2e9f7e7de..97ccea0bb285 100644 --- a/flang/lib/Optimizer/Builder/Character.cpp +++ b/flang/lib/Optimizer/Builder/Character.cpp @@ -13,19 +13,18 @@ #include "flang/Optimizer/Builder/Character.h" #include "flang/Lower/Todo.h" #include "flang/Optimizer/Builder/DoLoopHelper.h" +#include "flang/Optimizer/Builder/FIRBuilder.h" #include "llvm/Support/Debug.h" #include #define DEBUG_TYPE "flang-lower-character" -using namespace mlir; - //===----------------------------------------------------------------------===// // CharacterExprHelper implementation //===----------------------------------------------------------------------===// -/// Unwrap base fir.char type. -static fir::CharacterType recoverCharacterType(mlir::Type type) { +/// Unwrap all the ref and box types and return the inner element type. +static mlir::Type unwrapBoxAndRef(mlir::Type type) { if (auto boxType = type.dyn_cast()) return boxType.getEleTy(); while (true) { @@ -35,10 +34,29 @@ static fir::CharacterType recoverCharacterType(mlir::Type type) { else break; } - return fir::unwrapSequenceType(type).cast(); + return type; +} + +/// Unwrap base fir.char type. +static fir::CharacterType recoverCharacterType(mlir::Type type) { + type = fir::unwrapSequenceType(unwrapBoxAndRef(type)); + if (auto charTy = type.dyn_cast()) + return charTy; + llvm::report_fatal_error("expected a character type"); +} + +bool fir::factory::CharacterExprHelper::isCharacterScalar(mlir::Type type) { + type = unwrapBoxAndRef(type); + return !type.isa() && fir::isa_char(type); +} + +bool fir::factory::CharacterExprHelper::isArray(mlir::Type type) { + type = unwrapBoxAndRef(type); + if (auto seqTy = type.dyn_cast()) + return fir::isa_char(seqTy.getEleTy()); + return false; } -/// Get fir.char type with the same kind as inside str. fir::CharacterType fir::factory::CharacterExprHelper::getCharacterType(mlir::Type type) { assert(isCharacterScalar(type) && "expected scalar character"); @@ -143,8 +161,8 @@ fir::factory::CharacterExprHelper::toExtendedValue(mlir::Value character, // If the embox is accessible, use its operand to avoid filling // the generated fir with embox/unbox. mlir::Value boxCharLen; - if (auto *definingOp = character.getDefiningOp()) { - if (auto box = dyn_cast(definingOp)) { + if (auto definingOp = character.getDefiningOp()) { + if (auto box = mlir::dyn_cast(definingOp)) { base = box.getMemref(); boxCharLen = box.getLen(); } @@ -217,7 +235,7 @@ fir::CharBoxValue fir::factory::CharacterExprHelper::toScalarCharacter( auto lenType = builder.getCharacterLengthType(); auto len = builder.createConvert(loc, lenType, box.getLen()); for (auto extent : box.getExtents()) - len = builder.create( + len = builder.create( loc, len, builder.createConvert(loc, lenType, extent)); // TODO: typeLen can be improved in compiled constant cases @@ -302,48 +320,6 @@ mlir::Value fir::factory::CharacterExprHelper::getCharBoxBuffer( return buff; } -/// Get the LLVM intrinsic for `memcpy`. Use the 64 bit version. -mlir::FuncOp fir::factory::getLlvmMemcpy(fir::FirOpBuilder &builder) { - auto ptrTy = builder.getRefType(builder.getIntegerType(8)); - llvm::SmallVector args = {ptrTy, ptrTy, builder.getI64Type(), - builder.getI1Type()}; - auto memcpyTy = - mlir::FunctionType::get(builder.getContext(), args, llvm::None); - return builder.addNamedFunction(builder.getUnknownLoc(), - "llvm.memcpy.p0i8.p0i8.i64", memcpyTy); -} - -/// Get the LLVM intrinsic for `memmove`. Use the 64 bit version. -mlir::FuncOp fir::factory::getLlvmMemmove(fir::FirOpBuilder &builder) { - auto ptrTy = builder.getRefType(builder.getIntegerType(8)); - llvm::SmallVector args = {ptrTy, ptrTy, builder.getI64Type(), - builder.getI1Type()}; - auto memmoveTy = - mlir::FunctionType::get(builder.getContext(), args, llvm::None); - return builder.addNamedFunction(builder.getUnknownLoc(), - "llvm.memmove.p0i8.p0i8.i64", memmoveTy); -} - -/// Get the LLVM intrinsic for `memset`. Use the 64 bit version. -mlir::FuncOp fir::factory::getLlvmMemset(fir::FirOpBuilder &builder) { - auto ptrTy = builder.getRefType(builder.getIntegerType(8)); - llvm::SmallVector args = {ptrTy, ptrTy, builder.getI64Type(), - builder.getI1Type()}; - auto memsetTy = - mlir::FunctionType::get(builder.getContext(), args, llvm::None); - return builder.addNamedFunction(builder.getUnknownLoc(), - "llvm.memset.p0i8.p0i8.i64", memsetTy); -} - -/// Get the standard `realloc` function. -mlir::FuncOp fir::factory::getRealloc(fir::FirOpBuilder &builder) { - auto ptrTy = builder.getRefType(builder.getIntegerType(8)); - llvm::SmallVector args = {ptrTy, builder.getI64Type()}; - auto reallocTy = mlir::FunctionType::get(builder.getContext(), args, {ptrTy}); - return builder.addNamedFunction(builder.getUnknownLoc(), "realloc", - reallocTy); -} - /// Create a loop to copy `count` characters from `src` to `dest`. Note that the /// KIND indicates the number of bits in a code point. (ASCII, UCS-2, or UCS-4.) void fir::factory::CharacterExprHelper::createCopy( @@ -362,7 +338,8 @@ void fir::factory::CharacterExprHelper::createCopy( auto i64Ty = builder.getI64Type(); auto kindBytes = builder.createIntegerConstant(loc, i64Ty, bytes); auto castCount = builder.createConvert(loc, i64Ty, count); - auto totalBytes = builder.create(loc, kindBytes, castCount); + auto totalBytes = + builder.create(loc, kindBytes, castCount); auto notVolatile = builder.createBool(loc, false); auto memmv = getLlvmMemmove(builder); auto argTys = memmv.getFunctionType().getInputs(); @@ -441,8 +418,8 @@ void fir::factory::CharacterExprHelper::createLengthOneAssign( /// Returns the minimum of integer mlir::Value \p a and \b. mlir::Value genMin(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value a, mlir::Value b) { - auto cmp = - builder.create(loc, arith::CmpIPredicate::slt, a, b); + auto cmp = builder.create( + loc, mlir::arith::CmpIPredicate::slt, a, b); return builder.create(loc, cmp, a, b); } @@ -474,7 +451,8 @@ void fir::factory::CharacterExprHelper::createAssign( // Pad if needed. if (!compileTimeSameLength) { auto one = builder.createIntegerConstant(loc, lhs.getLen().getType(), 1); - auto maxPadding = builder.create(loc, lhs.getLen(), one); + auto maxPadding = + builder.create(loc, lhs.getLen(), one); createPadding(lhs, copyCount, maxPadding); } } @@ -485,18 +463,18 @@ fir::CharBoxValue fir::factory::CharacterExprHelper::createConcatenate( lhs.getLen()); auto rhsLen = builder.createConvert(loc, builder.getCharacterLengthType(), rhs.getLen()); - mlir::Value len = builder.create(loc, lhsLen, rhsLen); + mlir::Value len = builder.create(loc, lhsLen, rhsLen); auto temp = createCharacterTemp(getCharacterType(rhs), len); createCopy(temp, lhs, lhsLen); auto one = builder.createIntegerConstant(loc, len.getType(), 1); - auto upperBound = builder.create(loc, len, one); + auto upperBound = builder.create(loc, len, one); auto lhsLenIdx = builder.createConvert(loc, builder.getIndexType(), lhsLen); auto fromBuff = getCharBoxBuffer(rhs); auto toBuff = getCharBoxBuffer(temp); fir::factory::DoLoopHelper{builder, loc}.createLoop( lhsLenIdx, upperBound, one, [&](fir::FirOpBuilder &bldr, mlir::Value index) { - auto rhsIndex = bldr.create(loc, index, lhsLenIdx); + auto rhsIndex = bldr.create(loc, index, lhsLenIdx); auto charVal = createLoadCharAt(fromBuff, rhsIndex); createStoreCharAt(toBuff, index, charVal); }); @@ -519,7 +497,8 @@ fir::CharBoxValue fir::factory::CharacterExprHelper::createSubstring( 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 offset = + builder.create(loc, lowerBound, one).getResult(); auto addr = createElementAddr(box.getBuffer(), offset); auto kind = getCharacterKind(box.getBuffer().getType()); auto charTy = fir::CharacterType::getUnknownLen(builder.getContext(), kind); @@ -530,17 +509,17 @@ fir::CharBoxValue fir::factory::CharacterExprHelper::createSubstring( mlir::Value substringLen; if (nbounds < 2) { substringLen = - builder.create(loc, box.getLen(), castBounds[0]); + builder.create(loc, box.getLen(), castBounds[0]); } else { substringLen = - builder.create(loc, castBounds[1], castBounds[0]); + builder.create(loc, castBounds[1], castBounds[0]); } - substringLen = builder.create(loc, substringLen, one); + 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, arith::CmpIPredicate::slt, - substringLen, zero); + auto cdt = builder.create( + loc, mlir::arith::CmpIPredicate::slt, substringLen, zero); substringLen = builder.create(loc, cdt, zero, substringLen); @@ -558,7 +537,7 @@ fir::factory::CharacterExprHelper::createLenTrim(const fir::CharBoxValue &str) { 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); + mlir::Value lastChar = builder.create(loc, len, one); auto iterWhile = builder.create(loc, lastChar, zero, minusOne, trueVal, @@ -572,14 +551,14 @@ fir::factory::CharacterExprHelper::createLenTrim(const fir::CharBoxValue &str) { auto codeAddr = builder.createConvert(loc, builder.getRefType(blank.getType()), elemAddr); auto c = builder.create(loc, codeAddr); - auto isBlank = - builder.create(loc, arith::CmpIPredicate::eq, blank, c); + auto isBlank = builder.create( + loc, mlir::arith::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); + builder.create(loc, iterWhile.getResult(1), one); auto result = builder.create( loc, iterWhile.getResult(0), zero, newLen); return builder.createConvert(loc, builder.getCharacterLengthType(), result); @@ -651,16 +630,6 @@ bool fir::factory::CharacterExprHelper::isCharacterLiteral(mlir::Type type) { return false; } -bool fir::factory::CharacterExprHelper::isCharacterScalar(mlir::Type type) { - if (type.isa()) - return true; - type = fir::unwrapRefType(type); - if (auto boxTy = type.dyn_cast()) - type = boxTy.getEleTy(); - type = fir::unwrapRefType(type); - return !type.isa() && fir::isa_char(type); -} - fir::KindTy fir::factory::CharacterExprHelper::getCharacterKind(mlir::Type type) { assert(isCharacterScalar(type) && "expected scalar character"); @@ -672,10 +641,6 @@ fir::factory::CharacterExprHelper::getCharacterOrSequenceKind(mlir::Type type) { return recoverCharacterType(type).getFKind(); } -bool fir::factory::CharacterExprHelper::isArray(mlir::Type type) { - return !isCharacterScalar(type); -} - bool fir::factory::CharacterExprHelper::hasConstantLengthInType( const fir::ExtendedValue &exv) { auto charTy = recoverCharacterType(fir::getBase(exv).getType()); @@ -715,7 +680,7 @@ fir::factory::CharacterExprHelper::readLengthFromBox(mlir::Value box) { auto width = bits / 8; if (width > 1) { auto widthVal = builder.createIntegerConstant(loc, lenTy, width); - return builder.create(loc, size, widthVal); + return builder.create(loc, size, widthVal); } return size; } @@ -745,11 +710,16 @@ fir::factory::extractCharacterProcedureTuple(fir::FirOpBuilder &builder, loc, tupleType.getType(0), tuple, builder.getArrayAttr( {builder.getIntegerAttr(builder.getIndexType(), 0)})); + mlir::Value proc = [&]() -> mlir::Value { + if (auto addrTy = addr.getType().dyn_cast()) + return builder.create(loc, addrTy.getEleTy(), addr); + return addr; + }(); mlir::Value len = builder.create( loc, tupleType.getType(1), tuple, builder.getArrayAttr( {builder.getIntegerAttr(builder.getIndexType(), 1)})); - return {addr, len}; + return {proc, len}; } mlir::Value fir::factory::createCharacterProcedureTuple( @@ -770,13 +740,6 @@ mlir::Value fir::factory::createCharacterProcedureTuple( return tuple; } -bool fir::factory::isCharacterProcedureTuple(mlir::Type ty) { - mlir::TupleType tuple = ty.dyn_cast(); - return tuple && tuple.size() == 2 && - tuple.getType(0).isa() && - fir::isa_integer(tuple.getType(1)); -} - mlir::Type fir::factory::getCharacterProcedureTupleType(mlir::Type funcPointerType) { mlir::MLIRContext *context = funcPointerType.getContext(); diff --git a/flang/lib/Optimizer/Builder/FIRBuilder.cpp b/flang/lib/Optimizer/Builder/FIRBuilder.cpp index 64694aa56ca7..d30eadf47a9d 100644 --- a/flang/lib/Optimizer/Builder/FIRBuilder.cpp +++ b/flang/lib/Optimizer/Builder/FIRBuilder.cpp @@ -24,7 +24,12 @@ #include "llvm/Support/ErrorHandling.h" #include "llvm/Support/MD5.h" -static constexpr std::size_t nameLengthHashSize = 32; +static llvm::cl::opt + nameLengthHashSize("length-to-hash-string-literal", + llvm::cl::desc("string literals that exceed this length" + " will use a hash value as their symbol " + "name"), + llvm::cl::init(32)); mlir::FuncOp fir::FirOpBuilder::createFunction(mlir::Location loc, mlir::ModuleOp module, @@ -480,12 +485,13 @@ mlir::Value fir::FirOpBuilder::createBox(mlir::Location loc, return create( loc, fir::factory::getMutableIRBox(*this, loc, x)); }, - // UnboxedValue, ProcBoxValue or BoxValue. [&](const auto &) -> mlir::Value { return create(loc, boxTy, itemAddr); }); } +void fir::FirOpBuilder::dumpFunc() { getFunction().dump(); } + static mlir::Value genNullPointerComparison(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value addr, @@ -576,9 +582,9 @@ mlir::Value fir::factory::readExtent(fir::FirOpBuilder &builder, .getResult(1); }, [&](const fir::MutableBoxValue &x) -> mlir::Value { - // MutableBoxValue must be read into another category to work with them - // outside of allocation/assignment contexts. - fir::emitFatalError(loc, "readExtents on MutableBoxValue"); + return readExtent(builder, loc, + fir::factory::genMutableBoxRead(builder, loc, x), + dim); }, [&](const auto &) -> mlir::Value { fir::emitFatalError(loc, "extent inquiry on scalar"); @@ -894,35 +900,6 @@ fir::ExtendedValue fir::factory::arraySectionElementToExtendedValue( return fir::factory::componentToExtendedValue(builder, loc, element); } -mlir::TupleType -fir::factory::getRaggedArrayHeaderType(fir::FirOpBuilder &builder) { - mlir::IntegerType i64Ty = builder.getIntegerType(64); - auto arrTy = fir::SequenceType::get(builder.getIntegerType(8), 1); - auto buffTy = fir::HeapType::get(arrTy); - auto extTy = fir::SequenceType::get(i64Ty, 1); - auto shTy = fir::HeapType::get(extTy); - return mlir::TupleType::get(builder.getContext(), {i64Ty, buffTy, shTy}); -} - -mlir::Value fir::factory::createZeroValue(fir::FirOpBuilder &builder, - mlir::Location loc, mlir::Type type) { - mlir::Type i1 = builder.getIntegerType(1); - if (type.isa() || type == i1) - return builder.createConvert(loc, type, builder.createBool(loc, false)); - if (fir::isa_integer(type)) - return builder.createIntegerConstant(loc, type, 0); - if (fir::isa_real(type)) - return builder.createRealZeroConstant(loc, type); - if (fir::isa_complex(type)) { - fir::factory::Complex complexHelper(builder, loc); - mlir::Type partType = complexHelper.getComplexPartType(type); - mlir::Value zeroPart = builder.createRealZeroConstant(loc, partType); - return complexHelper.createComplex(type, zeroPart, zeroPart); - } - fir::emitFatalError(loc, "internal: trying to generate zero value of non " - "numeric or logical type"); -} - void fir::factory::genScalarAssignment(fir::FirOpBuilder &builder, mlir::Location loc, const fir::ExtendedValue &lhs, @@ -1072,6 +1049,16 @@ void fir::factory::genRecordAssignment(fir::FirOpBuilder &builder, genComponentByComponentAssignment(builder, loc, lhs, rhs); } +mlir::TupleType +fir::factory::getRaggedArrayHeaderType(fir::FirOpBuilder &builder) { + mlir::IntegerType i64Ty = builder.getIntegerType(64); + auto arrTy = fir::SequenceType::get(builder.getIntegerType(8), 1); + auto buffTy = fir::HeapType::get(arrTy); + auto extTy = fir::SequenceType::get(i64Ty, 1); + auto shTy = fir::HeapType::get(extTy); + return mlir::TupleType::get(builder.getContext(), {i64Ty, buffTy, shTy}); +} + mlir::Value fir::factory::genLenOfCharacter( fir::FirOpBuilder &builder, mlir::Location loc, fir::ArrayLoadOp arrLoad, llvm::ArrayRef path, llvm::ArrayRef substring) { @@ -1129,3 +1116,22 @@ mlir::Value fir::factory::genLenOfCharacter( } TODO(loc, "LEN of character must be computed at runtime"); } + +mlir::Value fir::factory::createZeroValue(fir::FirOpBuilder &builder, + mlir::Location loc, mlir::Type type) { + mlir::Type i1 = builder.getIntegerType(1); + if (type.isa() || type == i1) + return builder.createConvert(loc, type, builder.createBool(loc, false)); + if (fir::isa_integer(type)) + return builder.createIntegerConstant(loc, type, 0); + if (fir::isa_real(type)) + return builder.createRealZeroConstant(loc, type); + if (fir::isa_complex(type)) { + fir::factory::Complex complexHelper(builder, loc); + mlir::Type partType = complexHelper.getComplexPartType(type); + mlir::Value zeroPart = builder.createRealZeroConstant(loc, partType); + return complexHelper.createComplex(type, zeroPart, zeroPart); + } + fir::emitFatalError(loc, "internal: trying to generate zero value of non " + "numeric or logical type"); +} diff --git a/flang/lib/Optimizer/Builder/LowLevelIntrinsics.cpp b/flang/lib/Optimizer/Builder/LowLevelIntrinsics.cpp index f95a4fd19e53..e07b7eff5e32 100644 --- a/flang/lib/Optimizer/Builder/LowLevelIntrinsics.cpp +++ b/flang/lib/Optimizer/Builder/LowLevelIntrinsics.cpp @@ -21,6 +21,44 @@ #include "flang/Optimizer/Builder/LowLevelIntrinsics.h" #include "flang/Optimizer/Builder/FIRBuilder.h" +mlir::FuncOp fir::factory::getLlvmMemcpy(fir::FirOpBuilder &builder) { + auto ptrTy = builder.getRefType(builder.getIntegerType(8)); + llvm::SmallVector args = {ptrTy, ptrTy, builder.getI64Type(), + builder.getI1Type()}; + auto memcpyTy = + mlir::FunctionType::get(builder.getContext(), args, llvm::None); + return builder.addNamedFunction(builder.getUnknownLoc(), + "llvm.memcpy.p0i8.p0i8.i64", memcpyTy); +} + +mlir::FuncOp fir::factory::getLlvmMemmove(fir::FirOpBuilder &builder) { + auto ptrTy = builder.getRefType(builder.getIntegerType(8)); + llvm::SmallVector args = {ptrTy, ptrTy, builder.getI64Type(), + builder.getI1Type()}; + auto memmoveTy = + mlir::FunctionType::get(builder.getContext(), args, llvm::None); + return builder.addNamedFunction(builder.getUnknownLoc(), + "llvm.memmove.p0i8.p0i8.i64", memmoveTy); +} + +mlir::FuncOp fir::factory::getLlvmMemset(fir::FirOpBuilder &builder) { + auto ptrTy = builder.getRefType(builder.getIntegerType(8)); + llvm::SmallVector args = {ptrTy, ptrTy, builder.getI64Type(), + builder.getI1Type()}; + auto memsetTy = + mlir::FunctionType::get(builder.getContext(), args, llvm::None); + return builder.addNamedFunction(builder.getUnknownLoc(), + "llvm.memset.p0i8.p0i8.i64", memsetTy); +} + +mlir::FuncOp fir::factory::getRealloc(fir::FirOpBuilder &builder) { + auto ptrTy = builder.getRefType(builder.getIntegerType(8)); + llvm::SmallVector args = {ptrTy, builder.getI64Type()}; + auto reallocTy = mlir::FunctionType::get(builder.getContext(), args, {ptrTy}); + return builder.addNamedFunction(builder.getUnknownLoc(), "realloc", + reallocTy); +} + mlir::FuncOp fir::factory::getLlvmStackSave(fir::FirOpBuilder &builder) { auto ptrTy = builder.getRefType(builder.getIntegerType(8)); auto funcTy = @@ -36,3 +74,18 @@ mlir::FuncOp fir::factory::getLlvmStackRestore(fir::FirOpBuilder &builder) { return builder.addNamedFunction(builder.getUnknownLoc(), "llvm.stackrestore", funcTy); } + +mlir::FuncOp fir::factory::getLlvmInitTrampoline(fir::FirOpBuilder &builder) { + auto ptrTy = builder.getRefType(builder.getIntegerType(8)); + auto funcTy = mlir::FunctionType::get(builder.getContext(), + {ptrTy, ptrTy, ptrTy}, llvm::None); + return builder.addNamedFunction(builder.getUnknownLoc(), + "llvm.init.trampoline", funcTy); +} + +mlir::FuncOp fir::factory::getLlvmAdjustTrampoline(fir::FirOpBuilder &builder) { + auto ptrTy = builder.getRefType(builder.getIntegerType(8)); + auto funcTy = mlir::FunctionType::get(builder.getContext(), {ptrTy}, {ptrTy}); + return builder.addNamedFunction(builder.getUnknownLoc(), + "llvm.adjust.trampoline", funcTy); +} diff --git a/flang/lib/Optimizer/Builder/MutableBox.cpp b/flang/lib/Optimizer/Builder/MutableBox.cpp index 0d9fe18089ef..a9d86474a94d 100644 --- a/flang/lib/Optimizer/Builder/MutableBox.cpp +++ b/flang/lib/Optimizer/Builder/MutableBox.cpp @@ -268,52 +268,8 @@ private: /// Update the IR box (fir.ref>) of the MutableBoxValue. void updateIRBox(mlir::Value addr, mlir::ValueRange lbounds, mlir::ValueRange extents, mlir::ValueRange lengths) { - mlir::Value shape; - if (!extents.empty()) { - if (lbounds.empty()) { - auto shapeType = - fir::ShapeType::get(builder.getContext(), extents.size()); - shape = builder.create(loc, shapeType, extents); - } else { - llvm::SmallVector shapeShiftBounds; - for (auto [lb, extent] : llvm::zip(lbounds, extents)) { - shapeShiftBounds.emplace_back(lb); - shapeShiftBounds.emplace_back(extent); - } - auto shapeShiftType = - fir::ShapeShiftType::get(builder.getContext(), extents.size()); - shape = builder.create(loc, shapeShiftType, - shapeShiftBounds); - } - } - mlir::Value emptySlice; - // Ignore lengths if already constant in the box type (this would trigger an - // error in the embox). - llvm::SmallVector cleanedLengths; - mlir::Value irBox; - if (addr.getType().isa()) { - // The entity is already boxed. - irBox = builder.createConvert(loc, box.getBoxTy(), addr); - } else { - auto cleanedAddr = addr; - if (auto charTy = box.getEleTy().dyn_cast()) { - // Cast address to box type so that both input and output type have - // unknown or constant lengths. - auto bt = box.getBaseTy(); - auto addrTy = addr.getType(); - auto type = addrTy.isa() ? fir::HeapType::get(bt) - : addrTy.isa() ? fir::PointerType::get(bt) - : builder.getRefType(bt); - cleanedAddr = builder.createConvert(loc, type, addr); - if (charTy.getLen() == fir::CharacterType::unknownLen()) - cleanedLengths.append(lengths.begin(), lengths.end()); - } else if (box.isDerivedWithLengthParameters()) { - TODO(loc, "updating mutablebox of derived type with length parameters"); - cleanedLengths = lengths; - } - irBox = builder.create(loc, box.getBoxTy(), cleanedAddr, - shape, emptySlice, cleanedLengths); - } + mlir::Value irBox = + createNewFirBox(builder, loc, box, addr, lbounds, extents, lengths); builder.create(loc, irBox, box.getAddr()); } @@ -725,26 +681,19 @@ void fir::factory::genInlinedAllocation(fir::FirOpBuilder &builder, mlir::ValueRange extents, mlir::ValueRange lenParams, llvm::StringRef allocName) { - auto idxTy = builder.getIndexType(); - llvm::SmallVector lengths; - if (auto charTy = box.getEleTy().dyn_cast()) { - if (charTy.getLen() == fir::CharacterType::unknownLen()) { - if (box.hasNonDeferredLenParams()) - lengths.emplace_back( - builder.createConvert(loc, idxTy, box.nonDeferredLenParams()[0])); - else if (!lenParams.empty()) - lengths.emplace_back(builder.createConvert(loc, idxTy, lenParams[0])); - else - fir::emitFatalError( - loc, "could not deduce character lengths in character allocation"); - } - } - mlir::Value heap = builder.create( - loc, box.getBaseTy(), allocName, lengths, extents); - // TODO: run initializer if any. Currently, there is no way to know this is - // required here. + auto lengths = getNewLengths(builder, loc, box, lenParams); + auto heap = builder.create(loc, box.getBaseTy(), allocName, + lengths, extents); MutablePropertyWriter{builder, loc, box}.updateMutableBox(heap, lbounds, extents, lengths); + if (box.getEleTy().isa()) { + // TODO: skip runtime initialization if this is not required. Currently, + // there is no way to know here if a derived type needs it or not. But the + // information is available at compile time and could be reflected here + // somehow. + mlir::Value irBox = fir::factory::getMutableIRBox(builder, loc, box); + fir::runtime::genDerivedTypeInitialize(builder, loc, irBox); + } } void fir::factory::genInlinedDeallocate(fir::FirOpBuilder &builder, diff --git a/flang/lib/Optimizer/CodeGen/BoxedProcedure.cpp b/flang/lib/Optimizer/CodeGen/BoxedProcedure.cpp new file mode 100644 index 000000000000..74c79c03b399 --- /dev/null +++ b/flang/lib/Optimizer/CodeGen/BoxedProcedure.cpp @@ -0,0 +1,326 @@ +//===-- BoxedProcedure.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 "PassDetail.h" +#include "flang/Optimizer/Builder/FIRBuilder.h" +#include "flang/Optimizer/Builder/LowLevelIntrinsics.h" +#include "flang/Optimizer/CodeGen/CodeGen.h" +#include "flang/Optimizer/Dialect/FIRDialect.h" +#include "flang/Optimizer/Dialect/FIROps.h" +#include "flang/Optimizer/Dialect/FIRType.h" +#include "flang/Optimizer/Support/FIRContext.h" +#include "flang/Optimizer/Support/FatalError.h" +#include "mlir/IR/PatternMatch.h" +#include "mlir/Pass/Pass.h" +#include "mlir/Transforms/DialectConversion.h" + +#define DEBUG_TYPE "flang-procedure-pointer" + +using namespace fir; + +namespace { +/// Options to the procedure pointer pass. +struct BoxedProcedureOptions { + // Lower the boxproc abstraction to function pointers and thunks where + // required. + bool useThunks = true; +}; + +/// This type converter rewrites all `!fir.boxproc` types to `Func` types. +class BoxprocTypeRewriter : public mlir::TypeConverter { +public: + using mlir::TypeConverter::convertType; + + /// Does the type \p ty need to be converted? + /// Any type that is a `!fir.boxproc` in whole or in part will need to be + /// converted to a function type to lower the IR to function pointer form in + /// the default implementation performed in this pass. Other implementations + /// are possible, so those may convert `!fir.boxproc` to some other type or + /// not at all depending on the implementation target's characteristics and + /// preference. + bool needsConversion(mlir::Type ty) { + if (ty.isa()) + return true; + if (auto funcTy = ty.dyn_cast()) { + for (auto t : funcTy.getInputs()) + if (needsConversion(t)) + return true; + for (auto t : funcTy.getResults()) + if (needsConversion(t)) + return true; + return false; + } + if (auto tupleTy = ty.dyn_cast()) { + for (auto t : tupleTy.getTypes()) + if (needsConversion(t)) + return true; + return false; + } + if (auto recTy = ty.dyn_cast()) { + bool result = false; + visitedTypes.push_back(recTy); + for (auto t : recTy.getTypeList()) { + if (llvm::any_of(visitedTypes, + [&](mlir::Type rt) { return rt == recTy; })) + continue; + if (needsConversion(t.second)) { + result = true; + break; + } + } + visitedTypes.pop_back(); + return result; + } + if (auto boxTy = ty.dyn_cast()) + return needsConversion(boxTy.getEleTy()); + if (isa_ref_type(ty)) + return needsConversion(unwrapRefType(ty)); + if (auto t = ty.dyn_cast()) + return needsConversion(unwrapSequenceType(ty)); + return false; + } + + BoxprocTypeRewriter() { + addConversion([](mlir::Type ty) { return ty; }); + addConversion([](BoxProcType boxproc) { return boxproc.getEleTy(); }); + addConversion([&](mlir::TupleType tupTy) { + llvm::SmallVector memTys; + for (auto ty : tupTy.getTypes()) + memTys.push_back(convertType(ty)); + return mlir::TupleType::get(tupTy.getContext(), memTys); + }); + addConversion([&](mlir::FunctionType funcTy) { + llvm::SmallVector inTys; + llvm::SmallVector resTys; + for (auto ty : funcTy.getInputs()) + inTys.push_back(convertType(ty)); + for (auto ty : funcTy.getResults()) + resTys.push_back(convertType(ty)); + return mlir::FunctionType::get(funcTy.getContext(), inTys, resTys); + }); + addConversion([&](ReferenceType ty) { + return ReferenceType::get(convertType(ty.getEleTy())); + }); + addConversion([&](PointerType ty) { + return PointerType::get(convertType(ty.getEleTy())); + }); + addConversion( + [&](HeapType ty) { return HeapType::get(convertType(ty.getEleTy())); }); + addConversion( + [&](BoxType ty) { return BoxType::get(convertType(ty.getEleTy())); }); + addConversion([&](SequenceType ty) { + // TODO: add ty.getLayoutMap() as needed. + return SequenceType::get(ty.getShape(), convertType(ty.getEleTy())); + }); + addConversion([&](RecordType ty) { + // FIR record types can have recursive references, so conversion is a bit + // more complex than the other types. This conversion is not needed + // presently, so just emit a TODO message. Need to consider the uniqued + // name of the record, etc. + fir::emitFatalError( + mlir::UnknownLoc::get(ty.getContext()), + "not yet implemented: record type with a boxproc type"); + return RecordType::get(ty.getContext(), "*fixme*"); + }); + addArgumentMaterialization(materializeProcedure); + addSourceMaterialization(materializeProcedure); + addTargetMaterialization(materializeProcedure); + } + + static mlir::Value materializeProcedure(mlir::OpBuilder &builder, + BoxProcType type, + mlir::ValueRange inputs, + mlir::Location loc) { + assert(inputs.size() == 1); + return builder.create(loc, unwrapRefType(type.getEleTy()), + inputs[0]); + } + +private: + llvm::SmallVector visitedTypes; +}; + +/// A `boxproc` is an abstraction for a Fortran procedure reference. Typically, +/// Fortran procedures can be referenced directly through a function pointer. +/// However, Fortran has one-level dynamic scoping between a host procedure and +/// its internal procedures. This allows internal procedures to directly access +/// and modify the state of the host procedure's variables. +/// +/// There are any number of possible implementations possible. +/// +/// The implementation used here is to convert `boxproc` values to function +/// pointers everywhere. If a `boxproc` value includes a frame pointer to the +/// host procedure's data, then a thunk will be created at runtime to capture +/// the frame pointer during execution. In LLVM IR, the frame pointer is +/// designated with the `nest` attribute. The thunk's address will then be used +/// as the call target instead of the original function's address directly. +class BoxedProcedurePass : public BoxedProcedurePassBase { +public: + BoxedProcedurePass() { options = {true}; } + BoxedProcedurePass(bool useThunks) { options = {useThunks}; } + + inline mlir::ModuleOp getModule() { return getOperation(); } + + void runOnOperation() override final { + if (options.useThunks) { + auto *context = &getContext(); + mlir::IRRewriter rewriter(context); + BoxprocTypeRewriter typeConverter; + mlir::Dialect *firDialect = context->getLoadedDialect("fir"); + getModule().walk([&](mlir::Operation *op) { + if (auto addr = mlir::dyn_cast(op)) { + auto ty = addr.getVal().getType(); + if (typeConverter.needsConversion(ty) || + ty.isa()) { + // Rewrite all `fir.box_addr` ops on values of type `!fir.boxproc` + // or function type to be `fir.convert` ops. + rewriter.setInsertionPoint(addr); + rewriter.replaceOpWithNewOp( + addr, typeConverter.convertType(addr.getType()), addr.getVal()); + } + } else if (auto func = mlir::dyn_cast(op)) { + mlir::FunctionType ty = func.getFunctionType(); + if (typeConverter.needsConversion(ty)) { + rewriter.startRootUpdate(func); + auto toTy = + typeConverter.convertType(ty).cast(); + if (!func.empty()) + for (auto e : llvm::enumerate(toTy.getInputs())) { + unsigned i = e.index(); + auto &block = func.front(); + block.insertArgument(i, e.value(), func.getLoc()); + block.getArgument(i + 1).replaceAllUsesWith( + block.getArgument(i)); + block.eraseArgument(i + 1); + } + func.setType(toTy); + rewriter.finalizeRootUpdate(func); + } + } else if (auto embox = mlir::dyn_cast(op)) { + // Rewrite all `fir.emboxproc` ops to either `fir.convert` or a thunk + // as required. + mlir::Type toTy = embox.getType().cast().getEleTy(); + rewriter.setInsertionPoint(embox); + if (embox.getHost()) { + // Create the thunk. + auto module = embox->getParentOfType(); + FirOpBuilder builder(rewriter, getKindMapping(module)); + auto loc = embox.getLoc(); + mlir::Type i8Ty = builder.getI8Type(); + mlir::Type i8Ptr = builder.getRefType(i8Ty); + mlir::Type buffTy = SequenceType::get({32}, i8Ty); + auto buffer = builder.create(loc, buffTy); + mlir::Value closure = + builder.createConvert(loc, i8Ptr, embox.getHost()); + mlir::Value tramp = builder.createConvert(loc, i8Ptr, buffer); + mlir::Value func = + builder.createConvert(loc, i8Ptr, embox.getFunc()); + builder.create( + loc, factory::getLlvmInitTrampoline(builder), + llvm::ArrayRef{tramp, func, closure}); + auto adjustCall = builder.create( + loc, factory::getLlvmAdjustTrampoline(builder), + llvm::ArrayRef{tramp}); + rewriter.replaceOpWithNewOp(embox, toTy, + adjustCall.getResult(0)); + } else { + // Just forward the function as a pointer. + rewriter.replaceOpWithNewOp(embox, toTy, + embox.getFunc()); + } + } else if (auto mem = mlir::dyn_cast(op)) { + auto ty = mem.getType(); + if (typeConverter.needsConversion(ty)) { + rewriter.setInsertionPoint(mem); + auto toTy = typeConverter.convertType(unwrapRefType(ty)); + bool isPinned = mem.getPinned(); + llvm::StringRef uniqName; + if (mem.getUniqName().hasValue()) + uniqName = mem.getUniqName().getValue(); + llvm::StringRef bindcName; + if (mem.getBindcName().hasValue()) + bindcName = mem.getBindcName().getValue(); + rewriter.replaceOpWithNewOp( + mem, toTy, uniqName, bindcName, isPinned, mem.getTypeparams(), + mem.getShape()); + } + } else if (auto mem = mlir::dyn_cast(op)) { + auto ty = mem.getType(); + if (typeConverter.needsConversion(ty)) { + rewriter.setInsertionPoint(mem); + auto toTy = typeConverter.convertType(unwrapRefType(ty)); + llvm::StringRef uniqName; + if (mem.getUniqName().hasValue()) + uniqName = mem.getUniqName().getValue(); + llvm::StringRef bindcName; + if (mem.getBindcName().hasValue()) + bindcName = mem.getBindcName().getValue(); + rewriter.replaceOpWithNewOp( + mem, toTy, uniqName, bindcName, mem.getTypeparams(), + mem.getShape()); + } + } else if (auto coor = mlir::dyn_cast(op)) { + auto ty = coor.getType(); + mlir::Type baseTy = coor.getBaseType(); + if (typeConverter.needsConversion(ty) || + typeConverter.needsConversion(baseTy)) { + rewriter.setInsertionPoint(coor); + auto toTy = typeConverter.convertType(ty); + auto toBaseTy = typeConverter.convertType(baseTy); + rewriter.replaceOpWithNewOp(coor, toTy, coor.getRef(), + coor.getCoor(), toBaseTy); + } + } else if (auto index = mlir::dyn_cast(op)) { + auto ty = index.getType(); + mlir::Type onTy = index.getOnType(); + if (typeConverter.needsConversion(ty) || + typeConverter.needsConversion(onTy)) { + rewriter.setInsertionPoint(index); + auto toTy = typeConverter.convertType(ty); + auto toOnTy = typeConverter.convertType(onTy); + rewriter.replaceOpWithNewOp( + index, toTy, index.getFieldId(), toOnTy, index.getTypeparams()); + } + } else if (auto index = mlir::dyn_cast(op)) { + auto ty = index.getType(); + mlir::Type onTy = index.getOnType(); + if (typeConverter.needsConversion(ty) || + typeConverter.needsConversion(onTy)) { + rewriter.setInsertionPoint(index); + auto toTy = typeConverter.convertType(ty); + auto toOnTy = typeConverter.convertType(onTy); + rewriter.replaceOpWithNewOp( + mem, toTy, index.getFieldId(), toOnTy); + } + } else if (op->getDialect() == firDialect) { + rewriter.startRootUpdate(op); + for (auto i : llvm::enumerate(op->getResultTypes())) + if (typeConverter.needsConversion(i.value())) { + auto toTy = typeConverter.convertType(i.value()); + op->getResult(i.index()).setType(toTy); + } + rewriter.finalizeRootUpdate(op); + } + }); + } + // TODO: any alternative implementation. Note: currently, the default code + // gen will not be able to handle boxproc and will give an error. + } + +private: + BoxedProcedureOptions options; +}; +} // namespace + +std::unique_ptr fir::createBoxedProcedurePass() { + return std::make_unique(); +} + +std::unique_ptr fir::createBoxedProcedurePass(bool useThunks) { + return std::make_unique(useThunks); +} diff --git a/flang/lib/Optimizer/CodeGen/CMakeLists.txt b/flang/lib/Optimizer/CodeGen/CMakeLists.txt index 04016c506ebc..e9e4ca29f4eb 100644 --- a/flang/lib/Optimizer/CodeGen/CMakeLists.txt +++ b/flang/lib/Optimizer/CodeGen/CMakeLists.txt @@ -1,4 +1,5 @@ add_flang_library(FIRCodeGen + BoxedProcedure.cpp CGOps.cpp CodeGen.cpp PreCGRewrite.cpp diff --git a/flang/lib/Optimizer/CodeGen/TargetRewrite.cpp b/flang/lib/Optimizer/CodeGen/TargetRewrite.cpp index 3626d7534da8..0d64aee25eec 100644 --- a/flang/lib/Optimizer/CodeGen/TargetRewrite.cpp +++ b/flang/lib/Optimizer/CodeGen/TargetRewrite.cpp @@ -18,6 +18,7 @@ #include "Target.h" #include "flang/Lower/Todo.h" #include "flang/Optimizer/Builder/Character.h" +#include "flang/Optimizer/Builder/FIRBuilder.h" #include "flang/Optimizer/CodeGen/CodeGen.h" #include "flang/Optimizer/Dialect/FIRDialect.h" #include "flang/Optimizer/Dialect/FIROps.h" @@ -83,9 +84,8 @@ public: if (!forcedTargetTriple.empty()) setTargetTriple(mod, forcedTargetTriple); - auto specifics = CodeGenSpecifics::get(getOperation().getContext(), - getTargetTriple(getOperation()), - getKindMapping(getOperation())); + auto specifics = CodeGenSpecifics::get( + mod.getContext(), getTargetTriple(mod), getKindMapping(mod)); setMembers(specifics.get(), &rewriter); // Perform type conversion on signatures and call sites. @@ -272,12 +272,12 @@ public: rewriteCallComplexInputType(cmplx, oper, newInTys, newOpers); }) .template Case([&](mlir::TupleType tuple) { - if (factory::isCharacterProcedureTuple(tuple)) { + if (isCharacterProcedureTuple(tuple)) { mlir::ModuleOp module = getModule(); if constexpr (std::is_same_v, fir::CallOp>) { if (callOp.getCallee()) { llvm::StringRef charProcAttr = - fir::getCharacterProcedureDummyAttrName(); + getCharacterProcedureDummyAttrName(); // The charProcAttr attribute is only used as a safety to // confirm that this is a dummy procedure and should be split. // It cannot be used to match because attributes are not @@ -401,7 +401,7 @@ public: lowerComplexSignatureArg(ty, newInTys); }) .Case([&](mlir::TupleType tuple) { - if (factory::isCharacterProcedureTuple(tuple)) { + if (isCharacterProcedureTuple(tuple)) { newInTys.push_back(tuple.getType(0)); trailingInTys.push_back(tuple.getType(1)); } else { @@ -442,7 +442,7 @@ public: return false; } for (auto ty : func.getInputs()) - if (((ty.isa() || factory::isCharacterProcedureTuple(ty)) && + if (((ty.isa() || isCharacterProcedureTuple(ty)) && !noCharacterConversion) || (isa_complex(ty) && !noComplexConversion)) { LLVM_DEBUG(llvm::dbgs() << "rewrite " << signature << " for target\n"); @@ -451,11 +451,21 @@ public: return true; } + /// Determine if the signature has host associations. The host association + /// argument may need special target specific rewriting. + static bool hasHostAssociations(mlir::FuncOp func) { + std::size_t end = func.getFunctionType().getInputs().size(); + for (std::size_t i = 0; i < end; ++i) + if (func.getArgAttrOfType(i, getHostAssocAttrName())) + return true; + return false; + } + /// Rewrite the signatures and body of the `FuncOp`s in the module for /// the immediately subsequent target code gen. void convertSignature(mlir::FuncOp func) { auto funcTy = func.getFunctionType().cast(); - if (hasPortableSignature(funcTy)) + if (hasPortableSignature(funcTy) && !hasHostAssociations(func)) return; llvm::SmallVector newResTys; llvm::SmallVector newInTys; @@ -526,7 +536,7 @@ public: doComplexArg(func, cmplx, newInTys, fixups); }) .Case([&](mlir::TupleType tuple) { - if (factory::isCharacterProcedureTuple(tuple)) { + if (isCharacterProcedureTuple(tuple)) { fixups.emplace_back(FixupTy::Codes::TrailingCharProc, newInTys.size(), trailingTys.size()); newInTys.push_back(tuple.getType(0)); @@ -536,6 +546,10 @@ public: } }) .Default([&](mlir::Type ty) { newInTys.push_back(ty); }); + if (func.getArgAttrOfType(index, + getHostAssocAttrName())) { + func.setArgAttr(index, "llvm.nest", rewriter->getUnitAttr()); + } } if (!func.empty()) { @@ -665,7 +679,7 @@ public: func.front().eraseArgument(fixup.index + 1); } break; case FixupTy::Codes::TrailingCharProc: { - // The FIR character procedure argument tuple has been split into a + // The FIR character procedure argument tuple must be split into a // pair of distinct arguments. The first part of the pair appears in // the original argument position. The second part of the pair is // appended after all the original arguments. diff --git a/flang/lib/Optimizer/CodeGen/TypeConverter.h b/flang/lib/Optimizer/CodeGen/TypeConverter.h index 3202b00e72c5..5d15dade2dd7 100644 --- a/flang/lib/Optimizer/CodeGen/TypeConverter.h +++ b/flang/lib/Optimizer/CodeGen/TypeConverter.h @@ -250,6 +250,16 @@ public: .getElementType(); } + // fir.boxproc --> llvm<"{ any*, i8* }"> + mlir::Type convertBoxProcType(BoxProcType boxproc) { + auto funcTy = convertType(boxproc.getEleTy()); + auto i8PtrTy = mlir::LLVM::LLVMPointerType::get( + mlir::IntegerType::get(&getContext(), 8)); + llvm::SmallVector tuple = {funcTy, i8PtrTy}; + return mlir::LLVM::LLVMStructType::getLiteral(&getContext(), tuple, + /*isPacked=*/false); + } + unsigned characterBitsize(fir::CharacterType charTy) { return kindMapping.getCharacterBitsize(charTy.getFKind()); } diff --git a/flang/lib/Optimizer/Dialect/FIROps.cpp b/flang/lib/Optimizer/Dialect/FIROps.cpp index 159b0beb28f6..2c25805bb58f 100644 --- a/flang/lib/Optimizer/Dialect/FIROps.cpp +++ b/flang/lib/Optimizer/Dialect/FIROps.cpp @@ -1095,57 +1095,13 @@ mlir::LogicalResult EmboxCharOp::verify() { // EmboxProcOp //===----------------------------------------------------------------------===// -mlir::ParseResult EmboxProcOp::parse(mlir::OpAsmParser &parser, - mlir::OperationState &result) { - mlir::SymbolRefAttr procRef; - if (parser.parseAttribute(procRef, "funcname", result.attributes)) - return mlir::failure(); - bool hasTuple = false; - mlir::OpAsmParser::UnresolvedOperand tupleRef; - if (!parser.parseOptionalComma()) { - if (parser.parseOperand(tupleRef)) - return mlir::failure(); - hasTuple = true; - } - mlir::FunctionType type; - if (parser.parseColon() || parser.parseLParen() || parser.parseType(type)) - return mlir::failure(); - result.addAttribute("functype", mlir::TypeAttr::get(type)); - if (hasTuple) { - mlir::Type tupleType; - if (parser.parseComma() || parser.parseType(tupleType) || - parser.resolveOperand(tupleRef, tupleType, result.operands)) - return mlir::failure(); - } - mlir::Type boxType; - if (parser.parseRParen() || parser.parseArrow() || - parser.parseType(boxType) || parser.addTypesToList(boxType, result.types)) - return mlir::failure(); - return mlir::success(); -} - -void EmboxProcOp::print(mlir::OpAsmPrinter &p) { - p << ' ' << getOperation()->getAttr("funcname"); - auto h = getHost(); - if (h) { - p << ", "; - p.printOperand(h); - } - p << " : (" << getOperation()->getAttr("functype"); - if (h) - p << ", " << h.getType(); - p << ") -> " << getType(); -} - mlir::LogicalResult EmboxProcOp::verify() { // host bindings (optional) must be a reference to a tuple if (auto h = getHost()) { - if (auto r = h.getType().dyn_cast()) { - if (!r.getEleTy().dyn_cast()) - return mlir::failure(); - } else { - return mlir::failure(); - } + if (auto r = h.getType().dyn_cast()) + if (r.getEleTy().dyn_cast()) + return mlir::success(); + return mlir::failure(); } return mlir::success(); } diff --git a/flang/lib/Optimizer/Transforms/ExternalNameConversion.cpp b/flang/lib/Optimizer/Transforms/ExternalNameConversion.cpp index d448eda30a45..ef11b442a161 100644 --- a/flang/lib/Optimizer/Transforms/ExternalNameConversion.cpp +++ b/flang/lib/Optimizer/Transforms/ExternalNameConversion.cpp @@ -116,25 +116,6 @@ public: } }; -struct MangleNameOnEmboxProcOp - : public mlir::OpRewritePattern { -public: - using OpRewritePattern::OpRewritePattern; - - mlir::LogicalResult - matchAndRewrite(fir::EmboxProcOp op, - mlir::PatternRewriter &rewriter) const override { - rewriter.startRootUpdate(op); - auto result = fir::NameUniquer::deconstruct( - op.getFuncname().getRootReference().getValue()); - if (fir::NameUniquer::isExternalFacingUniquedName(result)) - op.setFuncnameAttr( - SymbolRefAttr::get(op.getContext(), mangleExternalName(result))); - rewriter.finalizeRootUpdate(op); - return success(); - } -}; - class ExternalNameConversionPass : public fir::ExternalNameConversionBase { public: @@ -149,8 +130,7 @@ void ExternalNameConversionPass::runOnOperation() { mlir::RewritePatternSet patterns(context); patterns.insert(context); + MangleNameForCommonBlock, MangleNameOnAddrOfOp>(context); ConversionTarget target(*context); target.addLegalDialect([](fir::EmboxProcOp op) { - return !fir::NameUniquer::needExternalNameMangling( - op.getFuncname().getRootReference().getValue()); - }); - if (failed(applyPartialConversion(op, target, std::move(patterns)))) signalPassFailure(); } diff --git a/flang/test/Fir/Todo/emboxproc.fir b/flang/test/Fir/Todo/emboxproc.fir deleted file mode 100644 index c16e7a1925f4..000000000000 --- a/flang/test/Fir/Todo/emboxproc.fir +++ /dev/null @@ -1,11 +0,0 @@ -// RUN: %not_todo_cmd fir-opt --fir-to-llvm-ir="target=x86_64-unknown-linux-gnu" %s 2>&1 | FileCheck %s - -// Test `fir.emboxproc` conversion to llvm. -// Not implemented yet. - -func @emboxproc_test() { - %host_vars = fir.alloca tuple -// CHECK: not yet implemented fir.emboxproc codegen - %bproc = fir.emboxproc @method_impl, %host_vars : ((i32) -> (), !fir.ref>) -> !fir.boxproc<(i32) -> ()> - return -} diff --git a/flang/test/Fir/external-mangling-emboxproc.fir b/flang/test/Fir/external-mangling-emboxproc.fir index d344f5166e3c..6a82384ff5f3 100644 --- a/flang/test/Fir/external-mangling-emboxproc.fir +++ b/flang/test/Fir/external-mangling-emboxproc.fir @@ -2,9 +2,10 @@ func @_QPfoo() { %e6 = fir.alloca tuple - %0 = fir.emboxproc @_QPfoo_impl, %e6 : ((!fir.box>) -> (), !fir.ref>) -> !fir.boxproc<(!fir.box>) -> ()> + %ao = fir.address_of(@_QPfoo_impl) : (!fir.box>) -> () + %0 = fir.emboxproc %ao, %e6 : ((!fir.box>) -> (), !fir.ref>) -> !fir.boxproc<(!fir.box>) -> ()> return } func private @_QPfoo_impl(!fir.ref) -// CHECK: %{{.*}}= fir.emboxproc @foo_impl_ +// CHECK: fir.address_of(@foo_impl_) diff --git a/flang/test/Fir/fir-ops.fir b/flang/test/Fir/fir-ops.fir index 6ab6d4c7a80a..f7643bd4b3df 100644 --- a/flang/test/Fir/fir-ops.fir +++ b/flang/test/Fir/fir-ops.fir @@ -53,13 +53,20 @@ func @instructions() { %6 = fir.embox %5 : (!fir.heap>) -> !fir.box> // CHECK: [[VAL_7:%.*]] = fir.box_addr [[VAL_6]] : (!fir.box>) -> !fir.ref> + %7 = fir.box_addr %6 : (!fir.box>) -> !fir.ref> +// CHECK: %[[WAL_2:.*]] = fir.undefined !fir.boxproc<() -> ()> + %ba1 = fir.undefined !fir.boxproc<() -> ()> +// CHECK: %{{.*}} = fir.box_addr %[[WAL_2]] : (!fir.boxproc<() -> ()>) -> (() -> ()) + %ba2 = fir.box_addr %ba1 : (!fir.boxproc<() -> ()>) -> (() -> ()) + %ba3 = fir.undefined !fir.boxchar<1> +// CHECK: %{{.*}} = fir.box_addr %{{.*}} : (!fir.boxchar<1>) -> !fir.ref> + %ba4 = fir.box_addr %ba3 : (!fir.boxchar<1>) -> !fir.ref> + %c0 = arith.constant 0 : index + %d1:3 = fir.box_dims %6, %c0 : (!fir.box>, index) -> (index, index, index) // CHECK: [[VAL_8:%.*]] = arith.constant 0 : index // CHECK: [[VAL_9:%.*]]:3 = fir.box_dims [[VAL_6]], [[VAL_8]] : (!fir.box>, index) -> (index, index, index) // CHECK: fir.call @print_index3([[VAL_9]]#0, [[VAL_9]]#1, [[VAL_9]]#2) : (index, index, index) -> () // CHECK: [[VAL_10:%.*]] = fir.call @it1() : () -> !fir.int<4> - %7 = fir.box_addr %6 : (!fir.box>) -> !fir.ref> - %c0 = arith.constant 0 : index - %d1:3 = fir.box_dims %6, %c0 : (!fir.box>, index) -> (index, index, index) fir.call @print_index3(%d1#0, %d1#1, %d1#2) : (index, index, index) -> () %8 = fir.call @it1() : () -> !fir.int<4> @@ -154,7 +161,8 @@ func @boxing_match() { // CHECK: [[VAL_53:%.*]] = arith.constant 4.213000e+01 : f64 // CHECK: [[VAL_54:%.*]] = fir.insert_value [[VAL_48]], [[VAL_53]], [1 : i32] : (!fir.type, f64) -> !fir.type // CHECK: fir.store [[VAL_54]] to [[VAL_39]] : !fir.ref> -// CHECK: [[VAL_55:%.*]] = fir.emboxproc @method_impl, [[VAL_41]] : ((!fir.box>) -> (), !fir.ref>) -> !fir.boxproc<(!fir.box>) -> ()> +// CHECK: %[[WAL_1:.*]] = fir.address_of(@method_impl) +// CHECK: [[VAL_55:%.*]] = fir.emboxproc %[[WAL_1]], [[VAL_41]] : ((!fir.box>) -> (), !fir.ref>) -> !fir.boxproc<(!fir.box>) -> ()> // CHECK: [[VAL_56:%.*]], [[VAL_57:%.*]] = fir.unboxproc [[VAL_55]] : (!fir.boxproc<(!fir.box>) -> ()>) -> ((!fir.box>) -> (), !fir.ref>>) // CHECK: [[VAL_58:%.*]] = fir.call @box2() : () -> !fir.boxproc<(i32, i32) -> i64> // CHECK: [[VAL_59:%.*]], [[VAL_60:%.*]] = fir.unboxproc [[VAL_58]] : (!fir.boxproc<(i32, i32) -> i64>) -> ((i32, i32) -> i64, !fir.ref>>) @@ -179,7 +187,8 @@ func @boxing_match() { %c42 = arith.constant 42.13 : f64 %a3 = fir.insert_value %6, %c42, [1 : i32] : (!fir.type, f64) -> !fir.type fir.store %a3 to %d6 : !fir.ref> - %7 = fir.emboxproc @method_impl, %e6 : ((!fir.box>) -> (), !fir.ref>) -> !fir.boxproc<(!fir.box>) -> ()> + %mi = fir.address_of(@method_impl) : (!fir.box>) -> () + %7 = fir.emboxproc %mi, %e6 : ((!fir.box>) -> (), !fir.ref>) -> !fir.boxproc<(!fir.box>) -> ()> %8:2 = fir.unboxproc %7 : (!fir.boxproc<(!fir.box>) -> ()>) -> ((!fir.box>) -> (), !fir.ref>>) %9 = fir.call @box2() : () -> !fir.boxproc<(i32, i32) -> i64> %10:2 = fir.unboxproc %9 : (!fir.boxproc<(i32, i32) -> i64>) -> ((i32, i32) -> i64, !fir.ref>>) diff --git a/flang/test/Lower/Intrinsics/len.f90 b/flang/test/Lower/Intrinsics/len.f90 index b14046fc0f31..1e22254b49fe 100644 --- a/flang/test/Lower/Intrinsics/len.f90 +++ b/flang/test/Lower/Intrinsics/len.f90 @@ -2,75 +2,108 @@ ! CHECK-LABEL: len_test subroutine len_test(i, c) - integer :: i - character(*) :: c - ! CHECK: %[[c:.*]]:2 = fir.unboxchar %arg1 - ! CHECK: %[[xx:.*]] = fir.convert %[[c]]#1 : (index) -> i32 - ! CHECK: fir.store %[[xx]] to %arg0 - i = len(c) - end subroutine - - ! CHECK-LABEL: len_test_array - ! CHECK-SAME: %[[arg0:.*]]: !fir.ref {fir.bindc_name = "i"}, %[[arg1:.*]]: !fir.boxchar<1> {fir.bindc_name = "c"} - subroutine len_test_array(i, c) - integer :: i - character(*) :: c(100) - ! CHECK: %[[c:.*]]:2 = fir.unboxchar %[[arg1]] - ! CHECK: %[[xx:.*]] = fir.convert %[[c]]#1 : (index) -> i32 - ! CHECK: fir.store %[[xx]] to %[[arg0]] - i = len(c) - end subroutine - - ! CHECK-LABEL: func @_QPlen_test_assumed_shape_array( - ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "i"}, - ! CHECK-SAME: %[[VAL_1:.*]]: !fir.box>> {fir.bindc_name = "c"}) { - subroutine len_test_assumed_shape_array(i, c) - integer :: i - character(*) :: c(:) - ! CHECK: %[[VAL_2:.*]] = fir.box_elesize %[[VAL_1]] : (!fir.box>>) -> index - ! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (index) -> i32 - ! CHECK: fir.store %[[VAL_3]] to %[[VAL_0]] : !fir.ref - i = len(c) - end subroutine - - ! CHECK-LABEL: func @_QPlen_test_array_alloc( - ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "i"}, - ! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref>>>> {fir.bindc_name = "c"}) { - subroutine len_test_array_alloc(i, c) - integer :: i - character(:), allocatable :: c(:) - ! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]] : !fir.ref>>>> - ! CHECK: %[[VAL_3:.*]] = fir.box_elesize %[[VAL_2]] : (!fir.box>>>) -> index - ! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (index) -> i32 - ! CHECK: fir.store %[[VAL_4]] to %[[VAL_0]] : !fir.ref - i = len(c) - end subroutine - - ! CHECK-LABEL: func @_QPlen_test_array_local_alloc( - ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "i"}) - subroutine len_test_array_local_alloc(i) - integer :: i - character(:), allocatable :: c(:) - ! CHECK: %[[VAL_5:.*]] = fir.alloca index {uniq_name = "_QFlen_test_array_local_allocEc.len"} - ! CHECK: %[[VAL_7:.*]] = arith.constant 10 : i32 - ! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_7]] : (i32) -> index - ! CHECK: fir.store %[[VAL_10]] to %[[VAL_5]] : !fir.ref - allocate(character(10):: c(100)) - ! CHECK: %[[VAL_13:.*]] = fir.load %[[VAL_5]] : !fir.ref - ! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_13]] : (index) -> i32 - ! CHECK: fir.store %[[VAL_14]] to %[[VAL_0]] : !fir.ref - i = len(c) - end subroutine - - ! CHECK-LABEL: func @_QPlen_test_alloc_explicit_len( - ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "i"}, - ! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref {fir.bindc_name = "n"}, - ! CHECK-SAME: %[[VAL_2:.*]]: !fir.ref>>>> {fir.bindc_name = "c"}) { - subroutine len_test_alloc_explicit_len(i, n, c) - integer :: i - integer :: n - character(n), allocatable :: c(:) - ! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_1]] : !fir.ref - ! CHECK: fir.store %[[VAL_3]] to %[[VAL_0]] : !fir.ref - i = len(c) - end subroutine + integer :: i + character(*) :: c + ! CHECK: %[[c:.*]]:2 = fir.unboxchar %arg1 + ! CHECK: %[[xx:.*]] = fir.convert %[[c]]#1 : (index) -> i32 + ! CHECK: fir.store %[[xx]] to %arg0 + i = len(c) +end subroutine + +! CHECK-LABEL: len_test_array +! CHECK-SAME: %[[arg0:.*]]: !fir.ref {fir.bindc_name = "i"}, %[[arg1:.*]]: !fir.boxchar<1> {fir.bindc_name = "c"} +subroutine len_test_array(i, c) + integer :: i + character(*) :: c(100) + ! CHECK: %[[c:.*]]:2 = fir.unboxchar %[[arg1]] + ! CHECK: %[[xx:.*]] = fir.convert %[[c]]#1 : (index) -> i32 + ! CHECK: fir.store %[[xx]] to %[[arg0]] + i = len(c) +end subroutine + +! CHECK-LABEL: func @_QPlen_test_assumed_shape_array( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "i"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.box>> {fir.bindc_name = "c"}) { +subroutine len_test_assumed_shape_array(i, c) + integer :: i + character(*) :: c(:) +! CHECK: %[[VAL_2:.*]] = fir.box_elesize %[[VAL_1]] : (!fir.box>>) -> index +! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (index) -> i32 +! CHECK: fir.store %[[VAL_3]] to %[[VAL_0]] : !fir.ref + i = len(c) +end subroutine + +! CHECK-LABEL: func @_QPlen_test_array_alloc( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "i"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref>>>> {fir.bindc_name = "c"}) { +subroutine len_test_array_alloc(i, c) + integer :: i + character(:), allocatable :: c(:) +! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]] : !fir.ref>>>> +! CHECK: %[[VAL_3:.*]] = fir.box_elesize %[[VAL_2]] : (!fir.box>>>) -> index +! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (index) -> i32 +! CHECK: fir.store %[[VAL_4]] to %[[VAL_0]] : !fir.ref + i = len(c) +end subroutine + +! CHECK-LABEL: func @_QPlen_test_array_local_alloc( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "i"}) +subroutine len_test_array_local_alloc(i) + integer :: i + character(:), allocatable :: c(:) +! CHECK: %[[VAL_5:.*]] = fir.alloca index {uniq_name = "_QFlen_test_array_local_allocEc.len"} +! CHECK: %[[VAL_7:.*]] = arith.constant 10 : i32 +! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_7]] : (i32) -> index +! CHECK: fir.store %[[VAL_10]] to %[[VAL_5]] : !fir.ref + allocate(character(10):: c(100)) +! CHECK: %[[VAL_13:.*]] = fir.load %[[VAL_5]] : !fir.ref +! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_13]] : (index) -> i32 +! CHECK: fir.store %[[VAL_14]] to %[[VAL_0]] : !fir.ref + i = len(c) +end subroutine + +! CHECK-LABEL: func @_QPlen_test_alloc_explicit_len( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "i"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref {fir.bindc_name = "n"}, +! CHECK-SAME: %[[VAL_2:.*]]: !fir.ref>>>> {fir.bindc_name = "c"}) { +subroutine len_test_alloc_explicit_len(i, n, c) + integer :: i + integer :: n + character(n), allocatable :: c(:) +! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_1]] : !fir.ref +! CHECK: %[[c0_i32:.*]] = arith.constant 0 : i32 +! CHECK: %[[cmp:.*]] = arith.cmpi sgt, %[[VAL_3]], %[[c0_i32]] : i32 +! CHECK: %[[len:.*]] = arith.select %[[cmp]], %[[VAL_3]], %[[c0_i32]] : i32 +! CHECK: fir.store %[[len]] to %[[VAL_0]] : !fir.ref + i = len(c) +end subroutine + +! CHECK-LABEL: func @_QPlen_test_pointer_explicit_len( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "i"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref {fir.bindc_name = "n"}, +subroutine len_test_pointer_explicit_len(i, n, c) + integer :: i + integer :: n + character(n), pointer :: c(:) +! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_1]] : !fir.ref +! CHECK: %[[c0_i32:.*]] = arith.constant 0 : i32 +! CHECK: %[[cmp:.*]] = arith.cmpi sgt, %[[VAL_3]], %[[c0_i32]] : i32 +! CHECK: %[[len:.*]] = arith.select %[[cmp]], %[[VAL_3]], %[[c0_i32]] : i32 +! CHECK: fir.store %[[len]] to %[[VAL_0]] : !fir.ref + i = len(c) +end subroutine + +! CHECK-LABEL: func @_QPlen_test_assumed_shape_explicit_len( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "i"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref {fir.bindc_name = "n"}, +subroutine len_test_assumed_shape_explicit_len(i, n, c) + integer :: i + integer :: n + character(n) :: c(:) +! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_1]] : !fir.ref +! CHECK: %[[c0_i32:.*]] = arith.constant 0 : i32 +! CHECK: %[[cmp:.*]] = arith.cmpi sgt, %[[VAL_3]], %[[c0_i32]] : i32 +! CHECK: %[[len:.*]] = arith.select %[[cmp]], %[[VAL_3]], %[[c0_i32]] : i32 +! CHECK: fir.store %[[len]] to %[[VAL_0]] : !fir.ref + i = len(c) +end subroutine diff --git a/flang/test/Lower/allocatable-assignment.f90 b/flang/test/Lower/allocatable-assignment.f90 index 945b6d0ccc9b..9c458371f23c 100644 --- a/flang/test/Lower/allocatable-assignment.f90 +++ b/flang/test/Lower/allocatable-assignment.f90 @@ -2,6 +2,9 @@ ! RUN: bbc -emit-fir %s -o - | FileCheck %s module alloc_assign + type t + integer :: i + end type contains ! ----------------------------------------------------------------------------- @@ -174,7 +177,10 @@ end subroutine subroutine test_dyn_char_scalar(x, n) integer :: n character(n), allocatable :: x -! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]] : !fir.ref +! CHECK: %[[VAL_2A:.*]] = fir.load %[[VAL_1]] : !fir.ref +! CHECK: %[[c0_i32:.*]] = arith.constant 0 : i32 +! CHECK: %[[VAL_2B:.*]] = arith.cmpi sgt, %[[VAL_2A]], %[[c0_i32]] : i32 +! CHECK: %[[VAL_2:.*]] = arith.select %[[VAL_2B]], %[[VAL_2A]], %[[c0_i32]] : i32 ! CHECK: %[[VAL_3:.*]] = fir.address_of(@_QQcl.48656C6C6F20776F726C6421) : !fir.ref> ! CHECK: %[[VAL_4:.*]] = arith.constant 12 : index ! CHECK: %[[VAL_5:.*]] = fir.load %[[VAL_0]] : !fir.ref>>> @@ -215,6 +221,46 @@ subroutine test_dyn_char_scalar(x, n) x = "Hello world!" end subroutine +! CHECK-LABEL: func @_QMalloc_assignPtest_derived_scalar( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>>{{.*}}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref>{{.*}}) { +subroutine test_derived_scalar(x, s) + type(t), allocatable :: x + type(t) :: s + x = s +! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_0]] : !fir.ref>>> +! CHECK: %[[VAL_3:.*]] = fir.box_addr %[[VAL_2]] : (!fir.box>>) -> !fir.heap> +! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.heap>) -> i64 +! CHECK: %[[VAL_5:.*]] = arith.constant 0 : i64 +! CHECK: %[[VAL_6:.*]] = arith.cmpi ne, %[[VAL_4]], %[[VAL_5]] : i64 +! CHECK: %[[VAL_7:.*]]:2 = fir.if %[[VAL_6]] -> (i1, !fir.heap>) { +! CHECK: %[[VAL_8:.*]] = arith.constant false +! CHECK: %[[VAL_9:.*]] = fir.if %[[VAL_8]] -> (!fir.heap>) { +! CHECK: %[[VAL_10:.*]] = fir.allocmem !fir.type<_QMalloc_assignTt{i:i32}> {uniq_name = ".auto.alloc"} +! CHECK: fir.result %[[VAL_10]] : !fir.heap> +! CHECK: } else { +! CHECK: fir.result %[[VAL_3]] : !fir.heap> +! CHECK: } +! CHECK: fir.result %[[VAL_8]], %[[VAL_11:.*]] : i1, !fir.heap> +! CHECK: } else { +! CHECK: %[[VAL_12:.*]] = arith.constant true +! CHECK: %[[VAL_13:.*]] = fir.allocmem !fir.type<_QMalloc_assignTt{i:i32}> {uniq_name = ".auto.alloc"} +! CHECK: fir.result %[[VAL_12]], %[[VAL_13]] : i1, !fir.heap> +! CHECK: } +! CHECK: %[[VAL_14:.*]] = fir.field_index i, !fir.type<_QMalloc_assignTt{i:i32}> +! CHECK: %[[VAL_15:.*]] = fir.coordinate_of %[[VAL_1]], %[[VAL_14]] : (!fir.ref>, !fir.field) -> !fir.ref +! CHECK: %[[VAL_16:.*]] = fir.coordinate_of %[[VAL_7]]#1, %[[VAL_14]] : (!fir.heap>, !fir.field) -> !fir.ref +! CHECK: %[[VAL_17:.*]] = fir.load %[[VAL_15]] : !fir.ref +! CHECK: fir.store %[[VAL_17]] to %[[VAL_16]] : !fir.ref>) -> !fir.box>> +! CHECK: fir.store %[[VAL_19]] to %[[VAL_0]] : !fir.ref>>> +! CHECK: } +end subroutine + ! ----------------------------------------------------------------------------- ! Test numeric/logical array RHS ! ----------------------------------------------------------------------------- @@ -385,6 +431,76 @@ subroutine test_with_lbounds(x, y) x = y end subroutine +! CHECK-LABEL: func @_QMalloc_assignPtest_runtime_shape( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>>{{.*}}) { +subroutine test_runtime_shape(x) + real, allocatable :: x(:, :) + interface + function return_pointer() + real, pointer :: return_pointer(:, :) + end function + end interface +! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.box>> {bindc_name = ".result"} +! CHECK: %[[VAL_2:.*]] = fir.call @_QPreturn_pointer() : () -> !fir.box>> +! CHECK: fir.save_result %[[VAL_2]] to %[[VAL_1]] : !fir.box>>, !fir.ref>>> +! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_1]] : !fir.ref>>> +! CHECK: %[[VAL_4:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_5:.*]]:3 = fir.box_dims %[[VAL_3]], %[[VAL_4]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[VAL_6:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_7:.*]]:3 = fir.box_dims %[[VAL_3]], %[[VAL_6]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[VAL_8:.*]] = fir.shift %[[VAL_5]]#0, %[[VAL_7]]#0 : (index, index) -> !fir.shift<2> +! CHECK: %[[VAL_10:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_11:.*]]:3 = fir.box_dims %[[VAL_3]], %[[VAL_10]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[VAL_12:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_13:.*]]:3 = fir.box_dims %[[VAL_3]], %[[VAL_12]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[VAL_9:.*]] = fir.array_load %[[VAL_3]](%[[VAL_8]]) : (!fir.box>>, !fir.shift<2>) -> !fir.array +! CHECK: %[[VAL_14:.*]] = fir.load %[[VAL_0]] : !fir.ref>>> +! CHECK: %[[VAL_15:.*]] = fir.box_addr %[[VAL_14]] : (!fir.box>>) -> !fir.heap> +! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_15]] : (!fir.heap>) -> i64 +! CHECK: %[[VAL_17:.*]] = arith.constant 0 : i64 +! CHECK: %[[VAL_18:.*]] = arith.cmpi ne, %[[VAL_16]], %[[VAL_17]] : i64 +! CHECK: %[[VAL_19:.*]]:2 = fir.if %[[VAL_18]] -> (i1, !fir.heap>) { +! CHECK: %[[VAL_20:.*]] = arith.constant false +! CHECK: %[[VAL_21:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_22:.*]]:3 = fir.box_dims %[[VAL_14]], %[[VAL_21]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[VAL_23:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_24:.*]]:3 = fir.box_dims %[[VAL_14]], %[[VAL_23]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[VAL_25:.*]] = arith.cmpi ne, %[[VAL_22]]#1, %[[VAL_11]]#1 : index +! CHECK: %[[VAL_26:.*]] = arith.select %[[VAL_25]], %[[VAL_25]], %[[VAL_20]] : i1 +! CHECK: %[[VAL_27:.*]] = arith.cmpi ne, %[[VAL_24]]#1, %[[VAL_13]]#1 : index +! CHECK: %[[VAL_28:.*]] = arith.select %[[VAL_27]], %[[VAL_27]], %[[VAL_26]] : i1 +! CHECK: %[[VAL_29:.*]] = fir.if %[[VAL_28]] -> (!fir.heap>) { +! CHECK: %[[VAL_30:.*]] = fir.allocmem !fir.array, %[[VAL_11]]#1, %[[VAL_13]]#1 {uniq_name = ".auto.alloc"} +! CHECK: fir.result %[[VAL_30]] : !fir.heap> +! CHECK: } else { +! CHECK: fir.result %[[VAL_15]] : !fir.heap> +! CHECK: } +! CHECK: fir.result %[[VAL_28]], %[[VAL_31:.*]] : i1, !fir.heap> +! CHECK: } else { +! CHECK: %[[VAL_32:.*]] = arith.constant true +! CHECK: %[[VAL_33:.*]] = fir.allocmem !fir.array, %[[VAL_11]]#1, %[[VAL_13]]#1 {uniq_name = ".auto.alloc"} +! CHECK: fir.result %[[VAL_32]], %[[VAL_33]] : i1, !fir.heap> +! CHECK: } + +! CHECK-NOT: fir.call @_QPreturn_pointer() +! CHECK: %[[VAL_34:.*]] = fir.shape %[[VAL_11]]#1, %[[VAL_13]]#1 : (index, index) -> !fir.shape<2> +! CHECK: %[[VAL_35:.*]] = fir.array_load %[[VAL_19]]#1(%[[VAL_34]]) : (!fir.heap>, !fir.shape<2>) -> !fir.array +! normal array assignment .... +! CHECK-NOT: fir.call @_QPreturn_pointer() +! CHECK: fir.array_merge_store %{{.*}}, %{{.*}} to %[[VAL_19]]#1 : !fir.array, !fir.array, !fir.heap> +! CHECK-NOT: fir.call @_QPreturn_pointer() + +! CHECK: fir.if %[[VAL_19]]#0 { +! CHECK: fir.if %[[VAL_18]] { +! CHECK: fir.freemem %[[VAL_15]] +! CHECK: } +! CHECK: %[[VAL_56:.*]] = fir.shape %[[VAL_11]]#1, %[[VAL_13]]#1 : (index, index) -> !fir.shape<2> +! CHECK: %[[VAL_57:.*]] = fir.embox %[[VAL_19]]#1(%[[VAL_56]]) : (!fir.heap>, !fir.shape<2>) -> !fir.box>> +! CHECK: fir.store %[[VAL_57]] to %[[VAL_0]] : !fir.ref>>> +! CHECK: } + x = return_pointer() +end subroutine + ! CHECK-LABEL: func @_QMalloc_assignPtest_scalar_rhs( subroutine test_scalar_rhs(x, y) real, allocatable :: x(:) @@ -405,6 +521,13 @@ end subroutine ! Test character array RHS ! ----------------------------------------------------------------------------- + +! Hit TODO: gathering lhs length in array expression +!subroutine test_deferred_char_rhs_scalar(x) +! character(:), allocatable :: x(:) +! x = "Hello world!" +!end subroutine + ! CHECK: func @_QMalloc_assignPtest_cst_char_rhs_scalar( subroutine test_cst_char_rhs_scalar(x) character(10), allocatable :: x(:) @@ -413,7 +536,7 @@ subroutine test_cst_char_rhs_scalar(x) ! CHECK: fir.if %false -> {{.*}} { ! CHECK: } ! CHECK: } else { - ! CHECK: fir.call @_FortranAReportFatalUserError + ! TODO: runtime error if unallocated ! CHECK-NOT: allocmem ! CHECK: } end subroutine @@ -427,11 +550,18 @@ subroutine test_dyn_char_rhs_scalar(x, n) ! CHECK: fir.if %false -> {{.*}} { ! CHECK: } ! CHECK: } else { - ! CHECK: fir.call @_FortranAReportFatalUserError + ! TODO: runtime error if unallocated ! CHECK-NOT: allocmem ! CHECK: } end subroutine +! Hit TODO: gathering lhs length in array expression +!subroutine test_deferred_char(x, c) +! character(:), allocatable :: x(:) +! character(12) :: c(20) +! x = "Hello world!" +!end subroutine + ! CHECK-LABEL: func @_QMalloc_assignPtest_cst_char( ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>>>{{.*}}, ! CHECK-SAME: %[[VAL_1:.*]]: !fir.boxchar<1>{{.*}}) { @@ -490,7 +620,10 @@ subroutine test_dyn_char(x, n, c) ! CHECK: %[[VAL_3:.*]]:2 = fir.unboxchar %[[VAL_2]] : (!fir.boxchar<1>) -> (!fir.ref>, index) ! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]]#0 : (!fir.ref>) -> !fir.ref>> ! CHECK: %[[VAL_5_0:.*]] = arith.constant 20 : index -! CHECK: %[[VAL_6:.*]] = fir.load %[[VAL_1]] : !fir.ref +! CHECK: %[[VAL_6A:.*]] = fir.load %[[VAL_1]] : !fir.ref +! CHECK: %[[c0_i32:.*]] = arith.constant 0 : i32 +! CHECK: %[[VAL_6B:.*]] = arith.cmpi sgt, %[[VAL_6A]], %[[c0_i32]] : i32 +! CHECK: %[[VAL_6:.*]] = arith.select %[[VAL_6B]], %[[VAL_6A]], %[[c0_i32]] : i32 ! CHECK: %[[VAL_5:.*]] = arith.constant 20 : index ! CHECK: %[[VAL_7:.*]] = fir.shape %[[VAL_5_0]] : (index) -> !fir.shape<1> ! CHECK: %[[VAL_9:.*]] = fir.load %[[VAL_0]] : !fir.ref>>>> @@ -536,4 +669,84 @@ subroutine test_dyn_char(x, n, c) x = c end subroutine +! CHECK-LABEL: func @_QMalloc_assignPtest_derived_with_init +subroutine test_derived_with_init(x, y) + type t + integer, allocatable :: a(:) + end type + type(t), allocatable :: x + type(t) :: y + ! The allocatable component of `x` need to be initialized + ! during the automatic allocation (setting its rank and allocation + ! status) before it is assigned with the component of `y` + x = y +! CHECK: fir.if %{{.*}} { +! CHECK: %[[VAL_11:.*]] = fir.allocmem !fir.type<_QMalloc_assignFtest_derived_with_initTt{a:!fir.box>>}> {uniq_name = ".auto.alloc"} +! CHECK: %[[VAL_12:.*]] = fir.embox %[[VAL_11]] : (!fir.heap>>}>>) -> !fir.box>>}>>> +! CHECK: %[[VAL_15:.*]] = fir.convert %[[VAL_12]] : (!fir.box>>}>>>) -> !fir.box +! CHECK: fir.call @_FortranAInitialize(%[[VAL_15]], %{{.*}}, %{{.*}}) : (!fir.box, !fir.ref, i32) -> none +! CHECK: fir.result %[[VAL_11]] : !fir.heap>>}>> +! CHECK: } else { +! CHECK: fir.result %{{.*}} : !fir.heap>>}>> +! CHECK: } +end subroutine + +! CHECK-LABEL: func @_QMalloc_assignPtest_vector_subscript( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>> {fir.bindc_name = "x"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.box> {fir.bindc_name = "y"}, +! CHECK-SAME: %[[VAL_2:.*]]: !fir.box> {fir.bindc_name = "v"}) { +subroutine test_vector_subscript(x, y, v) + ! Test that the new shape is computed correctly in presence of + ! vector subscripts on the RHS and that it is used to allocate + ! the new storage and to drive the implicit loop. + integer, allocatable :: x(:) + integer :: y(:), v(:) + x = y(v) +! CHECK: %[[VAL_3:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_4:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_5:.*]]:3 = fir.box_dims %[[VAL_1]], %[[VAL_4]] : (!fir.box>, index) -> (index, index, index) +! CHECK: %[[VAL_6:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_7:.*]]:3 = fir.box_dims %[[VAL_2]], %[[VAL_6]] : (!fir.box>, index) -> (index, index, index) +! CHECK: %[[VAL_8:.*]] = fir.array_load %[[VAL_2]] : (!fir.box>) -> !fir.array +! CHECK: %[[VAL_9:.*]] = arith.cmpi sgt, %[[VAL_7]]#1, %[[VAL_5]]#1 : index +! CHECK: %[[VAL_10:.*]] = arith.select %[[VAL_9]], %[[VAL_5]]#1, %[[VAL_7]]#1 : index +! CHECK: fir.if {{.*}} { +! CHECK: %[[VAL_18:.*]] = arith.constant false +! CHECK: %[[VAL_20:.*]]:3 = fir.box_dims %{{.*}}, %{{.*}} : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[VAL_21:.*]] = arith.cmpi ne, %[[VAL_20]]#1, %[[VAL_10]] : index +! CHECK: %[[VAL_22:.*]] = arith.select %[[VAL_21]], %[[VAL_21]], %[[VAL_18]] : i1 +! CHECK: fir.if %[[VAL_22]] {{.*}} { +! CHECK: %[[VAL_24:.*]] = fir.allocmem !fir.array, %[[VAL_10]] {uniq_name = ".auto.alloc"} +! CHECK: fir.result %[[VAL_24]] : !fir.heap> +! CHECK: } else { +! CHECK: fir.result %{{.*}} : !fir.heap> +! CHECK: } +! CHECK: fir.result %{{.*}}, %{{.*}} +! CHECK: } else { +! CHECK: %[[VAL_27:.*]] = fir.allocmem !fir.array, %[[VAL_10]] {uniq_name = ".auto.alloc"} +! CHECK: fir.result %{{.*}}, %[[VAL_27]] : i1, !fir.heap> +! CHECK: } +! CHECK: %[[VAL_28:.*]] = fir.shape %[[VAL_10]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_29:.*]] = fir.array_load %[[VAL_30:.*]]#1(%[[VAL_28]]) : (!fir.heap>, !fir.shape<1>) -> !fir.array +! CHECK: %[[VAL_31:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_32:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_33:.*]] = arith.subi %[[VAL_10]], %[[VAL_31]] : index +! CHECK: %[[VAL_34:.*]] = fir.do_loop %[[VAL_35:.*]] = %[[VAL_32]] to %[[VAL_33]] step %[[VAL_31]] {{.*}} { +! CHECK: } +end subroutine + +! CHECK: fir.global linkonce @[[error_message]] constant : !fir.char<1,76> { +! CHECK: %[[msg:.*]] = fir.string_lit "array left hand side must be allocated when the right hand side is a scalar\00"(76) : !fir.char<1,76> +! CHECK: fir.has_value %[[msg:.*]] : !fir.char<1,76> +! CHECK: } + end module + +! use alloc_assign +! real :: y(2, 3) = reshape([1,2,3,4,5,6], [2,3]) +! real, allocatable :: x (:, :) +! allocate(x(2,2)) +! call test_with_lbounds(x, y) +! print *, x(10, 20) +! print *, x +!end diff --git a/flang/test/Lower/allocatable-callee.f90 b/flang/test/Lower/allocatable-callee.f90 index 5daff59587b0..e5882f1a6d4d 100644 --- a/flang/test/Lower/allocatable-callee.f90 +++ b/flang/test/Lower/allocatable-callee.f90 @@ -59,7 +59,10 @@ subroutine test_char_scalar_explicit_dynamic(c, n) character(n), allocatable :: c external foo1 ! Check that the length expr was evaluated before the execution parts. - ! CHECK: %[[len:.*]] = fir.load %arg1 : !fir.ref + ! CHECK: %[[raw_len:.*]] = fir.load %arg1 : !fir.ref + ! CHECK: %[[c0_i32:.*]] = arith.constant 0 : i32 + ! CHECK: %[[cmp:.*]] = arith.cmpi sgt, %[[raw_len]], %[[c0_i32]] : i32 + ! CHECK: %[[len:.*]] = arith.select %[[cmp]], %[[raw_len]], %[[c0_i32]] : i32 n = n + 1 ! CHECK: fir.store {{.*}} to %arg1 : !fir.ref call foo1(c) @@ -106,7 +109,10 @@ subroutine test_char_array_explicit_dynamic(c, n) character(n), allocatable :: c(:) external foo1 ! Check that the length expr was evaluated before the execution parts. - ! CHECK: %[[len:.*]] = fir.load %arg1 : !fir.ref + ! CHECK: %[[raw_len:.*]] = fir.load %arg1 : !fir.ref + ! CHECK: %[[c0_i32:.*]] = arith.constant 0 : i32 + ! CHECK: %[[cmp:.*]] = arith.cmpi sgt, %[[raw_len]], %[[c0_i32]] : i32 + ! CHECK: %[[len:.*]] = arith.select %[[cmp]], %[[raw_len]], %[[c0_i32]] : i32 n = n + 1 ! CHECK: fir.store {{.*}} to %arg1 : !fir.ref call foo1(c(1)) diff --git a/flang/test/Lower/allocatable-runtime.f90 b/flang/test/Lower/allocatable-runtime.f90 index 982ed6e00ff7..39e972ff3d00 100644 --- a/flang/test/Lower/allocatable-runtime.f90 +++ b/flang/test/Lower/allocatable-runtime.f90 @@ -3,157 +3,163 @@ ! Test lowering of allocatables using runtime for allocate/deallcoate statements. ! CHECK-LABEL: _QPfoo subroutine foo() - real, allocatable :: x(:), y(:, :), z - ! CHECK: %[[xBoxAddr:.*]] = fir.alloca !fir.box>> {{{.*}}uniq_name = "_QFfooEx"} - ! CHECK-DAG: %[[xNullAddr:.*]] = fir.zero_bits !fir.heap> - ! CHECK-DAG: %[[xNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1> - ! CHECK: %[[xInitEmbox:.*]] = fir.embox %[[xNullAddr]](%[[xNullShape]]) : (!fir.heap>, !fir.shape<1>) -> !fir.box>> - ! CHECK: fir.store %[[xInitEmbox]] to %[[xBoxAddr]] : !fir.ref>>> - - ! CHECK: %[[yBoxAddr:.*]] = fir.alloca !fir.box>> {{{.*}}uniq_name = "_QFfooEy"} - ! CHECK-DAG: %[[yNullAddr:.*]] = fir.zero_bits !fir.heap> - ! CHECK-DAG: %[[yNullShape:.*]] = fir.shape %c0{{.*}}, %c0{{.*}} : (index, index) -> !fir.shape<2> - ! CHECK: %[[yInitEmbox:.*]] = fir.embox %[[yNullAddr]](%[[yNullShape]]) : (!fir.heap>, !fir.shape<2>) -> !fir.box>> - ! CHECK: fir.store %[[yInitEmbox]] to %[[yBoxAddr]] : !fir.ref>>> - - ! CHECK: %[[zBoxAddr:.*]] = fir.alloca !fir.box> {{{.*}}uniq_name = "_QFfooEz"} - ! CHECK: %[[zNullAddr:.*]] = fir.zero_bits !fir.heap - ! CHECK: %[[zInitEmbox:.*]] = fir.embox %[[zNullAddr]] : (!fir.heap) -> !fir.box> - ! CHECK: fir.store %[[zInitEmbox]] to %[[zBoxAddr]] : !fir.ref>> - - allocate(x(42:100), y(43:50, 51), z) - ! CHECK-DAG: %[[errMsg:.*]] = fir.absent !fir.box - ! CHECK-DAG: %[[xlb:.*]] = arith.constant 42 : i32 - ! CHECK-DAG: %[[xub:.*]] = arith.constant 100 : i32 - ! CHECK-DAG: %[[xBoxCast2:.*]] = fir.convert %[[xBoxAddr]] : (!fir.ref>>>) -> !fir.ref> - ! CHECK-DAG: %[[xlbCast:.*]] = fir.convert %[[xlb]] : (i32) -> i64 - ! CHECK-DAG: %[[xubCast:.*]] = fir.convert %[[xub]] : (i32) -> i64 - ! CHECK: fir.call @{{.*}}AllocatableSetBounds(%[[xBoxCast2]], %c0{{.*}}, %[[xlbCast]], %[[xubCast]]) : (!fir.ref>, i32, i64, i64) -> none - ! CHECK-DAG: %[[xBoxCast3:.*]] = fir.convert %[[xBoxAddr]] : (!fir.ref>>>) -> !fir.ref> - ! CHECK-DAG: %[[sourceFile:.*]] = fir.convert %{{.*}} -> !fir.ref - ! CHECK: fir.call @{{.*}}AllocatableAllocate(%[[xBoxCast3]], %false{{.*}}, %[[errMsg]], %[[sourceFile]], %{{.*}}) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 - - ! Simply check that we are emitting the right numebr of set bound for y and z. Otherwise, this is just like x. - ! CHECK: fir.convert %[[yBoxAddr]] : (!fir.ref>>>) -> !fir.ref> - ! CHECK: fir.call @{{.*}}AllocatableSetBounds - ! CHECK: fir.call @{{.*}}AllocatableSetBounds - ! CHECK: fir.call @{{.*}}AllocatableAllocate - ! CHECK: %[[zBoxCast:.*]] = fir.convert %[[zBoxAddr]] : (!fir.ref>>) -> !fir.ref> - ! CHECK-NOT: fir.call @{{.*}}AllocatableSetBounds - ! CHECK: fir.call @{{.*}}AllocatableAllocate - - ! Check that y descriptor is read when referencing it. - ! CHECK: %[[yBoxLoad:.*]] = fir.load %[[yBoxAddr]] : !fir.ref>>> - ! CHECK: %[[yBounds1:.*]]:3 = fir.box_dims %[[yBoxLoad]], %c0{{.*}} : (!fir.box>>, index) -> (index, index, index) - ! CHECK: %[[yBounds2:.*]]:3 = fir.box_dims %[[yBoxLoad]], %c1{{.*}} : (!fir.box>>, index) -> (index, index, index) - ! CHECK: %[[yAddr:.*]] = fir.box_addr %[[yBoxLoad]] : (!fir.box>>) -> !fir.heap> - print *, x, y(45, 46), z - - deallocate(x, y, z) - ! CHECK: %[[xBoxCast4:.*]] = fir.convert %[[xBoxAddr]] : (!fir.ref>>>) -> !fir.ref> - ! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[xBoxCast4]], {{.*}}) - ! CHECK: %[[yBoxCast4:.*]] = fir.convert %[[yBoxAddr]] : (!fir.ref>>>) -> !fir.ref> - ! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[yBoxCast4]], {{.*}}) - ! CHECK: %[[zBoxCast4:.*]] = fir.convert %[[zBoxAddr]] : (!fir.ref>>) -> !fir.ref> - ! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[zBoxCast4]], {{.*}}) - end subroutine - - ! test lowering of character allocatables - ! CHECK-LABEL: _QPchar_deferred( - subroutine char_deferred(n) - integer :: n - character(:), allocatable :: scalar, array(:) - ! CHECK-DAG: %[[sBoxAddr:.*]] = fir.alloca !fir.box>> {{{.*}}uniq_name = "_QFchar_deferredEscalar"} - ! CHECK-DAG: %[[sNullAddr:.*]] = fir.zero_bits !fir.heap> - ! CHECK-DAG: %[[sInitBox:.*]] = fir.embox %[[sNullAddr]] typeparams %c0{{.*}} : (!fir.heap>, index) -> !fir.box>> - ! CHECK-DAG: fir.store %[[sInitBox]] to %[[sBoxAddr]] : !fir.ref>>> - - ! CHECK-DAG: %[[aBoxAddr:.*]] = fir.alloca !fir.box>>> {{{.*}}uniq_name = "_QFchar_deferredEarray"} - ! CHECK-DAG: %[[aNullAddr:.*]] = fir.zero_bits !fir.heap>> - ! CHECK-DAG: %[[aNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1> - ! CHECK-DAG: %[[aInitBox:.*]] = fir.embox %[[aNullAddr]](%[[aNullShape]]) typeparams %c0{{.*}} : (!fir.heap>>, !fir.shape<1>, index) -> !fir.box>>> - ! CHECK-DAG: fir.store %[[aInitBox]] to %[[aBoxAddr]] : !fir.ref>>>> - - allocate(character(10):: scalar, array(30)) - ! CHECK-DAG: %[[sBoxCast1:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref>>>) -> !fir.ref> - ! CHECK-DAG: %[[ten1:.*]] = fir.convert %c10{{.*}} : (i32) -> i64 - ! CHECK: fir.call @{{.*}}AllocatableInitCharacter(%[[sBoxCast1]], %[[ten1]], %c1{{.*}}, %c0{{.*}}, %c0{{.*}}) - ! CHECK-NOT: AllocatableSetBounds - ! CHECK: %[[sBoxCast2:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref>>>) -> !fir.ref> - ! CHECK: fir.call @{{.*}}AllocatableAllocate(%[[sBoxCast2]] - - ! CHECK-DAG: %[[aBoxCast1:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref>>>>) -> !fir.ref> - ! CHECK-DAG: %[[ten2:.*]] = fir.convert %c10{{.*}} : (i32) -> i64 - ! CHECK: fir.call @{{.*}}AllocatableInitCharacter(%[[aBoxCast1]], %[[ten2]], %c1{{.*}}, %c1{{.*}}, %c0{{.*}}) - ! CHECK: %[[aBoxCast2:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref>>>>) -> !fir.ref> - ! CHECK: fir.call @{{.*}}AllocatableSetBounds(%[[aBoxCast2]] - ! CHECK: %[[aBoxCast3:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref>>>>) -> !fir.ref> - ! CHECK: fir.call @{{.*}}AllocatableAllocate(%[[aBoxCast3]] - - deallocate(scalar, array) - ! CHECK: %[[sBoxCast3:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref>>>) -> !fir.ref> - ! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[sBoxCast3]] - ! CHECK: %[[aBoxCast4:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref>>>>) -> !fir.ref> - ! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[aBoxCast4]] - - ! only testing that the correct length is set in the descriptor. - allocate(character(n):: scalar, array(40)) - ! CHECK: %[[n:.*]] = fir.load %arg0 : !fir.ref - ! CHECK-DAG: %[[ncast1:.*]] = fir.convert %[[n]] : (i32) -> i64 - ! CHECK-DAG: %[[sBoxCast4:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref>>>) -> !fir.ref> - ! CHECK: fir.call @{{.*}}AllocatableInitCharacter(%[[sBoxCast4]], %[[ncast1]], %c1{{.*}}, %c0{{.*}}, %c0{{.*}}) - ! CHECK-DAG: %[[ncast2:.*]] = fir.convert %[[n]] : (i32) -> i64 - ! CHECK-DAG: %[[aBoxCast5:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref>>>>) -> !fir.ref> - ! CHECK: fir.call @{{.*}}AllocatableInitCharacter(%[[aBoxCast5]], %[[ncast2]], %c1{{.*}}, %c1{{.*}}, %c0{{.*}}) - end subroutine - - ! CHECK-LABEL: _QPchar_explicit_cst( - subroutine char_explicit_cst(n) - integer :: n - character(10), allocatable :: scalar, array(:) - ! CHECK-DAG: %[[sBoxAddr:.*]] = fir.alloca !fir.box>> {{{.*}}uniq_name = "_QFchar_explicit_cstEscalar"} - ! CHECK-DAG: %[[sNullAddr:.*]] = fir.zero_bits !fir.heap> - ! CHECK-DAG: %[[sInitBox:.*]] = fir.embox %[[sNullAddr]] : (!fir.heap>) -> !fir.box>> - ! CHECK-DAG: fir.store %[[sInitBox]] to %[[sBoxAddr]] : !fir.ref>>> - - ! CHECK-DAG: %[[aBoxAddr:.*]] = fir.alloca !fir.box>>> {{{.*}}uniq_name = "_QFchar_explicit_cstEarray"} - ! CHECK-DAG: %[[aNullAddr:.*]] = fir.zero_bits !fir.heap>> - ! CHECK-DAG: %[[aNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1> - ! CHECK-DAG: %[[aInitBox:.*]] = fir.embox %[[aNullAddr]](%[[aNullShape]]) : (!fir.heap>>, !fir.shape<1>) -> !fir.box>>> - ! CHECK-DAG: fir.store %[[aInitBox]] to %[[aBoxAddr]] : !fir.ref>>>> - allocate(scalar, array(20)) - ! CHECK-NOT: AllocatableInitCharacter - ! CHECK: AllocatableAllocate - ! CHECK-NOT: AllocatableInitCharacter - ! CHECK: AllocatableAllocate - deallocate(scalar, array) - ! CHECK: AllocatableDeallocate - ! CHECK: AllocatableDeallocate - end subroutine - - ! CHECK-LABEL: _QPchar_explicit_dyn( - subroutine char_explicit_dyn(n, l1, l2) - integer :: n, l1, l2 - character(l1), allocatable :: scalar - ! CHECK-DAG: %[[l1:.*]] = fir.load %arg1 : !fir.ref - ! CHECK-DAG: %[[sBoxAddr:.*]] = fir.alloca !fir.box>> {{{.*}}uniq_name = "_QFchar_explicit_dynEscalar"} - ! CHECK-DAG: %[[sNullAddr:.*]] = fir.zero_bits !fir.heap> - ! CHECK-DAG: %[[sInitBox:.*]] = fir.embox %[[sNullAddr]] typeparams %[[l1]] : (!fir.heap>, i32) -> !fir.box>> - ! CHECK-DAG: fir.store %[[sInitBox]] to %[[sBoxAddr]] : !fir.ref>>> - - character(l2), allocatable :: array(:) - ! CHECK-DAG: %[[l2:.*]] = fir.load %arg2 : !fir.ref - ! CHECK-DAG: %[[aBoxAddr:.*]] = fir.alloca !fir.box>>> {{{.*}}uniq_name = "_QFchar_explicit_dynEarray"} - ! CHECK-DAG: %[[aNullAddr:.*]] = fir.zero_bits !fir.heap>> - ! CHECK-DAG: %[[aNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1> - ! CHECK-DAG: %[[aInitBox:.*]] = fir.embox %[[aNullAddr]](%[[aNullShape]]) typeparams %[[l2]] : (!fir.heap>>, !fir.shape<1>, i32) -> !fir.box>>> - ! CHECK-DAG: fir.store %[[aInitBox]] to %[[aBoxAddr]] : !fir.ref>>>> - allocate(scalar, array(20)) - ! CHECK-NOT: AllocatableInitCharacter - ! CHECK: AllocatableAllocate - ! CHECK-NOT: AllocatableInitCharacter - ! CHECK: AllocatableAllocate - deallocate(scalar, array) - ! CHECK: AllocatableDeallocate - ! CHECK: AllocatableDeallocate - end subroutine + real, allocatable :: x(:), y(:, :), z + ! CHECK: %[[xBoxAddr:.*]] = fir.alloca !fir.box>> {{{.*}}uniq_name = "_QFfooEx"} + ! CHECK-DAG: %[[xNullAddr:.*]] = fir.zero_bits !fir.heap> + ! CHECK-DAG: %[[xNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1> + ! CHECK: %[[xInitEmbox:.*]] = fir.embox %[[xNullAddr]](%[[xNullShape]]) : (!fir.heap>, !fir.shape<1>) -> !fir.box>> + ! CHECK: fir.store %[[xInitEmbox]] to %[[xBoxAddr]] : !fir.ref>>> + + ! CHECK: %[[yBoxAddr:.*]] = fir.alloca !fir.box>> {{{.*}}uniq_name = "_QFfooEy"} + ! CHECK-DAG: %[[yNullAddr:.*]] = fir.zero_bits !fir.heap> + ! CHECK-DAG: %[[yNullShape:.*]] = fir.shape %c0{{.*}}, %c0{{.*}} : (index, index) -> !fir.shape<2> + ! CHECK: %[[yInitEmbox:.*]] = fir.embox %[[yNullAddr]](%[[yNullShape]]) : (!fir.heap>, !fir.shape<2>) -> !fir.box>> + ! CHECK: fir.store %[[yInitEmbox]] to %[[yBoxAddr]] : !fir.ref>>> + + ! CHECK: %[[zBoxAddr:.*]] = fir.alloca !fir.box> {{{.*}}uniq_name = "_QFfooEz"} + ! CHECK: %[[zNullAddr:.*]] = fir.zero_bits !fir.heap + ! CHECK: %[[zInitEmbox:.*]] = fir.embox %[[zNullAddr]] : (!fir.heap) -> !fir.box> + ! CHECK: fir.store %[[zInitEmbox]] to %[[zBoxAddr]] : !fir.ref>> + + allocate(x(42:100), y(43:50, 51), z) + ! CHECK-DAG: %[[errMsg:.*]] = fir.absent !fir.box + ! CHECK-DAG: %[[xlb:.*]] = arith.constant 42 : i32 + ! CHECK-DAG: %[[xub:.*]] = arith.constant 100 : i32 + ! CHECK-DAG: %[[xBoxCast2:.*]] = fir.convert %[[xBoxAddr]] : (!fir.ref>>>) -> !fir.ref> + ! CHECK-DAG: %[[xlbCast:.*]] = fir.convert %[[xlb]] : (i32) -> i64 + ! CHECK-DAG: %[[xubCast:.*]] = fir.convert %[[xub]] : (i32) -> i64 + ! CHECK: fir.call @{{.*}}AllocatableSetBounds(%[[xBoxCast2]], %c0{{.*}}, %[[xlbCast]], %[[xubCast]]) : (!fir.ref>, i32, i64, i64) -> none + ! CHECK-DAG: %[[xBoxCast3:.*]] = fir.convert %[[xBoxAddr]] : (!fir.ref>>>) -> !fir.ref> + ! CHECK-DAG: %[[sourceFile:.*]] = fir.convert %{{.*}} -> !fir.ref + ! CHECK: fir.call @{{.*}}AllocatableAllocate(%[[xBoxCast3]], %false{{.*}}, %[[errMsg]], %[[sourceFile]], %{{.*}}) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 + + ! Simply check that we are emitting the right numebr of set bound for y and z. Otherwise, this is just like x. + ! CHECK: fir.convert %[[yBoxAddr]] : (!fir.ref>>>) -> !fir.ref> + ! CHECK: fir.call @{{.*}}AllocatableSetBounds + ! CHECK: fir.call @{{.*}}AllocatableSetBounds + ! CHECK: fir.call @{{.*}}AllocatableAllocate + ! CHECK: %[[zBoxCast:.*]] = fir.convert %[[zBoxAddr]] : (!fir.ref>>) -> !fir.ref> + ! CHECK-NOT: fir.call @{{.*}}AllocatableSetBounds + ! CHECK: fir.call @{{.*}}AllocatableAllocate + + ! Check that y descriptor is read when referencing it. + ! CHECK: %[[yBoxLoad:.*]] = fir.load %[[yBoxAddr]] : !fir.ref>>> + ! CHECK: %[[yBounds1:.*]]:3 = fir.box_dims %[[yBoxLoad]], %c0{{.*}} : (!fir.box>>, index) -> (index, index, index) + ! CHECK: %[[yBounds2:.*]]:3 = fir.box_dims %[[yBoxLoad]], %c1{{.*}} : (!fir.box>>, index) -> (index, index, index) + ! CHECK: %[[yAddr:.*]] = fir.box_addr %[[yBoxLoad]] : (!fir.box>>) -> !fir.heap> + print *, x, y(45, 46), z + + deallocate(x, y, z) + ! CHECK: %[[xBoxCast4:.*]] = fir.convert %[[xBoxAddr]] : (!fir.ref>>>) -> !fir.ref> + ! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[xBoxCast4]], {{.*}}) + ! CHECK: %[[yBoxCast4:.*]] = fir.convert %[[yBoxAddr]] : (!fir.ref>>>) -> !fir.ref> + ! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[yBoxCast4]], {{.*}}) + ! CHECK: %[[zBoxCast4:.*]] = fir.convert %[[zBoxAddr]] : (!fir.ref>>) -> !fir.ref> + ! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[zBoxCast4]], {{.*}}) +end subroutine + +! test lowering of character allocatables +! CHECK-LABEL: _QPchar_deferred( +subroutine char_deferred(n) + integer :: n + character(:), allocatable :: scalar, array(:) + ! CHECK-DAG: %[[sBoxAddr:.*]] = fir.alloca !fir.box>> {{{.*}}uniq_name = "_QFchar_deferredEscalar"} + ! CHECK-DAG: %[[sNullAddr:.*]] = fir.zero_bits !fir.heap> + ! CHECK-DAG: %[[sInitBox:.*]] = fir.embox %[[sNullAddr]] typeparams %c0{{.*}} : (!fir.heap>, index) -> !fir.box>> + ! CHECK-DAG: fir.store %[[sInitBox]] to %[[sBoxAddr]] : !fir.ref>>> + + ! CHECK-DAG: %[[aBoxAddr:.*]] = fir.alloca !fir.box>>> {{{.*}}uniq_name = "_QFchar_deferredEarray"} + ! CHECK-DAG: %[[aNullAddr:.*]] = fir.zero_bits !fir.heap>> + ! CHECK-DAG: %[[aNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1> + ! CHECK-DAG: %[[aInitBox:.*]] = fir.embox %[[aNullAddr]](%[[aNullShape]]) typeparams %c0{{.*}} : (!fir.heap>>, !fir.shape<1>, index) -> !fir.box>>> + ! CHECK-DAG: fir.store %[[aInitBox]] to %[[aBoxAddr]] : !fir.ref>>>> + + allocate(character(10):: scalar, array(30)) + ! CHECK-DAG: %[[sBoxCast1:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref>>>) -> !fir.ref> + ! CHECK-DAG: %[[ten1:.*]] = fir.convert %c10{{.*}} : (i32) -> i64 + ! CHECK: fir.call @{{.*}}AllocatableInitCharacter(%[[sBoxCast1]], %[[ten1]], %c1{{.*}}, %c0{{.*}}, %c0{{.*}}) + ! CHECK-NOT: AllocatableSetBounds + ! CHECK: %[[sBoxCast2:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref>>>) -> !fir.ref> + ! CHECK: fir.call @{{.*}}AllocatableAllocate(%[[sBoxCast2]] + + ! CHECK-DAG: %[[aBoxCast1:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref>>>>) -> !fir.ref> + ! CHECK-DAG: %[[ten2:.*]] = fir.convert %c10{{.*}} : (i32) -> i64 + ! CHECK: fir.call @{{.*}}AllocatableInitCharacter(%[[aBoxCast1]], %[[ten2]], %c1{{.*}}, %c1{{.*}}, %c0{{.*}}) + ! CHECK: %[[aBoxCast2:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref>>>>) -> !fir.ref> + ! CHECK: fir.call @{{.*}}AllocatableSetBounds(%[[aBoxCast2]] + ! CHECK: %[[aBoxCast3:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref>>>>) -> !fir.ref> + ! CHECK: fir.call @{{.*}}AllocatableAllocate(%[[aBoxCast3]] + + deallocate(scalar, array) + ! CHECK: %[[sBoxCast3:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref>>>) -> !fir.ref> + ! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[sBoxCast3]] + ! CHECK: %[[aBoxCast4:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref>>>>) -> !fir.ref> + ! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[aBoxCast4]] + + ! only testing that the correct length is set in the descriptor. + allocate(character(n):: scalar, array(40)) + ! CHECK: %[[n:.*]] = fir.load %arg0 : !fir.ref + ! CHECK-DAG: %[[ncast1:.*]] = fir.convert %[[n]] : (i32) -> i64 + ! CHECK-DAG: %[[sBoxCast4:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref>>>) -> !fir.ref> + ! CHECK: fir.call @{{.*}}AllocatableInitCharacter(%[[sBoxCast4]], %[[ncast1]], %c1{{.*}}, %c0{{.*}}, %c0{{.*}}) + ! CHECK-DAG: %[[ncast2:.*]] = fir.convert %[[n]] : (i32) -> i64 + ! CHECK-DAG: %[[aBoxCast5:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref>>>>) -> !fir.ref> + ! CHECK: fir.call @{{.*}}AllocatableInitCharacter(%[[aBoxCast5]], %[[ncast2]], %c1{{.*}}, %c1{{.*}}, %c0{{.*}}) +end subroutine + +! CHECK-LABEL: _QPchar_explicit_cst( +subroutine char_explicit_cst(n) + integer :: n + character(10), allocatable :: scalar, array(:) + ! CHECK-DAG: %[[sBoxAddr:.*]] = fir.alloca !fir.box>> {{{.*}}uniq_name = "_QFchar_explicit_cstEscalar"} + ! CHECK-DAG: %[[sNullAddr:.*]] = fir.zero_bits !fir.heap> + ! CHECK-DAG: %[[sInitBox:.*]] = fir.embox %[[sNullAddr]] : (!fir.heap>) -> !fir.box>> + ! CHECK-DAG: fir.store %[[sInitBox]] to %[[sBoxAddr]] : !fir.ref>>> + + ! CHECK-DAG: %[[aBoxAddr:.*]] = fir.alloca !fir.box>>> {{{.*}}uniq_name = "_QFchar_explicit_cstEarray"} + ! CHECK-DAG: %[[aNullAddr:.*]] = fir.zero_bits !fir.heap>> + ! CHECK-DAG: %[[aNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1> + ! CHECK-DAG: %[[aInitBox:.*]] = fir.embox %[[aNullAddr]](%[[aNullShape]]) : (!fir.heap>>, !fir.shape<1>) -> !fir.box>>> + ! CHECK-DAG: fir.store %[[aInitBox]] to %[[aBoxAddr]] : !fir.ref>>>> + allocate(scalar, array(20)) + ! CHECK-NOT: AllocatableInitCharacter + ! CHECK: AllocatableAllocate + ! CHECK-NOT: AllocatableInitCharacter + ! CHECK: AllocatableAllocate + deallocate(scalar, array) + ! CHECK: AllocatableDeallocate + ! CHECK: AllocatableDeallocate +end subroutine + +! CHECK-LABEL: _QPchar_explicit_dyn( +subroutine char_explicit_dyn(n, l1, l2) + integer :: n, l1, l2 + character(l1), allocatable :: scalar + ! CHECK: %[[sBoxAddr:.*]] = fir.alloca !fir.box>> {{{.*}}uniq_name = "_QFchar_explicit_dynEscalar"} + ! CHECK: %[[raw_l1:.*]] = fir.load %arg1 : !fir.ref + ! CHECK: %[[c0_i32:.*]] = arith.constant 0 : i32 + ! CHECK: %[[cmp1:.*]] = arith.cmpi sgt, %[[raw_l1]], %[[c0_i32]] : i32 + ! CHECK: %[[l1:.*]] = arith.select %[[cmp1]], %[[raw_l1]], %[[c0_i32]] : i32 + ! CHECK: %[[sNullAddr:.*]] = fir.zero_bits !fir.heap> + ! CHECK: %[[sInitBox:.*]] = fir.embox %[[sNullAddr]] typeparams %[[l1]] : (!fir.heap>, i32) -> !fir.box>> + ! CHECK: fir.store %[[sInitBox]] to %[[sBoxAddr]] : !fir.ref>>> + + character(l2), allocatable :: zarray(:) + ! CHECK: %[[aBoxAddr:.*]] = fir.alloca !fir.box>>> {{{.*}}uniq_name = "_QFchar_explicit_dynEzarray"} + ! CHECK: %[[raw_l2:.*]] = fir.load %arg2 : !fir.ref + ! CHECK: %[[c0_i32_2:.*]] = arith.constant 0 : i32 + ! CHECK: %[[cmp2:.*]] = arith.cmpi sgt, %[[raw_l2]], %[[c0_i32_2]] : i32 + ! CHECK: %[[l2:.*]] = arith.select %[[cmp2]], %[[raw_l2]], %[[c0_i32_2]] : i32 + ! CHECK: %[[aNullAddr:.*]] = fir.zero_bits !fir.heap>> + ! CHECK: %[[aNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1> + ! CHECK: %[[aInitBox:.*]] = fir.embox %[[aNullAddr]](%[[aNullShape]]) typeparams %[[l2]] : (!fir.heap>>, !fir.shape<1>, i32) -> !fir.box>>> + ! CHECK: fir.store %[[aInitBox]] to %[[aBoxAddr]] : !fir.ref>>>> + allocate(scalar, zarray(20)) + ! CHECK-NOT: AllocatableInitCharacter + ! CHECK: AllocatableAllocate + ! CHECK-NOT: AllocatableInitCharacter + ! CHECK: AllocatableAllocate + deallocate(scalar, zarray) + ! CHECK: AllocatableDeallocate + ! CHECK: AllocatableDeallocate +end subroutine diff --git a/flang/test/Lower/allocatables.f90 b/flang/test/Lower/allocatables.f90 index 6c266fb97bd3..d26e7fc881af 100644 --- a/flang/test/Lower/allocatables.f90 +++ b/flang/test/Lower/allocatables.f90 @@ -124,8 +124,11 @@ end subroutine subroutine char_explicit_dyn(l1, l2) integer :: l1, l2 character(l1), allocatable :: c - ! CHECK-DAG: %[[cLen:.*]] = fir.load %arg0 : !fir.ref - ! CHECK-DAG: %[[cAddrVar:.*]] = fir.alloca !fir.heap> {{{.*}}uniq_name = "_QFchar_explicit_dynEc.addr"} + ! CHECK: %[[l1:.*]] = fir.load %arg0 : !fir.ref + ! CHECK: %[[c0_i32:.*]] = arith.constant 0 : i32 + ! CHECK: %[[cmp:.*]] = arith.cmpi sgt, %[[l1]], %[[c0_i32]] : i32 + ! CHECK: %[[cLen:.*]] = arith.select %[[cmp]], %[[l1]], %[[c0_i32]] : i32 + ! CHECK: %[[cAddrVar:.*]] = fir.alloca !fir.heap> {{{.*}}uniq_name = "_QFchar_explicit_dynEc.addr"} ! CHECK-NOT: "_QFchar_explicit_dynEc.len" allocate(c) ! CHECK: %[[cLenCast1:.*]] = fir.convert %[[cLen]] : (i32) -> index diff --git a/flang/test/Lower/dummy-procedure-character.f90 b/flang/test/Lower/dummy-procedure-character.f90 new file mode 100644 index 000000000000..fbd9df2fbddc --- /dev/null +++ b/flang/test/Lower/dummy-procedure-character.f90 @@ -0,0 +1,254 @@ +! Test lowering of character function dummy procedure. The length must be +! passed along the function address. +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! ----------------------------------------------------------------------------- +! Test passing a character function as dummy procedure +! ----------------------------------------------------------------------------- + +! CHECK-LABEL: func @_QPcst_len +subroutine cst_len() + interface + character(7) function bar1() + end function + end interface + call foo1(bar1) + ! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QPbar1) : (!fir.ref>, index) -> !fir.boxchar<1> + ! CHECK: %[[VAL_1:.*]] = arith.constant 7 : i64 + ! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref>, index) -> !fir.boxchar<1>) -> !fir.boxproc<() -> ()> + ! CHECK: %[[VAL_3:.*]] = fir.undefined tuple ()>, i64> + ! CHECK: %[[VAL_4:.*]] = fir.insert_value %[[VAL_3]], %[[VAL_2]], [0 : index] : (tuple ()>, i64>, !fir.boxproc<() -> ()>) -> tuple ()>, i64> + ! CHECK: %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_1]], [1 : index] : (tuple ()>, i64>, i64) -> tuple ()>, i64> + ! CHECK: fir.call @_QPfoo1(%[[VAL_5]]) : (tuple ()>, i64>) -> () + end subroutine + + ! CHECK-LABEL: func @_QPcst_len_array + subroutine cst_len_array() + interface + function bar1_array() + character(7) :: bar1_array(10) + end function + end interface + ! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QPbar1_array) : () -> !fir.array<10x!fir.char<1,7>> + ! CHECK: %[[VAL_1:.*]] = arith.constant 7 : i64 + ! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_0]] : (() -> !fir.array<10x!fir.char<1,7>>) -> !fir.boxproc<() -> ()> + ! CHECK: %[[VAL_3:.*]] = fir.undefined tuple ()>, i64> + ! CHECK: %[[VAL_4:.*]] = fir.insert_value %[[VAL_3]], %[[VAL_2]], [0 : index] : (tuple ()>, i64>, !fir.boxproc<() -> ()>) -> tuple ()>, i64> + ! CHECK: %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_1]], [1 : index] : (tuple ()>, i64>, i64) -> tuple ()>, i64> + ! CHECK: fir.call @_QPfoo1b(%[[VAL_5]]) : (tuple ()>, i64>) -> () + call foo1b(bar1_array) + end subroutine + + ! CHECK-LABEL: func @_QPcst_len_2 + subroutine cst_len_2() + character(7) :: bar2 + external :: bar2 + ! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QPbar2) : (!fir.ref>, index) -> !fir.boxchar<1> + ! CHECK: %[[VAL_1:.*]] = arith.constant 7 : i64 + ! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref>, index) -> !fir.boxchar<1>) -> !fir.boxproc<() -> ()> + ! CHECK: %[[VAL_3:.*]] = fir.undefined tuple ()>, i64> + ! CHECK: %[[VAL_4:.*]] = fir.insert_value %[[VAL_3]], %[[VAL_2]], [0 : index] : (tuple ()>, i64>, !fir.boxproc<() -> ()>) -> tuple ()>, i64> + ! CHECK: %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_1]], [1 : index] : (tuple ()>, i64>, i64) -> tuple ()>, i64> + ! CHECK: fir.call @_QPfoo2(%[[VAL_5]]) : (tuple ()>, i64>) -> () + call foo2(bar2) + end subroutine + + ! CHECK-LABEL: func @_QPdyn_len( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref{{.*}}) { + subroutine dyn_len(n) + integer :: n + character(n) :: bar3 + external :: bar3 + ! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QPbar3) : (!fir.ref>, index) -> !fir.boxchar<1> + ! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_0]] : !fir.ref + ! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (i32) -> i64 + ! CHECK: %[[VAL_4:.*]] = arith.constant 0 : i64 + ! CHECK: %[[VAL_5:.*]] = arith.cmpi sgt, %[[VAL_3]], %[[VAL_4]] : i64 + ! CHECK: %[[VAL_6:.*]] = arith.select %[[VAL_5]], %[[VAL_3]], %[[VAL_4]] : i64 + ! CHECK: %[[VAL_7:.*]] = fir.emboxproc %[[VAL_1]] : ((!fir.ref>, index) -> !fir.boxchar<1>) -> !fir.boxproc<() -> ()> + ! CHECK: %[[VAL_8:.*]] = fir.undefined tuple ()>, i64> + ! CHECK: %[[VAL_9:.*]] = fir.insert_value %[[VAL_8]], %[[VAL_7]], [0 : index] : (tuple ()>, i64>, !fir.boxproc<() -> ()>) -> tuple ()>, i64> + ! CHECK: %[[VAL_10:.*]] = fir.insert_value %[[VAL_9]], %[[VAL_6]], [1 : index] : (tuple ()>, i64>, i64) -> tuple ()>, i64> + ! CHECK: fir.call @_QPfoo3(%[[VAL_10]]) : (tuple ()>, i64>) -> () + call foo3(bar3) + end subroutine + + ! CHECK-LABEL: func @_QPcannot_compute_len_yet + subroutine cannot_compute_len_yet() + interface + function bar4(n) + integer :: n + character(n) :: bar4 + end function + end interface + ! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QPbar4) : (!fir.ref>, index, !fir.ref) -> !fir.boxchar<1> + ! CHECK: %[[VAL_1:.*]] = arith.constant -1 : index + ! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref>, index, !fir.ref) -> !fir.boxchar<1>) -> !fir.boxproc<() -> ()> + ! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_1]] : (index) -> i64 + ! CHECK: %[[VAL_4:.*]] = fir.undefined tuple ()>, i64> + ! CHECK: %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_2]], [0 : index] : (tuple ()>, i64>, !fir.boxproc<() -> ()>) -> tuple ()>, i64> + ! CHECK: %[[VAL_6:.*]] = fir.insert_value %[[VAL_5]], %[[VAL_3]], [1 : index] : (tuple ()>, i64>, i64) -> tuple ()>, i64> + ! CHECK: fir.call @_QPfoo4(%[[VAL_6]]) : (tuple ()>, i64>) -> () + call foo4(bar4) + end subroutine + + ! CHECK-LABEL: func @_QPcannot_compute_len_yet_2 + subroutine cannot_compute_len_yet_2() + character(*) :: bar5 + external :: bar5 + ! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QPbar5) : (!fir.ref>, index) -> !fir.boxchar<1> + ! CHECK: %[[VAL_1:.*]] = arith.constant -1 : index + ! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref>, index) -> !fir.boxchar<1>) -> !fir.boxproc<() -> ()> + ! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_1]] : (index) -> i64 + ! CHECK: %[[VAL_4:.*]] = fir.undefined tuple ()>, i64> + ! CHECK: %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_2]], [0 : index] : (tuple ()>, i64>, !fir.boxproc<() -> ()>) -> tuple ()>, i64> + ! CHECK: %[[VAL_6:.*]] = fir.insert_value %[[VAL_5]], %[[VAL_3]], [1 : index] : (tuple ()>, i64>, i64) -> tuple ()>, i64> + ! CHECK: fir.call @_QPfoo5(%[[VAL_6]]) : (tuple ()>, i64>) -> () + call foo5(bar5) + end subroutine + + ! CHECK-LABEL: func @_QPforward_incoming_length + ! CHECK-SAME: %[[VAL_0:.*]]: tuple ()>, i64> {fir.char_proc}) { + subroutine forward_incoming_length(bar6) + character(*) :: bar6 + external :: bar6 + ! CHECK: %[[VAL_1:.*]] = fir.extract_value %[[VAL_0]], [0 : index] : (tuple ()>, i64>) -> !fir.boxproc<() -> ()> + ! CHECK: %[[WAL_2:.*]] = fir.box_addr %[[VAL_1]] : (!fir.boxproc<() -> ()>) -> (() -> ()) + ! CHECK: %[[VAL_2:.*]] = fir.extract_value %[[VAL_0]], [1 : index] : (tuple ()>, i64>) -> i64 + ! CHECK: %[[WAL_1:.*]] = fir.emboxproc %[[WAL_2]] : (() -> ()) -> !fir.boxproc<() -> ()> + ! CHECK: %[[VAL_3:.*]] = fir.undefined tuple ()>, i64> + ! CHECK: %[[VAL_4:.*]] = fir.insert_value %[[VAL_3]], %[[WAL_1]], [0 : index] : (tuple ()>, i64>, !fir.boxproc<() -> ()>) -> tuple ()>, i64> + ! CHECK: %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_2]], [1 : index] : (tuple ()>, i64>, i64) -> tuple ()>, i64> + ! CHECK: fir.call @_QPfoo6(%[[VAL_5]]) : (tuple ()>, i64>) -> () + call foo6(bar6) + end subroutine + + ! CHECK-LABEL: func @_QPoverride_incoming_length + ! CHECK-SAME: %[[VAL_0:.*]]: tuple ()>, i64> {fir.char_proc}) { + subroutine override_incoming_length(bar7) + character(7) :: bar7 + external :: bar7 + ! CHECK: %[[VAL_1:.*]] = fir.extract_value %[[VAL_0]], [0 : index] : (tuple ()>, i64>) -> !fir.boxproc<() -> ()> + ! CHECK: %[[WAL_2:.*]] = fir.box_addr %[[VAL_1]] : (!fir.boxproc<() -> ()>) -> (() -> ()) + ! CHECK: %[[VAL_2:.*]] = arith.constant 7 : i64 + ! CHECK: %[[WAL_1:.*]] = fir.emboxproc %[[WAL_2]] : (() -> ()) -> !fir.boxproc<() -> ()> + ! CHECK: %[[VAL_3:.*]] = fir.undefined tuple ()>, i64> + ! CHECK: %[[VAL_4:.*]] = fir.insert_value %[[VAL_3]], %[[WAL_1]], [0 : index] : (tuple ()>, i64>, !fir.boxproc<() -> ()>) -> tuple ()>, i64> + ! CHECK: %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_2]], [1 : index] : (tuple ()>, i64>, i64) -> tuple ()>, i64> + ! CHECK: fir.call @_QPfoo7(%[[VAL_5]]) : (tuple ()>, i64>) -> () + call foo7(bar7) + end subroutine + + ! ----------------------------------------------------------------------------- + ! Test calling character dummy function + ! ----------------------------------------------------------------------------- + + ! CHECK-LABEL: func @_QPcall_assumed_length + ! CHECK-SAME: %[[VAL_0:.*]]: tuple ()>, i64> {fir.char_proc}) { + subroutine call_assumed_length(bar8) + character(*) :: bar8 + external :: bar8 + ! CHECK: %[[VAL_3:.*]] = fir.extract_value %[[VAL_0]], [0 : index] : (tuple ()>, i64>) -> !fir.boxproc<() -> ()> + ! CHECK: %[[WAL_2:.*]] = fir.box_addr %[[VAL_3]] : (!fir.boxproc<() -> ()>) -> (() -> ()) + ! CHECK: %[[VAL_4:.*]] = fir.extract_value %[[VAL_0]], [1 : index] : (tuple ()>, i64>) -> i64 + ! CHECK: %[[VAL_6:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_4]] : i64) {bindc_name = ".result"} + ! CHECK: %[[VAL_7:.*]] = fir.convert %[[WAL_2]] : (() -> ()) -> ((!fir.ref>, index, !fir.ref) -> !fir.boxchar<1>) + ! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_4]] : (i64) -> index + ! CHECK: fir.call %[[VAL_7]](%[[VAL_6]], %[[VAL_8]], %{{.*}}) : (!fir.ref>, index, !fir.ref) -> !fir.boxchar<1> + call test(bar8(42)) + end subroutine + + ! CHECK-LABEL: func @_QPcall_explicit_length + ! CHECK-SAME: %[[VAL_0:.*]]: tuple ()>, i64> {fir.char_proc}) { + subroutine call_explicit_length(bar9) + character(7) :: bar9 + external :: bar9 + ! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.char<1,7> {bindc_name = ".result"} + ! CHECK: %[[VAL_4:.*]] = fir.extract_value %[[VAL_0]], [0 : index] : (tuple ()>, i64>) -> !fir.boxproc<() -> ()> + ! CHECK: %[[WAL_1:.*]] = fir.box_addr %[[VAL_4]] : (!fir.boxproc<() -> ()>) -> (() -> ()) + ! CHECK: %[[VAL_5:.*]] = arith.constant 7 : i64 + ! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i64) -> index + ! CHECK: %[[VAL_8:.*]] = fir.convert %[[WAL_1]] : (() -> ()) -> ((!fir.ref>, index, !fir.ref) -> !fir.boxchar<1>) + ! CHECK: fir.call %[[VAL_8]](%[[VAL_1]], %[[VAL_6]], %{{.*}}) : (!fir.ref>, index, !fir.ref) -> !fir.boxchar<1> + call test(bar9(42)) + end subroutine + + ! CHECK-LABEL: func @_QPcall_explicit_length_with_iface + ! CHECK-SAME: %[[VAL_0:.*]]: tuple ()>, i64> {fir.char_proc}) { + subroutine call_explicit_length_with_iface(bar10) + interface + function bar10(n) + integer(8) :: n + character(n) :: bar10 + end function + end interface + ! CHECK: %[[VAL_1:.*]] = fir.alloca i64 + ! CHECK: %[[VAL_2:.*]] = arith.constant 42 : i64 + ! CHECK: fir.store %[[VAL_2]] to %[[VAL_1]] : !fir.ref + ! CHECK: %[[VAL_3:.*]] = fir.extract_value %[[VAL_0]], [0 : index] : (tuple ()>, i64>) -> !fir.boxproc<() -> ()> + ! CHECK: %[[WAL_1:.*]] = fir.box_addr %[[VAL_3]] : (!fir.boxproc<() -> ()>) -> (() -> ()) + ! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_1]] : !fir.ref + ! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (i64) -> index + ! CHECK: %[[VAL_6:.*]] = fir.call @llvm.stacksave() : () -> !fir.ref + ! CHECK: %[[VAL_7:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_5]] : index) {bindc_name = ".result"} + ! CHECK: %[[VAL_8:.*]] = fir.convert %[[WAL_1]] : (() -> ()) -> ((!fir.ref>, index, !fir.ref) -> !fir.boxchar<1>) + ! CHECK: fir.call %[[VAL_8]](%[[VAL_7]], %[[VAL_5]], %[[VAL_1]]) : (!fir.ref>, index, !fir.ref) -> !fir.boxchar<1> + call test(bar10(42_8)) + end subroutine + + + ! CHECK-LABEL: func @_QPhost( + ! CHECK-SAME: %[[VAL_0:.*]]: tuple ()>, i64> + subroutine host(f) + character*(*) :: f + external :: f + ! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_1:.*]], %{{.*}} : (!fir.ref ()>, i64>>>, i32) -> !fir.ref ()>, i64>> + ! CHECK: fir.store %[[VAL_0]] to %[[VAL_3]] : !fir.ref ()>, i64>> + ! CHECK: fir.call @_QFhostPintern(%[[VAL_1]]) + call intern() + contains + ! CHECK-LABEL: func @_QFhostPintern( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref ()>, i64>>> {fir.host_assoc}) + subroutine intern() + ! CHECK: %[[VAL_1:.*]] = arith.constant 0 : i32 + ! CHECK: %[[VAL_2:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_1]] : (!fir.ref ()>, i64>>>, i32) -> !fir.ref ()>, i64>> + ! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_2]] : !fir.ref ()>, i64>> + ! CHECK: %[[VAL_4:.*]] = fir.extract_value %[[VAL_3]], [0 : index] : (tuple ()>, i64>) -> !fir.boxproc<() -> ()> + ! CHECK: %[[WAL_1:.*]] = fir.box_addr %[[VAL_4]] : (!fir.boxproc<() -> ()>) -> (() -> ()) + ! CHECK: %[[VAL_5:.*]] = fir.extract_value %[[VAL_3]], [1 : index] : (tuple ()>, i64>) -> i64 + ! CHECK: %[[VAL_7:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_5]] : i64) {bindc_name = ".result"} + ! CHECK: %[[VAL_8:.*]] = fir.convert %[[WAL_1]] : (() -> ()) -> ((!fir.ref>, index) -> !fir.boxchar<1>) + ! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_5]] : (i64) -> index + ! CHECK: fir.call %[[VAL_8]](%[[VAL_7]], %[[VAL_9]]) : (!fir.ref>, index) -> !fir.boxchar<1> + call test(f()) + end subroutine + end subroutine + + ! CHECK-LABEL: func @_QPhost2( + ! CHECK-SAME: %[[VAL_0:.*]]: tuple ()>, i64> {fir.char_proc}) + subroutine host2(f) + ! Test that dummy length is overridden by local length even when used + ! in the internal procedure. + character*(42) :: f + external :: f + ! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_1:.*]], %{{.*}} : (!fir.ref ()>, i64>>>, i32) -> !fir.ref ()>, i64>> + ! CHECK: fir.store %[[VAL_0]] to %[[VAL_3]] : !fir.ref ()>, i64>> + ! CHECK: fir.call @_QFhost2Pintern(%[[VAL_1]]) + call intern() + contains + ! CHECK-LABEL: func @_QFhost2Pintern( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref ()>, i64>>> {fir.host_assoc}) + subroutine intern() + ! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.char<1,42> {bindc_name = ".result"} + ! CHECK: %[[VAL_2:.*]] = arith.constant 0 : i32 + ! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_2]] : (!fir.ref ()>, i64>>>, i32) -> !fir.ref ()>, i64>> + ! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_3]] : !fir.ref ()>, i64>> + ! CHECK: %[[VAL_5:.*]] = fir.extract_value %[[VAL_4]], [0 : index] : (tuple ()>, i64>) -> !fir.boxproc<() -> ()> + ! CHECK: %[[WAL_1:.*]] = fir.box_addr %[[VAL_5]] : (!fir.boxproc<() -> ()>) -> (() -> ()) + ! CHECK: %[[VAL_6:.*]] = arith.constant 42 : i64 + ! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (i64) -> index + ! CHECK: %[[VAL_9:.*]] = fir.convert %[[WAL_1]] : (() -> ()) -> ((!fir.ref>, index) -> !fir.boxchar<1>) + ! CHECK: fir.call %[[VAL_9]](%[[VAL_1]], %[[VAL_7]]) : (!fir.ref>, index) -> !fir.boxchar<1> + call test(f()) + end subroutine + end subroutine diff --git a/flang/test/Lower/dummy-procedure.f90 b/flang/test/Lower/dummy-procedure.f90 new file mode 100644 index 000000000000..11efa9061630 --- /dev/null +++ b/flang/test/Lower/dummy-procedure.f90 @@ -0,0 +1,175 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! Test dummy procedures + +! Test of dummy procedure call +! CHECK-LABEL: func @_QPfoo( +! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}}) -> f32 +real function foo(bar) +real :: bar, x +! CHECK: %[[x:.*]] = fir.alloca f32 {{{.*}}uniq_name = "{{.*}}Ex"} +x = 42. +! CHECK: %[[funccast:.*]] = fir.box_addr %arg0 : (!fir.boxproc<() -> ()>) -> ((!fir.ref) -> f32) +! CHECK: fir.call %[[funccast]](%[[x]]) : (!fir.ref) -> f32 +foo = bar(x) +end function + +! Test case where dummy procedure is only transiting. +! CHECK-LABEL: func @_QPprefoo( +! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}}) -> f32 +real function prefoo(bar) +external :: bar +! CHECK: fir.call @_QPfoo(%arg0) : (!fir.boxproc<() -> ()>) -> f32 +prefoo = foo(bar) +end function + +! Function that will be passed as dummy argument +! CHECK-LABEL: func @_QPfunc( +! CHECK-SAME: %{{.*}}: !fir.ref{{.*}}) -> f32 +real function func(x) +real :: x +func = x + 0.5 +end function + +! Test passing functions as dummy procedure arguments +! CHECK-LABEL: func @_QPtest_func +real function test_func() +real :: func, prefoo +external :: func +!CHECK: %[[f:.*]] = fir.address_of(@_QPfunc) : (!fir.ref) -> f32 +!CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref) -> f32) -> !fir.boxproc<() -> ()> +!CHECK: fir.call @_QPprefoo(%[[fcast]]) : (!fir.boxproc<() -> ()>) -> f32 +test_func = prefoo(func) +end function + +! Repeat test with dummy subroutine + +! CHECK-LABEL: func @_QPfoo_sub( +! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}}) +subroutine foo_sub(bar_sub) +! CHECK: %[[x:.*]] = fir.alloca f32 {{{.*}}uniq_name = "{{.*}}Ex"} +x = 42. +! CHECK: %[[funccast:.*]] = fir.box_addr %arg0 : (!fir.boxproc<() -> ()>) -> ((!fir.ref) -> ()) +! CHECK: fir.call %[[funccast]](%[[x]]) : (!fir.ref) +call bar_sub(x) +end subroutine + +! Test case where dummy procedure is only transiting. +! CHECK-LABEL: func @_QPprefoo_sub( +! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}}) +subroutine prefoo_sub(bar_sub) +external :: bar_sub +! CHECK: fir.call @_QPfoo_sub(%arg0) : (!fir.boxproc<() -> ()>) -> () +call foo_sub(bar_sub) +end subroutine + +! Subroutine that will be passed as dummy argument +! CHECK-LABEL: func @_QPsub( +! CHECK-SAME: %{{.*}}: !fir.ref{{.*}}) +subroutine sub(x) +real :: x +print *, x +end subroutine + +! Test passing functions as dummy procedure arguments +! CHECK-LABEL: func @_QPtest_sub +subroutine test_sub() +external :: sub +!CHECK: %[[f:.*]] = fir.address_of(@_QPsub) : (!fir.ref) -> () +!CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref) -> ()) -> !fir.boxproc<() -> ()> +!CHECK: fir.call @_QPprefoo_sub(%[[fcast]]) : (!fir.boxproc<() -> ()>) -> () +call prefoo_sub(sub) +end subroutine + +! CHECK-LABEL: func @_QPpassing_not_defined_in_file() +subroutine passing_not_defined_in_file() +external proc_not_defined_in_file +! CHECK: %[[addr:.*]] = fir.address_of(@_QPproc_not_defined_in_file) : () -> () +! CHECK: %[[ep:.*]] = fir.emboxproc %[[addr]] +! CHECK: fir.call @_QPprefoo_sub(%[[ep]]) : (!fir.boxproc<() -> ()>) -> () +call prefoo_sub(proc_not_defined_in_file) +end subroutine + +! Test passing unrestricted intrinsics + +! Intrinsic using runtime +! CHECK-LABEL: func @_QPtest_acos +subroutine test_acos(x) +intrinsic :: acos +!CHECK: %[[f:.*]] = fir.address_of(@fir.acos.f32.ref_f32) : (!fir.ref) -> f32 +!CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref) -> f32) -> !fir.boxproc<() -> ()> +!CHECK: fir.call @_QPfoo_acos(%[[fcast]]) : (!fir.boxproc<() -> ()>) -> () +call foo_acos(acos) +end subroutine + +! CHECK-LABEL: func @_QPtest_atan2 +subroutine test_atan2() +intrinsic :: atan2 +! CHECK: %[[f:.*]] = fir.address_of(@fir.atan2.f32.ref_f32.ref_f32) : (!fir.ref, !fir.ref) -> f32 +! CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref, !fir.ref) -> f32) -> !fir.boxproc<() -> ()> +! CHECK: fir.call @_QPfoo_atan2(%[[fcast]]) : (!fir.boxproc<() -> ()>) -> () +call foo_atan2(atan2) +end subroutine + +! Intrinsic implemented inlined +! CHECK-LABEL: func @_QPtest_aimag +subroutine test_aimag() +intrinsic :: aimag +!CHECK: %[[f:.*]] = fir.address_of(@fir.aimag.f32.ref_z4) : (!fir.ref>) -> f32 +!CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref>) -> f32) -> !fir.boxproc<() -> ()> +!CHECK: fir.call @_QPfoo_aimag(%[[fcast]]) : (!fir.boxproc<() -> ()>) -> () +call foo_aimag(aimag) +end subroutine + +! Character Intrinsic implemented inlined +! CHECK-LABEL: func @_QPtest_len +subroutine test_len() +intrinsic :: len +! CHECK: %[[f:.*]] = fir.address_of(@fir.len.i32.bc1) : (!fir.boxchar<1>) -> i32 +! CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.boxchar<1>) -> i32) -> !fir.boxproc<() -> ()> +!CHECK: fir.call @_QPfoo_len(%[[fcast]]) : (!fir.boxproc<() -> ()>) -> () +call foo_len(len) +end subroutine + +! Intrinsic implemented inlined with specific name different from generic +! CHECK-LABEL: func @_QPtest_iabs +subroutine test_iabs() +intrinsic :: iabs +! CHECK: %[[f:.*]] = fir.address_of(@fir.abs.i32.ref_i32) : (!fir.ref) -> i32 +! CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref) -> i32) -> !fir.boxproc<() -> ()> +! CHECK: fir.call @_QPfoo_iabs(%[[fcast]]) : (!fir.boxproc<() -> ()>) -> () +call foo_iabs(iabs) +end subroutine + +! TODO: exhaustive test of unrestricted intrinsic table 16.2 + +! TODO: improve dummy procedure types when interface is given. +! CHECK: func @_QPtodo3( +! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}}) +! SHOULD-CHECK: func @_QPtodo3(%arg0: (!fir.ref) -> f32) +subroutine todo3(dummy_proc) +intrinsic :: acos +procedure(acos) :: dummy_proc +end subroutine + +! CHECK-LABEL: func private @fir.acos.f32.ref_f32(%arg0: !fir.ref) -> f32 +!CHECK: %[[load:.*]] = fir.load %arg0 +!CHECK: %[[res:.*]] = fir.call @__fs_acos_1(%[[load]]) : (f32) -> f32 +!CHECK: return %[[res]] : f32 + +! CHECK-LABEL: func private @fir.atan2.f32.ref_f32.ref_f32( +! CHECK-SAME: %[[x:.*]]: !fir.ref, %[[y:.*]]: !fir.ref) -> f32 +! CHECK-DAG: %[[xload:.*]] = fir.load %[[x]] : !fir.ref +! CHECK-DAG: %[[yload:.*]] = fir.load %[[y]] : !fir.ref +! CHECK: %[[atan2:.*]] = fir.call @__fs_atan2_1(%[[xload]], %[[yload]]) : (f32, f32) -> f32 +! CHECK: return %[[atan2]] : f32 + +!CHECK-LABEL: func private @fir.aimag.f32.ref_z4(%arg0: !fir.ref>) +!CHECK: %[[load:.*]] = fir.load %arg0 +!CHECK: %[[imag:.*]] = fir.extract_value %[[load]], [1 : index] : (!fir.complex<4>) -> f32 +!CHECK: return %[[imag]] : f32 + +!CHECK-LABEL: func private @fir.len.i32.bc1(%arg0: !fir.boxchar<1>) +!CHECK: %[[unboxed:.*]]:2 = fir.unboxchar %arg0 : (!fir.boxchar<1>) -> (!fir.ref>, index) +!CHECK: %[[len:.*]] = fir.convert %[[unboxed]]#1 : (index) -> i32 +!CHECK: return %[[len]] : i32 diff --git a/flang/test/Lower/host-associated.f90 b/flang/test/Lower/host-associated.f90 index 17aeba1f5fca..ea8c21dcfa6d 100644 --- a/flang/test/Lower/host-associated.f90 +++ b/flang/test/Lower/host-associated.f90 @@ -1,5 +1,5 @@ ! Test internal procedure host association lowering. -! RUN: bbc %s -o - -emit-fir | FileCheck %s +! RUN: bbc %s -o - | FileCheck %s ! ----------------------------------------------------------------------------- ! Test non character intrinsic scalars @@ -104,3 +104,560 @@ contains c = "Hi there" end subroutine test6_inner end subroutine test6 + +! ----------------------------------------------------------------------------- +! Test non allocatable and pointer arrays +! ----------------------------------------------------------------------------- + +! CHECK-LABEL: func @_QPtest3( +! CHECK-SAME: %[[p:[^:]+]]: !fir.box>{{.*}}, %[[q:.*]]: !fir.box>{{.*}}, %[[i:.*]]: !fir.ref +subroutine test3(p,q,i) + integer(8) :: i + real :: p(i:) + real :: q(:) + ! CHECK: %[[iload:.*]] = fir.load %[[i]] : !fir.ref + ! CHECK: %[[icast:.*]] = fir.convert %[[iload]] : (i64) -> index + ! CHECK: %[[tup:.*]] = fir.alloca tuple>, !fir.box>> + ! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref>, !fir.box>>>, i32) -> !fir.ref>> + ! CHECK: %[[pshift:.*]] = fir.shift %[[icast]] : (index) -> !fir.shift<1> + ! CHECK: %[[pbox:.*]] = fir.rebox %[[p]](%[[pshift]]) : (!fir.box>, !fir.shift<1>) -> !fir.box> + ! CHECK: fir.store %[[pbox]] to %[[ptup]] : !fir.ref>> + ! CHECK: %[[qtup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref>, !fir.box>>>, i32) -> !fir.ref>> + ! CHECK: %[[qbox:.*]] = fir.rebox %[[q]] : (!fir.box>) -> !fir.box> + ! CHECK: fir.store %[[qbox]] to %[[qtup]] : !fir.ref>> + + i = i + 1 + q = -42.0 + + ! CHECK: fir.call @_QFtest3Ptest3_inner(%[[tup]]) : (!fir.ref>, !fir.box>>>) -> () + call test3_inner + + if (p(2) .ne. -42.0) then + print *, "failed" + end if + +contains + ! CHECK-LABEL: func @_QFtest3Ptest3_inner( + ! CHECK-SAME: %[[tup:.*]]: !fir.ref>, !fir.box>>> {fir.host_assoc}) { + subroutine test3_inner + ! CHECK: %[[pcoor:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref>, !fir.box>>>, i32) -> !fir.ref>> + ! CHECK: %[[p:.*]] = fir.load %[[pcoor]] : !fir.ref>> + ! CHECK: %[[pbounds:.]]:3 = fir.box_dims %[[p]], %c0{{.*}} : (!fir.box>, index) -> (index, index, index) + ! CHECK: %[[qcoor:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref>, !fir.box>>>, i32) -> !fir.ref>> + ! CHECK: %[[q:.*]] = fir.load %[[qcoor]] : !fir.ref>> + ! CHECK: %[[qbounds:.]]:3 = fir.box_dims %[[q]], %c0{{.*}} : (!fir.box>, index) -> (index, index, index) + + + ! CHECK: %[[qlb:.*]] = fir.convert %[[qbounds]]#0 : (index) -> i64 + ! CHECK: %[[qoffset:.*]] = arith.subi %c1{{.*}}, %[[qlb]] : i64 + ! CHECK: %[[qelt:.*]] = fir.coordinate_of %[[q]], %[[qoffset]] : (!fir.box>, i64) -> !fir.ref + ! CHECK: %[[qload:.*]] = fir.load %[[qelt]] : !fir.ref + ! CHECK: %[[plb:.*]] = fir.convert %[[pbounds]]#0 : (index) -> i64 + ! CHECK: %[[poffset:.*]] = arith.subi %c2{{.*}}, %[[plb]] : i64 + ! CHECK: %[[pelt:.*]] = fir.coordinate_of %[[p]], %[[poffset]] : (!fir.box>, i64) -> !fir.ref + ! CHECK: fir.store %[[qload]] to %[[pelt]] : !fir.ref + p(2) = q(1) + end subroutine test3_inner +end subroutine test3 + +! CHECK-LABEL: func @_QPtest3a( +! CHECK-SAME: %[[p:.*]]: !fir.ref>{{.*}}) { +subroutine test3a(p) + real :: p(10) + real :: q(10) + ! CHECK: %[[q:.*]] = fir.alloca !fir.array<10xf32> {bindc_name = "q", uniq_name = "_QFtest3aEq"} + ! CHECK: %[[tup:.*]] = fir.alloca tuple>, !fir.box>> + ! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref>, !fir.box>>>, i32) -> !fir.ref>> + ! CHECK: %[[shape:.*]] = fir.shape %c10{{.*}} : (index) -> !fir.shape<1> + ! CHECK: %[[pbox:.*]] = fir.embox %[[p]](%[[shape]]) : (!fir.ref>, !fir.shape<1>) -> !fir.box> + ! CHECK: fir.store %[[pbox]] to %[[ptup]] : !fir.ref>> + ! CHECK: %[[qtup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref>, !fir.box>>>, i32) -> !fir.ref>> + ! CHECK: %[[qbox:.*]] = fir.embox %[[q]](%[[shape]]) : (!fir.ref>, !fir.shape<1>) -> !fir.box> + ! CHECK: fir.store %[[qbox]] to %[[qtup]] : !fir.ref>> + + q = -42.0 + ! CHECK: fir.call @_QFtest3aPtest3a_inner(%[[tup]]) : (!fir.ref>, !fir.box>>>) -> () + call test3a_inner + + if (p(1) .ne. -42.0) then + print *, "failed" + end if + +contains + ! CHECK: func @_QFtest3aPtest3a_inner( + ! CHECK-SAME: %[[tup:.*]]: !fir.ref>, !fir.box>>> {fir.host_assoc}) { + subroutine test3a_inner + ! CHECK: %[[pcoor:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref>, !fir.box>>>, i32) -> !fir.ref>> + ! CHECK: %[[p:.*]] = fir.load %[[pcoor]] : !fir.ref>> + ! CHECK: %[[paddr:.*]] = fir.box_addr %[[p]] : (!fir.box>) -> !fir.ref> + ! CHECK: %[[qcoor:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref>, !fir.box>>>, i32) -> !fir.ref>> + ! CHECK: %[[q:.*]] = fir.load %[[qcoor]] : !fir.ref>> + ! CHECK: %[[qaddr:.*]] = fir.box_addr %[[q]] : (!fir.box>) -> !fir.ref> + + ! CHECK: %[[qelt:.*]] = fir.coordinate_of %[[qaddr]], %c0{{.*}} : (!fir.ref>, i64) -> !fir.ref + ! CHECK: %[[qload:.*]] = fir.load %[[qelt]] : !fir.ref + ! CHECK: %[[pelt:.*]] = fir.coordinate_of %[[paddr]], %c0{{.*}} : (!fir.ref>, i64) -> !fir.ref + ! CHECK: fir.store %[[qload]] to %[[pelt]] : !fir.ref + p(1) = q(1) + end subroutine test3a_inner +end subroutine test3a + +! ----------------------------------------------------------------------------- +! Test allocatable and pointer scalars +! ----------------------------------------------------------------------------- + +! CHECK-LABEL: func @_QPtest4() { +subroutine test4 + real, pointer :: p + real, allocatable, target :: ally + ! CHECK: %[[ally:.*]] = fir.alloca !fir.box> {bindc_name = "ally", fir.target, uniq_name = "_QFtest4Eally"} + ! CHECK: %[[p:.*]] = fir.alloca !fir.box> {bindc_name = "p", uniq_name = "_QFtest4Ep"} + ! CHECK: %[[tup:.*]] = fir.alloca tuple>>, !fir.ref>>> + ! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref>>, !fir.ref>>>>, i32) -> !fir.llvm_ptr>>> + ! CHECK: fir.store %[[p]] to %[[ptup]] : !fir.llvm_ptr>>> + ! CHECK: %[[atup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref>>, !fir.ref>>>>, i32) -> !fir.llvm_ptr>>> + ! CHECK: fir.store %[[ally]] to %[[atup]] : !fir.llvm_ptr>>> + ! CHECK: fir.call @_QFtest4Ptest4_inner(%[[tup]]) : (!fir.ref>>, !fir.ref>>>>) -> () + + allocate(ally) + ally = -42.0 + call test4_inner + + if (p .ne. -42.0) then + print *, "failed" + end if + +contains + ! CHECK-LABEL: func @_QFtest4Ptest4_inner( + ! CHECK-SAME:%[[tup:.*]]: !fir.ref>>, !fir.ref>>>> {fir.host_assoc}) { + subroutine test4_inner + ! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref>>, !fir.ref>>>>, i32) -> !fir.llvm_ptr>>> + ! CHECK: %[[p:.*]] = fir.load %[[ptup]] : !fir.llvm_ptr>>> + ! CHECK: %[[atup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref>>, !fir.ref>>>>, i32) -> !fir.llvm_ptr>>> + ! CHECK: %[[a:.*]] = fir.load %[[atup]] : !fir.llvm_ptr>>> + ! CHECK: %[[abox:.*]] = fir.load %[[a]] : !fir.ref>> + ! CHECK: %[[addr:.*]] = fir.box_addr %[[abox]] : (!fir.box>) -> !fir.heap + ! CHECK: %[[ptr:.*]] = fir.embox %[[addr]] : (!fir.heap) -> !fir.box> + ! CHECK: fir.store %[[ptr]] to %[[p]] : !fir.ref>> + p => ally + end subroutine test4_inner +end subroutine test4 + +! ----------------------------------------------------------------------------- +! Test allocatable and pointer arrays +! ----------------------------------------------------------------------------- + +! CHECK-LABEL: func @_QPtest5() { +subroutine test5 + real, pointer :: p(:) + real, allocatable, target :: ally(:) + + ! CHECK: %[[ally:.*]] = fir.alloca !fir.box>> {bindc_name = "ally", fir.target + ! CHECK: %[[p:.*]] = fir.alloca !fir.box>> {bindc_name = "p" + ! CHECK: %[[tup:.*]] = fir.alloca tuple>>>, !fir.ref>>>> + ! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref>>>, !fir.ref>>>>>, i32) -> !fir.llvm_ptr>>>> + ! CHECK: fir.store %[[p]] to %[[ptup]] : !fir.llvm_ptr>>>> + ! CHECK: %[[atup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref>>>, !fir.ref>>>>>, i32) -> !fir.llvm_ptr>>>> + ! CHECK: fir.store %[[ally]] to %[[atup]] : !fir.llvm_ptr>>>> + ! CHECK: fir.call @_QFtest5Ptest5_inner(%[[tup]]) : (!fir.ref>>>, !fir.ref>>>>>) -> () + + allocate(ally(10)) + ally = -42.0 + call test5_inner + + if (p(1) .ne. -42.0) then + print *, "failed" + end if + +contains + ! CHECK-LABEL: func @_QFtest5Ptest5_inner( + ! CHECK-SAME:%[[tup:.*]]: !fir.ref>>>, !fir.ref>>>>> {fir.host_assoc}) { + subroutine test5_inner + ! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref>>>, !fir.ref>>>>>, i32) -> !fir.llvm_ptr>>>> + ! CHECK: %[[p:.*]] = fir.load %[[ptup]] : !fir.llvm_ptr>>>> + ! CHECK: %[[atup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref>>>, !fir.ref>>>>>, i32) -> !fir.llvm_ptr>>>> + ! CHECK: %[[a:.*]] = fir.load %[[atup]] : !fir.llvm_ptr>>>> + ! CHECK: %[[abox:.*]] = fir.load %[[a]] : !fir.ref>>> + ! CHECK-DAG: %[[adims:.*]]:3 = fir.box_dims %[[abox]], %c0{{.*}} : (!fir.box>>, index) -> (index, index, index) + ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[abox]] : (!fir.box>>) -> !fir.heap> + ! CHECK-DAG: %[[ashape:.*]] = fir.shape_shift %[[adims]]#0, %[[adims]]#1 : (index, index) -> !fir.shapeshift<1> + + ! CHECK: %[[ptr:.*]] = fir.embox %[[addr]](%[[ashape]]) : (!fir.heap>, !fir.shapeshift<1>) -> !fir.box>> + ! CHECK: fir.store %[[ptr]] to %[[p]] : !fir.ref>>> + p => ally + end subroutine test5_inner +end subroutine test5 + + +! ----------------------------------------------------------------------------- +! Test elemental internal procedure +! ----------------------------------------------------------------------------- + +! CHECK-LABEL: func @_QPtest7( +! CHECK-SAME: %[[j:.*]]: !fir.ref{{.*}}, %[[k:.*]]: !fir.box> +subroutine test7(j, k) + implicit none + integer :: j + integer :: k(:) + ! CHECK: %[[tup:.*]] = fir.alloca tuple> + ! CHECK: %[[jtup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref>>, i32) -> !fir.llvm_ptr> + ! CHECK: fir.store %[[j]] to %[[jtup]] : !fir.llvm_ptr> + + ! CHECK: %[[kelem:.*]] = fir.array_coor %[[k]] %{{.*}} : (!fir.box>, index) -> !fir.ref + ! CHECK: fir.call @_QFtest7Ptest7_inner(%[[kelem]], %[[tup]]) : (!fir.ref, !fir.ref>>) -> i32 + k = test7_inner(k) +contains + +! CHECK-LABEL: func @_QFtest7Ptest7_inner( +! CHECK-SAME: %[[i:.*]]: !fir.ref{{.*}}, %[[tup:.*]]: !fir.ref>> {fir.host_assoc}) -> i32 { +elemental integer function test7_inner(i) + implicit none + integer, intent(in) :: i + ! CHECK: %[[jtup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref>>, i32) -> !fir.llvm_ptr> + ! CHECK: %[[jptr:.*]] = fir.load %[[jtup]] : !fir.llvm_ptr> + ! CHECK-DAG: %[[iload:.*]] = fir.load %[[i]] : !fir.ref + ! CHECK-DAG: %[[jload:.*]] = fir.load %[[jptr]] : !fir.ref + ! CHECK: addi %[[iload]], %[[jload]] : i32 + test7_inner = i + j +end function +end subroutine + +subroutine issue990() + ! Test that host symbols used in statement functions inside an internal + ! procedure are correctly captured from the host. + implicit none + integer :: captured + call bar() +contains +! CHECK-LABEL: func @_QFissue990Pbar( +! CHECK-SAME: %[[tup:.*]]: !fir.ref>> {fir.host_assoc}) { +subroutine bar() + integer :: stmt_func, i + stmt_func(i) = i + captured + ! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref>>, i32) -> !fir.llvm_ptr> + ! CHECK: %[[addr:.*]] = fir.load %[[tupAddr]] : !fir.llvm_ptr> + ! CHECK: %[[value:.*]] = fir.load %[[addr]] : !fir.ref + ! CHECK: arith.addi %{{.*}}, %[[value]] : i32 + print *, stmt_func(10) +end subroutine +end subroutine + +subroutine issue990b() + ! Test when an internal procedure uses a statement function from its host + ! which uses host variables that are otherwise not used by the internal + ! procedure. + implicit none + integer :: captured, captured_stmt_func, i + captured_stmt_func(i) = i + captured + call bar() +contains +! CHECK-LABEL: func @_QFissue990bPbar( +! CHECK-SAME: %[[tup:.*]]: !fir.ref>> {fir.host_assoc}) { +subroutine bar() + ! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref>>, i32) -> !fir.llvm_ptr> + ! CHECK: %[[addr:.*]] = fir.load %[[tupAddr]] : !fir.llvm_ptr> + ! CHECK: %[[value:.*]] = fir.load %[[addr]] : !fir.ref + ! CHECK: arith.addi %{{.*}}, %[[value]] : i32 + print *, captured_stmt_func(10) +end subroutine +end subroutine + +! Test capture of dummy procedure functions. +subroutine test8(dummy_proc) + implicit none + interface + real function dummy_proc(x) + real :: x + end function + end interface + call bar() +contains +! CHECK-LABEL: func @_QFtest8Pbar( +! CHECK-SAME: %[[tup:.*]]: !fir.ref ()>>> {fir.host_assoc}) { +subroutine bar() + ! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref ()>>>, i32) -> !fir.ref ()>> + ! CHECK: %[[dummyProc:.*]] = fir.load %[[tupAddr]] : !fir.ref ()>> + ! CHECK: %[[dummyProcCast:.*]] = fir.box_addr %[[dummyProc]] : (!fir.boxproc<() -> ()>) -> ((!fir.ref) -> f32) + ! CHECK: fir.call %[[dummyProcCast]](%{{.*}}) : (!fir.ref) -> f32 + print *, dummy_proc(42.) +end subroutine +end subroutine + +! Test capture of dummy subroutines. +subroutine test9(dummy_proc) + implicit none + interface + subroutine dummy_proc() + end subroutine + end interface + call bar() +contains +! CHECK-LABEL: func @_QFtest9Pbar( +! CHECK-SAME: %[[tup:.*]]: !fir.ref ()>>> {fir.host_assoc}) { +subroutine bar() + ! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref ()>>>, i32) -> !fir.ref ()>> + ! CHECK: %[[dummyProc:.*]] = fir.load %[[tupAddr]] : !fir.ref ()>> + ! CHECK: %[[pa:.*]] = fir.box_addr %[[dummyProc]] + ! CHECK: fir.call %[[pa]]() : () -> () + call dummy_proc() +end subroutine +end subroutine + +! Test capture of namelist +! CHECK-LABEL: func @_QPtest10( +! CHECK-SAME: %[[i:.*]]: !fir.ref>>>{{.*}}) { +subroutine test10(i) + implicit none + integer, pointer :: i(:) + namelist /a_namelist/ i + ! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup:.*]], %c0{{.*}} : (!fir.ref>>>>>, i32) -> !fir.llvm_ptr>>>> + ! CHECK: fir.store %[[i]] to %[[tupAddr]] : !fir.llvm_ptr>>>> + ! CHECK: fir.call @_QFtest10Pbar(%[[tup]]) : (!fir.ref>>>>>) -> () + call bar() +contains +! CHECK-LABEL: func @_QFtest10Pbar( +! CHECK-SAME: %[[tup:.*]]: !fir.ref>>>>> {fir.host_assoc}) { +subroutine bar() + ! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref>>>>>, i32) -> !fir.llvm_ptr>>>> + ! CHECK: fir.load %[[tupAddr]] : !fir.llvm_ptr>>>> + read (88, NML = a_namelist) +end subroutine +end subroutine + +! Test passing an internal procedure as a dummy argument. + +! CHECK-LABEL: func @_QPtest_proc_dummy() { +! CHECK: %[[VAL_4:.*]] = fir.alloca i32 {bindc_name = "i", uniq_name = "_QFtest_proc_dummyEi"} +! CHECK: %[[VAL_5:.*]] = fir.alloca tuple> +! CHECK: %[[VAL_7:.*]] = fir.address_of(@_QFtest_proc_dummyPtest_proc_dummy_a) : (!fir.ref, !fir.ref>>) -> () +! CHECK: %[[VAL_8:.*]] = fir.emboxproc %[[VAL_7]], %[[VAL_5]] : ((!fir.ref, !fir.ref>>) -> (), !fir.ref>>) -> !fir.boxproc<() -> ()> +! CHECK: fir.call @_QPtest_proc_dummy_other(%[[VAL_8]]) : (!fir.boxproc<() -> ()>) -> () + +! CHECK-LABEL: func @_QFtest_proc_dummyPtest_proc_dummy_a( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "j"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref>> {fir.host_assoc}) { +! CHECK: %[[VAL_2:.*]] = arith.constant 0 : i32 +! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_1]], %[[VAL_2]] : (!fir.ref>>, i32) -> !fir.llvm_ptr> +! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_3]] : !fir.llvm_ptr> +! CHECK: %[[VAL_5:.*]] = fir.load %[[VAL_4]] : !fir.ref +! CHECK: %[[VAL_6:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_7:.*]] = arith.addi %[[VAL_5]], %[[VAL_6]] : i32 +! CHECK: fir.store %[[VAL_7]] to %[[VAL_4]] : !fir.ref +! CHECK: return +! CHECK: } + +! CHECK-LABEL: func @_QPtest_proc_dummy_other( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.boxproc<() -> ()>) { +! CHECK: %[[VAL_1:.*]] = arith.constant 4 : i32 +! CHECK: %[[VAL_2:.*]] = fir.alloca i32 {adapt.valuebyref} +! CHECK: fir.store %[[VAL_1]] to %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_3:.*]] = fir.box_addr %[[VAL_0]] : (!fir.boxproc<() -> ()>) -> ((!fir.ref) -> ()) +! CHECK: fir.call %[[VAL_3]](%[[VAL_2]]) : (!fir.ref) -> () +! CHECK: return +! CHECK: } + +subroutine test_proc_dummy + integer i + i = 1 + call test_proc_dummy_other(test_proc_dummy_a) + print *, i +contains + subroutine test_proc_dummy_a(j) + i = i + j + end subroutine test_proc_dummy_a +end subroutine test_proc_dummy + +subroutine test_proc_dummy_other(proc) + call proc(4) +end subroutine test_proc_dummy_other + +! CHECK-LABEL: func @_QPtest_proc_dummy_char() { +! CHECK-DAG: %[[VAL_0:.*]] = arith.constant 10 : index +! CHECK-DAG: %[[VAL_1:.*]] = arith.constant 0 : i32 +! CHECK-DAG: %[[VAL_2:.*]] = arith.constant 9 : index +! CHECK-DAG: %[[VAL_3:.*]] = arith.constant false +! CHECK-DAG: %[[VAL_4:.*]] = arith.constant 1 : index +! CHECK-DAG: %[[VAL_5:.*]] = arith.constant 32 : i8 +! CHECK-DAG: %[[VAL_6:.*]] = arith.constant -1 : i32 +! CHECK-DAG: %[[VAL_8:.*]] = arith.constant 10 : i64 +! CHECK-DAG: %[[VAL_9:.*]] = arith.constant 40 : index +! CHECK-DAG: %[[VAL_10:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_11:.*]] = fir.alloca !fir.char<1,40> {bindc_name = ".result"} +! CHECK: %[[VAL_12:.*]] = fir.alloca !fir.char<1,10> {bindc_name = "message", uniq_name = "_QFtest_proc_dummy_charEmessage"} +! CHECK: %[[VAL_13:.*]] = fir.alloca tuple> +! CHECK: %[[VAL_14:.*]] = fir.coordinate_of %[[VAL_13]], %[[VAL_1]] : (!fir.ref>>, i32) -> !fir.ref> +! CHECK: %[[VAL_15:.*]] = fir.convert %[[VAL_12]] : (!fir.ref>) -> !fir.ref> +! CHECK: %[[VAL_16:.*]] = fir.emboxchar %[[VAL_15]], %[[VAL_0]] : (!fir.ref>, index) -> !fir.boxchar<1> +! CHECK: fir.store %[[VAL_16]] to %[[VAL_14]] : !fir.ref> +! CHECK: %[[VAL_17:.*]] = fir.address_of(@_QQcl.{{.*}}) : !fir.ref> +! CHECK: %[[VAL_18:.*]] = fir.convert %[[VAL_2]] : (index) -> i64 +! CHECK: %[[VAL_19:.*]] = fir.convert %[[VAL_12]] : (!fir.ref>) -> !fir.ref +! CHECK: %[[VAL_20:.*]] = fir.convert %[[VAL_17]] : (!fir.ref>) -> !fir.ref +! CHECK: fir.call @llvm.memmove.p0i8.p0i8.i64(%[[VAL_19]], %[[VAL_20]], %[[VAL_18]], %[[VAL_3]]) : (!fir.ref, !fir.ref, i64, i1) -> () +! CHECK: %[[VAL_21:.*]] = fir.undefined !fir.char<1> +! CHECK: %[[VAL_22:.*]] = fir.insert_value %[[VAL_21]], %[[VAL_5]], [0 : index] : (!fir.char<1>, i8) -> !fir.char<1> +! CHECK: br ^bb1(%[[VAL_2]], %[[VAL_4]] : index, index) +! CHECK: ^bb1(%[[VAL_23:.*]]: index, %[[VAL_24:.*]]: index): +! CHECK: %[[VAL_25:.*]] = arith.cmpi sgt, %[[VAL_24]], %[[VAL_10]] : index +! CHECK: cond_br %[[VAL_25]], ^bb2, ^bb3 +! CHECK: ^bb2: +! CHECK: %[[VAL_26:.*]] = fir.convert %[[VAL_12]] : (!fir.ref>) -> !fir.ref>> +! CHECK: %[[VAL_27:.*]] = fir.coordinate_of %[[VAL_26]], %[[VAL_23]] : (!fir.ref>>, index) -> !fir.ref> +! CHECK: fir.store %[[VAL_22]] to %[[VAL_27]] : !fir.ref> +! CHECK: %[[VAL_28:.*]] = arith.addi %[[VAL_23]], %[[VAL_4]] : index +! CHECK: %[[VAL_29:.*]] = arith.subi %[[VAL_24]], %[[VAL_4]] : index +! CHECK: br ^bb1(%[[VAL_28]], %[[VAL_29]] : index, index) +! CHECK: ^bb3: +! CHECK: %[[VAL_30:.*]] = fir.address_of(@_QQcl.{{.*}}) : !fir.ref>) -> !fir.ref +! CHECK: %[[VAL_32:.*]] = fir.call @_FortranAioBeginExternalListOutput(%[[VAL_6]], %[[VAL_31]], %{{.*}}) : (i32, !fir.ref, i32) -> !fir.ref +! CHECK: %[[VAL_33:.*]] = fir.address_of(@_QFtest_proc_dummy_charPgen_message) : (!fir.ref>, index, !fir.ref>>) -> !fir.boxchar<1> +! CHECK: %[[VAL_34:.*]] = fir.emboxproc %[[VAL_33]], %[[VAL_13]] : ((!fir.ref>, index, !fir.ref>>) -> !fir.boxchar<1>, !fir.ref>>) -> !fir.boxproc<() -> ()> +! CHECK: %[[VAL_35:.*]] = fir.undefined tuple ()>, i64> +! CHECK: %[[VAL_36:.*]] = fir.insert_value %[[VAL_35]], %[[VAL_34]], [0 : index] : (tuple ()>, i64>, !fir.boxproc<() -> ()>) -> tuple ()>, i64> +! CHECK: %[[VAL_37:.*]] = fir.insert_value %[[VAL_36]], %[[VAL_8]], [1 : index] : (tuple ()>, i64>, i64) -> tuple ()>, i64> +! CHECK: %[[VAL_38:.*]] = fir.call @llvm.stacksave() : () -> !fir.ref +! CHECK: %[[VAL_39:.*]] = fir.call @_QPget_message(%[[VAL_11]], %[[VAL_9]], %[[VAL_37]]) : (!fir.ref>, index, tuple ()>, i64>) -> !fir.boxchar<1> +! CHECK: %[[VAL_40:.*]] = fir.convert %[[VAL_11]] : (!fir.ref>) -> !fir.ref +! CHECK: %[[VAL_41:.*]] = fir.convert %[[VAL_9]] : (index) -> i64 +! CHECK: %[[VAL_42:.*]] = fir.call @_FortranAioOutputAscii(%[[VAL_32]], %[[VAL_40]], %[[VAL_41]]) : (!fir.ref, !fir.ref, i64) -> i1 +! CHECK: fir.call @llvm.stackrestore(%[[VAL_38]]) : (!fir.ref) -> () +! CHECK: %[[VAL_43:.*]] = fir.call @_FortranAioEndIoStatement(%[[VAL_32]]) : (!fir.ref) -> i32 +! CHECK: return +! CHECK: } + +! CHECK-LABEL: func @_QFtest_proc_dummy_charPgen_message( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>, +! CHECK-SAME: %[[VAL_1:.*]]: index, +! CHECK-SAME: %[[VAL_2:.*]]: !fir.ref>> {fir.host_assoc}) -> !fir.boxchar<1> { +! CHECK-DAG: %[[VAL_3:.*]] = arith.constant 0 : i32 +! CHECK-DAG: %[[VAL_4:.*]] = arith.constant 10 : index +! CHECK-DAG: %[[VAL_5:.*]] = arith.constant false +! CHECK-DAG: %[[VAL_6:.*]] = arith.constant 1 : index +! CHECK-DAG: %[[VAL_7:.*]] = arith.constant 32 : i8 +! CHECK-DAG: %[[VAL_8:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_9:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_3]] : (!fir.ref>>, i32) -> !fir.ref> +! CHECK: %[[VAL_10:.*]] = fir.load %[[VAL_9]] : !fir.ref> +! CHECK: %[[VAL_11:.*]]:2 = fir.unboxchar %[[VAL_10]] : (!fir.boxchar<1>) -> (!fir.ref>, index) +! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_0]] : (!fir.ref>) -> !fir.ref> +! CHECK: %[[VAL_13:.*]] = arith.cmpi slt, %[[VAL_4]], %[[VAL_11]]#1 : index +! CHECK: %[[VAL_14:.*]] = arith.select %[[VAL_13]], %[[VAL_4]], %[[VAL_11]]#1 : index +! CHECK: %[[VAL_15:.*]] = fir.convert %[[VAL_14]] : (index) -> i64 +! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_12]] : (!fir.ref>) -> !fir.ref +! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_11]]#0 : (!fir.ref>) -> !fir.ref +! CHECK: fir.call @llvm.memmove.p0i8.p0i8.i64(%[[VAL_16]], %[[VAL_17]], %[[VAL_15]], %[[VAL_5]]) : (!fir.ref, !fir.ref, i64, i1) -> () +! CHECK: %[[VAL_18:.*]] = fir.undefined !fir.char<1> +! CHECK: %[[VAL_19:.*]] = fir.insert_value %[[VAL_18]], %[[VAL_7]], [0 : index] : (!fir.char<1>, i8) -> !fir.char<1> +! CHECK: %[[VAL_20:.*]] = arith.subi %[[VAL_4]], %[[VAL_14]] : index +! CHECK: br ^bb1(%[[VAL_14]], %[[VAL_20]] : index, index) +! CHECK: ^bb1(%[[VAL_21:.*]]: index, %[[VAL_22:.*]]: index): +! CHECK: %[[VAL_23:.*]] = arith.cmpi sgt, %[[VAL_22]], %[[VAL_8]] : index +! CHECK: cond_br %[[VAL_23]], ^bb2, ^bb3 +! CHECK: ^bb2: +! CHECK: %[[VAL_24:.*]] = fir.convert %[[VAL_12]] : (!fir.ref>) -> !fir.ref>> +! CHECK: %[[VAL_25:.*]] = fir.coordinate_of %[[VAL_24]], %[[VAL_21]] : (!fir.ref>>, index) -> !fir.ref> +! CHECK: fir.store %[[VAL_19]] to %[[VAL_25]] : !fir.ref> +! CHECK: %[[VAL_26:.*]] = arith.addi %[[VAL_21]], %[[VAL_6]] : index +! CHECK: %[[VAL_27:.*]] = arith.subi %[[VAL_22]], %[[VAL_6]] : index +! CHECK: br ^bb1(%[[VAL_26]], %[[VAL_27]] : index, index) +! CHECK: ^bb3: +! CHECK: %[[VAL_28:.*]] = fir.emboxchar %[[VAL_12]], %[[VAL_4]] : (!fir.ref>, index) -> !fir.boxchar<1> +! CHECK: return %[[VAL_28]] : !fir.boxchar<1> +! CHECK: } + +! CHECK-LABEL: func @_QPget_message( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>, +! CHECK-SAME: %[[VAL_1:.*]]: index, +! CHECK-SAME: %[[VAL_2:.*]]: tuple ()>, i64> {fir.char_proc}) -> !fir.boxchar<1> { +! CHECK: %[[VAL_3:.*]] = arith.constant 40 : index +! CHECK: %[[VAL_4:.*]] = arith.constant 12 : index +! CHECK: %[[VAL_5:.*]] = arith.constant false +! CHECK: %[[VAL_6:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_7:.*]] = arith.constant 32 : i8 +! CHECK: %[[VAL_8:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_0]] : (!fir.ref>) -> !fir.ref> +! CHECK: %[[VAL_10:.*]] = fir.address_of(@_QQcl.{{.*}}) : !fir.ref> +! CHECK: %[[VAL_11:.*]] = fir.extract_value %[[VAL_2]], [0 : index] : (tuple ()>, i64>) -> !fir.boxproc<() -> ()> +! CHECK: %[[VAL_12:.*]] = fir.box_addr %[[VAL_11]] : (!fir.boxproc<() -> ()>) -> (() -> ()) +! CHECK: %[[VAL_13:.*]] = fir.extract_value %[[VAL_2]], [1 : index] : (tuple ()>, i64>) -> i64 +! CHECK: %[[VAL_14:.*]] = fir.call @llvm.stacksave() : () -> !fir.ref +! CHECK: %[[VAL_15:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_13]] : i64) {bindc_name = ".result"} +! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_12]] : (() -> ()) -> ((!fir.ref>, index) -> !fir.boxchar<1>) +! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_13]] : (i64) -> index +! CHECK: %[[VAL_18:.*]] = fir.call %[[VAL_16]](%[[VAL_15]], %[[VAL_17]]) : (!fir.ref>, index) -> !fir.boxchar<1> +! CHECK: %[[VAL_19:.*]] = arith.addi %[[VAL_17]], %[[VAL_4]] : index +! CHECK: %[[VAL_20:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_19]] : index) {bindc_name = ".chrtmp"} +! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_4]] : (index) -> i64 +! CHECK: %[[VAL_22:.*]] = fir.convert %[[VAL_20]] : (!fir.ref>) -> !fir.ref +! CHECK: %[[VAL_23:.*]] = fir.convert %[[VAL_10]] : (!fir.ref>) -> !fir.ref +! CHECK: fir.call @llvm.memmove.p0i8.p0i8.i64(%[[VAL_22]], %[[VAL_23]], %[[VAL_21]], %[[VAL_5]]) : (!fir.ref, !fir.ref, i64, i1) -> () +! CHECK: br ^bb1(%[[VAL_4]], %[[VAL_17]] : index, index) +! CHECK: ^bb1(%[[VAL_24:.*]]: index, %[[VAL_25:.*]]: index): +! CHECK: %[[VAL_26:.*]] = arith.cmpi sgt, %[[VAL_25]], %[[VAL_8]] : index +! CHECK: cond_br %[[VAL_26]], ^bb2, ^bb3 +! CHECK: ^bb2: +! CHECK: %[[VAL_27:.*]] = arith.subi %[[VAL_24]], %[[VAL_4]] : index +! CHECK: %[[VAL_28:.*]] = fir.convert %[[VAL_15]] : (!fir.ref>) -> !fir.ref>> +! CHECK: %[[VAL_29:.*]] = fir.coordinate_of %[[VAL_28]], %[[VAL_27]] : (!fir.ref>>, index) -> !fir.ref> +! CHECK: %[[VAL_30:.*]] = fir.load %[[VAL_29]] : !fir.ref> +! CHECK: %[[VAL_31:.*]] = fir.convert %[[VAL_20]] : (!fir.ref>) -> !fir.ref>> +! CHECK: %[[VAL_32:.*]] = fir.coordinate_of %[[VAL_31]], %[[VAL_24]] : (!fir.ref>>, index) -> !fir.ref> +! CHECK: fir.store %[[VAL_30]] to %[[VAL_32]] : !fir.ref> +! CHECK: %[[VAL_33:.*]] = arith.addi %[[VAL_24]], %[[VAL_6]] : index +! CHECK: %[[VAL_34:.*]] = arith.subi %[[VAL_25]], %[[VAL_6]] : index +! CHECK: br ^bb1(%[[VAL_33]], %[[VAL_34]] : index, index) +! CHECK: ^bb3: +! CHECK: %[[VAL_35:.*]] = arith.cmpi slt, %[[VAL_3]], %[[VAL_19]] : index +! CHECK: %[[VAL_36:.*]] = arith.select %[[VAL_35]], %[[VAL_3]], %[[VAL_19]] : index +! CHECK: %[[VAL_37:.*]] = fir.convert %[[VAL_36]] : (index) -> i64 +! CHECK: %[[VAL_38:.*]] = fir.convert %[[VAL_9]] : (!fir.ref>) -> !fir.ref +! CHECK: fir.call @llvm.memmove.p0i8.p0i8.i64(%[[VAL_38]], %[[VAL_22]], %[[VAL_37]], %[[VAL_5]]) : (!fir.ref, !fir.ref, i64, i1) -> () +! CHECK: %[[VAL_39:.*]] = fir.undefined !fir.char<1> +! CHECK: %[[VAL_40:.*]] = fir.insert_value %[[VAL_39]], %[[VAL_7]], [0 : index] : (!fir.char<1>, i8) -> !fir.char<1> +! CHECK: %[[VAL_41:.*]] = arith.subi %[[VAL_3]], %[[VAL_36]] : index +! CHECK: br ^bb4(%[[VAL_36]], %[[VAL_41]] : index, index) +! CHECK: ^bb4(%[[VAL_42:.*]]: index, %[[VAL_43:.*]]: index): +! CHECK: %[[VAL_44:.*]] = arith.cmpi sgt, %[[VAL_43]], %[[VAL_8]] : index +! CHECK: cond_br %[[VAL_44]], ^bb5, ^bb6 +! CHECK: ^bb5: +! CHECK: %[[VAL_45:.*]] = fir.convert %[[VAL_9]] : (!fir.ref>) -> !fir.ref>> +! CHECK: %[[VAL_46:.*]] = fir.coordinate_of %[[VAL_45]], %[[VAL_42]] : (!fir.ref>>, index) -> !fir.ref> +! CHECK: fir.store %[[VAL_40]] to %[[VAL_46]] : !fir.ref> +! CHECK: %[[VAL_47:.*]] = arith.addi %[[VAL_42]], %[[VAL_6]] : index +! CHECK: %[[VAL_48:.*]] = arith.subi %[[VAL_43]], %[[VAL_6]] : index +! CHECK: br ^bb4(%[[VAL_47]], %[[VAL_48]] : index, index) +! CHECK: ^bb6: +! CHECK: fir.call @llvm.stackrestore(%[[VAL_14]]) : (!fir.ref) -> () +! CHECK: %[[VAL_49:.*]] = fir.emboxchar %[[VAL_9]], %[[VAL_3]] : (!fir.ref>, index) -> !fir.boxchar<1> +! CHECK: return %[[VAL_49]] : !fir.boxchar<1> +! CHECK: } + +subroutine test_proc_dummy_char + character(40) get_message + external get_message + character(10) message + message = "Hi there!" + print *, get_message(gen_message) +contains + function gen_message + character(10) :: gen_message + gen_message = message + end function gen_message +end subroutine test_proc_dummy_char + +function get_message(a) + character(40) :: get_message + character(*) :: a + get_message = "message is: " // a() +end function get_message + +! CHECK-LABEL: func @_QPtest_11a() { +! CHECK: %[[a:.*]] = fir.address_of(@_QPtest_11b) : () -> () +! CHECK: %[[b:.*]] = fir.emboxproc %[[a]] : (() -> ()) -> !fir.boxproc<() -> ()> +! CHECK: fir.call @_QPtest_11c(%[[b]], %{{.*}}) : (!fir.boxproc<() -> ()>, !fir.ref) -> () +! CHECK: func private @_QPtest_11c(!fir.boxproc<() -> ()>, !fir.ref) + +subroutine test_11a + external test_11b + call test_11c(test_11b, 3) +end subroutine test_11a diff --git a/flang/test/Lower/procedure-declarations.f90 b/flang/test/Lower/procedure-declarations.f90 index 8278cf90f5a1..57603245f9d4 100644 --- a/flang/test/Lower/procedure-declarations.f90 +++ b/flang/test/Lower/procedure-declarations.f90 @@ -11,6 +11,13 @@ ! since definition should be processed first regardless. ! pass, call, define +! CHECK-LABEL: func @_QPpass_foo() { +subroutine pass_foo() + external :: foo + ! CHECK: %[[f:.*]] = fir.address_of(@_QPfoo) + ! CHECK: fir.emboxproc %[[f]] : ((!fir.ref>) -> ()) -> !fir.boxproc<() -> ()> + call bar(foo) +end subroutine ! CHECK-LABEL: func @_QPcall_foo( ! CHECK-SAME: %{{.*}}: !fir.ref>{{.*}}) { subroutine call_foo(i) @@ -35,6 +42,13 @@ subroutine call_foo2(i) ! fir.call @_QPfoo2(%[[argconvert]]) : (!fir.ref>) -> () call foo2(i) end subroutine +! CHECK-LABEL: func @_QPpass_foo2() { +subroutine pass_foo2() + external :: foo2 + ! CHECK: %[[f:.*]] = fir.address_of(@_QPfoo2) + ! CHECK: fir.emboxproc %[[f]] : ((!fir.ref>) -> ()) -> !fir.boxproc<() -> ()> + call bar(foo2) +end subroutine ! CHECK-LABEL: func @_QPfoo2( ! CHECK-SAME: %{{.*}}: !fir.ref>{{.*}}) { subroutine foo2(i) @@ -57,6 +71,13 @@ subroutine foo3(i) integer :: i(2, 5) call do_something(i) end subroutine +! CHECK-LABEL: func @_QPpass_foo3() { +subroutine pass_foo3() + external :: foo3 + ! CHECK: %[[f:.*]] = fir.address_of(@_QPfoo3) + ! CHECK: fir.emboxproc %[[f]] : ((!fir.ref>) -> ()) -> !fir.boxproc<() -> ()> + call bar(foo3) +end subroutine ! define, call, pass ! CHECK-LABEL: func @_QPfoo4( @@ -73,6 +94,13 @@ subroutine call_foo4(i) ! fir.call @_QPfoo4(%[[argconvert]]) : (!fir.ref>) -> () call foo4(i) end subroutine +! CHECK-LABEL: func @_QPpass_foo4() { +subroutine pass_foo4() + external :: foo4 + ! CHECK: %[[f:.*]] = fir.address_of(@_QPfoo4) + ! CHECK: fir.emboxproc %[[f]] : ((!fir.ref>) -> ()) -> !fir.boxproc<() -> ()> + call bar(foo4) +end subroutine ! define, pass, call ! CHECK-LABEL: func @_QPfoo5( @@ -81,6 +109,13 @@ subroutine foo5(i) integer :: i(2, 5) call do_something(i) end subroutine +! CHECK-LABEL: func @_QPpass_foo5() { +subroutine pass_foo5() + external :: foo5 + ! CHECK: %[[f:.*]] = fir.address_of(@_QPfoo5) + ! CHECK: fir.emboxproc %[[f]] : ((!fir.ref>) -> ()) -> !fir.boxproc<() -> ()> + call bar(foo5) +end subroutine ! CHECK-LABEL: func @_QPcall_foo5( ! CHECK-SAME: %{{.*}}: !fir.ref>{{.*}}) { subroutine call_foo5(i) @@ -101,8 +136,32 @@ subroutine call_foo6(i) integer :: i(10) ! CHECK-NOT: convert call foo6(i) +end subroutine +! CHECK-LABEL: func @_QPpass_foo6() { +subroutine pass_foo6() + external :: foo6 + ! CHECK: %[[f:.*]] = fir.address_of(@_QPfoo6) : (!fir.ref>) -> () + ! CHECK: fir.emboxproc %[[f]] : ((!fir.ref>) -> ()) -> !fir.boxproc<() -> ()> + call bar(foo6) end subroutine +! pass, call +! CHECK-LABEL: func @_QPpass_foo7() { +subroutine pass_foo7() + external :: foo7 + ! CHECK-NOT: convert + call bar(foo7) +end subroutine +! CHECK-LABEL: func @_QPcall_foo7( +! CHECK-SAME: %{{.*}}: !fir.ref>{{.*}}) -> f32 { +function call_foo7(i) + integer :: i(10) + ! CHECK: %[[f:.*]] = fir.address_of(@_QPfoo7) : () -> () + ! CHECK: %[[funccast:.*]] = fir.convert %[[f]] : (() -> ()) -> ((!fir.ref>) -> f32) + ! CHECK: fir.call %[[funccast]](%arg0) : (!fir.ref>) -> f32 + call_foo7 = foo7(i) +end function + ! call, call with different type ! CHECK-LABEL: func @_QPcall_foo8( @@ -137,6 +196,7 @@ subroutine test_target_in_iface() end subroutine ! CHECK: func private @_QPfoo6(!fir.ref>) +! CHECK: func private @_QPfoo7() ! Test declaration from test_target_in_iface ! CHECK-LABEL: func private @_QPtest_target(!fir.ref {fir.target}, !fir.box> {fir.target})