diff --git a/flang/include/flang/Lower/Bridge.h b/flang/include/flang/Lower/Bridge.h --- 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 @@ /// 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 --- 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 @@ 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 @@ 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 @@ /// 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 @@ 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 @@ 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 @@ 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 @@ /// 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 @@ 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 @@ /// 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 @@ 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 --- 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 @@ 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 @@ 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 @@ 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 --- a/flang/include/flang/Lower/IntrinsicCall.h +++ b/flang/include/flang/Lower/IntrinsicCall.h @@ -100,6 +100,10 @@ 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 --- 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 @@ 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 @@ /// 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 @@ 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 @@ /// 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 --- 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 @@ 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 @@ mlir::FuncOp getNamedFunction(llvm::StringRef name) { return getNamedFunction(getModule(), name); } - static mlir::FuncOp getNamedFunction(mlir::ModuleOp module, llvm::StringRef name); @@ -382,6 +382,9 @@ 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 @@ 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 @@ 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 @@ 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 --- a/flang/include/flang/Optimizer/Builder/LowLevelIntrinsics.h +++ b/flang/include/flang/Optimizer/Builder/LowLevelIntrinsics.h @@ -24,12 +24,30 @@ 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 --- a/flang/include/flang/Optimizer/CodeGen/CGPasses.td +++ b/flang/include/flang/Optimizer/CodeGen/CGPasses.td @@ -64,4 +64,14 @@ ]; } +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 --- a/flang/include/flang/Optimizer/CodeGen/CodeGen.h +++ b/flang/include/flang/Optimizer/CodeGen/CodeGen.h @@ -55,12 +55,18 @@ 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 --- a/flang/include/flang/Optimizer/Dialect/FIROps.td +++ b/flang/include/flang/Optimizer/Dialect/FIROps.td @@ -885,7 +885,8 @@ 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 @@ 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 @@ ```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 --- 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 --- a/flang/include/flang/Optimizer/Dialect/FIRType.h +++ b/flang/include/flang/Optimizer/Dialect/FIRType.h @@ -78,9 +78,9 @@ /// 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 @@ /// 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 @@ 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 --- a/flang/include/flang/Optimizer/Dialect/FIRTypes.td +++ b/flang/include/flang/Optimizer/Dialect/FIRTypes.td @@ -567,6 +567,11 @@ fir_HeapType.predicate, fir_PointerType.predicate, fir_LLVMPointerType.predicate]>, "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 --- a/flang/include/flang/Tools/CLOptions.inc +++ b/flang/include/flang/Tools/CLOptions.inc @@ -62,6 +62,8 @@ 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 @@ 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 @@ #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 --- 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 @@ /// creation. llvm::SmallSetVector seen; }; + } // namespace //===----------------------------------------------------------------------===// @@ -160,7 +172,12 @@ [&](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 @@ 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 @@ 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 @@ 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,437 +409,120 @@ 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(); + mlir::Value hostAssocTupleValue() override final { return hostAssocTuple; } + + /// Record a binding for the ssa-value of the tuple for this function. + void bindHostAssocTuple(mlir::Value val) override final { + assert(!hostAssocTuple && val); + hostAssocTuple = val; } - /// 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); + void registerRuntimeTypeInfo( + mlir::Location loc, + Fortran::lower::SymbolRef typeInfoSym) override final { + runtimeTypeInfoConverter.registerTypeInfoSymbol(*this, loc, typeInfoSym); } - /// Conditionally switch code insertion to a new block. - void maybeStartBlock(mlir::Block *newBlock) { - if (newBlock) - startBlock(newBlock); +private: + FirConverter() = delete; + FirConverter(const FirConverter &) = delete; + FirConverter &operator=(const FirConverter &) = delete; + + //===--------------------------------------------------------------------===// + // Helper member functions + //===--------------------------------------------------------------------===// + + mlir::Value createFIRExpr(mlir::Location loc, + const Fortran::lower::SomeExpr *expr, + Fortran::lower::StatementContext &stmtCtx) { + return fir::getBase(genExprValue(*expr, stmtCtx, &loc)); } - /// 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(); + /// Find the symbol in the local map or return null. + Fortran::lower::SymbolBox + lookupSymbol(const Fortran::semantics::Symbol &sym) { + if (Fortran::lower::SymbolBox v = localSymbols.lookupSymbol(sym)) + return v; + return {}; } - /// 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(); + /// Find the symbol in the inner-most level of the local map or return null. + Fortran::lower::SymbolBox + shallowLookupSymbol(const Fortran::semantics::Symbol &sym) { + if (Fortran::lower::SymbolBox v = localSymbols.shallowLookupSymbol(sym)) + return v; + return {}; } - /// 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); - } - } - }); + + /// Add the symbol to the local map and return `true`. If the symbol is + /// already in the map and \p forced is `false`, the map is not updated. + /// Instead the value `false` is returned. + bool addSymbol(const Fortran::semantics::SymbolRef sym, mlir::Value val, + bool forced = false) { + if (!forced && lookupSymbol(sym)) + return false; + localSymbols.addSymbol(sym, val, forced); + return true; } - /// 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); + 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; + } - // 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())); - } + 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(); }); } - /// 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); + static bool isNumericScalarCategory(Fortran::common::TypeCategory cat) { + return cat == Fortran::common::TypeCategory::Integer || + cat == Fortran::common::TypeCategory::Real || + cat == Fortran::common::TypeCategory::Complex || + cat == Fortran::common::TypeCategory::Logical; + } + static bool isLogicalCategory(Fortran::common::TypeCategory cat) { + return cat == Fortran::common::TypeCategory::Logical; + } + static bool isCharacterCategory(Fortran::common::TypeCategory cat) { + return cat == Fortran::common::TypeCategory::Character; + } + static bool isDerivedCategory(Fortran::common::TypeCategory cat) { + return cat == Fortran::common::TypeCategory::Derived; } - /// 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()); + /// Insert a new block before \p block. Leave the insertion point unchanged. + mlir::Block *insertBlock(mlir::Block *block) { + mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint(); + mlir::Block *newBlock = builder->createBlock(block); + builder->restoreInsertionPoint(insertPt); + return newBlock; + } - mapDummiesAndResults(funit, callee); + mlir::Block *blockOfLabel(Fortran::lower::pft::Evaluation &eval, + Fortran::parser::Label label) { + const Fortran::lower::pft::LabelEvalMap &labelEvaluationMap = + eval.getOwningProcedure()->labelEvaluationMap; + const auto iter = labelEvaluationMap.find(label); + assert(iter != labelEvaluationMap.end() && "label missing from map"); + mlir::Block *block = iter->second->block; + assert(block && "missing labeled evaluation block"); + return block; + } - // 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. - void bindHostAssocTuple(mlir::Value val) override final { - assert(!hostAssocTuple && val); - hostAssocTuple = val; - } - - void registerRuntimeTypeInfo( - mlir::Location loc, - Fortran::lower::SymbolRef typeInfoSym) override final { - runtimeTypeInfoConverter.registerTypeInfoSymbol(*this, loc, typeInfoSym); - } - -private: - FirConverter() = delete; - FirConverter(const FirConverter &) = delete; - FirConverter &operator=(const FirConverter &) = delete; - - //===--------------------------------------------------------------------===// - // Helper member functions - //===--------------------------------------------------------------------===// - - mlir::Value createFIRExpr(mlir::Location loc, - const Fortran::lower::SomeExpr *expr, - Fortran::lower::StatementContext &stmtCtx) { - return fir::getBase(genExprValue(*expr, stmtCtx, &loc)); - } - - /// Find the symbol in the local map or return null. - Fortran::lower::SymbolBox - lookupSymbol(const Fortran::semantics::Symbol &sym) { - if (Fortran::lower::SymbolBox v = localSymbols.lookupSymbol(sym)) - return v; - return {}; - } - - /// Find the symbol in the inner-most level of the local map or return null. - Fortran::lower::SymbolBox - shallowLookupSymbol(const Fortran::semantics::Symbol &sym) { - if (Fortran::lower::SymbolBox v = localSymbols.shallowLookupSymbol(sym)) - return v; - return {}; - } - - /// Add the symbol to the local map and return `true`. If the symbol is - /// already in the map and \p forced is `false`, the map is not updated. - /// Instead the value `false` is returned. - bool addSymbol(const Fortran::semantics::SymbolRef sym, mlir::Value val, - bool forced = false) { - if (!forced && lookupSymbol(sym)) - return false; - localSymbols.addSymbol(sym, val, forced); - return true; - } - - bool isNumericScalarCategory(Fortran::common::TypeCategory cat) { - return cat == Fortran::common::TypeCategory::Integer || - cat == Fortran::common::TypeCategory::Real || - cat == Fortran::common::TypeCategory::Complex || - cat == Fortran::common::TypeCategory::Logical; - } - static bool isLogicalCategory(Fortran::common::TypeCategory cat) { - return cat == Fortran::common::TypeCategory::Logical; - } - bool isCharacterCategory(Fortran::common::TypeCategory cat) { - return cat == Fortran::common::TypeCategory::Character; - } - bool isDerivedCategory(Fortran::common::TypeCategory cat) { - return cat == Fortran::common::TypeCategory::Derived; - } - - /// Insert a new block before \p block. Leave the insertion point unchanged. - mlir::Block *insertBlock(mlir::Block *block) { - mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint(); - mlir::Block *newBlock = builder->createBlock(block); - builder->restoreInsertionPoint(insertPt); - return newBlock; - } - - mlir::Block *blockOfLabel(Fortran::lower::pft::Evaluation &eval, - Fortran::parser::Label label) { - const Fortran::lower::pft::LabelEvalMap &labelEvaluationMap = - eval.getOwningProcedure()->labelEvaluationMap; - const auto iter = labelEvaluationMap.find(label); - assert(iter != labelEvaluationMap.end() && "label missing from map"); - mlir::Block *block = iter->second->block; - assert(block && "missing labeled evaluation block"); - return block; - } - - void genFIRBranch(mlir::Block *targetBlock) { - assert(targetBlock && "missing unconditional target block"); - builder->create(toLocation(), targetBlock); - } + void genFIRBranch(mlir::Block *targetBlock) { + assert(targetBlock && "missing unconditional target block"); + builder->create(toLocation(), targetBlock); + } void genFIRConditionalBranch(mlir::Value cond, mlir::Block *trueTarget, mlir::Block *falseTarget) { @@ -947,255 +625,40 @@ mlir::Value retval = builder->create( toLocation(), getAltReturnResult(symbol)); builder->create(toLocation(), retval); - } else { - genExitRoutine(); - } - } - - // - // Statements that have control-flow semantics - // - - /// Generate an If[Then]Stmt condition or its negation. - template - mlir::Value genIfCondition(const A *stmt, bool negate = false) { - mlir::Location loc = toLocation(); - Fortran::lower::StatementContext stmtCtx; - mlir::Value condExpr = createFIRExpr( - loc, - Fortran::semantics::GetExpr( - std::get(stmt->t)), - stmtCtx); - stmtCtx.finalize(); - mlir::Value cond = - builder->createConvert(loc, builder->getI1Type(), condExpr); - if (negate) - cond = builder->create( - loc, cond, builder->createIntegerConstant(loc, cond.getType(), 1)); - 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(); - } - 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); - } - } - }, + } else { + genExitRoutine(); + } + } - // [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"); + // + // Statements that have control-flow semantics + // - // 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); + /// Generate an If[Then]Stmt condition or its negation. + template + mlir::Value genIfCondition(const A *stmt, bool negate = false) { + mlir::Location loc = toLocation(); + Fortran::lower::StatementContext stmtCtx; + mlir::Value condExpr = createFIRExpr( + loc, + Fortran::semantics::GetExpr( + std::get(stmt->t)), + stmtCtx); + stmtCtx.finalize(); + mlir::Value cond = + builder->createConvert(loc, builder->getI1Type(), condExpr); + if (negate) + cond = builder->create( + loc, cond, builder->createIntegerConstant(loc, cond.getType(), 1)); + return cond; + } + + mlir::FuncOp getFunc(llvm::StringRef name, mlir::FunctionType ty) { + if (mlir::FuncOp func = builder->getNamedFunction(name)) { + assert(func.getFunctionType() == ty); + return func; + } + return builder->createFunction(toLocation(), name, ty); } /// Lowering of CALL statement @@ -1264,7 +727,7 @@ 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 @@ 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 @@ builder->restoreInsertionPoint(insertPt); } - void genFIR(const Fortran::parser::OpenMPDeclarativeConstruct &) { + void genFIR(const Fortran::parser::OpenMPDeclarativeConstruct &ompDecl) { TODO(toLocation(), "OpenMPDeclarativeConstruct lowering"); } @@ -1647,7 +1116,7 @@ /// 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 @@ } 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 @@ 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 @@ 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,51 +1514,282 @@ TODO(toLocation(), "LockStmt lowering"); } - /// Return true if the current context is a conditionalized and implied - /// iteration space. - bool implicitIterationSpace() { return !implicitIterSpace.empty(); } + 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(); } + + /// Return true if context is currently an explicit iteration space. A scalar + /// assignment expression may be contextually within a user-defined iteration + /// space, transforming it into an array expression. + bool explicitIterationSpace() { return explicitIterSpace.isActive(); } + + /// Generate an array assignment. + /// This is an assignment expression with rank > 0. The assignment may or may + /// not be in a WHERE and/or FORALL context. + void genArrayAssignment(const Fortran::evaluate::Assignment &assign, + Fortran::lower::StatementContext &stmtCtx) { + if (isWholeAllocatable(assign.lhs)) { + // Assignment to allocatables may require the lhs to be + // deallocated/reallocated. See Fortran 2018 10.2.1.3 p3 + Fortran::lower::createAllocatableArrayAssignment( + *this, assign.lhs, assign.rhs, explicitIterSpace, implicitIterSpace, + localSymbols, stmtCtx); + return; + } + + if (!implicitIterationSpace() && !explicitIterationSpace()) { + // No masks and the iteration space is implied by the array, so create a + // simple array assignment. + Fortran::lower::createSomeArrayAssignment(*this, assign.lhs, assign.rhs, + localSymbols, stmtCtx); + return; + } + + // If there is an explicit iteration space, generate an array assignment + // with a user-specified iteration space and possibly with masks. These + // assignments may *appear* to be scalar expressions, but the scalar + // expression is evaluated at all points in the user-defined space much like + // an ordinary array assignment. More specifically, the semantics inside the + // FORALL much more closely resembles that of WHERE than a scalar + // assignment. + // Otherwise, generate a masked array assignment. The iteration space is + // implied by the lhs array expression. + Fortran::lower::createAnyMaskedArrayAssignment( + *this, assign.lhs, assign.rhs, explicitIterSpace, implicitIterSpace, + localSymbols, + explicitIterationSpace() ? explicitIterSpace.stmtContext() + : 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); + }, - /// Return true if context is currently an explicit iteration space. A scalar - /// assignment expression may be contextually within a user-defined iteration - /// space, transforming it into an array expression. - bool explicitIterationSpace() { return explicitIterSpace.isActive(); } + // [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"); - /// Generate an array assignment. - /// This is an assignment expression with rank > 0. The assignment may or may - /// not be in a WHERE and/or FORALL context. - void genArrayAssignment(const Fortran::evaluate::Assignment &assign, - Fortran::lower::StatementContext &stmtCtx) { - if (isWholeAllocatable(assign.lhs)) { - // Assignment to allocatables may require the lhs to be - // deallocated/reallocated. See Fortran 2018 10.2.1.3 p3 - Fortran::lower::createAllocatableArrayAssignment( - *this, assign.lhs, assign.rhs, explicitIterSpace, implicitIterSpace, - localSymbols, stmtCtx); - return; - } + // 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); + } + } + }, - if (!implicitIterationSpace() && !explicitIterationSpace()) { - // No masks and the iteration space is implied by the array, so create a - // simple array assignment. - Fortran::lower::createSomeArrayAssignment(*this, assign.lhs, assign.rhs, - localSymbols, stmtCtx); - return; - } + // [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"); - // If there is an explicit iteration space, generate an array assignment - // with a user-specified iteration space and possibly with masks. These - // assignments may *appear* to be scalar expressions, but the scalar - // expression is evaluated at all points in the user-defined space much like - // an ordinary array assignment. More specifically, the semantics inside the - // FORALL much more closely resembles that of WHERE than a scalar - // assignment. - // Otherwise, generate a masked array assignment. The iteration space is - // implied by the lhs array expression. - Fortran::lower::createAnyMaskedArrayAssignment( - *this, assign.lhs, assign.rhs, explicitIterSpace, implicitIterSpace, - localSymbols, - explicitIterationSpace() ? explicitIterSpace.stmtContext() - : implicitIterSpace.stmtContext()); + // 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) { @@ -2161,209 +1845,564 @@ implicitIterSpace.append(Fortran::semantics::GetExpr( std::get(stmt.t))); } - void genFIR(const Fortran::parser::WhereConstruct::Elsewhere &ew) { - genNestedStatement( - std::get>( - ew.t)); - for (const auto &body : - std::get>(ew.t)) - genFIR(body); + void genFIR(const Fortran::parser::WhereConstruct::Elsewhere &ew) { + genNestedStatement( + std::get>( + ew.t)); + for (const auto &body : + std::get>(ew.t)) + genFIR(body); + } + void genFIR(const Fortran::parser::ElsewhereStmt &stmt) { + implicitIterSpace.append(nullptr); + } + void genFIR(const Fortran::parser::EndWhereStmt &) { + implicitIterSpace.shrinkStack(); + } + + void genFIR(const Fortran::parser::WhereStmt &stmt) { + Fortran::lower::StatementContext stmtCtx; + const auto &assign = std::get(stmt.t); + implicitIterSpace.growStack(); + implicitIterSpace.append(Fortran::semantics::GetExpr( + std::get(stmt.t))); + genAssignment(*assign.typedAssignment->v); + implicitIterSpace.shrinkStack(); + } + + void genFIR(const Fortran::parser::PointerAssignmentStmt &stmt) { + genAssignment(*stmt.typedAssignment->v); + } + + void genFIR(const Fortran::parser::AssignmentStmt &stmt) { + genAssignment(*stmt.typedAssignment->v); + } + + void genFIR(const Fortran::parser::SyncAllStmt &stmt) { + TODO(toLocation(), "SyncAllStmt lowering"); + } + + void genFIR(const Fortran::parser::SyncImagesStmt &stmt) { + TODO(toLocation(), "SyncImagesStmt lowering"); + } + + void genFIR(const Fortran::parser::SyncMemoryStmt &stmt) { + TODO(toLocation(), "SyncMemoryStmt lowering"); + } + + void genFIR(const Fortran::parser::SyncTeamStmt &stmt) { + TODO(toLocation(), "SyncTeamStmt lowering"); + } + + void genFIR(const Fortran::parser::UnlockStmt &stmt) { + TODO(toLocation(), "UnlockStmt lowering"); + } + + void genFIR(const Fortran::parser::AssignStmt &stmt) { + const Fortran::semantics::Symbol &symbol = + *std::get(stmt.t).symbol; + mlir::Location loc = toLocation(); + mlir::Value labelValue = builder->createIntegerConstant( + loc, genType(symbol), std::get(stmt.t)); + builder->create(loc, labelValue, getSymbolAddress(symbol)); + } + + void genFIR(const Fortran::parser::FormatStmt &) { + // do nothing. + + // FORMAT statements have no semantics. They may be lowered if used by a + // data transfer statement. + } + + void genFIR(const Fortran::parser::PauseStmt &stmt) { + genPauseStatement(*this, stmt); + } + + // call FAIL IMAGE in runtime + void genFIR(const Fortran::parser::FailImageStmt &stmt) { + TODO(toLocation(), "FailImageStmt lowering"); + } + + // call STOP, ERROR STOP in runtime + void genFIR(const Fortran::parser::StopStmt &stmt) { + genStopStatement(*this, stmt); + } + + void genFIR(const Fortran::parser::ReturnStmt &stmt) { + Fortran::lower::pft::FunctionLikeUnit *funit = + getEval().getOwningProcedure(); + assert(funit && "not inside main program, function or subroutine"); + if (funit->isMainProgram()) { + genExitRoutine(); + return; + } + mlir::Location loc = toLocation(); + if (stmt.v) { + // Alternate return statement - If this is a subroutine where some + // alternate entries have alternate returns, but the active entry point + // does not, ignore the alternate return value. Otherwise, assign it + // to the compiler-generated result variable. + const Fortran::semantics::Symbol &symbol = funit->getSubprogramSymbol(); + if (Fortran::semantics::HasAlternateReturns(symbol)) { + Fortran::lower::StatementContext stmtCtx; + const Fortran::lower::SomeExpr *expr = + Fortran::semantics::GetExpr(*stmt.v); + assert(expr && "missing alternate return expression"); + mlir::Value altReturnIndex = builder->createConvert( + loc, builder->getIndexType(), createFIRExpr(loc, expr, stmtCtx)); + builder->create(loc, altReturnIndex, + getAltReturnResult(symbol)); + } + } + // Branch to the last block of the SUBROUTINE, which has the actual return. + if (!funit->finalBlock) { + mlir::OpBuilder::InsertPoint insPt = builder->saveInsertionPoint(); + funit->finalBlock = builder->createBlock(&builder->getRegion()); + builder->restoreInsertionPoint(insPt); + } + builder->create(loc, funit->finalBlock); + } + + void genFIR(const Fortran::parser::CycleStmt &) { + genFIRBranch(getEval().controlSuccessor->block); } - void genFIR(const Fortran::parser::ElsewhereStmt &stmt) { - implicitIterSpace.append(nullptr); + void genFIR(const Fortran::parser::ExitStmt &) { + genFIRBranch(getEval().controlSuccessor->block); } - void genFIR(const Fortran::parser::EndWhereStmt &) { - implicitIterSpace.shrinkStack(); + void genFIR(const Fortran::parser::GotoStmt &) { + genFIRBranch(getEval().controlSuccessor->block); } - void genFIR(const Fortran::parser::WhereStmt &stmt) { - Fortran::lower::StatementContext stmtCtx; - const auto &assign = std::get(stmt.t); - implicitIterSpace.growStack(); - implicitIterSpace.append(Fortran::semantics::GetExpr( - std::get(stmt.t))); - genAssignment(*assign.typedAssignment->v); - implicitIterSpace.shrinkStack(); + void genFIR(const Fortran::parser::EndDoStmt &) { + TODO(toLocation(), "EndDoStmt lowering"); } - void genFIR(const Fortran::parser::PointerAssignmentStmt &stmt) { - genAssignment(*stmt.typedAssignment->v); - } + // 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::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::AssignmentStmt &stmt) { - genAssignment(*stmt.typedAssignment->v); + void genFIR(const Fortran::parser::NonLabelDoStmt &) { + TODO(toLocation(), "NonLabelDoStmt lowering"); } - void genFIR(const Fortran::parser::SyncAllStmt &stmt) { - TODO(toLocation(), "SyncAllStmt lowering"); + void genFIR(const Fortran::parser::OmpEndLoopDirective &) { + TODO(toLocation(), "OmpEndLoopDirective lowering"); } - void genFIR(const Fortran::parser::SyncImagesStmt &stmt) { - TODO(toLocation(), "SyncImagesStmt lowering"); + void genFIR(const Fortran::parser::NamelistStmt &) { + TODO(toLocation(), "NamelistStmt lowering"); } - void genFIR(const Fortran::parser::SyncMemoryStmt &stmt) { - TODO(toLocation(), "SyncMemoryStmt lowering"); - } + /// Generate FIR for the Evaluation `eval`. + void genFIR(Fortran::lower::pft::Evaluation &eval, + bool unstructuredContext = true) { + if (unstructuredContext) { + // When transitioning from unstructured to structured code, + // the structured code could be a target that starts a new block. + maybeStartBlock(eval.isConstruct() && eval.lowerAsStructured() + ? eval.getFirstNestedEvaluation().block + : eval.block); + } - void genFIR(const Fortran::parser::SyncTeamStmt &stmt) { - TODO(toLocation(), "SyncTeamStmt lowering"); + setCurrentEval(eval); + setCurrentPosition(eval.position); + eval.visit([&](const auto &stmt) { genFIR(stmt); }); + + if (unstructuredContext && blockIsUnterminated()) { + // Exit from an unstructured IF or SELECT construct block. + Fortran::lower::pft::Evaluation *successor{}; + if (eval.isActionStmt()) + successor = eval.controlSuccessor; + else if (eval.isConstruct() && + eval.getLastNestedEvaluation() + .lexicalSuccessor->isIntermediateConstructStmt()) + successor = eval.constructExit; + if (successor && successor->block) + genFIRBranch(successor->block); + } } - void genFIR(const Fortran::parser::UnlockStmt &stmt) { - TODO(toLocation(), "UnlockStmt lowering"); + /// 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())); + } } - void genFIR(const Fortran::parser::AssignStmt &stmt) { - const Fortran::semantics::Symbol &symbol = - *std::get(stmt.t).symbol; - mlir::Location loc = toLocation(); - mlir::Value labelValue = builder->createIntegerConstant( - loc, genType(symbol), std::get(stmt.t)); - builder->create(loc, labelValue, getSymbolAddress(symbol)); + /// 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); } - void genFIR(const Fortran::parser::FormatStmt &) { - // do nothing. + /// 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); + } - // FORMAT statements have no semantics. They may be lowered if used by a - // data transfer statement. + if (Fortran::lower::pft::Evaluation *alternateEntryEval = + funit.getEntryEval()) + genFIRBranch(alternateEntryEval->lexicalSuccessor->block); } - void genFIR(const Fortran::parser::PauseStmt &stmt) { - genPauseStatement(*this, stmt); + /// 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); + } + } + } } - void genFIR(const Fortran::parser::FailImageStmt &stmt) { - TODO(toLocation(), "FailImageStmt lowering"); + /// Return the predicate: "current block does not have a terminator branch". + bool blockIsUnterminated() { + mlir::Block *currentBlock = builder->getBlock(); + return currentBlock->empty() || + !currentBlock->back().hasTrait(); } - // call STOP, ERROR STOP in runtime - void genFIR(const Fortran::parser::StopStmt &stmt) { - genStopStatement(*this, stmt); + /// 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); } - void genFIR(const Fortran::parser::ReturnStmt &stmt) { - Fortran::lower::pft::FunctionLikeUnit *funit = - getEval().getOwningProcedure(); - assert(funit && "not inside main program, function or subroutine"); - if (funit->isMainProgram()) { - genExitRoutine(); - return; - } - mlir::Location loc = toLocation(); - if (stmt.v) { - // Alternate return statement - If this is a subroutine where some - // alternate entries have alternate returns, but the active entry point - // does not, ignore the alternate return value. Otherwise, assign it - // to the compiler-generated result variable. - const Fortran::semantics::Symbol &symbol = funit->getSubprogramSymbol(); - if (Fortran::semantics::HasAlternateReturns(symbol)) { - Fortran::lower::StatementContext stmtCtx; - const Fortran::lower::SomeExpr *expr = - Fortran::semantics::GetExpr(*stmt.v); - assert(expr && "missing alternate return expression"); - mlir::Value altReturnIndex = builder->createConvert( - loc, builder->getIndexType(), createFIRExpr(loc, expr, stmtCtx)); - builder->create(loc, altReturnIndex, - getAltReturnResult(symbol)); - } - } - // Branch to the last block of the SUBROUTINE, which has the actual return. - if (!funit->finalBlock) { - mlir::OpBuilder::InsertPoint insPt = builder->saveInsertionPoint(); - funit->finalBlock = builder->createBlock(&builder->getRegion()); - builder->restoreInsertionPoint(insPt); - } - builder->create(loc, funit->finalBlock); + /// Conditionally switch code insertion to a new block. + void maybeStartBlock(mlir::Block *newBlock) { + if (newBlock) + startBlock(newBlock); } - void genFIR(const Fortran::parser::CycleStmt &) { - TODO(toLocation(), "CycleStmt lowering"); + /// 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(); } - void genFIR(const Fortran::parser::ExitStmt &) { - TODO(toLocation(), "ExitStmt lowering"); + /// 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(); } - - void genFIR(const Fortran::parser::GotoStmt &) { - genFIRBranch(getEval().controlSuccessor->block); + /// 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); + } + } + }); } - void genFIR(const Fortran::parser::ElseIfStmt &) { - TODO(toLocation(), "ElseIfStmt lowering"); + /// 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 } - void genFIR(const Fortran::parser::ElseStmt &) { - TODO(toLocation(), "ElseStmt lowering"); + /// 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); + }); } - void genFIR(const Fortran::parser::EndDoStmt &) { - TODO(toLocation(), "EndDoStmt lowering"); + /// Lower functions contained in a module. + void lowerMod(Fortran::lower::pft::ModuleLikeUnit &mod) { + for (Fortran::lower::pft::FunctionLikeUnit &f : mod.nestedFunctions) + lowerFunc(f); } - void genFIR(const Fortran::parser::EndMpSubprogramStmt &) { - TODO(toLocation(), "EndMpSubprogramStmt lowering"); + void setCurrentPosition(const Fortran::parser::CharBlock &position) { + if (position != Fortran::parser::CharBlock{}) + currentPosition = position; } - // 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"); + /// 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)); } - void genFIR(const Fortran::parser::IfThenStmt &) { - TODO(toLocation(), "IfThenStmt lowering"); - } + //===--------------------------------------------------------------------===// + // Utility methods + //===--------------------------------------------------------------------===// - void genFIR(const Fortran::parser::NonLabelDoStmt &) { - TODO(toLocation(), "NonLabelDoStmt lowering"); + /// Convert a parser CharBlock to a Location + mlir::Location toLocation(const Fortran::parser::CharBlock &cb) { + return genLocation(cb); } - void genFIR(const Fortran::parser::OmpEndLoopDirective &) { - TODO(toLocation(), "OmpEndLoopDirective lowering"); + mlir::Location toLocation() { return toLocation(currentPosition); } + void setCurrentEval(Fortran::lower::pft::Evaluation &eval) { + evalPtr = &eval; } - - void genFIR(const Fortran::parser::NamelistStmt &) { - TODO(toLocation(), "NamelistStmt lowering"); + Fortran::lower::pft::Evaluation &getEval() { + assert(evalPtr); + return *evalPtr; } - /// Generate FIR for the Evaluation `eval`. - void genFIR(Fortran::lower::pft::Evaluation &eval, - bool unstructuredContext = true) { - if (unstructuredContext) { - // When transitioning from unstructured to structured code, - // the structured code could be a target that starts a new block. - maybeStartBlock(eval.isConstruct() && eval.lowerAsStructured() - ? eval.getFirstNestedEvaluation().block - : eval.block); - } - - setCurrentEval(eval); - setCurrentPosition(eval.position); - eval.visit([&](const auto &stmt) { genFIR(stmt); }); - - if (unstructuredContext && blockIsUnterminated()) { - // Exit from an unstructured IF or SELECT construct block. - Fortran::lower::pft::Evaluation *successor{}; - if (eval.isActionStmt()) - successor = eval.controlSuccessor; - else if (eval.isConstruct() && - eval.getLastNestedEvaluation() - .lexicalSuccessor->isIntermediateConstructStmt()) - successor = eval.constructExit; - if (successor && successor->block) - genFIRBranch(successor->block); - } + std::optional + getShape(const Fortran::lower::SomeExpr &expr) { + return Fortran::evaluate::GetShape(foldingContext, expr); } //===--------------------------------------------------------------------===// @@ -2568,6 +2607,8 @@ }); } + void createRuntimeTypeInfoGlobals() {} + //===--------------------------------------------------------------------===// Fortran::lower::LoweringBridge &bridge; @@ -2578,10 +2619,16 @@ Fortran::parser::CharBlock currentPosition; RuntimeTypeInfoConverter runtimeTypeInfoConverter; - /// Tuple of host assoicated variables. - mlir::Value hostAssocTuple; + /// WHERE statement/construct mask expression stack. Fortran::lower::ImplicitIterSpace implicitIterSpace; + + /// FORALL context Fortran::lower::ExplicitIterSpace explicitIterSpace; + + /// Tuple of host assoicated variables. + mlir::Value hostAssocTuple; + + std::size_t constructDepth = 0; }; } // namespace @@ -2602,6 +2649,13 @@ 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 @@ default: break; } - if (!diag.getLocation().isa()) + if (!diag.getLocation().isa()) os << diag.getLocation() << ": "; os << diag << '\n'; os.flush(); @@ -2637,6 +2691,6 @@ 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 --- a/flang/lib/Lower/CallInterface.cpp +++ b/flang/lib/Lower/CallInterface.cpp @@ -239,11 +239,10 @@ 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 @@ 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 @@ 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 @@ 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 --- 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 @@ 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 @@ } ExtValue genval(const Fortran::evaluate::BOZLiteralConstant &) { - TODO(getLoc(), "genval BOZ"); + TODO(getLoc(), "BOZ"); } /// Return indirection to function designated in ProcedureDesignator. @@ -1024,12 +1039,17 @@ } 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 @@ 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 @@ 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 @@ 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 @@ return genScalarLit(opt.value()); } } - fir::ExtendedValue genval( const Fortran::evaluate::Constant &con) { if (con.Rank() > 0) @@ -1540,14 +1615,27 @@ 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 @@ } fir::emitFatalError(getLoc(), "subscript triple notation is not scalar"); } - ExtValue genSubscript(const Fortran::evaluate::Subscript &subs) { return genval(subs); } @@ -1629,13 +1716,12 @@ 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 @@ // 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 @@ return genLoad(gen(cmpt)); } + // 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(); + } + + // Generate the code for a Bound value. ExtValue genval(const Fortran::semantics::Bound &bound) { - TODO(getLoc(), "genval Bound"); - } - - /// 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); + 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 @@ 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 @@ 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 @@ // 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,157 +3017,31 @@ 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); + template + bool isScalar(const A &x) { + return x.Rank() == 0; } - /// 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)); + /// Helper to detect Transformational function reference. + template + bool isTransformationalRef(const T &) { + return false; + } + template + bool isTransformationalRef(const Fortran::evaluate::FunctionRef &funcRef) { + return !funcRef.IsElemental() && funcRef.Rank(); + } + template + bool isTransformationalRef(Fortran::evaluate::Expr expr) { + return std::visit([&](const auto &e) { return isTransformationalRef(e); }, + expr.u); } - /// 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; - } - - /// Helper to detect Transformational function reference. - template - bool isTransformationalRef(const T &) { - return false; - } - template - bool isTransformationalRef(const Fortran::evaluate::FunctionRef &funcRef) { - return !funcRef.IsElemental() && funcRef.Rank(); - } - template - bool isTransformationalRef(Fortran::evaluate::Expr expr) { - return std::visit([&](const auto &e) { return isTransformationalRef(e); }, - expr.u); - } - - template - ExtValue asArray(const A &x) { - return Fortran::lower::createSomeArrayTempValue(converter, toEvExpr(x), - symMap, stmtCtx); - } + template + ExtValue asArray(const A &x) { + return Fortran::lower::createSomeArrayTempValue(converter, toEvExpr(x), + symMap, stmtCtx); + } /// Lower an array value as an argument. This argument can be passed as a box /// value, so it may be possible to avoid making a temporary. @@ -3025,24 +3153,8 @@ 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 @@ 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,63 +3788,331 @@ return lexv; } - bool explicitSpaceIsActive() const { - return explicitSpace && explicitSpace->isActive(); +private: + void determineShapeOfDest(const fir::ExtendedValue &lhs) { + destShape = fir::factory::getExtents(builder, getLoc(), lhs); } - bool implicitSpaceHasMasks() const { - return implicitSpace && !implicitSpace->empty(); + 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)); } - CC genMaskAccess(mlir::Value tmp, mlir::Value shape) { + 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(); - return [=, builder = &converter.getFirOpBuilder()](IterSpace iters) { - mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(tmp.getType()); - auto eleTy = arrTy.cast().getEleTy(); - mlir::Type eleRefTy = builder->getRefType(eleTy); - mlir::IntegerType i1Ty = builder->getI1Type(); - // Adjust indices for any shift of the origin of the array. - llvm::SmallVector indices = fir::factory::originateIndices( - loc, *builder, tmp.getType(), shape, iters.iterVec()); - auto addr = builder->create( - loc, eleRefTy, tmp, shape, /*slice=*/mlir::Value{}, indices, - /*typeParams=*/llvm::None); - auto load = builder->create(loc, addr); - return builder->createConvert(loc, i1Ty, load); - }; + 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); } - /// Construct the incremental instantiations of the ragged array structure. - /// Rebind the lazy buffer variable, etc. as we go. - template - mlir::Value prepareRaggedArrays(Fortran::lower::FrontEndExpr expr) { - assert(explicitSpaceIsActive()); - mlir::Location loc = getLoc(); - mlir::TupleType raggedTy = fir::factory::getRaggedArrayHeaderType(builder); - llvm::SmallVector> loopStack = - explicitSpace->getLoopStack(); - const std::size_t depth = loopStack.size(); - mlir::IntegerType i64Ty = builder.getIntegerType(64); - [[maybe_unused]] mlir::Value byteSize = - builder.createIntegerConstant(loc, i64Ty, 1); - mlir::Value header = implicitSpace->lookupMaskHeader(expr); - for (std::remove_const_t i = 0; i < depth; ++i) { - auto insPt = builder.saveInsertionPoint(); - if (i < depth - 1) - builder.setInsertionPoint(loopStack[i + 1][0]); + /// 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; + } - // Compute and gather the extents. - llvm::SmallVector extents; - for (auto doLoop : loopStack[i]) - extents.push_back(builder.genExtentFromTriplet( - loc, doLoop.getLowerBound(), doLoop.getUpperBound(), - doLoop.getStep(), i64Ty)); - if constexpr (withAllocation) { - fir::runtime::genRaggedArrayAllocate( - loc, builder, header, /*asHeader=*/true, byteSize, extents); - } + /// 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); + } - // Compute the dynamic position into the header. + 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(); + } + + bool implicitSpaceHasMasks() const { + return implicitSpace && !implicitSpace->empty(); + } + + CC genMaskAccess(mlir::Value tmp, mlir::Value shape) { + mlir::Location loc = getLoc(); + return [=, builder = &converter.getFirOpBuilder()](IterSpace iters) { + mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(tmp.getType()); + auto eleTy = arrTy.cast().getEleTy(); + mlir::Type eleRefTy = builder->getRefType(eleTy); + mlir::IntegerType i1Ty = builder->getI1Type(); + // Adjust indices for any shift of the origin of the array. + llvm::SmallVector indices = fir::factory::originateIndices( + loc, *builder, tmp.getType(), shape, iters.iterVec()); + auto addr = builder->create( + loc, eleRefTy, tmp, shape, /*slice=*/mlir::Value{}, indices, + /*typeParams=*/llvm::None); + auto load = builder->create(loc, addr); + return builder->createConvert(loc, i1Ty, load); + }; + } + + /// Construct the incremental instantiations of the ragged array structure. + /// Rebind the lazy buffer variable, etc. as we go. + template + mlir::Value prepareRaggedArrays(Fortran::lower::FrontEndExpr expr) { + assert(explicitSpaceIsActive()); + mlir::Location loc = getLoc(); + mlir::TupleType raggedTy = fir::factory::getRaggedArrayHeaderType(builder); + llvm::SmallVector> loopStack = + explicitSpace->getLoopStack(); + const std::size_t depth = loopStack.size(); + mlir::IntegerType i64Ty = builder.getIntegerType(64); + [[maybe_unused]] mlir::Value byteSize = + builder.createIntegerConstant(loc, i64Ty, 1); + mlir::Value header = implicitSpace->lookupMaskHeader(expr); + for (std::remove_const_t i = 0; i < depth; ++i) { + auto insPt = builder.saveInsertionPoint(); + if (i < depth - 1) + builder.setInsertionPoint(loopStack[i + 1][0]); + + // Compute and gather the extents. + llvm::SmallVector extents; + for (auto doLoop : loopStack[i]) + extents.push_back(builder.genExtentFromTriplet( + loc, doLoop.getLowerBound(), doLoop.getUpperBound(), + doLoop.getStep(), i64Ty)); + if constexpr (withAllocation) { + fir::runtime::genRaggedArrayAllocate( + loc, builder, header, /*asHeader=*/true, byteSize, extents); + } + + // Compute the dynamic position into the header. llvm::SmallVector offsets; for (auto doLoop : loopStack[i]) { auto m = builder.create( @@ -3952,7 +4351,7 @@ 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 @@ .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 @@ 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 @@ 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,27 +4986,63 @@ 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"); - } - - /// Fortran's concatenation operator `//`. - template - CC genarr(const Fortran::evaluate::Concat &x) { mlir::Location loc = getLoc(); auto lf = genarr(x.left()); auto rf = genarr(x.right()); return [=](IterSpace iters) -> ExtValue { - auto lhs = lf(iters); + 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 `//`. + template + CC genarr(const Fortran::evaluate::Concat &x) { + mlir::Location loc = getLoc(); + auto lf = genarr(x.left()); + auto rf = genarr(x.right()); + return [=](IterSpace iters) -> ExtValue { + auto lhs = lf(iters); auto rhs = rf(iters); const fir::CharBoxValue *lchr = lhs.getCharBox(); const fir::CharBoxValue *rchr = rhs.getCharBox(); @@ -4748,7 +5192,7 @@ 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 @@ 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,1567 +5444,1323 @@ return genarr(extMemref, dummy); } - //===--------------------------------------------------------------------===// - // Array construction - //===--------------------------------------------------------------------===// - - /// Target agnostic computation of the size of an element in the array. - /// Returns the size in bytes with type `index` or a null Value if the element - /// size is not constant. - mlir::Value computeElementSize(const ExtValue &exv, mlir::Type eleTy, - mlir::Type resTy) { + /// Base case of generating an array reference, + CC genarr(const ExtValue &extMemref, ComponentPath &components) { mlir::Location loc = getLoc(); - mlir::IndexType idxTy = builder.getIndexType(); - mlir::Value multiplier = builder.createIntegerConstant(loc, idxTy, 1); - if (fir::hasDynamicSize(eleTy)) { - if (auto charTy = eleTy.dyn_cast()) { - // Array of char with dynamic length parameter. Downcast to an array - // of singleton char, and scale by the len type parameter from - // `exv`. - exv.match( - [&](const fir::CharBoxValue &cb) { multiplier = cb.getLen(); }, - [&](const fir::CharArrayBoxValue &cb) { multiplier = cb.getLen(); }, - [&](const fir::BoxValue &box) { - multiplier = fir::factory::CharacterExprHelper(builder, loc) - .readLengthFromBox(box.getAddr()); - }, - [&](const fir::MutableBoxValue &box) { - multiplier = fir::factory::CharacterExprHelper(builder, loc) - .readLengthFromBox(box.getAddr()); - }, - [&](const auto &) { - fir::emitFatalError(loc, - "array constructor element has unknown size"); - }); - fir::CharacterType newEleTy = fir::CharacterType::getSingleton( - eleTy.getContext(), charTy.getFKind()); - if (auto seqTy = resTy.dyn_cast()) { - assert(eleTy == seqTy.getEleTy()); - resTy = fir::SequenceType::get(seqTy.getShape(), newEleTy); + 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()); + } } - eleTy = newEleTy; + // 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 { - TODO(loc, "dynamic sized type"); + slice = builder.createSlice(loc, extMemref, components.trips, + components.suffixComponents); } - } - mlir::Type eleRefTy = builder.getRefType(eleTy); - mlir::Type resRefTy = builder.getRefType(resTy); - mlir::Value nullPtr = builder.createNullConstant(loc, resRefTy); - auto offset = builder.create( - loc, eleRefTy, nullPtr, mlir::ValueRange{multiplier}); - return builder.createConvert(loc, idxTy, offset); - } - - /// Get the function signature of the LLVM memcpy intrinsic. - mlir::FunctionType memcpyType() { - return fir::factory::getLlvmMemcpy(builder).getFunctionType(); - } - - /// Create a call to the LLVM memcpy intrinsic. - void createCallMemcpy(llvm::ArrayRef args) { - mlir::Location loc = getLoc(); - mlir::FuncOp memcpyFunc = fir::factory::getLlvmMemcpy(builder); - mlir::SymbolRefAttr funcSymAttr = - builder.getSymbolRefAttr(memcpyFunc.getName()); - mlir::FunctionType funcTy = memcpyFunc.getFunctionType(); - builder.create(loc, funcTy.getResults(), funcSymAttr, args); - } - - // Construct code to check for a buffer overrun and realloc the buffer when - // space is depleted. This is done between each item in the ac-value-list. - mlir::Value growBuffer(mlir::Value mem, mlir::Value needed, - mlir::Value bufferSize, mlir::Value buffSize, - mlir::Value eleSz) { - mlir::Location loc = getLoc(); - mlir::FuncOp reallocFunc = fir::factory::getRealloc(builder); - auto cond = builder.create( - loc, mlir::arith::CmpIPredicate::sle, bufferSize, needed); - auto ifOp = builder.create(loc, mem.getType(), cond, - /*withElseRegion=*/true); - auto insPt = builder.saveInsertionPoint(); - builder.setInsertionPointToStart(&ifOp.getThenRegion().front()); - // Not enough space, resize the buffer. - mlir::IndexType idxTy = builder.getIndexType(); - mlir::Value two = builder.createIntegerConstant(loc, idxTy, 2); - auto newSz = builder.create(loc, needed, two); - builder.create(loc, newSz, buffSize); - mlir::Value byteSz = builder.create(loc, newSz, eleSz); - mlir::SymbolRefAttr funcSymAttr = - builder.getSymbolRefAttr(reallocFunc.getName()); - mlir::FunctionType funcTy = reallocFunc.getFunctionType(); - auto newMem = builder.create( - loc, funcTy.getResults(), funcSymAttr, - llvm::ArrayRef{ - builder.createConvert(loc, funcTy.getInputs()[0], mem), - builder.createConvert(loc, funcTy.getInputs()[1], byteSz)}); - mlir::Value castNewMem = - builder.createConvert(loc, mem.getType(), newMem.getResult(0)); - builder.create(loc, castNewMem); - builder.setInsertionPointToStart(&ifOp.getElseRegion().front()); - // Otherwise, just forward the buffer. - builder.create(loc, mem); - builder.restoreInsertionPoint(insPt); - return ifOp.getResult(0); - } - - /// Copy the next value (or vector of values) into the array being - /// constructed. - mlir::Value copyNextArrayCtorSection(const ExtValue &exv, mlir::Value buffPos, - mlir::Value buffSize, mlir::Value mem, - mlir::Value eleSz, mlir::Type eleTy, - mlir::Type eleRefTy, mlir::Type resTy) { - mlir::Location loc = getLoc(); - auto off = builder.create(loc, buffPos); - auto limit = builder.create(loc, buffSize); - mlir::IndexType idxTy = builder.getIndexType(); - mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1); - - if (fir::isRecordWithAllocatableMember(eleTy)) - TODO(loc, "deep copy on allocatable members"); + 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()); - if (!eleSz) { - // Compute the element size at runtime. - assert(fir::hasDynamicSize(eleTy)); - if (auto charTy = eleTy.dyn_cast()) { - auto charBytes = - builder.getKindMap().getCharacterBitsize(charTy.getFKind()) / 8; - mlir::Value bytes = - builder.createIntegerConstant(loc, idxTy, charBytes); - mlir::Value length = fir::getLen(exv); - if (!length) - fir::emitFatalError(loc, "result is not boxed character"); - eleSz = builder.create(loc, bytes, length); - } else { - TODO(loc, "PDT size"); - // Will call the PDT's size function with the type parameters. + // 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'); } } - - // Compute the coordinate using `fir.coordinate_of`, or, if the type has - // dynamic size, generating the pointer arithmetic. - auto computeCoordinate = [&](mlir::Value buff, mlir::Value off) { - mlir::Type refTy = eleRefTy; - if (fir::hasDynamicSize(eleTy)) { - if (auto charTy = eleTy.dyn_cast()) { - // Scale a simple pointer using dynamic length and offset values. - auto chTy = fir::CharacterType::getSingleton(charTy.getContext(), - charTy.getFKind()); - refTy = builder.getRefType(chTy); - mlir::Type toTy = builder.getRefType(builder.getVarLenSeqTy(chTy)); - buff = builder.createConvert(loc, toTy, buff); - off = builder.create(loc, off, eleSz); - } else { - TODO(loc, "PDT offset"); - } + 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())); } - auto coor = builder.create(loc, refTy, buff, - mlir::ValueRange{off}); - return builder.createConvert(loc, eleRefTy, coor); - }; - - // Lambda to lower an abstract array box value. - auto doAbstractArray = [&](const auto &v) { - // Compute the array size. - mlir::Value arrSz = one; - for (auto ext : v.getExtents()) - arrSz = builder.create(loc, arrSz, ext); - - // Grow the buffer as needed. - auto endOff = builder.create(loc, off, arrSz); - mem = growBuffer(mem, endOff, limit, buffSize, eleSz); - - // Copy the elements to the buffer. - mlir::Value byteSz = - builder.create(loc, arrSz, eleSz); - auto buff = builder.createConvert(loc, fir::HeapType::get(resTy), mem); - mlir::Value buffi = computeCoordinate(buff, off); - llvm::SmallVector args = fir::runtime::createArguments( - builder, loc, memcpyType(), buffi, v.getAddr(), byteSz, - /*volatile=*/builder.createBool(loc, false)); - createCallMemcpy(args); - - // Save the incremented buffer position. - builder.create(loc, endOff, buffPos); - }; - - // Copy a trivial scalar value into the buffer. - auto doTrivialScalar = [&](const ExtValue &v, mlir::Value len = {}) { - // Increment the buffer position. - auto plusOne = builder.create(loc, off, one); - - // Grow the buffer as needed. - mem = growBuffer(mem, plusOne, limit, buffSize, eleSz); - - // Store the element in the buffer. - mlir::Value buff = - builder.createConvert(loc, fir::HeapType::get(resTy), mem); - auto buffi = builder.create(loc, eleRefTy, buff, - mlir::ValueRange{off}); - fir::factory::genScalarAssignment( - builder, loc, - [&]() -> ExtValue { - if (len) - return fir::CharBoxValue(buffi, len); - return buffi; - }(), - v); - builder.create(loc, plusOne, buffPos); - }; - - // Copy the value. - exv.match( - [&](mlir::Value) { doTrivialScalar(exv); }, - [&](const fir::CharBoxValue &v) { - auto buffer = v.getBuffer(); - if (fir::isa_char(buffer.getType())) { - doTrivialScalar(exv, eleSz); - } else { - // Increment the buffer position. - auto plusOne = builder.create(loc, off, one); - - // Grow the buffer as needed. - mem = growBuffer(mem, plusOne, limit, buffSize, eleSz); - - // Store the element in the buffer. - mlir::Value buff = - builder.createConvert(loc, fir::HeapType::get(resTy), mem); - mlir::Value buffi = computeCoordinate(buff, off); - llvm::SmallVector args = fir::runtime::createArguments( - builder, loc, memcpyType(), buffi, v.getAddr(), eleSz, - /*volatile=*/builder.createBool(loc, false)); - createCallMemcpy(args); - - builder.create(loc, plusOne, buffPos); + 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); } - }, - [&](const fir::ArrayBoxValue &v) { doAbstractArray(v); }, - [&](const fir::CharArrayBoxValue &v) { doAbstractArray(v); }, - [&](const auto &) { - TODO(loc, "unhandled array constructor expression"); - }); - return mem; - } - - // Lower the expr cases in an ac-value-list. - template - std::pair - genArrayCtorInitializer(const Fortran::evaluate::Expr &x, mlir::Type, - mlir::Value, mlir::Value, mlir::Value, - Fortran::lower::StatementContext &stmtCtx) { - if (isArray(x)) - return {lowerNewArrayExpression(converter, symMap, stmtCtx, toEvExpr(x)), - /*needCopy=*/true}; - return {asScalar(x), /*needCopy=*/true}; - } - - // Lower an ac-implied-do in an ac-value-list. - template - std::pair - genArrayCtorInitializer(const Fortran::evaluate::ImpliedDo &x, - mlir::Type resTy, mlir::Value mem, - mlir::Value buffPos, mlir::Value buffSize, - Fortran::lower::StatementContext &) { - mlir::Location loc = getLoc(); - mlir::IndexType idxTy = builder.getIndexType(); - mlir::Value lo = - builder.createConvert(loc, idxTy, fir::getBase(asScalar(x.lower()))); - mlir::Value up = - builder.createConvert(loc, idxTy, fir::getBase(asScalar(x.upper()))); - mlir::Value step = - builder.createConvert(loc, idxTy, fir::getBase(asScalar(x.stride()))); - auto seqTy = resTy.template cast(); - mlir::Type eleTy = fir::unwrapSequenceType(seqTy); - auto loop = - builder.create(loc, lo, up, step, /*unordered=*/false, - /*finalCount=*/false, mem); - // create a new binding for x.name(), to ac-do-variable, to the iteration - // value. - symMap.pushImpliedDoBinding(toStringRef(x.name()), loop.getInductionVar()); - auto insPt = builder.saveInsertionPoint(); - builder.setInsertionPointToStart(loop.getBody()); - // Thread mem inside the loop via loop argument. - mem = loop.getRegionIterArgs()[0]; - - mlir::Type eleRefTy = builder.getRefType(eleTy); - - // Any temps created in the loop body must be freed inside the loop body. - stmtCtx.pushScope(); - llvm::Optional charLen; - for (const Fortran::evaluate::ArrayConstructorValue &acv : x.values()) { - auto [exv, copyNeeded] = std::visit( - [&](const auto &v) { - return genArrayCtorInitializer(v, resTy, mem, buffPos, buffSize, - stmtCtx); - }, - acv.u); - mlir::Value eleSz = computeElementSize(exv, eleTy, resTy); - mem = copyNeeded ? copyNextArrayCtorSection(exv, buffPos, buffSize, mem, - eleSz, eleTy, eleRefTy, resTy) - : fir::getBase(exv); - if (fir::isa_char(seqTy.getEleTy()) && !charLen.hasValue()) { - charLen = builder.createTemporary(loc, builder.getI64Type()); - mlir::Value castLen = - builder.createConvert(loc, builder.getI64Type(), fir::getLen(exv)); - builder.create(loc, castLen, charLen.getValue()); - } + } + return fir::factory::arraySectionElementToExtendedValue( + builder, loc, extMemref, coor, slice); + }; } - stmtCtx.finalize(/*popScope=*/true); - - builder.create(loc, mem); - builder.restoreInsertionPoint(insPt); - mem = loop.getResult(0); - symMap.popImpliedDoBinding(); - llvm::SmallVector extents = { - builder.create(loc, buffPos).getResult()}; - - // Convert to extended value. - if (fir::isa_char(seqTy.getEleTy())) { - auto len = builder.create(loc, charLen.getValue()); - return {fir::CharArrayBoxValue{mem, len, extents}, /*needCopy=*/false}; + 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); }; } - return {fir::ArrayBoxValue{mem, extents}, /*needCopy=*/false}; - } - - // To simplify the handling and interaction between the various cases, array - // constructors are always lowered to the incremental construction code - // pattern, even if the extent of the array value is constant. After the - // MemToReg pass and constant folding, the optimizer should be able to - // determine that all the buffer overrun tests are false when the - // incremental construction wasn't actually required. - template - CC genarr(const Fortran::evaluate::ArrayConstructor &x) { - mlir::Location loc = getLoc(); - auto evExpr = toEvExpr(x); - mlir::Type resTy = translateSomeExprToFIRType(converter, evExpr); - mlir::IndexType idxTy = builder.getIndexType(); - auto seqTy = resTy.template cast(); - mlir::Type eleTy = fir::unwrapSequenceType(resTy); - mlir::Value buffSize = builder.createTemporary(loc, idxTy, ".buff.size"); - mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0); - mlir::Value buffPos = builder.createTemporary(loc, idxTy, ".buff.pos"); - builder.create(loc, zero, buffPos); - // Allocate space for the array to be constructed. - mlir::Value mem; - if (fir::hasDynamicSize(resTy)) { - if (fir::hasDynamicSize(eleTy)) { - // The size of each element may depend on a general expression. Defer - // creating the buffer until after the expression is evaluated. - mem = builder.createNullConstant(loc, builder.getRefType(eleTy)); - builder.create(loc, zero, buffSize); - } else { - mlir::Value initBuffSz = - builder.createIntegerConstant(loc, idxTy, clInitialBufferSize); - mem = builder.create( - loc, eleTy, /*typeparams=*/llvm::None, initBuffSz); - builder.create(loc, initBuffSz, buffSize); - } - } else { - mem = builder.create(loc, resTy); - int64_t buffSz = 1; - for (auto extent : seqTy.getShape()) - buffSz *= extent; - mlir::Value initBuffSz = - builder.createIntegerConstant(loc, idxTy, buffSz); - builder.create(loc, initBuffSz, buffSize); + 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)); + }; } - // Compute size of element - mlir::Type eleRefTy = builder.getRefType(eleTy); - - // Populate the buffer with the elements, growing as necessary. - llvm::Optional charLen; - for (const auto &expr : x) { - auto [exv, copyNeeded] = std::visit( - [&](const auto &e) { - return genArrayCtorInitializer(e, resTy, mem, buffPos, buffSize, - stmtCtx); - }, - expr.u); - mlir::Value eleSz = computeElementSize(exv, eleTy, resTy); - mem = copyNeeded ? copyNextArrayCtorSection(exv, buffPos, buffSize, mem, - eleSz, eleTy, eleRefTy, resTy) - : fir::getBase(exv); - if (fir::isa_char(seqTy.getEleTy()) && !charLen.hasValue()) { - charLen = builder.createTemporary(loc, builder.getI64Type()); - mlir::Value castLen = - builder.createConvert(loc, builder.getI64Type(), fir::getLen(exv)); - builder.create(loc, castLen, charLen.getValue()); - } + 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; }; } - mem = builder.createConvert(loc, fir::HeapType::get(resTy), mem); - llvm::SmallVector extents = { - builder.create(loc, buffPos)}; - - // Cleanup the temporary. - fir::FirOpBuilder *bldr = &converter.getFirOpBuilder(); - stmtCtx.attachCleanup( - [bldr, loc, mem]() { bldr->create(loc, mem); }); - - // Return the continuation. - if (fir::isa_char(seqTy.getEleTy())) { - if (charLen.hasValue()) { - auto len = builder.create(loc, charLen.getValue()); - return genarr(fir::CharArrayBoxValue{mem, len, extents}); - } - return genarr(fir::CharArrayBoxValue{mem, zero, extents}); + 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); + }; } - return genarr(fir::ArrayBoxValue{mem, extents}); - } - - CC genarr(const Fortran::evaluate::ImpliedDoIndex &) { - TODO(getLoc(), "genarr ImpliedDoIndex"); - } - - CC genarr(const Fortran::evaluate::TypeParamInquiry &x) { - TODO(getLoc(), "genarr TypeParamInquiry"); - } - - CC genarr(const Fortran::evaluate::DescriptorInquiry &x) { - TODO(getLoc(), "genarr DescriptorInquiry"); - } - - CC genarr(const Fortran::evaluate::StructureConstructor &x) { - TODO(getLoc(), "genarr StructureConstructor"); - } - - //===--------------------------------------------------------------------===// - // LOCICAL operators (.NOT., .AND., .EQV., etc.) - //===--------------------------------------------------------------------===// - - template - CC genarr(const Fortran::evaluate::Not &x) { - mlir::Location loc = getLoc(); - mlir::IntegerType i1Ty = builder.getI1Type(); - auto lambda = genarr(x.left()); - mlir::Value truth = builder.createBool(loc, true); + // In the default case, the array reference forwards an `array_fetch` or + // `array_access` Op in the continuation. return [=](IterSpace iters) -> ExtValue { - mlir::Value logical = fir::getBase(lambda(iters)); - mlir::Value val = builder.createConvert(loc, i1Ty, logical); - return builder.create(loc, val, truth); + 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); }; } - template - CC createBinaryBoolOp(const A &x) { - mlir::Location loc = getLoc(); - mlir::IntegerType i1Ty = builder.getI1Type(); - auto lf = genarr(x.left()); - auto rf = genarr(x.right()); - return [=](IterSpace iters) -> ExtValue { - mlir::Value left = fir::getBase(lf(iters)); - mlir::Value right = fir::getBase(rf(iters)); - mlir::Value lhs = builder.createConvert(loc, i1Ty, left); - mlir::Value rhs = builder.createConvert(loc, i1Ty, right); - return builder.create(loc, lhs, rhs); - }; + + /// 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); } - template - CC createCompareBoolOp(mlir::arith::CmpIPredicate pred, const A &x) { + + std::tuple + genOptionalArrayFetch(const Fortran::lower::SomeExpr &expr) { + assert(expr.Rank() > 0 && "expr must be an array"); mlir::Location loc = getLoc(); - mlir::IntegerType i1Ty = builder.getI1Type(); - auto lf = genarr(x.left()); - auto rf = genarr(x.right()); - return [=](IterSpace iters) -> ExtValue { - mlir::Value left = fir::getBase(lf(iters)); - mlir::Value right = fir::getBase(rf(iters)); - mlir::Value lhs = builder.createConvert(loc, i1Ty, left); - mlir::Value rhs = builder.createConvert(loc, i1Ty, right); - return builder.create(loc, pred, lhs, rhs); - }; - } - template - CC genarr(const Fortran::evaluate::LogicalOperation &x) { - switch (x.logicalOperator) { - case Fortran::evaluate::LogicalOperator::And: - return createBinaryBoolOp(x); - case Fortran::evaluate::LogicalOperator::Or: - return createBinaryBoolOp(x); - case Fortran::evaluate::LogicalOperator::Eqv: - return createCompareBoolOp( - mlir::arith::CmpIPredicate::eq, x); - case Fortran::evaluate::LogicalOperator::Neqv: - return createCompareBoolOp( - mlir::arith::CmpIPredicate::ne, x); - case Fortran::evaluate::LogicalOperator::Not: - llvm_unreachable(".NOT. handled elsewhere"); + 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); } - llvm_unreachable("unhandled case"); - } + // 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); - //===--------------------------------------------------------------------===// - // Relational operators (<, <=, ==, etc.) - //===--------------------------------------------------------------------===// + 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()); - template - CC createCompareOp(PRED pred, const A &x) { - 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 builder.create(loc, pred, lhs, rhs); + // 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}; } - template - CC createCompareCharOp(mlir::arith::CmpIPredicate pred, const A &x) { + + /// 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(); - auto lf = genarr(x.left()); - auto rf = genarr(x.right()); - return [=](IterSpace iters) -> ExtValue { - auto lhs = lf(iters); - auto rhs = rf(iters); - return fir::runtime::genCharCompare(builder, loc, pred, lhs, rhs); - }; - } - template - CC genarr(const Fortran::evaluate::Relational> &x) { - return createCompareOp(translateRelational(x.opr), x); - } - template - CC genarr(const Fortran::evaluate::Relational> &x) { - return createCompareCharOp(translateRelational(x.opr), x); - } - template - CC genarr(const Fortran::evaluate::Relational> &x) { - return createCompareOp(translateFloatRelational(x.opr), - x); - } - template - CC genarr(const Fortran::evaluate::Relational> &x) { - return createCompareOp(translateFloatRelational(x.opr), x); - } - CC genarr( - const Fortran::evaluate::Relational &r) { - return std::visit([&](const auto &x) { return genarr(x); }, r.u); - } + // Only by-value numerical and logical so far. + if (semant != ConstituentSemantics::RefTransparent) + TODO(loc, "optional arguments in user defined elemental procedures"); - template - CC genarr(const Fortran::evaluate::Designator &des) { - ComponentPath components(des.Rank() > 0); - return std::visit([&](const auto &x) { return genarr(x, components); }, - des.u); - } + // 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; }; + } - 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)))); + 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; + }; } - //===-------------------------------------------------------------------===// - // Array data references in an explicit iteration space. - // - // Use the base array that was loaded before the loop nest. - //===-------------------------------------------------------------------===// - - /// Lower the path (`revPath`, in reverse) to be appended to an array_fetch or - /// array_update op. \p ty is the initial type of the array - /// (reference). Returns the type of the element after application of the - /// path in \p components. - /// - /// TODO: This needs to deal with array's with initial bounds other than 1. - /// TODO: Thread type parameters correctly. - mlir::Type lowerPath(const ExtValue &arrayExv, ComponentPath &components) { - mlir::Location loc = getLoc(); - mlir::Type ty = fir::getBase(arrayExv).getType(); - auto &revPath = components.reversePath; - ty = fir::unwrapPassByRefType(ty); - bool prefix = true; - auto addComponent = [&](mlir::Value v) { - if (prefix) - components.prefixComponents.push_back(v); - else - components.suffixComponents.push_back(v); - }; - mlir::IndexType idxTy = builder.getIndexType(); - mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1); - bool atBase = true; - auto saveSemant = semant; - if (isProjectedCopyInCopyOut()) - semant = ConstituentSemantics::RefTransparent; - for (const auto &v : llvm::reverse(revPath)) { - std::visit( - Fortran::common::visitors{ - [&](const ImplicitSubscripts &) { - prefix = false; - ty = fir::unwrapSequenceType(ty); - }, - [&](const Fortran::evaluate::ComplexPart *x) { - assert(!prefix && "complex part must be at end"); - mlir::Value offset = builder.createIntegerConstant( - loc, builder.getI32Type(), - x->part() == Fortran::evaluate::ComplexPart::Part::RE ? 0 - : 1); - components.suffixComponents.push_back(offset); - ty = fir::applyPathToType(ty, mlir::ValueRange{offset}); - }, - [&](const Fortran::evaluate::ArrayRef *x) { - if (Fortran::lower::isRankedArrayAccess(*x)) { - genSliceIndices(components, arrayExv, *x, atBase); - } else { - // Array access where the expressions are scalar and cannot - // depend upon the implied iteration space. - unsigned ssIndex = 0u; - for (const auto &ss : x->subscript()) { - std::visit( - Fortran::common::visitors{ - [&](const Fortran::evaluate:: - IndirectSubscriptIntegerExpr &ie) { - const auto &e = ie.value(); - if (isArray(e)) - fir::emitFatalError( - loc, - "multiple components along single path " - "generating array subexpressions"); - // Lower scalar index expression, append it to - // subs. - mlir::Value subscriptVal = - fir::getBase(asScalarArray(e)); - // arrayExv is the base array. It needs to reflect - // the current array component instead. - // FIXME: must use lower bound of this component, - // not just the constant 1. - mlir::Value lb = - atBase ? fir::factory::readLowerBound( - builder, loc, arrayExv, ssIndex, - one) - : one; - mlir::Value val = builder.createConvert( - loc, idxTy, subscriptVal); - mlir::Value ivAdj = - builder.create( - loc, idxTy, val, lb); - addComponent( - builder.createConvert(loc, idxTy, ivAdj)); - }, - [&](const auto &) { - fir::emitFatalError( - loc, "multiple components along single path " - "generating array subexpressions"); - }}, - ss.u); - ssIndex++; - } - } - ty = fir::unwrapSequenceType(ty); - }, - [&](const Fortran::evaluate::Component *x) { - auto fieldTy = fir::FieldType::get(builder.getContext()); - llvm::StringRef name = toStringRef(getLastSym(*x).name()); - auto recTy = ty.cast(); - ty = recTy.getType(name); - auto fld = builder.create( - loc, fieldTy, name, recTy, fir::getTypeParams(arrayExv)); - addComponent(fld); - }}, - v); - atBase = false; + /// 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()); } - semant = saveSemant; - ty = fir::unwrapSequenceType(ty); - components.applied = true; - return ty; + // not sliced, so no change in rank + return arrTy; } - llvm::SmallVector genSubstringBounds(ComponentPath &components) { - llvm::SmallVector result; - if (components.substring) - populateBounds(result, components.substring); - return result; + /// Example: array%RE + CC genarr(const Fortran::evaluate::ComplexPart &x, + ComponentPath &components) { + components.reversePath.push_back(&x); + return genarr(x.complex(), components); } - CC applyPathToArrayLoad(fir::ArrayLoadOp load, ComponentPath &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 + //===--------------------------------------------------------------------===// + + /// Target agnostic computation of the size of an element in the array. + /// Returns the size in bytes with type `index` or a null Value if the element + /// size is not constant. + mlir::Value computeElementSize(const ExtValue &exv, mlir::Type eleTy, + mlir::Type resTy) { mlir::Location loc = getLoc(); - auto revPath = components.reversePath; - fir::ExtendedValue arrayExv = - arrayLoadExtValue(builder, loc, load, {}, load); - mlir::Type eleTy = lowerPath(arrayExv, components); - auto currentPC = components.pc; - auto pc = [=, prefix = components.prefixComponents, - suffix = components.suffixComponents](IterSpace iters) { - IterationSpace newIters = currentPC(iters); - // Add path prefix and suffix. - IterationSpace addIters(newIters, prefix, suffix); - return addIters; - }; - components.pc = [=](IterSpace iters) { return iters; }; - llvm::SmallVector substringBounds = - genSubstringBounds(components); - if (isProjectedCopyInCopyOut()) { - destination = load; - auto lambda = [=, esp = this->explicitSpace](IterSpace iters) mutable { - mlir::Value innerArg = esp->findArgumentOfLoad(load); - if (isAdjustedArrayElementType(eleTy)) { - mlir::Type eleRefTy = builder.getRefType(eleTy); - auto arrayOp = builder.create( - loc, eleRefTy, innerArg, iters.iterVec(), load.getTypeparams()); - if (auto charTy = eleTy.dyn_cast()) { - mlir::Value dstLen = fir::factory::genLenOfCharacter( - builder, loc, load, iters.iterVec(), substringBounds); - fir::ArrayAmendOp amend = createCharArrayAmend( - loc, builder, arrayOp, dstLen, iters.elementExv(), innerArg, - substringBounds); - return arrayLoadExtValue(builder, loc, load, iters.iterVec(), amend, - dstLen); - } else if (fir::isa_derived(eleTy)) { - fir::ArrayAmendOp amend = - createDerivedArrayAmend(loc, load, builder, arrayOp, - iters.elementExv(), eleTy, innerArg); - return arrayLoadExtValue(builder, loc, load, iters.iterVec(), - amend); - } - assert(eleTy.isa()); - TODO(loc, "array (as element) assignment"); + mlir::IndexType idxTy = builder.getIndexType(); + mlir::Value multiplier = builder.createIntegerConstant(loc, idxTy, 1); + if (fir::hasDynamicSize(eleTy)) { + if (auto charTy = eleTy.dyn_cast()) { + // Array of char with dynamic length parameter. Downcast to an array + // of singleton char, and scale by the len type parameter from + // `exv`. + exv.match( + [&](const fir::CharBoxValue &cb) { multiplier = cb.getLen(); }, + [&](const fir::CharArrayBoxValue &cb) { multiplier = cb.getLen(); }, + [&](const fir::BoxValue &box) { + multiplier = fir::factory::CharacterExprHelper(builder, loc) + .readLengthFromBox(box.getAddr()); + }, + [&](const fir::MutableBoxValue &box) { + multiplier = fir::factory::CharacterExprHelper(builder, loc) + .readLengthFromBox(box.getAddr()); + }, + [&](const auto &) { + fir::emitFatalError(loc, + "array constructor element has unknown size"); + }); + fir::CharacterType newEleTy = fir::CharacterType::getSingleton( + eleTy.getContext(), charTy.getFKind()); + if (auto seqTy = resTy.dyn_cast()) { + assert(eleTy == seqTy.getEleTy()); + resTy = fir::SequenceType::get(seqTy.getShape(), newEleTy); } - mlir::Value castedElement = - builder.createConvert(loc, eleTy, iters.getElement()); - auto update = builder.create( - loc, innerArg.getType(), innerArg, castedElement, iters.iterVec(), - load.getTypeparams()); - return arrayLoadExtValue(builder, loc, load, iters.iterVec(), update); - }; - return [=](IterSpace iters) mutable { return lambda(pc(iters)); }; - } - if (isCustomCopyInCopyOut()) { - // Create an array_modify to get the LHS element address and indicate - // the assignment, and create the call to the user defined assignment. - destination = load; - auto lambda = [=](IterSpace iters) mutable { - mlir::Value innerArg = explicitSpace->findArgumentOfLoad(load); - mlir::Type refEleTy = - fir::isa_ref_type(eleTy) ? eleTy : builder.getRefType(eleTy); - auto arrModify = builder.create( - loc, mlir::TypeRange{refEleTy, innerArg.getType()}, innerArg, - iters.iterVec(), load.getTypeparams()); - return arrayLoadExtValue(builder, loc, load, iters.iterVec(), - arrModify.getResult(1)); - }; - return [=](IterSpace iters) mutable { return lambda(pc(iters)); }; + eleTy = newEleTy; + } else { + TODO(loc, "dynamic sized type"); + } } - auto lambda = [=, semant = this->semant](IterSpace iters) mutable { - if (semant == ConstituentSemantics::RefOpaque || - isAdjustedArrayElementType(eleTy)) { - mlir::Type resTy = builder.getRefType(eleTy); - // Use array element reference semantics. - auto access = builder.create( - loc, resTy, load, iters.iterVec(), load.getTypeparams()); - mlir::Value newBase = access; - if (fir::isa_char(eleTy)) { - mlir::Value dstLen = fir::factory::genLenOfCharacter( - builder, loc, load, iters.iterVec(), substringBounds); - if (!substringBounds.empty()) { - fir::CharBoxValue charDst{access, dstLen}; - fir::factory::CharacterExprHelper helper{builder, loc}; - charDst = helper.createSubstring(charDst, substringBounds); - newBase = charDst.getAddr(); - } - return arrayLoadExtValue(builder, loc, load, iters.iterVec(), newBase, - dstLen); + mlir::Type eleRefTy = builder.getRefType(eleTy); + mlir::Type resRefTy = builder.getRefType(resTy); + mlir::Value nullPtr = builder.createNullConstant(loc, resRefTy); + auto offset = builder.create( + loc, eleRefTy, nullPtr, mlir::ValueRange{multiplier}); + return builder.createConvert(loc, idxTy, offset); + } + + /// Get the function signature of the LLVM memcpy intrinsic. + mlir::FunctionType memcpyType() { + return fir::factory::getLlvmMemcpy(builder).getFunctionType(); + } + + /// Create a call to the LLVM memcpy intrinsic. + void createCallMemcpy(llvm::ArrayRef args) { + mlir::Location loc = getLoc(); + mlir::FuncOp memcpyFunc = fir::factory::getLlvmMemcpy(builder); + mlir::SymbolRefAttr funcSymAttr = + builder.getSymbolRefAttr(memcpyFunc.getName()); + mlir::FunctionType funcTy = memcpyFunc.getFunctionType(); + builder.create(loc, funcTy.getResults(), funcSymAttr, args); + } + + // Construct code to check for a buffer overrun and realloc the buffer when + // space is depleted. This is done between each item in the ac-value-list. + mlir::Value growBuffer(mlir::Value mem, mlir::Value needed, + mlir::Value bufferSize, mlir::Value buffSize, + mlir::Value eleSz) { + mlir::Location loc = getLoc(); + mlir::FuncOp reallocFunc = fir::factory::getRealloc(builder); + auto cond = builder.create( + loc, mlir::arith::CmpIPredicate::sle, bufferSize, needed); + auto ifOp = builder.create(loc, mem.getType(), cond, + /*withElseRegion=*/true); + auto insPt = builder.saveInsertionPoint(); + builder.setInsertionPointToStart(&ifOp.getThenRegion().front()); + // Not enough space, resize the buffer. + mlir::IndexType idxTy = builder.getIndexType(); + mlir::Value two = builder.createIntegerConstant(loc, idxTy, 2); + auto newSz = builder.create(loc, needed, two); + builder.create(loc, newSz, buffSize); + mlir::Value byteSz = builder.create(loc, newSz, eleSz); + mlir::SymbolRefAttr funcSymAttr = + builder.getSymbolRefAttr(reallocFunc.getName()); + mlir::FunctionType funcTy = reallocFunc.getFunctionType(); + auto newMem = builder.create( + loc, funcTy.getResults(), funcSymAttr, + llvm::ArrayRef{ + builder.createConvert(loc, funcTy.getInputs()[0], mem), + builder.createConvert(loc, funcTy.getInputs()[1], byteSz)}); + mlir::Value castNewMem = + builder.createConvert(loc, mem.getType(), newMem.getResult(0)); + builder.create(loc, castNewMem); + builder.setInsertionPointToStart(&ifOp.getElseRegion().front()); + // Otherwise, just forward the buffer. + builder.create(loc, mem); + builder.restoreInsertionPoint(insPt); + return ifOp.getResult(0); + } + + /// Copy the next value (or vector of values) into the array being + /// constructed. + mlir::Value copyNextArrayCtorSection(const ExtValue &exv, mlir::Value buffPos, + mlir::Value buffSize, mlir::Value mem, + mlir::Value eleSz, mlir::Type eleTy, + mlir::Type eleRefTy, mlir::Type resTy) { + mlir::Location loc = getLoc(); + auto off = builder.create(loc, buffPos); + auto limit = builder.create(loc, buffSize); + mlir::IndexType idxTy = builder.getIndexType(); + mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1); + + if (fir::isRecordWithAllocatableMember(eleTy)) + TODO(loc, "deep copy on allocatable members"); + + if (!eleSz) { + // Compute the element size at runtime. + assert(fir::hasDynamicSize(eleTy)); + if (auto charTy = eleTy.dyn_cast()) { + auto charBytes = + builder.getKindMap().getCharacterBitsize(charTy.getFKind()) / 8; + mlir::Value bytes = + builder.createIntegerConstant(loc, idxTy, charBytes); + mlir::Value length = fir::getLen(exv); + if (!length) + fir::emitFatalError(loc, "result is not boxed character"); + eleSz = builder.create(loc, bytes, length); + } else { + TODO(loc, "PDT size"); + // Will call the PDT's size function with the type parameters. + } + } + + // Compute the coordinate using `fir.coordinate_of`, or, if the type has + // dynamic size, generating the pointer arithmetic. + auto computeCoordinate = [&](mlir::Value buff, mlir::Value off) { + mlir::Type refTy = eleRefTy; + if (fir::hasDynamicSize(eleTy)) { + if (auto charTy = eleTy.dyn_cast()) { + // Scale a simple pointer using dynamic length and offset values. + auto chTy = fir::CharacterType::getSingleton(charTy.getContext(), + charTy.getFKind()); + refTy = builder.getRefType(chTy); + mlir::Type toTy = builder.getRefType(builder.getVarLenSeqTy(chTy)); + buff = builder.createConvert(loc, toTy, buff); + off = builder.create(loc, off, eleSz); + } else { + TODO(loc, "PDT offset"); } - return arrayLoadExtValue(builder, loc, load, iters.iterVec(), newBase); } - auto fetch = builder.create( - loc, eleTy, load, iters.iterVec(), load.getTypeparams()); - return arrayLoadExtValue(builder, loc, load, iters.iterVec(), fetch); + auto coor = builder.create(loc, refTy, buff, + mlir::ValueRange{off}); + return builder.createConvert(loc, eleRefTy, coor); }; - return [=](IterSpace iters) mutable { - auto newIters = pc(iters); - return lambda(newIters); + + // Lambda to lower an abstract array box value. + auto doAbstractArray = [&](const auto &v) { + // Compute the array size. + mlir::Value arrSz = one; + for (auto ext : v.getExtents()) + arrSz = builder.create(loc, arrSz, ext); + + // Grow the buffer as needed. + auto endOff = builder.create(loc, off, arrSz); + mem = growBuffer(mem, endOff, limit, buffSize, eleSz); + + // Copy the elements to the buffer. + mlir::Value byteSz = + builder.create(loc, arrSz, eleSz); + auto buff = builder.createConvert(loc, fir::HeapType::get(resTy), mem); + mlir::Value buffi = computeCoordinate(buff, off); + llvm::SmallVector args = fir::runtime::createArguments( + builder, loc, memcpyType(), buffi, v.getAddr(), byteSz, + /*volatile=*/builder.createBool(loc, false)); + createCallMemcpy(args); + + // Save the incremented buffer position. + builder.create(loc, endOff, buffPos); + }; + + // Copy a trivial scalar value into the buffer. + auto doTrivialScalar = [&](const ExtValue &v, mlir::Value len = {}) { + // Increment the buffer position. + auto plusOne = builder.create(loc, off, one); + + // Grow the buffer as needed. + mem = growBuffer(mem, plusOne, limit, buffSize, eleSz); + + // Store the element in the buffer. + mlir::Value buff = + builder.createConvert(loc, fir::HeapType::get(resTy), mem); + auto buffi = builder.create(loc, eleRefTy, buff, + mlir::ValueRange{off}); + fir::factory::genScalarAssignment( + builder, loc, + [&]() -> ExtValue { + if (len) + return fir::CharBoxValue(buffi, len); + return buffi; + }(), + v); + builder.create(loc, plusOne, buffPos); }; + + // Copy the value. + exv.match( + [&](mlir::Value) { doTrivialScalar(exv); }, + [&](const fir::CharBoxValue &v) { + auto buffer = v.getBuffer(); + if (fir::isa_char(buffer.getType())) { + doTrivialScalar(exv, eleSz); + } else { + // Increment the buffer position. + auto plusOne = builder.create(loc, off, one); + + // Grow the buffer as needed. + mem = growBuffer(mem, plusOne, limit, buffSize, eleSz); + + // Store the element in the buffer. + mlir::Value buff = + builder.createConvert(loc, fir::HeapType::get(resTy), mem); + mlir::Value buffi = computeCoordinate(buff, off); + llvm::SmallVector args = fir::runtime::createArguments( + builder, loc, memcpyType(), buffi, v.getAddr(), eleSz, + /*volatile=*/builder.createBool(loc, false)); + createCallMemcpy(args); + + builder.create(loc, plusOne, buffPos); + } + }, + [&](const fir::ArrayBoxValue &v) { doAbstractArray(v); }, + [&](const fir::CharArrayBoxValue &v) { doAbstractArray(v); }, + [&](const auto &) { + TODO(loc, "unhandled array constructor expression"); + }); + return mem; } + // Lower the expr cases in an ac-value-list. template - CC genImplicitArrayAccess(const A &x, ComponentPath &components) { - components.reversePath.push_back(ImplicitSubscripts{}); - ExtValue exv = asScalarRef(x); - lowerPath(exv, components); - auto lambda = genarr(exv, components); - return [=](IterSpace iters) { return lambda(components.pc(iters)); }; - } - CC genImplicitArrayAccess(const Fortran::evaluate::NamedEntity &x, - ComponentPath &components) { - if (x.IsSymbol()) - return genImplicitArrayAccess(x.GetFirstSymbol(), components); - return genImplicitArrayAccess(x.GetComponent(), components); + std::pair + genArrayCtorInitializer(const Fortran::evaluate::Expr &x, mlir::Type, + mlir::Value, mlir::Value, mlir::Value, + Fortran::lower::StatementContext &stmtCtx) { + if (isArray(x)) + return {lowerNewArrayExpression(converter, symMap, stmtCtx, toEvExpr(x)), + /*needCopy=*/true}; + return {asScalar(x), /*needCopy=*/true}; } + // Lower an ac-implied-do in an ac-value-list. template - CC genAsScalar(const A &x) { + std::pair + genArrayCtorInitializer(const Fortran::evaluate::ImpliedDo &x, + mlir::Type resTy, mlir::Value mem, + mlir::Value buffPos, mlir::Value buffSize, + Fortran::lower::StatementContext &) { mlir::Location loc = getLoc(); - if (isProjectedCopyInCopyOut()) { - return [=, &x, builder = &converter.getFirOpBuilder()]( - IterSpace iters) -> ExtValue { - ExtValue exv = asScalarRef(x); - mlir::Value val = fir::getBase(exv); - mlir::Type eleTy = fir::unwrapRefType(val.getType()); - if (isAdjustedArrayElementType(eleTy)) { - if (fir::isa_char(eleTy)) { - TODO(getLoc(), "assignment of character type"); - } else if (fir::isa_derived(eleTy)) { - TODO(loc, "assignment of derived type"); - } else { - fir::emitFatalError(loc, "array type not expected in scalar"); - } - } else { - builder->create(loc, iters.getElement(), val); - } - return exv; - }; - } - return [=, &x](IterSpace) { return asScalar(x); }; - } + mlir::IndexType idxTy = builder.getIndexType(); + mlir::Value lo = + builder.createConvert(loc, idxTy, fir::getBase(asScalar(x.lower()))); + mlir::Value up = + builder.createConvert(loc, idxTy, fir::getBase(asScalar(x.upper()))); + mlir::Value step = + builder.createConvert(loc, idxTy, fir::getBase(asScalar(x.stride()))); + auto seqTy = resTy.template cast(); + mlir::Type eleTy = fir::unwrapSequenceType(seqTy); + auto loop = + builder.create(loc, lo, up, step, /*unordered=*/false, + /*finalCount=*/false, mem); + // create a new binding for x.name(), to ac-do-variable, to the iteration + // value. + symMap.pushImpliedDoBinding(toStringRef(x.name()), loop.getInductionVar()); + auto insPt = builder.saveInsertionPoint(); + builder.setInsertionPointToStart(loop.getBody()); + // Thread mem inside the loop via loop argument. + mem = loop.getRegionIterArgs()[0]; - CC genarr(const Fortran::semantics::Symbol &x, ComponentPath &components) { - if (explicitSpaceIsActive()) { - if (x.Rank() > 0) - components.reversePath.push_back(ImplicitSubscripts{}); - if (fir::ArrayLoadOp load = explicitSpace->findBinding(&x)) - return applyPathToArrayLoad(load, components); - } else { - return genImplicitArrayAccess(x, components); + mlir::Type eleRefTy = builder.getRefType(eleTy); + + // Any temps created in the loop body must be freed inside the loop body. + stmtCtx.pushScope(); + llvm::Optional charLen; + for (const Fortran::evaluate::ArrayConstructorValue &acv : x.values()) { + auto [exv, copyNeeded] = std::visit( + [&](const auto &v) { + return genArrayCtorInitializer(v, resTy, mem, buffPos, buffSize, + stmtCtx); + }, + acv.u); + mlir::Value eleSz = computeElementSize(exv, eleTy, resTy); + mem = copyNeeded ? copyNextArrayCtorSection(exv, buffPos, buffSize, mem, + eleSz, eleTy, eleRefTy, resTy) + : fir::getBase(exv); + if (fir::isa_char(seqTy.getEleTy()) && !charLen.hasValue()) { + charLen = builder.createTemporary(loc, builder.getI64Type()); + mlir::Value castLen = + builder.createConvert(loc, builder.getI64Type(), fir::getLen(exv)); + builder.create(loc, castLen, charLen.getValue()); + } } - if (pathIsEmpty(components)) - return genAsScalar(x); - mlir::Location loc = getLoc(); - return [=](IterSpace) -> ExtValue { - fir::emitFatalError(loc, "reached symbol with path"); - }; - } + stmtCtx.finalize(/*popScope=*/true); - /// Lower a component path with or without rank. - /// Example: array%baz%qux%waldo - CC genarr(const Fortran::evaluate::Component &x, ComponentPath &components) { - if (explicitSpaceIsActive()) { - if (x.base().Rank() == 0 && x.Rank() > 0) - components.reversePath.push_back(ImplicitSubscripts{}); - if (fir::ArrayLoadOp load = explicitSpace->findBinding(&x)) - return applyPathToArrayLoad(load, components); - } else { - if (x.base().Rank() == 0) - return genImplicitArrayAccess(x, components); + builder.create(loc, mem); + builder.restoreInsertionPoint(insPt); + mem = loop.getResult(0); + symMap.popImpliedDoBinding(); + llvm::SmallVector extents = { + builder.create(loc, buffPos).getResult()}; + + // Convert to extended value. + if (fir::isa_char(seqTy.getEleTy())) { + auto len = builder.create(loc, charLen.getValue()); + return {fir::CharArrayBoxValue{mem, len, extents}, /*needCopy=*/false}; } - bool atEnd = pathIsEmpty(components); - if (!getLastSym(x).test(Fortran::semantics::Symbol::Flag::ParentComp)) - // Skip parent components; their components are placed directly in the - // object. - components.reversePath.push_back(&x); - auto result = genarr(x.base(), components); - if (components.applied) - return result; - if (atEnd) - return genAsScalar(x); - mlir::Location loc = getLoc(); - return [=](IterSpace) -> ExtValue { - fir::emitFatalError(loc, "reached component with path"); - }; + return {fir::ArrayBoxValue{mem, extents}, /*needCopy=*/false}; } - /// Array reference with subscripts. If this has rank > 0, this is a form - /// of an array section (slice). - /// - /// There are two "slicing" primitives that may be applied on a dimension by - /// dimension basis: (1) triple notation and (2) vector addressing. Since - /// dimensions can be selectively sliced, some dimensions may contain - /// regular scalar expressions and those dimensions do not participate in - /// the array expression evaluation. - CC genarr(const Fortran::evaluate::ArrayRef &x, ComponentPath &components) { - if (explicitSpaceIsActive()) { - if (Fortran::lower::isRankedArrayAccess(x)) - components.reversePath.push_back(ImplicitSubscripts{}); - if (fir::ArrayLoadOp load = explicitSpace->findBinding(&x)) { - components.reversePath.push_back(&x); - return applyPathToArrayLoad(load, components); + // To simplify the handling and interaction between the various cases, array + // constructors are always lowered to the incremental construction code + // pattern, even if the extent of the array value is constant. After the + // MemToReg pass and constant folding, the optimizer should be able to + // determine that all the buffer overrun tests are false when the + // incremental construction wasn't actually required. + template + CC genarr(const Fortran::evaluate::ArrayConstructor &x) { + mlir::Location loc = getLoc(); + auto evExpr = toEvExpr(x); + mlir::Type resTy = translateSomeExprToFIRType(converter, evExpr); + mlir::IndexType idxTy = builder.getIndexType(); + auto seqTy = resTy.template cast(); + mlir::Type eleTy = fir::unwrapSequenceType(resTy); + mlir::Value buffSize = builder.createTemporary(loc, idxTy, ".buff.size"); + mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0); + mlir::Value buffPos = builder.createTemporary(loc, idxTy, ".buff.pos"); + builder.create(loc, zero, buffPos); + // Allocate space for the array to be constructed. + mlir::Value mem; + if (fir::hasDynamicSize(resTy)) { + if (fir::hasDynamicSize(eleTy)) { + // The size of each element may depend on a general expression. Defer + // creating the buffer until after the expression is evaluated. + mem = builder.createNullConstant(loc, builder.getRefType(eleTy)); + builder.create(loc, zero, buffSize); + } else { + mlir::Value initBuffSz = + builder.createIntegerConstant(loc, idxTy, clInitialBufferSize); + mem = builder.create( + loc, eleTy, /*typeparams=*/llvm::None, initBuffSz); + builder.create(loc, initBuffSz, buffSize); } } else { - if (Fortran::lower::isRankedArrayAccess(x)) { - components.reversePath.push_back(&x); - return genImplicitArrayAccess(x.base(), components); + mem = builder.create(loc, resTy); + int64_t buffSz = 1; + for (auto extent : seqTy.getShape()) + buffSz *= extent; + mlir::Value initBuffSz = + builder.createIntegerConstant(loc, idxTy, buffSz); + builder.create(loc, initBuffSz, buffSize); + } + // Compute size of element + mlir::Type eleRefTy = builder.getRefType(eleTy); + + // Populate the buffer with the elements, growing as necessary. + llvm::Optional charLen; + for (const auto &expr : x) { + auto [exv, copyNeeded] = std::visit( + [&](const auto &e) { + return genArrayCtorInitializer(e, resTy, mem, buffPos, buffSize, + stmtCtx); + }, + expr.u); + mlir::Value eleSz = computeElementSize(exv, eleTy, resTy); + mem = copyNeeded ? copyNextArrayCtorSection(exv, buffPos, buffSize, mem, + eleSz, eleTy, eleRefTy, resTy) + : fir::getBase(exv); + if (fir::isa_char(seqTy.getEleTy()) && !charLen.hasValue()) { + charLen = builder.createTemporary(loc, builder.getI64Type()); + mlir::Value castLen = + builder.createConvert(loc, builder.getI64Type(), fir::getLen(exv)); + builder.create(loc, castLen, charLen.getValue()); } } - bool atEnd = pathIsEmpty(components); - components.reversePath.push_back(&x); - auto result = genarr(x.base(), components); - if (components.applied) - return result; - mlir::Location loc = getLoc(); - if (atEnd) { - if (x.Rank() == 0) - return genAsScalar(x); - fir::emitFatalError(loc, "expected scalar"); + mem = builder.createConvert(loc, fir::HeapType::get(resTy), mem); + llvm::SmallVector extents = { + builder.create(loc, buffPos)}; + + // Cleanup the temporary. + fir::FirOpBuilder *bldr = &converter.getFirOpBuilder(); + stmtCtx.attachCleanup( + [bldr, loc, mem]() { bldr->create(loc, mem); }); + + // Return the continuation. + if (fir::isa_char(seqTy.getEleTy())) { + if (charLen.hasValue()) { + auto len = builder.create(loc, charLen.getValue()); + return genarr(fir::CharArrayBoxValue{mem, len, extents}); + } + return genarr(fir::CharArrayBoxValue{mem, zero, extents}); } - return [=](IterSpace) -> ExtValue { - fir::emitFatalError(loc, "reached arrayref with path"); - }; + return genarr(fir::ArrayBoxValue{mem, extents}); } - CC genarr(const Fortran::evaluate::CoarrayRef &x, ComponentPath &components) { - TODO(getLoc(), "coarray reference"); + CC genarr(const Fortran::evaluate::ImpliedDoIndex &) { + fir::emitFatalError(getLoc(), "implied do index cannot have rank > 0"); } - - CC genarr(const Fortran::evaluate::NamedEntity &x, - ComponentPath &components) { - return x.IsSymbol() ? genarr(x.GetFirstSymbol(), components) - : genarr(x.GetComponent(), components); + CC genarr(const Fortran::evaluate::TypeParamInquiry &x) { + TODO(getLoc(), "array expr type parameter inquiry"); + return [](IterSpace iters) -> ExtValue { return mlir::Value{}; }; } - - CC genarr(const Fortran::evaluate::DataRef &x, ComponentPath &components) { - return std::visit([&](const auto &v) { return genarr(v, components); }, - x.u); + CC genarr(const Fortran::evaluate::DescriptorInquiry &x) { + TODO(getLoc(), "array expr descriptor inquiry"); + return [](IterSpace iters) -> ExtValue { return mlir::Value{}; }; } - - bool pathIsEmpty(const ComponentPath &components) { - return components.reversePath.empty(); + CC genarr(const Fortran::evaluate::StructureConstructor &x) { + TODO(getLoc(), "structure constructor"); + return [](IterSpace iters) -> ExtValue { return mlir::Value{}; }; } - /// 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); - } + //===--------------------------------------------------------------------===// + // LOCICAL operators (.NOT., .AND., .EQV., etc.) + //===--------------------------------------------------------------------===// - std::tuple - genOptionalArrayFetch(const Fortran::lower::SomeExpr &expr) { - assert(expr.Rank() > 0 && "expr must be an array"); + template + CC genarr(const Fortran::evaluate::Not &x) { 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); + mlir::IntegerType i1Ty = builder.getI1Type(); + auto lambda = genarr(x.left()); + mlir::Value truth = builder.createBool(loc, true); + return [=](IterSpace iters) -> ExtValue { + mlir::Value logical = fir::getBase(lambda(iters)); + mlir::Value val = builder.createConvert(loc, i1Ty, logical); + return builder.create(loc, val, truth); }; - return {cc, isPresent, eleType}; + } + template + CC createBinaryBoolOp(const A &x) { + mlir::Location loc = getLoc(); + mlir::IntegerType i1Ty = builder.getI1Type(); + auto lf = genarr(x.left()); + auto rf = genarr(x.right()); + return [=](IterSpace iters) -> ExtValue { + mlir::Value left = fir::getBase(lf(iters)); + mlir::Value right = fir::getBase(rf(iters)); + mlir::Value lhs = builder.createConvert(loc, i1Ty, left); + mlir::Value rhs = builder.createConvert(loc, i1Ty, right); + return builder.create(loc, lhs, rhs); + }; + } + template + CC createCompareBoolOp(mlir::arith::CmpIPredicate pred, const A &x) { + mlir::Location loc = getLoc(); + mlir::IntegerType i1Ty = builder.getI1Type(); + auto lf = genarr(x.left()); + auto rf = genarr(x.right()); + return [=](IterSpace iters) -> ExtValue { + mlir::Value left = fir::getBase(lf(iters)); + mlir::Value right = fir::getBase(rf(iters)); + mlir::Value lhs = builder.createConvert(loc, i1Ty, left); + mlir::Value rhs = builder.createConvert(loc, i1Ty, right); + return builder.create(loc, pred, lhs, rhs); + }; + } + template + CC genarr(const Fortran::evaluate::LogicalOperation &x) { + switch (x.logicalOperator) { + case Fortran::evaluate::LogicalOperator::And: + return createBinaryBoolOp(x); + case Fortran::evaluate::LogicalOperator::Or: + return createBinaryBoolOp(x); + case Fortran::evaluate::LogicalOperator::Eqv: + return createCompareBoolOp( + mlir::arith::CmpIPredicate::eq, x); + case Fortran::evaluate::LogicalOperator::Neqv: + return createCompareBoolOp( + mlir::arith::CmpIPredicate::ne, x); + case Fortran::evaluate::LogicalOperator::Not: + llvm_unreachable(".NOT. handled elsewhere"); + } + llvm_unreachable("unhandled case"); } - /// 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; }; - } + //===--------------------------------------------------------------------===// + // Relational operators (<, <=, ==, etc.) + //===--------------------------------------------------------------------===// - CC cc; - mlir::Value isPresent; - mlir::Type eleType; - std::tie(cc, isPresent, eleType) = genOptionalArrayFetch(expr); + template + CC createCompareOp(PRED pred, const A &x) { + mlir::Location loc = getLoc(); + auto lf = genarr(x.left()); + auto rf = genarr(x.right()); 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; + mlir::Value lhs = fir::getBase(lf(iters)); + mlir::Value rhs = fir::getBase(rf(iters)); + return builder.create(loc, pred, lhs, rhs); }; } - - /// 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; + template + CC createCompareCharOp(mlir::arith::CmpIPredicate pred, const A &x) { + mlir::Location loc = getLoc(); + auto lf = genarr(x.left()); + auto rf = genarr(x.right()); + return [=](IterSpace iters) -> ExtValue { + auto lhs = lf(iters); + auto rhs = rf(iters); + return fir::runtime::genCharCompare(builder, loc, pred, lhs, rhs); + }; } - - CC genarr(const Fortran::evaluate::ComplexPart &x, - ComponentPath &components) { - components.reversePath.push_back(&x); - return genarr(x.complex(), components); + template + CC genarr(const Fortran::evaluate::Relational> &x) { + return createCompareOp(translateRelational(x.opr), x); + } + template + CC genarr(const Fortran::evaluate::Relational> &x) { + return createCompareCharOp(translateRelational(x.opr), x); + } + template + CC genarr(const Fortran::evaluate::Relational> &x) { + return createCompareOp(translateFloatRelational(x.opr), + x); + } + template + CC genarr(const Fortran::evaluate::Relational> &x) { + return createCompareOp(translateFloatRelational(x.opr), x); + } + CC genarr( + const Fortran::evaluate::Relational &r) { + return std::visit([&](const auto &x) { return genarr(x); }, r.u); } - CC genarr(const Fortran::evaluate::StaticDataObject::Pointer &, - ComponentPath &components) { - TODO(getLoc(), "genarr StaticDataObject::Pointer"); + template + CC genarr(const Fortran::evaluate::Designator &des) { + ComponentPath components(des.Rank() > 0); + return std::visit([&](const auto &x) { return genarr(x, components); }, + des.u); } - /// 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()); + /// 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); } - /// 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()); + //===-------------------------------------------------------------------===// + // Array data references in an explicit iteration space. + // + // Use the base array that was loaded before the loop nest. + //===-------------------------------------------------------------------===// - // 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); }; + /// Lower the path (`revPath`, in reverse) to be appended to an array_fetch or + /// array_update op. \p ty is the initial type of the array + /// (reference). Returns the type of the element after application of the + /// path in \p components. + /// + /// TODO: This needs to deal with array's with initial bounds other than 1. + /// TODO: Thread type parameters correctly. + mlir::Type lowerPath(const ExtValue &arrayExv, ComponentPath &components) { + mlir::Location loc = getLoc(); + mlir::Type ty = fir::getBase(arrayExv).getType(); + auto &revPath = components.reversePath; + ty = fir::unwrapPassByRefType(ty); + bool prefix = true; + auto addComponent = [&](mlir::Value v) { + if (prefix) + components.prefixComponents.push_back(v); + else + components.suffixComponents.push_back(v); + }; + mlir::IndexType idxTy = builder.getIndexType(); + mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1); + bool atBase = true; + auto saveSemant = semant; + if (isProjectedCopyInCopyOut()) + semant = ConstituentSemantics::RefTransparent; + for (const auto &v : llvm::reverse(revPath)) { + std::visit( + Fortran::common::visitors{ + [&](const ImplicitSubscripts &) { + prefix = false; + ty = fir::unwrapSequenceType(ty); + }, + [&](const Fortran::evaluate::ComplexPart *x) { + assert(!prefix && "complex part must be at end"); + mlir::Value offset = builder.createIntegerConstant( + loc, builder.getI32Type(), + x->part() == Fortran::evaluate::ComplexPart::Part::RE ? 0 + : 1); + components.suffixComponents.push_back(offset); + ty = fir::applyPathToType(ty, mlir::ValueRange{offset}); + }, + [&](const Fortran::evaluate::ArrayRef *x) { + if (Fortran::lower::isRankedArrayAccess(*x)) { + genSliceIndices(components, arrayExv, *x, atBase); + } else { + // Array access where the expressions are scalar and cannot + // depend upon the implied iteration space. + unsigned ssIndex = 0u; + for (const auto &ss : x->subscript()) { + std::visit( + Fortran::common::visitors{ + [&](const Fortran::evaluate:: + IndirectSubscriptIntegerExpr &ie) { + const auto &e = ie.value(); + if (isArray(e)) + fir::emitFatalError( + loc, + "multiple components along single path " + "generating array subexpressions"); + // Lower scalar index expression, append it to + // subs. + mlir::Value subscriptVal = + fir::getBase(asScalarArray(e)); + // arrayExv is the base array. It needs to reflect + // the current array component instead. + // FIXME: must use lower bound of this component, + // not just the constant 1. + mlir::Value lb = + atBase ? fir::factory::readLowerBound( + builder, loc, arrayExv, ssIndex, + one) + : one; + mlir::Value val = builder.createConvert( + loc, idxTy, subscriptVal); + mlir::Value ivAdj = + builder.create( + loc, idxTy, val, lb); + addComponent( + builder.createConvert(loc, idxTy, ivAdj)); + }, + [&](const auto &) { + fir::emitFatalError( + loc, "multiple components along single path " + "generating array subexpressions"); + }}, + ss.u); + ssIndex++; + } + } + ty = fir::unwrapSequenceType(ty); + }, + [&](const Fortran::evaluate::Component *x) { + auto fieldTy = fir::FieldType::get(builder.getContext()); + llvm::StringRef name = toStringRef(getLastSym(*x).name()); + auto recTy = ty.cast(); + ty = recTy.getType(name); + auto fld = builder.create( + loc, fieldTy, name, recTy, fir::getTypeParams(arrayExv)); + addComponent(fld); + }}, + v); + atBase = false; } - 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()) { + semant = saveSemant; + ty = fir::unwrapSequenceType(ty); + components.applied = true; + return ty; + } + + llvm::SmallVector genSubstringBounds(ComponentPath &components) { + llvm::SmallVector result; + if (components.substring) + populateBounds(result, components.substring); + return result; + } + + CC applyPathToArrayLoad(fir::ArrayLoadOp load, ComponentPath &components) { + mlir::Location loc = getLoc(); + auto revPath = components.reversePath; + fir::ExtendedValue arrayExv = + arrayLoadExtValue(builder, loc, load, {}, load); + mlir::Type eleTy = lowerPath(arrayExv, components); + auto currentPC = components.pc; + auto pc = [=, prefix = components.prefixComponents, + suffix = components.suffixComponents](IterSpace iters) { + IterationSpace newIters = currentPC(iters); + // Add path prefix and suffix. + IterationSpace addIters(newIters, prefix, suffix); + return addIters; + }; + components.pc = [=](IterSpace iters) { return iters; }; + llvm::SmallVector substringBounds = + genSubstringBounds(components); + if (isProjectedCopyInCopyOut()) { + destination = load; + auto lambda = [=, esp = this->explicitSpace](IterSpace iters) mutable { + mlir::Value innerArg = esp->findArgumentOfLoad(load); + if (isAdjustedArrayElementType(eleTy)) { + mlir::Type eleRefTy = builder.getRefType(eleTy); + auto arrayOp = builder.create( + loc, eleRefTy, innerArg, iters.iterVec(), load.getTypeparams()); + if (auto charTy = eleTy.dyn_cast()) { mlir::Value dstLen = fir::factory::genLenOfCharacter( - builder, loc, arrTy.cast(), memref, - fir::getTypeParams(extMemref), iters.iterVec(), + builder, loc, load, iters.iterVec(), substringBounds); + fir::ArrayAmendOp amend = createCharArrayAmend( + loc, builder, arrayOp, dstLen, iters.elementExv(), innerArg, substringBounds); - fir::CharBoxValue dstChar(coor, dstLen); - return fir::factory::CharacterExprHelper{builder, loc} - .createSubstring(dstChar, substringBounds); + return arrayLoadExtValue(builder, loc, load, iters.iterVec(), amend, + dstLen); + } else if (fir::isa_derived(eleTy)) { + fir::ArrayAmendOp amend = + createDerivedArrayAmend(loc, load, builder, arrayOp, + iters.elementExv(), eleTy, innerArg); + return arrayLoadExtValue(builder, loc, load, iters.iterVec(), + amend); } + assert(eleTy.isa()); + TODO(loc, "array (as element) assignment"); } - return fir::factory::arraySectionElementToExtendedValue( - builder, loc, extMemref, coor, slice); + mlir::Value castedElement = + builder.createConvert(loc, eleTy, iters.getElement()); + auto update = builder.create( + loc, innerArg.getType(), innerArg, castedElement, iters.iterVec(), + load.getTypeparams()); + return arrayLoadExtValue(builder, loc, load, iters.iterVec(), update); }; - } - 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); }; + return [=](IterSpace iters) mutable { return lambda(pc(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()); + // the assignment, and create the call to the user defined assignment. + destination = load; + auto lambda = [=](IterSpace iters) mutable { + mlir::Value innerArg = explicitSpace->findArgumentOfLoad(load); 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); + loc, mlir::TypeRange{refEleTy, innerArg.getType()}, innerArg, + iters.iterVec(), load.getTypeparams()); + return arrayLoadExtValue(builder, loc, load, iters.iterVec(), + arrModify.getResult(1)); }; + return [=](IterSpace iters) mutable { return lambda(pc(iters)); }; } - // 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); + auto lambda = [=, semant = this->semant](IterSpace iters) mutable { + if (semant == ConstituentSemantics::RefOpaque || + isAdjustedArrayElementType(eleTy)) { + mlir::Type resTy = builder.getRefType(eleTy); + // Use array element reference semantics. + auto access = builder.create( + loc, resTy, load, iters.iterVec(), load.getTypeparams()); + mlir::Value newBase = access; + if (fir::isa_char(eleTy)) { + mlir::Value dstLen = fir::factory::genLenOfCharacter( + builder, loc, load, iters.iterVec(), substringBounds); 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); + fir::CharBoxValue charDst{access, dstLen}; + fir::factory::CharacterExprHelper helper{builder, loc}; + charDst = helper.createSubstring(charDst, substringBounds); + newBase = charDst.getAddr(); } + return arrayLoadExtValue(builder, loc, load, iters.iterVec(), newBase, + dstLen); } - return fir::factory::arraySectionElementToExtendedValue( - builder, loc, extMemref, arrayOp, slice); + return arrayLoadExtValue(builder, loc, load, iters.iterVec(), newBase); } - auto arrFetch = builder.create( - loc, eleTy, arrLd, iters.iterVec(), arrLdTypeParams); - return fir::factory::arraySectionElementToExtendedValue( - builder, loc, extMemref, arrFetch, slice); + auto fetch = builder.create( + loc, eleTy, load, iters.iterVec(), load.getTypeparams()); + return arrayLoadExtValue(builder, loc, load, iters.iterVec(), fetch); + }; + return [=](IterSpace iters) mutable { + auto newIters = pc(iters); + return lambda(newIters); }; } -private: - void determineShapeOfDest(const fir::ExtendedValue &lhs) { - destShape = fir::factory::getExtents(builder, getLoc(), lhs); + template + CC genImplicitArrayAccess(const A &x, ComponentPath &components) { + components.reversePath.push_back(ImplicitSubscripts{}); + ExtValue exv = asScalarRef(x); + lowerPath(exv, components); + auto lambda = genarr(exv, components); + return [=](IterSpace iters) { return lambda(components.pc(iters)); }; } - - 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)); + CC genImplicitArrayAccess(const Fortran::evaluate::NamedEntity &x, + ComponentPath &components) { + if (x.IsSymbol()) + return genImplicitArrayAccess(getFirstSym(x), components); + return genImplicitArrayAccess(x.GetComponent(), components); } - 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()); + template + CC genAsScalar(const A &x) { 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); + if (isProjectedCopyInCopyOut()) { + return [=, &x, builder = &converter.getFirOpBuilder()]( + IterSpace iters) -> ExtValue { + ExtValue exv = asScalarRef(x); + mlir::Value val = fir::getBase(exv); + mlir::Type eleTy = fir::unwrapRefType(val.getType()); + if (isAdjustedArrayElementType(eleTy)) { + if (fir::isa_char(eleTy)) { + fir::factory::CharacterExprHelper{*builder, loc}.createAssign( + exv, iters.elementExv()); + } else if (fir::isa_derived(eleTy)) { + TODO(loc, "assignment of derived type"); + } else { + fir::emitFatalError(loc, "array type not expected in scalar"); + } + } else { + builder->create(loc, iters.getElement(), val); + } + return exv; + }; } - 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))); + return [=, &x](IterSpace) { return asScalar(x); }; } - /// 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); + CC genarr(const Fortran::semantics::Symbol &x, ComponentPath &components) { + if (explicitSpaceIsActive()) { + if (x.Rank() > 0) + components.reversePath.push_back(ImplicitSubscripts{}); + if (fir::ArrayLoadOp load = explicitSpace->findBinding(&x)) + return applyPathToArrayLoad(load, components); + } else { + return genImplicitArrayAccess(x, components); + } + if (pathIsEmpty(components)) + return genAsScalar(x); + mlir::Location loc = getLoc(); + return [=](IterSpace) -> ExtValue { + fir::emitFatalError(loc, "reached symbol with path"); }; } - /// 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) { + /// Lower a component path with or without rank. + /// Example: array%baz%qux%waldo + CC genarr(const Fortran::evaluate::Component &x, ComponentPath &components) { + if (explicitSpaceIsActive()) { + if (x.base().Rank() == 0 && x.Rank() > 0) + components.reversePath.push_back(ImplicitSubscripts{}); + if (fir::ArrayLoadOp load = explicitSpace->findBinding(&x)) + return applyPathToArrayLoad(load, components); + } else { + if (x.base().Rank() == 0) + return genImplicitArrayAccess(x, components); + } + bool atEnd = pathIsEmpty(components); + if (!getLastSym(x).test(Fortran::semantics::Symbol::Flag::ParentComp)) + // Skip parent components; their components are placed directly in the + // object. + components.reversePath.push_back(&x); + auto result = genarr(x.base(), components); + if (components.applied) + return result; + if (atEnd) + return genAsScalar(x); 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()); + return [=](IterSpace) -> ExtValue { + fir::emitFatalError(loc, "reached component with path"); + }; } - /// 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. + /// Array reference with subscripts. If this has rank > 0, this is a form + /// of an array section (slice). + /// + /// There are two "slicing" primitives that may be applied on a dimension by + /// dimension basis: (1) triple notation and (2) vector addressing. Since + /// dimensions can be selectively sliced, some dimensions may contain + /// regular scalar expressions and those dimensions do not participate in + /// the array expression evaluation. + CC genarr(const Fortran::evaluate::ArrayRef &x, ComponentPath &components) { + if (explicitSpaceIsActive()) { + if (Fortran::lower::isRankedArrayAccess(x)) + components.reversePath.push_back(ImplicitSubscripts{}); + if (fir::ArrayLoadOp load = explicitSpace->findBinding(&x)) { + components.reversePath.push_back(&x); + return applyPathToArrayLoad(load, components); + } + } else { + if (Fortran::lower::isRankedArrayAccess(x)) { + components.reversePath.push_back(&x); + return genImplicitArrayAccess(x.base(), components); } } - return slicedShape; + bool atEnd = pathIsEmpty(components); + components.reversePath.push_back(&x); + auto result = genarr(x.base(), components); + if (components.applied) + return result; + mlir::Location loc = getLoc(); + if (atEnd) { + if (x.Rank() == 0) + return genAsScalar(x); + fir::emitFatalError(loc, "expected scalar"); + } + return [=](IterSpace) -> ExtValue { + fir::emitFatalError(loc, "reached arrayref with path"); + }; } - /// 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()}; + CC genarr(const Fortran::evaluate::CoarrayRef &x, ComponentPath &components) { + TODO(getLoc(), "coarray reference"); } - /// Get the shape from an ArrayLoad. - llvm::SmallVector getShape(fir::ArrayLoadOp arrayLoad) { - return getShape(ArrayOperand{arrayLoad.getMemref(), arrayLoad.getShape(), - arrayLoad.getSlice()}); + CC genarr(const Fortran::evaluate::NamedEntity &x, + ComponentPath &components) { + return x.IsSymbol() ? genarr(getFirstSym(x), components) + : genarr(x.GetComponent(), components); } - /// 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]; + CC genarr(const Fortran::evaluate::DataRef &x, ComponentPath &components) { + return std::visit([&](const auto &v) { return genarr(v, components); }, + x.u); } - /// 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 pathIsEmpty(const ComponentPath &components) { + return components.reversePath.empty(); } explicit ArrayExprLowering(Fortran::lower::AbstractConverter &converter, @@ -6587,6 +6807,7 @@ return semant == ConstituentSemantics::ProjectedCopyInCopyOut; } + // ???: Do we still need this? inline bool isCustomCopyInCopyOut() { return semant == ConstituentSemantics::CustomCopyInCopyOut; } @@ -6689,7 +6910,7 @@ 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 @@ 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 @@ 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 @@ 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 --- a/flang/lib/Lower/ConvertVariable.cpp +++ b/flang/lib/Lower/ConvertVariable.cpp @@ -1119,7 +1119,11 @@ 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 --- a/flang/lib/Lower/IntrinsicCall.cpp +++ b/flang/lib/Lower/IntrinsicCall.cpp @@ -3688,6 +3688,15 @@ 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 --- 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 @@ 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 @@ // 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 @@ 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 @@ 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 @@ 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 @@ /// 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 @@ // 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 --- 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 @@ 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 @@ .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 @@ 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 @@ 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 @@ } 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 --- 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 @@ 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 --- a/flang/lib/Optimizer/Builder/MutableBox.cpp +++ b/flang/lib/Optimizer/Builder/MutableBox.cpp @@ -268,52 +268,8 @@ /// 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 @@ 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 --- /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 --- 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 --- 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ } }) .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 @@ 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 --- a/flang/lib/Optimizer/CodeGen/TypeConverter.h +++ b/flang/lib/Optimizer/CodeGen/TypeConverter.h @@ -250,6 +250,16 @@ .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 --- a/flang/lib/Optimizer/Dialect/FIROps.cpp +++ b/flang/lib/Optimizer/Dialect/FIROps.cpp @@ -1095,57 +1095,13 @@ // 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 --- a/flang/lib/Optimizer/Transforms/ExternalNameConversion.cpp +++ b/flang/lib/Optimizer/Transforms/ExternalNameConversion.cpp @@ -116,25 +116,6 @@ } }; -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 @@ 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 --- 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 --- 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 --- a/flang/test/Fir/fir-ops.fir +++ b/flang/test/Fir/fir-ops.fir @@ -53,13 +53,20 @@ %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 @@ // 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 @@ %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 --- 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 --- 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 @@ 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 @@ 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 @@ 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 @@ ! 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 @@ ! 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 @@ ! 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 @@ ! 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 @@ 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 --- a/flang/test/Lower/allocatable-callee.f90 +++ b/flang/test/Lower/allocatable-callee.f90 @@ -59,7 +59,10 @@ 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 @@ 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 --- 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 --- a/flang/test/Lower/allocatables.f90 +++ b/flang/test/Lower/allocatables.f90 @@ -124,8 +124,11 @@ 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 --- /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 --- /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 --- 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 @@ 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 --- 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 @@ ! 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 @@ 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 @@ ! 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 @@ 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 @@ 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 @@ 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})