Magic-Mirror/llvm-capstone
1
0
Fork 0
mirror of https://github.com/capstone-engine/llvm-capstone.git synced 2025-01-27 03:48:33 +00:00
Code Issues Actions 3 Packages Projects Releases Wiki Activity

Upstream support for POINTER assignment in FORALL.

Browse Source 
Reviewed By: vdonaldson, PeteSteinfeld

Differential Revision: https://reviews.llvm.org/D125140
This commit is contained in:
Eric Schweitz 2022-04-22 13:59:17 -07:00
parent 102bc634cb
commit 1bffc75383
22 changed files with 2005 additions and 481 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
flang/include/flang/Lower/AbstractConverter.h
View File

@ -103,37 +103,51 @@ public:
// 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.

63
flang/include/flang/Lower/Allocatable.h
View File

@ -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 @@ class Location;
} // 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 <typename T>
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<Fortran::evaluate::SomeType> &source,
mlir::ValueRange lbounds, Fortran::lower::StatementContext &);
/// 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);
} // namespace Fortran::lower
/// 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

21
flang/include/flang/Lower/ComponentPath.h
View File

@ -27,8 +27,7 @@ class ImplicitSubscripts {};
using PathComponent =
std::variant<const evaluate::ArrayRef *, const evaluate::Component *,
const Fortran::evaluate::ComplexPart *,
details::ImplicitSubscripts>;
const evaluate::ComplexPart *, details::ImplicitSubscripts>;
/// Collection of components.
///
@ -37,6 +36,8 @@ using PathComponent =
/// arguments.
class ComponentPath {
public:
using ExtendRefFunc = std::function<mlir::Value(const mlir::Value &)>;
ComponentPath(bool isImplicit) { setPC(isImplicit); }
ComponentPath(bool isImplicit, const evaluate::Substring *ss)
: substring(ss) {
@ -44,10 +45,15 @@ public:
}
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<PathComponent> reversePath;
const evaluate::Substring *substring = nullptr;
bool applied = false;
@ -57,6 +63,13 @@ public:
llvm::SmallVector<mlir::Value> suffixComponents;
std::function<IterationSpace(const IterationSpace &)> 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<ExtendRefFunc> extendCoorRef = llvm::None;
private:
void setPC(bool isImplicit);
};

27
flang/include/flang/Lower/ConvertExpr.h
View File

@ -164,22 +164,6 @@ void createAnyMaskedArrayAssignment(AbstractConverter &converter,
ImplicitIterSpace &implicitIterSpace,
SymMap &symMap, StatementContext &stmtCtx);
/// In the context of a FORALL, a pointer assignment is allowed. The pointer
/// assignment can be elementwise on an array of pointers. The bounds
/// expressions as well as the component path may contain references to the
/// concurrent control variables. The explicit iteration space must be defined.
void createAnyArrayPointerAssignment(
AbstractConverter &converter, const SomeExpr &lhs, const SomeExpr &rhs,
const evaluate::Assignment::BoundsSpec &bounds,
ExplicitIterSpace &explicitIterSpace, ImplicitIterSpace &implicitIterSpace,
SymMap &symMap);
/// Support the bounds remapping flavor of pointer assignment.
void createAnyArrayPointerAssignment(
AbstractConverter &converter, const SomeExpr &lhs, const SomeExpr &rhs,
const evaluate::Assignment::BoundsRemapping &bounds,
ExplicitIterSpace &explicitIterSpace, ImplicitIterSpace &implicitIterSpace,
SymMap &symMap);
/// Lower an assignment to an allocatable array, allocating the array if
/// it is not allocated yet or reallocation it if it does not conform
/// with the right hand side.
@ -190,6 +174,17 @@ void createAllocatableArrayAssignment(AbstractConverter &converter,
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<!fir.ptr<T>> ...>`. 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<mlir::Value> &lbounds,
llvm::Optional<llvm::SmallVector<mlir::Value>> 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,

13
flang/include/flang/Lower/Support/Utils.h
View File

@ -79,4 +79,17 @@ ignoreEvConvert(const Fortran::evaluate::Expr<Fortran::evaluate::Type<
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 <typename A>
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

91
flang/include/flang/Optimizer/Builder/BoxValue.h
View File

@ -25,8 +25,8 @@
namespace fir {
class FirOpBuilder;
class ArrayLoadOp;
class CharBoxValue;
class ArrayBoxValue;
class BoxValue;
class CharBoxValue;
@ -61,9 +61,9 @@ public:
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 @@ public:
return seqTy.getDimension();
return 0;
}
/// Is this a character entity ?
bool isCharacter() const { return fir::isa_char(getEleTy()); };
/// Is this a derived type entity ?
bool isDerived() const { return getEleTy().isa<fir::RecordType>(); };
bool isDerivedWithLengthParameters() const {
auto record = getEleTy().dyn_cast<fir::RecordType>();
return record && record.getNumLenParams() != 0;
};
/// Is this a character entity ?
bool isCharacter() const { return fir::isa_char(getEleTy()); }
/// Is this a derived type entity ?
bool isDerived() const { return getEleTy().isa<fir::RecordType>(); }
bool isDerivedWithLenParameters() const {
return fir::isRecordWithTypeParameters(getEleTy());
}
/// Is this a CLASS(*)/TYPE(*) ?
bool isUnlimitedPolymorphic() const {
return getEleTy().isa<mlir::NoneType>();
return fir::isUnlimitedPolymorphicType(getBaseTy());
}
};
@ -259,7 +261,7 @@ public:
/// 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 @@ public:
// 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 @@ protected:
// 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<mlir::Value, 2> explicitParams;
};
@ -318,7 +320,7 @@ public:
mlir::Value addr;
llvm::SmallVector<mlir::Value, 2> extents;
llvm::SmallVector<mlir::Value, 2> 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 @@ public:
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 @@ public:
mutableProperties{mutableProperties} {
// Currently only accepts fir.(ref/ptr/heap)<fir.box<type>> mlir::Value for
// the address. This may change if we accept
// fir.(ref/ptr/heap)<fir.heap<type>> for scalar without length parameters.
// fir.(ref/ptr/heap)<fir.heap<type>> for scalar without LEN parameters.
assert(verify() &&
"MutableBoxValue requires mem ref to fir.box<fir.[heap|ptr]<type>>");
}
@ -359,9 +361,9 @@ public:
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<mlir::Value> nonDeferredLenParams() const { return lenParams; }
friend llvm::raw_ostream &operator<<(llvm::raw_ostream &,
const MutableBoxValue &);
@ -378,8 +380,8 @@ public:
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<mlir::Value, 2> lenParams;
/// Set of variables holding the extents, lower bounds and
@ -411,14 +413,36 @@ bool isArray(const ExtendedValue &exv);
/// Get the type parameters for `exv`.
llvm::SmallVector<mlir::Value> 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<mlir::Value> 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<mlir::Value>
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<mlir::Value>
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 @@ inline mlir::Type getElementTypeOf(const ExtendedValue &exv) {
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<fir::RecordType>();
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

10
flang/include/flang/Optimizer/Builder/FIRBuilder.h
View File

@ -426,12 +426,6 @@ llvm::SmallVector<mlir::Value> readExtents(fir::FirOpBuilder &builder,
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<mlir::Value> 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 @@ llvm::SmallVector<mlir::Value> getExtents(fir::FirOpBuilder &builder,
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<mlir::Value>
getNonDefaultLowerBounds(fir::FirOpBuilder &builder, mlir::Location loc,
const fir::ExtendedValue &exv);

16
flang/include/flang/Optimizer/Builder/Factory.h
View File

@ -144,26 +144,30 @@ void genCharacterCopy(mlir::Value src, mlir::Value srcLen, mlir::Value dst,
/// Get extents from fir.shape/fir.shape_shift op. Empty result if
/// \p shapeVal is empty or is a fir.shift.
inline std::vector<mlir::Value> getExtents(mlir::Value shapeVal) {
inline llvm::SmallVector<mlir::Value> getExtents(mlir::Value shapeVal) {
if (shapeVal)
if (auto *shapeOp = shapeVal.getDefiningOp()) {
if (auto shOp = mlir::dyn_cast<fir::ShapeOp>(shapeOp)) {
auto operands = shOp.getExtents();
return {operands.begin(), operands.end()};
}
if (auto shOp = mlir::dyn_cast<fir::ShapeShiftOp>(shapeOp))
return shOp.getExtents();
if (auto shOp = mlir::dyn_cast<fir::ShapeShiftOp>(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<mlir::Value> getOrigins(mlir::Value shapeVal) {
inline llvm::SmallVector<mlir::Value> getOrigins(mlir::Value shapeVal) {
if (shapeVal)
if (auto *shapeOp = shapeVal.getDefiningOp()) {
if (auto shOp = mlir::dyn_cast<fir::ShapeShiftOp>(shapeOp))
return shOp.getOrigins();
if (auto shOp = mlir::dyn_cast<fir::ShapeShiftOp>(shapeOp)) {
auto operands = shOp.getOrigins();
return {operands.begin(), operands.end()};
}
if (auto shOp = mlir::dyn_cast<fir::ShiftOp>(shapeOp)) {
auto operands = shOp.getOrigins();
return {operands.begin(), operands.end()};

33
flang/include/flang/Optimizer/Dialect/FIRType.h
View File

@ -65,15 +65,14 @@ inline bool isa_ref_type(mlir::Type t) {
/// Is `t` a boxed type?
inline bool isa_box_type(mlir::Type t) {
return t.isa<BoxType>() || t.isa<BoxCharType>() || t.isa<BoxProcType>();
return t.isa<fir::BoxType, fir::BoxCharType, fir::BoxProcType>();
}
/// 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<ReferenceType>() || isa_box_type(t) ||
t.isa<mlir::FunctionType>();
return t.isa<fir::ReferenceType, mlir::FunctionType>() || isa_box_type(t);
}
/// Is `t` a type that can conform to be pass-by-reference? Depending on the
@ -88,8 +87,7 @@ inline bool isa_derived(mlir::Type t) { return t.isa<fir::RecordType>(); }
/// Is `t` a FIR dialect aggregate type?
inline bool isa_aggregate(mlir::Type t) {
return t.isa<SequenceType>() || fir::isa_derived(t) ||
t.isa<mlir::TupleType>();
return t.isa<SequenceType, mlir::TupleType>() || fir::isa_derived(t);
}
/// Extract the `Type` pointed to from a FIR memory reference type. If `t` is
@ -102,13 +100,12 @@ mlir::Type dyn_cast_ptrOrBoxEleTy(mlir::Type t);
/// Is `t` a FIR Real or MLIR Float type?
inline bool isa_real(mlir::Type t) {
return t.isa<fir::RealType>() || t.isa<mlir::FloatType>();
return t.isa<fir::RealType, mlir::FloatType>();
}
/// Is `t` an integral type?
inline bool isa_integer(mlir::Type t) {
return t.isa<mlir::IndexType>() || t.isa<mlir::IntegerType>() ||
t.isa<fir::IntegerType>();
return t.isa<mlir::IndexType, mlir::IntegerType, fir::IntegerType>();
}
mlir::Type parseFirType(FIROpsDialect *, mlir::DialectAsmParser &parser);
@ -121,7 +118,7 @@ void verifyIntegralType(mlir::Type type);
/// Is `t` a FIR or MLIR Complex type?
inline bool isa_complex(mlir::Type t) {
return t.isa<fir::ComplexType>() || t.isa<mlir::ComplexType>();
return t.isa<fir::ComplexType, mlir::ComplexType>();
}
/// Is `t` a CHARACTER type? Does not check the length.
@ -193,6 +190,20 @@ inline mlir::Type unwrapPassByRefType(mlir::Type t) {
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<!fir.ptr<!fir.array<...xT>>> -> 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 @@ bool isPointerType(mlir::Type ty);
/// 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);

2
flang/include/flang/Runtime/io-api.h
View File

@ -248,9 +248,7 @@ bool IONAME(OutputInteger8)(Cookie, std::int8_t);
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 &);

51
flang/lib/Lower/Allocatable.cpp
View File

@ -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 @@ struct ErrorManager {
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<fir::AbsentOp>(
loc,
fir::BoxType::get(mlir::NoneType::get(builder.getContext())));
@ -343,7 +344,7 @@ private:
if (const std::optional<Fortran::parser::BoundExpr> &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 @@ private:
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<mlir::arith::SubIOp>(loc, ub, lb);
@ -404,11 +405,11 @@ private:
if (const std::optional<Fortran::parser::BoundExpr> &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 @@ private:
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 @@ static void genDeallocate(fir::FirOpBuilder &builder, mlir::Location loc,
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<std::list<Fortran::parser::StatOrErrmsg>>(stmt.t))
std::visit(Fortran::common::visitors{
@ -671,8 +672,8 @@ fir::MutableBoxValue Fortran::lower::createMutableBox(
// 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 @@ void Fortran::lower::associateMutableBox(
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;
}

119
flang/lib/Lower/Bridge.cpp
View File

@ -373,16 +373,12 @@ public:
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 @@ public:
// Create a contiguous temp with the same shape and length as
// the original variable described by a fir.box.
llvm::SmallVector<mlir::Value> 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 @@ public:
},
[&](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 @@ private:
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 @@ private:
/// 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<llvm::SmallVector<mlir::Value>> lbounds = llvm::None,
llvm::Optional<llvm::SmallVector<mlir::Value>> 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 @@ private:
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 @@ private:
: implicitIterSpace.stmtContext());
}
static bool
isArraySectionWithoutVectorSubscript(const Fortran::lower::SomeExpr &expr) {
return expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) &&
!Fortran::evaluate::UnwrapWholeSymbolDataRef(expr) &&
!Fortran::evaluate::HasVectorSubscript(expr);
}
#if !defined(NDEBUG)
static bool isFuncResultDesignator(const Fortran::lower::SomeExpr &expr) {
const Fortran::semantics::Symbol *sym =
@ -1900,10 +1907,10 @@ private:
}
#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 @@ private:
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 @@ private:
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<fir::factory::MutableBoxReallocation> lhsRealloc;
llvm::Optional<fir::MutableBoxValue> lhsMutableBox;
auto lhs = [&]() -> fir::ExtendedValue {
@ -1959,7 +1968,7 @@ private:
llvm::SmallVector<mlir::Value> 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 @@ private:
// [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<Fortran::evaluate::DynamicType> lhsType =
assign.lhs.GetType();
@ -2034,23 +2043,19 @@ private:
(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<mlir::Value> lbounds;
for (const Fortran::evaluate::ExtentExpr &lbExpr : lbExprs)
lbounds.push_back(
fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx)));
if (explicitIterationSpace()) {
// 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);
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<fir::ResultOp>(loc, inners);
}
}
},
// [4] Pointer assignment with bounds-remapping. R1036: a
@ -2066,14 +2071,6 @@ private:
(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<Fortran::evaluate::NullPointer>(
assign.rhs)) {
fir::factory::disassociateMutableBox(*builder, loc, lhs);
return;
}
llvm::SmallVector<mlir::Value> lbounds;
llvm::SmallVector<mlir::Value> ubounds;
for (const std::pair<Fortran::evaluate::ExtentExpr,
@ -2086,9 +2083,22 @@ private:
ubounds.push_back(
fir::getBase(genExprValue(toEvExpr(ubExpr), stmtCtx)));
}
if (explicitIterationSpace()) {
// Pointer assignment in FORALL context. Copy the rhs box value
// into the lhs box variable.
genArrayAssignment(assign, stmtCtx, lbounds, ubounds);
return;
}
fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs);
if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
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 @@ private:
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<fir::ResultOp>(loc, inners);
}
}
},
},
@ -2349,7 +2356,7 @@ private:
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.

9
flang/lib/Lower/ComponentPath.cpp
View File

@ -48,6 +48,15 @@ bool Fortran::lower::isRankedArrayAccess(const Fortran::evaluate::ArrayRef &x) {
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; };
}

582
flang/lib/Lower/ConvertExpr.cpp
View File

@ -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 @@ arrayLoadExtValue(fir::FirOpBuilder &builder, mlir::Location loc,
fir::ArrayLoadOp load, llvm::ArrayRef<mlir::Value> 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 @@ arrayLoadExtValue(fir::FirOpBuilder &builder, mlir::Location loc,
arrTy = ty.cast<fir::SequenceType>();
}
auto arrayToExtendedValue =
[&](const llvm::SmallVector<mlir::Value> &extents,
const llvm::SmallVector<mlir::Value> &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<fir::ShiftOp>(shapeVal.getDefiningOp())) {
mlir::Type eleTy = fir::unwrapSequenceType(arrTy);
std::vector<mlir::Value> extents = fir::factory::getExtents(shapeVal);
std::vector<mlir::Value> 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<fir::ReboxOp>(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 @@ createInMemoryScalarCopy(fir::FirOpBuilder &builder, mlir::Location loc,
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 @@ public:
assert(type && "expected descriptor or memory type");
mlir::Location loc = getLoc();
llvm::SmallVector<mlir::Value> extents =
fir::factory::getExtents(builder, loc, mold);
fir::factory::getExtents(loc, builder, mold);
llvm::SmallVector<mlir::Value> allocMemTypeParams =
fir::getTypeParams(mold);
mlir::Value charLen;
@ -2605,7 +2624,7 @@ public:
[&](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 @@ public:
.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<ExtValue, mlir::Value>
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<fir::IsPresentOp>(
loc, builder.getI1Type(), actualArgBase);
if (!actualArgBase.getType().isa<fir::BoxType>())
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<mlir::arith::SelectOp>(loc, isPresent, len, zero);
mlir::Value temp = builder.createTemporary(
loc, type, /*name=*/{}, /*shape=*/{}, mlir::ValueRange{len},
llvm::ArrayRef<mlir::NamedAttribute>{
Fortran::lower::getAdaptToByRefAttr(builder)});
return fir::CharBoxValue{temp, len};
}
assert((fir::isa_trivial(type) || type.isa<fir::RecordType>()) &&
"must be simple scalar");
return builder.createTemporary(
loc, type,
llvm::ArrayRef<mlir::NamedAttribute>{
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 &copyOutPairs, 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<fir::ResultOp>(loc, fir::getBase(temp));
})
.genElse([&]() {
mlir::Value absent =
builder.create<fir::AbsentOp>(loc, tempAddrTy);
builder.create<fir::ResultOp>(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<mlir::Type> resultType) {
@ -2792,8 +2972,7 @@ public:
/*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 @@ public:
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 @@ public:
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<mlir::Value> &lbounds,
llvm::Optional<llvm::SmallVector<mlir::Value>> 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<mlir::Value> &lbounds,
llvm::Optional<llvm::SmallVector<mlir::Value>> 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 @@ public:
// 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 @@ public:
// 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 @@ public:
Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(rhs)) {
assert(arrayOperands.size() == 1 &&
"lbounds can only come from one array");
std::vector<mlir::Value> 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 @@ public:
}
ExtValue lowerBoxedArrayExpr(const Fortran::lower::SomeExpr &exp) {
PushSemantics(ConstituentSemantics::BoxValue);
return std::visit(
[&](const auto &e) {
auto f = genarr(e);
@ -3703,12 +3926,12 @@ public:
builder.restoreInsertionPoint(insPt);
}
template <typename A, typename B>
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 @@ public:
explicitSpace->setInnerArg(offset, fir::getBase(lexv));
builder.create<fir::ResultOp>(getLoc(), fir::getBase(lexv));
};
if (auto updateOp = mlir::dyn_cast<fir::ArrayUpdateOp>(
fir::getBase(lexv).getDefiningOp()))
createResult(updateOp);
else if (auto amend = mlir::dyn_cast<fir::ArrayAmendOp>(
fir::getBase(lexv).getDefiningOp()))
createResult(amend);
else if (auto modifyOp = mlir::dyn_cast<fir::ArrayModifyOp>(
fir::getBase(lexv).getDefiningOp()))
createResult(modifyOp);
llvm::TypeSwitch<mlir::Operation *, void>(
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 @@ public:
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 @@ private:
mlir::Location loc = getLoc();
mlir::IndexType idxTy = builder.getIndexType();
llvm::SmallVector<mlir::Value> 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 @@ private:
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<fir::ShiftOp>(loc, shiftTy, lbs);
val = builder.create<fir::ReboxOp>(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<fir::ShapeShiftOp>(loc, shapeTy, shapeShiftArgs);
val = builder.create<fir::ReboxOp>(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 @@ private:
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<fir::ArrayUpdateOp>(
loc, arrTy, innerArg, ele, iterSpace.iterVec(),
destination.getTypeparams());
@ -4014,9 +4264,7 @@ private:
if (array.memref.getType().isa<fir::BoxType>())
return fir::factory::readExtents(builder, getLoc(),
fir::BoxValue{array.memref});
std::vector<mlir::Value, std::allocator<mlir::Value>> 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 @@ private:
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<IterationSpace, mlir::OpBuilder::InsertPoint>
genIterSpace(mlir::Type resultType) {
mlir::Location loc = getLoc();
@ -4429,7 +4677,9 @@ private:
/// conflicts even when the result is a scalar element.
template <typename A>
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 @@ private:
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 @@ private:
x);
}
void extendComponent(Fortran::lower::ComponentPath &component,
mlir::Type coorTy, mlir::ValueRange vals) {
auto *bldr = &converter.getFirOpBuilder();
llvm::SmallVector<mlir::Value> 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<fir::CoordinateOp>(loc, bldr->getRefType(coorTy),
currentFunc(val), offsets);
};
component.extendCoorRef = newCoorRef;
}
//===-------------------------------------------------------------------===//
// Array data references in an explicit iteration space.
//
@ -6419,11 +6682,17 @@ private:
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 @@ private:
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 @@ private:
[&](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<mlir::Value> componentsToAdd;
for (const auto &ss : x->subscript()) {
std::visit(
Fortran::common::visitors{
@ -6483,7 +6755,7 @@ private:
mlir::Value ivAdj =
builder.create<mlir::arith::SubIOp>(
loc, idxTy, val, lb);
addComponent(
componentsToAdd.push_back(
builder.createConvert(loc, idxTy, ivAdj));
},
[&](const auto &) {
@ -6494,20 +6766,47 @@ private:
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<fir::RecordType>();
ty = recTy.getType(name);
auto fld = builder.create<fir::FieldIndexOp>(
loc, fieldTy, name, recTy, fir::getTypeParams(arrayExv));
addComponent(fld);
if (auto recTy = ty.dyn_cast<fir::RecordType>()) {
ty = recTy.getType(name);
auto fld = builder.create<fir::FieldIndexOp>(
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<fir::BoxType>()) {
auto currentFunc = components.getExtendCoorRef();
auto loc = getLoc();
auto *bldr = &converter.getFirOpBuilder();
auto newCoorRef = [=](mlir::Value val) -> mlir::Value {
return bldr->create<fir::LoadOp>(loc, currentFunc(val));
};
components.extendCoorRef = newCoorRef;
deref = true;
}
}
} else if (auto boxTy = ty.dyn_cast<fir::BoxType>()) {
ty = fir::unwrapRefType(boxTy.getEleTy());
auto recTy = ty.cast<fir::RecordType>();
ty = recTy.getType(name);
auto fld = builder.create<fir::FieldIndexOp>(
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 @@ private:
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<mlir::Value> substringBounds =
genSubstringBounds(components);
if (isProjectedCopyInCopyOut()) {
@ -6555,7 +6852,8 @@ private:
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 @@ private:
assert(eleTy.isa<fir::SequenceType>());
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<fir::BoxType>());
auto arrayOp = builder.create<fir::ArrayAccessOp>(
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<fir::BoxType>()) {
eleTy = boxTy.getEleTy();
if (!(eleTy.isa<fir::PointerType>() ||
eleTy.isa<fir::HeapType>()))
eleTy = builder.getRefType(eleTy);
addr = builder.create<fir::BoxAddrOp>(loc, eleTy, addr);
eleTy = fir::unwrapRefType(eleTy);
}
}
auto ele = convertElementForUpdate(loc, eleTy, iters.getElement());
builder.create<fir::StoreOp>(loc, ele, addr);
auto amend = builder.create<fir::ArrayAmendOp>(
loc, innerArg.getType(), innerArg, arrayOp);
return arrayLoadExtValue(builder, loc, load, iters.iterVec(), amend);
}
auto ele = convertElementForUpdate(loc, eleTy, iters.getElement());
auto update = builder.create<fir::ArrayUpdateOp>(
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 @@ private:
}
return arrayLoadExtValue(builder, loc, load, iters.iterVec(), newBase);
}
if (components.hasExtendCoorRef()) {
auto eleBoxTy = fir::applyPathToType(load.getType(), iters.iterVec());
assert(eleBoxTy && eleBoxTy.isa<fir::BoxType>());
auto access = builder.create<fir::ArrayAccessOp>(
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<fir::BoxType>()) {
// 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<fir::ArrayAccessOp>(
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<fir::EmboxOp>(
loc, boxTy, ptrAddr, /*shape=*/mlir::Value{},
/*slice=*/mlir::Value{}, typeParams);
return arrayLoadExtValue(builder, loc, load, iters.iterVec(), embox);
}
}
auto fetch = builder.create<fir::ArrayFetchOp>(
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 <typename A>
@ -6664,9 +7021,19 @@ private:
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 @@ private:
/// Example: <code>array%baz%qux%waldo</code>
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 @@ private:
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<mlir::Value> &lbs,
llvm::Optional<llvm::SmallVector<mlir::Value>> ubs) {
lbounds = lbs;
ubounds = ubs;
}
Fortran::lower::AbstractConverter &converter;
fir::FirOpBuilder &builder;
Fortran::lower::StatementContext &stmtCtx;
@ -6857,6 +7242,10 @@ private:
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<llvm::SmallVector<mlir::Value>> lbounds;
llvm::Optional<llvm::SmallVector<mlir::Value>> 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 @@ void Fortran::lower::createAllocatableArrayAssignment(
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<mlir::Value> &lbounds,
llvm::Optional<llvm::SmallVector<mlir::Value>> 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,

367
flang/lib/Lower/IO.cpp
View File

@ -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 @@ static constexpr std::tuple<
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 @@ static constexpr std::tuple<
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 @@ namespace {
/// 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<fir::ExtendedValue> 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 @@ struct ConditionSpecInfo {
/// Check for any condition specifier, including IOMSG.
bool hasAnyConditionSpec() const {
return hasTransferConditionSpec() || ioMsgExpr != nullptr;
return hasTransferConditionSpec() || ioMsg;
}
};
} // namespace
@ -138,7 +138,7 @@ template <typename D>
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 <typename A>
@ -162,7 +162,7 @@ template <typename E>
static mlir::func::FuncOp getIORuntimeFunc(mlir::Location loc,
fir::FirOpBuilder &builder) {
llvm::StringRef name = getName<E>();
mlir::func::FuncOp func = builder.getNamedFunction(name);
auto func = builder.getNamedFunction(name);
if (func)
return func;
auto funTy = getTypeModel<E>()(builder.getContext());
@ -176,35 +176,38 @@ static mlir::func::FuncOp getIORuntimeFunc(mlir::Location loc,
/// 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<mkIOKey(GetIoMsg)>(loc, builder);
fir::ExtendedValue ioMsgVar =
converter.genExprAddr(csi.ioMsgExpr, stmtCtx, loc);
if (csi.ioMsg) {
auto getIoMsg = getIORuntimeFunc<mkIOKey(GetIoMsg)>(loc, builder);
builder.create<fir::CallOp>(
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<mkIOKey(EndIoStatement)>(loc, builder);
auto endIoStatement = getIORuntimeFunc<mkIOKey(EndIoStatement)>(loc, builder);
auto call = builder.create<fir::CallOp>(loc, endIoStatement,
mlir::ValueRange{cookie});
mlir::Value iostat = call.getResult(0);
if (csi.bigUnitIfOp) {
stmtCtx.finalize(/*popScope=*/true);
builder.create<fir::ResultOp>(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<fir::StoreOp>(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 @@ static mlir::func::FuncOp getOutputFunc(mlir::Location loc,
return getIORuntimeFunc<mkIOKey(OutputInteger32)>(loc, builder);
case 64:
return getIORuntimeFunc<mkIOKey(OutputInteger64)>(loc, builder);
#ifdef __SIZEOF_INT128__
case 128:
return getIORuntimeFunc<mkIOKey(OutputInteger128)>(loc, builder);
#endif
}
llvm_unreachable("unknown OutputInteger kind");
}
@ -458,39 +459,37 @@ static mlir::func::FuncOp getOutputFunc(mlir::Location loc,
}
/// Generate a sequence of output data transfer calls.
static void
genOutputItemList(Fortran::lower::AbstractConverter &converter,
mlir::Value cookie,
const std::list<Fortran::parser::OutputItem> &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<Fortran::parser::OutputItem> &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<Fortran::parser::Expr>(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<fir::BoxType>()) &&
"expect descriptor for unformatted IO runtime");
llvm::SmallVector<mlir::Value> outputFuncArgs = {cookie};
fir::factory::CharacterExprHelper helper{builder, loc};
if (argType.isa<fir::BoxType>()) {
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 @@ genOutputItemList(Fortran::lower::AbstractConverter &converter,
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 @@ static void genInputItemList(Fortran::lower::AbstractConverter &converter,
mlir::Value cookie,
const std::list<Fortran::parser::InputItem> &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<Fortran::parser::Variable>(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<fir::BoxType>();
@ -653,11 +652,10 @@ static void genInputItemList(Fortran::lower::AbstractConverter &converter,
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<fir::BoxType>()
? 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 @@ template <typename D>
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 @@ static void genIoLoop(Fortran::lower::AbstractConverter &converter,
? genControlValue(*control.step)
: builder.create<mlir::arith::ConstantIndexOp>(loc, 1);
auto genItemList = [&](const D &ioImpliedDo) {
Fortran::lower::StatementContext loopCtx;
if constexpr (std::is_same_v<D, Fortran::parser::InputImpliedDo>)
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 @@ static void genIoLoop(Fortran::lower::AbstractConverter &converter,
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<fir::StoreOp>(loc, lcv, loopVar);
genItemList(ioImpliedDo);
builder.setInsertionPointToEnd(doLoopOp.getBody());
@ -711,7 +710,7 @@ static void genIoLoop(Fortran::lower::AbstractConverter &converter,
builder.create<fir::ResultOp>(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<fir::StoreOp>(loc, lcv, loopVar);
return;
@ -722,8 +721,9 @@ static void genIoLoop(Fortran::lower::AbstractConverter &converter,
auto iterWhileOp = builder.create<fir::IterWhileOp>(
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<fir::StoreOp>(loc, lcv, loopVar);
ok = iterWhileOp.getIterateVar();
mlir::Value falseValue =
@ -756,7 +756,7 @@ static void genIoLoop(Fortran::lower::AbstractConverter &converter,
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<fir::StoreOp>(loc, lcv, loopVar);
}
@ -874,10 +874,10 @@ mlir::Value genIntIOOption(Fortran::lower::AbstractConverter &converter,
const B &spec) {
Fortran::lower::StatementContext localStatementCtx;
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
mlir::func::FuncOp ioFunc = getIORuntimeFunc<A>(loc, builder);
auto ioFunc = getIORuntimeFunc<A>(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<mlir::Value> ioArgs = {cookie, val};
return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0);
@ -891,7 +891,7 @@ mlir::Value genCharIOOption(Fortran::lower::AbstractConverter &converter,
const B &spec) {
Fortran::lower::StatementContext localStatementCtx;
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
mlir::func::FuncOp ioFunc = getIORuntimeFunc<A>(loc, builder);
auto ioFunc = getIORuntimeFunc<A>(loc, builder);
mlir::FunctionType ioFuncTy = ioFunc.getFunctionType();
std::tuple<mlir::Value, mlir::Value, mlir::Value> tup =
lowerStringLit(converter, loc, localStatementCtx, spec,
@ -923,7 +923,7 @@ mlir::Value genIOOption<Fortran::parser::FileNameExpr>(
Fortran::lower::StatementContext localStatementCtx;
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
// has an extra KIND argument
mlir::func::FuncOp ioFunc = getIORuntimeFunc<mkIOKey(SetFile)>(loc, builder);
auto ioFunc = getIORuntimeFunc<mkIOKey(SetFile)>(loc, builder);
mlir::FunctionType ioFuncTy = ioFunc.getFunctionType();
std::tuple<mlir::Value, mlir::Value, mlir::Value> tup =
lowerStringLit(converter, loc, localStatementCtx, spec,
@ -1094,14 +1094,13 @@ static void genIOReadSize(Fortran::lower::AbstractConverter &converter,
std::get_if<Fortran::parser::IoControlSpec::Size>(&spec.u)) {
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
mlir::func::FuncOp ioFunc =
getIORuntimeFunc<mkIOKey(GetSize)>(loc, builder);
auto ioFunc = getIORuntimeFunc<mkIOKey(GetSize)>(loc, builder);
auto sizeValue =
builder.create<fir::CallOp>(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 @@ static void threadSpecs(Fortran::lower::AbstractConverter &converter,
/// information from the runtime, via a variable, about the nature of the
/// condition that occurred. These condition specifiers are handled here.
template <typename A>
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 @@ genConditionHandlerCall(Fortran::lower::AbstractConverter &converter,
std::get<Fortran::parser::ScalarIntVariable>(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<Fortran::parser::InquireSpec::CharVar::Kind>(
var.t) ==
Fortran::parser::InquireSpec::CharVar::Kind::Iomsg)
csi.ioMsgExpr = Fortran::semantics::GetExpr(
ioMsgExpr = Fortran::semantics::GetExpr(
std::get<Fortran::parser::ScalarDefaultCharVariable>(
var.t));
},
@ -1203,11 +1202,24 @@ genConditionHandlerCall(Fortran::lower::AbstractConverter &converter,
[](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 <typename A>
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<mkIOKey(EnableHandlers)>(loc, builder);
auto enableHandlers = getIORuntimeFunc<mkIOKey(EnableHandlers)>(loc, builder);
mlir::Type boolType = enableHandlers.getFunctionType().getInput(1);
auto boolValue = [&](bool specifierIsPresent) {
return builder.create<mlir::arith::ConstantOp>(
@ -1218,7 +1230,7 @@ genConditionHandlerCall(Fortran::lower::AbstractConverter &converter,
boolValue(csi.hasErr),
boolValue(csi.hasEnd),
boolValue(csi.hasEor),
boolValue(csi.ioMsgExpr != nullptr)};
boolValue(csi.ioMsg.hasValue())};
builder.create<fir::CallOp>(loc, enableHandlers, ioArgs);
}
@ -1437,7 +1449,7 @@ lowerReferenceAsStringSelect(Fortran::lower::AbstractConverter &converter,
// 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<fir::SelectOp>(loc, label, indexList, blockList);
builder.setInsertionPointToEnd(endBlock);
@ -1524,34 +1536,85 @@ getBuffer(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
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<mlir::IntegerType>().getWidth();
unsigned runtimeArgWidth = ty.cast<mlir::IntegerType>().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<mkIOKey(CheckUnitNumberInRange64)>(loc, builder)
: getIORuntimeFunc<mkIOKey(CheckUnitNumberInRange128)>(loc,
builder);
mlir::FunctionType funcTy = check.getFunctionType();
llvm::SmallVector<mlir::Value> 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<fir::CallOp>(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<mlir::arith::CmpIOp>(
loc, mlir::arith::CmpIPredicate::eq, iostat, zero);
auto ifOp = builder.create<fir::IfOp>(loc, iostatTy, unitIsOK,
/*withElseRegion=*/true);
builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
builder.create<fir::ResultOp>(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<Fortran::parser::FileUnitNumber>(&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<Fortran::parser::FileUnitNumber>(&iounit->u))
return genIOUnitNumber(converter, loc, Fortran::semantics::GetExpr(*e),
ty, csi, stmtCtx);
return builder.create<mlir::arith::ConstantOp>(
loc, builder.getIntegerAttr(ty, Fortran::runtime::io::DefaultUnit));
}
template <typename A>
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<Fortran::parser::IoUnit>(stmt))
return genIOUnit(converter, loc, *iounit, ty, stmtCtx);
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
return builder.create<mlir::arith::ConstantOp>(
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<Fortran::parser::IoUnit>(stmt);
return genIOUnit(converter, loc, iounit, ty, csi, stmtCtx);
}
//===----------------------------------------------------------------------===//
// Generators for each IO statement type.
//===----------------------------------------------------------------------===//
@ -1562,17 +1625,18 @@ static mlir::Value genBasicIOStmt(Fortran::lower::AbstractConverter &converter,
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
Fortran::lower::StatementContext stmtCtx;
mlir::Location loc = converter.getCurrentLocation();
mlir::func::FuncOp beginFunc = getIORuntimeFunc<K>(loc, builder);
ConditionSpecInfo csi = lowerErrorSpec(converter, loc, stmt.v);
auto beginFunc = getIORuntimeFunc<K>(loc, builder);
mlir::FunctionType beginFuncTy = beginFunc.getFunctionType();
mlir::Value unit = fir::getBase(converter.genExprValue(
getExpr<Fortran::parser::FileUnitNumber>(stmt), stmtCtx, loc));
mlir::Value unit = genIOUnitNumber(
converter, loc, getExpr<Fortran::parser::FileUnitNumber>(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<fir::CallOp>(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 @@ genNewunitSpec(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
std::get_if<Fortran::parser::ConnectSpec::Newunit>(&spec.u)) {
Fortran::lower::StatementContext stmtCtx;
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
mlir::func::FuncOp ioFunc =
getIORuntimeFunc<mkIOKey(GetNewUnit)>(loc, builder);
auto ioFunc = getIORuntimeFunc<mkIOKey(GetNewUnit)>(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<mlir::Value> ioArgs = {cookie, addr, kind};
@ -1638,14 +1701,15 @@ Fortran::lower::genOpenStatement(Fortran::lower::AbstractConverter &converter,
mlir::func::FuncOp beginFunc;
llvm::SmallVector<mlir::Value> beginArgs;
mlir::Location loc = converter.getCurrentLocation();
ConditionSpecInfo csi = lowerErrorSpec(converter, loc, stmt.v);
bool hasNewunitSpec = false;
if (hasSpec<Fortran::parser::FileUnitNumber>(stmt)) {
beginFunc = getIORuntimeFunc<mkIOKey(BeginOpenUnit)>(loc, builder);
mlir::FunctionType beginFuncTy = beginFunc.getFunctionType();
mlir::Value unit = fir::getBase(converter.genExprValue(
getExpr<Fortran::parser::FileUnitNumber>(stmt), stmtCtx, loc));
beginArgs.push_back(
builder.createConvert(loc, beginFuncTy.getInput(0), unit));
mlir::Value unit = genIOUnitNumber(
converter, loc, getExpr<Fortran::parser::FileUnitNumber>(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 @@ Fortran::lower::genOpenStatement(Fortran::lower::AbstractConverter &converter,
}
auto cookie =
builder.create<fir::CallOp>(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 @@ Fortran::lower::genWaitStatement(Fortran::lower::AbstractConverter &converter,
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
Fortran::lower::StatementContext stmtCtx;
mlir::Location loc = converter.getCurrentLocation();
ConditionSpecInfo csi = lowerErrorSpec(converter, loc, stmt.v);
bool hasId = hasSpec<Fortran::parser::IdExpr>(stmt);
mlir::func::FuncOp beginFunc =
hasId ? getIORuntimeFunc<mkIOKey(BeginWait)>(loc, builder)
: getIORuntimeFunc<mkIOKey(BeginWaitAll)>(loc, builder);
auto beginFunc = hasId
? getIORuntimeFunc<mkIOKey(BeginWait)>(loc, builder)
: getIORuntimeFunc<mkIOKey(BeginWaitAll)>(loc, builder);
mlir::FunctionType beginFuncTy = beginFunc.getFunctionType();
mlir::Value unit = fir::getBase(converter.genExprValue(
getExpr<Fortran::parser::FileUnitNumber>(stmt), stmtCtx, loc));
mlir::Value un = builder.createConvert(loc, beginFuncTy.getInput(0), unit);
llvm::SmallVector<mlir::Value> args{un};
mlir::Value unit = genIOUnitNumber(
converter, loc, getExpr<Fortran::parser::FileUnitNumber>(stmt),
beginFuncTy.getInput(0), csi, stmtCtx);
llvm::SmallVector<mlir::Value> args{unit};
if (hasId) {
mlir::Value id = fir::getBase(converter.genExprValue(
getExpr<Fortran::parser::IdExpr>(stmt), stmtCtx, loc));
loc, getExpr<Fortran::parser::IdExpr>(stmt), stmtCtx));
args.push_back(builder.createConvert(loc, beginFuncTy.getInput(1), id));
}
auto cookie = builder.create<fir::CallOp>(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 @@ void genBeginDataTransferCallArgs(
const A &stmt, mlir::FunctionType ioFuncTy, bool isFormatted,
bool isListOrNml, [[maybe_unused]] bool isInternal,
[[maybe_unused]] bool isAsync,
const llvm::Optional<fir::ExtendedValue> &descRef,
const llvm::Optional<fir::ExtendedValue> &descRef, ConditionSpecInfo &csi,
Fortran::lower::StatementContext &stmtCtx) {
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
auto maybeGetFormatArgs = [&]() {
@ -1812,12 +1875,14 @@ void genBeginDataTransferCallArgs(
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 @@ genDataTransferStmt(Fortran::lower::AbstractConverter &converter,
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<isInput>(
loc, builder, isFormatted, isList || isNml, isInternal,
isInternalWithDesc, isAsync);
auto ioFunc = getBeginDataTransferFunc<isInput>(loc, builder, isFormatted,
isList || isNml, isInternal,
isInternalWithDesc, isAsync);
llvm::SmallVector<mlir::Value> ioArgs;
genBeginDataTransferCallArgs<hasIOCtrl>(
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<fir::CallOp>(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 @@ genDataTransferStmt(Fortran::lower::AbstractConverter &converter,
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<A, Fortran::parser::WriteStmt>) {
if (isNml)
genNamelistIO(converter, cookie,
@ -1890,11 +1958,11 @@ genDataTransferStmt(Fortran::lower::AbstractConverter &converter,
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 @@ mlir::Value genInquireSpec<Fortran::parser::InquireSpec::CharVar>(
Fortran::parser::InquireSpec::CharVar::Kind::Iomsg)
return {};
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
mlir::func::FuncOp specFunc =
getIORuntimeFunc<mkIOKey(InquireCharacter)>(loc, builder);
auto specFunc = getIORuntimeFunc<mkIOKey(InquireCharacter)>(loc, builder);
mlir::FunctionType specFuncTy = specFunc.getFunctionType();
const auto *varExpr = Fortran::semantics::GetExpr(
std::get<Fortran::parser::ScalarDefaultCharVariable>(var.t));
fir::ExtendedValue str = converter.genExprAddr(varExpr, stmtCtx, loc);
fir::ExtendedValue str = converter.genExprAddr(loc, varExpr, stmtCtx);
llvm::SmallVector<mlir::Value> args = {
builder.createConvert(loc, specFuncTy.getInput(0), cookie),
builder.createIntegerConstant(
@ -1996,12 +2063,11 @@ mlir::Value genInquireSpec<Fortran::parser::InquireSpec::IntVar>(
Fortran::parser::InquireSpec::IntVar::Kind::Iostat)
return {};
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
mlir::func::FuncOp specFunc =
getIORuntimeFunc<mkIOKey(InquireInteger64)>(loc, builder);
auto specFunc = getIORuntimeFunc<mkIOKey(InquireInteger64)>(loc, builder);
mlir::FunctionType specFuncTy = specFunc.getFunctionType();
const auto *varExpr = Fortran::semantics::GetExpr(
std::get<Fortran::parser::ScalarIntVariable>(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 @@ mlir::Value genInquireSpec<Fortran::parser::InquireSpec::LogVar>(
bool pendId =
idExpr &&
logVarKind == Fortran::parser::InquireSpec::LogVar::Kind::Pending;
mlir::func::FuncOp specFunc =
auto specFunc =
pendId ? getIORuntimeFunc<mkIOKey(InquirePendingId)>(loc, builder)
: getIORuntimeFunc<mkIOKey(InquireLogical)>(loc, builder);
mlir::FunctionType specFuncTy = specFunc.getFunctionType();
mlir::Value addr = fir::getBase(converter.genExprAddr(
loc,
Fortran::semantics::GetExpr(
std::get<Fortran::parser::Scalar<
Fortran::parser::Logical<Fortran::parser::Variable>>>(var.t)),
stmtCtx, loc));
stmtCtx));
llvm::SmallVector<mlir::Value> args = {
builder.createConvert(loc, specFuncTy.getInput(0), cookie)};
if (pendId)
@ -2069,7 +2136,7 @@ lowerIdExpr(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
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 @@ mlir::Value Fortran::lower::genInquireStatement(
Fortran::lower::StatementContext stmtCtx;
mlir::Location loc = converter.getCurrentLocation();
mlir::func::FuncOp beginFunc;
ConditionSpecInfo csi;
llvm::SmallVector<mlir::Value> beginArgs;
const auto *list =
std::get_if<std::list<Fortran::parser::InquireSpec>>(&stmt.u);
@ -2114,22 +2180,24 @@ mlir::Value Fortran::lower::genInquireStatement(
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<mkIOKey(BeginInquireUnit)>(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<mkIOKey(BeginInquireFile)>(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 @@ mlir::Value Fortran::lower::genInquireStatement(
genOutputItemList(
converter, cookie,
std::get<std::list<Fortran::parser::OutputItem>>(ioLength->t),
/*isFormatted=*/false, /*checkResult=*/false, ok, /*inLoop=*/false,
stmtCtx);
/*isFormatted=*/false, /*checkResult=*/false, ok, /*inLoop=*/false);
auto *ioLengthVar = Fortran::semantics::GetExpr(
std::get<Fortran::parser::ScalarIntVariable>(ioLength->t));
mlir::Value ioLengthVarAddr =
fir::getBase(converter.genExprAddr(ioLengthVar, stmtCtx, loc));
fir::getBase(converter.genExprAddr(loc, ioLengthVar, stmtCtx));
llvm::SmallVector<mlir::Value> args = {cookie};
mlir::Value length =
builder

9
flang/lib/Optimizer/Builder/BoxValue.cpp
View File

@ -222,10 +222,11 @@ bool fir::BoxValue::verify() const {
/// 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 {};

73
flang/lib/Optimizer/Builder/FIRBuilder.cpp
View File

@ -649,7 +649,7 @@ fir::factory::readExtents(fir::FirOpBuilder &builder, mlir::Location loc,
}
llvm::SmallVector<mlir::Value>
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<mlir::Value> {
@ -663,7 +663,7 @@ fir::factory::getExtents(fir::FirOpBuilder &builder, mlir::Location loc,
},
[&](const fir::MutableBoxValue &x) -> llvm::SmallVector<mlir::Value> {
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<mlir::Value> { return {}; });
}
@ -683,7 +683,7 @@ fir::ExtendedValue fir::factory::readBoxValue(fir::FirOpBuilder &builder,
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 @@ fir::factory::getNonDeferredLengthParams(const fir::ExtendedValue &exv) {
[&](const auto &) -> llvm::SmallVector<mlir::Value> { return {}; });
}
// If valTy is a box type, then we need to extract the type parameters from
// the box value.
static llvm::SmallVector<mlir::Value> getFromBox(mlir::Location loc,
fir::FirOpBuilder &builder,
mlir::Type valTy,
mlir::Value boxVal) {
if (auto boxTy = valTy.dyn_cast<fir::BoxType>()) {
auto eleTy = fir::unwrapAllRefAndSeqType(boxTy.getEleTy());
if (auto recTy = eleTy.dyn_cast<fir::RecordType>()) {
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<fir::CharacterType>()) {
if (charTy.hasDynamicLen()) {
auto idxTy = builder.getIndexType();
auto eleSz = builder.create<fir::BoxEleSizeOp>(loc, idxTy, boxVal);
auto kindBytes =
builder.getKindMap().getCharacterBitsize(charTy.getFKind()) / 8;
mlir::Value charSz =
builder.createIntegerConstant(loc, idxTy, kindBytes);
mlir::Value len =
builder.create<mlir::arith::DivSIOp>(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<mlir::Value>
fir::factory::getTypeParams(mlir::Location loc, fir::FirOpBuilder &builder,
const fir::ExtendedValue &exv) {
auto handleBoxed = [&](const auto &box) -> llvm::SmallVector<mlir::Value> {
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<mlir::Value>
fir::factory::getTypeParams(mlir::Location loc, fir::FirOpBuilder &builder,
fir::ArrayLoadOp load) {
mlir::Type memTy = load.getMemref().getType();
if (auto boxTy = memTy.dyn_cast<fir::BoxType>())
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 @@ fir::ExtendedValue fir::factory::arrayElementToExtendedValue(
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;
},

20
flang/lib/Optimizer/Builder/MutableBox.cpp
View File

@ -66,7 +66,7 @@ static mlir::Value createNewFirBox(fir::FirOpBuilder &builder,
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 @@ public:
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 @@ private:
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 @@ void fir::factory::associateMutableBox(fir::FirOpBuilder &builder,
// fir.box to update the LHS.
auto rawAddr = builder.create<fir::BoxAddrOp>(loc, arr.getMemTy(),
arr.getAddr());
auto extents = fir::factory::getExtents(builder, loc, source);
auto extents = fir::factory::getExtents(loc, builder, source);
llvm::SmallVector<mlir::Value> 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 @@ void fir::factory::associateMutableBoxWithRemap(
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 @@ fir::factory::genReallocIfNeeded(fir::FirOpBuilder &builder, mlir::Location loc,
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 @@ fir::factory::genReallocIfNeeded(fir::FirOpBuilder &builder, mlir::Location loc,
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 @@ void fir::factory::finalizeRealloc(fir::FirOpBuilder &builder,
llvm::SmallVector<mlir::Value> 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); })

30
flang/lib/Optimizer/Dialect/FIRType.cpp
View File

@ -263,6 +263,14 @@ bool isAllocatableType(mlir::Type ty) {
return false;
}
bool isUnlimitedPolymorphicType(mlir::Type ty) {
if (auto refTy = fir::dyn_cast_ptrEleTy(ty))
ty = refTy;
if (auto boxTy = ty.dyn_cast<fir::BoxType>())
return boxTy.getEleTy().isa<mlir::NoneType>();
return false;
}
bool isRecordWithAllocatableMember(mlir::Type ty) {
if (auto recTy = ty.dyn_cast<fir::RecordType>())
for (auto [field, memTy] : recTy.getTypeList()) {
@ -276,6 +284,28 @@ bool isRecordWithAllocatableMember(mlir::Type ty) {
return false;
}
mlir::Type unwrapAllRefAndSeqType(mlir::Type ty) {
while (true) {
mlir::Type nt = unwrapSequenceType(unwrapRefType(ty));
if (auto vecTy = nt.dyn_cast<fir::VectorType>())
nt = vecTy.getEleTy();
if (nt == ty)
return ty;
ty = nt;
}
}
mlir::Type unwrapSeqOrBoxedSeqType(mlir::Type ty) {
if (auto seqTy = ty.dyn_cast<fir::SequenceType>())
return seqTy.getEleTy();
if (auto boxTy = ty.dyn_cast<fir::BoxType>()) {
auto eleTy = unwrapRefType(boxTy.getEleTy());
if (auto seqTy = eleTy.dyn_cast<fir::SequenceType>())
return seqTy.getEleTy();
}
return ty;
}
} // namespace fir
namespace {

816
flang/test/Lower/forall/array-pointer.f90 Normal file
View File

@ -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.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>> {fir.bindc_name = "x"},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.box<!fir.array<?xi32>> {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<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>>) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>
! CHECK: %[[VAL_9:.*]] = fir.array_load %[[VAL_1]] : (!fir.box<!fir.array<?xi32>>) -> !fir.array<?xi32>
! 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<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>) {
! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_11]] : (index) -> i32
! CHECK: fir.store %[[VAL_13]] to %[[VAL_2]] : !fir.ref<i32>
! CHECK: %[[VAL_14:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_15:.*]] = fir.load %[[VAL_2]] : !fir.ref<i32>
! 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<?xi32>, index) -> i32
! CHECK: %[[VAL_20:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_21:.*]] = fir.load %[[VAL_2]] : !fir.ref<i32>
! 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<!fir.ptr<i32>>}>
! CHECK: %[[VAL_26:.*]] = fir.array_access %[[VAL_12]], %[[VAL_24]], %[[VAL_25]] : (!fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, index, !fir.field) -> !fir.ref<!fir.box<!fir.ptr<i32>>>
! CHECK: %[[VAL_27:.*]] = fir.load %[[VAL_26]] : !fir.ref<!fir.box<!fir.ptr<i32>>>
! CHECK: %[[VAL_28:.*]] = fir.box_addr %[[VAL_27]] : (!fir.box<!fir.ptr<i32>>) -> !fir.ptr<i32>
! CHECK: fir.store %[[VAL_19]] to %[[VAL_28]] : !fir.ptr<i32>
! CHECK: %[[VAL_29:.*]] = fir.array_amend %[[VAL_12]], %[[VAL_26]] : (!fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, !fir.ref<!fir.box<!fir.ptr<i32>>>) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>
! CHECK: fir.result %[[VAL_29]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>
! CHECK: }
! CHECK: fir.array_merge_store %[[VAL_8]], %[[VAL_30:.*]] to %[[VAL_0]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, !fir.box<!fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>>
! 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.array<10x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>> {fir.bindc_name = "x"},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref<!fir.array<10xi32>> {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.array<10x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>>, !fir.shape<1>) -> !fir.array<10x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>
! CHECK: %[[VAL_12:.*]] = fir.shape %[[VAL_4]] : (index) -> !fir.shape<1>
! CHECK: %[[VAL_13:.*]] = fir.array_load %[[VAL_1]](%[[VAL_12]]) : (!fir.ref<!fir.array<10xi32>>, !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<!fir.ptr<i32>>}>>) {
! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_15]] : (index) -> i32
! CHECK: fir.store %[[VAL_17]] to %[[VAL_2]] : !fir.ref<i32>
! CHECK: %[[VAL_18:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_19:.*]] = fir.load %[[VAL_2]] : !fir.ref<i32>
! 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<i32>
! 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<!fir.ptr<i32>>}>
! CHECK: %[[VAL_30:.*]] = fir.array_access %[[VAL_16]], %[[VAL_28]], %[[VAL_29]] : (!fir.array<10x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, index, !fir.field) -> !fir.ref<!fir.box<!fir.ptr<i32>>>
! CHECK: %[[VAL_31:.*]] = fir.load %[[VAL_30]] : !fir.ref<!fir.box<!fir.ptr<i32>>>
! CHECK: %[[VAL_32:.*]] = fir.box_addr %[[VAL_31]] : (!fir.box<!fir.ptr<i32>>) -> !fir.ptr<i32>
! CHECK: fir.store %[[VAL_23]] to %[[VAL_32]] : !fir.ptr<i32>
! CHECK: %[[VAL_33:.*]] = fir.array_amend %[[VAL_16]], %[[VAL_30]] : (!fir.array<10x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, !fir.ref<!fir.box<!fir.ptr<i32>>>) -> !fir.array<10x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>
! CHECK: fir.result %[[VAL_33]] : !fir.array<10x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>
! 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.ptr<i32>>}>>, !fir.array<10x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, !fir.ref<!fir.array<10x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>>
! 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.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>> {fir.bindc_name = "x"},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.box<!fir.array<?xi32>> {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<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>>) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>
! CHECK: %[[VAL_9:.*]] = fir.array_load %[[VAL_1]] : (!fir.box<!fir.array<?xi32>>) -> !fir.array<?xi32>
! 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<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>) {
! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_11]] : (index) -> i32
! CHECK: fir.store %[[VAL_13]] to %[[VAL_2]] : !fir.ref<i32>
! CHECK: %[[VAL_14:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_15:.*]] = fir.load %[[VAL_2]] : !fir.ref<i32>
! 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<?xi32>, index) -> !fir.ref<i32>
! CHECK: %[[VAL_20:.*]] = fir.convert %[[VAL_19]] : (!fir.ref<i32>) -> !fir.ptr<i32>
! CHECK: %[[VAL_21:.*]] = fir.embox %[[VAL_20]] : (!fir.ptr<i32>) -> !fir.box<!fir.ptr<i32>>
! CHECK: %[[VAL_22:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_23:.*]] = fir.load %[[VAL_2]] : !fir.ref<i32>
! 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<!fir.ptr<i32>>}>
! CHECK: %[[VAL_28:.*]] = fir.array_update %[[VAL_12]], %[[VAL_21]], %[[VAL_26]], %[[VAL_27]] : (!fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, !fir.box<!fir.ptr<i32>>, index, !fir.field) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>
! CHECK: fir.result %[[VAL_28]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>
! CHECK: }
! CHECK: fir.array_merge_store %[[VAL_8]], %[[VAL_29:.*]] to %[[VAL_0]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, !fir.box<!fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>>
! 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.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>> {fir.bindc_name = "x"},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>> {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<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>>) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>
! CHECK: %[[VAL_9:.*]] = fir.load %[[VAL_1]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>
! CHECK: %[[VAL_10:.*]] = arith.constant 0 : index
! CHECK: %[[VAL_11:.*]]:3 = fir.box_dims %[[VAL_9]], %[[VAL_10]] : (!fir.box<!fir.ptr<!fir.array<?xi32>>>, 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.ptr<!fir.array<?xi32>>>, !fir.shift<1>) -> !fir.array<?xi32>
! 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<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>) {
! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_15]] : (index) -> i32
! CHECK: fir.store %[[VAL_17]] to %[[VAL_2]] : !fir.ref<i32>
! CHECK: %[[VAL_18:.*]] = fir.load %[[VAL_2]] : !fir.ref<i32>
! 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<?xi32>, index) -> !fir.ref<i32>
! CHECK: %[[VAL_23:.*]] = fir.convert %[[VAL_22]] : (!fir.ref<i32>) -> !fir.ptr<i32>
! CHECK: %[[VAL_24:.*]] = fir.embox %[[VAL_23]] : (!fir.ptr<i32>) -> !fir.box<!fir.ptr<i32>>
! CHECK: %[[VAL_25:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_26:.*]] = fir.load %[[VAL_2]] : !fir.ref<i32>
! 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<!fir.ptr<i32>>}>
! CHECK: %[[VAL_31:.*]] = fir.array_update %[[VAL_16]], %[[VAL_24]], %[[VAL_29]], %[[VAL_30]] : (!fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, !fir.box<!fir.ptr<i32>>, index, !fir.field) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>
! CHECK: fir.result %[[VAL_31]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>
! CHECK: }
! CHECK: fir.array_merge_store %[[VAL_8]], %[[VAL_32:.*]] to %[[VAL_0]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, !fir.box<!fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>>
! 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.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>> {fir.bindc_name = "x"},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>> {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<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>>) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>
! CHECK: %[[VAL_9:.*]] = fir.load %[[VAL_1]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>
! CHECK: %[[VAL_10:.*]] = arith.constant 0 : index
! CHECK: %[[VAL_11:.*]]:3 = fir.box_dims %[[VAL_9]], %[[VAL_10]] : (!fir.box<!fir.heap<!fir.array<?xi32>>>, index) -> (index, index, index)
! CHECK: %[[VAL_12:.*]] = fir.box_addr %[[VAL_9]] : (!fir.box<!fir.heap<!fir.array<?xi32>>>) -> !fir.heap<!fir.array<?xi32>>
! 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.array<?xi32>>, !fir.shapeshift<1>) -> !fir.array<?xi32>
! 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<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>) {
! CHECK: %[[VAL_18:.*]] = fir.convert %[[VAL_16]] : (index) -> i32
! CHECK: fir.store %[[VAL_18]] to %[[VAL_2]] : !fir.ref<i32>
! CHECK: %[[VAL_19:.*]] = fir.load %[[VAL_2]] : !fir.ref<i32>
! 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<?xi32>, index) -> !fir.ref<i32>
! CHECK: %[[VAL_24:.*]] = fir.convert %[[VAL_23]] : (!fir.ref<i32>) -> !fir.ptr<i32>
! CHECK: %[[VAL_25:.*]] = fir.embox %[[VAL_24]] : (!fir.ptr<i32>) -> !fir.box<!fir.ptr<i32>>
! CHECK: %[[VAL_26:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_27:.*]] = fir.load %[[VAL_2]] : !fir.ref<i32>
! 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<!fir.ptr<i32>>}>
! CHECK: %[[VAL_32:.*]] = fir.array_update %[[VAL_17]], %[[VAL_25]], %[[VAL_30]], %[[VAL_31]] : (!fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, !fir.box<!fir.ptr<i32>>, index, !fir.field) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>
! CHECK: fir.result %[[VAL_32]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>
! CHECK: }
! CHECK: fir.array_merge_store %[[VAL_8]], %[[VAL_33:.*]] to %[[VAL_0]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, !fir.box<!fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>>
! 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.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>> {fir.bindc_name = "x"}) {
! CHECK: %[[VAL_1:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "i"}
! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xi32>>> {bindc_name = "y", fir.target, uniq_name = "_QFs2_3Ey"}
! CHECK: %[[VAL_3:.*]] = fir.alloca !fir.heap<!fir.array<?xi32>> {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<!fir.array<?xi32>>
! CHECK: fir.store %[[VAL_6]] to %[[VAL_3]] : !fir.ref<!fir.heap<!fir.array<?xi32>>>
! 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<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>>) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>
! CHECK: %[[VAL_13:.*]] = fir.load %[[VAL_4]] : !fir.ref<index>
! CHECK: %[[VAL_14:.*]] = fir.load %[[VAL_5]] : !fir.ref<index>
! CHECK: %[[VAL_15:.*]] = fir.load %[[VAL_3]] : !fir.ref<!fir.heap<!fir.array<?xi32>>>
! 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.array<?xi32>>, !fir.shapeshift<1>) -> !fir.array<?xi32>
! 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<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>) {
! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_19]] : (index) -> i32
! CHECK: fir.store %[[VAL_21]] to %[[VAL_1]] : !fir.ref<i32>
! CHECK: %[[VAL_22:.*]] = fir.load %[[VAL_1]] : !fir.ref<i32>
! 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<?xi32>, index) -> !fir.ref<i32>
! CHECK: %[[VAL_27:.*]] = fir.convert %[[VAL_26]] : (!fir.ref<i32>) -> !fir.ptr<i32>
! CHECK: %[[VAL_28:.*]] = fir.embox %[[VAL_27]] : (!fir.ptr<i32>) -> !fir.box<!fir.ptr<i32>>
! CHECK: %[[VAL_29:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_30:.*]] = fir.load %[[VAL_1]] : !fir.ref<i32>
! 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<!fir.ptr<i32>>}>
! CHECK: %[[VAL_35:.*]] = fir.array_update %[[VAL_20]], %[[VAL_28]], %[[VAL_33]], %[[VAL_34]] : (!fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, !fir.box<!fir.ptr<i32>>, index, !fir.field) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>
! CHECK: fir.result %[[VAL_35]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>
! CHECK: }
! CHECK: fir.array_merge_store %[[VAL_12]], %[[VAL_36:.*]] to %[[VAL_0]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, !fir.box<!fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>>
! 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.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>> {fir.bindc_name = "x"},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.box<!fir.array<?xi32>> {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<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>>) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>
! CHECK: %[[VAL_9:.*]] = fir.array_load %[[VAL_1]] : (!fir.box<!fir.array<?xi32>>) -> !fir.array<?xi32>
! 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<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>) {
! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_11]] : (index) -> i32
! CHECK: fir.store %[[VAL_13]] to %[[VAL_2]] : !fir.ref<i32>
! CHECK: %[[VAL_14:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_15:.*]] = fir.load %[[VAL_2]] : !fir.ref<i32>
! 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<?xi32>, index) -> i32
! CHECK: %[[VAL_20:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_21:.*]] = fir.load %[[VAL_2]] : !fir.ref<i32>
! 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<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>
! 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<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>, index, !fir.field) -> !fir.ref<!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>>
! CHECK: %[[VAL_28:.*]] = fir.load %[[VAL_27]] : !fir.ref<!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>>
! CHECK: %[[VAL_29:.*]] = fir.coordinate_of %[[VAL_28]], %[[VAL_26]] : (!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>, !fir.field) -> !fir.ref<i32>
! CHECK: fir.store %[[VAL_19]] to %[[VAL_29]] : !fir.ref<i32>
! CHECK: %[[VAL_30:.*]] = fir.array_amend %[[VAL_12]], %[[VAL_27]] : (!fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>, !fir.ref<!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>>) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>
! CHECK: fir.result %[[VAL_30]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>
! CHECK: }
! CHECK: fir.array_merge_store %[[VAL_8]], %[[VAL_31:.*]] to %[[VAL_0]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>, !fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>, !fir.box<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>>
! 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.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>> {fir.bindc_name = "x"},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.box<!fir.array<?xi32>> {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<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>>) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>
! CHECK: %[[VAL_9:.*]] = fir.array_load %[[VAL_1]] : (!fir.box<!fir.array<?xi32>>) -> !fir.array<?xi32>
! 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<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>) {
! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_11]] : (index) -> i32
! CHECK: fir.store %[[VAL_13]] to %[[VAL_2]] : !fir.ref<i32>
! CHECK: %[[VAL_14:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_15:.*]] = fir.load %[[VAL_2]] : !fir.ref<i32>
! 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<?xi32>, index) -> i32
! CHECK: %[[VAL_20:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_21:.*]] = fir.load %[[VAL_2]] : !fir.ref<i32>
! 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<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>
! 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<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>, index, !fir.field) -> !fir.ref<!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>>
! CHECK: %[[VAL_28:.*]] = fir.load %[[VAL_27]] : !fir.ref<!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>>
! CHECK: %[[VAL_29:.*]] = fir.coordinate_of %[[VAL_28]], %[[VAL_26]] : (!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>, !fir.field) -> !fir.ref<i32>
! CHECK: fir.store %[[VAL_19]] to %[[VAL_29]] : !fir.ref<i32>
! CHECK: %[[VAL_30:.*]] = fir.array_amend %[[VAL_12]], %[[VAL_27]] : (!fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>, !fir.ref<!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>>) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>
! CHECK: fir.result %[[VAL_30]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>
! CHECK: }
! CHECK: fir.array_merge_store %[[VAL_8]], %[[VAL_31:.*]] to %[[VAL_0]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>, !fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>, !fir.box<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>>
! 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.array<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>> {fir.bindc_name = "x"},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.box<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtb{ip:!fir.box<!fir.ptr<!fir.array<?x?xi32>>>}>>> {fir.bindc_name = "y"},
! CHECK-SAME: %[[VAL_2:.*]]: !fir.box<!fir.array<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>> {fir.bindc_name = "z", fir.target},
! CHECK-SAME: %[[VAL_3:.*]]: !fir.ref<i32> {fir.bindc_name = "n1"},
! CHECK-SAME: %[[VAL_4:.*]]: !fir.ref<i32> {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<?x!fir.type<_QMarray_of_pointer_testTtb{ip:!fir.box<!fir.ptr<!fir.array<?x?xi32>>>}>>>) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTtb{ip:!fir.box<!fir.ptr<!fir.array<?x?xi32>>>}>>
! CHECK: %[[VAL_12:.*]] = fir.array_load %[[VAL_2]] : (!fir.box<!fir.array<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>>) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>
! 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<?x!fir.type<_QMarray_of_pointer_testTtb{ip:!fir.box<!fir.ptr<!fir.array<?x?xi32>>>}>>) {
! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_14]] : (index) -> i32
! CHECK: fir.store %[[VAL_16]] to %[[VAL_5]] : !fir.ref<i32>
! CHECK: %[[VAL_17:.*]] = arith.constant 1 : i64
! CHECK: %[[VAL_18:.*]] = fir.load %[[VAL_3]] : !fir.ref<i32>
! 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<i32>
! 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<i32>
! 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<!fir.ptr<!fir.array<?xi32>>>}>
! CHECK: %[[VAL_29:.*]] = fir.array_fetch %[[VAL_12]], %[[VAL_27]], %[[VAL_28]] : (!fir.array<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>, index, !fir.field) -> !fir.box<!fir.ptr<!fir.array<?xi32>>>
! CHECK: %[[VAL_30:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_31:.*]] = fir.load %[[VAL_5]] : !fir.ref<i32>
! 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<!fir.ptr<!fir.array<?x?xi32>>>}>
! CHECK: %[[VAL_36:.*]] = fir.convert %[[VAL_29]] : (!fir.box<!fir.ptr<!fir.array<?xi32>>>) -> !fir.box<!fir.ptr<!fir.array<?x?xi32>>>
! 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.ptr<!fir.array<?x?xi32>>>, !fir.shapeshift<2>) -> !fir.box<!fir.ptr<!fir.array<?x?xi32>>>
! CHECK: %[[VAL_39:.*]] = fir.array_update %[[VAL_15]], %[[VAL_38]], %[[VAL_34]], %[[VAL_35]] : (!fir.array<?x!fir.type<_QMarray_of_pointer_testTtb{ip:!fir.box<!fir.ptr<!fir.array<?x?xi32>>>}>>, !fir.box<!fir.ptr<!fir.array<?x?xi32>>>, index, !fir.field) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTtb{ip:!fir.box<!fir.ptr<!fir.array<?x?xi32>>>}>>
! CHECK: fir.result %[[VAL_39]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTtb{ip:!fir.box<!fir.ptr<!fir.array<?x?xi32>>>}>>
! CHECK: }
! CHECK: fir.array_merge_store %[[VAL_11]], %[[VAL_40:.*]] to %[[VAL_1]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTtb{ip:!fir.box<!fir.ptr<!fir.array<?x?xi32>>>}>>, !fir.array<?x!fir.type<_QMarray_of_pointer_testTtb{ip:!fir.box<!fir.ptr<!fir.array<?x?xi32>>>}>>, !fir.box<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtb{ip:!fir.box<!fir.ptr<!fir.array<?x?xi32>>>}>>>
! 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.array<?x!fir.type<_QMarray_of_pointer_testTtv{jp:!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>>>}>>> {fir.bindc_name = "x"},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.box<!fir.array<?xi32>> {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<?x!fir.type<_QMarray_of_pointer_testTtv{jp:!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>>>}>>>) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTtv{jp:!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>>>}>>
! CHECK: %[[VAL_16:.*]] = fir.array_load %[[VAL_1]] : (!fir.box<!fir.array<?xi32>>) -> !fir.array<?xi32>
! 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<?x!fir.type<_QMarray_of_pointer_testTtv{jp:!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>>>}>>) {
! CHECK: %[[VAL_20:.*]] = fir.convert %[[VAL_18]] : (index) -> i32
! CHECK: fir.store %[[VAL_20]] to %[[VAL_3]] : !fir.ref<i32>
! 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<?x!fir.type<_QMarray_of_pointer_testTtv{jp:!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>>>}>>) {
! CHECK: %[[VAL_24:.*]] = fir.convert %[[VAL_22]] : (index) -> i32
! CHECK: fir.store %[[VAL_24]] to %[[VAL_2]] : !fir.ref<i32>
! CHECK: %[[VAL_25:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_26:.*]] = fir.load %[[VAL_3]] : !fir.ref<i32>
! 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<?xi32>, index) -> i32
! CHECK: %[[VAL_31:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_32:.*]] = fir.load %[[VAL_3]] : !fir.ref<i32>
! 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<!fir.ptr<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>>>}>
! CHECK: %[[VAL_37:.*]] = fir.load %[[VAL_2]] : !fir.ref<i32>
! 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<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>
! 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<?x!fir.type<_QMarray_of_pointer_testTtv{jp:!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>>>}>>, index, !fir.field) -> !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>>>>
! CHECK: %[[VAL_44:.*]] = fir.load %[[VAL_43]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>>>>
! CHECK: %[[VAL_45:.*]] = fir.coordinate_of %[[VAL_44]], %[[VAL_40]] : (!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>>>, index) -> !fir.ref<!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>
! CHECK: %[[VAL_46:.*]] = fir.coordinate_of %[[VAL_45]], %[[VAL_41]] : (!fir.ref<!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>, !fir.field) -> !fir.ref<!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>>
! CHECK: %[[VAL_47:.*]] = fir.load %[[VAL_46]] : !fir.ref<!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>>
! CHECK: %[[VAL_48:.*]] = fir.coordinate_of %[[VAL_47]], %[[VAL_42]] : (!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>, !fir.field) -> !fir.ref<i32>
! CHECK: fir.store %[[VAL_30]] to %[[VAL_48]] : !fir.ref<i32>
! CHECK: %[[VAL_49:.*]] = fir.array_amend %[[VAL_23]], %[[VAL_43]] : (!fir.array<?x!fir.type<_QMarray_of_pointer_testTtv{jp:!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>>>}>>, !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>>>>) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTtv{jp:!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>>>}>>
! CHECK: fir.result %[[VAL_49]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTtv{jp:!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>>>}>>
! CHECK: }
! CHECK: fir.result %[[VAL_50:.*]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTtv{jp:!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>>>}>>
! CHECK: }
! CHECK: fir.array_merge_store %[[VAL_15]], %[[VAL_51:.*]] to %[[VAL_0]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTtv{jp:!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>>>}>>, !fir.array<?x!fir.type<_QMarray_of_pointer_testTtv{jp:!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>>>}>>, !fir.box<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtv{jp:!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QMarray_of_pointer_testTtu{ip:!fir.box<!fir.ptr<!fir.type<_QMarray_of_pointer_testTu{v:i32}>>>}>>>>}>>>
! 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.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>> {fir.bindc_name = "x"},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.box<!fir.array<?xi32>> {fir.bindc_name = "y", fir.target},
! CHECK-SAME: %[[VAL_2:.*]]: !fir.ref<i32> {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<i32>
! 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<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>>) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>
! CHECK: %[[VAL_10:.*]] = fir.array_load %[[VAL_1]] : (!fir.box<!fir.array<?xi32>>) -> !fir.array<?xi32>
! 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<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>) {
! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_12]] : (index) -> i32
! CHECK: fir.store %[[VAL_14]] to %[[VAL_3]] : !fir.ref<i32>
! CHECK: %[[VAL_15:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_16:.*]] = fir.load %[[VAL_2]] : !fir.ref<i32>
! 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<i32>
! 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<!fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>>, i64) -> !fir.ref<!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>
! CHECK: %[[VAL_25:.*]] = fir.field_index ip, !fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>
! CHECK: %[[VAL_26:.*]] = fir.coordinate_of %[[VAL_24]], %[[VAL_25]] : (!fir.ref<!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, !fir.field) -> !fir.ref<!fir.box<!fir.ptr<i32>>>
! CHECK: %[[VAL_27:.*]] = fir.load %[[VAL_26]] : !fir.ref<!fir.box<!fir.ptr<i32>>>
! CHECK: %[[VAL_28:.*]] = fir.box_addr %[[VAL_27]] : (!fir.box<!fir.ptr<i32>>) -> !fir.ptr<i32>
! CHECK: %[[VAL_29:.*]] = fir.load %[[VAL_28]] : !fir.ptr<i32>
! 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<?xi32>, index) -> !fir.ref<i32>
! CHECK: %[[VAL_34:.*]] = fir.convert %[[VAL_33]] : (!fir.ref<i32>) -> !fir.ptr<i32>
! CHECK: %[[VAL_35:.*]] = fir.embox %[[VAL_34]] : (!fir.ptr<i32>) -> !fir.box<!fir.ptr<i32>>
! CHECK: %[[VAL_36:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_37:.*]] = fir.load %[[VAL_3]] : !fir.ref<i32>
! 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<!fir.ptr<i32>>}>
! CHECK: %[[VAL_42:.*]] = fir.array_update %[[VAL_13]], %[[VAL_35]], %[[VAL_40]], %[[VAL_41]] : (!fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, !fir.box<!fir.ptr<i32>>, index, !fir.field) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>
! CHECK: fir.result %[[VAL_42]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>
! CHECK: }
! CHECK: fir.array_merge_store %[[VAL_9]], %[[VAL_43:.*]] to %[[VAL_0]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, !fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>, !fir.box<!fir.array<?x!fir.type<_QMarray_of_pointer_testTt{ip:!fir.box<!fir.ptr<i32>>}>>>
! 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.array<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>> {fir.bindc_name = "x"},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>> {fir.bindc_name = "y"},
! CHECK-SAME: %[[VAL_2:.*]]: !fir.ref<i32> {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<i32>
! 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<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>>) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>
! CHECK: %[[VAL_10:.*]] = fir.load %[[VAL_1]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>
! CHECK: %[[VAL_11:.*]] = arith.constant 0 : index
! CHECK: %[[VAL_12:.*]]:3 = fir.box_dims %[[VAL_10]], %[[VAL_11]] : (!fir.box<!fir.ptr<!fir.array<?xi32>>>, 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<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>) {
! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_15]] : (index) -> i32
! CHECK: fir.store %[[VAL_17]] to %[[VAL_3]] : !fir.ref<i32>
! CHECK: %[[VAL_18:.*]] = fir.load %[[VAL_3]] : !fir.ref<i32>
! CHECK: %[[VAL_19:.*]] = fir.convert %[[VAL_18]] : (i32) -> i64
! CHECK: %[[VAL_20:.*]] = fir.rebox %[[VAL_10]](%[[VAL_13]]) : (!fir.box<!fir.ptr<!fir.array<?xi32>>>, !fir.shift<1>) -> !fir.box<!fir.ptr<!fir.array<?xi32>>>
! CHECK: %[[VAL_21:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_22:.*]] = fir.load %[[VAL_3]] : !fir.ref<i32>
! 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<!fir.ptr<!fir.array<?xi32>>>}>
! CHECK: %[[VAL_27:.*]] = fir.shift %[[VAL_19]] : (i64) -> !fir.shift<1>
! CHECK: %[[VAL_28:.*]] = fir.rebox %[[VAL_20]](%[[VAL_27]]) : (!fir.box<!fir.ptr<!fir.array<?xi32>>>, !fir.shift<1>) -> !fir.box<!fir.ptr<!fir.array<?xi32>>>
! CHECK: %[[VAL_29:.*]] = fir.array_update %[[VAL_16]], %[[VAL_28]], %[[VAL_25]], %[[VAL_26]] : (!fir.array<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>, !fir.box<!fir.ptr<!fir.array<?xi32>>>, index, !fir.field) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>
! CHECK: fir.result %[[VAL_29]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>
! CHECK: }
! CHECK: fir.array_merge_store %[[VAL_9]], %[[VAL_30:.*]] to %[[VAL_0]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>, !fir.array<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>, !fir.box<!fir.array<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>>
! 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.array<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>> {fir.bindc_name = "x"},
! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>> {fir.bindc_name = "y"},
! CHECK-SAME: %[[VAL_2:.*]]: !fir.ref<i32> {fir.bindc_name = "n1"},
! CHECK-SAME: %[[VAL_3:.*]]: !fir.ref<i32> {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<i32>
! 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<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>>) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>
! CHECK: %[[VAL_11:.*]] = fir.load %[[VAL_1]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>
! CHECK: %[[VAL_12:.*]] = arith.constant 0 : index
! CHECK: %[[VAL_13:.*]]:3 = fir.box_dims %[[VAL_11]], %[[VAL_12]] : (!fir.box<!fir.ptr<!fir.array<?xi32>>>, 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<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>) {
! CHECK: %[[VAL_18:.*]] = fir.convert %[[VAL_16]] : (index) -> i32
! CHECK: fir.store %[[VAL_18]] to %[[VAL_4]] : !fir.ref<i32>
! CHECK: %[[VAL_19:.*]] = fir.load %[[VAL_4]] : !fir.ref<i32>
! CHECK: %[[VAL_20:.*]] = fir.convert %[[VAL_19]] : (i32) -> i64
! CHECK: %[[VAL_21:.*]] = fir.load %[[VAL_3]] : !fir.ref<i32>
! 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<i32>
! 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.ptr<!fir.array<?xi32>>>, !fir.shift<1>) -> !fir.box<!fir.ptr<!fir.array<?xi32>>>
! CHECK: %[[VAL_28:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_29:.*]] = fir.load %[[VAL_4]] : !fir.ref<i32>
! 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<!fir.ptr<!fir.array<?xi32>>>}>
! 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.ptr<!fir.array<?xi32>>>, !fir.shapeshift<1>) -> !fir.box<!fir.ptr<!fir.array<?xi32>>>
! CHECK: %[[VAL_36:.*]] = fir.array_update %[[VAL_17]], %[[VAL_35]], %[[VAL_32]], %[[VAL_33]] : (!fir.array<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>, !fir.box<!fir.ptr<!fir.array<?xi32>>>, index, !fir.field) -> !fir.array<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>
! CHECK: fir.result %[[VAL_36]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>
! CHECK: }
! CHECK: fir.array_merge_store %[[VAL_10]], %[[VAL_37:.*]] to %[[VAL_0]] : !fir.array<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>, !fir.array<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>, !fir.box<!fir.array<?x!fir.type<_QMarray_of_pointer_testTta{ip:!fir.box<!fir.ptr<!fir.array<?xi32>>>}>>>
! 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

74
flang/test/Lower/forall/forall-2.f90
View File

@ -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<!fir.array<?x!fir.type<_QFimplied_iters_allocatableTt{oui:!fir.logical<4>,arr:!fir.box<!fir.heap<!fir.array<?xf32>>>}>>>{{.*}}, %[[VAL_1:.*]]: !fir.box<!fir.array<?xf32>>{{.*}}) {
! 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 @@ subroutine implied_iters_allocatable(thing, a1)
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<!fir.array<?x!fir.type<_QFconflicting_allocatableTt{oui:!fir.logical<4>,arr:!fir.box<!fir.heap<!fir.array<?xf32>>>}>>>{{.*}}, %[[VAL_1:.*]]: !fir.ref<i32>{{.*}}, %[[VAL_2:.*]]: !fir.ref<i32>{{.*}}) {
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 @@ subroutine conflicting_allocatable(thing, lo, hi)
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<!fir.array<?x!fir.type<_QFforall_pointer_assignTt{ptr:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>>{{.*}}, %[[VAL_1:.*]]: !fir.box<!fir.array<?x!fir.type<_QFforall_pointer_assignTu{targ:!fir.array<20xf32>}>>> {fir.bindc_name = "at", fir.target}, %[[VAL_2:.*]]: !fir.ref<i32>{{.*}}, %[[VAL_3:.*]]: !fir.ref<i32>{{.*}}) {
! CHECK-SAME: %[[VAL_0:.*]]: !fir.box<!fir.array<?x!fir.type<_QFforall_pointer_assignTt{ptr:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>> {fir.bindc_name = "ap"}, %[[VAL_1:.*]]: !fir.ref<f32> {fir.bindc_name = "at"}, %[[VAL_2:.*]]: !fir.ref<i32> {fir.bindc_name = "ii"}, %[[VAL_3:.*]]: !fir.ref<i32> {fir.bindc_name = "ij"}) {
! CHECK: %[[VAL_4:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "i"}
! CHECK: %[[VAL_5:.*]] = fir.load %[[VAL_2]] : !fir.ref<i32>
! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i32) -> index
! CHECK: %[[VAL_7:.*]] = fir.load %[[VAL_3]] : !fir.ref<i32>
! 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<?x!fir.type<_QFforall_pointer_assignTt{ptr:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>>) -> !fir.array<?x!fir.type<_QFforall_pointer_assignTt{ptr:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>
! CHECK: %[[VAL_12:.*]] = fir.array_load %[[VAL_0]] : (!fir.box<!fir.array<?x!fir.type<_QFforall_pointer_assignTt{ptr:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>>) -> !fir.array<?x!fir.type<_QFforall_pointer_assignTt{ptr:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>
! 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<?x!fir.type<_QFforall_pointer_assignTt{ptr:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>) {
! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_14]] : (index) -> i32
! CHECK: fir.store %[[VAL_16]] to %[[VAL_4]] : !fir.ref<i32>
! 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<i32>
! 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<!fir.ptr<!fir.array<?xf32>>>}>
! CHECK: %[[VAL_25:.*]] = fir.array_fetch %[[VAL_12]], %[[VAL_23]], %[[VAL_24]] : (!fir.array<?x!fir.type<_QFforall_pointer_assignTt{ptr:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>, index, !fir.field) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
! CHECK: %[[VAL_26:.*]] = arith.constant 1 : index
! CHECK: %[[VAL_27:.*]] = fir.load %[[VAL_4]] : !fir.ref<i32>
! 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<!fir.ptr<!fir.array<?xf32>>>}>
! CHECK: %[[VAL_32:.*]] = fir.array_update %[[VAL_15]], %[[VAL_25]], %[[VAL_30]], %[[VAL_31]] : (!fir.array<?x!fir.type<_QFforall_pointer_assignTt{ptr:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>, !fir.box<!fir.ptr<!fir.array<?xf32>>>, index, !fir.field) -> !fir.array<?x!fir.type<_QFforall_pointer_assignTt{ptr:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>
! CHECK: fir.result %[[VAL_32]] : !fir.array<?x!fir.type<_QFforall_pointer_assignTt{ptr:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>
! CHECK: }
! CHECK: fir.array_merge_store %[[VAL_11]], %[[VAL_33:.*]] to %[[VAL_0]] : !fir.array<?x!fir.type<_QFforall_pointer_assignTt{ptr:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>, !fir.array<?x!fir.type<_QFforall_pointer_assignTt{ptr:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>, !fir.box<!fir.array<?x!fir.type<_QFforall_pointer_assignTt{ptr:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>>
! CHECK: return
! CHECK: }
! POSTOPT-LABEL: func @_QPforall_pointer_assign(
! POSTOPT: %[[VAL_15:.*]] = fir.allocmem !fir.array<?x!fir.type<_QFforall_pointer_assignTt{ptr:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>, %{{.*}}#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<!fir.array<?x!fir.type<_QFforall_pointer_assignTt{ptr:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>>
! 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() {

12
flang/unittests/Optimizer/Builder/FIRBuilderTest.cpp
View File

@ -404,7 +404,7 @@ TEST_F(FIRBuilderTest, getExtents) {
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 @@ TEST_F(FIRBuilderTest, getExtents) {
mlir::Value array = builder.create<fir::UndefOp>(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 @@ TEST_F(FIRBuilderTest, getBaseTypeOf) {
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 @@ TEST_F(FIRBuilderTest, getBaseTypeOf) {
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));
}
}