[flang-commits] [flang] f9704f0 - [flang] Simple array assignment lowering
Valentin Clement via flang-commits
flang-commits at lists.llvm.org
Thu Feb 24 12:23:50 PST 2022
Author: Valentin Clement
Date: 2022-02-24T21:23:30+01:00
New Revision: f9704f0cfb7a9edb86c0755bafef54cbd365743d
URL: https://github.com/llvm/llvm-project/commit/f9704f0cfb7a9edb86c0755bafef54cbd365743d
DIFF: https://github.com/llvm/llvm-project/commit/f9704f0cfb7a9edb86c0755bafef54cbd365743d.diff
LOG: [flang] Simple array assignment lowering
This patch handles lowering of simple array assignment.
```
a(:) = 10
```
or
```
a(1) = 1
```
This patch is part of the upstreaming effort from fir-dev branch.
Reviewed By: PeteSteinfeld, schweitz
Differential Revision: https://reviews.llvm.org/D120501
Co-authored-by: Jean Perier <jperier at nvidia.com>
Co-authored-by: V Donaldson <vdonaldson at nvidia.com>
Co-authored-by: Eric Schweitz <eschweitz at nvidia.com>
Added:
flang/include/flang/Lower/ComponentPath.h
flang/include/flang/Lower/DumpEvaluateExpr.h
flang/include/flang/Lower/IterationSpace.h
flang/lib/Lower/ComponentPath.cpp
flang/lib/Lower/DumpEvaluateExpr.cpp
flang/lib/Lower/IterationSpace.cpp
Modified:
flang/include/flang/Evaluate/variable.h
flang/include/flang/Lower/ConvertExpr.h
flang/include/flang/Optimizer/Builder/FIRBuilder.h
flang/include/flang/Optimizer/Builder/Factory.h
flang/lib/Lower/Bridge.cpp
flang/lib/Lower/CMakeLists.txt
flang/lib/Lower/CallInterface.cpp
flang/lib/Lower/ConvertExpr.cpp
flang/lib/Lower/ConvertVariable.cpp
flang/lib/Optimizer/Builder/FIRBuilder.cpp
flang/test/Lower/assignment.f90
flang/test/Lower/basic-function.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/variable.h b/flang/include/flang/Evaluate/variable.h
index 5f5e7e1911c6b..0a689473cfc9c 100644
--- a/flang/include/flang/Evaluate/variable.h
+++ b/flang/include/flang/Evaluate/variable.h
@@ -160,10 +160,17 @@ class Triplet {
std::optional<Expr<SubscriptInteger>> &&);
std::optional<Expr<SubscriptInteger>> lower() const;
+ const Expr<SubscriptInteger> *GetLower() const {
+ return lower_.has_value() ? &lower_->value() : nullptr;
+ }
Triplet &set_lower(Expr<SubscriptInteger> &&);
std::optional<Expr<SubscriptInteger>> upper() const;
+ const Expr<SubscriptInteger> *GetUpper() const {
+ return upper_.has_value() ? &upper_->value() : nullptr;
+ }
Triplet &set_upper(Expr<SubscriptInteger> &&);
Expr<SubscriptInteger> stride() const; // N.B. result is not optional<>
+ const Expr<SubscriptInteger> &GetStride() const { return stride_.value(); }
Triplet &set_stride(Expr<SubscriptInteger> &&);
bool operator==(const Triplet &) const;
diff --git a/flang/include/flang/Lower/ComponentPath.h b/flang/include/flang/Lower/ComponentPath.h
new file mode 100644
index 0000000000000..951474287f33a
--- /dev/null
+++ b/flang/include/flang/Lower/ComponentPath.h
@@ -0,0 +1,70 @@
+//===-- ComponentPath.h -----------------------------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_LOWER_COMPONENTPATH_H
+#define FORTRAN_LOWER_COMPONENTPATH_H
+
+#include "flang/Lower/IterationSpace.h"
+#include "llvm/ADT/SmallVector.h"
+
+namespace fir {
+class ArrayLoadOp;
+}
+namespace Fortran::evaluate {
+class ArrayRef;
+}
+
+namespace Fortran::lower {
+
+namespace details {
+class ImplicitSubscripts {};
+} // namespace details
+
+using PathComponent =
+ std::variant<const evaluate::ArrayRef *, const evaluate::Component *,
+ const Fortran::evaluate::ComplexPart *,
+ details::ImplicitSubscripts>;
+
+/// Collection of components.
+///
+/// This class is used both to collect front-end post-order functional Expr
+/// trees and their translations to Values to be used in a pre-order list of
+/// arguments.
+class ComponentPath {
+public:
+ ComponentPath(bool isImplicit) { setPC(isImplicit); }
+ ComponentPath(bool isImplicit, const evaluate::Substring *ss)
+ : substring(ss) {
+ setPC(isImplicit);
+ }
+ ComponentPath() = delete;
+
+ bool isSlice() { return !trips.empty() || hasComponents(); }
+ bool hasComponents() { return !suffixComponents.empty(); }
+ void clear();
+
+ llvm::SmallVector<PathComponent> reversePath;
+ const evaluate::Substring *substring = nullptr;
+ bool applied = false;
+
+ llvm::SmallVector<mlir::Value> prefixComponents;
+ llvm::SmallVector<mlir::Value> trips;
+ llvm::SmallVector<mlir::Value> suffixComponents;
+ std::function<IterationSpace(const IterationSpace &)> pc;
+
+private:
+ void setPC(bool isImplicit);
+};
+
+/// Examine each subscript expression of \p x and return true if and only if any
+/// of the subscripts is a vector or has a rank greater than 0.
+bool isRankedArrayAccess(const Fortran::evaluate::ArrayRef &x);
+
+} // namespace Fortran::lower
+
+#endif // FORTRAN_LOWER_COMPONENTPATH_H
diff --git a/flang/include/flang/Lower/ConvertExpr.h b/flang/include/flang/Lower/ConvertExpr.h
index c26cf72fee20b..47d4fd2e136a7 100644
--- a/flang/include/flang/Lower/ConvertExpr.h
+++ b/flang/include/flang/Lower/ConvertExpr.h
@@ -36,6 +36,10 @@ namespace Fortran::lower {
class AbstractConverter;
class StatementContext;
class SymMap;
+class ExplicitIterSpace;
+class ImplicitIterSpace;
+class StatementContext;
+
using SomeExpr = Fortran::evaluate::Expr<Fortran::evaluate::SomeType>;
/// Create an extended expression value.
@@ -67,6 +71,44 @@ mlir::Value createSubroutineCall(AbstractConverter &converter,
const evaluate::ProcedureRef &call,
SymMap &symMap, StatementContext &stmtCtx);
+/// Create the address of the box.
+/// \p expr must be the designator of an allocatable/pointer entity.
+fir::MutableBoxValue createMutableBox(mlir::Location loc,
+ AbstractConverter &converter,
+ const SomeExpr &expr, SymMap &symMap);
+
+/// Lower an array assignment expression.
+///
+/// 1. Evaluate the lhs to determine the rank and how to form the ArrayLoad
+/// (e.g., if there is a slicing op).
+/// 2. Scan the rhs, creating the ArrayLoads and evaluate the scalar subparts to
+/// be added to the map.
+/// 3. Create the loop nest and evaluate the elemental expression, threading the
+/// results.
+/// 4. Copy the resulting array back with ArrayMergeStore to the lhs as
+/// determined per step 1.
+void createSomeArrayAssignment(AbstractConverter &converter,
+ const SomeExpr &lhs, const SomeExpr &rhs,
+ SymMap &symMap, StatementContext &stmtCtx);
+
+/// Lower an array assignment expression with pre-evaluated left and right
+/// hand sides. This implements an array copy taking into account
+/// non-contiguity and potential overlaps.
+void createSomeArrayAssignment(AbstractConverter &converter,
+ const fir::ExtendedValue &lhs,
+ const fir::ExtendedValue &rhs, SymMap &symMap,
+ StatementContext &stmtCtx);
+
+/// 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.
+void createAllocatableArrayAssignment(AbstractConverter &converter,
+ const SomeExpr &lhs, const SomeExpr &rhs,
+ ExplicitIterSpace &explicitIterSpace,
+ ImplicitIterSpace &implicitIterSpace,
+ SymMap &symMap,
+ StatementContext &stmtCtx);
+
// Attribute for an alloca that is a trivial adaptor for converting a value to
// pass-by-ref semantics for a VALUE parameter. The optimizer may be able to
// eliminate these.
diff --git a/flang/include/flang/Lower/DumpEvaluateExpr.h b/flang/include/flang/Lower/DumpEvaluateExpr.h
new file mode 100644
index 0000000000000..c67df245359e3
--- /dev/null
+++ b/flang/include/flang/Lower/DumpEvaluateExpr.h
@@ -0,0 +1,212 @@
+//===-- Lower/DumpEvaluateExpr.h --------------------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_LOWER_DUMPEVALUATEEXPR_H
+#define FORTRAN_LOWER_DUMPEVALUATEEXPR_H
+
+#include "flang/Evaluate/tools.h"
+#include "flang/Lower/Support/Utils.h"
+#include "llvm/ADT/StringRef.h"
+#include "llvm/ADT/Twine.h"
+
+namespace Fortran::lower {
+
+/// Class to dump Fortran::evaluate::Expr trees out in a user readable way.
+///
+/// FIXME: This can be improved to dump more information in some cases.
+class DumpEvaluateExpr {
+public:
+ DumpEvaluateExpr() : outs(llvm::errs()) {}
+ DumpEvaluateExpr(llvm::raw_ostream &str) : outs(str) {}
+
+ template <typename A>
+ static void dump(const A &x) {
+ DumpEvaluateExpr{}.show(x);
+ }
+ template <typename A>
+ static void dump(llvm::raw_ostream &stream, const A &x) {
+ DumpEvaluateExpr{stream}.show(x);
+ }
+
+private:
+ template <typename A, bool C>
+ void show(const Fortran::common::Indirection<A, C> &x) {
+ show(x.value());
+ }
+ template <typename A>
+ void show(const Fortran::semantics::SymbolRef x) {
+ show(*x);
+ }
+ template <typename A>
+ void show(const std::unique_ptr<A> &x) {
+ show(x.get());
+ }
+ template <typename A>
+ void show(const std::shared_ptr<A> &x) {
+ show(x.get());
+ }
+ template <typename A>
+ void show(const A *x) {
+ if (x) {
+ show(*x);
+ return;
+ }
+ print("nullptr");
+ }
+ template <typename A>
+ void show(const std::optional<A> &x) {
+ if (x) {
+ show(*x);
+ return;
+ }
+ print("None");
+ }
+ template <typename... A>
+ void show(const std::variant<A...> &u) {
+ std::visit([&](const auto &v) { show(v); }, u);
+ }
+ template <typename A>
+ void show(const std::vector<A> &x) {
+ indent("vector");
+ for (const auto &v : x)
+ show(v);
+ outdent();
+ }
+ void show(const Fortran::evaluate::BOZLiteralConstant &);
+ void show(const Fortran::evaluate::NullPointer &);
+ template <typename T>
+ void show(const Fortran::evaluate::Constant<T> &x) {
+ if constexpr (T::category == Fortran::common::TypeCategory::Derived) {
+ indent("derived constant");
+ for (const auto &map : x.values())
+ for (const auto &pair : map)
+ show(pair.second.value());
+ outdent();
+ } else {
+ print("constant");
+ }
+ }
+ void show(const Fortran::semantics::Symbol &symbol);
+ void show(const Fortran::evaluate::StaticDataObject &);
+ void show(const Fortran::evaluate::ImpliedDoIndex &);
+ void show(const Fortran::evaluate::BaseObject &x);
+ void show(const Fortran::evaluate::Component &x);
+ void show(const Fortran::evaluate::NamedEntity &x);
+ void show(const Fortran::evaluate::TypeParamInquiry &x);
+ void show(const Fortran::evaluate::Triplet &x);
+ void show(const Fortran::evaluate::Subscript &x);
+ void show(const Fortran::evaluate::ArrayRef &x);
+ void show(const Fortran::evaluate::CoarrayRef &x);
+ void show(const Fortran::evaluate::DataRef &x);
+ void show(const Fortran::evaluate::Substring &x);
+ void show(const Fortran::evaluate::ComplexPart &x);
+ template <typename T>
+ void show(const Fortran::evaluate::Designator<T> &x) {
+ indent("designator");
+ show(x.u);
+ outdent();
+ }
+ template <typename T>
+ void show(const Fortran::evaluate::Variable<T> &x) {
+ indent("variable");
+ show(x.u);
+ outdent();
+ }
+ void show(const Fortran::evaluate::DescriptorInquiry &x);
+ void show(const Fortran::evaluate::SpecificIntrinsic &);
+ void show(const Fortran::evaluate::ProcedureDesignator &x);
+ void show(const Fortran::evaluate::ActualArgument &x);
+ void show(const Fortran::evaluate::ProcedureRef &x) {
+ indent("procedure ref");
+ show(x.proc());
+ show(x.arguments());
+ outdent();
+ }
+ template <typename T>
+ void show(const Fortran::evaluate::FunctionRef<T> &x) {
+ indent("function ref");
+ show(x.proc());
+ show(x.arguments());
+ outdent();
+ }
+ template <typename T>
+ void show(const Fortran::evaluate::ArrayConstructorValue<T> &x) {
+ show(x.u);
+ }
+ template <typename T>
+ void show(const Fortran::evaluate::ArrayConstructorValues<T> &x) {
+ indent("array constructor value");
+ for (auto &v : x)
+ show(v);
+ outdent();
+ }
+ template <typename T>
+ void show(const Fortran::evaluate::ImpliedDo<T> &x) {
+ indent("implied do");
+ show(x.lower());
+ show(x.upper());
+ show(x.stride());
+ show(x.values());
+ outdent();
+ }
+ void show(const Fortran::semantics::ParamValue &x);
+ void
+ show(const Fortran::semantics::DerivedTypeSpec::ParameterMapType::value_type
+ &x);
+ void show(const Fortran::semantics::DerivedTypeSpec &x);
+ void show(const Fortran::evaluate::StructureConstructorValues::value_type &x);
+ void show(const Fortran::evaluate::StructureConstructor &x);
+ template <typename D, typename R, typename O>
+ void show(const Fortran::evaluate::Operation<D, R, O> &op) {
+ indent("unary op");
+ show(op.left());
+ outdent();
+ }
+ template <typename D, typename R, typename LO, typename RO>
+ void show(const Fortran::evaluate::Operation<D, R, LO, RO> &op) {
+ indent("binary op");
+ show(op.left());
+ show(op.right());
+ outdent();
+ }
+ void
+ show(const Fortran::evaluate::Relational<Fortran::evaluate::SomeType> &x);
+ template <typename T>
+ void show(const Fortran::evaluate::Expr<T> &x) {
+ indent("expr T");
+ show(x.u);
+ outdent();
+ }
+
+ const char *getIndentString() const;
+ void print(llvm::Twine s);
+ void indent(llvm::StringRef s);
+ void outdent();
+
+ llvm::raw_ostream &outs;
+ unsigned level = 0;
+};
+
+LLVM_DUMP_METHOD void
+dumpEvExpr(const Fortran::evaluate::Expr<Fortran::evaluate::SomeType> &x);
+LLVM_DUMP_METHOD void dumpEvExpr(
+ const Fortran::evaluate::Expr<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer, 4>> &x);
+LLVM_DUMP_METHOD void dumpEvExpr(
+ const Fortran::evaluate::Expr<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer, 8>> &x);
+LLVM_DUMP_METHOD void dumpEvExpr(const Fortran::evaluate::ArrayRef &x);
+LLVM_DUMP_METHOD void dumpEvExpr(const Fortran::evaluate::DataRef &x);
+LLVM_DUMP_METHOD void dumpEvExpr(const Fortran::evaluate::Substring &x);
+LLVM_DUMP_METHOD void dumpEvExpr(
+ const Fortran::evaluate::Designator<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer, 4>> &x);
+
+} // namespace Fortran::lower
+
+#endif // FORTRAN_LOWER_DUMPEVALUATEEXPR_H
diff --git a/flang/include/flang/Lower/IterationSpace.h b/flang/include/flang/Lower/IterationSpace.h
new file mode 100644
index 0000000000000..4c6f3a1fe1ca4
--- /dev/null
+++ b/flang/include/flang/Lower/IterationSpace.h
@@ -0,0 +1,587 @@
+//===-- IterationSpace.h ----------------------------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+//
+// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_LOWER_ITERATIONSPACE_H
+#define FORTRAN_LOWER_ITERATIONSPACE_H
+
+#include "flang/Evaluate/tools.h"
+#include "flang/Lower/StatementContext.h"
+#include "flang/Lower/SymbolMap.h"
+#include "flang/Optimizer/Builder/FIRBuilder.h"
+
+namespace llvm {
+class raw_ostream;
+}
+
+namespace Fortran {
+namespace evaluate {
+struct SomeType;
+template <typename>
+class Expr;
+} // namespace evaluate
+
+namespace lower {
+
+using FrontEndExpr = const evaluate::Expr<evaluate::SomeType> *;
+using FrontEndSymbol = const semantics::Symbol *;
+
+class AbstractConverter;
+
+unsigned getHashValue(FrontEndExpr x);
+bool isEqual(FrontEndExpr x, FrontEndExpr y);
+} // namespace lower
+} // namespace Fortran
+
+namespace llvm {
+template <>
+struct DenseMapInfo<Fortran::lower::FrontEndExpr> {
+ static inline Fortran::lower::FrontEndExpr getEmptyKey() {
+ return reinterpret_cast<Fortran::lower::FrontEndExpr>(~0);
+ }
+ static inline Fortran::lower::FrontEndExpr getTombstoneKey() {
+ return reinterpret_cast<Fortran::lower::FrontEndExpr>(~0 - 1);
+ }
+ static unsigned getHashValue(Fortran::lower::FrontEndExpr v) {
+ return Fortran::lower::getHashValue(v);
+ }
+ static bool isEqual(Fortran::lower::FrontEndExpr lhs,
+ Fortran::lower::FrontEndExpr rhs) {
+ return Fortran::lower::isEqual(lhs, rhs);
+ }
+};
+} // namespace llvm
+
+namespace Fortran::lower {
+
+/// Abstraction of the iteration space for building the elemental compute loop
+/// of an array(-like) statement.
+class IterationSpace {
+public:
+ IterationSpace() = default;
+
+ template <typename A>
+ explicit IterationSpace(mlir::Value inArg, mlir::Value outRes,
+ llvm::iterator_range<A> range)
+ : inArg{inArg}, outRes{outRes}, indices{range.begin(), range.end()} {}
+
+ explicit IterationSpace(const IterationSpace &from,
+ llvm::ArrayRef<mlir::Value> idxs)
+ : inArg(from.inArg), outRes(from.outRes), element(from.element),
+ indices(idxs.begin(), idxs.end()) {}
+
+ /// Create a copy of the \p from IterationSpace and prepend the \p prefix
+ /// values and append the \p suffix values, respectively.
+ explicit IterationSpace(const IterationSpace &from,
+ llvm::ArrayRef<mlir::Value> prefix,
+ llvm::ArrayRef<mlir::Value> suffix)
+ : inArg(from.inArg), outRes(from.outRes), element(from.element) {
+ indices.assign(prefix.begin(), prefix.end());
+ indices.append(from.indices.begin(), from.indices.end());
+ indices.append(suffix.begin(), suffix.end());
+ }
+
+ bool empty() const { return indices.empty(); }
+
+ /// This is the output value as it appears as an argument in the innermost
+ /// loop in the nest. The output value is threaded through the loop (and
+ /// conditionals) to maintain proper SSA form.
+ mlir::Value innerArgument() const { return inArg; }
+
+ /// This is the output value as it appears as an output value from the
+ /// outermost loop in the loop nest. The output value is threaded through the
+ /// loop (and conditionals) to maintain proper SSA form.
+ mlir::Value outerResult() const { return outRes; }
+
+ /// Returns a vector for the iteration space. This vector is used to access
+ /// elements of arrays in the compute loop.
+ llvm::SmallVector<mlir::Value> iterVec() const { return indices; }
+
+ mlir::Value iterValue(std::size_t i) const {
+ assert(i < indices.size());
+ return indices[i];
+ }
+
+ /// Set (rewrite) the Value at a given index.
+ void setIndexValue(std::size_t i, mlir::Value v) {
+ assert(i < indices.size());
+ indices[i] = v;
+ }
+
+ void setIndexValues(llvm::ArrayRef<mlir::Value> vals) {
+ indices.assign(vals.begin(), vals.end());
+ }
+
+ void insertIndexValue(std::size_t i, mlir::Value av) {
+ assert(i <= indices.size());
+ indices.insert(indices.begin() + i, av);
+ }
+
+ /// Set the `element` value. This is the SSA value that corresponds to an
+ /// element of the resultant array value.
+ void setElement(fir::ExtendedValue &&ele) {
+ assert(!fir::getBase(element) && "result element already set");
+ element = ele;
+ }
+
+ /// Get the value that will be merged into the resultant array. This is the
+ /// computed value that will be stored to the lhs of the assignment.
+ mlir::Value getElement() const {
+ assert(fir::getBase(element) && "element must be set");
+ return fir::getBase(element);
+ }
+
+ /// Get the element as an extended value.
+ fir::ExtendedValue elementExv() const { return element; }
+
+ void clearIndices() { indices.clear(); }
+
+private:
+ mlir::Value inArg;
+ mlir::Value outRes;
+ fir::ExtendedValue element;
+ llvm::SmallVector<mlir::Value> indices;
+};
+
+using GenerateElementalArrayFunc =
+ std::function<fir::ExtendedValue(const IterationSpace &)>;
+
+template <typename A>
+class StackableConstructExpr {
+public:
+ bool empty() const { return stack.empty(); }
+
+ void growStack() { stack.push_back(A{}); }
+
+ /// Bind a front-end expression to a closure.
+ void bind(FrontEndExpr e, GenerateElementalArrayFunc &&fun) {
+ vmap.insert({e, std::move(fun)});
+ }
+
+ /// Replace the binding of front-end expression `e` with a new closure.
+ void rebind(FrontEndExpr e, GenerateElementalArrayFunc &&fun) {
+ vmap.erase(e);
+ bind(e, std::move(fun));
+ }
+
+ /// Get the closure bound to the front-end expression, `e`.
+ GenerateElementalArrayFunc getBoundClosure(FrontEndExpr e) const {
+ if (!vmap.count(e))
+ llvm::report_fatal_error(
+ "evaluate::Expr is not in the map of lowered mask expressions");
+ return vmap.lookup(e);
+ }
+
+ /// Has the front-end expression, `e`, been lowered and bound?
+ bool isLowered(FrontEndExpr e) const { return vmap.count(e); }
+
+ StatementContext &stmtContext() { return stmtCtx; }
+
+protected:
+ void shrinkStack() {
+ assert(!empty());
+ stack.pop_back();
+ if (empty()) {
+ stmtCtx.finalize();
+ vmap.clear();
+ }
+ }
+
+ // The stack for the construct information.
+ llvm::SmallVector<A> stack;
+
+ // Map each mask expression back to the temporary holding the initial
+ // evaluation results.
+ llvm::DenseMap<FrontEndExpr, GenerateElementalArrayFunc> vmap;
+
+ // Inflate the statement context for the entire construct. We have to cache
+ // the mask expression results, which are always evaluated first, across the
+ // entire construct.
+ StatementContext stmtCtx;
+};
+
+class ImplicitIterSpace;
+llvm::raw_ostream &operator<<(llvm::raw_ostream &, const ImplicitIterSpace &);
+
+/// All array expressions have an implicit iteration space, which is isomorphic
+/// to the shape of the base array that facilitates the expression having a
+/// non-zero rank. This implied iteration space may be conditionalized
+/// (disjunctively) with an if-elseif-else like structure, specifically
+/// Fortran's WHERE construct.
+///
+/// This class is used in the bridge to collect the expressions from the
+/// front end (the WHERE construct mask expressions), forward them for lowering
+/// as array expressions in an "evaluate once" (copy-in, copy-out) semantics.
+/// See 10.2.3.2p3, 10.2.3.2p13, etc.
+class ImplicitIterSpace
+ : public StackableConstructExpr<llvm::SmallVector<FrontEndExpr>> {
+public:
+ using Base = StackableConstructExpr<llvm::SmallVector<FrontEndExpr>>;
+ using FrontEndMaskExpr = FrontEndExpr;
+
+ friend llvm::raw_ostream &operator<<(llvm::raw_ostream &,
+ const ImplicitIterSpace &);
+
+ LLVM_DUMP_METHOD void dump() const;
+
+ void append(FrontEndMaskExpr e) {
+ assert(!empty());
+ getMasks().back().push_back(e);
+ }
+
+ llvm::SmallVector<FrontEndMaskExpr> getExprs() const {
+ llvm::SmallVector<FrontEndMaskExpr> maskList = getMasks()[0];
+ for (size_t i = 1, d = getMasks().size(); i < d; ++i)
+ maskList.append(getMasks()[i].begin(), getMasks()[i].end());
+ return maskList;
+ }
+
+ /// Add a variable binding, `var`, along with its shape for the mask
+ /// expression `exp`.
+ void addMaskVariable(FrontEndExpr exp, mlir::Value var, mlir::Value shape,
+ mlir::Value header) {
+ maskVarMap.try_emplace(exp, std::make_tuple(var, shape, header));
+ }
+
+ /// Lookup the variable corresponding to the temporary buffer that contains
+ /// the mask array expression results.
+ mlir::Value lookupMaskVariable(FrontEndExpr exp) {
+ return std::get<0>(maskVarMap.lookup(exp));
+ }
+
+ /// Lookup the variable containing the shape vector for the mask array
+ /// expression results.
+ mlir::Value lookupMaskShapeBuffer(FrontEndExpr exp) {
+ return std::get<1>(maskVarMap.lookup(exp));
+ }
+
+ mlir::Value lookupMaskHeader(FrontEndExpr exp) {
+ return std::get<2>(maskVarMap.lookup(exp));
+ }
+
+ // Stack of WHERE constructs, each building a list of mask expressions.
+ llvm::SmallVector<llvm::SmallVector<FrontEndMaskExpr>> &getMasks() {
+ return stack;
+ }
+ const llvm::SmallVector<llvm::SmallVector<FrontEndMaskExpr>> &
+ getMasks() const {
+ return stack;
+ }
+
+ // Cleanup at the end of a WHERE statement or construct.
+ void shrinkStack() {
+ Base::shrinkStack();
+ if (stack.empty())
+ maskVarMap.clear();
+ }
+
+private:
+ llvm::DenseMap<FrontEndExpr,
+ std::tuple<mlir::Value, mlir::Value, mlir::Value>>
+ maskVarMap;
+};
+
+class ExplicitIterSpace;
+llvm::raw_ostream &operator<<(llvm::raw_ostream &, const ExplicitIterSpace &);
+
+/// Create all the array_load ops for the explicit iteration space context. The
+/// nest of FORALLs must have been analyzed a priori.
+void createArrayLoads(AbstractConverter &converter, ExplicitIterSpace &esp,
+ SymMap &symMap);
+
+/// Create the array_merge_store ops after the explicit iteration space context
+/// is conmpleted.
+void createArrayMergeStores(AbstractConverter &converter,
+ ExplicitIterSpace &esp);
+using ExplicitSpaceArrayBases =
+ std::variant<FrontEndSymbol, const evaluate::Component *,
+ const evaluate::ArrayRef *>;
+
+unsigned getHashValue(const ExplicitSpaceArrayBases &x);
+bool isEqual(const ExplicitSpaceArrayBases &x,
+ const ExplicitSpaceArrayBases &y);
+
+} // namespace Fortran::lower
+
+namespace llvm {
+template <>
+struct DenseMapInfo<Fortran::lower::ExplicitSpaceArrayBases> {
+ static inline Fortran::lower::ExplicitSpaceArrayBases getEmptyKey() {
+ return reinterpret_cast<Fortran::lower::FrontEndSymbol>(~0);
+ }
+ static inline Fortran::lower::ExplicitSpaceArrayBases getTombstoneKey() {
+ return reinterpret_cast<Fortran::lower::FrontEndSymbol>(~0 - 1);
+ }
+ static unsigned
+ getHashValue(const Fortran::lower::ExplicitSpaceArrayBases &v) {
+ return Fortran::lower::getHashValue(v);
+ }
+ static bool isEqual(const Fortran::lower::ExplicitSpaceArrayBases &lhs,
+ const Fortran::lower::ExplicitSpaceArrayBases &rhs) {
+ return Fortran::lower::isEqual(lhs, rhs);
+ }
+};
+} // namespace llvm
+
+namespace Fortran::lower {
+/// Fortran also allows arrays to be evaluated under constructs which allow the
+/// user to explicitly specify the iteration space using concurrent-control
+/// expressions. These constructs allow the user to define both an iteration
+/// space and explicit access vectors on arrays. These need not be isomorphic.
+/// The explicit iteration spaces may be conditionalized (conjunctively) with an
+/// "and" structure and may be found in FORALL (and DO CONCURRENT) constructs.
+///
+/// This class is used in the bridge to collect a stack of lists of
+/// concurrent-control expressions to be used to generate the iteration space
+/// and associated masks (if any) for a set of nested FORALL constructs around
+/// assignment and WHERE constructs.
+class ExplicitIterSpace {
+public:
+ using IterSpaceDim =
+ std::tuple<FrontEndSymbol, FrontEndExpr, FrontEndExpr, FrontEndExpr>;
+ using ConcurrentSpec =
+ std::pair<llvm::SmallVector<IterSpaceDim>, FrontEndExpr>;
+ using ArrayBases = ExplicitSpaceArrayBases;
+
+ friend void createArrayLoads(AbstractConverter &converter,
+ ExplicitIterSpace &esp, SymMap &symMap);
+ friend void createArrayMergeStores(AbstractConverter &converter,
+ ExplicitIterSpace &esp);
+
+ /// Is a FORALL context presently active?
+ /// If we are lowering constructs/statements nested within a FORALL, then a
+ /// FORALL context is active.
+ bool isActive() const { return forallContextOpen != 0; }
+
+ /// Get the statement context.
+ StatementContext &stmtContext() { return stmtCtx; }
+
+ //===--------------------------------------------------------------------===//
+ // Analysis support
+ //===--------------------------------------------------------------------===//
+
+ /// Open a new construct. The analysis phase starts here.
+ void pushLevel();
+
+ /// Close the construct.
+ void popLevel();
+
+ /// Add new concurrent header control variable symbol.
+ void addSymbol(FrontEndSymbol sym);
+
+ /// Collect array bases from the expression, `x`.
+ void exprBase(FrontEndExpr x, bool lhs);
+
+ /// Called at the end of a assignment statement.
+ void endAssign();
+
+ /// Return all the active control variables on the stack.
+ llvm::SmallVector<FrontEndSymbol> collectAllSymbols();
+
+ //===--------------------------------------------------------------------===//
+ // Code gen support
+ //===--------------------------------------------------------------------===//
+
+ /// Enter a FORALL context.
+ void enter() { forallContextOpen++; }
+
+ /// Leave a FORALL context.
+ void leave();
+
+ void pushLoopNest(std::function<void()> lambda) {
+ ccLoopNest.push_back(lambda);
+ }
+
+ /// Get the inner arguments that correspond to the output arrays.
+ mlir::ValueRange getInnerArgs() const { return innerArgs; }
+
+ /// Set the inner arguments for the next loop level.
+ void setInnerArgs(llvm::ArrayRef<mlir::BlockArgument> args) {
+ innerArgs.clear();
+ for (auto &arg : args)
+ innerArgs.push_back(arg);
+ }
+
+ /// Reset the outermost `array_load` arguments to the loop nest.
+ void resetInnerArgs() { innerArgs = initialArgs; }
+
+ /// Capture the current outermost loop.
+ void setOuterLoop(fir::DoLoopOp loop) {
+ clearLoops();
+ outerLoop = loop;
+ }
+
+ /// Sets the inner loop argument at position \p offset to \p val.
+ void setInnerArg(size_t offset, mlir::Value val) {
+ assert(offset < innerArgs.size());
+ innerArgs[offset] = val;
+ }
+
+ /// Get the types of the output arrays.
+ llvm::SmallVector<mlir::Type> innerArgTypes() const {
+ llvm::SmallVector<mlir::Type> result;
+ for (auto &arg : innerArgs)
+ result.push_back(arg.getType());
+ return result;
+ }
+
+ /// Create a binding between an Ev::Expr node pointer and a fir::array_load
+ /// op. This bindings will be used when generating the IR.
+ void bindLoad(ArrayBases base, fir::ArrayLoadOp load) {
+ loadBindings.try_emplace(std::move(base), load);
+ }
+
+ fir::ArrayLoadOp findBinding(const ArrayBases &base) {
+ return loadBindings.lookup(base);
+ }
+
+ /// `load` must be a LHS array_load. Returns `llvm::None` on error.
+ llvm::Optional<size_t> findArgPosition(fir::ArrayLoadOp load);
+
+ bool isLHS(fir::ArrayLoadOp load) { return findArgPosition(load).hasValue(); }
+
+ /// `load` must be a LHS array_load. Determine the threaded inner argument
+ /// corresponding to this load.
+ mlir::Value findArgumentOfLoad(fir::ArrayLoadOp load) {
+ if (auto opt = findArgPosition(load))
+ return innerArgs[*opt];
+ llvm_unreachable("array load argument not found");
+ }
+
+ size_t argPosition(mlir::Value arg) {
+ for (auto i : llvm::enumerate(innerArgs))
+ if (arg == i.value())
+ return i.index();
+ llvm_unreachable("inner argument value was not found");
+ }
+
+ llvm::Optional<fir::ArrayLoadOp> getLhsLoad(size_t i) {
+ assert(i < lhsBases.size());
+ if (lhsBases[counter].hasValue())
+ return findBinding(lhsBases[counter].getValue());
+ return llvm::None;
+ }
+
+ /// Return the outermost loop in this FORALL nest.
+ fir::DoLoopOp getOuterLoop() {
+ assert(outerLoop.hasValue());
+ return outerLoop.getValue();
+ }
+
+ /// Return the statement context for the entire, outermost FORALL construct.
+ StatementContext &outermostContext() { return outerContext; }
+
+ /// Generate the explicit loop nest.
+ void genLoopNest() {
+ for (auto &lambda : ccLoopNest)
+ lambda();
+ }
+
+ /// Clear the array_load bindings.
+ void resetBindings() { loadBindings.clear(); }
+
+ /// Get the current counter value.
+ std::size_t getCounter() const { return counter; }
+
+ /// Increment the counter value to the next assignment statement.
+ void incrementCounter() { counter++; }
+
+ bool isOutermostForall() const {
+ assert(forallContextOpen);
+ return forallContextOpen == 1;
+ }
+
+ void attachLoopCleanup(std::function<void(fir::FirOpBuilder &builder)> fn) {
+ if (!loopCleanup.hasValue()) {
+ loopCleanup = fn;
+ return;
+ }
+ std::function<void(fir::FirOpBuilder &)> oldFn = loopCleanup.getValue();
+ loopCleanup = [=](fir::FirOpBuilder &builder) {
+ oldFn(builder);
+ fn(builder);
+ };
+ }
+
+ // LLVM standard dump method.
+ LLVM_DUMP_METHOD void dump() const;
+
+ // Pretty-print.
+ friend llvm::raw_ostream &operator<<(llvm::raw_ostream &,
+ const ExplicitIterSpace &);
+
+ /// Finalize the current body statement context.
+ void finalizeContext() { stmtCtx.finalize(); }
+
+ void appendLoops(const llvm::SmallVector<fir::DoLoopOp> &loops) {
+ loopStack.push_back(loops);
+ }
+
+ void clearLoops() { loopStack.clear(); }
+
+ llvm::SmallVector<llvm::SmallVector<fir::DoLoopOp>> getLoopStack() const {
+ return loopStack;
+ }
+
+private:
+ /// Cleanup the analysis results.
+ void conditionalCleanup();
+
+ StatementContext outerContext;
+
+ // A stack of lists of front-end symbols.
+ llvm::SmallVector<llvm::SmallVector<FrontEndSymbol>> symbolStack;
+ llvm::SmallVector<llvm::Optional<ArrayBases>> lhsBases;
+ llvm::SmallVector<llvm::SmallVector<ArrayBases>> rhsBases;
+ llvm::DenseMap<ArrayBases, fir::ArrayLoadOp> loadBindings;
+
+ // Stack of lambdas to create the loop nest.
+ llvm::SmallVector<std::function<void()>> ccLoopNest;
+
+ // Assignment statement context (inside the loop nest).
+ StatementContext stmtCtx;
+ llvm::SmallVector<mlir::Value> innerArgs;
+ llvm::SmallVector<mlir::Value> initialArgs;
+ llvm::Optional<fir::DoLoopOp> outerLoop;
+ llvm::SmallVector<llvm::SmallVector<fir::DoLoopOp>> loopStack;
+ llvm::Optional<std::function<void(fir::FirOpBuilder &)>> loopCleanup;
+ std::size_t forallContextOpen = 0;
+ std::size_t counter = 0;
+};
+
+/// Is there a Symbol in common between the concurrent header set and the set
+/// of symbols in the expression?
+template <typename A>
+bool symbolSetsIntersect(llvm::ArrayRef<FrontEndSymbol> ctrlSet,
+ const A &exprSyms) {
+ for (const auto &sym : exprSyms)
+ if (std::find(ctrlSet.begin(), ctrlSet.end(), &sym.get()) != ctrlSet.end())
+ return true;
+ return false;
+}
+
+/// Determine if the subscript expression symbols from an Ev::ArrayRef
+/// intersects with the set of concurrent control symbols, `ctrlSet`.
+template <typename A>
+bool symbolsIntersectSubscripts(llvm::ArrayRef<FrontEndSymbol> ctrlSet,
+ const A &subscripts) {
+ for (auto &sub : subscripts) {
+ if (const auto *expr =
+ std::get_if<evaluate::IndirectSubscriptIntegerExpr>(&sub.u))
+ if (symbolSetsIntersect(ctrlSet, evaluate::CollectSymbols(expr->value())))
+ return true;
+ }
+ return false;
+}
+
+} // namespace Fortran::lower
+
+#endif // FORTRAN_LOWER_ITERATIONSPACE_H
diff --git a/flang/include/flang/Optimizer/Builder/FIRBuilder.h b/flang/include/flang/Optimizer/Builder/FIRBuilder.h
index fc056298eec3d..2d0abeafaaa0a 100644
--- a/flang/include/flang/Optimizer/Builder/FIRBuilder.h
+++ b/flang/include/flang/Optimizer/Builder/FIRBuilder.h
@@ -286,6 +286,11 @@ class FirOpBuilder : public mlir::OpBuilder {
/// this may create a `fir.shift` op.
mlir::Value createShape(mlir::Location loc, const fir::ExtendedValue &exv);
+ /// Create a slice op extended value. The value to be sliced, `exv`, must be
+ /// an array.
+ mlir::Value createSlice(mlir::Location loc, const fir::ExtendedValue &exv,
+ mlir::ValueRange triples, mlir::ValueRange path);
+
/// Create a boxed value (Fortran descriptor) to be passed to the runtime.
/// \p exv is an extended value holding a memory reference to the object that
/// must be boxed. This function will crash if provided something that is not
@@ -389,6 +394,13 @@ mlir::Value readCharLen(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Value readExtent(fir::FirOpBuilder &builder, mlir::Location loc,
const fir::ExtendedValue &box, unsigned dim);
+/// Read or get the lower bound in dimension \p dim of the array described by
+/// \p box. If the lower bound is left default in the ExtendedValue,
+/// \p defaultValue will be returned.
+mlir::Value readLowerBound(fir::FirOpBuilder &builder, mlir::Location loc,
+ const fir::ExtendedValue &box, unsigned dim,
+ mlir::Value defaultValue);
+
/// Read extents from \p box.
llvm::SmallVector<mlir::Value> readExtents(fir::FirOpBuilder &builder,
mlir::Location loc,
@@ -447,6 +459,35 @@ mlir::TupleType getRaggedArrayHeaderType(fir::FirOpBuilder &builder);
mlir::Value createZeroValue(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Type type);
+//===--------------------------------------------------------------------===//
+// ExtendedValue helpers
+//===--------------------------------------------------------------------===//
+
+/// Return the extended value for a component of a derived type instance given
+/// the address of the component.
+fir::ExtendedValue componentToExtendedValue(fir::FirOpBuilder &builder,
+ mlir::Location loc,
+ mlir::Value component);
+
+/// Given the address of an array element and the ExtendedValue describing the
+/// array, returns the ExtendedValue describing the array element. The purpose
+/// is to propagate the length parameters of the array to the element.
+/// This can be used for elements of `array` or `array(i:j:k)`. If \p element
+/// belongs to an array section `array%x` whose base is \p array,
+/// arraySectionElementToExtendedValue must be used instead.
+fir::ExtendedValue arrayElementToExtendedValue(fir::FirOpBuilder &builder,
+ mlir::Location loc,
+ const fir::ExtendedValue &array,
+ mlir::Value element);
+
+/// Build the ExtendedValue for \p element that is an element of an array or
+/// array section with \p array base (`array` or `array(i:j:k)%x%y`).
+/// If it is an array section, \p slice must be provided and be a fir::SliceOp
+/// that describes the section.
+fir::ExtendedValue arraySectionElementToExtendedValue(
+ fir::FirOpBuilder &builder, mlir::Location loc,
+ const fir::ExtendedValue &array, mlir::Value element, mlir::Value slice);
+
} // namespace fir::factory
#endif // FORTRAN_OPTIMIZER_BUILDER_FIRBUILDER_H
diff --git a/flang/include/flang/Optimizer/Builder/Factory.h b/flang/include/flang/Optimizer/Builder/Factory.h
index 837f07b9e17b6..cc25c673c5ead 100644
--- a/flang/include/flang/Optimizer/Builder/Factory.h
+++ b/flang/include/flang/Optimizer/Builder/Factory.h
@@ -31,6 +31,21 @@ constexpr llvm::StringRef attrFortranArrayOffsets() {
return "Fortran.offsets";
}
+/// 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) {
+ 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();
+ }
+ 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) {
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index 72e68833afba0..3dac57c941250 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -16,6 +16,7 @@
#include "flang/Lower/ConvertExpr.h"
#include "flang/Lower/ConvertType.h"
#include "flang/Lower/ConvertVariable.h"
+#include "flang/Lower/IterationSpace.h"
#include "flang/Lower/Mangler.h"
#include "flang/Lower/PFTBuilder.h"
#include "flang/Lower/Runtime.h"
@@ -517,7 +518,7 @@ class FirConverter : public Fortran::lower::AbstractConverter {
if (assign.lhs.Rank() > 0) {
// Array assignment
// See Fortran 2018 10.2.1.3 p5, p6, and p7
- TODO(toLocation(), "Array assignment");
+ genArrayAssignment(assign, stmtCtx);
return;
}
@@ -835,6 +836,26 @@ class FirConverter : public Fortran::lower::AbstractConverter {
TODO(toLocation(), "LockStmt lowering");
}
+ /// Generate an array assignment.
+ /// This is an assignment expression with rank > 0. The assignment may or may
+ /// not be in a WHERE and/or FORALL context.
+ void genArrayAssignment(const Fortran::evaluate::Assignment &assign,
+ Fortran::lower::StatementContext &stmtCtx) {
+ if (isWholeAllocatable(assign.lhs)) {
+ // Assignment to allocatables may require the lhs to be
+ // deallocated/reallocated. See Fortran 2018 10.2.1.3 p3
+ Fortran::lower::createAllocatableArrayAssignment(
+ *this, assign.lhs, assign.rhs, explicitIterSpace, implicitIterSpace,
+ localSymbols, stmtCtx);
+ return;
+ }
+
+ // No masks and the iteration space is implied by the array, so create a
+ // simple array assignment.
+ Fortran::lower::createSomeArrayAssignment(*this, assign.lhs, assign.rhs,
+ localSymbols, stmtCtx);
+ }
+
void genFIR(const Fortran::parser::WhereConstruct &c) {
TODO(toLocation(), "WhereConstruct lowering");
}
@@ -1047,6 +1068,8 @@ class FirConverter : public Fortran::lower::AbstractConverter {
/// Tuple of host assoicated variables.
mlir::Value hostAssocTuple;
+ Fortran::lower::ImplicitIterSpace implicitIterSpace;
+ Fortran::lower::ExplicitIterSpace explicitIterSpace;
};
} // namespace
diff --git a/flang/lib/Lower/CMakeLists.txt b/flang/lib/Lower/CMakeLists.txt
index 3be444bf1323f..031701e99902e 100644
--- a/flang/lib/Lower/CMakeLists.txt
+++ b/flang/lib/Lower/CMakeLists.txt
@@ -9,6 +9,9 @@ add_flang_library(FortranLower
ConvertType.cpp
ConvertVariable.cpp
IntrinsicCall.cpp
+ ComponentPath.cpp
+ DumpEvaluateExpr.cpp
+ IterationSpace.cpp
Mangler.cpp
OpenACC.cpp
OpenMP.cpp
diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
index 4e45a704240cd..f0d18ccc732c8 100644
--- a/flang/lib/Lower/CallInterface.cpp
+++ b/flang/lib/Lower/CallInterface.cpp
@@ -601,20 +601,22 @@ class Fortran::lower::CallInterfaceImpl {
fir::SequenceType::Shape getBounds(const Fortran::evaluate::Shape &shape) {
fir::SequenceType::Shape bounds;
- for (Fortran::evaluate::MaybeExtentExpr extentExpr : shape) {
- fir::SequenceType::Extent extent = fir::SequenceType::getUnknownExtent();
- if (std::optional<std::int64_t> constantExtent =
- toInt64(std::move(extentExpr)))
- extent = *constantExtent;
- bounds.push_back(extent);
+ for (const std::optional<Fortran::evaluate::ExtentExpr> &extent : shape) {
+ fir::SequenceType::Extent bound = fir::SequenceType::getUnknownExtent();
+ if (std::optional<std::int64_t> i = toInt64(extent))
+ bound = *i;
+ bounds.emplace_back(bound);
}
return bounds;
}
-
- template <typename A>
- std::optional<std::int64_t> toInt64(A &&expr) {
- return Fortran::evaluate::ToInt64(Fortran::evaluate::Fold(
- getConverter().getFoldingContext(), std::move(expr)));
+ std::optional<std::int64_t>
+ toInt64(std::optional<
+ Fortran::evaluate::Expr<Fortran::evaluate::SubscriptInteger>>
+ expr) {
+ if (expr)
+ return Fortran::evaluate::ToInt64(Fortran::evaluate::Fold(
+ getConverter().getFoldingContext(), toEvExpr(*expr)));
+ return std::nullopt;
}
/// Return a vector with an attribute with the name of the argument if this
diff --git a/flang/lib/Lower/ComponentPath.cpp b/flang/lib/Lower/ComponentPath.cpp
new file mode 100644
index 0000000000000..f06c72c249187
--- /dev/null
+++ b/flang/lib/Lower/ComponentPath.cpp
@@ -0,0 +1,53 @@
+//===-- ComponentPath.cpp -------------------------------------------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#include "flang/Lower/ComponentPath.h"
+
+static std::function<
+ Fortran::lower::IterationSpace(const Fortran::lower::IterationSpace &)>
+getIdentityFunc() {
+ return [](const Fortran::lower::IterationSpace &s) { return s; };
+}
+
+static std::function<
+ Fortran::lower::IterationSpace(const Fortran::lower::IterationSpace &)>
+getNullaryFunc() {
+ return [](const Fortran::lower::IterationSpace &s) {
+ Fortran::lower::IterationSpace newIters(s);
+ newIters.clearIndices();
+ return newIters;
+ };
+}
+
+void Fortran::lower::ComponentPath::clear() {
+ reversePath.clear();
+ substring = nullptr;
+ applied = false;
+ prefixComponents.clear();
+ trips.clear();
+ suffixComponents.clear();
+ pc = getIdentityFunc();
+}
+
+bool Fortran::lower::isRankedArrayAccess(const Fortran::evaluate::ArrayRef &x) {
+ for (const Fortran::evaluate::Subscript &sub : x.subscript()) {
+ if (std::visit(
+ Fortran::common::visitors{
+ [&](const Fortran::evaluate::Triplet &) { return true; },
+ [&](const Fortran::evaluate::IndirectSubscriptIntegerExpr &e) {
+ return e.value().Rank() > 0;
+ }},
+ sub.u))
+ return true;
+ }
+ return false;
+}
+
+void Fortran::lower::ComponentPath::setPC(bool isImplicit) {
+ pc = isImplicit ? getIdentityFunc() : getNullaryFunc();
+}
diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp
index 7bef850b079b6..93deacea6713a 100644
--- a/flang/lib/Lower/ConvertExpr.cpp
+++ b/flang/lib/Lower/ConvertExpr.cpp
@@ -15,13 +15,17 @@
#include "flang/Evaluate/traverse.h"
#include "flang/Lower/AbstractConverter.h"
#include "flang/Lower/CallInterface.h"
+#include "flang/Lower/ComponentPath.h"
#include "flang/Lower/ConvertType.h"
#include "flang/Lower/ConvertVariable.h"
+#include "flang/Lower/DumpEvaluateExpr.h"
#include "flang/Lower/IntrinsicCall.h"
#include "flang/Lower/StatementContext.h"
#include "flang/Lower/SymbolMap.h"
#include "flang/Lower/Todo.h"
#include "flang/Optimizer/Builder/Complex.h"
+#include "flang/Optimizer/Builder/Factory.h"
+#include "flang/Optimizer/Builder/MutableBox.h"
#include "flang/Optimizer/Dialect/FIROpsSupport.h"
#include "flang/Semantics/expression.h"
#include "flang/Semantics/symbol.h"
@@ -43,6 +47,68 @@
// to the correct FIR representation in SSA form.
//===----------------------------------------------------------------------===//
+/// The various semantics of a program constituent (or a part thereof) as it may
+/// appear in an expression.
+///
+/// Given the following Fortran declarations.
+/// ```fortran
+/// REAL :: v1, v2, v3
+/// REAL, POINTER :: vp1
+/// REAL :: a1(c), a2(c)
+/// REAL ELEMENTAL FUNCTION f1(arg) ! array -> array
+/// FUNCTION f2(arg) ! array -> array
+/// vp1 => v3 ! 1
+/// v1 = v2 * vp1 ! 2
+/// a1 = a1 + a2 ! 3
+/// a1 = f1(a2) ! 4
+/// a1 = f2(a2) ! 5
+/// ```
+///
+/// In line 1, `vp1` is a BoxAddr to copy a box value into. The box value is
+/// constructed from the DataAddr of `v3`.
+/// In line 2, `v1` is a DataAddr to copy a value into. The value is constructed
+/// from the DataValue of `v2` and `vp1`. DataValue is implicitly a double
+/// dereference in the `vp1` case.
+/// In line 3, `a1` and `a2` on the rhs are RefTransparent. The `a1` on the lhs
+/// is CopyInCopyOut as `a1` is replaced elementally by the additions.
+/// In line 4, `a2` can be RefTransparent, ByValueArg, RefOpaque, or BoxAddr if
+/// `arg` is declared as C-like pass-by-value, VALUE, INTENT(?), or ALLOCATABLE/
+/// POINTER, respectively. `a1` on the lhs is CopyInCopyOut.
+/// In line 5, `a2` may be DataAddr or BoxAddr assuming f2 is transformational.
+/// `a1` on the lhs is again CopyInCopyOut.
+enum class ConstituentSemantics {
+ // Scalar data reference semantics.
+ //
+ // For these let `v` be the location in memory of a variable with value `x`
+ DataValue, // refers to the value `x`
+ DataAddr, // refers to the address `v`
+ BoxValue, // refers to a box value containing `v`
+ BoxAddr, // refers to the address of a box value containing `v`
+
+ // Array data reference semantics.
+ //
+ // For these let `a` be the location in memory of a sequence of value `[xs]`.
+ // Let `x_i` be the `i`-th value in the sequence `[xs]`.
+
+ // Referentially transparent. Refers to the array's value, `[xs]`.
+ RefTransparent,
+ // Refers to an ephemeral address `tmp` containing value `x_i` (15.5.2.3.p7
+ // note 2). (Passing a copy by reference to simulate pass-by-value.)
+ ByValueArg,
+ // Refers to the merge of array value `[xs]` with another array value `[ys]`.
+ // This merged array value will be written into memory location `a`.
+ CopyInCopyOut,
+ // Similar to CopyInCopyOut but `a` may be a transient projection (rather than
+ // a whole array).
+ ProjectedCopyInCopyOut,
+ // Similar to ProjectedCopyInCopyOut, except the merge value is not assigned
+ // automatically by the framework. Instead, and address for `[xs]` is made
+ // accessible so that custom assignments to `[xs]` can be implemented.
+ CustomCopyInCopyOut,
+ // Referentially opaque. Refers to the address of `x_i`.
+ RefOpaque
+};
+
/// Place \p exv in memory if it is not already a memory reference. If
/// \p forceValueType is provided, the value is first casted to the provided
/// type before being stored (this is mainly intended for logicals whose value
@@ -125,6 +191,16 @@ isElementalProcWithArrayArgs(const Fortran::evaluate::ProcedureRef &procRef) {
return true;
return false;
}
+template <typename T>
+static bool isElementalProcWithArrayArgs(const Fortran::evaluate::Expr<T> &) {
+ return false;
+}
+template <>
+bool isElementalProcWithArrayArgs(const Fortran::lower::SomeExpr &x) {
+ if (const auto *procRef = std::get_if<Fortran::evaluate::ProcedureRef>(&x.u))
+ return isElementalProcWithArrayArgs(*procRef);
+ return false;
+}
/// If \p arg is the address of a function with a denoted host-association tuple
/// argument, then return the host-associations tuple value of the current
@@ -215,7 +291,7 @@ class ScalarExprLowering {
return symMap.lookupSymbol(*sym).toExtendedValue();
},
[&](const Fortran::evaluate::Component &comp) -> ExtValue {
- TODO(getLoc(), "genMutableBoxValueImpl Component");
+ return genComponent(comp);
},
[&](const auto &) -> ExtValue {
fir::emitFatalError(getLoc(),
@@ -564,7 +640,17 @@ class ScalarExprLowering {
}
ExtValue genval(const Fortran::evaluate::Subscript &subs) {
- TODO(getLoc(), "genval Subscript");
+ if (auto *s = std::get_if<Fortran::evaluate::IndirectSubscriptIntegerExpr>(
+ &subs.u)) {
+ if (s->value().Rank() > 0)
+ fir::emitFatalError(getLoc(), "vector subscript is not scalar");
+ return {genval(s->value())};
+ }
+ fir::emitFatalError(getLoc(), "subscript triple notation is not scalar");
+ }
+
+ ExtValue genSubscript(const Fortran::evaluate::Subscript &subs) {
+ return genval(subs);
}
ExtValue gen(const Fortran::evaluate::DataRef &dref) {
@@ -574,6 +660,56 @@ class ScalarExprLowering {
TODO(getLoc(), "genval DataRef");
}
+ // Helper function to turn the Component structure into a list of nested
+ // components, ordered from largest/leftmost to smallest/rightmost:
+ // - where only the smallest/rightmost item may be allocatable or a pointer
+ // (nested allocatable/pointer components require nested coordinate_of ops)
+ // - that does not contain any parent components
+ // (the front end places parent components directly in the object)
+ // Return the object used as the base coordinate for the component chain.
+ static Fortran::evaluate::DataRef const *
+ reverseComponents(const Fortran::evaluate::Component &cmpt,
+ std::list<const Fortran::evaluate::Component *> &list) {
+ if (!cmpt.GetLastSymbol().test(
+ Fortran::semantics::Symbol::Flag::ParentComp))
+ list.push_front(&cmpt);
+ return std::visit(
+ Fortran::common::visitors{
+ [&](const Fortran::evaluate::Component &x) {
+ if (Fortran::semantics::IsAllocatableOrPointer(x.GetLastSymbol()))
+ return &cmpt.base();
+ return reverseComponents(x, list);
+ },
+ [&](auto &) { return &cmpt.base(); },
+ },
+ cmpt.base().u);
+ }
+
+ // Return the coordinate of the component reference
+ ExtValue genComponent(const Fortran::evaluate::Component &cmpt) {
+ std::list<const Fortran::evaluate::Component *> list;
+ const Fortran::evaluate::DataRef *base = reverseComponents(cmpt, list);
+ llvm::SmallVector<mlir::Value> coorArgs;
+ ExtValue obj = gen(*base);
+ mlir::Type ty = fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(obj).getType());
+ mlir::Location loc = getLoc();
+ auto fldTy = fir::FieldType::get(&converter.getMLIRContext());
+ // FIXME: need to thread the LEN type parameters here.
+ for (const Fortran::evaluate::Component *field : list) {
+ auto recTy = ty.cast<fir::RecordType>();
+ const Fortran::semantics::Symbol &sym = field->GetLastSymbol();
+ llvm::StringRef name = toStringRef(sym.name());
+ coorArgs.push_back(builder.create<fir::FieldIndexOp>(
+ loc, fldTy, name, recTy, fir::getTypeParams(obj)));
+ ty = recTy.getType(name);
+ }
+ ty = builder.getRefType(ty);
+ return fir::factory::componentToExtendedValue(
+ builder, loc,
+ builder.create<fir::CoordinateOp>(loc, ty, fir::getBase(obj),
+ coorArgs));
+ }
+
ExtValue gen(const Fortran::evaluate::Component &cmpt) {
TODO(getLoc(), "gen Component");
}
@@ -585,8 +721,53 @@ class ScalarExprLowering {
TODO(getLoc(), "genval Bound");
}
+ /// Return lower bounds of \p box in dimension \p dim. The returned value
+ /// has type \ty.
+ mlir::Value getLBound(const ExtValue &box, unsigned dim, mlir::Type ty) {
+ assert(box.rank() > 0 && "must be an array");
+ mlir::Location loc = getLoc();
+ mlir::Value one = builder.createIntegerConstant(loc, ty, 1);
+ mlir::Value lb = fir::factory::readLowerBound(builder, loc, box, dim, one);
+ return builder.createConvert(loc, ty, lb);
+ }
+
+ /// Lower an ArrayRef to a fir.coordinate_of given its lowered base.
+ ExtValue genCoordinateOp(const ExtValue &array,
+ const Fortran::evaluate::ArrayRef &aref) {
+ mlir::Location loc = getLoc();
+ // References to array of rank > 1 with non constant shape that are not
+ // fir.box must be collapsed into an offset computation in lowering already.
+ // The same is needed with dynamic length character arrays of all ranks.
+ mlir::Type baseType =
+ fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(array).getType());
+ if ((array.rank() > 1 && fir::hasDynamicSize(baseType)) ||
+ fir::characterWithDynamicLen(fir::unwrapSequenceType(baseType)))
+ if (!array.getBoxOf<fir::BoxValue>())
+ TODO(getLoc(), "genOffsetAndCoordinateOp");
+ // Generate a fir.coordinate_of with zero based array indexes.
+ llvm::SmallVector<mlir::Value> args;
+ for (const auto &subsc : llvm::enumerate(aref.subscript())) {
+ ExtValue subVal = genSubscript(subsc.value());
+ assert(fir::isUnboxedValue(subVal) && "subscript must be simple scalar");
+ mlir::Value val = fir::getBase(subVal);
+ mlir::Type ty = val.getType();
+ mlir::Value lb = getLBound(array, subsc.index(), ty);
+ args.push_back(builder.create<mlir::arith::SubIOp>(loc, ty, val, lb));
+ }
+
+ mlir::Value base = fir::getBase(array);
+ auto seqTy =
+ fir::dyn_cast_ptrOrBoxEleTy(base.getType()).cast<fir::SequenceType>();
+ assert(args.size() == seqTy.getDimension());
+ mlir::Type ty = builder.getRefType(seqTy.getEleTy());
+ auto addr = builder.create<fir::CoordinateOp>(loc, ty, base, args);
+ return fir::factory::arrayElementToExtendedValue(builder, loc, array, addr);
+ }
+
ExtValue gen(const Fortran::evaluate::ArrayRef &aref) {
- TODO(getLoc(), "gen ArrayRef");
+ ExtValue base = aref.base().IsSymbol() ? gen(aref.base().GetFirstSymbol())
+ : gen(aref.base().GetComponent());
+ return genCoordinateOp(base, aref);
}
ExtValue genval(const Fortran::evaluate::ArrayRef &aref) {
TODO(getLoc(), "genval ArrayRef");
@@ -1275,6 +1456,1093 @@ class ScalarExprLowering {
};
} // namespace
+// Helper for changing the semantics in a given context. Preserves the current
+// semantics which is resumed when the "push" goes out of scope.
+#define PushSemantics(PushVal) \
+ [[maybe_unused]] auto pushSemanticsLocalVariable##__LINE__ = \
+ Fortran::common::ScopedSet(semant, PushVal);
+
+static bool isAdjustedArrayElementType(mlir::Type t) {
+ return fir::isa_char(t) || fir::isa_derived(t) || t.isa<fir::SequenceType>();
+}
+
+/// Build an ExtendedValue from a fir.array<?x...?xT> without actually setting
+/// the actual extents and lengths. This is only to allow their propagation as
+/// ExtendedValue without triggering verifier failures when propagating
+/// character/arrays as unboxed values. Only the base of the resulting
+/// ExtendedValue should be used, it is undefined to use the length or extents
+/// of the extended value returned,
+inline static fir::ExtendedValue
+convertToArrayBoxValue(mlir::Location loc, fir::FirOpBuilder &builder,
+ mlir::Value val, mlir::Value len) {
+ mlir::Type ty = fir::unwrapRefType(val.getType());
+ mlir::IndexType idxTy = builder.getIndexType();
+ auto seqTy = ty.cast<fir::SequenceType>();
+ auto undef = builder.create<fir::UndefOp>(loc, idxTy);
+ llvm::SmallVector<mlir::Value> extents(seqTy.getDimension(), undef);
+ if (fir::isa_char(seqTy.getEleTy()))
+ return fir::CharArrayBoxValue(val, len ? len : undef, extents);
+ return fir::ArrayBoxValue(val, extents);
+}
+
+//===----------------------------------------------------------------------===//
+//
+// Lowering of array expressions.
+//
+//===----------------------------------------------------------------------===//
+
+namespace {
+class ArrayExprLowering {
+ using ExtValue = fir::ExtendedValue;
+
+ /// Structure to keep track of lowered array operands in the
+ /// array expression. Useful to later deduce the shape of the
+ /// array expression.
+ struct ArrayOperand {
+ /// Array base (can be a fir.box).
+ mlir::Value memref;
+ /// ShapeOp, ShapeShiftOp or ShiftOp
+ mlir::Value shape;
+ /// SliceOp
+ mlir::Value slice;
+ /// Can this operand be absent ?
+ bool mayBeAbsent = false;
+ };
+
+ using ImplicitSubscripts = Fortran::lower::details::ImplicitSubscripts;
+ using PathComponent = Fortran::lower::PathComponent;
+
+ /// Active iteration space.
+ using IterationSpace = Fortran::lower::IterationSpace;
+ using IterSpace = const Fortran::lower::IterationSpace &;
+
+ /// Current continuation. Function that will generate IR for a single
+ /// iteration of the pending iterative loop structure.
+ using CC = Fortran::lower::GenerateElementalArrayFunc;
+
+ /// Projection continuation. Function that will project one iteration space
+ /// into another.
+ using PC = std::function<IterationSpace(IterSpace)>;
+ using ArrayBaseTy =
+ std::variant<std::monostate, const Fortran::evaluate::ArrayRef *,
+ const Fortran::evaluate::DataRef *>;
+ using ComponentPath = Fortran::lower::ComponentPath;
+
+public:
+ //===--------------------------------------------------------------------===//
+ // Regular array assignment
+ //===--------------------------------------------------------------------===//
+
+ /// Entry point for array assignments. Both the left-hand and right-hand sides
+ /// can either be ExtendedValue or evaluate::Expr.
+ template <typename TL, typename TR>
+ static void lowerArrayAssignment(Fortran::lower::AbstractConverter &converter,
+ Fortran::lower::SymMap &symMap,
+ Fortran::lower::StatementContext &stmtCtx,
+ const TL &lhs, const TR &rhs) {
+ ArrayExprLowering ael{converter, stmtCtx, symMap,
+ ConstituentSemantics::CopyInCopyOut};
+ ael.lowerArrayAssignment(lhs, rhs);
+ }
+
+ template <typename TL, typename TR>
+ void lowerArrayAssignment(const TL &lhs, const TR &rhs) {
+ mlir::Location loc = getLoc();
+ /// Here the target subspace is not necessarily contiguous. The ArrayUpdate
+ /// continuation is implicitly returned in `ccStoreToDest` and the ArrayLoad
+ /// in `destination`.
+ PushSemantics(ConstituentSemantics::ProjectedCopyInCopyOut);
+ ccStoreToDest = genarr(lhs);
+ determineShapeOfDest(lhs);
+ semant = ConstituentSemantics::RefTransparent;
+ ExtValue exv = lowerArrayExpression(rhs);
+ if (explicitSpaceIsActive()) {
+ explicitSpace->finalizeContext();
+ builder.create<fir::ResultOp>(loc, fir::getBase(exv));
+ } else {
+ builder.create<fir::ArrayMergeStoreOp>(
+ loc, destination, fir::getBase(exv), destination.getMemref(),
+ destination.getSlice(), destination.getTypeparams());
+ }
+ }
+
+ //===--------------------------------------------------------------------===//
+ // Array assignment to allocatable array
+ //===--------------------------------------------------------------------===//
+
+ /// Entry point for assignment to allocatable array.
+ static void lowerAllocatableArrayAssignment(
+ 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) {
+ ArrayExprLowering ael(converter, stmtCtx, symMap,
+ ConstituentSemantics::CopyInCopyOut, &explicitSpace,
+ &implicitSpace);
+ ael.lowerAllocatableArrayAssignment(lhs, rhs);
+ }
+
+ /// Assignment to allocatable array.
+ ///
+ /// The semantics are reverse that of a "regular" array assignment. The rhs
+ /// defines the iteration space of the computation and the lhs is
+ /// resized/reallocated to fit if necessary.
+ void lowerAllocatableArrayAssignment(const Fortran::lower::SomeExpr &lhs,
+ const Fortran::lower::SomeExpr &rhs) {
+ // With assignment to allocatable, we want to lower the rhs first and use
+ // its shape to determine if we need to reallocate, etc.
+ mlir::Location loc = getLoc();
+ // FIXME: If the lhs is in an explicit iteration space, the assignment may
+ // be to an array of allocatable arrays rather than a single allocatable
+ // array.
+ fir::MutableBoxValue mutableBox =
+ createMutableBox(loc, converter, lhs, symMap);
+ mlir::Type resultTy = converter.genType(rhs);
+ if (rhs.Rank() > 0)
+ determineShapeOfDest(rhs);
+ auto rhsCC = [&]() {
+ PushSemantics(ConstituentSemantics::RefTransparent);
+ return genarr(rhs);
+ }();
+
+ llvm::SmallVector<mlir::Value> lengthParams;
+ // Currently no safe way to gather length from rhs (at least for
+ // character, it cannot be taken from array_loads since it may be
+ // changed by concatenations).
+ if ((mutableBox.isCharacter() && !mutableBox.hasNonDeferredLenParams()) ||
+ mutableBox.isDerivedWithLengthParameters())
+ TODO(loc, "gather rhs length parameters in assignment to allocatable");
+
+ // The allocatable must take lower bounds from the expr if it is
+ // reallocated and the right hand side is not a scalar.
+ const bool takeLboundsIfRealloc = rhs.Rank() > 0;
+ llvm::SmallVector<mlir::Value> lbounds;
+ // When the reallocated LHS takes its lower bounds from the RHS,
+ // they will be non default only if the RHS is a whole array
+ // variable. Otherwise, lbounds is left empty and default lower bounds
+ // will be used.
+ if (takeLboundsIfRealloc &&
+ 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);
+ lbounds.append(lbs.begin(), lbs.end());
+ }
+ fir::factory::MutableBoxReallocation realloc =
+ fir::factory::genReallocIfNeeded(builder, loc, mutableBox, destShape,
+ lengthParams);
+ // Create ArrayLoad for the mutable box and save it into `destination`.
+ PushSemantics(ConstituentSemantics::ProjectedCopyInCopyOut);
+ ccStoreToDest = genarr(realloc.newValue);
+ // If the rhs is scalar, get shape from the allocatable ArrayLoad.
+ if (destShape.empty())
+ destShape = getShape(destination);
+ // Finish lowering the loop nest.
+ assert(destination && "destination must have been set");
+ ExtValue exv = lowerArrayExpression(rhsCC, resultTy);
+ if (explicitSpaceIsActive()) {
+ explicitSpace->finalizeContext();
+ builder.create<fir::ResultOp>(loc, fir::getBase(exv));
+ } else {
+ builder.create<fir::ArrayMergeStoreOp>(
+ loc, destination, fir::getBase(exv), destination.getMemref(),
+ destination.getSlice(), destination.getTypeparams());
+ }
+ fir::factory::finalizeRealloc(builder, loc, mutableBox, lbounds,
+ takeLboundsIfRealloc, realloc);
+ }
+
+ /// Entry point into lowering an expression with rank. This entry point is for
+ /// lowering a rhs expression, for example. (RefTransparent semantics.)
+ static ExtValue
+ lowerNewArrayExpression(Fortran::lower::AbstractConverter &converter,
+ Fortran::lower::SymMap &symMap,
+ Fortran::lower::StatementContext &stmtCtx,
+ const Fortran::lower::SomeExpr &expr) {
+ ArrayExprLowering ael{converter, stmtCtx, symMap};
+ ael.determineShapeOfDest(expr);
+ ExtValue loopRes = ael.lowerArrayExpression(expr);
+ fir::ArrayLoadOp dest = ael.destination;
+ mlir::Value tempRes = dest.getMemref();
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ mlir::Location loc = converter.getCurrentLocation();
+ builder.create<fir::ArrayMergeStoreOp>(loc, dest, fir::getBase(loopRes),
+ tempRes, dest.getSlice(),
+ dest.getTypeparams());
+
+ auto arrTy =
+ fir::dyn_cast_ptrEleTy(tempRes.getType()).cast<fir::SequenceType>();
+ if (auto charTy =
+ arrTy.getEleTy().template dyn_cast<fir::CharacterType>()) {
+ if (fir::characterWithDynamicLen(charTy))
+ TODO(loc, "CHARACTER does not have constant LEN");
+ mlir::Value len = builder.createIntegerConstant(
+ loc, builder.getCharacterLengthType(), charTy.getLen());
+ return fir::CharArrayBoxValue(tempRes, len, dest.getExtents());
+ }
+ return fir::ArrayBoxValue(tempRes, dest.getExtents());
+ }
+
+ // FIXME: should take multiple inner arguments.
+ std::pair<IterationSpace, mlir::OpBuilder::InsertPoint>
+ genImplicitLoops(mlir::ValueRange shape, mlir::Value innerArg) {
+ mlir::Location loc = getLoc();
+ mlir::IndexType idxTy = builder.getIndexType();
+ mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
+ mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0);
+ llvm::SmallVector<mlir::Value> loopUppers;
+
+ // Convert any implied shape to closed interval form. The fir.do_loop will
+ // run from 0 to `extent - 1` inclusive.
+ for (auto extent : shape)
+ loopUppers.push_back(
+ builder.create<mlir::arith::SubIOp>(loc, extent, one));
+
+ // Iteration space is created with outermost columns, innermost rows
+ llvm::SmallVector<fir::DoLoopOp> loops;
+
+ const std::size_t loopDepth = loopUppers.size();
+ llvm::SmallVector<mlir::Value> ivars;
+
+ for (auto i : llvm::enumerate(llvm::reverse(loopUppers))) {
+ if (i.index() > 0) {
+ assert(!loops.empty());
+ builder.setInsertionPointToStart(loops.back().getBody());
+ }
+ fir::DoLoopOp loop;
+ if (innerArg) {
+ loop = builder.create<fir::DoLoopOp>(
+ loc, zero, i.value(), one, isUnordered(),
+ /*finalCount=*/false, mlir::ValueRange{innerArg});
+ innerArg = loop.getRegionIterArgs().front();
+ if (explicitSpaceIsActive())
+ explicitSpace->setInnerArg(0, innerArg);
+ } else {
+ loop = builder.create<fir::DoLoopOp>(loc, zero, i.value(), one,
+ isUnordered(),
+ /*finalCount=*/false);
+ }
+ ivars.push_back(loop.getInductionVar());
+ loops.push_back(loop);
+ }
+
+ if (innerArg)
+ for (std::remove_const_t<decltype(loopDepth)> i = 0; i + 1 < loopDepth;
+ ++i) {
+ builder.setInsertionPointToEnd(loops[i].getBody());
+ builder.create<fir::ResultOp>(loc, loops[i + 1].getResult(0));
+ }
+
+ // Move insertion point to the start of the innermost loop in the nest.
+ builder.setInsertionPointToStart(loops.back().getBody());
+ // Set `afterLoopNest` to just after the entire loop nest.
+ auto currPt = builder.saveInsertionPoint();
+ builder.setInsertionPointAfter(loops[0]);
+ auto afterLoopNest = builder.saveInsertionPoint();
+ builder.restoreInsertionPoint(currPt);
+
+ // Put the implicit loop variables in row to column order to match FIR's
+ // Ops. (The loops were constructed from outermost column to innermost
+ // row.)
+ mlir::Value outerRes = loops[0].getResult(0);
+ return {IterationSpace(innerArg, outerRes, llvm::reverse(ivars)),
+ afterLoopNest};
+ }
+
+ /// 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();
+ llvm::SmallVector<mlir::Value> shape = genIterationShape();
+ if (!destination) {
+ // Allocate storage for the result if it is not already provided.
+ destination = createAndLoadSomeArrayTemp(resultType, shape);
+ }
+
+ // Generate the lazy mask allocation, if one was given.
+ if (ccPrelude.hasValue())
+ ccPrelude.getValue()(shape);
+
+ // Now handle the implicit loops.
+ mlir::Value inner = explicitSpaceIsActive()
+ ? explicitSpace->getInnerArgs().front()
+ : destination.getResult();
+ auto [iters, afterLoopNest] = genImplicitLoops(shape, inner);
+ mlir::Value innerArg = iters.innerArgument();
+
+ // Generate the mask conditional structure, if there are masks. Unlike the
+ // explicit masks, which are interleaved, these mask expression appear in
+ // the innermost loop.
+ if (implicitSpaceHasMasks()) {
+ // Recover the cached condition from the mask buffer.
+ auto genCond = [&](Fortran::lower::FrontEndExpr e, IterSpace iters) {
+ return implicitSpace->getBoundClosure(e)(iters);
+ };
+
+ // Handle the negated conditions in topological order of the WHERE
+ // clauses. See 10.2.3.2p4 as to why this control structure is produced.
+ for (llvm::SmallVector<Fortran::lower::FrontEndExpr> maskExprs :
+ implicitSpace->getMasks()) {
+ const std::size_t size = maskExprs.size() - 1;
+ auto genFalseBlock = [&](const auto *e, auto &&cond) {
+ auto ifOp = builder.create<fir::IfOp>(
+ loc, mlir::TypeRange{innerArg.getType()}, fir::getBase(cond),
+ /*withElseRegion=*/true);
+ builder.create<fir::ResultOp>(loc, ifOp.getResult(0));
+ builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
+ builder.create<fir::ResultOp>(loc, innerArg);
+ builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
+ };
+ auto genTrueBlock = [&](const auto *e, auto &&cond) {
+ auto ifOp = builder.create<fir::IfOp>(
+ loc, mlir::TypeRange{innerArg.getType()}, fir::getBase(cond),
+ /*withElseRegion=*/true);
+ builder.create<fir::ResultOp>(loc, ifOp.getResult(0));
+ builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
+ builder.create<fir::ResultOp>(loc, innerArg);
+ builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
+ };
+ for (std::remove_const_t<decltype(size)> i = 0; i < size; ++i)
+ if (const auto *e = maskExprs[i])
+ genFalseBlock(e, genCond(e, iters));
+
+ // The last condition is either non-negated or unconditionally negated.
+ if (const auto *e = maskExprs[size])
+ genTrueBlock(e, genCond(e, iters));
+ }
+ }
+
+ // We're ready to lower the body (an assignment statement) for this context
+ // of loop nests at this point.
+ return {iters, afterLoopNest};
+ }
+
+ fir::ArrayLoadOp
+ createAndLoadSomeArrayTemp(mlir::Type type,
+ llvm::ArrayRef<mlir::Value> shape) {
+ if (ccLoadDest.hasValue())
+ return ccLoadDest.getValue()(shape);
+ auto seqTy = type.dyn_cast<fir::SequenceType>();
+ assert(seqTy && "must be an array");
+ mlir::Location loc = getLoc();
+ // TODO: Need to thread the length parameters here. For character, they may
+ //
diff er from the operands length (e.g concatenation). So the array loads
+ // type parameters are not enough.
+ if (auto charTy = seqTy.getEleTy().dyn_cast<fir::CharacterType>())
+ if (charTy.hasDynamicLen())
+ TODO(loc, "character array expression temp with dynamic length");
+ if (auto recTy = seqTy.getEleTy().dyn_cast<fir::RecordType>())
+ if (recTy.getNumLenParams() > 0)
+ TODO(loc, "derived type array expression temp with length parameters");
+ mlir::Value temp = seqTy.hasConstantShape()
+ ? builder.create<fir::AllocMemOp>(loc, type)
+ : builder.create<fir::AllocMemOp>(
+ loc, type, ".array.expr", llvm::None, shape);
+ fir::FirOpBuilder *bldr = &converter.getFirOpBuilder();
+ stmtCtx.attachCleanup(
+ [bldr, loc, temp]() { bldr->create<fir::FreeMemOp>(loc, temp); });
+ mlir::Value shapeOp = genShapeOp(shape);
+ return builder.create<fir::ArrayLoadOp>(loc, seqTy, temp, shapeOp,
+ /*slice=*/mlir::Value{},
+ llvm::None);
+ }
+
+ static fir::ShapeOp genShapeOp(mlir::Location loc, fir::FirOpBuilder &builder,
+ llvm::ArrayRef<mlir::Value> shape) {
+ mlir::IndexType idxTy = builder.getIndexType();
+ llvm::SmallVector<mlir::Value> idxShape;
+ for (auto s : shape)
+ idxShape.push_back(builder.createConvert(loc, idxTy, s));
+ auto shapeTy = fir::ShapeType::get(builder.getContext(), idxShape.size());
+ return builder.create<fir::ShapeOp>(loc, shapeTy, idxShape);
+ }
+
+ fir::ShapeOp genShapeOp(llvm::ArrayRef<mlir::Value> shape) {
+ return genShapeOp(getLoc(), builder, shape);
+ }
+
+ //===--------------------------------------------------------------------===//
+ // Expression traversal and lowering.
+ //===--------------------------------------------------------------------===//
+
+ /// Lower the expression, \p x, in a scalar context.
+ template <typename A>
+ ExtValue asScalar(const A &x) {
+ return ScalarExprLowering{getLoc(), converter, symMap, stmtCtx}.genval(x);
+ }
+
+ /// Lower the expression in a scalar context to a memory reference.
+ template <typename A>
+ ExtValue asScalarRef(const A &x) {
+ return ScalarExprLowering{getLoc(), converter, symMap, stmtCtx}.gen(x);
+ }
+
+ // An expression with non-zero rank is an array expression.
+ template <typename A>
+ bool isArray(const A &x) const {
+ return x.Rank() != 0;
+ }
+
+ /// If there were temporaries created for this element evaluation, finalize
+ /// and deallocate the resources now. This should be done just prior the the
+ /// fir::ResultOp at the end of the innermost loop.
+ void finalizeElementCtx() {
+ if (elementCtx) {
+ stmtCtx.finalize(/*popScope=*/true);
+ elementCtx = false;
+ }
+ }
+
+ template <typename A>
+ CC genScalarAndForwardValue(const A &x) {
+ ExtValue result = asScalar(x);
+ return [=](IterSpace) { return result; };
+ }
+
+ template <typename A, typename = std::enable_if_t<Fortran::common::HasMember<
+ A, Fortran::evaluate::TypelessExpression>>>
+ CC genarr(const A &x) {
+ return genScalarAndForwardValue(x);
+ }
+
+ template <typename A>
+ CC genarr(const Fortran::evaluate::Expr<A> &x) {
+ LLVM_DEBUG(Fortran::lower::DumpEvaluateExpr::dump(llvm::dbgs(), x));
+ if (isArray(x) || explicitSpaceIsActive() ||
+ isElementalProcWithArrayArgs(x))
+ return std::visit([&](const auto &e) { return genarr(e); }, x.u);
+ return genScalarAndForwardValue(x);
+ }
+
+ template <Fortran::common::TypeCategory TC1, int KIND,
+ Fortran::common::TypeCategory TC2>
+ CC genarr(const Fortran::evaluate::Convert<Fortran::evaluate::Type<TC1, KIND>,
+ TC2> &x) {
+ TODO(getLoc(), "");
+ }
+
+ template <int KIND>
+ CC genarr(const Fortran::evaluate::ComplexComponent<KIND> &x) {
+ TODO(getLoc(), "");
+ }
+
+ template <typename T>
+ CC genarr(const Fortran::evaluate::Parentheses<T> &x) {
+ TODO(getLoc(), "");
+ }
+
+ template <int KIND>
+ CC genarr(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
+ Fortran::common::TypeCategory::Integer, KIND>> &x) {
+ TODO(getLoc(), "");
+ }
+
+ template <int KIND>
+ CC genarr(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
+ Fortran::common::TypeCategory::Real, KIND>> &x) {
+ TODO(getLoc(), "");
+ }
+ template <int KIND>
+ CC genarr(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
+ Fortran::common::TypeCategory::Complex, KIND>> &x) {
+ TODO(getLoc(), "");
+ }
+
+#undef GENBIN
+#define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp) \
+ template <int KIND> \
+ CC genarr(const Fortran::evaluate::GenBinEvOp<Fortran::evaluate::Type< \
+ Fortran::common::TypeCategory::GenBinTyCat, KIND>> &x) { \
+ TODO(getLoc(), "genarr Binary"); \
+ }
+
+ GENBIN(Add, Integer, mlir::arith::AddIOp)
+ GENBIN(Add, Real, mlir::arith::AddFOp)
+ GENBIN(Add, Complex, fir::AddcOp)
+ GENBIN(Subtract, Integer, mlir::arith::SubIOp)
+ GENBIN(Subtract, Real, mlir::arith::SubFOp)
+ GENBIN(Subtract, Complex, fir::SubcOp)
+ GENBIN(Multiply, Integer, mlir::arith::MulIOp)
+ GENBIN(Multiply, Real, mlir::arith::MulFOp)
+ GENBIN(Multiply, Complex, fir::MulcOp)
+ GENBIN(Divide, Integer, mlir::arith::DivSIOp)
+ GENBIN(Divide, Real, mlir::arith::DivFOp)
+ GENBIN(Divide, Complex, fir::DivcOp)
+
+ template <Fortran::common::TypeCategory TC, int KIND>
+ CC genarr(
+ const Fortran::evaluate::Power<Fortran::evaluate::Type<TC, KIND>> &x) {
+ TODO(getLoc(), "genarr ");
+ }
+ template <Fortran::common::TypeCategory TC, int KIND>
+ CC genarr(
+ const Fortran::evaluate::Extremum<Fortran::evaluate::Type<TC, KIND>> &x) {
+ TODO(getLoc(), "genarr ");
+ }
+ template <Fortran::common::TypeCategory TC, int KIND>
+ CC genarr(
+ const Fortran::evaluate::RealToIntPower<Fortran::evaluate::Type<TC, KIND>>
+ &x) {
+ TODO(getLoc(), "genarr ");
+ }
+ template <int KIND>
+ CC genarr(const Fortran::evaluate::ComplexConstructor<KIND> &x) {
+ TODO(getLoc(), "genarr ");
+ }
+
+ template <int KIND>
+ CC genarr(const Fortran::evaluate::Concat<KIND> &x) {
+ TODO(getLoc(), "genarr ");
+ }
+
+ template <int KIND>
+ CC genarr(const Fortran::evaluate::SetLength<KIND> &x) {
+ TODO(getLoc(), "genarr ");
+ }
+
+ template <typename A>
+ CC genarr(const Fortran::evaluate::Constant<A> &x) {
+ TODO(getLoc(), "genarr ");
+ }
+
+ CC genarr(const Fortran::semantics::SymbolRef &sym,
+ ComponentPath &components) {
+ return genarr(sym.get(), components);
+ }
+
+ ExtValue abstractArrayExtValue(mlir::Value val, mlir::Value len = {}) {
+ return convertToArrayBoxValue(getLoc(), builder, val, len);
+ }
+
+ CC genarr(const ExtValue &extMemref) {
+ ComponentPath dummy(/*isImplicit=*/true);
+ return genarr(extMemref, dummy);
+ }
+
+ template <typename A>
+ CC genarr(const Fortran::evaluate::ArrayConstructor<A> &x) {
+ TODO(getLoc(), "genarr ArrayConstructor<A>");
+ }
+
+ CC genarr(const Fortran::evaluate::ImpliedDoIndex &) {
+ TODO(getLoc(), "genarr ImpliedDoIndex");
+ }
+
+ CC genarr(const Fortran::evaluate::TypeParamInquiry &x) {
+ TODO(getLoc(), "genarr TypeParamInquiry");
+ }
+
+ CC genarr(const Fortran::evaluate::DescriptorInquiry &x) {
+ TODO(getLoc(), "genarr DescriptorInquiry");
+ }
+
+ CC genarr(const Fortran::evaluate::StructureConstructor &x) {
+ TODO(getLoc(), "genarr StructureConstructor");
+ }
+
+ template <int KIND>
+ CC genarr(const Fortran::evaluate::Not<KIND> &x) {
+ TODO(getLoc(), "genarr Not");
+ }
+
+ template <int KIND>
+ CC genarr(const Fortran::evaluate::LogicalOperation<KIND> &x) {
+ TODO(getLoc(), "genarr LogicalOperation");
+ }
+
+ template <int KIND>
+ CC genarr(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
+ Fortran::common::TypeCategory::Integer, KIND>> &x) {
+ TODO(getLoc(), "genarr Relational Integer");
+ }
+ template <int KIND>
+ CC genarr(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
+ Fortran::common::TypeCategory::Character, KIND>> &x) {
+ TODO(getLoc(), "genarr Relational Character");
+ }
+ template <int KIND>
+ CC genarr(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
+ Fortran::common::TypeCategory::Real, KIND>> &x) {
+ TODO(getLoc(), "genarr Relational Real");
+ }
+ template <int KIND>
+ CC genarr(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
+ Fortran::common::TypeCategory::Complex, KIND>> &x) {
+ TODO(getLoc(), "genarr Relational Complex");
+ }
+ CC genarr(
+ const Fortran::evaluate::Relational<Fortran::evaluate::SomeType> &r) {
+ TODO(getLoc(), "genarr Relational SomeType");
+ }
+
+ template <typename A>
+ CC genarr(const Fortran::evaluate::Designator<A> &des) {
+ ComponentPath components(des.Rank() > 0);
+ return std::visit([&](const auto &x) { return genarr(x, components); },
+ des.u);
+ }
+
+ template <typename T>
+ CC genarr(const Fortran::evaluate::FunctionRef<T> &funRef) {
+ TODO(getLoc(), "genarr FunctionRef");
+ }
+
+ template <typename A>
+ CC genImplicitArrayAccess(const A &x, ComponentPath &components) {
+ components.reversePath.push_back(ImplicitSubscripts{});
+ ExtValue exv = asScalarRef(x);
+ // lowerPath(exv, components);
+ auto lambda = genarr(exv, components);
+ return [=](IterSpace iters) { return lambda(components.pc(iters)); };
+ }
+ CC genImplicitArrayAccess(const Fortran::evaluate::NamedEntity &x,
+ ComponentPath &components) {
+ if (x.IsSymbol())
+ return genImplicitArrayAccess(x.GetFirstSymbol(), components);
+ return genImplicitArrayAccess(x.GetComponent(), components);
+ }
+
+ template <typename A>
+ CC genAsScalar(const A &x) {
+ mlir::Location loc = getLoc();
+ if (isProjectedCopyInCopyOut()) {
+ return [=, &x, builder = &converter.getFirOpBuilder()](
+ IterSpace iters) -> ExtValue {
+ ExtValue exv = asScalarRef(x);
+ mlir::Value val = fir::getBase(exv);
+ mlir::Type eleTy = fir::unwrapRefType(val.getType());
+ if (isAdjustedArrayElementType(eleTy)) {
+ if (fir::isa_char(eleTy)) {
+ TODO(getLoc(), "assignment of character type");
+ } else if (fir::isa_derived(eleTy)) {
+ TODO(loc, "assignment of derived type");
+ } else {
+ fir::emitFatalError(loc, "array type not expected in scalar");
+ }
+ } else {
+ builder->create<fir::StoreOp>(loc, iters.getElement(), val);
+ }
+ return exv;
+ };
+ }
+ return [=, &x](IterSpace) { return asScalar(x); };
+ }
+
+ CC genarr(const Fortran::semantics::Symbol &x, ComponentPath &components) {
+ if (explicitSpaceIsActive()) {
+ TODO(getLoc(), "genarr Symbol explicitSpace");
+ } else {
+ return genImplicitArrayAccess(x, components);
+ }
+ }
+
+ CC genarr(const Fortran::evaluate::Component &x, ComponentPath &components) {
+ TODO(getLoc(), "genarr Component");
+ }
+
+ CC genarr(const Fortran::evaluate::ArrayRef &x, ComponentPath &components) {
+ TODO(getLoc(), "genar ArrayRef");
+ }
+
+ CC genarr(const Fortran::evaluate::CoarrayRef &x, ComponentPath &components) {
+ TODO(getLoc(), "coarray reference");
+ }
+
+ CC genarr(const Fortran::evaluate::NamedEntity &x,
+ ComponentPath &components) {
+ return x.IsSymbol() ? genarr(x.GetFirstSymbol(), components)
+ : genarr(x.GetComponent(), components);
+ }
+
+ CC genarr(const Fortran::evaluate::DataRef &x, ComponentPath &components) {
+ return std::visit([&](const auto &v) { return genarr(v, components); },
+ x.u);
+ }
+
+ CC genarr(const Fortran::evaluate::ComplexPart &x,
+ ComponentPath &components) {
+ TODO(getLoc(), "genarr ComplexPart");
+ }
+
+ CC genarr(const Fortran::evaluate::StaticDataObject::Pointer &,
+ ComponentPath &components) {
+ TODO(getLoc(), "genarr StaticDataObject::Pointer");
+ }
+
+ /// Substrings (see 9.4.1)
+ CC genarr(const Fortran::evaluate::Substring &x, ComponentPath &components) {
+ TODO(getLoc(), "genarr Substring");
+ }
+
+ /// Base case of generating an array reference,
+ CC genarr(const ExtValue &extMemref, ComponentPath &components) {
+ mlir::Location loc = getLoc();
+ mlir::Value memref = fir::getBase(extMemref);
+ mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(memref.getType());
+ assert(arrTy.isa<fir::SequenceType>() && "memory ref must be an array");
+ mlir::Value shape = builder.createShape(loc, extMemref);
+ mlir::Value slice;
+ if (components.isSlice()) {
+ TODO(loc, "genarr with Slices");
+ }
+ arrayOperands.push_back(ArrayOperand{memref, shape, slice});
+ if (destShape.empty())
+ destShape = getShape(arrayOperands.back());
+ if (isBoxValue()) {
+ TODO(loc, "genarr BoxValue");
+ }
+ if (isReferentiallyOpaque()) {
+ TODO(loc, "genarr isReferentiallyOpaque");
+ }
+ auto arrLoad = builder.create<fir::ArrayLoadOp>(
+ loc, arrTy, memref, shape, slice, fir::getTypeParams(extMemref));
+ mlir::Value arrLd = arrLoad.getResult();
+ if (isProjectedCopyInCopyOut()) {
+ // Semantics are projected copy-in copy-out.
+ // The backing store of the destination of an array expression may be
+ // partially modified. These updates are recorded in FIR by forwarding a
+ // continuation that generates an `array_update` Op. The destination is
+ // always loaded at the beginning of the statement and merged at the
+ // end.
+ destination = arrLoad;
+ auto lambda = ccStoreToDest.hasValue()
+ ? ccStoreToDest.getValue()
+ : defaultStoreToDestination(components.substring);
+ return [=](IterSpace iters) -> ExtValue { return lambda(iters); };
+ }
+ if (isCustomCopyInCopyOut()) {
+ TODO(loc, "isCustomCopyInCopyOut");
+ }
+ if (isCopyInCopyOut()) {
+ // Semantics are copy-in copy-out.
+ // The continuation simply forwards the result of the `array_load` Op,
+ // which is the value of the array as it was when loaded. All data
+ // references with rank > 0 in an array expression typically have
+ // copy-in copy-out semantics.
+ return [=](IterSpace) -> ExtValue { return arrLd; };
+ }
+ mlir::Operation::operand_range arrLdTypeParams = arrLoad.getTypeparams();
+ if (isValueAttribute()) {
+ // Semantics are value attribute.
+ // Here the continuation will `array_fetch` a value from an array and
+ // then store that value in a temporary. One can thus imitate pass by
+ // value even when the call is pass by reference.
+ return [=](IterSpace iters) -> ExtValue {
+ mlir::Value base;
+ mlir::Type eleTy = fir::applyPathToType(arrTy, iters.iterVec());
+ if (isAdjustedArrayElementType(eleTy)) {
+ mlir::Type eleRefTy = builder.getRefType(eleTy);
+ base = builder.create<fir::ArrayAccessOp>(
+ loc, eleRefTy, arrLd, iters.iterVec(), arrLdTypeParams);
+ } else {
+ base = builder.create<fir::ArrayFetchOp>(
+ loc, eleTy, arrLd, iters.iterVec(), arrLdTypeParams);
+ }
+ mlir::Value temp = builder.createTemporary(
+ loc, base.getType(),
+ llvm::ArrayRef<mlir::NamedAttribute>{
+ Fortran::lower::getAdaptToByRefAttr(builder)});
+ builder.create<fir::StoreOp>(loc, base, temp);
+ return fir::factory::arraySectionElementToExtendedValue(
+ builder, loc, extMemref, temp, slice);
+ };
+ }
+ // In the default case, the array reference forwards an `array_fetch` or
+ // `array_access` Op in the continuation.
+ return [=](IterSpace iters) -> ExtValue {
+ mlir::Type eleTy = fir::applyPathToType(arrTy, iters.iterVec());
+ if (isAdjustedArrayElementType(eleTy)) {
+ mlir::Type eleRefTy = builder.getRefType(eleTy);
+ mlir::Value arrayOp = builder.create<fir::ArrayAccessOp>(
+ loc, eleRefTy, arrLd, iters.iterVec(), arrLdTypeParams);
+ if (auto charTy = eleTy.dyn_cast<fir::CharacterType>()) {
+ llvm::SmallVector<mlir::Value> substringBounds;
+ populateBounds(substringBounds, components.substring);
+ if (!substringBounds.empty()) {
+ // mlir::Value dstLen = fir::factory::genLenOfCharacter(
+ // builder, loc, arrLoad, iters.iterVec(), substringBounds);
+ // fir::CharBoxValue dstChar(arrayOp, dstLen);
+ // return fir::factory::CharacterExprHelper{builder, loc}
+ // .createSubstring(dstChar, substringBounds);
+ }
+ }
+ return fir::factory::arraySectionElementToExtendedValue(
+ builder, loc, extMemref, arrayOp, slice);
+ }
+ auto arrFetch = builder.create<fir::ArrayFetchOp>(
+ loc, eleTy, arrLd, iters.iterVec(), arrLdTypeParams);
+ return fir::factory::arraySectionElementToExtendedValue(
+ builder, loc, extMemref, arrFetch, slice);
+ };
+ }
+
+ /// Reduce the rank of a array to be boxed based on the slice's operands.
+ static mlir::Type reduceRank(mlir::Type arrTy, mlir::Value slice) {
+ if (slice) {
+ auto slOp = mlir::dyn_cast<fir::SliceOp>(slice.getDefiningOp());
+ assert(slOp && "expected slice op");
+ auto seqTy = arrTy.dyn_cast<fir::SequenceType>();
+ assert(seqTy && "expected array type");
+ mlir::Operation::operand_range triples = slOp.getTriples();
+ fir::SequenceType::Shape shape;
+ // reduce the rank for each invariant dimension
+ for (unsigned i = 1, end = triples.size(); i < end; i += 3)
+ if (!mlir::isa_and_nonnull<fir::UndefOp>(triples[i].getDefiningOp()))
+ shape.push_back(fir::SequenceType::getUnknownExtent());
+ return fir::SequenceType::get(shape, seqTy.getEleTy());
+ }
+ // not sliced, so no change in rank
+ return arrTy;
+ }
+
+private:
+ void determineShapeOfDest(const fir::ExtendedValue &lhs) {
+ destShape = fir::factory::getExtents(builder, getLoc(), lhs);
+ }
+
+ void determineShapeOfDest(const Fortran::lower::SomeExpr &lhs) {
+ if (!destShape.empty())
+ return;
+ // if (explicitSpaceIsActive() && determineShapeWithSlice(lhs))
+ // return;
+ mlir::Type idxTy = builder.getIndexType();
+ mlir::Location loc = getLoc();
+ if (std::optional<Fortran::evaluate::ConstantSubscripts> constantShape =
+ Fortran::evaluate::GetConstantExtents(converter.getFoldingContext(),
+ lhs))
+ for (Fortran::common::ConstantSubscript extent : *constantShape)
+ destShape.push_back(builder.createIntegerConstant(loc, idxTy, extent));
+ }
+
+ ExtValue lowerArrayExpression(const Fortran::lower::SomeExpr &exp) {
+ mlir::Type resTy = converter.genType(exp);
+ return std::visit(
+ [&](const auto &e) { return lowerArrayExpression(genarr(e), resTy); },
+ exp.u);
+ }
+ ExtValue lowerArrayExpression(const ExtValue &exv) {
+ assert(!explicitSpace);
+ mlir::Type resTy = fir::unwrapPassByRefType(fir::getBase(exv).getType());
+ return lowerArrayExpression(genarr(exv), resTy);
+ }
+
+ void populateBounds(llvm::SmallVectorImpl<mlir::Value> &bounds,
+ const Fortran::evaluate::Substring *substring) {
+ if (!substring)
+ return;
+ bounds.push_back(fir::getBase(asScalar(substring->lower())));
+ if (auto upper = substring->upper())
+ bounds.push_back(fir::getBase(asScalar(*upper)));
+ }
+
+ /// Default store to destination implementation.
+ /// This implements the default case, which is to assign the value in
+ /// `iters.element` into the destination array, `iters.innerArgument`. Handles
+ /// by value and by reference assignment.
+ CC defaultStoreToDestination(const Fortran::evaluate::Substring *substring) {
+ return [=](IterSpace iterSpace) -> ExtValue {
+ mlir::Location loc = getLoc();
+ mlir::Value innerArg = iterSpace.innerArgument();
+ fir::ExtendedValue exv = iterSpace.elementExv();
+ mlir::Type arrTy = innerArg.getType();
+ mlir::Type eleTy = fir::applyPathToType(arrTy, iterSpace.iterVec());
+ if (isAdjustedArrayElementType(eleTy)) {
+ TODO(loc, "isAdjustedArrayElementType");
+ }
+ // By value semantics. The element is being assigned by value.
+ mlir::Value ele = builder.createConvert(loc, eleTy, fir::getBase(exv));
+ auto update = builder.create<fir::ArrayUpdateOp>(
+ loc, arrTy, innerArg, ele, iterSpace.iterVec(),
+ destination.getTypeparams());
+ return abstractArrayExtValue(update);
+ };
+ }
+
+ /// For an elemental array expression.
+ /// 1. Lower the scalars and array loads.
+ /// 2. Create the iteration space.
+ /// 3. Create the element-by-element computation in the loop.
+ /// 4. Return the resulting array value.
+ /// If no destination was set in the array context, a temporary of
+ /// \p resultTy will be created to hold the evaluated expression.
+ /// Otherwise, \p resultTy is ignored and the expression is evaluated
+ /// in the destination. \p f is a continuation built from an
+ /// evaluate::Expr or an ExtendedValue.
+ ExtValue lowerArrayExpression(CC f, mlir::Type resultTy) {
+ mlir::Location loc = getLoc();
+ auto [iterSpace, insPt] = genIterSpace(resultTy);
+ auto exv = f(iterSpace);
+ iterSpace.setElement(std::move(exv));
+ auto lambda = ccStoreToDest.hasValue()
+ ? ccStoreToDest.getValue()
+ : defaultStoreToDestination(/*substring=*/nullptr);
+ mlir::Value updVal = fir::getBase(lambda(iterSpace));
+ finalizeElementCtx();
+ builder.create<fir::ResultOp>(loc, updVal);
+ builder.restoreInsertionPoint(insPt);
+ return abstractArrayExtValue(iterSpace.outerResult());
+ }
+
+ /// Get the shape from an ArrayOperand. The shape of the array is adjusted if
+ /// the array was sliced.
+ llvm::SmallVector<mlir::Value> getShape(ArrayOperand array) {
+ // if (array.slice)
+ // return computeSliceShape(array.slice);
+ 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()};
+ }
+
+ /// Get the shape from an ArrayLoad.
+ llvm::SmallVector<mlir::Value> getShape(fir::ArrayLoadOp arrayLoad) {
+ return getShape(ArrayOperand{arrayLoad.getMemref(), arrayLoad.getShape(),
+ arrayLoad.getSlice()});
+ }
+
+ /// Returns the first array operand that may not be absent. If all
+ /// array operands may be absent, return the first one.
+ const ArrayOperand &getInducingShapeArrayOperand() const {
+ assert(!arrayOperands.empty());
+ for (const ArrayOperand &op : arrayOperands)
+ if (!op.mayBeAbsent)
+ return op;
+ // If all arrays operand appears in optional position, then none of them
+ // is allowed to be absent as per 15.5.2.12 point 3. (6). Just pick the
+ // first operands.
+ // TODO: There is an opportunity to add a runtime check here that
+ // this array is present as required.
+ return arrayOperands[0];
+ }
+
+ /// Generate the shape of the iteration space over the array expression. The
+ /// iteration space may be implicit, explicit, or both. If it is implied it is
+ /// based on the destination and operand array loads, or an optional
+ /// Fortran::evaluate::Shape from the front end. If the shape is explicit,
+ /// this returns any implicit shape component, if it exists.
+ llvm::SmallVector<mlir::Value> genIterationShape() {
+ // Use the precomputed destination shape.
+ if (!destShape.empty())
+ return destShape;
+ // Otherwise, use the destination's shape.
+ if (destination)
+ return getShape(destination);
+ // Otherwise, use the first ArrayLoad operand shape.
+ if (!arrayOperands.empty())
+ return getShape(getInducingShapeArrayOperand());
+ fir::emitFatalError(getLoc(),
+ "failed to compute the array expression shape");
+ }
+
+ bool explicitSpaceIsActive() const {
+ return explicitSpace && explicitSpace->isActive();
+ }
+
+ bool implicitSpaceHasMasks() const {
+ return implicitSpace && !implicitSpace->empty();
+ }
+
+ explicit ArrayExprLowering(Fortran::lower::AbstractConverter &converter,
+ Fortran::lower::StatementContext &stmtCtx,
+ Fortran::lower::SymMap &symMap)
+ : converter{converter}, builder{converter.getFirOpBuilder()},
+ stmtCtx{stmtCtx}, symMap{symMap} {}
+
+ explicit ArrayExprLowering(Fortran::lower::AbstractConverter &converter,
+ Fortran::lower::StatementContext &stmtCtx,
+ Fortran::lower::SymMap &symMap,
+ ConstituentSemantics sem)
+ : converter{converter}, builder{converter.getFirOpBuilder()},
+ stmtCtx{stmtCtx}, symMap{symMap}, semant{sem} {}
+
+ explicit ArrayExprLowering(Fortran::lower::AbstractConverter &converter,
+ Fortran::lower::StatementContext &stmtCtx,
+ Fortran::lower::SymMap &symMap,
+ ConstituentSemantics sem,
+ Fortran::lower::ExplicitIterSpace *expSpace,
+ Fortran::lower::ImplicitIterSpace *impSpace)
+ : converter{converter}, builder{converter.getFirOpBuilder()},
+ stmtCtx{stmtCtx}, symMap{symMap},
+ explicitSpace(expSpace->isActive() ? expSpace : nullptr),
+ implicitSpace(impSpace->empty() ? nullptr : impSpace), semant{sem} {
+ // Generate any mask expressions, as necessary. This is the compute step
+ // that creates the effective masks. See 10.2.3.2 in particular.
+ // genMasks();
+ }
+
+ mlir::Location getLoc() { return converter.getCurrentLocation(); }
+
+ /// Array appears in a lhs context such that it is assigned after the rhs is
+ /// fully evaluated.
+ inline bool isCopyInCopyOut() {
+ return semant == ConstituentSemantics::CopyInCopyOut;
+ }
+
+ /// Array appears in a lhs (or temp) context such that a projected,
+ /// discontiguous subspace of the array is assigned after the rhs is fully
+ /// evaluated. That is, the rhs array value is merged into a section of the
+ /// lhs array.
+ inline bool isProjectedCopyInCopyOut() {
+ return semant == ConstituentSemantics::ProjectedCopyInCopyOut;
+ }
+
+ inline bool isCustomCopyInCopyOut() {
+ return semant == ConstituentSemantics::CustomCopyInCopyOut;
+ }
+
+ /// Array appears in a context where it must be boxed.
+ inline bool isBoxValue() { return semant == ConstituentSemantics::BoxValue; }
+
+ /// Array appears in a context where
diff erences in the memory reference can
+ /// be observable in the computational results. For example, an array
+ /// element is passed to an impure procedure.
+ inline bool isReferentiallyOpaque() {
+ return semant == ConstituentSemantics::RefOpaque;
+ }
+
+ /// Array appears in a context where it is passed as a VALUE argument.
+ inline bool isValueAttribute() {
+ return semant == ConstituentSemantics::ByValueArg;
+ }
+
+ /// Can the loops over the expression be unordered?
+ inline bool isUnordered() const { return unordered; }
+
+ void setUnordered(bool b) { unordered = b; }
+
+ Fortran::lower::AbstractConverter &converter;
+ fir::FirOpBuilder &builder;
+ Fortran::lower::StatementContext &stmtCtx;
+ bool elementCtx = false;
+ Fortran::lower::SymMap &symMap;
+ /// The continuation to generate code to update the destination.
+ llvm::Optional<CC> ccStoreToDest;
+ llvm::Optional<std::function<void(llvm::ArrayRef<mlir::Value>)>> ccPrelude;
+ llvm::Optional<std::function<fir::ArrayLoadOp(llvm::ArrayRef<mlir::Value>)>>
+ ccLoadDest;
+ /// The destination is the loaded array into which the results will be
+ /// merged.
+ fir::ArrayLoadOp destination;
+ /// The shape of the destination.
+ llvm::SmallVector<mlir::Value> destShape;
+ /// List of arrays in the expression that have been loaded.
+ llvm::SmallVector<ArrayOperand> arrayOperands;
+ /// If there is a user-defined iteration space, explicitShape will hold the
+ /// information from the front end.
+ Fortran::lower::ExplicitIterSpace *explicitSpace = nullptr;
+ Fortran::lower::ImplicitIterSpace *implicitSpace = nullptr;
+ ConstituentSemantics semant = ConstituentSemantics::RefTransparent;
+ // 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;
+};
+} // namespace
+
fir::ExtendedValue Fortran::lower::createSomeExtendedExpression(
mlir::Location loc, Fortran::lower::AbstractConverter &converter,
const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
@@ -1314,3 +2582,36 @@ mlir::Value Fortran::lower::createSubroutineCall(
loc, converter, toEvExpr(call), symMap, stmtCtx);
return fir::getBase(res);
}
+
+void Fortran::lower::createSomeArrayAssignment(
+ Fortran::lower::AbstractConverter &converter,
+ const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
+ Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
+ LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "onto array: ") << '\n';
+ rhs.AsFortran(llvm::dbgs() << "assign expression: ") << '\n';);
+ ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs);
+}
+
+void Fortran::lower::createSomeArrayAssignment(
+ Fortran::lower::AbstractConverter &converter, const fir::ExtendedValue &lhs,
+ const fir::ExtendedValue &rhs, Fortran::lower::SymMap &symMap,
+ Fortran::lower::StatementContext &stmtCtx) {
+ LLVM_DEBUG(llvm::dbgs() << "onto array: " << lhs << '\n';
+ llvm::dbgs() << "assign expression: " << rhs << '\n';);
+ ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs);
+}
+
+void Fortran::lower::createAllocatableArrayAssignment(
+ Fortran::lower::AbstractConverter &converter,
+ const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
+ Fortran::lower::ExplicitIterSpace &explicitSpace,
+ Fortran::lower::ImplicitIterSpace &implicitSpace,
+ Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
+ LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "defining array: ") << '\n';
+ rhs.AsFortran(llvm::dbgs() << "assign expression: ")
+ << " given the explicit iteration space:\n"
+ << explicitSpace << "\n and implied mask conditions:\n"
+ << implicitSpace << '\n';);
+ ArrayExprLowering::lowerAllocatableArrayAssignment(
+ converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace);
+}
diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index a2e7e1de85b97..771f3ad18e713 100644
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -301,13 +301,13 @@ void Fortran::lower::mapSymbolAttributes(
//===--------------------------------------------------------------===//
[&](const Fortran::lower::details::ScalarStaticChar &x) {
- TODO(loc, "mapSymbolAttributes ScalarStaticChar");
+ TODO(loc, "ScalarStaticChar variable lowering");
},
//===--------------------------------------------------------------===//
[&](const Fortran::lower::details::ScalarDynamicChar &x) {
- TODO(loc, "mapSymbolAttributes ScalarDynamicChar");
+ TODO(loc, "ScalarDynamicChar variable lowering");
},
//===--------------------------------------------------------------===//
@@ -346,31 +346,31 @@ void Fortran::lower::mapSymbolAttributes(
//===--------------------------------------------------------------===//
[&](const Fortran::lower::details::DynamicArray &x) {
- TODO(loc, "mapSymbolAttributes DynamicArray");
+ TODO(loc, "DynamicArray variable lowering");
},
//===--------------------------------------------------------------===//
[&](const Fortran::lower::details::StaticArrayStaticChar &x) {
- TODO(loc, "mapSymbolAttributes StaticArrayStaticChar");
+ TODO(loc, "StaticArrayStaticChar variable lowering");
},
//===--------------------------------------------------------------===//
[&](const Fortran::lower::details::StaticArrayDynamicChar &x) {
- TODO(loc, "mapSymbolAttributes StaticArrayDynamicChar");
+ TODO(loc, "StaticArrayDynamicChar variable lowering");
},
//===--------------------------------------------------------------===//
[&](const Fortran::lower::details::DynamicArrayStaticChar &x) {
- TODO(loc, "mapSymbolAttributes DynamicArrayStaticChar");
+ TODO(loc, "DynamicArrayStaticChar variable lowering");
},
//===--------------------------------------------------------------===//
[&](const Fortran::lower::details::DynamicArrayDynamicChar &x) {
- TODO(loc, "mapSymbolAttributes DynamicArrayDynamicChar");
+ TODO(loc, "DynamicArrayDynamicChar variable lowering");
},
//===--------------------------------------------------------------===//
diff --git a/flang/lib/Lower/DumpEvaluateExpr.cpp b/flang/lib/Lower/DumpEvaluateExpr.cpp
new file mode 100644
index 0000000000000..9273e94d702f8
--- /dev/null
+++ b/flang/lib/Lower/DumpEvaluateExpr.cpp
@@ -0,0 +1,272 @@
+//===-- Lower/DumpEvaluateExpr.cpp ----------------------------------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#include "flang/Lower/DumpEvaluateExpr.h"
+#include <iostream>
+
+static constexpr char whiteSpacePadding[] =
+ ">> ";
+static constexpr auto whiteSize = sizeof(whiteSpacePadding) - 1;
+
+inline const char *Fortran::lower::DumpEvaluateExpr::getIndentString() const {
+ auto count = (level * 2 >= whiteSize) ? whiteSize : level * 2;
+ return whiteSpacePadding + whiteSize - count;
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::evaluate::CoarrayRef &x) {
+ indent("coarray ref");
+ show(x.base());
+ show(x.subscript());
+ show(x.cosubscript());
+ show(x.stat());
+ show(x.team());
+ outdent();
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::evaluate::BOZLiteralConstant &) {
+ print("BOZ literal constant");
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::evaluate::NullPointer &) {
+ print("null pointer");
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::semantics::Symbol &symbol) {
+ const auto &ultimate{symbol.GetUltimate()};
+ print("symbol: "s + std::string(toStringRef(symbol.name())));
+ if (const auto *assoc =
+ ultimate.detailsIf<Fortran::semantics::AssocEntityDetails>()) {
+ indent("assoc details");
+ show(assoc->expr());
+ outdent();
+ }
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::evaluate::StaticDataObject &) {
+ print("static data object");
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::evaluate::ImpliedDoIndex &) {
+ print("implied do index");
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::evaluate::BaseObject &x) {
+ indent("base object");
+ show(x.u);
+ outdent();
+}
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::evaluate::Component &x) {
+ indent("component");
+ show(x.base());
+ show(x.GetLastSymbol());
+ outdent();
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::evaluate::NamedEntity &x) {
+ indent("named entity");
+ if (const auto *component = x.UnwrapComponent())
+ show(*component);
+ else
+ show(x.GetFirstSymbol());
+ outdent();
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::evaluate::TypeParamInquiry &x) {
+ indent("type inquiry");
+ show(x.base());
+ outdent();
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::evaluate::Triplet &x) {
+ indent("triplet");
+ show(x.lower());
+ show(x.upper());
+ show(x.stride());
+ outdent();
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::evaluate::Subscript &x) {
+ indent("subscript");
+ show(x.u);
+ outdent();
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::evaluate::ArrayRef &x) {
+ indent("array ref");
+ show(x.base());
+ show(x.subscript());
+ outdent();
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::evaluate::DataRef &x) {
+ indent("data ref");
+ show(x.u);
+ outdent();
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::evaluate::Substring &x) {
+ indent("substring");
+ show(x.parent());
+ show(x.lower());
+ show(x.upper());
+ outdent();
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::semantics::ParamValue &x) {
+ indent("param value");
+ show(x.GetExplicit());
+ outdent();
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::semantics::DerivedTypeSpec::ParameterMapType::value_type
+ &x) {
+ show(x.second);
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::semantics::DerivedTypeSpec &x) {
+ indent("derived type spec");
+ for (auto &v : x.parameters())
+ show(v);
+ outdent();
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::evaluate::StructureConstructorValues::value_type &x) {
+ show(x.second);
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::evaluate::StructureConstructor &x) {
+ indent("structure constructor");
+ show(x.derivedTypeSpec());
+ for (auto &v : x)
+ show(v);
+ outdent();
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::evaluate::Relational<Fortran::evaluate::SomeType> &x) {
+ indent("expr some type");
+ show(x.u);
+ outdent();
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::evaluate::ComplexPart &x) {
+ indent("complex part");
+ show(x.complex());
+ outdent();
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::evaluate::ActualArgument &x) {
+ indent("actual argument");
+ if (const auto *symbol = x.GetAssumedTypeDummy())
+ show(*symbol);
+ else
+ show(x.UnwrapExpr());
+ outdent();
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::evaluate::ProcedureDesignator &x) {
+ indent("procedure designator");
+ if (const auto *component = x.GetComponent())
+ show(*component);
+ else if (const auto *symbol = x.GetSymbol())
+ show(*symbol);
+ else
+ show(DEREF(x.GetSpecificIntrinsic()));
+ outdent();
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::evaluate::SpecificIntrinsic &) {
+ print("specific intrinsic");
+}
+
+void Fortran::lower::DumpEvaluateExpr::show(
+ const Fortran::evaluate::DescriptorInquiry &x) {
+ indent("descriptor inquiry");
+ show(x.base());
+ outdent();
+}
+
+void Fortran::lower::DumpEvaluateExpr::print(llvm::Twine twine) {
+ outs << getIndentString() << twine << '\n';
+}
+
+void Fortran::lower::DumpEvaluateExpr::indent(llvm::StringRef s) {
+ print(s + " {");
+ level++;
+}
+
+void Fortran::lower::DumpEvaluateExpr::outdent() {
+ if (level)
+ level--;
+ print("}");
+}
+
+//===----------------------------------------------------------------------===//
+// Boilerplate entry points that the debugger can find.
+//===----------------------------------------------------------------------===//
+
+void Fortran::lower::dumpEvExpr(const Fortran::semantics::SomeExpr &x) {
+ DumpEvaluateExpr::dump(x);
+}
+
+void Fortran::lower::dumpEvExpr(
+ const Fortran::evaluate::Expr<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer, 4>>
+ &x) {
+ DumpEvaluateExpr::dump(x);
+}
+
+void Fortran::lower::dumpEvExpr(
+ const Fortran::evaluate::Expr<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer, 8>>
+ &x) {
+ DumpEvaluateExpr::dump(x);
+}
+
+void Fortran::lower::dumpEvExpr(const Fortran::evaluate::ArrayRef &x) {
+ DumpEvaluateExpr::dump(x);
+}
+
+void Fortran::lower::dumpEvExpr(const Fortran::evaluate::DataRef &x) {
+ DumpEvaluateExpr::dump(x);
+}
+
+void Fortran::lower::dumpEvExpr(const Fortran::evaluate::Substring &x) {
+ DumpEvaluateExpr::dump(x);
+}
+
+void Fortran::lower::dumpEvExpr(
+ const Fortran::evaluate::Designator<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer, 4>>
+ &x) {
+ DumpEvaluateExpr::dump(x);
+}
diff --git a/flang/lib/Lower/IterationSpace.cpp b/flang/lib/Lower/IterationSpace.cpp
new file mode 100644
index 0000000000000..4d7a7f8cda0f8
--- /dev/null
+++ b/flang/lib/Lower/IterationSpace.cpp
@@ -0,0 +1,940 @@
+//===-- IterationSpace.cpp ------------------------------------------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+//
+// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
+//
+//===----------------------------------------------------------------------===//
+
+#include "flang/Lower/IterationSpace.h"
+#include "flang/Evaluate/expression.h"
+#include "flang/Lower/AbstractConverter.h"
+#include "flang/Lower/Support/Utils.h"
+#include "llvm/Support/Debug.h"
+
+#define DEBUG_TYPE "flang-lower-iteration-space"
+
+namespace {
+// Fortran::evaluate::Expr are functional values organized like an AST. A
+// Fortran::evaluate::Expr is meant to be moved and cloned. Using the front end
+// tools can often cause copies and extra wrapper classes to be added to any
+// Fortran::evalute::Expr. These values should not be assumed or relied upon to
+// have an *object* identity. They are deeply recursive, irregular structures
+// built from a large number of classes which do not use inheritance and
+// necessitate a large volume of boilerplate code as a result.
+//
+// Contrastingly, LLVM data structures make ubiquitous assumptions about an
+// object's identity via pointers to the object. An object's location in memory
+// is thus very often an identifying relation.
+
+// This class defines a hash computation of a Fortran::evaluate::Expr tree value
+// so it can be used with llvm::DenseMap. The Fortran::evaluate::Expr need not
+// have the same address.
+class HashEvaluateExpr {
+public:
+ // A Se::Symbol is the only part of an Fortran::evaluate::Expr with an
+ // identity property.
+ static unsigned getHashValue(const Fortran::semantics::Symbol &x) {
+ return static_cast<unsigned>(reinterpret_cast<std::intptr_t>(&x));
+ }
+ template <typename A, bool COPY>
+ static unsigned getHashValue(const Fortran::common::Indirection<A, COPY> &x) {
+ return getHashValue(x.value());
+ }
+ template <typename A>
+ static unsigned getHashValue(const std::optional<A> &x) {
+ if (x.has_value())
+ return getHashValue(x.value());
+ return 0u;
+ }
+ static unsigned getHashValue(const Fortran::evaluate::Subscript &x) {
+ return std::visit([&](const auto &v) { return getHashValue(v); }, x.u);
+ }
+ static unsigned getHashValue(const Fortran::evaluate::Triplet &x) {
+ return getHashValue(x.lower()) - getHashValue(x.upper()) * 5u -
+ getHashValue(x.stride()) * 11u;
+ }
+ static unsigned getHashValue(const Fortran::evaluate::Component &x) {
+ return getHashValue(x.base()) * 83u - getHashValue(x.GetLastSymbol());
+ }
+ static unsigned getHashValue(const Fortran::evaluate::ArrayRef &x) {
+ unsigned subs = 1u;
+ for (const Fortran::evaluate::Subscript &v : x.subscript())
+ subs -= getHashValue(v);
+ return getHashValue(x.base()) * 89u - subs;
+ }
+ static unsigned getHashValue(const Fortran::evaluate::CoarrayRef &x) {
+ unsigned subs = 1u;
+ for (const Fortran::evaluate::Subscript &v : x.subscript())
+ subs -= getHashValue(v);
+ unsigned cosubs = 3u;
+ for (const Fortran::evaluate::Expr<Fortran::evaluate::SubscriptInteger> &v :
+ x.cosubscript())
+ cosubs -= getHashValue(v);
+ unsigned syms = 7u;
+ for (const Fortran::evaluate::SymbolRef &v : x.base())
+ syms += getHashValue(v);
+ return syms * 97u - subs - cosubs + getHashValue(x.stat()) + 257u +
+ getHashValue(x.team());
+ }
+ static unsigned getHashValue(const Fortran::evaluate::NamedEntity &x) {
+ if (x.IsSymbol())
+ return getHashValue(x.GetFirstSymbol()) * 11u;
+ return getHashValue(x.GetComponent()) * 13u;
+ }
+ static unsigned getHashValue(const Fortran::evaluate::DataRef &x) {
+ return std::visit([&](const auto &v) { return getHashValue(v); }, x.u);
+ }
+ static unsigned getHashValue(const Fortran::evaluate::ComplexPart &x) {
+ return getHashValue(x.complex()) - static_cast<unsigned>(x.part());
+ }
+ template <Fortran::common::TypeCategory TC1, int KIND,
+ Fortran::common::TypeCategory TC2>
+ static unsigned getHashValue(
+ const Fortran::evaluate::Convert<Fortran::evaluate::Type<TC1, KIND>, TC2>
+ &x) {
+ return getHashValue(x.left()) - (static_cast<unsigned>(TC1) + 2u) -
+ (static_cast<unsigned>(KIND) + 5u);
+ }
+ template <int KIND>
+ static unsigned
+ getHashValue(const Fortran::evaluate::ComplexComponent<KIND> &x) {
+ return getHashValue(x.left()) -
+ (static_cast<unsigned>(x.isImaginaryPart) + 1u) * 3u;
+ }
+ template <typename T>
+ static unsigned getHashValue(const Fortran::evaluate::Parentheses<T> &x) {
+ return getHashValue(x.left()) * 17u;
+ }
+ template <Fortran::common::TypeCategory TC, int KIND>
+ static unsigned getHashValue(
+ const Fortran::evaluate::Negate<Fortran::evaluate::Type<TC, KIND>> &x) {
+ return getHashValue(x.left()) - (static_cast<unsigned>(TC) + 5u) -
+ (static_cast<unsigned>(KIND) + 7u);
+ }
+ template <Fortran::common::TypeCategory TC, int KIND>
+ static unsigned getHashValue(
+ const Fortran::evaluate::Add<Fortran::evaluate::Type<TC, KIND>> &x) {
+ return (getHashValue(x.left()) + getHashValue(x.right())) * 23u +
+ static_cast<unsigned>(TC) + static_cast<unsigned>(KIND);
+ }
+ template <Fortran::common::TypeCategory TC, int KIND>
+ static unsigned getHashValue(
+ const Fortran::evaluate::Subtract<Fortran::evaluate::Type<TC, KIND>> &x) {
+ return (getHashValue(x.left()) - getHashValue(x.right())) * 19u +
+ static_cast<unsigned>(TC) + static_cast<unsigned>(KIND);
+ }
+ template <Fortran::common::TypeCategory TC, int KIND>
+ static unsigned getHashValue(
+ const Fortran::evaluate::Multiply<Fortran::evaluate::Type<TC, KIND>> &x) {
+ return (getHashValue(x.left()) + getHashValue(x.right())) * 29u +
+ static_cast<unsigned>(TC) + static_cast<unsigned>(KIND);
+ }
+ template <Fortran::common::TypeCategory TC, int KIND>
+ static unsigned getHashValue(
+ const Fortran::evaluate::Divide<Fortran::evaluate::Type<TC, KIND>> &x) {
+ return (getHashValue(x.left()) - getHashValue(x.right())) * 31u +
+ static_cast<unsigned>(TC) + static_cast<unsigned>(KIND);
+ }
+ template <Fortran::common::TypeCategory TC, int KIND>
+ static unsigned getHashValue(
+ const Fortran::evaluate::Power<Fortran::evaluate::Type<TC, KIND>> &x) {
+ return (getHashValue(x.left()) - getHashValue(x.right())) * 37u +
+ static_cast<unsigned>(TC) + static_cast<unsigned>(KIND);
+ }
+ template <Fortran::common::TypeCategory TC, int KIND>
+ static unsigned getHashValue(
+ const Fortran::evaluate::Extremum<Fortran::evaluate::Type<TC, KIND>> &x) {
+ return (getHashValue(x.left()) + getHashValue(x.right())) * 41u +
+ static_cast<unsigned>(TC) + static_cast<unsigned>(KIND) +
+ static_cast<unsigned>(x.ordering) * 7u;
+ }
+ template <Fortran::common::TypeCategory TC, int KIND>
+ static unsigned getHashValue(
+ const Fortran::evaluate::RealToIntPower<Fortran::evaluate::Type<TC, KIND>>
+ &x) {
+ return (getHashValue(x.left()) - getHashValue(x.right())) * 43u +
+ static_cast<unsigned>(TC) + static_cast<unsigned>(KIND);
+ }
+ template <int KIND>
+ static unsigned
+ getHashValue(const Fortran::evaluate::ComplexConstructor<KIND> &x) {
+ return (getHashValue(x.left()) - getHashValue(x.right())) * 47u +
+ static_cast<unsigned>(KIND);
+ }
+ template <int KIND>
+ static unsigned getHashValue(const Fortran::evaluate::Concat<KIND> &x) {
+ return (getHashValue(x.left()) - getHashValue(x.right())) * 53u +
+ static_cast<unsigned>(KIND);
+ }
+ template <int KIND>
+ static unsigned getHashValue(const Fortran::evaluate::SetLength<KIND> &x) {
+ return (getHashValue(x.left()) - getHashValue(x.right())) * 59u +
+ static_cast<unsigned>(KIND);
+ }
+ static unsigned getHashValue(const Fortran::semantics::SymbolRef &sym) {
+ return getHashValue(sym.get());
+ }
+ static unsigned getHashValue(const Fortran::evaluate::Substring &x) {
+ return 61u * std::visit([&](const auto &p) { return getHashValue(p); },
+ x.parent()) -
+ getHashValue(x.lower()) - (getHashValue(x.lower()) + 1u);
+ }
+ static unsigned
+ getHashValue(const Fortran::evaluate::StaticDataObject::Pointer &x) {
+ return llvm::hash_value(x->name());
+ }
+ static unsigned getHashValue(const Fortran::evaluate::SpecificIntrinsic &x) {
+ return llvm::hash_value(x.name);
+ }
+ template <typename A>
+ static unsigned getHashValue(const Fortran::evaluate::Constant<A> &x) {
+ // FIXME: Should hash the content.
+ return 103u;
+ }
+ static unsigned getHashValue(const Fortran::evaluate::ActualArgument &x) {
+ if (const Fortran::evaluate::Symbol *sym = x.GetAssumedTypeDummy())
+ return getHashValue(*sym);
+ return getHashValue(*x.UnwrapExpr());
+ }
+ static unsigned
+ getHashValue(const Fortran::evaluate::ProcedureDesignator &x) {
+ return std::visit([&](const auto &v) { return getHashValue(v); }, x.u);
+ }
+ static unsigned getHashValue(const Fortran::evaluate::ProcedureRef &x) {
+ unsigned args = 13u;
+ for (const std::optional<Fortran::evaluate::ActualArgument> &v :
+ x.arguments())
+ args -= getHashValue(v);
+ return getHashValue(x.proc()) * 101u - args;
+ }
+ template <typename A>
+ static unsigned
+ getHashValue(const Fortran::evaluate::ArrayConstructor<A> &x) {
+ // FIXME: hash the contents.
+ return 127u;
+ }
+ static unsigned getHashValue(const Fortran::evaluate::ImpliedDoIndex &x) {
+ return llvm::hash_value(toStringRef(x.name).str()) * 131u;
+ }
+ static unsigned getHashValue(const Fortran::evaluate::TypeParamInquiry &x) {
+ return getHashValue(x.base()) * 137u - getHashValue(x.parameter()) * 3u;
+ }
+ static unsigned getHashValue(const Fortran::evaluate::DescriptorInquiry &x) {
+ return getHashValue(x.base()) * 139u -
+ static_cast<unsigned>(x.field()) * 13u +
+ static_cast<unsigned>(x.dimension());
+ }
+ static unsigned
+ getHashValue(const Fortran::evaluate::StructureConstructor &x) {
+ // FIXME: hash the contents.
+ return 149u;
+ }
+ template <int KIND>
+ static unsigned getHashValue(const Fortran::evaluate::Not<KIND> &x) {
+ return getHashValue(x.left()) * 61u + static_cast<unsigned>(KIND);
+ }
+ template <int KIND>
+ static unsigned
+ getHashValue(const Fortran::evaluate::LogicalOperation<KIND> &x) {
+ unsigned result = getHashValue(x.left()) + getHashValue(x.right());
+ return result * 67u + static_cast<unsigned>(x.logicalOperator) * 5u;
+ }
+ template <Fortran::common::TypeCategory TC, int KIND>
+ static unsigned getHashValue(
+ const Fortran::evaluate::Relational<Fortran::evaluate::Type<TC, KIND>>
+ &x) {
+ return (getHashValue(x.left()) + getHashValue(x.right())) * 71u +
+ static_cast<unsigned>(TC) + static_cast<unsigned>(KIND) +
+ static_cast<unsigned>(x.opr) * 11u;
+ }
+ template <typename A>
+ static unsigned getHashValue(const Fortran::evaluate::Expr<A> &x) {
+ return std::visit([&](const auto &v) { return getHashValue(v); }, x.u);
+ }
+ static unsigned getHashValue(
+ const Fortran::evaluate::Relational<Fortran::evaluate::SomeType> &x) {
+ return std::visit([&](const auto &v) { return getHashValue(v); }, x.u);
+ }
+ template <typename A>
+ static unsigned getHashValue(const Fortran::evaluate::Designator<A> &x) {
+ return std::visit([&](const auto &v) { return getHashValue(v); }, x.u);
+ }
+ template <int BITS>
+ static unsigned
+ getHashValue(const Fortran::evaluate::value::Integer<BITS> &x) {
+ return static_cast<unsigned>(x.ToSInt());
+ }
+ static unsigned getHashValue(const Fortran::evaluate::NullPointer &x) {
+ return ~179u;
+ }
+};
+} // namespace
+
+unsigned Fortran::lower::getHashValue(
+ const Fortran::lower::ExplicitIterSpace::ArrayBases &x) {
+ return std::visit(
+ [&](const auto *p) { return HashEvaluateExpr::getHashValue(*p); }, x);
+}
+
+unsigned Fortran::lower::getHashValue(Fortran::lower::FrontEndExpr x) {
+ return HashEvaluateExpr::getHashValue(*x);
+}
+
+namespace {
+// Define the is equals test for using Fortran::evaluate::Expr values with
+// llvm::DenseMap.
+class IsEqualEvaluateExpr {
+public:
+ // A Se::Symbol is the only part of an Fortran::evaluate::Expr with an
+ // identity property.
+ static bool isEqual(const Fortran::semantics::Symbol &x,
+ const Fortran::semantics::Symbol &y) {
+ return isEqual(&x, &y);
+ }
+ static bool isEqual(const Fortran::semantics::Symbol *x,
+ const Fortran::semantics::Symbol *y) {
+ return x == y;
+ }
+ template <typename A, bool COPY>
+ static bool isEqual(const Fortran::common::Indirection<A, COPY> &x,
+ const Fortran::common::Indirection<A, COPY> &y) {
+ return isEqual(x.value(), y.value());
+ }
+ template <typename A>
+ static bool isEqual(const std::optional<A> &x, const std::optional<A> &y) {
+ if (x.has_value() && y.has_value())
+ return isEqual(x.value(), y.value());
+ return !x.has_value() && !y.has_value();
+ }
+ template <typename A>
+ static bool isEqual(const std::vector<A> &x, const std::vector<A> &y) {
+ if (x.size() != y.size())
+ return false;
+ const std::size_t size = x.size();
+ for (std::remove_const_t<decltype(size)> i = 0; i < size; ++i)
+ if (!isEqual(x[i], y[i]))
+ return false;
+ return true;
+ }
+ static bool isEqual(const Fortran::evaluate::Subscript &x,
+ const Fortran::evaluate::Subscript &y) {
+ return std::visit(
+ [&](const auto &v, const auto &w) { return isEqual(v, w); }, x.u, y.u);
+ }
+ static bool isEqual(const Fortran::evaluate::Triplet &x,
+ const Fortran::evaluate::Triplet &y) {
+ return isEqual(x.lower(), y.lower()) && isEqual(x.upper(), y.upper()) &&
+ isEqual(x.stride(), y.stride());
+ }
+ static bool isEqual(const Fortran::evaluate::Component &x,
+ const Fortran::evaluate::Component &y) {
+ return isEqual(x.base(), y.base()) &&
+ isEqual(x.GetLastSymbol(), y.GetLastSymbol());
+ }
+ static bool isEqual(const Fortran::evaluate::ArrayRef &x,
+ const Fortran::evaluate::ArrayRef &y) {
+ return isEqual(x.base(), y.base()) && isEqual(x.subscript(), y.subscript());
+ }
+ static bool isEqual(const Fortran::evaluate::CoarrayRef &x,
+ const Fortran::evaluate::CoarrayRef &y) {
+ return isEqual(x.base(), y.base()) &&
+ isEqual(x.subscript(), y.subscript()) &&
+ isEqual(x.cosubscript(), y.cosubscript()) &&
+ isEqual(x.stat(), y.stat()) && isEqual(x.team(), y.team());
+ }
+ static bool isEqual(const Fortran::evaluate::NamedEntity &x,
+ const Fortran::evaluate::NamedEntity &y) {
+ if (x.IsSymbol() && y.IsSymbol())
+ return isEqual(x.GetFirstSymbol(), y.GetFirstSymbol());
+ return !x.IsSymbol() && !y.IsSymbol() &&
+ isEqual(x.GetComponent(), y.GetComponent());
+ }
+ static bool isEqual(const Fortran::evaluate::DataRef &x,
+ const Fortran::evaluate::DataRef &y) {
+ return std::visit(
+ [&](const auto &v, const auto &w) { return isEqual(v, w); }, x.u, y.u);
+ }
+ static bool isEqual(const Fortran::evaluate::ComplexPart &x,
+ const Fortran::evaluate::ComplexPart &y) {
+ return isEqual(x.complex(), y.complex()) && x.part() == y.part();
+ }
+ template <typename A, Fortran::common::TypeCategory TC2>
+ static bool isEqual(const Fortran::evaluate::Convert<A, TC2> &x,
+ const Fortran::evaluate::Convert<A, TC2> &y) {
+ return isEqual(x.left(), y.left());
+ }
+ template <int KIND>
+ static bool isEqual(const Fortran::evaluate::ComplexComponent<KIND> &x,
+ const Fortran::evaluate::ComplexComponent<KIND> &y) {
+ return isEqual(x.left(), y.left()) &&
+ x.isImaginaryPart == y.isImaginaryPart;
+ }
+ template <typename T>
+ static bool isEqual(const Fortran::evaluate::Parentheses<T> &x,
+ const Fortran::evaluate::Parentheses<T> &y) {
+ return isEqual(x.left(), y.left());
+ }
+ template <typename A>
+ static bool isEqual(const Fortran::evaluate::Negate<A> &x,
+ const Fortran::evaluate::Negate<A> &y) {
+ return isEqual(x.left(), y.left());
+ }
+ template <typename A>
+ static bool isBinaryEqual(const A &x, const A &y) {
+ return isEqual(x.left(), y.left()) && isEqual(x.right(), y.right());
+ }
+ template <typename A>
+ static bool isEqual(const Fortran::evaluate::Add<A> &x,
+ const Fortran::evaluate::Add<A> &y) {
+ return isBinaryEqual(x, y);
+ }
+ template <typename A>
+ static bool isEqual(const Fortran::evaluate::Subtract<A> &x,
+ const Fortran::evaluate::Subtract<A> &y) {
+ return isBinaryEqual(x, y);
+ }
+ template <typename A>
+ static bool isEqual(const Fortran::evaluate::Multiply<A> &x,
+ const Fortran::evaluate::Multiply<A> &y) {
+ return isBinaryEqual(x, y);
+ }
+ template <typename A>
+ static bool isEqual(const Fortran::evaluate::Divide<A> &x,
+ const Fortran::evaluate::Divide<A> &y) {
+ return isBinaryEqual(x, y);
+ }
+ template <typename A>
+ static bool isEqual(const Fortran::evaluate::Power<A> &x,
+ const Fortran::evaluate::Power<A> &y) {
+ return isBinaryEqual(x, y);
+ }
+ template <typename A>
+ static bool isEqual(const Fortran::evaluate::Extremum<A> &x,
+ const Fortran::evaluate::Extremum<A> &y) {
+ return isBinaryEqual(x, y);
+ }
+ template <typename A>
+ static bool isEqual(const Fortran::evaluate::RealToIntPower<A> &x,
+ const Fortran::evaluate::RealToIntPower<A> &y) {
+ return isBinaryEqual(x, y);
+ }
+ template <int KIND>
+ static bool isEqual(const Fortran::evaluate::ComplexConstructor<KIND> &x,
+ const Fortran::evaluate::ComplexConstructor<KIND> &y) {
+ return isBinaryEqual(x, y);
+ }
+ template <int KIND>
+ static bool isEqual(const Fortran::evaluate::Concat<KIND> &x,
+ const Fortran::evaluate::Concat<KIND> &y) {
+ return isBinaryEqual(x, y);
+ }
+ template <int KIND>
+ static bool isEqual(const Fortran::evaluate::SetLength<KIND> &x,
+ const Fortran::evaluate::SetLength<KIND> &y) {
+ return isBinaryEqual(x, y);
+ }
+ static bool isEqual(const Fortran::semantics::SymbolRef &x,
+ const Fortran::semantics::SymbolRef &y) {
+ return isEqual(x.get(), y.get());
+ }
+ static bool isEqual(const Fortran::evaluate::Substring &x,
+ const Fortran::evaluate::Substring &y) {
+ return std::visit(
+ [&](const auto &p, const auto &q) { return isEqual(p, q); },
+ x.parent(), y.parent()) &&
+ isEqual(x.lower(), y.lower()) && isEqual(x.lower(), y.lower());
+ }
+ static bool isEqual(const Fortran::evaluate::StaticDataObject::Pointer &x,
+ const Fortran::evaluate::StaticDataObject::Pointer &y) {
+ return x->name() == y->name();
+ }
+ static bool isEqual(const Fortran::evaluate::SpecificIntrinsic &x,
+ const Fortran::evaluate::SpecificIntrinsic &y) {
+ return x.name == y.name;
+ }
+ template <typename A>
+ static bool isEqual(const Fortran::evaluate::Constant<A> &x,
+ const Fortran::evaluate::Constant<A> &y) {
+ return x == y;
+ }
+ static bool isEqual(const Fortran::evaluate::ActualArgument &x,
+ const Fortran::evaluate::ActualArgument &y) {
+ if (const Fortran::evaluate::Symbol *xs = x.GetAssumedTypeDummy()) {
+ if (const Fortran::evaluate::Symbol *ys = y.GetAssumedTypeDummy())
+ return isEqual(*xs, *ys);
+ return false;
+ }
+ return !y.GetAssumedTypeDummy() &&
+ isEqual(*x.UnwrapExpr(), *y.UnwrapExpr());
+ }
+ static bool isEqual(const Fortran::evaluate::ProcedureDesignator &x,
+ const Fortran::evaluate::ProcedureDesignator &y) {
+ return std::visit(
+ [&](const auto &v, const auto &w) { return isEqual(v, w); }, x.u, y.u);
+ }
+ static bool isEqual(const Fortran::evaluate::ProcedureRef &x,
+ const Fortran::evaluate::ProcedureRef &y) {
+ return isEqual(x.proc(), y.proc()) && isEqual(x.arguments(), y.arguments());
+ }
+ template <typename A>
+ static bool isEqual(const Fortran::evaluate::ArrayConstructor<A> &x,
+ const Fortran::evaluate::ArrayConstructor<A> &y) {
+ llvm::report_fatal_error("not implemented");
+ }
+ static bool isEqual(const Fortran::evaluate::ImpliedDoIndex &x,
+ const Fortran::evaluate::ImpliedDoIndex &y) {
+ return toStringRef(x.name) == toStringRef(y.name);
+ }
+ static bool isEqual(const Fortran::evaluate::TypeParamInquiry &x,
+ const Fortran::evaluate::TypeParamInquiry &y) {
+ return isEqual(x.base(), y.base()) && isEqual(x.parameter(), y.parameter());
+ }
+ static bool isEqual(const Fortran::evaluate::DescriptorInquiry &x,
+ const Fortran::evaluate::DescriptorInquiry &y) {
+ return isEqual(x.base(), y.base()) && x.field() == y.field() &&
+ x.dimension() == y.dimension();
+ }
+ static bool isEqual(const Fortran::evaluate::StructureConstructor &x,
+ const Fortran::evaluate::StructureConstructor &y) {
+ llvm::report_fatal_error("not implemented");
+ }
+ template <int KIND>
+ static bool isEqual(const Fortran::evaluate::Not<KIND> &x,
+ const Fortran::evaluate::Not<KIND> &y) {
+ return isEqual(x.left(), y.left());
+ }
+ template <int KIND>
+ static bool isEqual(const Fortran::evaluate::LogicalOperation<KIND> &x,
+ const Fortran::evaluate::LogicalOperation<KIND> &y) {
+ return isEqual(x.left(), y.left()) && isEqual(x.right(), x.right());
+ }
+ template <typename A>
+ static bool isEqual(const Fortran::evaluate::Relational<A> &x,
+ const Fortran::evaluate::Relational<A> &y) {
+ return isEqual(x.left(), y.left()) && isEqual(x.right(), y.right());
+ }
+ template <typename A>
+ static bool isEqual(const Fortran::evaluate::Expr<A> &x,
+ const Fortran::evaluate::Expr<A> &y) {
+ return std::visit(
+ [&](const auto &v, const auto &w) { return isEqual(v, w); }, x.u, y.u);
+ }
+ static bool
+ isEqual(const Fortran::evaluate::Relational<Fortran::evaluate::SomeType> &x,
+ const Fortran::evaluate::Relational<Fortran::evaluate::SomeType> &y) {
+ return std::visit(
+ [&](const auto &v, const auto &w) { return isEqual(v, w); }, x.u, y.u);
+ }
+ template <typename A>
+ static bool isEqual(const Fortran::evaluate::Designator<A> &x,
+ const Fortran::evaluate::Designator<A> &y) {
+ return std::visit(
+ [&](const auto &v, const auto &w) { return isEqual(v, w); }, x.u, y.u);
+ }
+ template <int BITS>
+ static bool isEqual(const Fortran::evaluate::value::Integer<BITS> &x,
+ const Fortran::evaluate::value::Integer<BITS> &y) {
+ return x == y;
+ }
+ static bool isEqual(const Fortran::evaluate::NullPointer &x,
+ const Fortran::evaluate::NullPointer &y) {
+ return true;
+ }
+ template <typename A, typename B,
+ std::enable_if_t<!std::is_same_v<A, B>, bool> = true>
+ static bool isEqual(const A &, const B &) {
+ return false;
+ }
+};
+} // namespace
+
+bool Fortran::lower::isEqual(
+ const Fortran::lower::ExplicitIterSpace::ArrayBases &x,
+ const Fortran::lower::ExplicitIterSpace::ArrayBases &y) {
+ return std::visit(
+ Fortran::common::visitors{
+ // Fortran::semantics::Symbol * are the exception here. These pointers
+ // have identity; if two Symbol * values are the same (
diff erent) then
+ // they are the same (
diff erent) logical symbol.
+ [&](Fortran::lower::FrontEndSymbol p,
+ Fortran::lower::FrontEndSymbol q) { return p == q; },
+ [&](const auto *p, const auto *q) {
+ if constexpr (std::is_same_v<decltype(p), decltype(q)>) {
+ LLVM_DEBUG(llvm::dbgs()
+ << "is equal: " << p << ' ' << q << ' '
+ << IsEqualEvaluateExpr::isEqual(*p, *q) << '\n');
+ return IsEqualEvaluateExpr::isEqual(*p, *q);
+ } else {
+ // Different subtree types are never equal.
+ return false;
+ }
+ }},
+ x, y);
+}
+
+bool Fortran::lower::isEqual(Fortran::lower::FrontEndExpr x,
+ Fortran::lower::FrontEndExpr y) {
+ auto empty = llvm::DenseMapInfo<Fortran::lower::FrontEndExpr>::getEmptyKey();
+ auto tombstone =
+ llvm::DenseMapInfo<Fortran::lower::FrontEndExpr>::getTombstoneKey();
+ if (x == empty || y == empty || x == tombstone || y == tombstone)
+ return x == y;
+ return x == y || IsEqualEvaluateExpr::isEqual(*x, *y);
+}
+
+namespace {
+
+/// This class can recover the base array in an expression that contains
+/// explicit iteration space symbols. Most of the class can be ignored as it is
+/// boilerplate Fortran::evaluate::Expr traversal.
+class ArrayBaseFinder {
+public:
+ using RT = bool;
+
+ ArrayBaseFinder(llvm::ArrayRef<Fortran::lower::FrontEndSymbol> syms)
+ : controlVars(syms.begin(), syms.end()) {}
+
+ template <typename T>
+ void operator()(const T &x) {
+ (void)find(x);
+ }
+
+ /// Get the list of bases.
+ llvm::ArrayRef<Fortran::lower::ExplicitIterSpace::ArrayBases>
+ getBases() const {
+ LLVM_DEBUG(llvm::dbgs()
+ << "number of array bases found: " << bases.size() << '\n');
+ return bases;
+ }
+
+private:
+ // First, the cases that are of interest.
+ RT find(const Fortran::semantics::Symbol &symbol) {
+ if (symbol.Rank() > 0) {
+ bases.push_back(&symbol);
+ return true;
+ }
+ return {};
+ }
+ RT find(const Fortran::evaluate::Component &x) {
+ auto found = find(x.base());
+ if (!found && x.base().Rank() == 0 && x.Rank() > 0) {
+ bases.push_back(&x);
+ return true;
+ }
+ return found;
+ }
+ RT find(const Fortran::evaluate::ArrayRef &x) {
+ for (const auto &sub : x.subscript())
+ (void)find(sub);
+ if (x.base().IsSymbol()) {
+ if (x.Rank() > 0 || intersection(x.subscript())) {
+ bases.push_back(&x);
+ return true;
+ }
+ return {};
+ }
+ auto found = find(x.base());
+ if (!found && ((x.base().Rank() == 0 && x.Rank() > 0) ||
+ intersection(x.subscript()))) {
+ bases.push_back(&x);
+ return true;
+ }
+ return found;
+ }
+ RT find(const Fortran::evaluate::Triplet &x) {
+ if (const auto *lower = x.GetLower())
+ (void)find(*lower);
+ if (const auto *upper = x.GetUpper())
+ (void)find(*upper);
+ return find(x.GetStride());
+ }
+ RT find(const Fortran::evaluate::IndirectSubscriptIntegerExpr &x) {
+ return find(x.value());
+ }
+ RT find(const Fortran::evaluate::Subscript &x) { return find(x.u); }
+ RT find(const Fortran::evaluate::DataRef &x) { return find(x.u); }
+ RT find(const Fortran::evaluate::CoarrayRef &x) {
+ assert(false && "coarray reference");
+ return {};
+ }
+
+ template <typename A>
+ bool intersection(const A &subscripts) {
+ return Fortran::lower::symbolsIntersectSubscripts(controlVars, subscripts);
+ }
+
+ // The rest is traversal boilerplate and can be ignored.
+ RT find(const Fortran::evaluate::Substring &x) { return find(x.parent()); }
+ template <typename A>
+ RT find(const Fortran::semantics::SymbolRef x) {
+ return find(*x);
+ }
+ RT find(const Fortran::evaluate::NamedEntity &x) {
+ if (x.IsSymbol())
+ return find(x.GetFirstSymbol());
+ return find(x.GetComponent());
+ }
+
+ template <typename A, bool C>
+ RT find(const Fortran::common::Indirection<A, C> &x) {
+ return find(x.value());
+ }
+ template <typename A>
+ RT find(const std::unique_ptr<A> &x) {
+ return find(x.get());
+ }
+ template <typename A>
+ RT find(const std::shared_ptr<A> &x) {
+ return find(x.get());
+ }
+ template <typename A>
+ RT find(const A *x) {
+ if (x)
+ return find(*x);
+ return {};
+ }
+ template <typename A>
+ RT find(const std::optional<A> &x) {
+ if (x)
+ return find(*x);
+ return {};
+ }
+ template <typename... A>
+ RT find(const std::variant<A...> &u) {
+ return std::visit([&](const auto &v) { return find(v); }, u);
+ }
+ template <typename A>
+ RT find(const std::vector<A> &x) {
+ for (auto &v : x)
+ (void)find(v);
+ return {};
+ }
+ RT find(const Fortran::evaluate::BOZLiteralConstant &) { return {}; }
+ RT find(const Fortran::evaluate::NullPointer &) { return {}; }
+ template <typename T>
+ RT find(const Fortran::evaluate::Constant<T> &x) {
+ return {};
+ }
+ RT find(const Fortran::evaluate::StaticDataObject &) { return {}; }
+ RT find(const Fortran::evaluate::ImpliedDoIndex &) { return {}; }
+ RT find(const Fortran::evaluate::BaseObject &x) {
+ (void)find(x.u);
+ return {};
+ }
+ RT find(const Fortran::evaluate::TypeParamInquiry &) { return {}; }
+ RT find(const Fortran::evaluate::ComplexPart &x) { return {}; }
+ template <typename T>
+ RT find(const Fortran::evaluate::Designator<T> &x) {
+ return find(x.u);
+ }
+ template <typename T>
+ RT find(const Fortran::evaluate::Variable<T> &x) {
+ return find(x.u);
+ }
+ RT find(const Fortran::evaluate::DescriptorInquiry &) { return {}; }
+ RT find(const Fortran::evaluate::SpecificIntrinsic &) { return {}; }
+ RT find(const Fortran::evaluate::ProcedureDesignator &x) { return {}; }
+ RT find(const Fortran::evaluate::ProcedureRef &x) {
+ (void)find(x.proc());
+ if (x.IsElemental())
+ (void)find(x.arguments());
+ return {};
+ }
+ RT find(const Fortran::evaluate::ActualArgument &x) {
+ if (const auto *sym = x.GetAssumedTypeDummy())
+ (void)find(*sym);
+ else
+ (void)find(x.UnwrapExpr());
+ return {};
+ }
+ template <typename T>
+ RT find(const Fortran::evaluate::FunctionRef<T> &x) {
+ (void)find(static_cast<const Fortran::evaluate::ProcedureRef &>(x));
+ return {};
+ }
+ template <typename T>
+ RT find(const Fortran::evaluate::ArrayConstructorValue<T> &) {
+ return {};
+ }
+ template <typename T>
+ RT find(const Fortran::evaluate::ArrayConstructorValues<T> &) {
+ return {};
+ }
+ template <typename T>
+ RT find(const Fortran::evaluate::ImpliedDo<T> &) {
+ return {};
+ }
+ RT find(const Fortran::semantics::ParamValue &) { return {}; }
+ RT find(const Fortran::semantics::DerivedTypeSpec &) { return {}; }
+ RT find(const Fortran::evaluate::StructureConstructor &) { return {}; }
+ template <typename D, typename R, typename O>
+ RT find(const Fortran::evaluate::Operation<D, R, O> &op) {
+ (void)find(op.left());
+ return false;
+ }
+ template <typename D, typename R, typename LO, typename RO>
+ RT find(const Fortran::evaluate::Operation<D, R, LO, RO> &op) {
+ (void)find(op.left());
+ (void)find(op.right());
+ return false;
+ }
+ RT find(const Fortran::evaluate::Relational<Fortran::evaluate::SomeType> &x) {
+ (void)find(x.u);
+ return {};
+ }
+ template <typename T>
+ RT find(const Fortran::evaluate::Expr<T> &x) {
+ (void)find(x.u);
+ return {};
+ }
+
+ llvm::SmallVector<Fortran::lower::ExplicitIterSpace::ArrayBases> bases;
+ llvm::SmallVector<Fortran::lower::FrontEndSymbol> controlVars;
+};
+
+} // namespace
+
+void Fortran::lower::ExplicitIterSpace::leave() {
+ ccLoopNest.pop_back();
+ --forallContextOpen;
+ conditionalCleanup();
+}
+
+void Fortran::lower::ExplicitIterSpace::addSymbol(
+ Fortran::lower::FrontEndSymbol sym) {
+ assert(!symbolStack.empty());
+ symbolStack.back().push_back(sym);
+}
+
+void Fortran::lower::ExplicitIterSpace::exprBase(Fortran::lower::FrontEndExpr x,
+ bool lhs) {
+ ArrayBaseFinder finder(collectAllSymbols());
+ finder(*x);
+ llvm::ArrayRef<Fortran::lower::ExplicitIterSpace::ArrayBases> bases =
+ finder.getBases();
+ if (rhsBases.empty())
+ endAssign();
+ if (lhs) {
+ if (bases.empty()) {
+ lhsBases.push_back(llvm::None);
+ return;
+ }
+ assert(bases.size() >= 1 && "must detect an array reference on lhs");
+ if (bases.size() > 1)
+ rhsBases.back().append(bases.begin(), bases.end() - 1);
+ lhsBases.push_back(bases.back());
+ return;
+ }
+ rhsBases.back().append(bases.begin(), bases.end());
+}
+
+void Fortran::lower::ExplicitIterSpace::endAssign() { rhsBases.emplace_back(); }
+
+void Fortran::lower::ExplicitIterSpace::pushLevel() {
+ symbolStack.push_back(llvm::SmallVector<Fortran::lower::FrontEndSymbol>{});
+}
+
+void Fortran::lower::ExplicitIterSpace::popLevel() { symbolStack.pop_back(); }
+
+void Fortran::lower::ExplicitIterSpace::conditionalCleanup() {
+ if (forallContextOpen == 0) {
+ // Exiting the outermost FORALL context.
+ // Cleanup any residual mask buffers.
+ outermostContext().finalize();
+ // Clear and reset all the cached information.
+ symbolStack.clear();
+ lhsBases.clear();
+ rhsBases.clear();
+ loadBindings.clear();
+ ccLoopNest.clear();
+ innerArgs.clear();
+ outerLoop = llvm::None;
+ clearLoops();
+ counter = 0;
+ }
+}
+
+llvm::Optional<size_t>
+Fortran::lower::ExplicitIterSpace::findArgPosition(fir::ArrayLoadOp load) {
+ if (lhsBases[counter].hasValue()) {
+ auto ld = loadBindings.find(lhsBases[counter].getValue());
+ llvm::Optional<size_t> optPos;
+ if (ld != loadBindings.end() && ld->second == load)
+ optPos = static_cast<size_t>(0u);
+ assert(optPos.hasValue() && "load does not correspond to lhs");
+ return optPos;
+ }
+ return llvm::None;
+}
+
+llvm::SmallVector<Fortran::lower::FrontEndSymbol>
+Fortran::lower::ExplicitIterSpace::collectAllSymbols() {
+ llvm::SmallVector<Fortran::lower::FrontEndSymbol> result;
+ for (llvm::SmallVector<FrontEndSymbol> vec : symbolStack)
+ result.append(vec.begin(), vec.end());
+ return result;
+}
+
+llvm::raw_ostream &
+Fortran::lower::operator<<(llvm::raw_ostream &s,
+ const Fortran::lower::ImplicitIterSpace &e) {
+ for (const llvm::SmallVector<
+ Fortran::lower::ImplicitIterSpace::FrontEndMaskExpr> &xs :
+ e.getMasks()) {
+ s << "{ ";
+ for (const Fortran::lower::ImplicitIterSpace::FrontEndMaskExpr &x : xs)
+ x->AsFortran(s << '(') << "), ";
+ s << "}\n";
+ }
+ return s;
+}
+
+llvm::raw_ostream &
+Fortran::lower::operator<<(llvm::raw_ostream &s,
+ const Fortran::lower::ExplicitIterSpace &e) {
+ auto dump = [&](const auto &u) {
+ std::visit(Fortran::common::visitors{
+ [&](const Fortran::semantics::Symbol *y) {
+ s << " " << *y << '\n';
+ },
+ [&](const Fortran::evaluate::ArrayRef *y) {
+ s << " ";
+ if (y->base().IsSymbol())
+ s << y->base().GetFirstSymbol();
+ else
+ s << y->base().GetComponent().GetLastSymbol();
+ s << '\n';
+ },
+ [&](const Fortran::evaluate::Component *y) {
+ s << " " << y->GetLastSymbol() << '\n';
+ }},
+ u);
+ };
+ s << "LHS bases:\n";
+ for (const llvm::Optional<Fortran::lower::ExplicitIterSpace::ArrayBases> &u :
+ e.lhsBases)
+ if (u.hasValue())
+ dump(u.getValue());
+ s << "RHS bases:\n";
+ for (const llvm::SmallVector<Fortran::lower::ExplicitIterSpace::ArrayBases>
+ &bases : e.rhsBases) {
+ for (const Fortran::lower::ExplicitIterSpace::ArrayBases &u : bases)
+ dump(u);
+ s << '\n';
+ }
+ return s;
+}
+
+void Fortran::lower::ImplicitIterSpace::dump() const {
+ llvm::errs() << *this << '\n';
+}
+
+void Fortran::lower::ExplicitIterSpace::dump() const {
+ llvm::errs() << *this << '\n';
+}
diff --git a/flang/lib/Optimizer/Builder/FIRBuilder.cpp b/flang/lib/Optimizer/Builder/FIRBuilder.cpp
index bc9f6dbff075a..b1271e583e3e3 100644
--- a/flang/lib/Optimizer/Builder/FIRBuilder.cpp
+++ b/flang/lib/Optimizer/Builder/FIRBuilder.cpp
@@ -390,6 +390,57 @@ mlir::Value fir::FirOpBuilder::createShape(mlir::Location loc,
[&](auto) -> mlir::Value { fir::emitFatalError(loc, "not an array"); });
}
+mlir::Value fir::FirOpBuilder::createSlice(mlir::Location loc,
+ const fir::ExtendedValue &exv,
+ mlir::ValueRange triples,
+ mlir::ValueRange path) {
+ if (triples.empty()) {
+ // If there is no slicing by triple notation, then take the whole array.
+ auto fullShape = [&](const llvm::ArrayRef<mlir::Value> lbounds,
+ llvm::ArrayRef<mlir::Value> extents) -> mlir::Value {
+ llvm::SmallVector<mlir::Value> trips;
+ auto idxTy = getIndexType();
+ auto one = createIntegerConstant(loc, idxTy, 1);
+ if (lbounds.empty()) {
+ for (auto v : extents) {
+ trips.push_back(one);
+ trips.push_back(v);
+ trips.push_back(one);
+ }
+ return create<fir::SliceOp>(loc, trips, path);
+ }
+ for (auto [lbnd, extent] : llvm::zip(lbounds, extents)) {
+ auto lb = createConvert(loc, idxTy, lbnd);
+ auto ext = createConvert(loc, idxTy, extent);
+ auto shift = create<mlir::arith::SubIOp>(loc, lb, one);
+ auto ub = create<mlir::arith::AddIOp>(loc, ext, shift);
+ trips.push_back(lb);
+ trips.push_back(ub);
+ trips.push_back(one);
+ }
+ return create<fir::SliceOp>(loc, trips, path);
+ };
+ return exv.match(
+ [&](const fir::ArrayBoxValue &box) {
+ return fullShape(box.getLBounds(), box.getExtents());
+ },
+ [&](const fir::CharArrayBoxValue &box) {
+ return fullShape(box.getLBounds(), box.getExtents());
+ },
+ [&](const fir::BoxValue &box) {
+ auto extents = fir::factory::readExtents(*this, loc, box);
+ return fullShape(box.getLBounds(), extents);
+ },
+ [&](const fir::MutableBoxValue &) -> mlir::Value {
+ // MutableBoxValue must be read into another category to work with
+ // them outside of allocation/assignment contexts.
+ fir::emitFatalError(loc, "createSlice on MutableBoxValue");
+ },
+ [&](auto) -> mlir::Value { fir::emitFatalError(loc, "not an array"); });
+ }
+ return create<fir::SliceOp>(loc, triples, path);
+}
+
mlir::Value fir::FirOpBuilder::createBox(mlir::Location loc,
const fir::ExtendedValue &exv) {
mlir::Value itemAddr = fir::getBase(exv);
@@ -518,6 +569,35 @@ mlir::Value fir::factory::readExtent(fir::FirOpBuilder &builder,
});
}
+mlir::Value fir::factory::readLowerBound(fir::FirOpBuilder &builder,
+ mlir::Location loc,
+ const fir::ExtendedValue &box,
+ unsigned dim,
+ mlir::Value defaultValue) {
+ assert(box.rank() > dim);
+ auto lb = box.match(
+ [&](const fir::ArrayBoxValue &x) -> mlir::Value {
+ return x.getLBounds().empty() ? mlir::Value{} : x.getLBounds()[dim];
+ },
+ [&](const fir::CharArrayBoxValue &x) -> mlir::Value {
+ return x.getLBounds().empty() ? mlir::Value{} : x.getLBounds()[dim];
+ },
+ [&](const fir::BoxValue &x) -> mlir::Value {
+ return x.getLBounds().empty() ? mlir::Value{} : x.getLBounds()[dim];
+ },
+ [&](const fir::MutableBoxValue &x) -> mlir::Value {
+ return readLowerBound(builder, loc,
+ fir::factory::genMutableBoxRead(builder, loc, x),
+ dim, defaultValue);
+ },
+ [&](const auto &) -> mlir::Value {
+ fir::emitFatalError(loc, "lower bound inquiry on scalar");
+ });
+ if (lb)
+ return lb;
+ return defaultValue;
+}
+
llvm::SmallVector<mlir::Value>
fir::factory::readExtents(fir::FirOpBuilder &builder, mlir::Location loc,
const fir::BoxValue &box) {
@@ -653,6 +733,111 @@ fir::factory::createExtents(fir::FirOpBuilder &builder, mlir::Location loc,
return extents;
}
+// FIXME: This needs some work. To correctly determine the extended value of a
+// component, one needs the base object, its type, and its type parameters. (An
+// alternative would be to provide an already computed address of the final
+// component rather than the base object's address, the point being the result
+// will require the address of the final component to create the extended
+// value.) One further needs the full path of components being applied. One
+// needs to apply type-based expressions to type parameters along this said
+// path. (See applyPathToType for a type-only derivation.) Finally, one needs to
+// compose the extended value of the terminal component, including all of its
+// parameters: array lower bounds expressions, extents, type parameters, etc.
+// Any of these properties may be deferred until runtime in Fortran. This
+// operation may therefore generate a sizeable block of IR, including calls to
+// type-based helper functions, so caching the result of this operation in the
+// client would be advised as well.
+fir::ExtendedValue fir::factory::componentToExtendedValue(
+ fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value component) {
+ auto fieldTy = component.getType();
+ if (auto ty = fir::dyn_cast_ptrEleTy(fieldTy))
+ fieldTy = ty;
+ if (fieldTy.isa<fir::BoxType>()) {
+ llvm::SmallVector<mlir::Value> nonDeferredTypeParams;
+ auto eleTy = fir::unwrapSequenceType(fir::dyn_cast_ptrOrBoxEleTy(fieldTy));
+ if (auto charTy = eleTy.dyn_cast<fir::CharacterType>()) {
+ auto lenTy = builder.getCharacterLengthType();
+ if (charTy.hasConstantLen())
+ nonDeferredTypeParams.emplace_back(
+ builder.createIntegerConstant(loc, lenTy, charTy.getLen()));
+ // TODO: Starting, F2003, the dynamic character length might be dependent
+ // on a PDT length parameter. There is no way to make a
diff erence with
+ // deferred length here yet.
+ }
+ if (auto recTy = eleTy.dyn_cast<fir::RecordType>())
+ if (recTy.getNumLenParams() > 0)
+ TODO(loc, "allocatable and pointer components non deferred length "
+ "parameters");
+
+ return fir::MutableBoxValue(component, nonDeferredTypeParams,
+ /*mutableProperties=*/{});
+ }
+ llvm::SmallVector<mlir::Value> extents;
+ if (auto seqTy = fieldTy.dyn_cast<fir::SequenceType>()) {
+ fieldTy = seqTy.getEleTy();
+ auto idxTy = builder.getIndexType();
+ for (auto extent : seqTy.getShape()) {
+ if (extent == fir::SequenceType::getUnknownExtent())
+ TODO(loc, "array component shape depending on length parameters");
+ extents.emplace_back(builder.createIntegerConstant(loc, idxTy, extent));
+ }
+ }
+ if (auto charTy = fieldTy.dyn_cast<fir::CharacterType>()) {
+ auto cstLen = charTy.getLen();
+ if (cstLen == fir::CharacterType::unknownLen())
+ TODO(loc, "get character component length from length type parameters");
+ auto len = builder.createIntegerConstant(
+ loc, builder.getCharacterLengthType(), cstLen);
+ if (!extents.empty())
+ return fir::CharArrayBoxValue{component, len, extents};
+ return fir::CharBoxValue{component, len};
+ }
+ if (auto recordTy = fieldTy.dyn_cast<fir::RecordType>())
+ if (recordTy.getNumLenParams() != 0)
+ TODO(loc,
+ "lower component ref that is a derived type with length parameter");
+ if (!extents.empty())
+ return fir::ArrayBoxValue{component, extents};
+ return component;
+}
+
+fir::ExtendedValue fir::factory::arrayElementToExtendedValue(
+ fir::FirOpBuilder &builder, mlir::Location loc,
+ const fir::ExtendedValue &array, mlir::Value element) {
+ return array.match(
+ [&](const fir::CharBoxValue &cb) -> fir::ExtendedValue {
+ return cb.clone(element);
+ },
+ [&](const fir::CharArrayBoxValue &bv) -> fir::ExtendedValue {
+ return bv.cloneElement(element);
+ },
+ [&](const fir::BoxValue &box) -> fir::ExtendedValue {
+ if (box.isCharacter()) {
+ auto len = fir::factory::readCharLen(builder, loc, box);
+ return fir::CharBoxValue{element, len};
+ }
+ if (box.isDerivedWithLengthParameters())
+ TODO(loc, "get length parameters from derived type BoxValue");
+ return element;
+ },
+ [&](const auto &) -> fir::ExtendedValue { return element; });
+}
+
+fir::ExtendedValue fir::factory::arraySectionElementToExtendedValue(
+ fir::FirOpBuilder &builder, mlir::Location loc,
+ const fir::ExtendedValue &array, mlir::Value element, mlir::Value slice) {
+ if (!slice)
+ return arrayElementToExtendedValue(builder, loc, array, element);
+ auto sliceOp = mlir::dyn_cast_or_null<fir::SliceOp>(slice.getDefiningOp());
+ assert(sliceOp && "slice must be a sliceOp");
+ if (sliceOp.getFields().empty())
+ return arrayElementToExtendedValue(builder, loc, array, element);
+ // For F95, using componentToExtendedValue will work, but when PDTs are
+ // lowered. It will be required to go down the slice to propagate the length
+ // parameters.
+ return fir::factory::componentToExtendedValue(builder, loc, element);
+}
+
mlir::TupleType
fir::factory::getRaggedArrayHeaderType(fir::FirOpBuilder &builder) {
mlir::IntegerType i64Ty = builder.getIntegerType(64);
diff --git a/flang/test/Lower/assignment.f90 b/flang/test/Lower/assignment.f90
index f2f81c3b41248..2b6e2fb8a7dfa 100644
--- a/flang/test/Lower/assignment.f90
+++ b/flang/test/Lower/assignment.f90
@@ -298,3 +298,39 @@ subroutine complex_constant()
! CHECK: %[[INS0:.*]] = fir.insert_value %[[UNDEF]], %[[C0]], [0 : index] : (!fir.complex<4>, f32) -> !fir.complex<4>
! CHECK: %[[INS1:.*]] = fir.insert_value %[[INS0]], %[[C1]], [1 : index] : (!fir.complex<4>, f32) -> !fir.complex<4>
! CHECK: fir.store %[[INS1]] to %[[A]] : !fir.ref<!fir.complex<4>>
+
+subroutine sub1_arr(a)
+ integer :: a(10)
+ a(2) = 10
+end
+
+! CHECK-LABEL: func @_QPsub1_arr(
+! CHECK-SAME: %[[A:.*]]: !fir.ref<!fir.array<10xi32>> {fir.bindc_name = "a"})
+! CHECK-DAG: %[[C10:.*]] = arith.constant 10 : i32
+! CHECK-DAG: %[[C2:.*]] = arith.constant 2 : i64
+! CHECK-DAG: %[[C1:.*]] = arith.constant 1 : i64
+! CHECK: %[[ZERO_BASED_INDEX:.*]] = arith.subi %[[C2]], %[[C1]] : i64
+! CHECK: %[[COORD:.*]] = fir.coordinate_of %[[A]], %[[ZERO_BASED_INDEX]] : (!fir.ref<!fir.array<10xi32>>, i64) -> !fir.ref<i32>
+! CHECK: fir.store %[[C10]] to %[[COORD]] : !fir.ref<i32>
+! CHECK: return
+
+subroutine sub2_arr(a)
+ integer :: a(10)
+ a = 10
+end
+
+! CHECK-LABEL: func @_QPsub2_arr(
+! CHECK-SAME: %[[A:.*]]: !fir.ref<!fir.array<10xi32>> {fir.bindc_name = "a"})
+! CHECK-DAG: %[[C10_0:.*]] = arith.constant 10 : index
+! CHECK: %[[SHAPE:.*]] = fir.shape %[[C10_0]] : (index) -> !fir.shape<1>
+! CHECK: %[[LOAD:.*]] = fir.array_load %[[A]](%[[SHAPE]]) : (!fir.ref<!fir.array<10xi32>>, !fir.shape<1>) -> !fir.array<10xi32>
+! CHECK-DAG: %[[C10_1:.*]] = arith.constant 10 : i32
+! CHECK-DAG: %[[C1:.*]] = arith.constant 1 : index
+! CHECK-DAG: %[[C0:.*]] = arith.constant 0 : index
+! CHECK-DAG: %[[UB:.*]] = arith.subi %[[C10_0]], %c1 : index
+! CHECK: %[[DO_RES:.*]] = fir.do_loop %[[ARG1:.*]] = %[[C0]] to %[[UB]] step %[[C1]] unordered iter_args(%[[ARG2:.*]] = %[[LOAD]]) -> (!fir.array<10xi32>) {
+! CHECK: %[[RES:.*]] = fir.array_update %[[ARG2]], %[[C10_1]], %[[ARG1]] : (!fir.array<10xi32>, i32, index) -> !fir.array<10xi32>
+! CHECK: fir.result %[[RES]] : !fir.array<10xi32>
+! CHECK: }
+! CHECK: fir.array_merge_store %[[LOAD]], %[[DO_RES]] to %[[A]] : !fir.array<10xi32>, !fir.array<10xi32>, !fir.ref<!fir.array<10xi32>>
+! CHECK: return
diff --git a/flang/test/Lower/basic-function.f90 b/flang/test/Lower/basic-function.f90
index 1aee3a94c1e22..21489dd9fec5a 100644
--- a/flang/test/Lower/basic-function.f90
+++ b/flang/test/Lower/basic-function.f90
@@ -62,20 +62,6 @@ function fct_iarr2()
! CHECK-LABEL: func @_QPfct_iarr2() -> !fir.array<10x20xi32>
! CHECK: return %{{.*}} : !fir.array<10x20xi32>
-function fct_iarr3()
- integer, dimension(:, :), allocatable :: fct_iarr3
-end
-
-! CHECK-LABEL: func @_QPfct_iarr3() -> !fir.box<!fir.heap<!fir.array<?x?xi32>>>
-! CHECK: return %{{.*}} : !fir.box<!fir.heap<!fir.array<?x?xi32>>>
-
-function fct_iarr4()
- integer, dimension(:), pointer :: fct_iarr4
-end
-
-! CHECK-LABEL: func @_QPfct_iarr4() -> !fir.box<!fir.ptr<!fir.array<?xi32>>>
-! CHECK: return %{{.*}} : !fir.box<!fir.ptr<!fir.array<?xi32>>>
-
logical(1) function lfct1()
end
! CHECK-LABEL: func @_QPlfct1() -> !fir.logical<1>
More information about the flang-commits
mailing list