diff --git a/flang/include/flang/Lower/AbstractConverter.h b/flang/include/flang/Lower/AbstractConverter.h --- a/flang/include/flang/Lower/AbstractConverter.h +++ b/flang/include/flang/Lower/AbstractConverter.h @@ -103,37 +103,51 @@ // Expressions //===--------------------------------------------------------------------===// - /// Generate the address of the location holding the expression, someExpr. - virtual fir::ExtendedValue genExprAddr(const SomeExpr &, StatementContext &, + /// Generate the address of the location holding the expression, \p expr. + /// If \p expr is a Designator that is not compile time contiguous, the + /// address returned is the one of a contiguous temporary storage holding the + /// expression value. The clean-up for this temporary is added to \p context. + virtual fir::ExtendedValue genExprAddr(const SomeExpr &expr, + StatementContext &context, mlir::Location *loc = nullptr) = 0; - /// Generate the address of the location holding the expression, someExpr - fir::ExtendedValue genExprAddr(const SomeExpr *someExpr, - StatementContext &stmtCtx, - mlir::Location loc) { - return genExprAddr(*someExpr, stmtCtx, &loc); + + /// Generate the address of the location holding the expression, \p expr. + fir::ExtendedValue genExprAddr(mlir::Location loc, const SomeExpr *expr, + StatementContext &stmtCtx) { + return genExprAddr(*expr, stmtCtx, &loc); + } + fir::ExtendedValue genExprAddr(mlir::Location loc, const SomeExpr &expr, + StatementContext &stmtCtx) { + return genExprAddr(expr, stmtCtx, &loc); } - /// Generate the computations of the expression to produce a value - virtual fir::ExtendedValue genExprValue(const SomeExpr &, StatementContext &, + /// Generate the computations of the expression to produce a value. + virtual fir::ExtendedValue genExprValue(const SomeExpr &expr, + StatementContext &context, mlir::Location *loc = nullptr) = 0; - /// Generate the computations of the expression, someExpr, to produce a value - fir::ExtendedValue genExprValue(const SomeExpr *someExpr, - StatementContext &stmtCtx, - mlir::Location loc) { - return genExprValue(*someExpr, stmtCtx, &loc); + + /// Generate the computations of the expression, \p expr, to produce a value. + fir::ExtendedValue genExprValue(mlir::Location loc, const SomeExpr *expr, + StatementContext &stmtCtx) { + return genExprValue(*expr, stmtCtx, &loc); + } + fir::ExtendedValue genExprValue(mlir::Location loc, const SomeExpr &expr, + StatementContext &stmtCtx) { + return genExprValue(expr, stmtCtx, &loc); } /// Generate or get a fir.box describing the expression. If SomeExpr is /// a Designator, the fir.box describes an entity over the Designator base /// storage without making a temporary. - virtual fir::ExtendedValue genExprBox(const SomeExpr &, StatementContext &, - mlir::Location) = 0; + virtual fir::ExtendedValue genExprBox(mlir::Location loc, + const SomeExpr &expr, + StatementContext &stmtCtx) = 0; /// Generate the address of the box describing the variable designated /// by the expression. The expression must be an allocatable or pointer /// designator. virtual fir::MutableBoxValue genExprMutableBox(mlir::Location loc, - const SomeExpr &) = 0; + const SomeExpr &expr) = 0; /// Get FoldingContext that is required for some expression /// analysis. diff --git a/flang/include/flang/Lower/Allocatable.h b/flang/include/flang/Lower/Allocatable.h --- a/flang/include/flang/Lower/Allocatable.h +++ b/flang/include/flang/Lower/Allocatable.h @@ -13,6 +13,7 @@ #ifndef FORTRAN_LOWER_ALLOCATABLE_H #define FORTRAN_LOWER_ALLOCATABLE_H +#include "flang/Lower/AbstractConverter.h" #include "flang/Optimizer/Builder/MutableBox.h" #include "llvm/ADT/StringRef.h" @@ -23,55 +24,55 @@ } // namespace mlir namespace fir { -class MutableBoxValue; -} +class FirOpBuilder; +} // namespace fir -namespace Fortran::parser { +namespace Fortran { +namespace parser { struct AllocateStmt; struct DeallocateStmt; -} // namespace Fortran::parser +} // namespace parser -namespace Fortran::evaluate { -template -class Expr; -struct SomeType; -} // namespace Fortran::evaluate +namespace lower { +struct SymbolBox; -namespace Fortran::lower { -class AbstractConverter; class StatementContext; -namespace pft { -struct Variable; -} +bool isArraySectionWithoutVectorSubscript(const SomeExpr &expr); /// Lower an allocate statement to fir. -void genAllocateStmt(Fortran::lower::AbstractConverter &, - const Fortran::parser::AllocateStmt &, mlir::Location); +void genAllocateStmt(AbstractConverter &converter, + const parser::AllocateStmt &stmt, mlir::Location loc); /// Lower a deallocate statement to fir. -void genDeallocateStmt(Fortran::lower::AbstractConverter &, - const Fortran::parser::DeallocateStmt &, mlir::Location); +void genDeallocateStmt(AbstractConverter &converter, + const parser::DeallocateStmt &stmt, mlir::Location loc); /// Create a MutableBoxValue for an allocatable or pointer entity. /// If the variables is a local variable that is not a dummy, it will be /// initialized to unallocated/diassociated status. -fir::MutableBoxValue createMutableBox(Fortran::lower::AbstractConverter &, - mlir::Location, - const Fortran::lower::pft::Variable &var, +fir::MutableBoxValue createMutableBox(AbstractConverter &converter, + mlir::Location loc, + const pft::Variable &var, mlir::Value boxAddr, mlir::ValueRange nonDeferredParams); -/// Update a MutableBoxValue to describe the entity designated by the expression -/// \p source. This version takes care of \p source lowering. -/// If \lbounds is not empty, it is used to defined the MutableBoxValue -/// lower bounds, otherwise, the lower bounds from \p source are used. -void associateMutableBox( - Fortran::lower::AbstractConverter &, mlir::Location, - const fir::MutableBoxValue &, - const Fortran::evaluate::Expr &source, - mlir::ValueRange lbounds, Fortran::lower::StatementContext &); - -} // namespace Fortran::lower +/// Assign a boxed value to a boxed variable, \p box (known as a +/// MutableBoxValue). Expression \p source will be lowered to build the +/// assignment. If \p lbounds is not empty, it is used to define the result's +/// lower bounds. Otherwise, the lower bounds from \p source will be used. +void associateMutableBox(AbstractConverter &converter, mlir::Location loc, + const fir::MutableBoxValue &box, + const SomeExpr &source, mlir::ValueRange lbounds, + StatementContext &stmtCtx); + +/// Is \p expr a reference to an entity with the ALLOCATABLE attribute? +bool isWholeAllocatable(const SomeExpr &expr); + +/// Is \p expr a reference to an entity with the POINTER attribute? +bool isWholePointer(const SomeExpr &expr); + +} // namespace lower +} // namespace Fortran #endif // FORTRAN_LOWER_ALLOCATABLE_H diff --git a/flang/include/flang/Lower/ComponentPath.h b/flang/include/flang/Lower/ComponentPath.h --- a/flang/include/flang/Lower/ComponentPath.h +++ b/flang/include/flang/Lower/ComponentPath.h @@ -27,8 +27,7 @@ using PathComponent = std::variant; + const evaluate::ComplexPart *, details::ImplicitSubscripts>; /// Collection of components. /// @@ -37,6 +36,8 @@ /// arguments. class ComponentPath { public: + using ExtendRefFunc = std::function; + ComponentPath(bool isImplicit) { setPC(isImplicit); } ComponentPath(bool isImplicit, const evaluate::Substring *ss) : substring(ss) { @@ -44,10 +45,15 @@ } ComponentPath() = delete; - bool isSlice() { return !trips.empty() || hasComponents(); } - bool hasComponents() { return !suffixComponents.empty(); } + bool isSlice() const { return !trips.empty() || hasComponents(); } + bool hasComponents() const { return !suffixComponents.empty(); } void clear(); + bool hasExtendCoorRef() const { return extendCoorRef.hasValue(); } + ExtendRefFunc getExtendCoorRef() const; + void resetExtendCoorRef() { extendCoorRef = llvm::None; } + void resetPC(); + llvm::SmallVector reversePath; const evaluate::Substring *substring = nullptr; bool applied = false; @@ -57,6 +63,13 @@ llvm::SmallVector suffixComponents; std::function pc; + /// In the case where a path of components involves members that are POINTER + /// or ALLOCATABLE, a dereference is required in FIR for semantic correctness. + /// This optional continuation allows the generation of those dereferences. + /// These accesses are always on Fortran entities of record types, which are + /// implicitly in-memory objects. + llvm::Optional extendCoorRef = llvm::None; + private: void setPC(bool isImplicit); }; 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 @@ -164,22 +164,6 @@ 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. @@ -190,6 +174,17 @@ SymMap &symMap, StatementContext &stmtCtx); +/// Lower a pointer assignment in an explicit iteration space. The explicit +/// space iterates over a data structure with a type of `!fir.array<... +/// !fir.box> ...>`. Lower the assignment by copying the rhs box +/// value to each array element. +void createArrayOfPointerAssignment( + AbstractConverter &converter, const SomeExpr &lhs, const SomeExpr &rhs, + ExplicitIterSpace &explicitIterSpace, ImplicitIterSpace &implicitIterSpace, + const llvm::SmallVector &lbounds, + llvm::Optional> ubounds, SymMap &symMap, + StatementContext &stmtCtx); + /// Lower an array expression with "parallel" semantics. Such a rhs expression /// is fully evaluated prior to being assigned back to a temporary array. fir::ExtendedValue createSomeArrayTempValue(AbstractConverter &converter, diff --git a/flang/include/flang/Lower/Support/Utils.h b/flang/include/flang/Lower/Support/Utils.h --- a/flang/include/flang/Lower/Support/Utils.h +++ b/flang/include/flang/Lower/Support/Utils.h @@ -79,4 +79,17 @@ return std::visit([](const auto &v) { return ignoreEvConvert(v); }, x.u); } +/// Zip two containers of the same size together and flatten the pairs. `flatZip +/// [1;2] [3;4]` yields `[1;3;2;4]`. +template +A flatZip(const A &container1, const A &container2) { + assert(container1.size() == container2.size()); + A result; + for (auto [e1, e2] : llvm::zip(container1, container2)) { + result.emplace_back(e1); + result.emplace_back(e2); + } + return result; +} + #endif // FORTRAN_LOWER_SUPPORT_UTILS_H diff --git a/flang/include/flang/Optimizer/Builder/BoxValue.h b/flang/include/flang/Optimizer/Builder/BoxValue.h --- a/flang/include/flang/Optimizer/Builder/BoxValue.h +++ b/flang/include/flang/Optimizer/Builder/BoxValue.h @@ -25,8 +25,8 @@ namespace fir { class FirOpBuilder; +class ArrayLoadOp; -class CharBoxValue; class ArrayBoxValue; class BoxValue; class CharBoxValue; @@ -61,9 +61,9 @@ AbstractBox() = delete; AbstractBox(mlir::Value addr) : addr{addr} {} - /// FIXME: this comment is not true anymore since genLoad - /// is loading constant length characters. What is the impact /// ? - /// An abstract box always contains a memory reference to a value. + /// An abstract box most often contains a memory reference to a value. Despite + /// the name here, it is possible that `addr` is a scalar value that is not a + /// memory reference. mlir::Value getAddr() const { return addr; } protected: @@ -239,18 +239,20 @@ return seqTy.getDimension(); return 0; } + /// Is this a character entity ? - bool isCharacter() const { return fir::isa_char(getEleTy()); }; + bool isCharacter() const { return fir::isa_char(getEleTy()); } + /// Is this a derived type entity ? - bool isDerived() const { return getEleTy().isa(); }; + bool isDerived() const { return getEleTy().isa(); } + + bool isDerivedWithLenParameters() const { + return fir::isRecordWithTypeParameters(getEleTy()); + } - bool isDerivedWithLengthParameters() const { - auto record = getEleTy().dyn_cast(); - return record && record.getNumLenParams() != 0; - }; /// Is this a CLASS(*)/TYPE(*) ? bool isUnlimitedPolymorphic() const { - return getEleTy().isa(); + return fir::isUnlimitedPolymorphicType(getBaseTy()); } }; @@ -259,7 +261,7 @@ /// absent optional and we need to wait until the user is referencing it /// to read it, or because it contains important information that cannot /// be exposed in FIR (e.g. non contiguous byte stride). -/// It may also store explicit bounds or length parameters that were specified +/// It may also store explicit bounds or LEN parameters that were specified /// for the entity. class BoxValue : public AbstractIrBox { public: @@ -287,7 +289,7 @@ // The extents member is not guaranteed to be field for arrays. It is only // guaranteed to be field for explicit shape arrays. In general, // explicit-shape will not come as descriptors, so this field will be empty in - // most cases. The exception are derived types with length parameters and + // most cases. The exception are derived types with LEN parameters and // polymorphic dummy argument arrays. It may be possible for the explicit // extents to conflict with the shape information that is in the box according // to 15.5.2.11 sequence association rules. @@ -301,8 +303,8 @@ // Verify constructor invariants. bool verify() const; - // Only field when the BoxValue has explicit length parameters. - // Otherwise, the length parameters are in the fir.box. + // Only field when the BoxValue has explicit LEN parameters. + // Otherwise, the LEN parameters are in the fir.box. llvm::SmallVector explicitParams; }; @@ -318,7 +320,7 @@ mlir::Value addr; llvm::SmallVector extents; llvm::SmallVector lbounds; - /// Only keep track of the deferred length parameters through variables, since + /// Only keep track of the deferred LEN parameters through variables, since /// they are the only ones that can change as per the deferred type parameters /// definition in F2018 standard section 3.147.12.2. /// Non-deferred values are returned by @@ -333,9 +335,9 @@ class MutableBoxValue : public AbstractIrBox { public: /// Create MutableBoxValue given the address \p addr of the box and the non - /// deferred length parameters \p lenParameters. The non deferred length - /// parameters must always be provided, even if they are constant and already - /// reflected in the address type. + /// deferred LEN parameters \p lenParameters. The non deferred LEN parameters + /// must always be provided, even if they are constant and already reflected + /// in the address type. MutableBoxValue(mlir::Value addr, mlir::ValueRange lenParameters, MutableProperties mutableProperties) : AbstractIrBox(addr), lenParams{lenParameters.begin(), @@ -343,7 +345,7 @@ mutableProperties{mutableProperties} { // Currently only accepts fir.(ref/ptr/heap)> mlir::Value for // the address. This may change if we accept - // fir.(ref/ptr/heap)> for scalar without length parameters. + // fir.(ref/ptr/heap)> for scalar without LEN parameters. assert(verify() && "MutableBoxValue requires mem ref to fir.box>"); } @@ -359,9 +361,9 @@ MutableBoxValue clone(mlir::Value newBox) const { return {newBox, lenParams, mutableProperties}; } - /// Does this entity has any non deferred length parameters ? + /// Does this entity has any non deferred LEN parameters? bool hasNonDeferredLenParams() const { return !lenParams.empty(); } - /// Return the non deferred length parameters. + /// Return the non deferred LEN parameters. llvm::ArrayRef nonDeferredLenParams() const { return lenParams; } friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, const MutableBoxValue &); @@ -378,8 +380,8 @@ protected: /// Validate the address type form in the constructor. bool verify() const; - /// Hold the non-deferred length parameter values (both for characters and - /// derived). Non-deferred length parameters cannot change dynamically, as + /// Hold the non-deferred LEN parameter values (both for characters and + /// derived). Non-deferred LEN parameters cannot change dynamically, as /// opposed to deferred type parameters (3.147.12.2). llvm::SmallVector lenParams; /// Set of variables holding the extents, lower bounds and @@ -411,14 +413,36 @@ /// Get the type parameters for `exv`. llvm::SmallVector getTypeParams(const ExtendedValue &exv); +//===----------------------------------------------------------------------===// +// Functions that may generate IR to recover properties from extended values. +//===----------------------------------------------------------------------===// +namespace factory { + +/// Generalized function to recover dependent type parameters. This does away +/// with the distinction between deferred and non-deferred LEN type parameters +/// (Fortran definition), since that categorization is irrelevant when getting +/// all type parameters for a value of dependent type. +llvm::SmallVector getTypeParams(mlir::Location loc, + FirOpBuilder &builder, + const ExtendedValue &exv); + +/// Specialization of get type parameters for an ArrayLoadOp. An array load must +/// either have all type parameters given as arguments or be a boxed value. +llvm::SmallVector +getTypeParams(mlir::Location loc, FirOpBuilder &builder, ArrayLoadOp load); + // The generalized function to get a vector of extents is -// fir::factory::getExtents(). See FIRBuilder.h. +/// Get extents from \p box. For fir::BoxValue and +/// fir::MutableBoxValue, this will generate code to read the extents. +llvm::SmallVector +getExtents(mlir::Location loc, FirOpBuilder &builder, const ExtendedValue &box); /// Get exactly one extent for any array-like extended value, \p exv. If \p exv /// is not an array or has rank less then \p dim, the result will be a nullptr. -mlir::Value getExtentAtDimension(const ExtendedValue &exv, - FirOpBuilder &builder, mlir::Location loc, - unsigned dim); +mlir::Value getExtentAtDimension(mlir::Location loc, FirOpBuilder &builder, + const ExtendedValue &exv, unsigned dim); + +} // namespace factory /// An extended value is a box of values pertaining to a discrete entity. It is /// used in lowering to track all the runtime values related to an entity. For @@ -507,10 +531,9 @@ return fir::unwrapSequenceType(getBaseTypeOf(exv)); } -/// Is the extended value `exv` a derived type with length parameters ? -inline bool isDerivedWithLengthParameters(const ExtendedValue &exv) { - auto record = getElementTypeOf(exv).dyn_cast(); - return record && record.getNumLenParams() != 0; +/// Is the extended value `exv` a derived type with LEN parameters? +inline bool isDerivedWithLenParameters(const ExtendedValue &exv) { + return fir::isRecordWithTypeParameters(getElementTypeOf(exv)); } } // namespace fir 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 @@ -426,12 +426,6 @@ mlir::Location loc, const fir::BoxValue &box); -/// Get extents from \p box. For fir::BoxValue and -/// fir::MutableBoxValue, this will generate code to read the extents. -llvm::SmallVector getExtents(fir::FirOpBuilder &builder, - mlir::Location loc, - const fir::ExtendedValue &box); - /// Read a fir::BoxValue into an fir::UnboxValue, a fir::ArrayBoxValue or a /// fir::CharArrayBoxValue. This should only be called if the fir::BoxValue is /// known to be contiguous given the context (or if the resulting address will @@ -440,8 +434,8 @@ fir::ExtendedValue readBoxValue(fir::FirOpBuilder &builder, mlir::Location loc, const fir::BoxValue &box); -/// Get non default (not all ones) lower bounds of \p exv. Returns empty -/// vector if the lower bounds are all ones. +/// Get the lower bounds of \p exv. NB: returns an empty vector if the lower +/// bounds are all ones, which is the default in Fortran. llvm::SmallVector getNonDefaultLowerBounds(fir::FirOpBuilder &builder, mlir::Location loc, const fir::ExtendedValue &exv); diff --git a/flang/include/flang/Optimizer/Builder/Factory.h b/flang/include/flang/Optimizer/Builder/Factory.h --- a/flang/include/flang/Optimizer/Builder/Factory.h +++ b/flang/include/flang/Optimizer/Builder/Factory.h @@ -144,26 +144,30 @@ /// Get extents from fir.shape/fir.shape_shift op. Empty result if /// \p shapeVal is empty or is a fir.shift. -inline std::vector getExtents(mlir::Value shapeVal) { +inline llvm::SmallVector getExtents(mlir::Value shapeVal) { if (shapeVal) if (auto *shapeOp = shapeVal.getDefiningOp()) { if (auto shOp = mlir::dyn_cast(shapeOp)) { auto operands = shOp.getExtents(); return {operands.begin(), operands.end()}; } - if (auto shOp = mlir::dyn_cast(shapeOp)) - return shOp.getExtents(); + if (auto shOp = mlir::dyn_cast(shapeOp)) { + auto operands = shOp.getExtents(); + return {operands.begin(), operands.end()}; + } } return {}; } /// Get origins from fir.shape_shift/fir.shift op. Empty result if /// \p shapeVal is empty or is a fir.shape. -inline std::vector getOrigins(mlir::Value shapeVal) { +inline llvm::SmallVector getOrigins(mlir::Value shapeVal) { if (shapeVal) if (auto *shapeOp = shapeVal.getDefiningOp()) { - if (auto shOp = mlir::dyn_cast(shapeOp)) - return shOp.getOrigins(); + if (auto shOp = mlir::dyn_cast(shapeOp)) { + auto operands = shOp.getOrigins(); + return {operands.begin(), operands.end()}; + } if (auto shOp = mlir::dyn_cast(shapeOp)) { auto operands = shOp.getOrigins(); return {operands.begin(), operands.end()}; 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 @@ -65,15 +65,14 @@ /// Is `t` a boxed type? inline bool isa_box_type(mlir::Type t) { - return t.isa() || t.isa() || t.isa(); + return t.isa(); } /// Is `t` a type that is always trivially pass-by-reference? Specifically, this /// is testing if `t` is a ReferenceType or any box type. Compare this to /// conformsWithPassByRef(), which includes pointers and allocatables. inline bool isa_passbyref_type(mlir::Type t) { - return t.isa() || isa_box_type(t) || - t.isa(); + return t.isa() || isa_box_type(t); } /// Is `t` a type that can conform to be pass-by-reference? Depending on the @@ -88,8 +87,7 @@ /// Is `t` a FIR dialect aggregate type? inline bool isa_aggregate(mlir::Type t) { - return t.isa() || fir::isa_derived(t) || - t.isa(); + return t.isa() || fir::isa_derived(t); } /// Extract the `Type` pointed to from a FIR memory reference type. If `t` is @@ -102,13 +100,12 @@ /// Is `t` a FIR Real or MLIR Float type? inline bool isa_real(mlir::Type t) { - return t.isa() || t.isa(); + return t.isa(); } /// Is `t` an integral type? inline bool isa_integer(mlir::Type t) { - return t.isa() || t.isa() || - t.isa(); + return t.isa(); } mlir::Type parseFirType(FIROpsDialect *, mlir::DialectAsmParser &parser); @@ -121,7 +118,7 @@ /// Is `t` a FIR or MLIR Complex type? inline bool isa_complex(mlir::Type t) { - return t.isa() || t.isa(); + return t.isa(); } /// Is `t` a CHARACTER type? Does not check the length. @@ -193,6 +190,20 @@ return t; } +/// Unwrap either a sequence or a boxed sequence type, returning the element +/// type of the sequence type. +/// e.g., +/// !fir.array<...xT> -> T +/// !fir.box>> -> T +/// otherwise +/// T -> T +mlir::Type unwrapSeqOrBoxedSeqType(mlir::Type ty); + +/// Unwrap all referential and sequential outer types (if any). Returns the +/// element type. This is useful for determining the element type of any object +/// memory reference, whether it is a single instance or a series of instances. +mlir::Type unwrapAllRefAndSeqType(mlir::Type ty); + /// 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) { @@ -224,6 +235,10 @@ /// Return true iff `ty` is the type of an ALLOCATABLE entity or value. bool isAllocatableType(mlir::Type ty); +/// Return true iff `ty` is the type of an unlimited polymorphic entity or +/// value. +bool isUnlimitedPolymorphicType(mlir::Type ty); + /// Return true iff `ty` is a RecordType with members that are allocatable. bool isRecordWithAllocatableMember(mlir::Type ty); diff --git a/flang/include/flang/Runtime/io-api.h b/flang/include/flang/Runtime/io-api.h --- a/flang/include/flang/Runtime/io-api.h +++ b/flang/include/flang/Runtime/io-api.h @@ -248,9 +248,7 @@ bool IONAME(OutputInteger16)(Cookie, std::int16_t); bool IONAME(OutputInteger32)(Cookie, std::int32_t); bool IONAME(OutputInteger64)(Cookie, std::int64_t); -#ifdef __SIZEOF_INT128__ bool IONAME(OutputInteger128)(Cookie, common::int128_t); -#endif bool IONAME(InputInteger)(Cookie, std::int64_t &, int kind = 8); bool IONAME(OutputReal32)(Cookie, float); bool IONAME(InputReal32)(Cookie, float &); diff --git a/flang/lib/Lower/Allocatable.cpp b/flang/lib/Lower/Allocatable.cpp --- a/flang/lib/Lower/Allocatable.cpp +++ b/flang/lib/Lower/Allocatable.cpp @@ -13,6 +13,7 @@ #include "flang/Lower/Allocatable.h" #include "flang/Evaluate/tools.h" #include "flang/Lower/AbstractConverter.h" +#include "flang/Lower/IterationSpace.h" #include "flang/Lower/PFTBuilder.h" #include "flang/Lower/Runtime.h" #include "flang/Lower/StatementContext.h" @@ -58,12 +59,12 @@ fir::FirOpBuilder &builder = converter.getFirOpBuilder(); hasStat = builder.createBool(loc, statExpr != nullptr); statAddr = statExpr - ? fir::getBase(converter.genExprAddr(statExpr, stmtCtx, loc)) + ? fir::getBase(converter.genExprAddr(loc, statExpr, stmtCtx)) : mlir::Value{}; errMsgAddr = statExpr && errMsgExpr ? builder.createBox(loc, - converter.genExprAddr(errMsgExpr, stmtCtx, loc)) + converter.genExprAddr(loc, errMsgExpr, stmtCtx)) : builder.create( loc, fir::BoxType::get(mlir::NoneType::get(builder.getContext()))); @@ -343,7 +344,7 @@ if (const std::optional &lbExpr = std::get<0>(shapeSpec.t)) { lb = fir::getBase(converter.genExprValue( - Fortran::semantics::GetExpr(*lbExpr), stmtCtx, loc)); + loc, Fortran::semantics::GetExpr(*lbExpr), stmtCtx)); lb = builder.createConvert(loc, idxTy, lb); } else { lb = one; @@ -351,7 +352,7 @@ lbounds.emplace_back(lb); } mlir::Value ub = fir::getBase(converter.genExprValue( - Fortran::semantics::GetExpr(std::get<1>(shapeSpec.t)), stmtCtx, loc)); + loc, Fortran::semantics::GetExpr(std::get<1>(shapeSpec.t)), stmtCtx)); ub = builder.createConvert(loc, idxTy, ub); if (lb) { mlir::Value diff = builder.create(loc, ub, lb); @@ -404,11 +405,11 @@ if (const std::optional &lbExpr = std::get<0>(bounds)) lb = fir::getBase(converter.genExprValue( - Fortran::semantics::GetExpr(*lbExpr), stmtCtx, loc)); + loc, Fortran::semantics::GetExpr(*lbExpr), stmtCtx)); else lb = builder.createIntegerConstant(loc, idxTy, 1); mlir::Value ub = fir::getBase(converter.genExprValue( - Fortran::semantics::GetExpr(std::get<1>(bounds)), stmtCtx, loc)); + loc, Fortran::semantics::GetExpr(std::get<1>(bounds)), stmtCtx)); mlir::Value dimIndex = builder.createIntegerConstant(loc, i32Ty, iter.index()); // Runtime call @@ -438,7 +439,7 @@ Fortran::lower::StatementContext stmtCtx; Fortran::lower::SomeExpr lenExpr{*intExpr}; lenParams.push_back( - fir::getBase(converter.genExprValue(lenExpr, stmtCtx, &loc))); + fir::getBase(converter.genExprValue(loc, lenExpr, stmtCtx))); } } } @@ -526,8 +527,8 @@ void Fortran::lower::genDeallocateStmt( Fortran::lower::AbstractConverter &converter, const Fortran::parser::DeallocateStmt &stmt, mlir::Location loc) { - const Fortran::lower::SomeExpr *statExpr{nullptr}; - const Fortran::lower::SomeExpr *errMsgExpr{nullptr}; + const Fortran::lower::SomeExpr *statExpr = nullptr; + const Fortran::lower::SomeExpr *errMsgExpr = nullptr; for (const Fortran::parser::StatOrErrmsg &statOrErr : std::get>(stmt.t)) std::visit(Fortran::common::visitors{ @@ -671,8 +672,8 @@ // MutableBoxValue reading interface implementation //===----------------------------------------------------------------------===// -static bool -isArraySectionWithoutVectorSubscript(const Fortran::lower::SomeExpr &expr) { +bool Fortran::lower::isArraySectionWithoutVectorSubscript( + const Fortran::lower::SomeExpr &expr) { return expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) && !Fortran::evaluate::UnwrapWholeSymbolDataRef(expr) && !Fortran::evaluate::HasVectorSubscript(expr); @@ -687,12 +688,28 @@ fir::factory::disassociateMutableBox(builder, loc, box); return; } - // The right hand side must not be evaluated in a temp. - // Array sections can be described by fir.box without making a temp. - // Otherwise, do not generate a fir.box to avoid having to later use a - // fir.rebox to implement the pointer association. + + // The right hand side is not be evaluated into a temp. Array sections can + // typically be represented as a value of type `!fir.box`. However, an + // expression that uses vector subscripts cannot be emboxed. In that case, + // generate a reference to avoid having to later use a fir.rebox to implement + // the pointer association. fir::ExtendedValue rhs = isArraySectionWithoutVectorSubscript(source) - ? converter.genExprBox(source, stmtCtx, loc) - : converter.genExprAddr(source, stmtCtx); + ? converter.genExprBox(loc, source, stmtCtx) + : converter.genExprAddr(loc, source, stmtCtx); fir::factory::associateMutableBox(builder, loc, box, rhs, lbounds); } + +bool Fortran::lower::isWholeAllocatable(const Fortran::lower::SomeExpr &expr) { + if (const Fortran::semantics::Symbol *sym = + Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr)) + return Fortran::semantics::IsAllocatable(*sym); + return false; +} + +bool Fortran::lower::isWholePointer(const Fortran::lower::SomeExpr &expr) { + if (const Fortran::semantics::Symbol *sym = + Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr)) + return Fortran::semantics::IsPointer(*sym); + return false; +} 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 @@ -373,16 +373,12 @@ return Fortran::lower::createSomeExtendedExpression( loc ? *loc : toLocation(), *this, expr, localSymbols, context); } - fir::MutableBoxValue - genExprMutableBox(mlir::Location loc, - const Fortran::lower::SomeExpr &expr) override final { - return Fortran::lower::createMutableBox(loc, *this, expr, localSymbols); - } - fir::ExtendedValue genExprBox(const Fortran::lower::SomeExpr &expr, - Fortran::lower::StatementContext &context, - mlir::Location loc) override final { + + fir::ExtendedValue + genExprBox(mlir::Location loc, const Fortran::lower::SomeExpr &expr, + Fortran::lower::StatementContext &stmtCtx) override final { return Fortran::lower::createBoxValue(loc, *this, expr, localSymbols, - context); + stmtCtx); } Fortran::evaluate::FoldingContext &getFoldingContext() override final { @@ -441,8 +437,8 @@ // Create a contiguous temp with the same shape and length as // the original variable described by a fir.box. llvm::SmallVector extents = - fir::factory::getExtents(*builder, loc, hexv); - if (box.isDerivedWithLengthParameters()) + fir::factory::getExtents(loc, *builder, hexv); + if (box.isDerivedWithLenParameters()) TODO(loc, "get length parameters from derived type BoxValue"); if (box.isCharacter()) { mlir::Value len = fir::factory::readCharLen(*builder, loc, box); @@ -459,7 +455,7 @@ }, [&](const auto &) -> fir::ExtendedValue { mlir::Value temp = - allocate(fir::factory::getExtents(*builder, loc, hexv), + allocate(fir::factory::getExtents(loc, *builder, hexv), fir::getTypeParams(hexv)); return fir::substBase(hexv, temp); }); @@ -1598,7 +1594,7 @@ fir::ExtendedValue genAssociateSelector(const Fortran::lower::SomeExpr &selector, Fortran::lower::StatementContext &stmtCtx) { - return isArraySectionWithoutVectorSubscript(selector) + return Fortran::lower::isArraySectionWithoutVectorSubscript(selector) ? Fortran::lower::createSomeArrayBox(*this, selector, localSymbols, stmtCtx) : genExprAddr(selector, stmtCtx); @@ -1850,9 +1846,16 @@ /// 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)) { + /// In a FORALL context, the assignment may be a pointer assignment and the \p + /// lbounds and \p ubounds parameters should only be used in such a pointer + /// assignment case. (If both are None then the array assignment cannot be a + /// pointer assignment.) + void genArrayAssignment( + const Fortran::evaluate::Assignment &assign, + Fortran::lower::StatementContext &stmtCtx, + llvm::Optional> lbounds = llvm::None, + llvm::Optional> ubounds = llvm::None) { + if (Fortran::lower::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( @@ -1861,6 +1864,17 @@ return; } + if (lbounds.hasValue()) { + // Array of POINTER entities, with elemental assignment. + if (!Fortran::lower::isWholePointer(assign.lhs)) + fir::emitFatalError(toLocation(), "pointer assignment to non-pointer"); + + Fortran::lower::createArrayOfPointerAssignment( + *this, assign.lhs, assign.rhs, explicitIterSpace, implicitIterSpace, + lbounds.getValue(), ubounds, localSymbols, stmtCtx); + return; + } + if (!implicitIterationSpace() && !explicitIterationSpace()) { // No masks and the iteration space is implied by the array, so create a // simple array assignment. @@ -1885,13 +1899,6 @@ : 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 = @@ -1900,10 +1907,10 @@ } #endif - static bool isWholeAllocatable(const Fortran::lower::SomeExpr &expr) { - const Fortran::semantics::Symbol *sym = - Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr); - return sym && Fortran::semantics::IsAllocatable(*sym); + inline fir::MutableBoxValue + genExprMutableBox(mlir::Location loc, + const Fortran::lower::SomeExpr &expr) override final { + return Fortran::lower::createMutableBox(loc, *this, expr, localSymbols); } /// Shared for both assignments and pointer assignments. @@ -1929,7 +1936,8 @@ 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)) + if (lhsType->IsPolymorphic() && + Fortran::lower::isWholeAllocatable(assign.lhs)) TODO(loc, "assignment to polymorphic allocatable"); // Note: No ad-hoc handling for pointers is required here. The @@ -1950,7 +1958,8 @@ fir::ExtendedValue rhs = isNumericScalar ? genExprValue(assign.rhs, stmtCtx) : genExprAddr(assign.rhs, stmtCtx); - bool lhsIsWholeAllocatable = isWholeAllocatable(assign.lhs); + const bool lhsIsWholeAllocatable = + Fortran::lower::isWholeAllocatable(assign.lhs); llvm::Optional lhsRealloc; llvm::Optional lhsMutableBox; auto lhs = [&]() -> fir::ExtendedValue { @@ -1959,7 +1968,7 @@ llvm::SmallVector lengthParams; if (const fir::CharBoxValue *charBox = rhs.getCharBox()) lengthParams.push_back(charBox->getLen()); - else if (fir::isDerivedWithLengthParameters(rhs)) + else if (fir::isDerivedWithLenParameters(rhs)) TODO(loc, "assignment to derived type allocatable with " "length parameters"); lhsRealloc = fir::factory::genReallocIfNeeded( @@ -2023,7 +2032,7 @@ // [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)) + if (Fortran::evaluate::IsProcedure(assign.rhs)) TODO(loc, "procedure pointer assignment"); std::optional lhsType = assign.lhs.GetType(); @@ -2034,23 +2043,19 @@ (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); - } + // Pointer assignment in FORALL context. Copy the rhs box value + // into the lhs box variable. + genArrayAssignment(assign, stmtCtx, lbounds); + return; } + fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs); + Fortran::lower::associateMutableBox(*this, loc, lhs, assign.rhs, + lbounds, stmtCtx); }, // [4] Pointer assignment with bounds-remapping. R1036: a @@ -2066,14 +2071,6 @@ (rhsType && rhsType->IsPolymorphic())) TODO(loc, "pointer assignment involving polymorphic entity"); - // FIXME: in the explicit space context, we want to use - // ScalarArrayExprLowering here. - fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs); - if (Fortran::evaluate::UnwrapExpr( - assign.rhs)) { - fir::factory::disassociateMutableBox(*builder, loc, lhs); - return; - } llvm::SmallVector lbounds; llvm::SmallVector ubounds; for (const std::pair( + assign.rhs)) { + fir::factory::disassociateMutableBox(*builder, loc, lhs); + return; + } // Do not generate a temp in case rhs is an array section. fir::ExtendedValue rhs = - isArraySectionWithoutVectorSubscript(assign.rhs) + Fortran::lower::isArraySectionWithoutVectorSubscript( + assign.rhs) ? Fortran::lower::createSomeArrayBox( *this, assign.rhs, localSymbols, stmtCtx) : genExprAddr(assign.rhs, stmtCtx); @@ -2096,11 +2106,8 @@ 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) + if (!inners.empty()) builder->create(loc, inners); - } } }, }, @@ -2349,7 +2356,7 @@ 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 { + auto mapPassedEntity = [&](const auto arg) { if (arg.passBy == PassBy::AddressAndLength) { // TODO: now that fir call has some attributes regarding character // return, PassBy::AddressAndLength should be retired. diff --git a/flang/lib/Lower/ComponentPath.cpp b/flang/lib/Lower/ComponentPath.cpp --- a/flang/lib/Lower/ComponentPath.cpp +++ b/flang/lib/Lower/ComponentPath.cpp @@ -48,6 +48,15 @@ return false; } +void Fortran::lower::ComponentPath::resetPC() { pc = getIdentityFunc(); } + void Fortran::lower::ComponentPath::setPC(bool isImplicit) { pc = isImplicit ? getIdentityFunc() : getNullaryFunc(); + resetExtendCoorRef(); +} + +Fortran::lower::ComponentPath::ExtendRefFunc +Fortran::lower::ComponentPath::getExtendCoorRef() const { + return hasExtendCoorRef() ? extendCoorRef.getValue() + : [](mlir::Value v) { return v; }; } 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 @@ -46,6 +46,7 @@ #include "flang/Semantics/tools.h" #include "flang/Semantics/type.h" #include "mlir/Dialect/Func/IR/FuncOps.h" +#include "llvm/ADT/TypeSwitch.h" #include "llvm/Support/CommandLine.h" #include "llvm/Support/Debug.h" #include "llvm/Support/ErrorHandling.h" @@ -211,7 +212,8 @@ fir::ArrayLoadOp load, llvm::ArrayRef path, mlir::Value newBase, mlir::Value newLen = {}) { // Recover the extended value from the load. - assert(!load.getSlice() && "slice is not allowed"); + if (load.getSlice()) + fir::emitFatalError(loc, "array_load with slice is not allowed"); mlir::Type arrTy = load.getType(); if (!path.empty()) { mlir::Type ty = fir::applyPathToType(arrTy, path); @@ -235,39 +237,56 @@ arrTy = ty.cast(); } + auto arrayToExtendedValue = + [&](const llvm::SmallVector &extents, + const llvm::SmallVector &origins) -> fir::ExtendedValue { + mlir::Type eleTy = fir::unwrapSequenceType(arrTy); + if (fir::isa_char(eleTy)) { + mlir::Value len = newLen; + if (!len) + len = fir::factory::CharacterExprHelper{builder, loc}.getLength( + load.getMemref()); + if (!len) { + assert(load.getTypeparams().size() == 1 && + "length must be in array_load"); + len = load.getTypeparams()[0]; + } + return fir::CharArrayBoxValue(newBase, len, extents, origins); + } + return fir::ArrayBoxValue(newBase, extents, origins); + }; // Use the shape op, if there is one. mlir::Value shapeVal = load.getShape(); if (shapeVal) { if (!mlir::isa(shapeVal.getDefiningOp())) { - mlir::Type eleTy = fir::unwrapSequenceType(arrTy); - std::vector extents = fir::factory::getExtents(shapeVal); - std::vector origins = fir::factory::getOrigins(shapeVal); - if (fir::isa_char(eleTy)) { - mlir::Value len = newLen; - if (!len) - len = fir::factory::CharacterExprHelper{builder, loc}.getLength( - load.getMemref()); - if (!len) { - assert(load.getTypeparams().size() == 1 && - "length must be in array_load"); - len = load.getTypeparams()[0]; - } - return fir::CharArrayBoxValue(newBase, len, extents, origins); - } - return fir::ArrayBoxValue(newBase, extents, origins); + auto extents = fir::factory::getExtents(shapeVal); + auto origins = fir::factory::getOrigins(shapeVal); + return arrayToExtendedValue(extents, origins); } if (!fir::isa_box_type(load.getMemref().getType())) fir::emitFatalError(loc, "shift op is invalid in this context"); } - // There is no shape or the array is in a box. Extents and lower bounds must - // be read at runtime. - if (path.empty() && !shapeVal) { - fir::ExtendedValue exv = - fir::factory::readBoxValue(builder, loc, load.getMemref()); - return fir::substBase(exv, newBase); + // If we're dealing with the array_load op (not a subobject) and the load does + // not have any type parameters, then read the extents from the original box. + // The origin may be either from the box or a shift operation. Create and + // return the array extended value. + if (path.empty() && load.getTypeparams().empty()) { + auto oldBox = load.getMemref(); + fir::ExtendedValue exv = fir::factory::readBoxValue(builder, loc, oldBox); + auto extents = fir::factory::getExtents(loc, builder, exv); + auto origins = fir::factory::getNonDefaultLowerBounds(builder, loc, exv); + if (shapeVal) { + // shapeVal is a ShiftOp and load.memref() is a boxed value. + newBase = builder.create(loc, oldBox.getType(), oldBox, + shapeVal, /*slice=*/mlir::Value{}); + origins = fir::factory::getOrigins(shapeVal); + } + return fir::substBase(arrayToExtendedValue(extents, origins), newBase); } - TODO(loc, "component is boxed, retreive its type parameters"); + TODO(loc, "path to a POINTER, ALLOCATABLE, or other component that requires " + "dereferencing; generating the type parameters is a hard " + "requirement for correctness."); } /// Place \p exv in memory if it is not already a memory reference. If @@ -304,7 +323,7 @@ assert(exv.rank() == 0 && "input to scalar memory copy must be a scalar"); if (exv.getCharBox() != nullptr) return fir::factory::CharacterExprHelper{builder, loc}.createTempFrom(exv); - if (fir::isDerivedWithLengthParameters(exv)) + if (fir::isDerivedWithLenParameters(exv)) TODO(loc, "copy derived type with length parameters"); mlir::Type type = fir::unwrapPassByRefType(fir::getBase(exv).getType()); fir::ExtendedValue temp = builder.createTemporary(loc, type); @@ -2281,7 +2300,7 @@ assert(type && "expected descriptor or memory type"); mlir::Location loc = getLoc(); llvm::SmallVector extents = - fir::factory::getExtents(builder, loc, mold); + fir::factory::getExtents(loc, builder, mold); llvm::SmallVector allocMemTypeParams = fir::getTypeParams(mold); mlir::Value charLen; @@ -2605,7 +2624,7 @@ [&](const fir::BoxValue &x) -> ExtValue { // Derived type scalar that may be polymorphic. assert(!x.hasRank() && x.isDerived()); - if (x.isDerivedWithLengthParameters()) + if (x.isDerivedWithLenParameters()) fir::emitFatalError( loc, "making temps for derived type with length parameters"); // TODO: polymorphic aspects should be kept but for now the temp @@ -2711,6 +2730,167 @@ .end(); } + /// Lower a designator to a variable that may be absent at runtime into an + /// ExtendedValue where all the properties (base address, shape and length + /// parameters) can be safely read (set to zero if not present). It also + /// returns a boolean mlir::Value telling if the variable is present at + /// runtime. + /// This is useful to later be able to do conditional copy-in/copy-out + /// or to retrieve the base address without having to deal with the case + /// where the actual may be an absent fir.box. + std::pair + prepareActualThatMayBeAbsent(const Fortran::lower::SomeExpr &expr) { + mlir::Location loc = getLoc(); + if (Fortran::evaluate::IsAllocatableOrPointerObject( + expr, converter.getFoldingContext())) { + // Fortran 2018 15.5.2.12 point 1: If unallocated/disassociated, + // it is as if the argument was absent. The main care here is to + // not do a copy-in/copy-out because the temp address, even though + // pointing to a null size storage, would not be a nullptr and + // therefore the argument would not be considered absent on the + // callee side. Note: if wholeSymbol is optional, it cannot be + // absent as per 15.5.2.12 point 7. and 8. We rely on this to + // un-conditionally read the allocatable/pointer descriptor here. + fir::MutableBoxValue mutableBox = genMutableBoxValue(expr); + mlir::Value isPresent = fir::factory::genIsAllocatedOrAssociatedTest( + builder, loc, mutableBox); + fir::ExtendedValue actualArg = + fir::factory::genMutableBoxRead(builder, loc, mutableBox); + return {actualArg, isPresent}; + } + // Absent descriptor cannot be read. To avoid any issue in + // copy-in/copy-out, and when retrieving the address/length + // create an descriptor pointing to a null address here if the + // fir.box is absent. + ExtValue actualArg = gen(expr); + mlir::Value actualArgBase = fir::getBase(actualArg); + mlir::Value isPresent = builder.create( + loc, builder.getI1Type(), actualArgBase); + if (!actualArgBase.getType().isa()) + return {actualArg, isPresent}; + ExtValue safeToReadBox; + return {safeToReadBox, isPresent}; + } + + /// Create a temp on the stack for scalar actual arguments that may be absent + /// at runtime, but must be passed via a temp if they are presents. + fir::ExtendedValue + createScalarTempForArgThatMayBeAbsent(ExtValue actualArg, + mlir::Value isPresent) { + mlir::Location loc = getLoc(); + mlir::Type type = fir::unwrapRefType(fir::getBase(actualArg).getType()); + if (fir::isDerivedWithLenParameters(actualArg)) + TODO(loc, "parametrized derived type optional scalar argument copy-in"); + if (const fir::CharBoxValue *charBox = actualArg.getCharBox()) { + mlir::Value len = charBox->getLen(); + mlir::Value zero = builder.createIntegerConstant(loc, len.getType(), 0); + len = builder.create(loc, isPresent, len, zero); + mlir::Value temp = builder.createTemporary( + loc, type, /*name=*/{}, /*shape=*/{}, mlir::ValueRange{len}, + llvm::ArrayRef{ + Fortran::lower::getAdaptToByRefAttr(builder)}); + return fir::CharBoxValue{temp, len}; + } + assert((fir::isa_trivial(type) || type.isa()) && + "must be simple scalar"); + return builder.createTemporary( + loc, type, + llvm::ArrayRef{ + Fortran::lower::getAdaptToByRefAttr(builder)}); + } + + /// Lower an actual argument that must be passed via an address. + /// This generates of the copy-in/copy-out if the actual is not contiguous, or + /// the creation of the temp if the actual is a variable and \p byValue is + /// true. It handles the cases where the actual may be absent, and all of the + /// copying has to be conditional at runtime. + ExtValue prepareActualToBaseAddressLike( + const Fortran::lower::SomeExpr &expr, + const Fortran::lower::CallerInterface::PassedEntity &arg, + CopyOutPairs ©OutPairs, bool byValue) { + mlir::Location loc = getLoc(); + const bool isArray = expr.Rank() > 0; + const bool actualArgIsVariable = Fortran::evaluate::IsVariable(expr); + // It must be possible to modify VALUE arguments on the callee side, even + // if the actual argument is a literal or named constant. Hence, the + // address of static storage must not be passed in that case, and a copy + // must be made even if this is not a variable. + // Note: isArray should be used here, but genBoxArg already creates copies + // for it, so do not duplicate the copy until genBoxArg behavior is changed. + const bool isStaticConstantByValue = + byValue && Fortran::evaluate::IsActuallyConstant(expr) && + (isCharacterType(expr)); + const bool variableNeedsCopy = + actualArgIsVariable && + (byValue || (isArray && !Fortran::evaluate::IsSimplyContiguous( + expr, converter.getFoldingContext()))); + const bool needsCopy = isStaticConstantByValue || variableNeedsCopy; + auto argAddr = [&]() -> ExtValue { + if (!actualArgIsVariable && !needsCopy) + // Actual argument is not a variable. Make sure a variable address is + // not passed. + return genTempExtAddr(expr); + ExtValue baseAddr; + if (arg.isOptional() && Fortran::evaluate::MayBePassedAsAbsentOptional( + expr, converter.getFoldingContext())) { + auto [actualArgBind, isPresent] = prepareActualThatMayBeAbsent(expr); + const ExtValue &actualArg = actualArgBind; + if (!needsCopy) + return actualArg; + + if (isArray) + return genCopyIn(actualArg, arg, copyOutPairs, + isPresent /*, byValue*/); + // Scalars, create a temp, and use it conditionally at runtime if + // the argument is present. + ExtValue temp = + createScalarTempForArgThatMayBeAbsent(actualArg, isPresent); + mlir::Type tempAddrTy = fir::getBase(temp).getType(); + mlir::Value selectAddr = + builder + .genIfOp(loc, {tempAddrTy}, isPresent, + /*withElseRegion=*/true) + .genThen([&]() { + fir::factory::genScalarAssignment(builder, loc, temp, + actualArg); + builder.create(loc, fir::getBase(temp)); + }) + .genElse([&]() { + mlir::Value absent = + builder.create(loc, tempAddrTy); + builder.create(loc, absent); + }) + .getResults()[0]; + return fir::substBase(temp, selectAddr); + } + // Actual cannot be absent, the actual argument can safely be + // copied-in/copied-out without any care if needed. + if (isArray) { + ExtValue box = genBoxArg(expr); + if (needsCopy) + return genCopyIn(box, arg, copyOutPairs, + /*restrictCopyAtRuntime=*/llvm::None /*, byValue*/); + // Contiguous: just use the box we created above! + // This gets "unboxed" below, if needed. + return box; + } + // Actual argument is a non-optional, non-pointer, non-allocatable + // scalar. + ExtValue actualArg = genExtAddr(expr); + if (needsCopy) + return createInMemoryScalarCopy(builder, loc, actualArg); + return actualArg; + }(); + // Scalar and contiguous expressions may be lowered to a fir.box, + // either to account for potential polymorphism, or because lowering + // did not account for some contiguity hints. + // Here, polymorphism does not matter (an entity of the declared type + // is passed, not one of the dynamic type), and the expr is known to + // be simply contiguous, so it is safe to unbox it and pass the + // address without making a copy. + return readIfBoxValue(argAddr); + } + /// Lower a non-elemental procedure reference. ExtValue genRawProcedureRef(const Fortran::evaluate::ProcedureRef &procRef, llvm::Optional resultType) { @@ -2792,8 +2972,7 @@ /*nonDeferredParams=*/mlir::ValueRange{}, /*mutableProperties=*/{}); Fortran::lower::associateMutableBox(converter, loc, pointer, *expr, - /*lbounds*/ mlir::ValueRange{}, - stmtCtx); + /*lbounds=*/llvm::None, stmtCtx); caller.placeInput(arg, irBox); continue; } @@ -3350,8 +3529,8 @@ Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, const TL &lhs, const TR &rhs) { - ArrayExprLowering ael{converter, stmtCtx, symMap, - ConstituentSemantics::CopyInCopyOut}; + ArrayExprLowering ael(converter, stmtCtx, symMap, + ConstituentSemantics::CopyInCopyOut); ael.lowerArrayAssignment(lhs, rhs); } @@ -3406,6 +3585,50 @@ ael.lowerArrayAssignment(lhs, rhs); } + //===--------------------------------------------------------------------===// + // Array assignment to array of pointer box values. + //===--------------------------------------------------------------------===// + + /// Entry point for assignment to pointer in an array of pointers. + static void lowerArrayOfPointerAssignment( + Fortran::lower::AbstractConverter &converter, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, + const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs, + Fortran::lower::ExplicitIterSpace &explicitSpace, + Fortran::lower::ImplicitIterSpace &implicitSpace, + const llvm::SmallVector &lbounds, + llvm::Optional> ubounds) { + ArrayExprLowering ael(converter, stmtCtx, symMap, + ConstituentSemantics::CopyInCopyOut, &explicitSpace, + &implicitSpace); + ael.lowerArrayOfPointerAssignment(lhs, rhs, lbounds, ubounds); + } + + /// Scalar pointer assignment in an explicit iteration space. + /// + /// Pointers may be bound to targets in a FORALL context. This is a scalar + /// assignment in the sense there is never an implied iteration space, even if + /// the pointer is to a target with non-zero rank. Since the pointer + /// assignment must appear in a FORALL construct, correctness may require that + /// the array of pointers follow copy-in/copy-out semantics. The pointer + /// assignment may include a bounds-spec (lower bounds), a bounds-remapping + /// (lower and upper bounds), or neither. + void lowerArrayOfPointerAssignment( + const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs, + const llvm::SmallVector &lbounds, + llvm::Optional> ubounds) { + setPointerAssignmentBounds(lbounds, ubounds); + if (rhs.Rank() == 0 || + (Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(rhs) && + Fortran::evaluate::IsAllocatableOrPointerObject( + rhs, converter.getFoldingContext()))) { + lowerScalarAssignment(lhs, rhs); + return; + } + TODO(getLoc(), + "auto boxing of a ranked expression on RHS for pointer assignment"); + } + //===--------------------------------------------------------------------===// // Array assignment to allocatable array //===--------------------------------------------------------------------===// @@ -3437,7 +3660,7 @@ // be to an array of allocatable arrays rather than a single allocatable // array. fir::MutableBoxValue mutableBox = - createMutableBox(loc, converter, lhs, symMap); + Fortran::lower::createMutableBox(loc, converter, lhs, symMap); mlir::Type resultTy = converter.genType(rhs); if (rhs.Rank() > 0) determineShapeOfDest(rhs); @@ -3451,7 +3674,7 @@ // character, it cannot be taken from array_loads since it may be // changed by concatenations). if ((mutableBox.isCharacter() && !mutableBox.hasNonDeferredLenParams()) || - mutableBox.isDerivedWithLengthParameters()) + mutableBox.isDerivedWithLenParameters()) TODO(loc, "gather rhs length parameters in assignment to allocatable"); // The allocatable must take lower bounds from the expr if it is @@ -3466,8 +3689,7 @@ Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(rhs)) { assert(arrayOperands.size() == 1 && "lbounds can only come from one array"); - std::vector lbs = - fir::factory::getOrigins(arrayOperands[0].shape); + auto lbs = fir::factory::getOrigins(arrayOperands[0].shape); lbounds.append(lbs.begin(), lbs.end()); } fir::factory::MutableBoxReallocation realloc = @@ -3507,6 +3729,7 @@ } ExtValue lowerBoxedArrayExpr(const Fortran::lower::SomeExpr &exp) { + PushSemantics(ConstituentSemantics::BoxValue); return std::visit( [&](const auto &e) { auto f = genarr(e); @@ -3703,12 +3926,12 @@ builder.restoreInsertionPoint(insPt); } - template - ExtValue lowerScalarAssignment(const A &lhs, const B &rhs) { + ExtValue lowerScalarAssignment(const Fortran::lower::SomeExpr &lhs, + const Fortran::lower::SomeExpr &rhs) { + PushSemantics(ConstituentSemantics::RefTransparent); // 1) Lower the rhs expression with array_fetch op(s). IterationSpace iters; iters.setElement(genarr(rhs)(iters)); - fir::ExtendedValue elementalExv = iters.elementExv(); // 2) Lower the lhs expression to an array_update. semant = ConstituentSemantics::ProjectedCopyInCopyOut; auto lexv = genarr(lhs)(iters); @@ -3723,15 +3946,12 @@ explicitSpace->setInnerArg(offset, fir::getBase(lexv)); builder.create(getLoc(), fir::getBase(lexv)); }; - if (auto updateOp = mlir::dyn_cast( - fir::getBase(lexv).getDefiningOp())) - createResult(updateOp); - else if (auto amend = mlir::dyn_cast( - fir::getBase(lexv).getDefiningOp())) - createResult(amend); - else if (auto modifyOp = mlir::dyn_cast( - fir::getBase(lexv).getDefiningOp())) - createResult(modifyOp); + llvm::TypeSwitch( + fir::getBase(lexv).getDefiningOp()) + .Case([&](fir::ArrayUpdateOp op) { createResult(op); }) + .Case([&](fir::ArrayAmendOp op) { createResult(op); }) + .Case([&](fir::ArrayModifyOp op) { createResult(op); }) + .Default([&](mlir::Operation *) {}); return lexv; } @@ -3793,7 +4013,7 @@ private: void determineShapeOfDest(const fir::ExtendedValue &lhs) { - destShape = fir::factory::getExtents(builder, getLoc(), lhs); + destShape = fir::factory::getExtents(getLoc(), builder, lhs); } void determineShapeOfDest(const Fortran::lower::SomeExpr &lhs) { @@ -3832,7 +4052,7 @@ mlir::Location loc = getLoc(); mlir::IndexType idxTy = builder.getIndexType(); llvm::SmallVector definedShape = - fir::factory::getExtents(builder, loc, exv); + fir::factory::getExtents(loc, builder, exv); mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1); for (auto ss : llvm::enumerate(x.subscript())) { std::visit(Fortran::common::visitors{ @@ -3913,6 +4133,36 @@ bounds.push_back(fir::getBase(asScalar(*upper))); } + /// Convert the original value, \p origVal, to type \p eleTy. When in a + /// pointer assignment context, generate an appropriate `fir.rebox` for + /// dealing with any bounds parameters on the pointer assignment. + mlir::Value convertElementForUpdate(mlir::Location loc, mlir::Type eleTy, + mlir::Value origVal) { + mlir::Value val = builder.createConvert(loc, eleTy, origVal); + if (isBoundsSpec()) { + auto lbs = lbounds.getValue(); + if (lbs.size() > 0) { + // Rebox the value with user-specified shift. + auto shiftTy = fir::ShiftType::get(eleTy.getContext(), lbs.size()); + mlir::Value shiftOp = builder.create(loc, shiftTy, lbs); + val = builder.create(loc, eleTy, val, shiftOp, + mlir::Value{}); + } + } else if (isBoundsRemap()) { + auto lbs = lbounds.getValue(); + if (lbs.size() > 0) { + // Rebox the value with user-specified shift and shape. + auto shapeShiftArgs = flatZip(lbs, ubounds.getValue()); + auto shapeTy = fir::ShapeShiftType::get(eleTy.getContext(), lbs.size()); + mlir::Value shapeShift = + builder.create(loc, shapeTy, shapeShiftArgs); + val = builder.create(loc, eleTy, val, shapeShift, + mlir::Value{}); + } + } + return val; + } + /// 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 @@ -3951,7 +4201,7 @@ 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 ele = convertElementForUpdate(loc, eleTy, fir::getBase(exv)); auto update = builder.create( loc, arrTy, innerArg, ele, iterSpace.iterVec(), destination.getTypeparams()); @@ -4014,9 +4264,7 @@ 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()}; + return fir::factory::getExtents(array.shape); } /// Get the shape from an ArrayLoad. @@ -4300,8 +4548,8 @@ afterLoopNest}; } - /// Build the iteration space into which the array expression will be - /// lowered. The resultType is used to create a temporary, if needed. + /// Build the iteration space into which the array expression will be lowered. + /// The resultType is used to create a temporary, if needed. std::pair genIterSpace(mlir::Type resultType) { mlir::Location loc = getLoc(); @@ -4429,7 +4677,9 @@ /// conflicts even when the result is a scalar element. template ExtValue asScalarArray(const A &x) { - return explicitSpaceIsActive() ? genarr(x)(IterationSpace{}) : asScalar(x); + return explicitSpaceIsActive() && !isPointerAssignment() + ? genarr(x)(IterationSpace{}) + : asScalar(x); } /// Lower the expression in a scalar context to a memory reference. @@ -5329,10 +5579,9 @@ assert(!isBoxValue() && "fir.box cannot be created with vector subscripts"); auto arrExpr = ignoreEvConvert(e); - if (createDestShape) { - destShape.push_back(fir::getExtentAtDimension( - arrayExv, builder, loc, subsIndex)); - } + if (createDestShape) + destShape.push_back(fir::factory::getExtentAtDimension( + loc, builder, arrayExv, subsIndex)); auto genArrFetch = genVectorSubscriptArrayFetch(arrExpr, shapeIndex); auto currentPC = pc; @@ -6400,6 +6649,20 @@ x); } + void extendComponent(Fortran::lower::ComponentPath &component, + mlir::Type coorTy, mlir::ValueRange vals) { + auto *bldr = &converter.getFirOpBuilder(); + llvm::SmallVector offsets(vals.begin(), vals.end()); + auto currentFunc = component.getExtendCoorRef(); + auto loc = getLoc(); + auto newCoorRef = [bldr, coorTy, offsets, currentFunc, + loc](mlir::Value val) -> mlir::Value { + return bldr->create(loc, bldr->getRefType(coorTy), + currentFunc(val), offsets); + }; + component.extendCoorRef = newCoorRef; + } + //===-------------------------------------------------------------------===// // Array data references in an explicit iteration space. // @@ -6419,11 +6682,17 @@ 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); + bool deref = false; + auto addComponentList = [&](mlir::Type ty, mlir::ValueRange vals) { + if (deref) { + extendComponent(components, ty, vals); + } else if (prefix) { + for (auto v : vals) + components.prefixComponents.push_back(v); + } else { + for (auto v : vals) + components.suffixComponents.push_back(v); + } }; mlir::IndexType idxTy = builder.getIndexType(); mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1); @@ -6431,6 +6700,7 @@ auto saveSemant = semant; if (isProjectedCopyInCopyOut()) semant = ConstituentSemantics::RefTransparent; + unsigned index = 0; for (const auto &v : llvm::reverse(revPath)) { std::visit( Fortran::common::visitors{ @@ -6450,10 +6720,12 @@ [&](const Fortran::evaluate::ArrayRef *x) { if (Fortran::lower::isRankedArrayAccess(*x)) { genSliceIndices(components, arrayExv, *x, atBase); + ty = fir::unwrapSeqOrBoxedSeqType(ty); } else { // Array access where the expressions are scalar and cannot // depend upon the implied iteration space. unsigned ssIndex = 0u; + llvm::SmallVector componentsToAdd; for (const auto &ss : x->subscript()) { std::visit( Fortran::common::visitors{ @@ -6483,7 +6755,7 @@ mlir::Value ivAdj = builder.create( loc, idxTy, val, lb); - addComponent( + componentsToAdd.push_back( builder.createConvert(loc, idxTy, ivAdj)); }, [&](const auto &) { @@ -6494,20 +6766,47 @@ ss.u); ssIndex++; } + ty = fir::unwrapSeqOrBoxedSeqType(ty); + addComponentList(ty, componentsToAdd); } - 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); + if (auto recTy = ty.dyn_cast()) { + ty = recTy.getType(name); + auto fld = builder.create( + loc, fieldTy, name, recTy, fir::getTypeParams(arrayExv)); + addComponentList(ty, {fld}); + if (index != revPath.size() - 1 || !isPointerAssignment()) { + // Need an intermediate dereference if the boxed value + // appears in the middle of the component path or if it is + // on the right and this is not a pointer assignment. + if (auto boxTy = ty.dyn_cast()) { + auto currentFunc = components.getExtendCoorRef(); + auto loc = getLoc(); + auto *bldr = &converter.getFirOpBuilder(); + auto newCoorRef = [=](mlir::Value val) -> mlir::Value { + return bldr->create(loc, currentFunc(val)); + }; + components.extendCoorRef = newCoorRef; + deref = true; + } + } + } else if (auto boxTy = ty.dyn_cast()) { + ty = fir::unwrapRefType(boxTy.getEleTy()); + auto recTy = ty.cast(); + ty = recTy.getType(name); + auto fld = builder.create( + loc, fieldTy, name, recTy, fir::getTypeParams(arrayExv)); + extendComponent(components, ty, {fld}); + } else { + TODO(loc, "other component type"); + } }}, v); atBase = false; + ++index; } semant = saveSemant; ty = fir::unwrapSequenceType(ty); @@ -6531,12 +6830,10 @@ 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; + return IterationSpace(currentPC(iters), prefix, suffix); }; - components.pc = [=](IterSpace iters) { return iters; }; + components.resetPC(); llvm::SmallVector substringBounds = genSubstringBounds(components); if (isProjectedCopyInCopyOut()) { @@ -6555,7 +6852,8 @@ substringBounds); return arrayLoadExtValue(builder, loc, load, iters.iterVec(), amend, dstLen); - } else if (fir::isa_derived(eleTy)) { + } + if (fir::isa_derived(eleTy)) { fir::ArrayAmendOp amend = createDerivedArrayAmend(loc, load, builder, arrayOp, iters.elementExv(), eleTy, innerArg); @@ -6565,11 +6863,38 @@ assert(eleTy.isa()); TODO(loc, "array (as element) assignment"); } - mlir::Value castedElement = - builder.createConvert(loc, eleTy, iters.getElement()); + if (components.hasExtendCoorRef()) { + auto eleBoxTy = + fir::applyPathToType(innerArg.getType(), iters.iterVec()); + assert(eleBoxTy && eleBoxTy.isa()); + auto arrayOp = builder.create( + loc, builder.getRefType(eleBoxTy), innerArg, iters.iterVec(), + fir::factory::getTypeParams(loc, builder, load)); + mlir::Value addr = components.getExtendCoorRef()(arrayOp); + components.resetExtendCoorRef(); + // When the lhs is a boxed value and the context is not a pointer + // assignment, then insert the dereference of the box before any + // conversion and store. + if (!isPointerAssignment()) { + if (auto boxTy = eleTy.dyn_cast()) { + eleTy = boxTy.getEleTy(); + if (!(eleTy.isa() || + eleTy.isa())) + eleTy = builder.getRefType(eleTy); + addr = builder.create(loc, eleTy, addr); + eleTy = fir::unwrapRefType(eleTy); + } + } + auto ele = convertElementForUpdate(loc, eleTy, iters.getElement()); + builder.create(loc, ele, addr); + auto amend = builder.create( + loc, innerArg.getType(), innerArg, arrayOp); + return arrayLoadExtValue(builder, loc, load, iters.iterVec(), amend); + } + auto ele = convertElementForUpdate(loc, eleTy, iters.getElement()); auto update = builder.create( - loc, innerArg.getType(), innerArg, castedElement, iters.iterVec(), - load.getTypeparams()); + loc, innerArg.getType(), innerArg, ele, iters.iterVec(), + fir::factory::getTypeParams(loc, builder, load)); return arrayLoadExtValue(builder, loc, load, iters.iterVec(), update); }; return [=](IterSpace iters) mutable { return lambda(pc(iters)); }; @@ -6612,14 +6937,46 @@ } return arrayLoadExtValue(builder, loc, load, iters.iterVec(), newBase); } + if (components.hasExtendCoorRef()) { + auto eleBoxTy = fir::applyPathToType(load.getType(), iters.iterVec()); + assert(eleBoxTy && eleBoxTy.isa()); + auto access = builder.create( + loc, builder.getRefType(eleBoxTy), load, iters.iterVec(), + fir::factory::getTypeParams(loc, builder, load)); + mlir::Value addr = components.getExtendCoorRef()(access); + components.resetExtendCoorRef(); + return arrayLoadExtValue(builder, loc, load, iters.iterVec(), addr); + } + if (isPointerAssignment()) { + auto eleTy = fir::applyPathToType(load.getType(), iters.iterVec()); + if (!eleTy.isa()) { + // Rhs is a regular expression that will need to be boxed before + // assigning to the boxed variable. + auto typeParams = fir::factory::getTypeParams(loc, builder, load); + auto access = builder.create( + loc, builder.getRefType(eleTy), load, iters.iterVec(), + typeParams); + auto addr = components.getExtendCoorRef()(access); + components.resetExtendCoorRef(); + auto ptrEleTy = fir::PointerType::get(eleTy); + auto ptrAddr = builder.createConvert(loc, ptrEleTy, addr); + auto boxTy = fir::BoxType::get(ptrEleTy); + // FIXME: The typeparams to the load may be different than those of + // the subobject. + if (components.hasExtendCoorRef()) + TODO(loc, "need to adjust typeparameter(s) to reflect the final " + "component"); + mlir::Value embox = builder.create( + loc, boxTy, ptrAddr, /*shape=*/mlir::Value{}, + /*slice=*/mlir::Value{}, typeParams); + return arrayLoadExtValue(builder, loc, load, iters.iterVec(), embox); + } + } 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); - }; + return [=](IterSpace iters) mutable { return lambda(pc(iters)); }; } template @@ -6664,9 +7021,19 @@ return [=, &x](IterSpace) { return asScalar(x); }; } + bool tailIsPointerInPointerAssignment(const Fortran::semantics::Symbol &x, + ComponentPath &components) { + return isPointerAssignment() && Fortran::semantics::IsPointer(x) && + !components.hasComponents(); + } + bool tailIsPointerInPointerAssignment(const Fortran::evaluate::Component &x, + ComponentPath &components) { + return tailIsPointerInPointerAssignment(getLastSym(x), components); + } + CC genarr(const Fortran::semantics::Symbol &x, ComponentPath &components) { if (explicitSpaceIsActive()) { - if (x.Rank() > 0) + if (x.Rank() > 0 && !tailIsPointerInPointerAssignment(x, components)) components.reversePath.push_back(ImplicitSubscripts{}); if (fir::ArrayLoadOp load = explicitSpace->findBinding(&x)) return applyPathToArrayLoad(load, components); @@ -6685,7 +7052,8 @@ /// Example: array%baz%qux%waldo CC genarr(const Fortran::evaluate::Component &x, ComponentPath &components) { if (explicitSpaceIsActive()) { - if (x.base().Rank() == 0 && x.Rank() > 0) + if (x.base().Rank() == 0 && x.Rank() > 0 && + !tailIsPointerInPointerAssignment(x, components)) components.reversePath.push_back(ImplicitSubscripts{}); if (fir::ArrayLoadOp load = explicitSpace->findBinding(&x)) return applyPathToArrayLoad(load, components); @@ -6835,6 +7203,23 @@ void setUnordered(bool b) { unordered = b; } + inline bool isPointerAssignment() const { return lbounds.hasValue(); } + + inline bool isBoundsSpec() const { + return isPointerAssignment() && !ubounds.hasValue(); + } + + inline bool isBoundsRemap() const { + return isPointerAssignment() && ubounds.hasValue(); + } + + void setPointerAssignmentBounds( + const llvm::SmallVector &lbs, + llvm::Optional> ubs) { + lbounds = lbs; + ubounds = ubs; + } + Fortran::lower::AbstractConverter &converter; fir::FirOpBuilder &builder; Fortran::lower::StatementContext &stmtCtx; @@ -6857,6 +7242,10 @@ Fortran::lower::ExplicitIterSpace *explicitSpace = nullptr; Fortran::lower::ImplicitIterSpace *implicitSpace = nullptr; ConstituentSemantics semant = ConstituentSemantics::RefTransparent; + /// `lbounds`, `ubounds` are used in POINTER value assignments, which may only + /// occur in an explicit iteration space. + llvm::Optional> lbounds; + llvm::Optional> ubounds; // Can the array expression be evaluated in any order? // Will be set to false if any of the expression parts prevent this. bool unordered = true; @@ -6981,6 +7370,25 @@ converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace); } +void Fortran::lower::createArrayOfPointerAssignment( + Fortran::lower::AbstractConverter &converter, + const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs, + Fortran::lower::ExplicitIterSpace &explicitSpace, + Fortran::lower::ImplicitIterSpace &implicitSpace, + const llvm::SmallVector &lbounds, + llvm::Optional> ubounds, + Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { + LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "defining pointer: ") << '\n'; + rhs.AsFortran(llvm::dbgs() << "assign expression: ") + << " given the explicit iteration space:\n" + << explicitSpace << "\n and implied mask conditions:\n" + << implicitSpace << '\n';); + assert(explicitSpace.isActive() && "must be in FORALL construct"); + ArrayExprLowering::lowerArrayOfPointerAssignment( + converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace, + lbounds, ubounds); +} + fir::ExtendedValue Fortran::lower::createSomeArrayTempValue( Fortran::lower::AbstractConverter &converter, const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap, diff --git a/flang/lib/Lower/IO.cpp b/flang/lib/Lower/IO.cpp --- a/flang/lib/Lower/IO.cpp +++ b/flang/lib/Lower/IO.cpp @@ -31,6 +31,7 @@ #include "flang/Runtime/io-api.h" #include "flang/Semantics/tools.h" #include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h" +#include "llvm/Support/Debug.h" #define DEBUG_TYPE "flang-lower-io" @@ -80,6 +81,7 @@ mkIOKey(BeginEndfile), mkIOKey(BeginRewind), mkIOKey(BeginOpenUnit), mkIOKey(BeginOpenNewUnit), mkIOKey(BeginInquireUnit), mkIOKey(BeginInquireFile), mkIOKey(BeginInquireIoLength), + mkIOKey(CheckUnitNumberInRange64), mkIOKey(CheckUnitNumberInRange128), mkIOKey(EnableHandlers), mkIOKey(SetAdvance), mkIOKey(SetBlank), mkIOKey(SetDecimal), mkIOKey(SetDelim), mkIOKey(SetPad), mkIOKey(SetPos), mkIOKey(SetRec), mkIOKey(SetRound), mkIOKey(SetSign), @@ -87,18 +89,15 @@ mkIOKey(InputDescriptor), mkIOKey(OutputUnformattedBlock), mkIOKey(InputUnformattedBlock), mkIOKey(OutputInteger8), mkIOKey(OutputInteger16), mkIOKey(OutputInteger32), - mkIOKey(OutputInteger64), -#ifdef __SIZEOF_INT128__ - mkIOKey(OutputInteger128), -#endif - mkIOKey(InputInteger), mkIOKey(OutputReal32), mkIOKey(InputReal32), - mkIOKey(OutputReal64), mkIOKey(InputReal64), mkIOKey(OutputComplex32), - mkIOKey(InputComplex32), mkIOKey(OutputComplex64), mkIOKey(InputComplex64), - mkIOKey(OutputAscii), mkIOKey(InputAscii), mkIOKey(OutputLogical), - mkIOKey(InputLogical), mkIOKey(SetAccess), mkIOKey(SetAction), - mkIOKey(SetAsynchronous), mkIOKey(SetCarriagecontrol), mkIOKey(SetEncoding), - mkIOKey(SetForm), mkIOKey(SetPosition), mkIOKey(SetRecl), - mkIOKey(SetStatus), mkIOKey(SetFile), mkIOKey(GetNewUnit), mkIOKey(GetSize), + mkIOKey(OutputInteger64), mkIOKey(OutputInteger128), mkIOKey(InputInteger), + mkIOKey(OutputReal32), mkIOKey(InputReal32), mkIOKey(OutputReal64), + mkIOKey(InputReal64), mkIOKey(OutputComplex32), mkIOKey(InputComplex32), + mkIOKey(OutputComplex64), mkIOKey(InputComplex64), mkIOKey(OutputAscii), + mkIOKey(InputAscii), mkIOKey(OutputLogical), mkIOKey(InputLogical), + mkIOKey(SetAccess), mkIOKey(SetAction), mkIOKey(SetAsynchronous), + mkIOKey(SetCarriagecontrol), mkIOKey(SetEncoding), mkIOKey(SetForm), + mkIOKey(SetPosition), mkIOKey(SetRecl), mkIOKey(SetStatus), + mkIOKey(SetFile), mkIOKey(GetNewUnit), mkIOKey(GetSize), mkIOKey(GetIoLength), mkIOKey(GetIoMsg), mkIOKey(InquireCharacter), mkIOKey(InquireLogical), mkIOKey(InquirePendingId), mkIOKey(InquireInteger64), mkIOKey(EndIoStatement)> @@ -113,10 +112,11 @@ /// and an IOMSG specifier variable may be set to a description of a condition. struct ConditionSpecInfo { const Fortran::lower::SomeExpr *ioStatExpr{}; - const Fortran::lower::SomeExpr *ioMsgExpr{}; + llvm::Optional ioMsg; bool hasErr{}; bool hasEnd{}; bool hasEor{}; + fir::IfOp bigUnitIfOp; /// Check for any condition specifier that applies to specifier processing. bool hasErrorConditionSpec() const { return ioStatExpr != nullptr || hasErr; } @@ -129,7 +129,7 @@ /// Check for any condition specifier, including IOMSG. bool hasAnyConditionSpec() const { - return hasTransferConditionSpec() || ioMsgExpr != nullptr; + return hasTransferConditionSpec() || ioMsg; } }; } // namespace @@ -138,7 +138,7 @@ static void genIoLoop(Fortran::lower::AbstractConverter &converter, mlir::Value cookie, const D &ioImpliedDo, bool isFormatted, bool checkResult, mlir::Value &ok, - bool inLoop, Fortran::lower::StatementContext &stmtCtx); + bool inLoop); /// Helper function to retrieve the name of the IO function given the key `A` template @@ -162,7 +162,7 @@ static mlir::func::FuncOp getIORuntimeFunc(mlir::Location loc, fir::FirOpBuilder &builder) { llvm::StringRef name = getName(); - mlir::func::FuncOp func = builder.getNamedFunction(name); + auto func = builder.getNamedFunction(name); if (func) return func; auto funTy = getTypeModel()(builder.getContext()); @@ -176,35 +176,38 @@ /// It is the caller's responsibility to generate branches on that value. static mlir::Value genEndIO(Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Value cookie, - const ConditionSpecInfo &csi, + ConditionSpecInfo &csi, Fortran::lower::StatementContext &stmtCtx) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); - if (csi.ioMsgExpr) { - mlir::func::FuncOp getIoMsg = - getIORuntimeFunc(loc, builder); - fir::ExtendedValue ioMsgVar = - converter.genExprAddr(csi.ioMsgExpr, stmtCtx, loc); + if (csi.ioMsg) { + auto getIoMsg = getIORuntimeFunc(loc, builder); builder.create( loc, getIoMsg, mlir::ValueRange{ cookie, builder.createConvert(loc, getIoMsg.getFunctionType().getInput(1), - fir::getBase(ioMsgVar)), + fir::getBase(*csi.ioMsg)), builder.createConvert(loc, getIoMsg.getFunctionType().getInput(2), - fir::getLen(ioMsgVar))}); + fir::getLen(*csi.ioMsg))}); } - mlir::func::FuncOp endIoStatement = - getIORuntimeFunc(loc, builder); + auto endIoStatement = getIORuntimeFunc(loc, builder); auto call = builder.create(loc, endIoStatement, mlir::ValueRange{cookie}); + mlir::Value iostat = call.getResult(0); + if (csi.bigUnitIfOp) { + stmtCtx.finalize(/*popScope=*/true); + builder.create(loc, iostat); + builder.setInsertionPointAfter(csi.bigUnitIfOp); + iostat = csi.bigUnitIfOp.getResult(0); + } if (csi.ioStatExpr) { mlir::Value ioStatVar = - fir::getBase(converter.genExprAddr(csi.ioStatExpr, stmtCtx, loc)); - mlir::Value ioStatResult = builder.createConvert( - loc, converter.genType(*csi.ioStatExpr), call.getResult(0)); + fir::getBase(converter.genExprAddr(loc, csi.ioStatExpr, stmtCtx)); + mlir::Value ioStatResult = + builder.createConvert(loc, converter.genType(*csi.ioStatExpr), iostat); builder.create(loc, ioStatResult, ioStatVar); } - return csi.hasTransferConditionSpec() ? call.getResult(0) : mlir::Value{}; + return csi.hasTransferConditionSpec() ? iostat : mlir::Value{}; } /// Make the next call in the IO statement conditional on runtime result `ok`. @@ -420,10 +423,8 @@ return getIORuntimeFunc(loc, builder); case 64: return getIORuntimeFunc(loc, builder); -#ifdef __SIZEOF_INT128__ case 128: return getIORuntimeFunc(loc, builder); -#endif } llvm_unreachable("unknown OutputInteger kind"); } @@ -458,39 +459,37 @@ } /// Generate a sequence of output data transfer calls. -static void -genOutputItemList(Fortran::lower::AbstractConverter &converter, - mlir::Value cookie, - const std::list &items, - bool isFormatted, bool checkResult, mlir::Value &ok, - bool inLoop, Fortran::lower::StatementContext &stmtCtx) { +static void genOutputItemList( + Fortran::lower::AbstractConverter &converter, mlir::Value cookie, + const std::list &items, bool isFormatted, + bool checkResult, mlir::Value &ok, bool inLoop) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); for (const Fortran::parser::OutputItem &item : items) { if (const auto &impliedDo = std::get_if<1>(&item.u)) { genIoLoop(converter, cookie, impliedDo->value(), isFormatted, checkResult, - ok, inLoop, stmtCtx); + ok, inLoop); continue; } auto &pExpr = std::get(item.u); mlir::Location loc = converter.genLocation(pExpr.source); makeNextConditionalOn(builder, loc, checkResult, ok, inLoop); + Fortran::lower::StatementContext stmtCtx; const auto *expr = Fortran::semantics::GetExpr(pExpr); if (!expr) fir::emitFatalError(loc, "internal error: could not get evaluate::Expr"); mlir::Type itemTy = converter.genType(*expr); - mlir::func::FuncOp outputFunc = - getOutputFunc(loc, builder, itemTy, isFormatted); + auto outputFunc = getOutputFunc(loc, builder, itemTy, isFormatted); mlir::Type argType = outputFunc.getFunctionType().getInput(1); assert((isFormatted || argType.isa()) && "expect descriptor for unformatted IO runtime"); llvm::SmallVector outputFuncArgs = {cookie}; fir::factory::CharacterExprHelper helper{builder, loc}; if (argType.isa()) { - mlir::Value box = fir::getBase(converter.genExprBox(*expr, stmtCtx, loc)); + mlir::Value box = fir::getBase(converter.genExprBox(loc, *expr, stmtCtx)); outputFuncArgs.push_back(builder.createConvert(loc, argType, box)); } else if (helper.isCharacterScalar(itemTy)) { - fir::ExtendedValue exv = converter.genExprAddr(expr, stmtCtx, loc); + fir::ExtendedValue exv = converter.genExprAddr(loc, expr, stmtCtx); // scalar allocatable/pointer may also get here, not clear if // genExprAddr will lower them as CharBoxValue or BoxValue. if (!exv.getCharBox()) @@ -501,7 +500,7 @@ outputFuncArgs.push_back(builder.createConvert( loc, outputFunc.getFunctionType().getInput(2), fir::getLen(exv))); } else { - fir::ExtendedValue itemBox = converter.genExprValue(expr, stmtCtx, loc); + fir::ExtendedValue itemBox = converter.genExprValue(loc, expr, stmtCtx); mlir::Value itemValue = fir::getBase(itemBox); if (fir::isa_complex(itemTy)) { auto parts = @@ -609,25 +608,25 @@ mlir::Value cookie, const std::list &items, bool isFormatted, bool checkResult, - mlir::Value &ok, bool inLoop, - Fortran::lower::StatementContext &stmtCtx) { + mlir::Value &ok, bool inLoop) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); for (const Fortran::parser::InputItem &item : items) { if (const auto &impliedDo = std::get_if<1>(&item.u)) { genIoLoop(converter, cookie, impliedDo->value(), isFormatted, checkResult, - ok, inLoop, stmtCtx); + ok, inLoop); continue; } auto &pVar = std::get(item.u); mlir::Location loc = converter.genLocation(pVar.GetSource()); makeNextConditionalOn(builder, loc, checkResult, ok, inLoop); + Fortran::lower::StatementContext stmtCtx; const auto *expr = Fortran::semantics::GetExpr(pVar); if (!expr) fir::emitFatalError(loc, "internal error: could not get evaluate::Expr"); if (Fortran::evaluate::HasVectorSubscript(*expr)) { auto vectorSubscriptBox = Fortran::lower::genVectorSubscriptBox(loc, converter, stmtCtx, *expr); - mlir::func::FuncOp inputFunc = getInputFunc( + auto inputFunc = getInputFunc( loc, builder, vectorSubscriptBox.getElementType(), isFormatted); const bool mustBox = inputFunc.getFunctionType().getInput(1).isa(); @@ -653,11 +652,10 @@ continue; } mlir::Type itemTy = converter.genType(*expr); - mlir::func::FuncOp inputFunc = - getInputFunc(loc, builder, itemTy, isFormatted); + auto inputFunc = getInputFunc(loc, builder, itemTy, isFormatted); auto itemExv = inputFunc.getFunctionType().getInput(1).isa() - ? converter.genExprBox(*expr, stmtCtx, loc) - : converter.genExprAddr(expr, stmtCtx, loc); + ? converter.genExprBox(loc, *expr, stmtCtx) + : converter.genExprAddr(loc, expr, stmtCtx); ok = createIoRuntimeCallForItem(loc, builder, inputFunc, cookie, itemExv); } } @@ -667,14 +665,16 @@ static void genIoLoop(Fortran::lower::AbstractConverter &converter, mlir::Value cookie, const D &ioImpliedDo, bool isFormatted, bool checkResult, mlir::Value &ok, - bool inLoop, Fortran::lower::StatementContext &stmtCtx) { + bool inLoop) { + Fortran::lower::StatementContext stmtCtx; fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::Location loc = converter.getCurrentLocation(); makeNextConditionalOn(builder, loc, checkResult, ok, inLoop); const auto &itemList = std::get<0>(ioImpliedDo.t); const auto &control = std::get<1>(ioImpliedDo.t); const auto &loopSym = *control.name.thing.thing.symbol; - mlir::Value loopVar = converter.getSymbolAddress(loopSym); + mlir::Value loopVar = fir::getBase(converter.genExprAddr( + Fortran::evaluate::AsGenericExpr(loopSym).value(), stmtCtx)); auto genControlValue = [&](const Fortran::parser::ScalarIntExpr &expr) { mlir::Value v = fir::getBase( converter.genExprValue(*Fortran::semantics::GetExpr(expr), stmtCtx)); @@ -687,13 +687,12 @@ ? genControlValue(*control.step) : builder.create(loc, 1); auto genItemList = [&](const D &ioImpliedDo) { - Fortran::lower::StatementContext loopCtx; if constexpr (std::is_same_v) genInputItemList(converter, cookie, itemList, isFormatted, checkResult, - ok, /*inLoop=*/true, loopCtx); + ok, /*inLoop=*/true); else genOutputItemList(converter, cookie, itemList, isFormatted, checkResult, - ok, /*inLoop=*/true, loopCtx); + ok, /*inLoop=*/true); }; if (!checkResult) { // No IO call result checks - the loop is a fir.do_loop op. @@ -701,8 +700,8 @@ loc, lowerValue, upperValue, stepValue, /*unordered=*/false, /*finalCountValue=*/true); builder.setInsertionPointToStart(doLoopOp.getBody()); - mlir::Value lcv = builder.createConvert(loc, converter.genType(loopSym), - doLoopOp.getInductionVar()); + mlir::Value lcv = builder.createConvert( + loc, fir::unwrapRefType(loopVar.getType()), doLoopOp.getInductionVar()); builder.create(loc, lcv, loopVar); genItemList(ioImpliedDo); builder.setInsertionPointToEnd(doLoopOp.getBody()); @@ -711,7 +710,7 @@ builder.create(loc, result); builder.setInsertionPointAfter(doLoopOp); // The loop control variable may be used after the loop. - lcv = builder.createConvert(loc, converter.genType(loopSym), + lcv = builder.createConvert(loc, fir::unwrapRefType(loopVar.getType()), doLoopOp.getResult(0)); builder.create(loc, lcv, loopVar); return; @@ -722,8 +721,9 @@ auto iterWhileOp = builder.create( loc, lowerValue, upperValue, stepValue, ok, /*finalCountValue*/ true); builder.setInsertionPointToStart(iterWhileOp.getBody()); - mlir::Value lcv = builder.createConvert(loc, converter.genType(loopSym), - iterWhileOp.getInductionVar()); + mlir::Value lcv = + builder.createConvert(loc, fir::unwrapRefType(loopVar.getType()), + iterWhileOp.getInductionVar()); builder.create(loc, lcv, loopVar); ok = iterWhileOp.getIterateVar(); mlir::Value falseValue = @@ -756,7 +756,7 @@ ok = iterWhileOp.getResult(1); builder.setInsertionPointAfter(iterWhileOp); // The loop control variable may be used after the loop. - lcv = builder.createConvert(loc, converter.genType(loopSym), + lcv = builder.createConvert(loc, fir::unwrapRefType(loopVar.getType()), iterWhileOp.getResult(0)); builder.create(loc, lcv, loopVar); } @@ -874,10 +874,10 @@ const B &spec) { Fortran::lower::StatementContext localStatementCtx; fir::FirOpBuilder &builder = converter.getFirOpBuilder(); - mlir::func::FuncOp ioFunc = getIORuntimeFunc(loc, builder); + auto ioFunc = getIORuntimeFunc(loc, builder); mlir::FunctionType ioFuncTy = ioFunc.getFunctionType(); mlir::Value expr = fir::getBase(converter.genExprValue( - Fortran::semantics::GetExpr(spec.v), localStatementCtx, loc)); + loc, Fortran::semantics::GetExpr(spec.v), localStatementCtx)); mlir::Value val = builder.createConvert(loc, ioFuncTy.getInput(1), expr); llvm::SmallVector ioArgs = {cookie, val}; return builder.create(loc, ioFunc, ioArgs).getResult(0); @@ -891,7 +891,7 @@ const B &spec) { Fortran::lower::StatementContext localStatementCtx; fir::FirOpBuilder &builder = converter.getFirOpBuilder(); - mlir::func::FuncOp ioFunc = getIORuntimeFunc(loc, builder); + auto ioFunc = getIORuntimeFunc(loc, builder); mlir::FunctionType ioFuncTy = ioFunc.getFunctionType(); std::tuple tup = lowerStringLit(converter, loc, localStatementCtx, spec, @@ -923,7 +923,7 @@ Fortran::lower::StatementContext localStatementCtx; fir::FirOpBuilder &builder = converter.getFirOpBuilder(); // has an extra KIND argument - mlir::func::FuncOp ioFunc = getIORuntimeFunc(loc, builder); + auto ioFunc = getIORuntimeFunc(loc, builder); mlir::FunctionType ioFuncTy = ioFunc.getFunctionType(); std::tuple tup = lowerStringLit(converter, loc, localStatementCtx, spec, @@ -1094,14 +1094,13 @@ std::get_if(&spec.u)) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); - mlir::func::FuncOp ioFunc = - getIORuntimeFunc(loc, builder); + auto ioFunc = getIORuntimeFunc(loc, builder); auto sizeValue = builder.create(loc, ioFunc, mlir::ValueRange{cookie}) .getResult(0); Fortran::lower::StatementContext localStatementCtx; fir::ExtendedValue var = converter.genExprAddr( - Fortran::semantics::GetExpr(size->v), localStatementCtx, loc); + loc, Fortran::semantics::GetExpr(size->v), localStatementCtx); mlir::Value varAddr = fir::getBase(var); mlir::Type varType = fir::unwrapPassByRefType(varAddr.getType()); mlir::Value sizeCast = builder.createConvert(loc, varType, sizeValue); @@ -1170,10 +1169,10 @@ /// information from the runtime, via a variable, about the nature of the /// condition that occurred. These condition specifiers are handled here. template -static void -genConditionHandlerCall(Fortran::lower::AbstractConverter &converter, - mlir::Location loc, mlir::Value cookie, - const A &specList, ConditionSpecInfo &csi) { +ConditionSpecInfo lowerErrorSpec(Fortran::lower::AbstractConverter &converter, + mlir::Location loc, const A &specList) { + ConditionSpecInfo csi; + const Fortran::lower::SomeExpr *ioMsgExpr = nullptr; for (const auto &spec : specList) { std::visit( Fortran::common::visitors{ @@ -1187,13 +1186,13 @@ std::get(var.t)); }, [&](const Fortran::parser::MsgVariable &var) { - csi.ioMsgExpr = Fortran::semantics::GetExpr(var); + ioMsgExpr = Fortran::semantics::GetExpr(var); }, [&](const Fortran::parser::InquireSpec::CharVar &var) { if (std::get( var.t) == Fortran::parser::InquireSpec::CharVar::Kind::Iomsg) - csi.ioMsgExpr = Fortran::semantics::GetExpr( + ioMsgExpr = Fortran::semantics::GetExpr( std::get( var.t)); }, @@ -1203,11 +1202,24 @@ [](const auto &) {}}, spec.u); } + if (ioMsgExpr) { + // iomsg is a variable, its evaluation may require temps, but it cannot + // itself be a temp, and it is ok to us a local statement context here. + Fortran::lower::StatementContext stmtCtx; + csi.ioMsg = converter.genExprAddr(loc, ioMsgExpr, stmtCtx); + } + + return csi; +} +template +static void +genConditionHandlerCall(Fortran::lower::AbstractConverter &converter, + mlir::Location loc, mlir::Value cookie, + const A &specList, ConditionSpecInfo &csi) { if (!csi.hasAnyConditionSpec()) return; fir::FirOpBuilder &builder = converter.getFirOpBuilder(); - mlir::func::FuncOp enableHandlers = - getIORuntimeFunc(loc, builder); + auto enableHandlers = getIORuntimeFunc(loc, builder); mlir::Type boolType = enableHandlers.getFunctionType().getInput(1); auto boolValue = [&](bool specifierIsPresent) { return builder.create( @@ -1218,7 +1230,7 @@ boolValue(csi.hasErr), boolValue(csi.hasEnd), boolValue(csi.hasEor), - boolValue(csi.ioMsgExpr != nullptr)}; + boolValue(csi.ioMsg.hasValue())}; builder.create(loc, enableHandlers, ioArgs); } @@ -1437,7 +1449,7 @@ // Lower the selectOp. builder.setInsertionPointToEnd(startBlock); - auto label = fir::getBase(converter.genExprValue(&expr, stmtCtx, loc)); + auto label = fir::getBase(converter.genExprValue(loc, &expr, stmtCtx)); builder.create(loc, label, indexList, blockList); builder.setInsertionPointToEnd(endBlock); @@ -1524,34 +1536,85 @@ llvm::report_fatal_error("failed to get IoUnit expr in lowering"); } +static mlir::Value genIOUnitNumber(Fortran::lower::AbstractConverter &converter, + mlir::Location loc, + const Fortran::lower::SomeExpr *iounit, + mlir::Type ty, ConditionSpecInfo &csi, + Fortran::lower::StatementContext &stmtCtx) { + auto &builder = converter.getFirOpBuilder(); + auto rawUnit = fir::getBase(converter.genExprValue(loc, iounit, stmtCtx)); + unsigned rawUnitWidth = + rawUnit.getType().cast().getWidth(); + unsigned runtimeArgWidth = ty.cast().getWidth(); + // The IO runtime supports `int` unit numbers, if the unit number may + // overflow when passed to the IO runtime, check that the unit number is + // in range before calling the BeginXXX. + if (rawUnitWidth > runtimeArgWidth) { + auto check = + rawUnitWidth <= 64 + ? getIORuntimeFunc(loc, builder) + : getIORuntimeFunc(loc, + builder); + mlir::FunctionType funcTy = check.getFunctionType(); + llvm::SmallVector args; + args.push_back(builder.createConvert(loc, funcTy.getInput(0), rawUnit)); + args.push_back(builder.createBool(loc, csi.hasErrorConditionSpec())); + if (csi.ioMsg) { + args.push_back(builder.createConvert(loc, funcTy.getInput(2), + fir::getBase(*csi.ioMsg))); + args.push_back(builder.createConvert(loc, funcTy.getInput(3), + fir::getLen(*csi.ioMsg))); + } else { + args.push_back(builder.createNullConstant(loc, funcTy.getInput(2))); + args.push_back( + fir::factory::createZeroValue(builder, loc, funcTy.getInput(3))); + } + mlir::Value file = locToFilename(converter, loc, funcTy.getInput(4)); + mlir::Value line = locToLineNo(converter, loc, funcTy.getInput(5)); + args.push_back(file); + args.push_back(line); + auto checkCall = builder.create(loc, check, args); + if (csi.hasErrorConditionSpec()) { + mlir::Value iostat = checkCall.getResult(0); + mlir::Type iostatTy = iostat.getType(); + mlir::Value zero = fir::factory::createZeroValue(builder, loc, iostatTy); + mlir::Value unitIsOK = builder.create( + loc, mlir::arith::CmpIPredicate::eq, iostat, zero); + auto ifOp = builder.create(loc, iostatTy, unitIsOK, + /*withElseRegion=*/true); + builder.setInsertionPointToStart(&ifOp.getElseRegion().front()); + builder.create(loc, iostat); + builder.setInsertionPointToStart(&ifOp.getThenRegion().front()); + stmtCtx.pushScope(); + csi.bigUnitIfOp = ifOp; + } + } + return builder.createConvert(loc, ty, rawUnit); +} + static mlir::Value genIOUnit(Fortran::lower::AbstractConverter &converter, mlir::Location loc, - const Fortran::parser::IoUnit &iounit, - mlir::Type ty, + const Fortran::parser::IoUnit *iounit, + mlir::Type ty, ConditionSpecInfo &csi, Fortran::lower::StatementContext &stmtCtx) { auto &builder = converter.getFirOpBuilder(); - if (auto *e = std::get_if(&iounit.u)) { - auto ex = fir::getBase( - converter.genExprValue(Fortran::semantics::GetExpr(*e), stmtCtx, loc)); - return builder.createConvert(loc, ty, ex); - } + if (iounit) + if (auto *e = std::get_if(&iounit->u)) + return genIOUnitNumber(converter, loc, Fortran::semantics::GetExpr(*e), + ty, csi, stmtCtx); return builder.create( loc, builder.getIntegerAttr(ty, Fortran::runtime::io::DefaultUnit)); } template -mlir::Value getIOUnit(Fortran::lower::AbstractConverter &converter, - mlir::Location loc, const A &stmt, mlir::Type ty, - Fortran::lower::StatementContext &stmtCtx) { - if (stmt.iounit) - return genIOUnit(converter, loc, *stmt.iounit, ty, stmtCtx); - if (auto *iounit = getIOControl(stmt)) - return genIOUnit(converter, loc, *iounit, ty, stmtCtx); - fir::FirOpBuilder &builder = converter.getFirOpBuilder(); - return builder.create( - loc, builder.getIntegerAttr(ty, Fortran::runtime::io::DefaultUnit)); +static mlir::Value getIOUnit(Fortran::lower::AbstractConverter &converter, + mlir::Location loc, const A &stmt, mlir::Type ty, + ConditionSpecInfo &csi, + Fortran::lower::StatementContext &stmtCtx) { + const Fortran::parser::IoUnit *iounit = + stmt.iounit ? &*stmt.iounit : getIOControl(stmt); + return genIOUnit(converter, loc, iounit, ty, csi, stmtCtx); } - //===----------------------------------------------------------------------===// // Generators for each IO statement type. //===----------------------------------------------------------------------===// @@ -1562,17 +1625,18 @@ fir::FirOpBuilder &builder = converter.getFirOpBuilder(); Fortran::lower::StatementContext stmtCtx; mlir::Location loc = converter.getCurrentLocation(); - mlir::func::FuncOp beginFunc = getIORuntimeFunc(loc, builder); + ConditionSpecInfo csi = lowerErrorSpec(converter, loc, stmt.v); + auto beginFunc = getIORuntimeFunc(loc, builder); mlir::FunctionType beginFuncTy = beginFunc.getFunctionType(); - mlir::Value unit = fir::getBase(converter.genExprValue( - getExpr(stmt), stmtCtx, loc)); + mlir::Value unit = genIOUnitNumber( + converter, loc, getExpr(stmt), + beginFuncTy.getInput(0), csi, stmtCtx); mlir::Value un = builder.createConvert(loc, beginFuncTy.getInput(0), unit); mlir::Value file = locToFilename(converter, loc, beginFuncTy.getInput(1)); mlir::Value line = locToLineNo(converter, loc, beginFuncTy.getInput(2)); auto call = builder.create(loc, beginFunc, mlir::ValueRange{un, file, line}); mlir::Value cookie = call.getResult(0); - ConditionSpecInfo csi; genConditionHandlerCall(converter, loc, cookie, stmt.v, csi); mlir::Value ok; auto insertPt = builder.saveInsertionPoint(); @@ -1615,13 +1679,12 @@ std::get_if(&spec.u)) { Fortran::lower::StatementContext stmtCtx; fir::FirOpBuilder &builder = converter.getFirOpBuilder(); - mlir::func::FuncOp ioFunc = - getIORuntimeFunc(loc, builder); + auto ioFunc = getIORuntimeFunc(loc, builder); mlir::FunctionType ioFuncTy = ioFunc.getFunctionType(); const auto *var = Fortran::semantics::GetExpr(newunit->v); mlir::Value addr = builder.createConvert( loc, ioFuncTy.getInput(1), - fir::getBase(converter.genExprAddr(var, stmtCtx, loc))); + fir::getBase(converter.genExprAddr(loc, var, stmtCtx))); auto kind = builder.createIntegerConstant(loc, ioFuncTy.getInput(2), var->GetType().value().kind()); llvm::SmallVector ioArgs = {cookie, addr, kind}; @@ -1638,14 +1701,15 @@ mlir::func::FuncOp beginFunc; llvm::SmallVector beginArgs; mlir::Location loc = converter.getCurrentLocation(); + ConditionSpecInfo csi = lowerErrorSpec(converter, loc, stmt.v); bool hasNewunitSpec = false; if (hasSpec(stmt)) { beginFunc = getIORuntimeFunc(loc, builder); mlir::FunctionType beginFuncTy = beginFunc.getFunctionType(); - mlir::Value unit = fir::getBase(converter.genExprValue( - getExpr(stmt), stmtCtx, loc)); - beginArgs.push_back( - builder.createConvert(loc, beginFuncTy.getInput(0), unit)); + mlir::Value unit = genIOUnitNumber( + converter, loc, getExpr(stmt), + beginFuncTy.getInput(0), csi, stmtCtx); + beginArgs.push_back(unit); beginArgs.push_back(locToFilename(converter, loc, beginFuncTy.getInput(1))); beginArgs.push_back(locToLineNo(converter, loc, beginFuncTy.getInput(2))); } else { @@ -1658,7 +1722,6 @@ } auto cookie = builder.create(loc, beginFunc, beginArgs).getResult(0); - ConditionSpecInfo csi; genConditionHandlerCall(converter, loc, cookie, stmt.v, csi); mlir::Value ok; auto insertPt = builder.saveInsertionPoint(); @@ -1681,22 +1744,22 @@ fir::FirOpBuilder &builder = converter.getFirOpBuilder(); Fortran::lower::StatementContext stmtCtx; mlir::Location loc = converter.getCurrentLocation(); + ConditionSpecInfo csi = lowerErrorSpec(converter, loc, stmt.v); bool hasId = hasSpec(stmt); - mlir::func::FuncOp beginFunc = - hasId ? getIORuntimeFunc(loc, builder) - : getIORuntimeFunc(loc, builder); + auto beginFunc = hasId + ? getIORuntimeFunc(loc, builder) + : getIORuntimeFunc(loc, builder); mlir::FunctionType beginFuncTy = beginFunc.getFunctionType(); - mlir::Value unit = fir::getBase(converter.genExprValue( - getExpr(stmt), stmtCtx, loc)); - mlir::Value un = builder.createConvert(loc, beginFuncTy.getInput(0), unit); - llvm::SmallVector args{un}; + mlir::Value unit = genIOUnitNumber( + converter, loc, getExpr(stmt), + beginFuncTy.getInput(0), csi, stmtCtx); + llvm::SmallVector args{unit}; if (hasId) { mlir::Value id = fir::getBase(converter.genExprValue( - getExpr(stmt), stmtCtx, loc)); + loc, getExpr(stmt), stmtCtx)); args.push_back(builder.createConvert(loc, beginFuncTy.getInput(1), id)); } auto cookie = builder.create(loc, beginFunc, args).getResult(0); - ConditionSpecInfo csi; genConditionHandlerCall(converter, loc, cookie, stmt.v, csi); return genEndIO(converter, converter.getCurrentLocation(), cookie, csi, stmtCtx); @@ -1779,7 +1842,7 @@ const A &stmt, mlir::FunctionType ioFuncTy, bool isFormatted, bool isListOrNml, [[maybe_unused]] bool isInternal, [[maybe_unused]] bool isAsync, - const llvm::Optional &descRef, + const llvm::Optional &descRef, ConditionSpecInfo &csi, Fortran::lower::StatementContext &stmtCtx) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); auto maybeGetFormatArgs = [&]() { @@ -1812,12 +1875,14 @@ getDefaultScratchLen(builder, loc, ioFuncTy.getInput(ioArgs.size()))); } else if (isAsync) { // unit; REC; buffer and length ioArgs.push_back(getIOUnit(converter, loc, stmt, - ioFuncTy.getInput(ioArgs.size()), stmtCtx)); + ioFuncTy.getInput(ioArgs.size()), csi, + stmtCtx)); TODO(loc, "asynchronous"); } else { // external IO - maybe explicit format; unit maybeGetFormatArgs(); ioArgs.push_back(getIOUnit(converter, loc, stmt, - ioFuncTy.getInput(ioArgs.size()), stmtCtx)); + ioFuncTy.getInput(ioArgs.size()), csi, + stmtCtx)); } } else { // PRINT - maybe explicit format; default unit maybeGetFormatArgs(); @@ -1849,19 +1914,23 @@ const bool isAsync = isDataTransferAsynchronous(loc, stmt); const bool isNml = isDataTransferNamelist(stmt); + // Generate an EnableHandlers call and remaining specifier calls. + ConditionSpecInfo csi; + if constexpr (hasIOCtrl) { + csi = lowerErrorSpec(converter, loc, stmt.controls); + } + // Generate the begin data transfer function call. - mlir::func::FuncOp ioFunc = getBeginDataTransferFunc( - loc, builder, isFormatted, isList || isNml, isInternal, - isInternalWithDesc, isAsync); + auto ioFunc = getBeginDataTransferFunc(loc, builder, isFormatted, + isList || isNml, isInternal, + isInternalWithDesc, isAsync); llvm::SmallVector ioArgs; genBeginDataTransferCallArgs( ioArgs, converter, loc, stmt, ioFunc.getFunctionType(), isFormatted, - isList || isNml, isInternal, isAsync, descRef, stmtCtx); + isList || isNml, isInternal, isAsync, descRef, csi, stmtCtx); mlir::Value cookie = builder.create(loc, ioFunc, ioArgs).getResult(0); - // Generate an EnableHandlers call and remaining specifier calls. - ConditionSpecInfo csi; auto insertPt = builder.saveInsertionPoint(); mlir::Value ok; if constexpr (hasIOCtrl) { @@ -1879,8 +1948,7 @@ csi.hasTransferConditionSpec(), ok, stmtCtx); else genInputItemList(converter, cookie, stmt.items, isFormatted, - csi.hasTransferConditionSpec(), ok, /*inLoop=*/false, - stmtCtx); + csi.hasTransferConditionSpec(), ok, /*inLoop=*/false); } else if constexpr (std::is_same_v) { if (isNml) genNamelistIO(converter, cookie, @@ -1890,11 +1958,11 @@ else genOutputItemList(converter, cookie, stmt.items, isFormatted, csi.hasTransferConditionSpec(), ok, - /*inLoop=*/false, stmtCtx); + /*inLoop=*/false); } else { // PRINT genOutputItemList(converter, cookie, std::get<1>(stmt.t), isFormatted, csi.hasTransferConditionSpec(), ok, - /*inLoop=*/false, stmtCtx); + /*inLoop=*/false); } stmtCtx.finalize(); @@ -1966,12 +2034,11 @@ Fortran::parser::InquireSpec::CharVar::Kind::Iomsg) return {}; fir::FirOpBuilder &builder = converter.getFirOpBuilder(); - mlir::func::FuncOp specFunc = - getIORuntimeFunc(loc, builder); + auto specFunc = getIORuntimeFunc(loc, builder); mlir::FunctionType specFuncTy = specFunc.getFunctionType(); const auto *varExpr = Fortran::semantics::GetExpr( std::get(var.t)); - fir::ExtendedValue str = converter.genExprAddr(varExpr, stmtCtx, loc); + fir::ExtendedValue str = converter.genExprAddr(loc, varExpr, stmtCtx); llvm::SmallVector args = { builder.createConvert(loc, specFuncTy.getInput(0), cookie), builder.createIntegerConstant( @@ -1996,12 +2063,11 @@ Fortran::parser::InquireSpec::IntVar::Kind::Iostat) return {}; fir::FirOpBuilder &builder = converter.getFirOpBuilder(); - mlir::func::FuncOp specFunc = - getIORuntimeFunc(loc, builder); + auto specFunc = getIORuntimeFunc(loc, builder); mlir::FunctionType specFuncTy = specFunc.getFunctionType(); const auto *varExpr = Fortran::semantics::GetExpr( std::get(var.t)); - mlir::Value addr = fir::getBase(converter.genExprAddr(varExpr, stmtCtx, loc)); + mlir::Value addr = fir::getBase(converter.genExprAddr(loc, varExpr, stmtCtx)); mlir::Type eleTy = fir::dyn_cast_ptrEleTy(addr.getType()); if (!eleTy) fir::emitFatalError(loc, @@ -2033,15 +2099,16 @@ bool pendId = idExpr && logVarKind == Fortran::parser::InquireSpec::LogVar::Kind::Pending; - mlir::func::FuncOp specFunc = + auto specFunc = pendId ? getIORuntimeFunc(loc, builder) : getIORuntimeFunc(loc, builder); mlir::FunctionType specFuncTy = specFunc.getFunctionType(); mlir::Value addr = fir::getBase(converter.genExprAddr( + loc, Fortran::semantics::GetExpr( std::get>>(var.t)), - stmtCtx, loc)); + stmtCtx)); llvm::SmallVector args = { builder.createConvert(loc, specFuncTy.getInput(0), cookie)}; if (pendId) @@ -2069,7 +2136,7 @@ Fortran::common::visitors{ [&](const Fortran::parser::IdExpr &idExpr) { return fir::getBase(converter.genExprValue( - Fortran::semantics::GetExpr(idExpr), stmtCtx, loc)); + loc, Fortran::semantics::GetExpr(idExpr), stmtCtx)); }, [](const auto &) { return mlir::Value{}; }}, spec.u)) @@ -2102,7 +2169,6 @@ Fortran::lower::StatementContext stmtCtx; mlir::Location loc = converter.getCurrentLocation(); mlir::func::FuncOp beginFunc; - ConditionSpecInfo csi; llvm::SmallVector beginArgs; const auto *list = std::get_if>(&stmt.u); @@ -2114,22 +2180,24 @@ return exprPair.first && exprPair.second; }; + ConditionSpecInfo csi = + list ? lowerErrorSpec(converter, loc, *list) : ConditionSpecInfo{}; + // Make one of three BeginInquire calls. if (inquireFileUnit()) { // Inquire by unit -- [UNIT=]file-unit-number. beginFunc = getIORuntimeFunc(loc, builder); mlir::FunctionType beginFuncTy = beginFunc.getFunctionType(); - beginArgs = {builder.createConvert(loc, beginFuncTy.getInput(0), - fir::getBase(converter.genExprValue( - exprPair.first, stmtCtx, loc))), - locToFilename(converter, loc, beginFuncTy.getInput(1)), + mlir::Value unit = genIOUnitNumber(converter, loc, exprPair.first, + beginFuncTy.getInput(0), csi, stmtCtx); + beginArgs = {unit, locToFilename(converter, loc, beginFuncTy.getInput(1)), locToLineNo(converter, loc, beginFuncTy.getInput(2))}; } else if (inquireFileName()) { // Inquire by file -- FILE=file-name-expr. beginFunc = getIORuntimeFunc(loc, builder); mlir::FunctionType beginFuncTy = beginFunc.getFunctionType(); fir::ExtendedValue file = - converter.genExprAddr(exprPair.first, stmtCtx, loc); + converter.genExprAddr(loc, exprPair.first, stmtCtx); beginArgs = { builder.createConvert(loc, beginFuncTy.getInput(0), fir::getBase(file)), builder.createConvert(loc, beginFuncTy.getInput(1), fir::getLen(file)), @@ -2150,12 +2218,11 @@ genOutputItemList( converter, cookie, std::get>(ioLength->t), - /*isFormatted=*/false, /*checkResult=*/false, ok, /*inLoop=*/false, - stmtCtx); + /*isFormatted=*/false, /*checkResult=*/false, ok, /*inLoop=*/false); auto *ioLengthVar = Fortran::semantics::GetExpr( std::get(ioLength->t)); mlir::Value ioLengthVarAddr = - fir::getBase(converter.genExprAddr(ioLengthVar, stmtCtx, loc)); + fir::getBase(converter.genExprAddr(loc, ioLengthVar, stmtCtx)); llvm::SmallVector args = {cookie}; mlir::Value length = builder diff --git a/flang/lib/Optimizer/Builder/BoxValue.cpp b/flang/lib/Optimizer/Builder/BoxValue.cpp --- a/flang/lib/Optimizer/Builder/BoxValue.cpp +++ b/flang/lib/Optimizer/Builder/BoxValue.cpp @@ -222,10 +222,11 @@ /// Get exactly one extent for any array-like extended value, \p exv. If \p exv /// is not an array or has rank less then \p dim, the result will be a nullptr. -mlir::Value fir::getExtentAtDimension(const fir::ExtendedValue &exv, - fir::FirOpBuilder &builder, - mlir::Location loc, unsigned dim) { - auto extents = fir::factory::getExtents(builder, loc, exv); +mlir::Value fir::factory::getExtentAtDimension(mlir::Location loc, + fir::FirOpBuilder &builder, + const fir::ExtendedValue &exv, + unsigned dim) { + auto extents = fir::factory::getExtents(loc, builder, exv); if (dim < extents.size()) return extents[dim]; return {}; 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 @@ -649,7 +649,7 @@ } llvm::SmallVector -fir::factory::getExtents(fir::FirOpBuilder &builder, mlir::Location loc, +fir::factory::getExtents(mlir::Location loc, fir::FirOpBuilder &builder, const fir::ExtendedValue &box) { return box.match( [&](const fir::ArrayBoxValue &x) -> llvm::SmallVector { @@ -663,7 +663,7 @@ }, [&](const fir::MutableBoxValue &x) -> llvm::SmallVector { auto load = fir::factory::genMutableBoxRead(builder, loc, x); - return fir::factory::getExtents(builder, loc, load); + return fir::factory::getExtents(loc, builder, load); }, [&](const auto &) -> llvm::SmallVector { return {}; }); } @@ -683,7 +683,7 @@ fir::factory::readExtents(builder, loc, box), box.getLBounds()); } - if (box.isDerivedWithLengthParameters()) + if (box.isDerivedWithLenParameters()) TODO(loc, "read fir.box with length parameters"); if (box.rank() == 0) return addr; @@ -731,6 +731,71 @@ [&](const auto &) -> llvm::SmallVector { return {}; }); } +// If valTy is a box type, then we need to extract the type parameters from +// the box value. +static llvm::SmallVector getFromBox(mlir::Location loc, + fir::FirOpBuilder &builder, + mlir::Type valTy, + mlir::Value boxVal) { + if (auto boxTy = valTy.dyn_cast()) { + auto eleTy = fir::unwrapAllRefAndSeqType(boxTy.getEleTy()); + if (auto recTy = eleTy.dyn_cast()) { + if (recTy.getNumLenParams() > 0) { + // Walk each type parameter in the record and get the value. + TODO(loc, "generate code to get LEN type parameters"); + } + } else if (auto charTy = eleTy.dyn_cast()) { + if (charTy.hasDynamicLen()) { + auto idxTy = builder.getIndexType(); + auto eleSz = builder.create(loc, idxTy, boxVal); + auto kindBytes = + builder.getKindMap().getCharacterBitsize(charTy.getFKind()) / 8; + mlir::Value charSz = + builder.createIntegerConstant(loc, idxTy, kindBytes); + mlir::Value len = + builder.create(loc, eleSz, charSz); + return {len}; + } + } + } + return {}; +} + +// fir::getTypeParams() will get the type parameters from the extended value. +// When the extended value is a BoxValue or MutableBoxValue, it may be necessary +// to generate code, so this factory function handles those cases. +// TODO: fix the inverted type tests, etc. +llvm::SmallVector +fir::factory::getTypeParams(mlir::Location loc, fir::FirOpBuilder &builder, + const fir::ExtendedValue &exv) { + auto handleBoxed = [&](const auto &box) -> llvm::SmallVector { + if (box.isCharacter()) + return {fir::factory::readCharLen(builder, loc, exv)}; + if (box.isDerivedWithLenParameters()) { + // This should generate code to read the type parameters from the box. + // This requires some consideration however as MutableBoxValues need to be + // in a sane state to be provide the correct values. + TODO(loc, "derived type with type parameters"); + } + return {}; + }; + // Intentionally reuse the original code path to get type parameters for the + // cases that were supported rather than introduce a new path. + return exv.match( + [&](const fir::BoxValue &box) { return handleBoxed(box); }, + [&](const fir::MutableBoxValue &box) { return handleBoxed(box); }, + [&](const auto &) { return fir::getTypeParams(exv); }); +} + +llvm::SmallVector +fir::factory::getTypeParams(mlir::Location loc, fir::FirOpBuilder &builder, + fir::ArrayLoadOp load) { + mlir::Type memTy = load.getMemref().getType(); + if (auto boxTy = memTy.dyn_cast()) + return getFromBox(loc, builder, boxTy, load.getMemref()); + return load.getTypeparams(); +} + std::string fir::factory::uniqueCGIdent(llvm::StringRef prefix, llvm::StringRef name) { // For "long" identifiers use a hash value @@ -886,7 +951,7 @@ auto len = fir::factory::readCharLen(builder, loc, box); return fir::CharBoxValue{element, len}; } - if (box.isDerivedWithLengthParameters()) + if (box.isDerivedWithLenParameters()) TODO(loc, "get length parameters from derived type BoxValue"); return element; }, 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 @@ -66,7 +66,7 @@ cleanedAddr = builder.createConvert(loc, type, addr); if (charTy.getLen() == fir::CharacterType::unknownLen()) cleanedLengths.append(lengths.begin(), lengths.end()); - } else if (box.isDerivedWithLengthParameters()) { + } else if (box.isDerivedWithLenParameters()) { TODO(loc, "updating mutablebox of derived type with length parameters"); cleanedLengths = lengths; } @@ -164,7 +164,7 @@ extents = readShape(&lbounds); if (box.isCharacter()) lengths.emplace_back(readCharacterLength()); - else if (box.isDerivedWithLengthParameters()) + else if (box.isDerivedWithLenParameters()) TODO(loc, "read allocatable or pointer derived type LEN parameters"); return readBaseAddress(); } @@ -306,7 +306,7 @@ for (auto [len, lenVar] : llvm::zip(lengths, mutableProperties.deferredParams)) castAndStore(len, lenVar); - else if (box.isDerivedWithLengthParameters()) + else if (box.isDerivedWithLenParameters()) TODO(loc, "update allocatable derived type length parameters"); } fir::FirOpBuilder &builder; @@ -496,12 +496,12 @@ // fir.box to update the LHS. auto rawAddr = builder.create(loc, arr.getMemTy(), arr.getAddr()); - auto extents = fir::factory::getExtents(builder, loc, source); + auto extents = fir::factory::getExtents(loc, builder, source); llvm::SmallVector lenParams; if (arr.isCharacter()) { lenParams.emplace_back( fir::factory::readCharLen(builder, loc, source)); - } else if (arr.isDerivedWithLengthParameters()) { + } else if (arr.isDerivedWithLenParameters()) { TODO(loc, "pointer assignment to derived with length parameters"); } writer.updateMutableBox(rawAddr, newLbounds, extents, lenParams); @@ -593,7 +593,7 @@ if (arr.isCharacter()) { lenParams.emplace_back( fir::factory::readCharLen(builder, loc, source)); - } else if (arr.isDerivedWithLengthParameters()) { + } else if (arr.isDerivedWithLenParameters()) { TODO(loc, "pointer assignment to derived with length parameters"); } writer.updateMutableBox(rawAddr, lbounds, extents, lenParams); @@ -745,7 +745,7 @@ assert(!lengthParams.empty() && "must provide length parameters for character"); compareProperty(reader.readCharacterLength(), lengthParams[0]); - } else if (box.isDerivedWithLengthParameters()) { + } else if (box.isDerivedWithLenParameters()) { TODO(loc, "automatic allocation of derived type allocatable with " "length parameters"); } @@ -808,7 +808,7 @@ return fir::CharArrayBoxValue{newAddr, len, extents}; return fir::CharBoxValue{newAddr, len}; } - if (box.isDerivedWithLengthParameters()) + if (box.isDerivedWithLenParameters()) TODO(loc, "reallocation of derived type entities with length parameters"); if (box.hasRank()) return fir::ArrayBoxValue{newAddr, extents}; @@ -834,12 +834,12 @@ llvm::SmallVector lenParams; if (box.isCharacter()) lenParams.push_back(fir::getLen(realloc.newValue)); - if (box.isDerivedWithLengthParameters()) + if (box.isDerivedWithLenParameters()) TODO(loc, "reallocation of derived type entities with length parameters"); auto lengths = getNewLengths(builder, loc, box, lenParams); auto heap = fir::getBase(realloc.newValue); - auto extents = fir::factory::getExtents(builder, loc, realloc.newValue); + auto extents = fir::factory::getExtents(loc, builder, realloc.newValue); builder.genIfThen(loc, realloc.oldAddressWasAllocated) .genThen( [&]() { genFinalizeAndFree(builder, loc, realloc.oldAddress); }) diff --git a/flang/lib/Optimizer/Dialect/FIRType.cpp b/flang/lib/Optimizer/Dialect/FIRType.cpp --- a/flang/lib/Optimizer/Dialect/FIRType.cpp +++ b/flang/lib/Optimizer/Dialect/FIRType.cpp @@ -263,6 +263,14 @@ return false; } +bool isUnlimitedPolymorphicType(mlir::Type ty) { + if (auto refTy = fir::dyn_cast_ptrEleTy(ty)) + ty = refTy; + if (auto boxTy = ty.dyn_cast()) + return boxTy.getEleTy().isa(); + return false; +} + bool isRecordWithAllocatableMember(mlir::Type ty) { if (auto recTy = ty.dyn_cast()) for (auto [field, memTy] : recTy.getTypeList()) { @@ -276,6 +284,28 @@ return false; } +mlir::Type unwrapAllRefAndSeqType(mlir::Type ty) { + while (true) { + mlir::Type nt = unwrapSequenceType(unwrapRefType(ty)); + if (auto vecTy = nt.dyn_cast()) + nt = vecTy.getEleTy(); + if (nt == ty) + return ty; + ty = nt; + } +} + +mlir::Type unwrapSeqOrBoxedSeqType(mlir::Type ty) { + if (auto seqTy = ty.dyn_cast()) + return seqTy.getEleTy(); + if (auto boxTy = ty.dyn_cast()) { + auto eleTy = unwrapRefType(boxTy.getEleTy()); + if (auto seqTy = eleTy.dyn_cast()) + return seqTy.getEleTy(); + } + return ty; +} + } // namespace fir namespace { diff --git a/flang/test/Lower/forall/array-pointer.f90 b/flang/test/Lower/forall/array-pointer.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/forall/array-pointer.f90 @@ -0,0 +1,816 @@ +! Test lowering of arrays of POINTER. +! +! An array of pointer to T can be constructed by having an array of +! derived type, where the derived type has a pointer to T +! component. An entity with both the DIMENSION and POINTER attributes +! is a pointer to an array of T and never an array of pointer to T in +! Fortran. + +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +module array_of_pointer_test + type t + integer, POINTER :: ip + end type t + + type u + integer :: v + end type u + + type tu + type(u), POINTER :: ip + end type tu + + type ta + integer, POINTER :: ip(:) + end type ta + + type tb + integer, POINTER :: ip(:,:) + end type tb + + type tv + type(tu), POINTER :: jp(:) + end type tv + + ! Derived types with type parameters hit a TODO. +! type ct(l) +! integer, len :: l +! character(LEN=l), POINTER :: cp +! end type ct + +! type cu(l) +! integer, len :: l +! character(LEN=l) :: cv +! end type cu +end module array_of_pointer_test + +subroutine s1(x,y) + use array_of_pointer_test + type(t) :: x(:) + integer :: y(:) + + forall (i=1:10) + ! assign value to pointee variable + x(i)%ip = y(i) + end forall +end subroutine s1 + +! CHECK-LABEL: func @_QPs1( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.box>}>>> {fir.bindc_name = "x"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.box> {fir.bindc_name = "y"}) { +! CHECK: %[[VAL_2:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "i"} +! CHECK: %[[VAL_3:.*]] = arith.constant 1 : i32 +! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (i32) -> index +! CHECK: %[[VAL_5:.*]] = arith.constant 10 : i32 +! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i32) -> index +! CHECK: %[[VAL_7:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_8:.*]] = fir.array_load %[[VAL_0]] : (!fir.box>}>>>) -> !fir.array>}>> +! CHECK: %[[VAL_9:.*]] = fir.array_load %[[VAL_1]] : (!fir.box>) -> !fir.array +! CHECK: %[[VAL_10:.*]] = fir.do_loop %[[VAL_11:.*]] = %[[VAL_4]] to %[[VAL_6]] step %[[VAL_7]] unordered iter_args(%[[VAL_12:.*]] = %[[VAL_8]]) -> (!fir.array>}>>) { +! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_11]] : (index) -> i32 +! CHECK: fir.store %[[VAL_13]] to %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_14:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_15:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_15]] : (i32) -> i64 +! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_16]] : (i64) -> index +! CHECK: %[[VAL_18:.*]] = arith.subi %[[VAL_17]], %[[VAL_14]] : index +! CHECK: %[[VAL_19:.*]] = fir.array_fetch %[[VAL_9]], %[[VAL_18]] : (!fir.array, index) -> i32 +! CHECK: %[[VAL_20:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_21:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_22:.*]] = fir.convert %[[VAL_21]] : (i32) -> i64 +! CHECK: %[[VAL_23:.*]] = fir.convert %[[VAL_22]] : (i64) -> index +! CHECK: %[[VAL_24:.*]] = arith.subi %[[VAL_23]], %[[VAL_20]] : index +! CHECK: %[[VAL_25:.*]] = fir.field_index ip, !fir.type<_QMarray_of_pointer_testTt{ip:!fir.box>}> +! CHECK: %[[VAL_26:.*]] = fir.array_access %[[VAL_12]], %[[VAL_24]], %[[VAL_25]] : (!fir.array>}>>, index, !fir.field) -> !fir.ref>> +! CHECK: %[[VAL_27:.*]] = fir.load %[[VAL_26]] : !fir.ref>> +! CHECK: %[[VAL_28:.*]] = fir.box_addr %[[VAL_27]] : (!fir.box>) -> !fir.ptr +! CHECK: fir.store %[[VAL_19]] to %[[VAL_28]] : !fir.ptr +! CHECK: %[[VAL_29:.*]] = fir.array_amend %[[VAL_12]], %[[VAL_26]] : (!fir.array>}>>, !fir.ref>>) -> !fir.array>}>> +! CHECK: fir.result %[[VAL_29]] : !fir.array>}>> +! CHECK: } +! CHECK: fir.array_merge_store %[[VAL_8]], %[[VAL_30:.*]] to %[[VAL_0]] : !fir.array>}>>, !fir.array>}>>, !fir.box>}>>> +! CHECK: return +! CHECK: } + +subroutine s1_1(x,y) + use array_of_pointer_test + type(t) :: x(10) + integer :: y(10) + + forall (i=1:10) + ! assign value to pointee variable + x(i)%ip = y(i) + end forall +end subroutine s1_1 + +! CHECK-LABEL: func @_QPs1_1( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>}>>> {fir.bindc_name = "x"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref> {fir.bindc_name = "y"}) { +! CHECK: %[[VAL_2:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "i"} +! CHECK: %[[VAL_3:.*]] = arith.constant 10 : index +! CHECK: %[[VAL_4:.*]] = arith.constant 10 : index +! CHECK: %[[VAL_5:.*]] = arith.constant 1 : i32 +! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i32) -> index +! CHECK: %[[VAL_7:.*]] = arith.constant 10 : i32 +! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (i32) -> index +! CHECK: %[[VAL_9:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_10:.*]] = fir.shape %[[VAL_3]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_11:.*]] = fir.array_load %[[VAL_0]](%[[VAL_10]]) : (!fir.ref>}>>>, !fir.shape<1>) -> !fir.array<10x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box>}>> +! CHECK: %[[VAL_12:.*]] = fir.shape %[[VAL_4]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_13:.*]] = fir.array_load %[[VAL_1]](%[[VAL_12]]) : (!fir.ref>, !fir.shape<1>) -> !fir.array<10xi32> +! CHECK: %[[VAL_14:.*]] = fir.do_loop %[[VAL_15:.*]] = %[[VAL_6]] to %[[VAL_8]] step %[[VAL_9]] unordered iter_args(%[[VAL_16:.*]] = %[[VAL_11]]) -> (!fir.array<10x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box>}>>) { +! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_15]] : (index) -> i32 +! CHECK: fir.store %[[VAL_17]] to %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_18:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_19:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_20:.*]] = fir.convert %[[VAL_19]] : (i32) -> i64 +! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_20]] : (i64) -> index +! CHECK: %[[VAL_22:.*]] = arith.subi %[[VAL_21]], %[[VAL_18]] : index +! CHECK: %[[VAL_23:.*]] = fir.array_fetch %[[VAL_13]], %[[VAL_22]] : (!fir.array<10xi32>, index) -> i32 +! CHECK: %[[VAL_24:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_25:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_26:.*]] = fir.convert %[[VAL_25]] : (i32) -> i64 +! CHECK: %[[VAL_27:.*]] = fir.convert %[[VAL_26]] : (i64) -> index +! CHECK: %[[VAL_28:.*]] = arith.subi %[[VAL_27]], %[[VAL_24]] : index +! CHECK: %[[VAL_29:.*]] = fir.field_index ip, !fir.type<_QMarray_of_pointer_testTt{ip:!fir.box>}> +! CHECK: %[[VAL_30:.*]] = fir.array_access %[[VAL_16]], %[[VAL_28]], %[[VAL_29]] : (!fir.array<10x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box>}>>, index, !fir.field) -> !fir.ref>> +! CHECK: %[[VAL_31:.*]] = fir.load %[[VAL_30]] : !fir.ref>> +! CHECK: %[[VAL_32:.*]] = fir.box_addr %[[VAL_31]] : (!fir.box>) -> !fir.ptr +! CHECK: fir.store %[[VAL_23]] to %[[VAL_32]] : !fir.ptr +! CHECK: %[[VAL_33:.*]] = fir.array_amend %[[VAL_16]], %[[VAL_30]] : (!fir.array<10x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box>}>>, !fir.ref>>) -> !fir.array<10x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box>}>> +! CHECK: fir.result %[[VAL_33]] : !fir.array<10x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box>}>> +! CHECK: } +! CHECK: fir.array_merge_store %[[VAL_11]], %[[VAL_34:.*]] to %[[VAL_0]] : !fir.array<10x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box>}>>, !fir.array<10x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box>}>>, !fir.ref>}>>> +! CHECK: return +! CHECK: } + +! Dependent type assignment, TODO +!subroutine s1_2(x,y,l) +! use array_of_pointer_test +! type(ct(l)) :: x(10) +! character(l) :: y(10) + +! forall (i=1:10) + ! assign value to pointee variable +! x(i)%cp = y(i) +! end forall +!end subroutine s1_2 + +subroutine s2(x,y) + use array_of_pointer_test + type(t) :: x(:) + integer, TARGET :: y(:) + + forall (i=1:10) + ! assign address to POINTER + x(i)%ip => y(i) + end forall +end subroutine s2 + +! CHECK-LABEL: func @_QPs2( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.box>}>>> {fir.bindc_name = "x"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.box> {fir.bindc_name = "y", fir.target}) { +! CHECK: %[[VAL_2:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "i"} +! CHECK: %[[VAL_3:.*]] = arith.constant 1 : i32 +! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (i32) -> index +! CHECK: %[[VAL_5:.*]] = arith.constant 10 : i32 +! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i32) -> index +! CHECK: %[[VAL_7:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_8:.*]] = fir.array_load %[[VAL_0]] : (!fir.box>}>>>) -> !fir.array>}>> +! CHECK: %[[VAL_9:.*]] = fir.array_load %[[VAL_1]] : (!fir.box>) -> !fir.array +! CHECK: %[[VAL_10:.*]] = fir.do_loop %[[VAL_11:.*]] = %[[VAL_4]] to %[[VAL_6]] step %[[VAL_7]] unordered iter_args(%[[VAL_12:.*]] = %[[VAL_8]]) -> (!fir.array>}>>) { +! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_11]] : (index) -> i32 +! CHECK: fir.store %[[VAL_13]] to %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_14:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_15:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_15]] : (i32) -> i64 +! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_16]] : (i64) -> index +! CHECK: %[[VAL_18:.*]] = arith.subi %[[VAL_17]], %[[VAL_14]] : index +! CHECK: %[[VAL_19:.*]] = fir.array_access %[[VAL_9]], %[[VAL_18]] : (!fir.array, index) -> !fir.ref +! CHECK: %[[VAL_20:.*]] = fir.convert %[[VAL_19]] : (!fir.ref) -> !fir.ptr +! CHECK: %[[VAL_21:.*]] = fir.embox %[[VAL_20]] : (!fir.ptr) -> !fir.box> +! CHECK: %[[VAL_22:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_23:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_24:.*]] = fir.convert %[[VAL_23]] : (i32) -> i64 +! CHECK: %[[VAL_25:.*]] = fir.convert %[[VAL_24]] : (i64) -> index +! CHECK: %[[VAL_26:.*]] = arith.subi %[[VAL_25]], %[[VAL_22]] : index +! CHECK: %[[VAL_27:.*]] = fir.field_index ip, !fir.type<_QMarray_of_pointer_testTt{ip:!fir.box>}> +! CHECK: %[[VAL_28:.*]] = fir.array_update %[[VAL_12]], %[[VAL_21]], %[[VAL_26]], %[[VAL_27]] : (!fir.array>}>>, !fir.box>, index, !fir.field) -> !fir.array>}>> +! CHECK: fir.result %[[VAL_28]] : !fir.array>}>> +! CHECK: } +! CHECK: fir.array_merge_store %[[VAL_8]], %[[VAL_29:.*]] to %[[VAL_0]] : !fir.array>}>>, !fir.array>}>>, !fir.box>}>>> +! CHECK: return +! CHECK: } + +subroutine s2_1(x,y) + use array_of_pointer_test + type(t) :: x(:) + integer, POINTER :: y(:) + + forall (i=1:10) + ! assign address to POINTER + x(i)%ip => y(i) + end forall +end subroutine s2_1 + +! CHECK-LABEL: func @_QPs2_1( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.box>}>>> {fir.bindc_name = "x"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref>>> {fir.bindc_name = "y"}) { +! CHECK: %[[VAL_2:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "i"} +! CHECK: %[[VAL_3:.*]] = arith.constant 1 : i32 +! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (i32) -> index +! CHECK: %[[VAL_5:.*]] = arith.constant 10 : i32 +! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i32) -> index +! CHECK: %[[VAL_7:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_8:.*]] = fir.array_load %[[VAL_0]] : (!fir.box>}>>>) -> !fir.array>}>> +! CHECK: %[[VAL_9:.*]] = fir.load %[[VAL_1]] : !fir.ref>>> +! CHECK: %[[VAL_10:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_11:.*]]:3 = fir.box_dims %[[VAL_9]], %[[VAL_10]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[VAL_12:.*]] = fir.shift %[[VAL_11]]#0 : (index) -> !fir.shift<1> +! CHECK: %[[VAL_13:.*]] = fir.array_load %[[VAL_9]](%[[VAL_12]]) : (!fir.box>>, !fir.shift<1>) -> !fir.array +! CHECK: %[[VAL_14:.*]] = fir.do_loop %[[VAL_15:.*]] = %[[VAL_4]] to %[[VAL_6]] step %[[VAL_7]] unordered iter_args(%[[VAL_16:.*]] = %[[VAL_8]]) -> (!fir.array>}>>) { +! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_15]] : (index) -> i32 +! CHECK: fir.store %[[VAL_17]] to %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_18:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_19:.*]] = fir.convert %[[VAL_18]] : (i32) -> i64 +! CHECK: %[[VAL_20:.*]] = fir.convert %[[VAL_19]] : (i64) -> index +! CHECK: %[[VAL_21:.*]] = arith.subi %[[VAL_20]], %[[VAL_11]]#0 : index +! CHECK: %[[VAL_22:.*]] = fir.array_access %[[VAL_13]], %[[VAL_21]] : (!fir.array, index) -> !fir.ref +! CHECK: %[[VAL_23:.*]] = fir.convert %[[VAL_22]] : (!fir.ref) -> !fir.ptr +! CHECK: %[[VAL_24:.*]] = fir.embox %[[VAL_23]] : (!fir.ptr) -> !fir.box> +! CHECK: %[[VAL_25:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_26:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_27:.*]] = fir.convert %[[VAL_26]] : (i32) -> i64 +! CHECK: %[[VAL_28:.*]] = fir.convert %[[VAL_27]] : (i64) -> index +! CHECK: %[[VAL_29:.*]] = arith.subi %[[VAL_28]], %[[VAL_25]] : index +! CHECK: %[[VAL_30:.*]] = fir.field_index ip, !fir.type<_QMarray_of_pointer_testTt{ip:!fir.box>}> +! CHECK: %[[VAL_31:.*]] = fir.array_update %[[VAL_16]], %[[VAL_24]], %[[VAL_29]], %[[VAL_30]] : (!fir.array>}>>, !fir.box>, index, !fir.field) -> !fir.array>}>> +! CHECK: fir.result %[[VAL_31]] : !fir.array>}>> +! CHECK: } +! CHECK: fir.array_merge_store %[[VAL_8]], %[[VAL_32:.*]] to %[[VAL_0]] : !fir.array>}>>, !fir.array>}>>, !fir.box>}>>> +! CHECK: return +! CHECK: } + +subroutine s2_2(x,y) + use array_of_pointer_test + type(t) :: x(:) + integer, ALLOCATABLE, TARGET :: y(:) + + forall (i=1:10) + ! assign address to POINTER + x(i)%ip => y(i) + end forall +end subroutine s2_2 + +! CHECK-LABEL: func @_QPs2_2( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.box>}>>> {fir.bindc_name = "x"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref>>> {fir.bindc_name = "y", fir.target}) { +! CHECK: %[[VAL_2:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "i"} +! CHECK: %[[VAL_3:.*]] = arith.constant 1 : i32 +! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (i32) -> index +! CHECK: %[[VAL_5:.*]] = arith.constant 10 : i32 +! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i32) -> index +! CHECK: %[[VAL_7:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_8:.*]] = fir.array_load %[[VAL_0]] : (!fir.box>}>>>) -> !fir.array>}>> +! CHECK: %[[VAL_9:.*]] = fir.load %[[VAL_1]] : !fir.ref>>> +! CHECK: %[[VAL_10:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_11:.*]]:3 = fir.box_dims %[[VAL_9]], %[[VAL_10]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[VAL_12:.*]] = fir.box_addr %[[VAL_9]] : (!fir.box>>) -> !fir.heap> +! CHECK: %[[VAL_13:.*]] = fir.shape_shift %[[VAL_11]]#0, %[[VAL_11]]#1 : (index, index) -> !fir.shapeshift<1> +! CHECK: %[[VAL_14:.*]] = fir.array_load %[[VAL_12]](%[[VAL_13]]) : (!fir.heap>, !fir.shapeshift<1>) -> !fir.array +! CHECK: %[[VAL_15:.*]] = fir.do_loop %[[VAL_16:.*]] = %[[VAL_4]] to %[[VAL_6]] step %[[VAL_7]] unordered iter_args(%[[VAL_17:.*]] = %[[VAL_8]]) -> (!fir.array>}>>) { +! CHECK: %[[VAL_18:.*]] = fir.convert %[[VAL_16]] : (index) -> i32 +! CHECK: fir.store %[[VAL_18]] to %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_19:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_20:.*]] = fir.convert %[[VAL_19]] : (i32) -> i64 +! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_20]] : (i64) -> index +! CHECK: %[[VAL_22:.*]] = arith.subi %[[VAL_21]], %[[VAL_11]]#0 : index +! CHECK: %[[VAL_23:.*]] = fir.array_access %[[VAL_14]], %[[VAL_22]] : (!fir.array, index) -> !fir.ref +! CHECK: %[[VAL_24:.*]] = fir.convert %[[VAL_23]] : (!fir.ref) -> !fir.ptr +! CHECK: %[[VAL_25:.*]] = fir.embox %[[VAL_24]] : (!fir.ptr) -> !fir.box> +! CHECK: %[[VAL_26:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_27:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_28:.*]] = fir.convert %[[VAL_27]] : (i32) -> i64 +! CHECK: %[[VAL_29:.*]] = fir.convert %[[VAL_28]] : (i64) -> index +! CHECK: %[[VAL_30:.*]] = arith.subi %[[VAL_29]], %[[VAL_26]] : index +! CHECK: %[[VAL_31:.*]] = fir.field_index ip, !fir.type<_QMarray_of_pointer_testTt{ip:!fir.box>}> +! CHECK: %[[VAL_32:.*]] = fir.array_update %[[VAL_17]], %[[VAL_25]], %[[VAL_30]], %[[VAL_31]] : (!fir.array>}>>, !fir.box>, index, !fir.field) -> !fir.array>}>> +! CHECK: fir.result %[[VAL_32]] : !fir.array>}>> +! CHECK: } +! CHECK: fir.array_merge_store %[[VAL_8]], %[[VAL_33:.*]] to %[[VAL_0]] : !fir.array>}>>, !fir.array>}>>, !fir.box>}>>> +! CHECK: return +! CHECK: } + +subroutine s2_3(x) + use array_of_pointer_test + type(t) :: x(:) + ! This is legal, but a bad idea. + integer, ALLOCATABLE, TARGET :: y(:) + + forall (i=1:10) + ! assign address to POINTER + x(i)%ip => y(i) + end forall + ! x's pointers will remain associated, and may point to deallocated y. +end subroutine s2_3 + +! CHECK-LABEL: func @_QPs2_3( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.box>}>>> {fir.bindc_name = "x"}) { +! CHECK: %[[VAL_1:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "i"} +! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.box>> {bindc_name = "y", fir.target, uniq_name = "_QFs2_3Ey"} +! CHECK: %[[VAL_3:.*]] = fir.alloca !fir.heap> {uniq_name = "_QFs2_3Ey.addr"} +! CHECK: %[[VAL_4:.*]] = fir.alloca index {uniq_name = "_QFs2_3Ey.lb0"} +! CHECK: %[[VAL_5:.*]] = fir.alloca index {uniq_name = "_QFs2_3Ey.ext0"} +! CHECK: %[[VAL_6:.*]] = fir.zero_bits !fir.heap> +! CHECK: fir.store %[[VAL_6]] to %[[VAL_3]] : !fir.ref>> +! CHECK: %[[VAL_7:.*]] = arith.constant 1 : i32 +! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (i32) -> index +! CHECK: %[[VAL_9:.*]] = arith.constant 10 : i32 +! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_9]] : (i32) -> index +! CHECK: %[[VAL_11:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_12:.*]] = fir.array_load %[[VAL_0]] : (!fir.box>}>>>) -> !fir.array>}>> +! CHECK: %[[VAL_13:.*]] = fir.load %[[VAL_4]] : !fir.ref +! CHECK: %[[VAL_14:.*]] = fir.load %[[VAL_5]] : !fir.ref +! CHECK: %[[VAL_15:.*]] = fir.load %[[VAL_3]] : !fir.ref>> +! CHECK: %[[VAL_16:.*]] = fir.shape_shift %[[VAL_13]], %[[VAL_14]] : (index, index) -> !fir.shapeshift<1> +! CHECK: %[[VAL_17:.*]] = fir.array_load %[[VAL_15]](%[[VAL_16]]) : (!fir.heap>, !fir.shapeshift<1>) -> !fir.array +! CHECK: %[[VAL_18:.*]] = fir.do_loop %[[VAL_19:.*]] = %[[VAL_8]] to %[[VAL_10]] step %[[VAL_11]] unordered iter_args(%[[VAL_20:.*]] = %[[VAL_12]]) -> (!fir.array>}>>) { +! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_19]] : (index) -> i32 +! CHECK: fir.store %[[VAL_21]] to %[[VAL_1]] : !fir.ref +! CHECK: %[[VAL_22:.*]] = fir.load %[[VAL_1]] : !fir.ref +! CHECK: %[[VAL_23:.*]] = fir.convert %[[VAL_22]] : (i32) -> i64 +! CHECK: %[[VAL_24:.*]] = fir.convert %[[VAL_23]] : (i64) -> index +! CHECK: %[[VAL_25:.*]] = arith.subi %[[VAL_24]], %[[VAL_13]] : index +! CHECK: %[[VAL_26:.*]] = fir.array_access %[[VAL_17]], %[[VAL_25]] : (!fir.array, index) -> !fir.ref +! CHECK: %[[VAL_27:.*]] = fir.convert %[[VAL_26]] : (!fir.ref) -> !fir.ptr +! CHECK: %[[VAL_28:.*]] = fir.embox %[[VAL_27]] : (!fir.ptr) -> !fir.box> +! CHECK: %[[VAL_29:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_30:.*]] = fir.load %[[VAL_1]] : !fir.ref +! CHECK: %[[VAL_31:.*]] = fir.convert %[[VAL_30]] : (i32) -> i64 +! CHECK: %[[VAL_32:.*]] = fir.convert %[[VAL_31]] : (i64) -> index +! CHECK: %[[VAL_33:.*]] = arith.subi %[[VAL_32]], %[[VAL_29]] : index +! CHECK: %[[VAL_34:.*]] = fir.field_index ip, !fir.type<_QMarray_of_pointer_testTt{ip:!fir.box>}> +! CHECK: %[[VAL_35:.*]] = fir.array_update %[[VAL_20]], %[[VAL_28]], %[[VAL_33]], %[[VAL_34]] : (!fir.array>}>>, !fir.box>, index, !fir.field) -> !fir.array>}>> +! CHECK: fir.result %[[VAL_35]] : !fir.array>}>> +! CHECK: } +! CHECK: fir.array_merge_store %[[VAL_12]], %[[VAL_36:.*]] to %[[VAL_0]] : !fir.array>}>>, !fir.array>}>>, !fir.box>}>>> +! CHECK: return +! CHECK: } + +! Dependent type - TODO +!subroutine s2_4(x,y,l) +! use array_of_pointer_test +! type(ct(l)) :: x(:) +! character(l), TARGET :: y(:) + +! forall (i=1:10) + ! assign address to POINTER +! x(i)%cp => y(i) +! end forall +!end subroutine s2_4 + +subroutine s3(x,y) + use array_of_pointer_test + type(tu) :: x(:) + integer :: y(:) + + forall (i=1:10) + ! assign value to variable, indirecting through box + x(i)%ip%v = y(i) + end forall +end subroutine s3 + +! CHECK-LABEL: func @_QPs3( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.box>>}>>> {fir.bindc_name = "x"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.box> {fir.bindc_name = "y"}) { +! CHECK: %[[VAL_2:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "i"} +! CHECK: %[[VAL_3:.*]] = arith.constant 1 : i32 +! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (i32) -> index +! CHECK: %[[VAL_5:.*]] = arith.constant 10 : i32 +! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i32) -> index +! CHECK: %[[VAL_7:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_8:.*]] = fir.array_load %[[VAL_0]] : (!fir.box>>}>>>) -> !fir.array>>}>> +! CHECK: %[[VAL_9:.*]] = fir.array_load %[[VAL_1]] : (!fir.box>) -> !fir.array +! CHECK: %[[VAL_10:.*]] = fir.do_loop %[[VAL_11:.*]] = %[[VAL_4]] to %[[VAL_6]] step %[[VAL_7]] unordered iter_args(%[[VAL_12:.*]] = %[[VAL_8]]) -> (!fir.array>>}>>) { +! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_11]] : (index) -> i32 +! CHECK: fir.store %[[VAL_13]] to %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_14:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_15:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_15]] : (i32) -> i64 +! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_16]] : (i64) -> index +! CHECK: %[[VAL_18:.*]] = arith.subi %[[VAL_17]], %[[VAL_14]] : index +! CHECK: %[[VAL_19:.*]] = fir.array_fetch %[[VAL_9]], %[[VAL_18]] : (!fir.array, index) -> i32 +! CHECK: %[[VAL_20:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_21:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_22:.*]] = fir.convert %[[VAL_21]] : (i32) -> i64 +! CHECK: %[[VAL_23:.*]] = fir.convert %[[VAL_22]] : (i64) -> index +! CHECK: %[[VAL_24:.*]] = arith.subi %[[VAL_23]], %[[VAL_20]] : index +! CHECK: %[[VAL_25:.*]] = fir.field_index ip, !fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box>>}> +! CHECK: %[[VAL_26:.*]] = fir.field_index v, !fir.type<_QMarray_of_pointer_testTu{v:i32}> +! CHECK: %[[VAL_27:.*]] = fir.array_access %[[VAL_12]], %[[VAL_24]], %[[VAL_25]] : (!fir.array>>}>>, index, !fir.field) -> !fir.ref>>> +! CHECK: %[[VAL_28:.*]] = fir.load %[[VAL_27]] : !fir.ref>>> +! CHECK: %[[VAL_29:.*]] = fir.coordinate_of %[[VAL_28]], %[[VAL_26]] : (!fir.box>>, !fir.field) -> !fir.ref +! CHECK: fir.store %[[VAL_19]] to %[[VAL_29]] : !fir.ref +! CHECK: %[[VAL_30:.*]] = fir.array_amend %[[VAL_12]], %[[VAL_27]] : (!fir.array>>}>>, !fir.ref>>>) -> !fir.array>>}>> +! CHECK: fir.result %[[VAL_30]] : !fir.array>>}>> +! CHECK: } +! CHECK: fir.array_merge_store %[[VAL_8]], %[[VAL_31:.*]] to %[[VAL_0]] : !fir.array>>}>>, !fir.array>>}>>, !fir.box>>}>>> +! CHECK: return +! CHECK: } + +subroutine s3_1(x,y) + use array_of_pointer_test + type(tu) :: x(:) + integer :: y(:) + + forall (i=1:10) + ! assign value to variable, indirecting through box + x(i)%ip%v = y(i) + end forall +end subroutine s3_1 + +! CHECK-LABEL: func @_QPs3_1( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.box>>}>>> {fir.bindc_name = "x"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.box> {fir.bindc_name = "y"}) { +! CHECK: %[[VAL_2:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "i"} +! CHECK: %[[VAL_3:.*]] = arith.constant 1 : i32 +! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (i32) -> index +! CHECK: %[[VAL_5:.*]] = arith.constant 10 : i32 +! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i32) -> index +! CHECK: %[[VAL_7:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_8:.*]] = fir.array_load %[[VAL_0]] : (!fir.box>>}>>>) -> !fir.array>>}>> +! CHECK: %[[VAL_9:.*]] = fir.array_load %[[VAL_1]] : (!fir.box>) -> !fir.array +! CHECK: %[[VAL_10:.*]] = fir.do_loop %[[VAL_11:.*]] = %[[VAL_4]] to %[[VAL_6]] step %[[VAL_7]] unordered iter_args(%[[VAL_12:.*]] = %[[VAL_8]]) -> (!fir.array>>}>>) { +! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_11]] : (index) -> i32 +! CHECK: fir.store %[[VAL_13]] to %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_14:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_15:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_15]] : (i32) -> i64 +! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_16]] : (i64) -> index +! CHECK: %[[VAL_18:.*]] = arith.subi %[[VAL_17]], %[[VAL_14]] : index +! CHECK: %[[VAL_19:.*]] = fir.array_fetch %[[VAL_9]], %[[VAL_18]] : (!fir.array, index) -> i32 +! CHECK: %[[VAL_20:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_21:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_22:.*]] = fir.convert %[[VAL_21]] : (i32) -> i64 +! CHECK: %[[VAL_23:.*]] = fir.convert %[[VAL_22]] : (i64) -> index +! CHECK: %[[VAL_24:.*]] = arith.subi %[[VAL_23]], %[[VAL_20]] : index +! CHECK: %[[VAL_25:.*]] = fir.field_index ip, !fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box>>}> +! CHECK: %[[VAL_26:.*]] = fir.field_index v, !fir.type<_QMarray_of_pointer_testTu{v:i32}> +! CHECK: %[[VAL_27:.*]] = fir.array_access %[[VAL_12]], %[[VAL_24]], %[[VAL_25]] : (!fir.array>>}>>, index, !fir.field) -> !fir.ref>>> +! CHECK: %[[VAL_28:.*]] = fir.load %[[VAL_27]] : !fir.ref>>> +! CHECK: %[[VAL_29:.*]] = fir.coordinate_of %[[VAL_28]], %[[VAL_26]] : (!fir.box>>, !fir.field) -> !fir.ref +! CHECK: fir.store %[[VAL_19]] to %[[VAL_29]] : !fir.ref +! CHECK: %[[VAL_30:.*]] = fir.array_amend %[[VAL_12]], %[[VAL_27]] : (!fir.array>>}>>, !fir.ref>>>) -> !fir.array>>}>> +! CHECK: fir.result %[[VAL_30]] : !fir.array>>}>> +! CHECK: } +! CHECK: fir.array_merge_store %[[VAL_8]], %[[VAL_31:.*]] to %[[VAL_0]] : !fir.array>>}>>, !fir.array>>}>>, !fir.box>>}>>> +! CHECK: return +! CHECK: } + +! Slice a target array and assign the box to a pointer of rank-1 field. +! RHS is an array section. Hits a TODO. +subroutine s4(x,y) + use array_of_pointer_test + type(ta) :: x(:) + integer, TARGET :: y(:) + + forall (i=1:10) + ! TODO: auto boxing of ranked RHS +! x(i)%ip => y(i:i+1) + end forall +end subroutine s4 + +! Most other Fortran implementations cannot compile the following 2 cases, s5 +! and s5_1. +subroutine s5(x,y,z,n1,n2) + use array_of_pointer_test + type(ta) :: x(:) + type(tb) :: y(:) + type(ta), TARGET :: z(:) + + forall (i=1:10) + ! Convert the rank-1 array to a rank-2 array on assignment + y(i)%ip(1:n1,1:n2) => z(i)%ip + end forall +end subroutine s5 + +! CHECK-LABEL: func @_QPs5( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.box>>}>>> {fir.bindc_name = "x"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.box>>}>>> {fir.bindc_name = "y"}, +! CHECK-SAME: %[[VAL_2:.*]]: !fir.box>>}>>> {fir.bindc_name = "z", fir.target}, +! CHECK-SAME: %[[VAL_3:.*]]: !fir.ref {fir.bindc_name = "n1"}, +! CHECK-SAME: %[[VAL_4:.*]]: !fir.ref {fir.bindc_name = "n2"}) { +! CHECK: %[[VAL_5:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "i"} +! CHECK: %[[VAL_6:.*]] = arith.constant 1 : i32 +! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (i32) -> index +! CHECK: %[[VAL_8:.*]] = arith.constant 10 : i32 +! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_8]] : (i32) -> index +! CHECK: %[[VAL_10:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_11:.*]] = fir.array_load %[[VAL_1]] : (!fir.box>>}>>>) -> !fir.array>>}>> +! CHECK: %[[VAL_12:.*]] = fir.array_load %[[VAL_2]] : (!fir.box>>}>>>) -> !fir.array>>}>> +! CHECK: %[[VAL_13:.*]] = fir.do_loop %[[VAL_14:.*]] = %[[VAL_7]] to %[[VAL_9]] step %[[VAL_10]] unordered iter_args(%[[VAL_15:.*]] = %[[VAL_11]]) -> (!fir.array>>}>>) { +! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_14]] : (index) -> i32 +! CHECK: fir.store %[[VAL_16]] to %[[VAL_5]] : !fir.ref +! CHECK: %[[VAL_17:.*]] = arith.constant 1 : i64 +! CHECK: %[[VAL_18:.*]] = fir.load %[[VAL_3]] : !fir.ref +! CHECK: %[[VAL_19:.*]] = fir.convert %[[VAL_18]] : (i32) -> i64 +! CHECK: %[[VAL_20:.*]] = arith.constant 1 : i64 +! CHECK: %[[VAL_21:.*]] = fir.load %[[VAL_4]] : !fir.ref +! CHECK: %[[VAL_22:.*]] = fir.convert %[[VAL_21]] : (i32) -> i64 +! CHECK: %[[VAL_23:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_24:.*]] = fir.load %[[VAL_5]] : !fir.ref +! CHECK: %[[VAL_25:.*]] = fir.convert %[[VAL_24]] : (i32) -> i64 +! CHECK: %[[VAL_26:.*]] = fir.convert %[[VAL_25]] : (i64) -> index +! CHECK: %[[VAL_27:.*]] = arith.subi %[[VAL_26]], %[[VAL_23]] : index +! CHECK: %[[VAL_28:.*]] = fir.field_index ip, !fir.type<_QMarray_of_pointer_testTta{ip:!fir.box>>}> +! CHECK: %[[VAL_29:.*]] = fir.array_fetch %[[VAL_12]], %[[VAL_27]], %[[VAL_28]] : (!fir.array>>}>>, index, !fir.field) -> !fir.box>> +! CHECK: %[[VAL_30:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_31:.*]] = fir.load %[[VAL_5]] : !fir.ref +! CHECK: %[[VAL_32:.*]] = fir.convert %[[VAL_31]] : (i32) -> i64 +! CHECK: %[[VAL_33:.*]] = fir.convert %[[VAL_32]] : (i64) -> index +! CHECK: %[[VAL_34:.*]] = arith.subi %[[VAL_33]], %[[VAL_30]] : index +! CHECK: %[[VAL_35:.*]] = fir.field_index ip, !fir.type<_QMarray_of_pointer_testTtb{ip:!fir.box>>}> +! CHECK: %[[VAL_36:.*]] = fir.convert %[[VAL_29]] : (!fir.box>>) -> !fir.box>> +! CHECK: %[[VAL_37:.*]] = fir.shape_shift %[[VAL_17]], %[[VAL_19]], %[[VAL_20]], %[[VAL_22]] : (i64, i64, i64, i64) -> !fir.shapeshift<2> +! CHECK: %[[VAL_38:.*]] = fir.rebox %[[VAL_36]](%[[VAL_37]]) : (!fir.box>>, !fir.shapeshift<2>) -> !fir.box>> +! CHECK: %[[VAL_39:.*]] = fir.array_update %[[VAL_15]], %[[VAL_38]], %[[VAL_34]], %[[VAL_35]] : (!fir.array>>}>>, !fir.box>>, index, !fir.field) -> !fir.array>>}>> +! CHECK: fir.result %[[VAL_39]] : !fir.array>>}>> +! CHECK: } +! CHECK: fir.array_merge_store %[[VAL_11]], %[[VAL_40:.*]] to %[[VAL_1]] : !fir.array>>}>>, !fir.array>>}>>, !fir.box>>}>>> +! CHECK: return +! CHECK: } + +! RHS is an array section. Hits a TODO. +subroutine s5_1(x,y,z,n1,n2) + use array_of_pointer_test + type(ta) :: x(:) + type(tb) :: y(:) + type(ta), TARGET :: z(:) + + forall (i=1:10) + ! Slice a rank 1 array and save the slice to the box. +! x(i)%ip => z(i)%ip(1::n1+1) + end forall +end subroutine s5_1 + +subroutine s6(x,y) + use array_of_pointer_test + type(tv) :: x(:) + integer, target :: y(:) + + forall (i=1:10, j=2:20:2) + ! Two box indirections. + x(i)%jp(j)%ip%v = y(i) + end forall +end subroutine s6 + +! CHECK-LABEL: func @_QPs6( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.box>>}>>>>}>>> {fir.bindc_name = "x"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.box> {fir.bindc_name = "y", fir.target}) { +! CHECK: %[[VAL_2:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "j"} +! CHECK: %[[VAL_3:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "i"} +! CHECK: %[[VAL_4:.*]] = arith.constant 1 : i32 +! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (i32) -> index +! CHECK: %[[VAL_6:.*]] = arith.constant 10 : i32 +! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (i32) -> index +! CHECK: %[[VAL_8:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_9:.*]] = arith.constant 2 : i32 +! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_9]] : (i32) -> index +! CHECK: %[[VAL_11:.*]] = arith.constant 20 : i32 +! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (i32) -> index +! CHECK: %[[VAL_13:.*]] = arith.constant 2 : i32 +! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_13]] : (i32) -> index +! CHECK: %[[VAL_15:.*]] = fir.array_load %[[VAL_0]] : (!fir.box>>}>>>>}>>>) -> !fir.array>>}>>>>}>> +! CHECK: %[[VAL_16:.*]] = fir.array_load %[[VAL_1]] : (!fir.box>) -> !fir.array +! CHECK: %[[VAL_17:.*]] = fir.do_loop %[[VAL_18:.*]] = %[[VAL_5]] to %[[VAL_7]] step %[[VAL_8]] unordered iter_args(%[[VAL_19:.*]] = %[[VAL_15]]) -> (!fir.array>>}>>>>}>>) { +! CHECK: %[[VAL_20:.*]] = fir.convert %[[VAL_18]] : (index) -> i32 +! CHECK: fir.store %[[VAL_20]] to %[[VAL_3]] : !fir.ref +! CHECK: %[[VAL_21:.*]] = fir.do_loop %[[VAL_22:.*]] = %[[VAL_10]] to %[[VAL_12]] step %[[VAL_14]] unordered iter_args(%[[VAL_23:.*]] = %[[VAL_19]]) -> (!fir.array>>}>>>>}>>) { +! CHECK: %[[VAL_24:.*]] = fir.convert %[[VAL_22]] : (index) -> i32 +! CHECK: fir.store %[[VAL_24]] to %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_25:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_26:.*]] = fir.load %[[VAL_3]] : !fir.ref +! CHECK: %[[VAL_27:.*]] = fir.convert %[[VAL_26]] : (i32) -> i64 +! CHECK: %[[VAL_28:.*]] = fir.convert %[[VAL_27]] : (i64) -> index +! CHECK: %[[VAL_29:.*]] = arith.subi %[[VAL_28]], %[[VAL_25]] : index +! CHECK: %[[VAL_30:.*]] = fir.array_fetch %[[VAL_16]], %[[VAL_29]] : (!fir.array, index) -> i32 +! CHECK: %[[VAL_31:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_32:.*]] = fir.load %[[VAL_3]] : !fir.ref +! CHECK: %[[VAL_33:.*]] = fir.convert %[[VAL_32]] : (i32) -> i64 +! CHECK: %[[VAL_34:.*]] = fir.convert %[[VAL_33]] : (i64) -> index +! CHECK: %[[VAL_35:.*]] = arith.subi %[[VAL_34]], %[[VAL_31]] : index +! CHECK: %[[VAL_36:.*]] = fir.field_index jp, !fir.type<_QMarray_of_pointer_testTtv{jp:!fir.box>>}>>>>}> +! CHECK: %[[VAL_37:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_38:.*]] = fir.convert %[[VAL_37]] : (i32) -> i64 +! CHECK: %[[VAL_39:.*]] = fir.convert %[[VAL_38]] : (i64) -> index +! CHECK: %[[VAL_40:.*]] = arith.subi %[[VAL_39]], %[[VAL_31]] : index +! CHECK: %[[VAL_41:.*]] = fir.field_index ip, !fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box>>}> +! CHECK: %[[VAL_42:.*]] = fir.field_index v, !fir.type<_QMarray_of_pointer_testTu{v:i32}> +! CHECK: %[[VAL_43:.*]] = fir.array_access %[[VAL_23]], %[[VAL_35]], %[[VAL_36]] : (!fir.array>>}>>>>}>>, index, !fir.field) -> !fir.ref>>}>>>>> +! CHECK: %[[VAL_44:.*]] = fir.load %[[VAL_43]] : !fir.ref>>}>>>>> +! CHECK: %[[VAL_45:.*]] = fir.coordinate_of %[[VAL_44]], %[[VAL_40]] : (!fir.box>>}>>>>, index) -> !fir.ref>>}>> +! CHECK: %[[VAL_46:.*]] = fir.coordinate_of %[[VAL_45]], %[[VAL_41]] : (!fir.ref>>}>>, !fir.field) -> !fir.ref>>> +! CHECK: %[[VAL_47:.*]] = fir.load %[[VAL_46]] : !fir.ref>>> +! CHECK: %[[VAL_48:.*]] = fir.coordinate_of %[[VAL_47]], %[[VAL_42]] : (!fir.box>>, !fir.field) -> !fir.ref +! CHECK: fir.store %[[VAL_30]] to %[[VAL_48]] : !fir.ref +! CHECK: %[[VAL_49:.*]] = fir.array_amend %[[VAL_23]], %[[VAL_43]] : (!fir.array>>}>>>>}>>, !fir.ref>>}>>>>>) -> !fir.array>>}>>>>}>> +! CHECK: fir.result %[[VAL_49]] : !fir.array>>}>>>>}>> +! CHECK: } +! CHECK: fir.result %[[VAL_50:.*]] : !fir.array>>}>>>>}>> +! CHECK: } +! CHECK: fir.array_merge_store %[[VAL_15]], %[[VAL_51:.*]] to %[[VAL_0]] : !fir.array>>}>>>>}>>, !fir.array>>}>>>>}>>, !fir.box>>}>>>>}>>> +! CHECK: return +! CHECK: } + +subroutine s7(x,y,n) + use array_of_pointer_test + type(t) x(:) + integer, TARGET :: y(:) + ! Introduce a crossing dependence + forall (i=1:n) + x(i)%ip => y(x(n+1-i)%ip) + end forall +end subroutine s7 + +! CHECK-LABEL: func @_QPs7( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.box>}>>> {fir.bindc_name = "x"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.box> {fir.bindc_name = "y", fir.target}, +! CHECK-SAME: %[[VAL_2:.*]]: !fir.ref {fir.bindc_name = "n"}) { +! CHECK: %[[VAL_3:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "i"} +! CHECK: %[[VAL_4:.*]] = arith.constant 1 : i32 +! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (i32) -> index +! CHECK: %[[VAL_6:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (i32) -> index +! CHECK: %[[VAL_8:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_9:.*]] = fir.array_load %[[VAL_0]] : (!fir.box>}>>>) -> !fir.array>}>> +! CHECK: %[[VAL_10:.*]] = fir.array_load %[[VAL_1]] : (!fir.box>) -> !fir.array +! CHECK: %[[VAL_11:.*]] = fir.do_loop %[[VAL_12:.*]] = %[[VAL_5]] to %[[VAL_7]] step %[[VAL_8]] unordered iter_args(%[[VAL_13:.*]] = %[[VAL_9]]) -> (!fir.array>}>>) { +! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_12]] : (index) -> i32 +! CHECK: fir.store %[[VAL_14]] to %[[VAL_3]] : !fir.ref +! CHECK: %[[VAL_15:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_16:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_17:.*]] = arith.constant 1 : i32 +! CHECK: %[[VAL_18:.*]] = arith.addi %[[VAL_16]], %[[VAL_17]] : i32 +! CHECK: %[[VAL_19:.*]] = fir.load %[[VAL_3]] : !fir.ref +! CHECK: %[[VAL_20:.*]] = arith.subi %[[VAL_18]], %[[VAL_19]] : i32 +! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_20]] : (i32) -> i64 +! CHECK: %[[VAL_22:.*]] = arith.constant 1 : i64 +! CHECK: %[[VAL_23:.*]] = arith.subi %[[VAL_21]], %[[VAL_22]] : i64 +! CHECK: %[[VAL_24:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_23]] : (!fir.box>}>>>, i64) -> !fir.ref>}>> +! CHECK: %[[VAL_25:.*]] = fir.field_index ip, !fir.type<_QMarray_of_pointer_testTt{ip:!fir.box>}> +! CHECK: %[[VAL_26:.*]] = fir.coordinate_of %[[VAL_24]], %[[VAL_25]] : (!fir.ref>}>>, !fir.field) -> !fir.ref>> +! CHECK: %[[VAL_27:.*]] = fir.load %[[VAL_26]] : !fir.ref>> +! CHECK: %[[VAL_28:.*]] = fir.box_addr %[[VAL_27]] : (!fir.box>) -> !fir.ptr +! CHECK: %[[VAL_29:.*]] = fir.load %[[VAL_28]] : !fir.ptr +! CHECK: %[[VAL_30:.*]] = fir.convert %[[VAL_29]] : (i32) -> i64 +! CHECK: %[[VAL_31:.*]] = fir.convert %[[VAL_30]] : (i64) -> index +! CHECK: %[[VAL_32:.*]] = arith.subi %[[VAL_31]], %[[VAL_15]] : index +! CHECK: %[[VAL_33:.*]] = fir.array_access %[[VAL_10]], %[[VAL_32]] : (!fir.array, index) -> !fir.ref +! CHECK: %[[VAL_34:.*]] = fir.convert %[[VAL_33]] : (!fir.ref) -> !fir.ptr +! CHECK: %[[VAL_35:.*]] = fir.embox %[[VAL_34]] : (!fir.ptr) -> !fir.box> +! CHECK: %[[VAL_36:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_37:.*]] = fir.load %[[VAL_3]] : !fir.ref +! CHECK: %[[VAL_38:.*]] = fir.convert %[[VAL_37]] : (i32) -> i64 +! CHECK: %[[VAL_39:.*]] = fir.convert %[[VAL_38]] : (i64) -> index +! CHECK: %[[VAL_40:.*]] = arith.subi %[[VAL_39]], %[[VAL_36]] : index +! CHECK: %[[VAL_41:.*]] = fir.field_index ip, !fir.type<_QMarray_of_pointer_testTt{ip:!fir.box>}> +! CHECK: %[[VAL_42:.*]] = fir.array_update %[[VAL_13]], %[[VAL_35]], %[[VAL_40]], %[[VAL_41]] : (!fir.array>}>>, !fir.box>, index, !fir.field) -> !fir.array>}>> +! CHECK: fir.result %[[VAL_42]] : !fir.array>}>> +! CHECK: } +! CHECK: fir.array_merge_store %[[VAL_9]], %[[VAL_43:.*]] to %[[VAL_0]] : !fir.array>}>>, !fir.array>}>>, !fir.box>}>>> +! CHECK: return +! CHECK: } + +subroutine s8(x,y,n) + use array_of_pointer_test + type(ta) x(:) + integer, POINTER :: y(:) + forall (i=1:n) + x(i)%ip(i:) => y + end forall +end subroutine s8 + +! CHECK-LABEL: func @_QPs8( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.box>>}>>> {fir.bindc_name = "x"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref>>> {fir.bindc_name = "y"}, +! CHECK-SAME: %[[VAL_2:.*]]: !fir.ref {fir.bindc_name = "n"}) { +! CHECK: %[[VAL_3:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "i"} +! CHECK: %[[VAL_4:.*]] = arith.constant 1 : i32 +! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (i32) -> index +! CHECK: %[[VAL_6:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (i32) -> index +! CHECK: %[[VAL_8:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_9:.*]] = fir.array_load %[[VAL_0]] : (!fir.box>>}>>>) -> !fir.array>>}>> +! CHECK: %[[VAL_10:.*]] = fir.load %[[VAL_1]] : !fir.ref>>> +! CHECK: %[[VAL_11:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_12:.*]]:3 = fir.box_dims %[[VAL_10]], %[[VAL_11]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[VAL_13:.*]] = fir.shift %[[VAL_12]]#0 : (index) -> !fir.shift<1> +! CHECK: %[[VAL_14:.*]] = fir.do_loop %[[VAL_15:.*]] = %[[VAL_5]] to %[[VAL_7]] step %[[VAL_8]] unordered iter_args(%[[VAL_16:.*]] = %[[VAL_9]]) -> (!fir.array>>}>>) { +! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_15]] : (index) -> i32 +! CHECK: fir.store %[[VAL_17]] to %[[VAL_3]] : !fir.ref +! CHECK: %[[VAL_18:.*]] = fir.load %[[VAL_3]] : !fir.ref +! CHECK: %[[VAL_19:.*]] = fir.convert %[[VAL_18]] : (i32) -> i64 +! CHECK: %[[VAL_20:.*]] = fir.rebox %[[VAL_10]](%[[VAL_13]]) : (!fir.box>>, !fir.shift<1>) -> !fir.box>> +! CHECK: %[[VAL_21:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_22:.*]] = fir.load %[[VAL_3]] : !fir.ref +! CHECK: %[[VAL_23:.*]] = fir.convert %[[VAL_22]] : (i32) -> i64 +! CHECK: %[[VAL_24:.*]] = fir.convert %[[VAL_23]] : (i64) -> index +! CHECK: %[[VAL_25:.*]] = arith.subi %[[VAL_24]], %[[VAL_21]] : index +! CHECK: %[[VAL_26:.*]] = fir.field_index ip, !fir.type<_QMarray_of_pointer_testTta{ip:!fir.box>>}> +! CHECK: %[[VAL_27:.*]] = fir.shift %[[VAL_19]] : (i64) -> !fir.shift<1> +! CHECK: %[[VAL_28:.*]] = fir.rebox %[[VAL_20]](%[[VAL_27]]) : (!fir.box>>, !fir.shift<1>) -> !fir.box>> +! CHECK: %[[VAL_29:.*]] = fir.array_update %[[VAL_16]], %[[VAL_28]], %[[VAL_25]], %[[VAL_26]] : (!fir.array>>}>>, !fir.box>>, index, !fir.field) -> !fir.array>>}>> +! CHECK: fir.result %[[VAL_29]] : !fir.array>>}>> +! CHECK: } +! CHECK: fir.array_merge_store %[[VAL_9]], %[[VAL_30:.*]] to %[[VAL_0]] : !fir.array>>}>>, !fir.array>>}>>, !fir.box>>}>>> +! CHECK: return +! CHECK: } + +subroutine s8_1(x,y,n1,n2) + use array_of_pointer_test + type(ta) x(:) + integer, POINTER :: y(:) + forall (i=1:n1) + x(i)%ip(i:n2+1+i) => y + end forall +end subroutine s8_1 + +! CHECK-LABEL: func @_QPs8_1( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.box>>}>>> {fir.bindc_name = "x"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref>>> {fir.bindc_name = "y"}, +! CHECK-SAME: %[[VAL_2:.*]]: !fir.ref {fir.bindc_name = "n1"}, +! CHECK-SAME: %[[VAL_3:.*]]: !fir.ref {fir.bindc_name = "n2"}) { +! CHECK: %[[VAL_4:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "i"} +! CHECK: %[[VAL_5:.*]] = arith.constant 1 : i32 +! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i32) -> index +! CHECK: %[[VAL_7:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (i32) -> index +! CHECK: %[[VAL_9:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_10:.*]] = fir.array_load %[[VAL_0]] : (!fir.box>>}>>>) -> !fir.array>>}>> +! CHECK: %[[VAL_11:.*]] = fir.load %[[VAL_1]] : !fir.ref>>> +! CHECK: %[[VAL_12:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_13:.*]]:3 = fir.box_dims %[[VAL_11]], %[[VAL_12]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[VAL_14:.*]] = fir.shift %[[VAL_13]]#0 : (index) -> !fir.shift<1> +! CHECK: %[[VAL_15:.*]] = fir.do_loop %[[VAL_16:.*]] = %[[VAL_6]] to %[[VAL_8]] step %[[VAL_9]] unordered iter_args(%[[VAL_17:.*]] = %[[VAL_10]]) -> (!fir.array>>}>>) { +! CHECK: %[[VAL_18:.*]] = fir.convert %[[VAL_16]] : (index) -> i32 +! CHECK: fir.store %[[VAL_18]] to %[[VAL_4]] : !fir.ref +! CHECK: %[[VAL_19:.*]] = fir.load %[[VAL_4]] : !fir.ref +! CHECK: %[[VAL_20:.*]] = fir.convert %[[VAL_19]] : (i32) -> i64 +! CHECK: %[[VAL_21:.*]] = fir.load %[[VAL_3]] : !fir.ref +! CHECK: %[[VAL_22:.*]] = arith.constant 1 : i32 +! CHECK: %[[VAL_23:.*]] = arith.addi %[[VAL_21]], %[[VAL_22]] : i32 +! CHECK: %[[VAL_24:.*]] = fir.load %[[VAL_4]] : !fir.ref +! CHECK: %[[VAL_25:.*]] = arith.addi %[[VAL_23]], %[[VAL_24]] : i32 +! CHECK: %[[VAL_26:.*]] = fir.convert %[[VAL_25]] : (i32) -> i64 +! CHECK: %[[VAL_27:.*]] = fir.rebox %[[VAL_11]](%[[VAL_14]]) : (!fir.box>>, !fir.shift<1>) -> !fir.box>> +! CHECK: %[[VAL_28:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_29:.*]] = fir.load %[[VAL_4]] : !fir.ref +! CHECK: %[[VAL_30:.*]] = fir.convert %[[VAL_29]] : (i32) -> i64 +! CHECK: %[[VAL_31:.*]] = fir.convert %[[VAL_30]] : (i64) -> index +! CHECK: %[[VAL_32:.*]] = arith.subi %[[VAL_31]], %[[VAL_28]] : index +! CHECK: %[[VAL_33:.*]] = fir.field_index ip, !fir.type<_QMarray_of_pointer_testTta{ip:!fir.box>>}> +! CHECK: %[[VAL_34:.*]] = fir.shape_shift %[[VAL_20]], %[[VAL_26]] : (i64, i64) -> !fir.shapeshift<1> +! CHECK: %[[VAL_35:.*]] = fir.rebox %[[VAL_27]](%[[VAL_34]]) : (!fir.box>>, !fir.shapeshift<1>) -> !fir.box>> +! CHECK: %[[VAL_36:.*]] = fir.array_update %[[VAL_17]], %[[VAL_35]], %[[VAL_32]], %[[VAL_33]] : (!fir.array>>}>>, !fir.box>>, index, !fir.field) -> !fir.array>>}>> +! CHECK: fir.result %[[VAL_36]] : !fir.array>>}>> +! CHECK: } +! CHECK: fir.array_merge_store %[[VAL_10]], %[[VAL_37:.*]] to %[[VAL_0]] : !fir.array>>}>>, !fir.array>>}>>, !fir.box>>}>>> +! CHECK: return +! CHECK: } + +subroutine s8_2(x,y,n) + use array_of_pointer_test + type(ta) x(:) + integer, TARGET :: y(:) + forall (i=1:n) +! x(i)%ip(i:) => y + end forall +end subroutine s8_2 + +subroutine s8_3(x,y,n1,n2) + use array_of_pointer_test + type(ta) x(:) + integer, TARGET :: y(:) + forall (i=1:n1) +! x(i)%ip(i:n2+1+i) => y + end forall +end subroutine s8_3 + +subroutine s8_4(x,y,n) + use array_of_pointer_test + type(ta) x(:) + integer, ALLOCATABLE, TARGET :: y(:) + forall (i=1:n) +! x(i)%ip(i:) => y + end forall +end subroutine s8_4 + +subroutine s8_5(x,y,n1,n2) + use array_of_pointer_test + type(ta) x(:) + integer, ALLOCATABLE, TARGET :: y(:) + forall (i=1:n1) +! x(i)%ip(i:n2+1+i) => y + end forall +end subroutine s8_5 diff --git a/flang/test/Lower/forall/forall-2.f90 b/flang/test/Lower/forall/forall-2.f90 --- a/flang/test/Lower/forall/forall-2.f90 +++ b/flang/test/Lower/forall/forall-2.f90 @@ -1,7 +1,11 @@ ! RUN: bbc -emit-fir %s -o - | FileCheck %s +! RUN: bbc %s -o - | FileCheck --check-prefix=POSTOPT %s ! CHECK-LABEL: func @_QPimplied_iters_allocatable( ! CHECK-SAME: %[[VAL_0:.*]]: !fir.box,arr:!fir.box>>}>>>{{.*}}, %[[VAL_1:.*]]: !fir.box>{{.*}}) { +! CHECK: return +! CHECK: } + subroutine implied_iters_allocatable(thing, a1) ! No dependence between lhs and rhs. ! Lhs may need to be reallocated to conform. @@ -14,17 +18,13 @@ integer :: i forall (i=5:13) - ! commenting out this test for the moment + ! commenting out this test for the moment (hits assert) ! thing(i)%arr = a1 end forall - ! CHECK: return - ! CHECK: } end subroutine implied_iters_allocatable -! CHECK-LABEL: func @_QPconflicting_allocatable( -! CHECK-SAME: %[[VAL_0:.*]]: !fir.box,arr:!fir.box>>}>>>{{.*}}, %[[VAL_1:.*]]: !fir.ref{{.*}}, %[[VAL_2:.*]]: !fir.ref{{.*}}) { subroutine conflicting_allocatable(thing, lo, hi) - ! Introduce a crossing dependence to incite a (deep) copy. + ! Introduce a crossing dependence to produce copy-in/copy-out code. integer :: lo,hi type t logical :: oui @@ -34,34 +34,68 @@ integer :: i forall (i = lo:hi) - ! commenting out this test for the moment + ! commenting out this test for the moment (hits assert) ! thing(i)%arr = thing(hi-i)%arr end forall - ! CHECK: return - ! CHECK: } end subroutine conflicting_allocatable ! CHECK-LABEL: func @_QPforall_pointer_assign( -! CHECK-SAME: %[[VAL_0:.*]]: !fir.box>>}>>>{{.*}}, %[[VAL_1:.*]]: !fir.box}>>> {fir.bindc_name = "at", fir.target}, %[[VAL_2:.*]]: !fir.ref{{.*}}, %[[VAL_3:.*]]: !fir.ref{{.*}}) { +! CHECK-SAME: %[[VAL_0:.*]]: !fir.box>>}>>> {fir.bindc_name = "ap"}, %[[VAL_1:.*]]: !fir.ref {fir.bindc_name = "at"}, %[[VAL_2:.*]]: !fir.ref {fir.bindc_name = "ii"}, %[[VAL_3:.*]]: !fir.ref {fir.bindc_name = "ij"}) { +! CHECK: %[[VAL_4:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "i"} +! CHECK: %[[VAL_5:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i32) -> index +! CHECK: %[[VAL_7:.*]] = fir.load %[[VAL_3]] : !fir.ref +! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (i32) -> index +! CHECK: %[[VAL_9:.*]] = arith.constant 8 : i32 +! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_9]] : (i32) -> index +! CHECK: %[[VAL_11:.*]] = fir.array_load %[[VAL_0]] : (!fir.box>>}>>>) -> !fir.array>>}>> +! CHECK: %[[VAL_12:.*]] = fir.array_load %[[VAL_0]] : (!fir.box>>}>>>) -> !fir.array>>}>> +! CHECK: %[[VAL_13:.*]] = fir.do_loop %[[VAL_14:.*]] = %[[VAL_6]] to %[[VAL_8]] step %[[VAL_10]] unordered iter_args(%[[VAL_15:.*]] = %[[VAL_11]]) -> (!fir.array>>}>>) { +! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_14]] : (index) -> i32 +! CHECK: fir.store %[[VAL_16]] to %[[VAL_4]] : !fir.ref +! CHECK-DAG: %[[VAL_17:.*]] = arith.constant 1 : index +! CHECK-DAG: %[[VAL_18:.*]] = arith.constant 1 : i32 +! CHECK-DAG: %[[VAL_19:.*]] = fir.load %[[VAL_4]] : !fir.ref +! CHECK: %[[VAL_20:.*]] = arith.subi %[[VAL_19]], %[[VAL_18]] : i32 +! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_20]] : (i32) -> i64 +! CHECK: %[[VAL_22:.*]] = fir.convert %[[VAL_21]] : (i64) -> index +! CHECK: %[[VAL_23:.*]] = arith.subi %[[VAL_22]], %[[VAL_17]] : index +! CHECK: %[[VAL_24:.*]] = fir.field_index ptr, !fir.type<_QFforall_pointer_assignTt{ptr:!fir.box>>}> +! CHECK: %[[VAL_25:.*]] = fir.array_fetch %[[VAL_12]], %[[VAL_23]], %[[VAL_24]] : (!fir.array>>}>>, index, !fir.field) -> !fir.box>> +! CHECK: %[[VAL_26:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_27:.*]] = fir.load %[[VAL_4]] : !fir.ref +! CHECK: %[[VAL_28:.*]] = fir.convert %[[VAL_27]] : (i32) -> i64 +! CHECK: %[[VAL_29:.*]] = fir.convert %[[VAL_28]] : (i64) -> index +! CHECK: %[[VAL_30:.*]] = arith.subi %[[VAL_29]], %[[VAL_26]] : index +! CHECK: %[[VAL_31:.*]] = fir.field_index ptr, !fir.type<_QFforall_pointer_assignTt{ptr:!fir.box>>}> +! CHECK: %[[VAL_32:.*]] = fir.array_update %[[VAL_15]], %[[VAL_25]], %[[VAL_30]], %[[VAL_31]] : (!fir.array>>}>>, !fir.box>>, index, !fir.field) -> !fir.array>>}>> +! CHECK: fir.result %[[VAL_32]] : !fir.array>>}>> +! CHECK: } +! CHECK: fir.array_merge_store %[[VAL_11]], %[[VAL_33:.*]] to %[[VAL_0]] : !fir.array>>}>>, !fir.array>>}>>, !fir.box>>}>>> +! CHECK: return +! CHECK: } + +! POSTOPT-LABEL: func @_QPforall_pointer_assign( +! POSTOPT: %[[VAL_15:.*]] = fir.allocmem !fir.array>>}>>, %{{.*}}#1 +! POSTOPT: ^bb{{[0-9]+}}(%[[VAL_16:.*]]: index, %[[VAL_17:.*]]: index): +! POSTOPT: ^bb{{[0-9]+}}(%[[VAL_30:.*]]: index, %[[VAL_31:.*]]: index): +! POSTOPT: ^bb{{[0-9]+}}(%[[VAL_46:.*]]: index, %[[VAL_47:.*]]: index): +! POSTOPT-NOT: ^bb{{[0-9]+}}(%{{.*}}: index, %{{.*}}: index): +! POSTOPT: fir.freemem %[[VAL_15]] : !fir.heap>>}>>> +! POSTOPT: } + subroutine forall_pointer_assign(ap, at, ii, ij) - ! Set pointer members in an array of derived type to targets. - ! No conflicts (multiple-assignment being forbidden, of course). + ! Set pointer members in an array of derived type of pointers to arrays. + ! Introduce a loop carried dependence to produce copy-in/copy-out code. type t real, pointer :: ptr(:) end type t - type u - real :: targ(20) - end type u type(t) :: ap(:) - type(u), target :: at(:) integer :: ii, ij forall (i = ii:ij:8) - ! commenting out this test for the moment - ! ap(i)%ptr => at(i-4)%targ + ap(i)%ptr => ap(i-1)%ptr end forall - ! CHECK: return - ! CHECK: } end subroutine forall_pointer_assign ! CHECK-LABEL: func @_QPslice_with_explicit_iters() { diff --git a/flang/unittests/Optimizer/Builder/FIRBuilderTest.cpp b/flang/unittests/Optimizer/Builder/FIRBuilderTest.cpp --- a/flang/unittests/Optimizer/Builder/FIRBuilderTest.cpp +++ b/flang/unittests/Optimizer/Builder/FIRBuilderTest.cpp @@ -404,7 +404,7 @@ auto loc = builder.getUnknownLoc(); llvm::StringRef strValue("length"); auto strLit = fir::factory::createStringLiteral(builder, loc, strValue); - auto ext = fir::factory::getExtents(builder, loc, strLit); + auto ext = fir::factory::getExtents(loc, builder, strLit); EXPECT_EQ(0u, ext.size()); auto c10 = builder.createIntegerConstant(loc, builder.getI64Type(), 10); auto c100 = builder.createIntegerConstant(loc, builder.getI64Type(), 100); @@ -414,7 +414,7 @@ mlir::Value array = builder.create(loc, arrayTy); fir::ArrayBoxValue aab(array, extents, {}); fir::ExtendedValue ex(aab); - auto readExtents = fir::factory::getExtents(builder, loc, ex); + auto readExtents = fir::factory::getExtents(loc, builder, ex); EXPECT_EQ(2u, readExtents.size()); } @@ -497,12 +497,12 @@ for (const auto &scalar : f32Scalars) { EXPECT_EQ(fir::getBaseTypeOf(scalar), f32Ty); EXPECT_EQ(fir::getElementTypeOf(scalar), f32Ty); - EXPECT_FALSE(fir::isDerivedWithLengthParameters(scalar)); + EXPECT_FALSE(fir::isDerivedWithLenParameters(scalar)); } for (const auto &array : f32Arrays) { EXPECT_EQ(fir::getBaseTypeOf(array), f32SeqTy); EXPECT_EQ(fir::getElementTypeOf(array), f32Ty); - EXPECT_FALSE(fir::isDerivedWithLengthParameters(array)); + EXPECT_FALSE(fir::isDerivedWithLenParameters(array)); } auto derivedWithLengthTy = @@ -520,11 +520,11 @@ for (const auto &scalar : derivedWithLengthScalars) { EXPECT_EQ(fir::getBaseTypeOf(scalar), derivedWithLengthTy); EXPECT_EQ(fir::getElementTypeOf(scalar), derivedWithLengthTy); - EXPECT_TRUE(fir::isDerivedWithLengthParameters(scalar)); + EXPECT_TRUE(fir::isDerivedWithLenParameters(scalar)); } for (const auto &array : derivedWithLengthArrays) { EXPECT_EQ(fir::getBaseTypeOf(array), derivedWithLengthSeqTy); EXPECT_EQ(fir::getElementTypeOf(array), derivedWithLengthTy); - EXPECT_TRUE(fir::isDerivedWithLengthParameters(array)); + EXPECT_TRUE(fir::isDerivedWithLenParameters(array)); } }