[flang-commits] [flang] 2a59ead - [flang] Lower allocatable assignment for scalar
Valentin Clement via flang-commits
flang-commits at lists.llvm.org
Thu Feb 24 09:13:29 PST 2022
Author: Valentin Clement
Date: 2022-02-24T18:13:18+01:00
New Revision: 2a59ead118065012446bdbd0a31dc52799212f87
URL: https://github.com/llvm/llvm-project/commit/2a59ead118065012446bdbd0a31dc52799212f87
DIFF: https://github.com/llvm/llvm-project/commit/2a59ead118065012446bdbd0a31dc52799212f87.diff
LOG: [flang] Lower allocatable assignment for scalar
Add lowering for simple assignement on allocatable
scalars.
This patch is part of the upstreaming effort from fir-dev branch.
Depends on D120483
Reviewed By: PeteSteinfeld
Differential Revision: https://reviews.llvm.org/D120488
Co-authored-by: Eric Schweitz <eschweitz at nvidia.com>
Co-authored-by: Jean Perier <jperier at nvidia.com>
Added:
flang/include/flang/Lower/Allocatable.h
flang/include/flang/Lower/BoxAnalyzer.h
flang/lib/Lower/Allocatable.cpp
flang/test/Lower/allocatable-assignment.f90
Modified:
flang/include/flang/Lower/AbstractConverter.h
flang/include/flang/Lower/ConvertExpr.h
flang/include/flang/Lower/ConvertVariable.h
flang/include/flang/Optimizer/Builder/MutableBox.h
flang/include/flang/Optimizer/Builder/Runtime/Stop.h
flang/lib/Lower/Bridge.cpp
flang/lib/Lower/CMakeLists.txt
flang/lib/Lower/ConvertExpr.cpp
flang/lib/Lower/ConvertVariable.cpp
flang/lib/Optimizer/Builder/MutableBox.cpp
flang/lib/Optimizer/Builder/Runtime/Stop.cpp
Removed:
################################################################################
diff --git a/flang/include/flang/Lower/AbstractConverter.h b/flang/include/flang/Lower/AbstractConverter.h
index b4ec1658e24f6..1b38bfb973d7c 100644
--- a/flang/include/flang/Lower/AbstractConverter.h
+++ b/flang/include/flang/Lower/AbstractConverter.h
@@ -99,6 +99,12 @@ class AbstractConverter {
return genExprValue(*someExpr, stmtCtx, &loc);
}
+ /// Generate the address of the box describing the variable designated
+ /// by the expression. The expression must be an allocatable or pointer
+ /// designator.
+ virtual fir::MutableBoxValue genExprMutableBox(mlir::Location loc,
+ const SomeExpr &) = 0;
+
/// Get FoldingContext that is required for some expression
/// analysis.
virtual Fortran::evaluate::FoldingContext &getFoldingContext() = 0;
diff --git a/flang/include/flang/Lower/Allocatable.h b/flang/include/flang/Lower/Allocatable.h
new file mode 100644
index 0000000000000..1bb23feb84f17
--- /dev/null
+++ b/flang/include/flang/Lower/Allocatable.h
@@ -0,0 +1,47 @@
+//===-- Allocatable.h -- Allocatable statements lowering ------------------===//
+//
+// 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_ALLOCATABLE_H
+#define FORTRAN_LOWER_ALLOCATABLE_H
+
+#include "flang/Optimizer/Builder/MutableBox.h"
+#include "llvm/ADT/StringRef.h"
+
+namespace mlir {
+class Value;
+class ValueRange;
+class Location;
+} // namespace mlir
+
+namespace fir {
+class MutableBoxValue;
+} // namespace fir
+
+namespace Fortran::lower {
+class AbstractConverter;
+
+namespace pft {
+struct Variable;
+}
+
+/// Create a MutableBoxValue for an allocatable or pointer entity.
+/// If the variables is a local variable that is not a dummy, it will be
+/// initialized to unallocated/disassociated status.
+fir::MutableBoxValue createMutableBox(Fortran::lower::AbstractConverter &,
+ mlir::Location,
+ const Fortran::lower::pft::Variable &var,
+ mlir::Value boxAddr,
+ mlir::ValueRange nonDeferredParams);
+
+} // namespace Fortran::lower
+
+#endif // FORTRAN_LOWER_ALLOCATABLE_H
diff --git a/flang/include/flang/Lower/BoxAnalyzer.h b/flang/include/flang/Lower/BoxAnalyzer.h
new file mode 100644
index 0000000000000..8baf23e13ec57
--- /dev/null
+++ b/flang/include/flang/Lower/BoxAnalyzer.h
@@ -0,0 +1,508 @@
+//===-- BoxAnalyzer.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_BOXANALYZER_H
+#define FORTRAN_LOWER_BOXANALYZER_H
+
+#include "flang/Evaluate/fold.h"
+#include "flang/Lower/Support/Utils.h"
+#include "flang/Optimizer/Dialect/FIRType.h"
+#include "flang/Optimizer/Support/Matcher.h"
+
+namespace Fortran::lower {
+
+//===----------------------------------------------------------------------===//
+// Classifications of a symbol.
+//
+// Each classification is a distinct class and can be used in pattern matching.
+//===----------------------------------------------------------------------===//
+
+namespace details {
+
+using FromBox = std::monostate;
+
+/// Base class for all box analysis results.
+struct ScalarSym {
+ ScalarSym(const Fortran::semantics::Symbol &sym) : sym{&sym} {}
+ ScalarSym &operator=(const ScalarSym &) = default;
+
+ const Fortran::semantics::Symbol &symbol() const { return *sym; }
+
+ static constexpr bool staticSize() { return true; }
+ static constexpr bool isChar() { return false; }
+ static constexpr bool isArray() { return false; }
+
+private:
+ const Fortran::semantics::Symbol *sym;
+};
+
+/// Scalar of dependent type CHARACTER, constant LEN.
+struct ScalarStaticChar : ScalarSym {
+ ScalarStaticChar(const Fortran::semantics::Symbol &sym, int64_t len)
+ : ScalarSym{sym}, len{len} {}
+
+ int64_t charLen() const { return len; }
+
+ static constexpr bool isChar() { return true; }
+
+private:
+ int64_t len;
+};
+
+/// Scalar of dependent type Derived, constant LEN(s).
+struct ScalarStaticDerived : ScalarSym {
+ ScalarStaticDerived(const Fortran::semantics::Symbol &sym,
+ llvm::SmallVectorImpl<int64_t> &&lens)
+ : ScalarSym{sym}, lens{std::move(lens)} {}
+
+private:
+ llvm::SmallVector<int64_t> lens;
+};
+
+/// Scalar of dependent type CHARACTER, dynamic LEN.
+struct ScalarDynamicChar : ScalarSym {
+ ScalarDynamicChar(const Fortran::semantics::Symbol &sym,
+ const Fortran::lower::SomeExpr &len)
+ : ScalarSym{sym}, len{len} {}
+ ScalarDynamicChar(const Fortran::semantics::Symbol &sym)
+ : ScalarSym{sym}, len{FromBox{}} {}
+
+ llvm::Optional<Fortran::lower::SomeExpr> charLen() const {
+ if (auto *l = std::get_if<Fortran::lower::SomeExpr>(&len))
+ return {*l};
+ return llvm::None;
+ }
+
+ static constexpr bool staticSize() { return false; }
+ static constexpr bool isChar() { return true; }
+
+private:
+ std::variant<FromBox, Fortran::lower::SomeExpr> len;
+};
+
+/// Scalar of dependent type Derived, dynamic LEN(s).
+struct ScalarDynamicDerived : ScalarSym {
+ ScalarDynamicDerived(const Fortran::semantics::Symbol &sym,
+ llvm::SmallVectorImpl<Fortran::lower::SomeExpr> &&lens)
+ : ScalarSym{sym}, lens{std::move(lens)} {}
+
+private:
+ llvm::SmallVector<Fortran::lower::SomeExpr> lens;
+};
+
+struct LBoundsAndShape {
+ LBoundsAndShape(llvm::SmallVectorImpl<int64_t> &&lbounds,
+ llvm::SmallVectorImpl<int64_t> &&shapes)
+ : lbounds{std::move(lbounds)}, shapes{std::move(shapes)} {}
+
+ static constexpr bool staticSize() { return true; }
+ static constexpr bool isArray() { return true; }
+ bool lboundAllOnes() const {
+ return llvm::all_of(lbounds, [](int64_t v) { return v == 1; });
+ }
+
+ llvm::SmallVector<int64_t> lbounds;
+ llvm::SmallVector<int64_t> shapes;
+};
+
+/// Array of T with statically known origin (lbounds) and shape.
+struct StaticArray : ScalarSym, LBoundsAndShape {
+ StaticArray(const Fortran::semantics::Symbol &sym,
+ llvm::SmallVectorImpl<int64_t> &&lbounds,
+ llvm::SmallVectorImpl<int64_t> &&shapes)
+ : ScalarSym{sym}, LBoundsAndShape{std::move(lbounds), std::move(shapes)} {
+ }
+
+ static constexpr bool staticSize() { return LBoundsAndShape::staticSize(); }
+};
+
+struct DynamicBound {
+ DynamicBound(
+ llvm::SmallVectorImpl<const Fortran::semantics::ShapeSpec *> &&bounds)
+ : bounds{std::move(bounds)} {}
+
+ static constexpr bool staticSize() { return false; }
+ static constexpr bool isArray() { return true; }
+ bool lboundAllOnes() const {
+ return llvm::all_of(bounds, [](const Fortran::semantics::ShapeSpec *p) {
+ if (auto low = p->lbound().GetExplicit())
+ if (auto lb = Fortran::evaluate::ToInt64(*low))
+ return *lb == 1;
+ return false;
+ });
+ }
+
+ llvm::SmallVector<const Fortran::semantics::ShapeSpec *> bounds;
+};
+
+/// Array of T with dynamic origin and/or shape.
+struct DynamicArray : ScalarSym, DynamicBound {
+ DynamicArray(
+ const Fortran::semantics::Symbol &sym,
+ llvm::SmallVectorImpl<const Fortran::semantics::ShapeSpec *> &&bounds)
+ : ScalarSym{sym}, DynamicBound{std::move(bounds)} {}
+
+ static constexpr bool staticSize() { return DynamicBound::staticSize(); }
+};
+
+/// Array of CHARACTER with statically known LEN, origin, and shape.
+struct StaticArrayStaticChar : ScalarStaticChar, LBoundsAndShape {
+ StaticArrayStaticChar(const Fortran::semantics::Symbol &sym, int64_t len,
+ llvm::SmallVectorImpl<int64_t> &&lbounds,
+ llvm::SmallVectorImpl<int64_t> &&shapes)
+ : ScalarStaticChar{sym, len}, LBoundsAndShape{std::move(lbounds),
+ std::move(shapes)} {}
+
+ static constexpr bool staticSize() {
+ return ScalarStaticChar::staticSize() && LBoundsAndShape::staticSize();
+ }
+};
+
+/// Array of CHARACTER with dynamic LEN but constant origin, shape.
+struct StaticArrayDynamicChar : ScalarDynamicChar, LBoundsAndShape {
+ StaticArrayDynamicChar(const Fortran::semantics::Symbol &sym,
+ const Fortran::lower::SomeExpr &len,
+ llvm::SmallVectorImpl<int64_t> &&lbounds,
+ llvm::SmallVectorImpl<int64_t> &&shapes)
+ : ScalarDynamicChar{sym, len}, LBoundsAndShape{std::move(lbounds),
+ std::move(shapes)} {}
+ StaticArrayDynamicChar(const Fortran::semantics::Symbol &sym,
+ llvm::SmallVectorImpl<int64_t> &&lbounds,
+ llvm::SmallVectorImpl<int64_t> &&shapes)
+ : ScalarDynamicChar{sym}, LBoundsAndShape{std::move(lbounds),
+ std::move(shapes)} {}
+
+ static constexpr bool staticSize() {
+ return ScalarDynamicChar::staticSize() && LBoundsAndShape::staticSize();
+ }
+};
+
+/// Array of CHARACTER with constant LEN but dynamic origin, shape.
+struct DynamicArrayStaticChar : ScalarStaticChar, DynamicBound {
+ DynamicArrayStaticChar(
+ const Fortran::semantics::Symbol &sym, int64_t len,
+ llvm::SmallVectorImpl<const Fortran::semantics::ShapeSpec *> &&bounds)
+ : ScalarStaticChar{sym, len}, DynamicBound{std::move(bounds)} {}
+
+ static constexpr bool staticSize() {
+ return ScalarStaticChar::staticSize() && DynamicBound::staticSize();
+ }
+};
+
+/// Array of CHARACTER with dynamic LEN, origin, and shape.
+struct DynamicArrayDynamicChar : ScalarDynamicChar, DynamicBound {
+ DynamicArrayDynamicChar(
+ const Fortran::semantics::Symbol &sym,
+ const Fortran::lower::SomeExpr &len,
+ llvm::SmallVectorImpl<const Fortran::semantics::ShapeSpec *> &&bounds)
+ : ScalarDynamicChar{sym, len}, DynamicBound{std::move(bounds)} {}
+ DynamicArrayDynamicChar(
+ const Fortran::semantics::Symbol &sym,
+ llvm::SmallVectorImpl<const Fortran::semantics::ShapeSpec *> &&bounds)
+ : ScalarDynamicChar{sym}, DynamicBound{std::move(bounds)} {}
+
+ static constexpr bool staticSize() {
+ return ScalarDynamicChar::staticSize() && DynamicBound::staticSize();
+ }
+};
+
+// TODO: Arrays of derived types with LEN(s)...
+
+} // namespace details
+
+inline bool symIsChar(const Fortran::semantics::Symbol &sym) {
+ return sym.GetType()->category() ==
+ Fortran::semantics::DeclTypeSpec::Character;
+}
+
+inline bool symIsArray(const Fortran::semantics::Symbol &sym) {
+ const auto *det =
+ sym.GetUltimate().detailsIf<Fortran::semantics::ObjectEntityDetails>();
+ return det && det->IsArray();
+}
+
+inline bool isExplicitShape(const Fortran::semantics::Symbol &sym) {
+ const auto *det =
+ sym.GetUltimate().detailsIf<Fortran::semantics::ObjectEntityDetails>();
+ return det && det->IsArray() && det->shape().IsExplicitShape();
+}
+
+//===----------------------------------------------------------------------===//
+// Perform analysis to determine a box's parameter values
+//===----------------------------------------------------------------------===//
+
+/// Analyze a symbol, classify it as to whether it just a scalar, a CHARACTER
+/// scalar, an array entity, a combination thereof, and whether the LEN, shape,
+/// and lbounds are constant or not.
+class BoxAnalyzer : public fir::details::matcher<BoxAnalyzer> {
+public:
+ // Analysis default state
+ using None = std::monostate;
+
+ using ScalarSym = details::ScalarSym;
+ using ScalarStaticChar = details::ScalarStaticChar;
+ using ScalarDynamicChar = details::ScalarDynamicChar;
+ using StaticArray = details::StaticArray;
+ using DynamicArray = details::DynamicArray;
+ using StaticArrayStaticChar = details::StaticArrayStaticChar;
+ using StaticArrayDynamicChar = details::StaticArrayDynamicChar;
+ using DynamicArrayStaticChar = details::DynamicArrayStaticChar;
+ using DynamicArrayDynamicChar = details::DynamicArrayDynamicChar;
+ // TODO: derived types
+
+ using VT = std::variant<None, ScalarSym, ScalarStaticChar, ScalarDynamicChar,
+ StaticArray, DynamicArray, StaticArrayStaticChar,
+ StaticArrayDynamicChar, DynamicArrayStaticChar,
+ DynamicArrayDynamicChar>;
+
+ //===--------------------------------------------------------------------===//
+ // Constructor
+ //===--------------------------------------------------------------------===//
+
+ BoxAnalyzer() : box{None{}} {}
+
+ operator bool() const { return !std::holds_alternative<None>(box); }
+
+ bool isTrivial() const { return std::holds_alternative<ScalarSym>(box); }
+
+ /// Returns true for any sort of CHARACTER.
+ bool isChar() const {
+ return match([](const ScalarStaticChar &) { return true; },
+ [](const ScalarDynamicChar &) { return true; },
+ [](const StaticArrayStaticChar &) { return true; },
+ [](const StaticArrayDynamicChar &) { return true; },
+ [](const DynamicArrayStaticChar &) { return true; },
+ [](const DynamicArrayDynamicChar &) { return true; },
+ [](const auto &) { return false; });
+ }
+
+ /// Returns true for any sort of array.
+ bool isArray() const {
+ return match([](const StaticArray &) { return true; },
+ [](const DynamicArray &) { return true; },
+ [](const StaticArrayStaticChar &) { return true; },
+ [](const StaticArrayDynamicChar &) { return true; },
+ [](const DynamicArrayStaticChar &) { return true; },
+ [](const DynamicArrayDynamicChar &) { return true; },
+ [](const auto &) { return false; });
+ }
+
+ /// Returns true iff this is an array with constant extents and lbounds. This
+ /// returns true for arrays of CHARACTER, even if the LEN is not a constant.
+ bool isStaticArray() const {
+ return match([](const StaticArray &) { return true; },
+ [](const StaticArrayStaticChar &) { return true; },
+ [](const StaticArrayDynamicChar &) { return true; },
+ [](const auto &) { return false; });
+ }
+
+ bool isConstant() const {
+ return match(
+ [](const None &) -> bool {
+ llvm::report_fatal_error("internal: analysis failed");
+ },
+ [](const auto &x) { return x.staticSize(); });
+ }
+
+ llvm::Optional<int64_t> getCharLenConst() const {
+ using A = llvm::Optional<int64_t>;
+ return match(
+ [](const ScalarStaticChar &x) -> A { return {x.charLen()}; },
+ [](const StaticArrayStaticChar &x) -> A { return {x.charLen()}; },
+ [](const DynamicArrayStaticChar &x) -> A { return {x.charLen()}; },
+ [](const auto &) -> A { return llvm::None; });
+ }
+
+ llvm::Optional<Fortran::lower::SomeExpr> getCharLenExpr() const {
+ using A = llvm::Optional<Fortran::lower::SomeExpr>;
+ return match([](const ScalarDynamicChar &x) { return x.charLen(); },
+ [](const StaticArrayDynamicChar &x) { return x.charLen(); },
+ [](const DynamicArrayDynamicChar &x) { return x.charLen(); },
+ [](const auto &) -> A { return llvm::None; });
+ }
+
+ /// Is the origin of this array the default of vector of `1`?
+ bool lboundIsAllOnes() const {
+ return match(
+ [&](const StaticArray &x) { return x.lboundAllOnes(); },
+ [&](const DynamicArray &x) { return x.lboundAllOnes(); },
+ [&](const StaticArrayStaticChar &x) { return x.lboundAllOnes(); },
+ [&](const StaticArrayDynamicChar &x) { return x.lboundAllOnes(); },
+ [&](const DynamicArrayStaticChar &x) { return x.lboundAllOnes(); },
+ [&](const DynamicArrayDynamicChar &x) { return x.lboundAllOnes(); },
+ [](const auto &) -> bool { llvm::report_fatal_error("not an array"); });
+ }
+
+ /// Get the static lbound values (the origin of the array).
+ llvm::ArrayRef<int64_t> staticLBound() const {
+ using A = llvm::ArrayRef<int64_t>;
+ return match([](const StaticArray &x) -> A { return x.lbounds; },
+ [](const StaticArrayStaticChar &x) -> A { return x.lbounds; },
+ [](const StaticArrayDynamicChar &x) -> A { return x.lbounds; },
+ [](const auto &) -> A {
+ llvm::report_fatal_error("does not have static lbounds");
+ });
+ }
+
+ /// Get the static extents of the array.
+ llvm::ArrayRef<int64_t> staticShape() const {
+ using A = llvm::ArrayRef<int64_t>;
+ return match([](const StaticArray &x) -> A { return x.shapes; },
+ [](const StaticArrayStaticChar &x) -> A { return x.shapes; },
+ [](const StaticArrayDynamicChar &x) -> A { return x.shapes; },
+ [](const auto &) -> A {
+ llvm::report_fatal_error("does not have static shape");
+ });
+ }
+
+ /// Get the dynamic bounds information of the array (both origin, shape).
+ llvm::ArrayRef<const Fortran::semantics::ShapeSpec *> dynamicBound() const {
+ using A = llvm::ArrayRef<const Fortran::semantics::ShapeSpec *>;
+ return match([](const DynamicArray &x) -> A { return x.bounds; },
+ [](const DynamicArrayStaticChar &x) -> A { return x.bounds; },
+ [](const DynamicArrayDynamicChar &x) -> A { return x.bounds; },
+ [](const auto &) -> A {
+ llvm::report_fatal_error("does not have bounds");
+ });
+ }
+
+ /// Run the analysis on `sym`.
+ void analyze(const Fortran::semantics::Symbol &sym) {
+ if (symIsArray(sym)) {
+ bool isConstant = true;
+ llvm::SmallVector<int64_t> lbounds;
+ llvm::SmallVector<int64_t> shapes;
+ llvm::SmallVector<const Fortran::semantics::ShapeSpec *> bounds;
+ for (const Fortran::semantics::ShapeSpec &subs : getSymShape(sym)) {
+ bounds.push_back(&subs);
+ if (!isConstant)
+ continue;
+ if (auto low = subs.lbound().GetExplicit()) {
+ if (auto lb = Fortran::evaluate::ToInt64(*low)) {
+ lbounds.push_back(*lb); // origin for this dim
+ if (auto high = subs.ubound().GetExplicit()) {
+ if (auto ub = Fortran::evaluate::ToInt64(*high)) {
+ int64_t extent = *ub - *lb + 1;
+ shapes.push_back(extent < 0 ? 0 : extent);
+ continue;
+ }
+ } else if (subs.ubound().isStar()) {
+ shapes.push_back(fir::SequenceType::getUnknownExtent());
+ continue;
+ }
+ }
+ }
+ isConstant = false;
+ }
+
+ // sym : array<CHARACTER>
+ if (symIsChar(sym)) {
+ if (auto len = charLenConstant(sym)) {
+ if (isConstant)
+ box = StaticArrayStaticChar(sym, *len, std::move(lbounds),
+ std::move(shapes));
+ else
+ box = DynamicArrayStaticChar(sym, *len, std::move(bounds));
+ return;
+ }
+ if (auto var = charLenVariable(sym)) {
+ if (isConstant)
+ box = StaticArrayDynamicChar(sym, *var, std::move(lbounds),
+ std::move(shapes));
+ else
+ box = DynamicArrayDynamicChar(sym, *var, std::move(bounds));
+ return;
+ }
+ if (isConstant)
+ box = StaticArrayDynamicChar(sym, std::move(lbounds),
+ std::move(shapes));
+ else
+ box = DynamicArrayDynamicChar(sym, std::move(bounds));
+ return;
+ }
+
+ // sym : array<other>
+ if (isConstant)
+ box = StaticArray(sym, std::move(lbounds), std::move(shapes));
+ else
+ box = DynamicArray(sym, std::move(bounds));
+ return;
+ }
+
+ // sym : CHARACTER
+ if (symIsChar(sym)) {
+ if (auto len = charLenConstant(sym))
+ box = ScalarStaticChar(sym, *len);
+ else if (auto var = charLenVariable(sym))
+ box = ScalarDynamicChar(sym, *var);
+ else
+ box = ScalarDynamicChar(sym);
+ return;
+ }
+
+ // sym : other
+ box = ScalarSym(sym);
+ }
+
+ const VT &matchee() const { return box; }
+
+private:
+ // Get the shape of a symbol.
+ const Fortran::semantics::ArraySpec &
+ getSymShape(const Fortran::semantics::Symbol &sym) {
+ return sym.GetUltimate()
+ .get<Fortran::semantics::ObjectEntityDetails>()
+ .shape();
+ }
+
+ // Get the constant LEN of a CHARACTER, if it exists.
+ llvm::Optional<int64_t>
+ charLenConstant(const Fortran::semantics::Symbol &sym) {
+ if (llvm::Optional<Fortran::lower::SomeExpr> expr = charLenVariable(sym))
+ if (std::optional<int64_t> asInt = Fortran::evaluate::ToInt64(*expr)) {
+ // Length is max(0, *asInt) (F2018 7.4.4.2 point 5.).
+ if (*asInt < 0)
+ return 0;
+ return *asInt;
+ }
+ return llvm::None;
+ }
+
+ // Get the `SomeExpr` that describes the CHARACTER's LEN.
+ llvm::Optional<Fortran::lower::SomeExpr>
+ charLenVariable(const Fortran::semantics::Symbol &sym) {
+ const Fortran::semantics::ParamValue &lenParam =
+ sym.GetType()->characterTypeSpec().length();
+ if (Fortran::semantics::MaybeIntExpr expr = lenParam.GetExplicit())
+ return {Fortran::evaluate::AsGenericExpr(std::move(*expr))};
+ // For assumed length parameters, the length comes from the initialization
+ // expression.
+ if (sym.attrs().test(Fortran::semantics::Attr::PARAMETER))
+ if (const auto *objectDetails =
+ sym.GetUltimate()
+ .detailsIf<Fortran::semantics::ObjectEntityDetails>())
+ if (objectDetails->init())
+ if (const auto *charExpr = std::get_if<
+ Fortran::evaluate::Expr<Fortran::evaluate::SomeCharacter>>(
+ &objectDetails->init()->u))
+ if (Fortran::semantics::MaybeSubscriptIntExpr expr =
+ charExpr->LEN())
+ return {Fortran::evaluate::AsGenericExpr(std::move(*expr))};
+ return llvm::None;
+ }
+
+ VT box;
+}; // namespace Fortran::lower
+
+} // namespace Fortran::lower
+
+#endif // FORTRAN_LOWER_BOXANALYZER_H
diff --git a/flang/include/flang/Lower/ConvertExpr.h b/flang/include/flang/Lower/ConvertExpr.h
index 07763f5d5c1fb..c26cf72fee20b 100644
--- a/flang/include/flang/Lower/ConvertExpr.h
+++ b/flang/include/flang/Lower/ConvertExpr.h
@@ -52,6 +52,12 @@ fir::ExtendedValue createSomeExtendedAddress(mlir::Location loc,
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 a subroutine call. This handles both elemental and non elemental
/// subroutines. \p isUserDefAssignment must be set if this is called in the
/// context of a user defined assignment. For subroutines with alternate
diff --git a/flang/include/flang/Lower/ConvertVariable.h b/flang/include/flang/Lower/ConvertVariable.h
index f1d9d4141949e..a4222f2478aa7 100644
--- a/flang/include/flang/Lower/ConvertVariable.h
+++ b/flang/include/flang/Lower/ConvertVariable.h
@@ -17,9 +17,12 @@
#ifndef FORTRAN_LOWER_CONVERT_VARIABLE_H
#define FORTRAN_LOWER_CONVERT_VARIABLE_H
+#include "mlir/IR/Value.h"
+
namespace Fortran ::lower {
class AbstractConverter;
class CallerInterface;
+class StatementContext;
class SymMap;
namespace pft {
struct Variable;
@@ -32,6 +35,13 @@ struct Variable;
void instantiateVariable(AbstractConverter &, const pft::Variable &var,
SymMap &symMap);
+/// Lower a symbol attributes given an optional storage \p and add it to the
+/// provided symbol map. If \preAlloc is not provided, a temporary storage will
+/// be allocated. This is a low level function that should only be used if
+/// instantiateVariable cannot be called.
+void mapSymbolAttributes(AbstractConverter &, const pft::Variable &, SymMap &,
+ StatementContext &, mlir::Value preAlloc = {});
+
/// Instantiate the variables that appear in the specification expressions
/// of the result of a function call. The instantiated variables are added
/// to \p symMap.
diff --git a/flang/include/flang/Optimizer/Builder/MutableBox.h b/flang/include/flang/Optimizer/Builder/MutableBox.h
index a7c16d4808312..de0e5db4f3e9a 100644
--- a/flang/include/flang/Optimizer/Builder/MutableBox.h
+++ b/flang/include/flang/Optimizer/Builder/MutableBox.h
@@ -13,6 +13,7 @@
#ifndef FORTRAN_OPTIMIZER_BUILDER_MUTABLEBOX_H
#define FORTRAN_OPTIMIZER_BUILDER_MUTABLEBOX_H
+#include "flang/Optimizer/Builder/BoxValue.h"
#include "llvm/ADT/StringRef.h"
namespace mlir {
@@ -86,10 +87,23 @@ void disassociateMutableBox(fir::FirOpBuilder &builder, mlir::Location loc,
/// parameter mismatch can trigger a reallocation. See Fortran 10.2.1.3 point 3
/// that this function is implementing for more details. The polymorphic
/// requirements are not yet covered by this function.
-void genReallocIfNeeded(fir::FirOpBuilder &builder, mlir::Location loc,
- const fir::MutableBoxValue &box,
- mlir::ValueRange lbounds, mlir::ValueRange shape,
- mlir::ValueRange lengthParams);
+struct MutableBoxReallocation {
+ fir::ExtendedValue newValue;
+ mlir::Value oldAddress;
+ mlir::Value wasReallocated;
+ mlir::Value oldAddressWasAllocated;
+};
+
+MutableBoxReallocation genReallocIfNeeded(fir::FirOpBuilder &builder,
+ mlir::Location loc,
+ const fir::MutableBoxValue &box,
+ mlir::ValueRange shape,
+ mlir::ValueRange lengthParams);
+
+void finalizeRealloc(fir::FirOpBuilder &builder, mlir::Location loc,
+ const fir::MutableBoxValue &box, mlir::ValueRange lbounds,
+ bool takeLboundsIfRealloc,
+ const MutableBoxReallocation &realloc);
/// Finalize a mutable box if it is allocated or associated. This includes both
/// calling the finalizer, if any, and deallocating the storage.
diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Stop.h b/flang/include/flang/Optimizer/Builder/Runtime/Stop.h
index d5fce1401d934..e0ca52b6f96a2 100644
--- a/flang/include/flang/Optimizer/Builder/Runtime/Stop.h
+++ b/flang/include/flang/Optimizer/Builder/Runtime/Stop.h
@@ -9,6 +9,10 @@
#ifndef FORTRAN_OPTIMIZER_BUILDER_RUNTIME_STOP_H
#define FORTRAN_OPTIMIZER_BUILDER_RUNTIME_STOP_H
+namespace llvm {
+class StringRef;
+}
+
namespace mlir {
class Value;
class Location;
@@ -23,5 +27,10 @@ namespace fir::runtime {
/// Generate call to EXIT intrinsic runtime routine.
void genExit(fir::FirOpBuilder &, mlir::Location, mlir::Value status);
+/// Generate call to crash the program with an error message when detecting
+/// an invalid situation at runtime.
+void genReportFatalUserError(fir::FirOpBuilder &, mlir::Location,
+ llvm::StringRef message);
+
} // namespace fir::runtime
#endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_STOP_H
diff --git a/flang/lib/Lower/Allocatable.cpp b/flang/lib/Lower/Allocatable.cpp
new file mode 100644
index 0000000000000..e56b8f5f10c0d
--- /dev/null
+++ b/flang/lib/Lower/Allocatable.cpp
@@ -0,0 +1,157 @@
+//===-- Allocatable.cpp -- Allocatable statements lowering ----------------===//
+//
+// 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/Allocatable.h"
+#include "flang/Evaluate/tools.h"
+#include "flang/Lower/AbstractConverter.h"
+#include "flang/Lower/PFTBuilder.h"
+#include "flang/Lower/Runtime.h"
+#include "flang/Lower/StatementContext.h"
+#include "flang/Lower/Todo.h"
+#include "flang/Optimizer/Builder/FIRBuilder.h"
+#include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
+#include "flang/Optimizer/Dialect/FIROps.h"
+#include "flang/Optimizer/Dialect/FIROpsSupport.h"
+#include "flang/Optimizer/Support/FatalError.h"
+#include "flang/Parser/parse-tree.h"
+#include "flang/Semantics/tools.h"
+#include "flang/Semantics/type.h"
+#include "llvm/Support/CommandLine.h"
+
+/// By default fir memory operation fir::AllocMemOp/fir::FreeMemOp are used.
+/// This switch allow forcing the use of runtime and descriptors for everything.
+/// This is mainly intended as a debug switch.
+static llvm::cl::opt<bool> useAllocateRuntime(
+ "use-alloc-runtime",
+ llvm::cl::desc("Lower allocations to fortran runtime calls"),
+ llvm::cl::init(false));
+/// Switch to force lowering of allocatable and pointers to descriptors in all
+/// cases for debug purposes.
+static llvm::cl::opt<bool> useDescForMutableBox(
+ "use-desc-for-alloc",
+ llvm::cl::desc("Always use descriptors for POINTER and ALLOCATABLE"),
+ llvm::cl::init(false));
+
+//===----------------------------------------------------------------------===//
+// MutableBoxValue creation implementation
+//===----------------------------------------------------------------------===//
+
+/// Is this symbol a pointer to a pointer array that does not have the
+/// CONTIGUOUS attribute ?
+static inline bool
+isNonContiguousArrayPointer(const Fortran::semantics::Symbol &sym) {
+ return Fortran::semantics::IsPointer(sym) && sym.Rank() != 0 &&
+ !sym.attrs().test(Fortran::semantics::Attr::CONTIGUOUS);
+}
+
+/// Is this a local procedure symbol in a procedure that contains internal
+/// procedures ?
+static bool mayBeCapturedInInternalProc(const Fortran::semantics::Symbol &sym) {
+ const Fortran::semantics::Scope &owner = sym.owner();
+ Fortran::semantics::Scope::Kind kind = owner.kind();
+ // Test if this is a procedure scope that contains a subprogram scope that is
+ // not an interface.
+ if (kind == Fortran::semantics::Scope::Kind::Subprogram ||
+ kind == Fortran::semantics::Scope::Kind::MainProgram)
+ for (const Fortran::semantics::Scope &childScope : owner.children())
+ if (childScope.kind() == Fortran::semantics::Scope::Kind::Subprogram)
+ if (const Fortran::semantics::Symbol *childSym = childScope.symbol())
+ if (const auto *details =
+ childSym->detailsIf<Fortran::semantics::SubprogramDetails>())
+ if (!details->isInterface())
+ return true;
+ return false;
+}
+
+/// In case it is safe to track the properties in variables outside a
+/// descriptor, create the variables to hold the mutable properties of the
+/// entity var. The variables are not initialized here.
+static fir::MutableProperties
+createMutableProperties(Fortran::lower::AbstractConverter &converter,
+ mlir::Location loc,
+ const Fortran::lower::pft::Variable &var,
+ mlir::ValueRange nonDeferredParams) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ const Fortran::semantics::Symbol &sym = var.getSymbol();
+ // Globals and dummies may be associated, creating local variables would
+ // require keeping the values and descriptor before and after every single
+ // impure calls in the current scope (not only the ones taking the variable as
+ // arguments. All.) Volatile means the variable may change in ways not defined
+ // per Fortran, so lowering can most likely not keep the descriptor and values
+ // in sync as needed.
+ // Pointers to non contiguous arrays need to be represented with a fir.box to
+ // account for the discontiguity.
+ // Pointer/Allocatable in internal procedure are descriptors in the host link,
+ // and it would increase complexity to sync this descriptor with the local
+ // values every time the host link is escaping.
+ if (var.isGlobal() || Fortran::semantics::IsDummy(sym) ||
+ Fortran::semantics::IsFunctionResult(sym) ||
+ sym.attrs().test(Fortran::semantics::Attr::VOLATILE) ||
+ isNonContiguousArrayPointer(sym) || useAllocateRuntime ||
+ useDescForMutableBox || mayBeCapturedInInternalProc(sym))
+ return {};
+ fir::MutableProperties mutableProperties;
+ std::string name = converter.mangleName(sym);
+ mlir::Type baseAddrTy = converter.genType(sym);
+ if (auto boxType = baseAddrTy.dyn_cast<fir::BoxType>())
+ baseAddrTy = boxType.getEleTy();
+ // Allocate and set a variable to hold the address.
+ // It will be set to null in setUnallocatedStatus.
+ mutableProperties.addr =
+ builder.allocateLocal(loc, baseAddrTy, name + ".addr", "",
+ /*shape=*/llvm::None, /*typeparams=*/llvm::None);
+ // Allocate variables to hold lower bounds and extents.
+ int rank = sym.Rank();
+ mlir::Type idxTy = builder.getIndexType();
+ for (decltype(rank) i = 0; i < rank; ++i) {
+ mlir::Value lboundVar =
+ builder.allocateLocal(loc, idxTy, name + ".lb" + std::to_string(i), "",
+ /*shape=*/llvm::None, /*typeparams=*/llvm::None);
+ mlir::Value extentVar =
+ builder.allocateLocal(loc, idxTy, name + ".ext" + std::to_string(i), "",
+ /*shape=*/llvm::None, /*typeparams=*/llvm::None);
+ mutableProperties.lbounds.emplace_back(lboundVar);
+ mutableProperties.extents.emplace_back(extentVar);
+ }
+
+ // Allocate variable to hold deferred length parameters.
+ mlir::Type eleTy = baseAddrTy;
+ if (auto newTy = fir::dyn_cast_ptrEleTy(eleTy))
+ eleTy = newTy;
+ if (auto seqTy = eleTy.dyn_cast<fir::SequenceType>())
+ eleTy = seqTy.getEleTy();
+ if (auto record = eleTy.dyn_cast<fir::RecordType>())
+ if (record.getNumLenParams() != 0)
+ TODO(loc, "deferred length type parameters.");
+ if (fir::isa_char(eleTy) && nonDeferredParams.empty()) {
+ mlir::Value lenVar =
+ builder.allocateLocal(loc, builder.getCharacterLengthType(),
+ name + ".len", "", /*shape=*/llvm::None,
+ /*typeparams=*/llvm::None);
+ mutableProperties.deferredParams.emplace_back(lenVar);
+ }
+ return mutableProperties;
+}
+
+fir::MutableBoxValue Fortran::lower::createMutableBox(
+ Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ const Fortran::lower::pft::Variable &var, mlir::Value boxAddr,
+ mlir::ValueRange nonDeferredParams) {
+
+ fir::MutableProperties mutableProperties =
+ createMutableProperties(converter, loc, var, nonDeferredParams);
+ fir::MutableBoxValue box(boxAddr, nonDeferredParams, mutableProperties);
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ if (!var.isGlobal() && !Fortran::semantics::IsDummy(var.getSymbol()))
+ fir::factory::disassociateMutableBox(builder, loc, box);
+ return box;
+}
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index 815ba254c34e1..72e68833afba0 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -22,6 +22,8 @@
#include "flang/Lower/StatementContext.h"
#include "flang/Lower/SymbolMap.h"
#include "flang/Lower/Todo.h"
+#include "flang/Optimizer/Builder/BoxValue.h"
+#include "flang/Optimizer/Builder/MutableBox.h"
#include "flang/Optimizer/Support/FIRContext.h"
#include "flang/Semantics/tools.h"
#include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h"
@@ -90,6 +92,11 @@ class FirConverter : public Fortran::lower::AbstractConverter {
return createSomeExtendedExpression(loc ? *loc : toLocation(), *this, expr,
localSymbols, context);
}
+ fir::MutableBoxValue
+ genExprMutableBox(mlir::Location loc,
+ const Fortran::lower::SomeExpr &expr) override final {
+ return Fortran::lower::createMutableBox(loc, *this, expr, localSymbols);
+ }
Fortran::evaluate::FoldingContext &getFoldingContext() override final {
return foldingContext;
@@ -520,14 +527,32 @@ class FirConverter : public Fortran::lower::AbstractConverter {
fir::ExtendedValue rhs = isNumericScalar
? genExprValue(assign.rhs, stmtCtx)
: genExprAddr(assign.rhs, stmtCtx);
+ bool lhsIsWholeAllocatable = isWholeAllocatable(assign.lhs);
+ llvm::Optional<fir::factory::MutableBoxReallocation> lhsRealloc;
+ llvm::Optional<fir::MutableBoxValue> lhsMutableBox;
+ auto lhs = [&]() -> fir::ExtendedValue {
+ if (lhsIsWholeAllocatable) {
+ lhsMutableBox = genExprMutableBox(loc, assign.lhs);
+ llvm::SmallVector<mlir::Value> lengthParams;
+ if (const fir::CharBoxValue *charBox = rhs.getCharBox())
+ lengthParams.push_back(charBox->getLen());
+ else if (fir::isDerivedWithLengthParameters(rhs))
+ TODO(loc, "assignment to derived type allocatable with "
+ "length parameters");
+ lhsRealloc = fir::factory::genReallocIfNeeded(
+ *builder, loc, *lhsMutableBox,
+ /*shape=*/llvm::None, lengthParams);
+ return lhsRealloc->newValue;
+ }
+ return genExprAddr(assign.lhs, stmtCtx);
+ }();
if (isNumericScalar) {
// Fortran 2018 10.2.1.3 p8 and p9
// Conversions should have been inserted by semantic analysis,
// but they can be incorrect between the rhs and lhs. Correct
// that here.
- mlir::Value addr =
- fir::getBase(genExprAddr(assign.lhs, stmtCtx));
+ mlir::Value addr = fir::getBase(lhs);
mlir::Value val = fir::getBase(rhs);
// A function with multiple entry points returning
diff erent
// types tags all result variables with one of the largest
@@ -550,6 +575,11 @@ class FirConverter : public Fortran::lower::AbstractConverter {
} else {
llvm_unreachable("unknown category");
}
+ if (lhsIsWholeAllocatable)
+ fir::factory::finalizeRealloc(
+ *builder, loc, lhsMutableBox.getValue(),
+ /*lbounds=*/llvm::None, /*takeLboundsIfRealloc=*/false,
+ lhsRealloc.getValue());
},
// [2] User defined assignment. If the context is a scalar
diff --git a/flang/lib/Lower/CMakeLists.txt b/flang/lib/Lower/CMakeLists.txt
index 56fdce46f9433..3be444bf1323f 100644
--- a/flang/lib/Lower/CMakeLists.txt
+++ b/flang/lib/Lower/CMakeLists.txt
@@ -1,6 +1,7 @@
get_property(dialect_libs GLOBAL PROPERTY MLIR_DIALECT_LIBS)
add_flang_library(FortranLower
+ Allocatable.cpp
Bridge.cpp
CallInterface.cpp
Coarray.cpp
diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp
index 8d6805d262e7d..7bef850b079b6 100644
--- a/flang/lib/Lower/ConvertExpr.cpp
+++ b/flang/lib/Lower/ConvertExpr.cpp
@@ -174,6 +174,62 @@ class ScalarExprLowering {
return genval(expr);
}
+ /// Lower an expression that is a pointer or an allocatable to a
+ /// MutableBoxValue.
+ fir::MutableBoxValue
+ genMutableBoxValue(const Fortran::lower::SomeExpr &expr) {
+ // Pointers and allocatables can only be:
+ // - a simple designator "x"
+ // - a component designator "a%b(i,j)%x"
+ // - a function reference "foo()"
+ // - result of NULL() or NULL(MOLD) intrinsic.
+ // NULL() requires some context to be lowered, so it is not handled
+ // here and must be lowered according to the context where it appears.
+ ExtValue exv = std::visit(
+ [&](const auto &x) { return genMutableBoxValueImpl(x); }, expr.u);
+ const fir::MutableBoxValue *mutableBox =
+ exv.getBoxOf<fir::MutableBoxValue>();
+ if (!mutableBox)
+ fir::emitFatalError(getLoc(), "expr was not lowered to MutableBoxValue");
+ return *mutableBox;
+ }
+
+ template <typename T>
+ ExtValue genMutableBoxValueImpl(const T &) {
+ // NULL() case should not be handled here.
+ fir::emitFatalError(getLoc(), "NULL() must be lowered in its context");
+ }
+
+ template <typename T>
+ ExtValue
+ genMutableBoxValueImpl(const Fortran::evaluate::FunctionRef<T> &funRef) {
+ return genRawProcedureRef(funRef, converter.genType(toEvExpr(funRef)));
+ }
+
+ template <typename T>
+ ExtValue
+ genMutableBoxValueImpl(const Fortran::evaluate::Designator<T> &designator) {
+ return std::visit(
+ Fortran::common::visitors{
+ [&](const Fortran::evaluate::SymbolRef &sym) -> ExtValue {
+ return symMap.lookupSymbol(*sym).toExtendedValue();
+ },
+ [&](const Fortran::evaluate::Component &comp) -> ExtValue {
+ TODO(getLoc(), "genMutableBoxValueImpl Component");
+ },
+ [&](const auto &) -> ExtValue {
+ fir::emitFatalError(getLoc(),
+ "not an allocatable or pointer designator");
+ }},
+ designator.u);
+ }
+
+ template <typename T>
+ ExtValue genMutableBoxValueImpl(const Fortran::evaluate::Expr<T> &expr) {
+ return std::visit([&](const auto &x) { return genMutableBoxValueImpl(x); },
+ expr.u);
+ }
+
mlir::Location getLoc() { return location; }
template <typename A>
@@ -1235,6 +1291,19 @@ fir::ExtendedValue Fortran::lower::createSomeExtendedAddress(
return ScalarExprLowering{loc, converter, symMap, stmtCtx}.gen(expr);
}
+fir::MutableBoxValue Fortran::lower::createMutableBox(
+ mlir::Location loc, Fortran::lower::AbstractConverter &converter,
+ const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap) {
+ // MutableBox lowering StatementContext does not need to be propagated
+ // to the caller because the result value is a variable, not a temporary
+ // expression. The StatementContext clean-up can occur before using the
+ // resulting MutableBoxValue. Variables of all other types are handled in the
+ // bridge.
+ Fortran::lower::StatementContext dummyStmtCtx;
+ return ScalarExprLowering{loc, converter, symMap, dummyStmtCtx}
+ .genMutableBoxValue(expr);
+}
+
mlir::Value Fortran::lower::createSubroutineCall(
AbstractConverter &converter, const evaluate::ProcedureRef &call,
SymMap &symMap, StatementContext &stmtCtx) {
diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index 8667732bd4257..a2e7e1de85b97 100644
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -12,10 +12,13 @@
#include "flang/Lower/ConvertVariable.h"
#include "flang/Lower/AbstractConverter.h"
+#include "flang/Lower/Allocatable.h"
+#include "flang/Lower/BoxAnalyzer.h"
#include "flang/Lower/CallInterface.h"
#include "flang/Lower/ConvertExpr.h"
#include "flang/Lower/Mangler.h"
#include "flang/Lower/PFTBuilder.h"
+#include "flang/Lower/StatementContext.h"
#include "flang/Lower/Support/Utils.h"
#include "flang/Lower/SymbolMap.h"
#include "flang/Lower/Todo.h"
@@ -32,6 +35,18 @@
#define DEBUG_TYPE "flang-lower-variable"
+/// Helper to lower a scalar expression using a specific symbol mapping.
+static mlir::Value genScalarValue(Fortran::lower::AbstractConverter &converter,
+ mlir::Location loc,
+ const Fortran::lower::SomeExpr &expr,
+ Fortran::lower::SymMap &symMap,
+ Fortran::lower::StatementContext &context) {
+ // This does not use the AbstractConverter member function to override the
+ // symbol mapping to be used expression lowering.
+ return fir::getBase(Fortran::lower::createSomeExtendedExpression(
+ loc, converter, expr, symMap, context));
+}
+
//===----------------------------------------------------------------===//
// Local variables instantiation (not for alias)
//===----------------------------------------------------------------===//
@@ -65,28 +80,305 @@ static void instantiateLocal(Fortran::lower::AbstractConverter &converter,
const Fortran::lower::pft::Variable &var,
Fortran::lower::SymMap &symMap) {
assert(!var.isAlias());
+ Fortran::lower::StatementContext stmtCtx;
+ mapSymbolAttributes(converter, var, symMap, stmtCtx);
+}
+
+/// Helper to decide if a dummy argument must be tracked in an BoxValue.
+static bool lowerToBoxValue(const Fortran::semantics::Symbol &sym,
+ mlir::Value dummyArg) {
+ // Only dummy arguments coming as fir.box can be tracked in an BoxValue.
+ if (!dummyArg || !dummyArg.getType().isa<fir::BoxType>())
+ return false;
+ // Non contiguous arrays must be tracked in an BoxValue.
+ if (sym.Rank() > 0 && !sym.attrs().test(Fortran::semantics::Attr::CONTIGUOUS))
+ return true;
+ // Assumed rank and optional fir.box cannot yet be read while lowering the
+ // specifications.
+ if (Fortran::evaluate::IsAssumedRank(sym) ||
+ Fortran::semantics::IsOptional(sym))
+ return true;
+ // Polymorphic entity should be tracked through a fir.box that has the
+ // dynamic type info.
+ if (const Fortran::semantics::DeclTypeSpec *type = sym.GetType())
+ if (type->IsPolymorphic())
+ return true;
+ return false;
+}
+
+/// Compute extent from lower and upper bound.
+static mlir::Value computeExtent(fir::FirOpBuilder &builder, mlir::Location loc,
+ mlir::Value lb, mlir::Value ub) {
+ mlir::IndexType idxTy = builder.getIndexType();
+ // Let the folder deal with the common `ub - <const> + 1` case.
+ auto
diff = builder.create<mlir::arith::SubIOp>(loc, idxTy, ub, lb);
+ mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
+ return builder.create<mlir::arith::AddIOp>(loc, idxTy,
diff , one);
+}
+
+/// Lower explicit lower bounds into \p result. Does nothing if this is not an
+/// array, or if the lower bounds are deferred, or all implicit or one.
+static void lowerExplicitLowerBounds(
+ Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ const Fortran::lower::BoxAnalyzer &box,
+ llvm::SmallVectorImpl<mlir::Value> &result, Fortran::lower::SymMap &symMap,
+ Fortran::lower::StatementContext &stmtCtx) {
+ if (!box.isArray() || box.lboundIsAllOnes())
+ return;
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ mlir::IndexType idxTy = builder.getIndexType();
+ if (box.isStaticArray()) {
+ for (int64_t lb : box.staticLBound())
+ result.emplace_back(builder.createIntegerConstant(loc, idxTy, lb));
+ return;
+ }
+ for (const Fortran::semantics::ShapeSpec *spec : box.dynamicBound()) {
+ if (auto low = spec->lbound().GetExplicit()) {
+ auto expr = Fortran::lower::SomeExpr{*low};
+ mlir::Value lb = builder.createConvert(
+ loc, idxTy, genScalarValue(converter, loc, expr, symMap, stmtCtx));
+ result.emplace_back(lb);
+ } else if (!spec->lbound().isColon()) {
+ // Implicit lower bound is 1 (Fortran 2018 section 8.5.8.3 point 3.)
+ result.emplace_back(builder.createIntegerConstant(loc, idxTy, 1));
+ }
+ }
+ assert(result.empty() || result.size() == box.dynamicBound().size());
+}
+
+/// Lower explicit extents into \p result if this is an explicit-shape or
+/// assumed-size array. Does nothing if this is not an explicit-shape or
+/// assumed-size array.
+static void lowerExplicitExtents(Fortran::lower::AbstractConverter &converter,
+ mlir::Location loc,
+ const Fortran::lower::BoxAnalyzer &box,
+ llvm::ArrayRef<mlir::Value> lowerBounds,
+ llvm::SmallVectorImpl<mlir::Value> &result,
+ Fortran::lower::SymMap &symMap,
+ Fortran::lower::StatementContext &stmtCtx) {
+ if (!box.isArray())
+ return;
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ mlir::IndexType idxTy = builder.getIndexType();
+ if (box.isStaticArray()) {
+ for (int64_t extent : box.staticShape())
+ result.emplace_back(builder.createIntegerConstant(loc, idxTy, extent));
+ return;
+ }
+ for (const auto &spec : llvm::enumerate(box.dynamicBound())) {
+ if (auto up = spec.value()->ubound().GetExplicit()) {
+ auto expr = Fortran::lower::SomeExpr{*up};
+ mlir::Value ub = builder.createConvert(
+ loc, idxTy, genScalarValue(converter, loc, expr, symMap, stmtCtx));
+ if (lowerBounds.empty())
+ result.emplace_back(ub);
+ else
+ result.emplace_back(
+ computeExtent(builder, loc, lowerBounds[spec.index()], ub));
+ } else if (spec.value()->ubound().isStar()) {
+ // Assumed extent is undefined. Must be provided by user's code.
+ result.emplace_back(builder.create<fir::UndefOp>(loc, idxTy));
+ }
+ }
+ assert(result.empty() || result.size() == box.dynamicBound().size());
+}
+
+/// Treat negative values as undefined. Assumed size arrays will return -1 from
+/// the front end for example. Using negative values can produce hard to find
+/// bugs much further along in the compilation.
+static mlir::Value genExtentValue(fir::FirOpBuilder &builder,
+ mlir::Location loc, mlir::Type idxTy,
+ long frontEndExtent) {
+ if (frontEndExtent >= 0)
+ return builder.createIntegerConstant(loc, idxTy, frontEndExtent);
+ return builder.create<fir::UndefOp>(loc, idxTy);
+}
+
+/// Lower specification expressions and attributes of variable \p var and
+/// add it to the symbol map.
+/// For global and aliases, the address must be pre-computed and provided
+/// in \p preAlloc.
+/// Dummy arguments must have already been mapped to mlir block arguments
+/// their mapping may be updated here.
+void Fortran::lower::mapSymbolAttributes(
+ AbstractConverter &converter, const Fortran::lower::pft::Variable &var,
+ Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
+ mlir::Value preAlloc) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
const Fortran::semantics::Symbol &sym = var.getSymbol();
+ const mlir::Location loc = converter.genLocation(sym.name());
+ mlir::IndexType idxTy = builder.getIndexType();
const bool isDummy = Fortran::semantics::IsDummy(sym);
const bool isResult = Fortran::semantics::IsFunctionResult(sym);
- if (symMap.lookupSymbol(sym))
+ const bool replace = isDummy || isResult;
+ fir::factory::CharacterExprHelper charHelp{builder, loc};
+ Fortran::lower::BoxAnalyzer ba;
+ ba.analyze(sym);
+
+ // First deal with pointers an allocatables, because their handling here
+ // is the same regardless of their rank.
+ if (Fortran::semantics::IsAllocatableOrPointer(sym)) {
+ // Get address of fir.box describing the entity.
+ // global
+ mlir::Value boxAlloc = preAlloc;
+ // dummy or passed result
+ if (!boxAlloc)
+ if (Fortran::lower::SymbolBox symbox = symMap.lookupSymbol(sym))
+ boxAlloc = symbox.getAddr();
+ // local
+ if (!boxAlloc)
+ boxAlloc = createNewLocal(converter, loc, var, preAlloc);
+ // Lower non deferred parameters.
+ llvm::SmallVector<mlir::Value> nonDeferredLenParams;
+ if (ba.isChar()) {
+ TODO(loc, "mapSymbolAttributes allocatble or pointer char");
+ } else if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType()) {
+ if (const Fortran::semantics::DerivedTypeSpec *derived =
+ declTy->AsDerived())
+ if (Fortran::semantics::CountLenParameters(*derived) != 0)
+ TODO(loc,
+ "derived type allocatable or pointer with length parameters");
+ }
+ fir::MutableBoxValue box = Fortran::lower::createMutableBox(
+ converter, loc, var, boxAlloc, nonDeferredLenParams);
+ symMap.addAllocatableOrPointer(var.getSymbol(), box, replace);
return;
+ }
- const mlir::Location loc = converter.genLocation(sym.name());
if (isDummy) {
- // This is an argument.
- if (!symMap.lookupSymbol(sym))
- mlir::emitError(loc, "symbol \"")
- << toStringRef(sym.name()) << "\" must already be in map";
- return;
- } else if (isResult) {
- // Some Fortran results may be passed by argument (e.g. derived
- // types)
- if (symMap.lookupSymbol(sym))
+ mlir::Value dummyArg = symMap.lookupSymbol(sym).getAddr();
+ if (lowerToBoxValue(sym, dummyArg)) {
+ llvm::SmallVector<mlir::Value> lbounds;
+ llvm::SmallVector<mlir::Value> extents;
+ llvm::SmallVector<mlir::Value> explicitParams;
+ // Lower lower bounds, explicit type parameters and explicit
+ // extents if any.
+ if (ba.isChar())
+ TODO(loc, "lowerToBoxValue character");
+ // TODO: derived type length parameters.
+ lowerExplicitLowerBounds(converter, loc, ba, lbounds, symMap, stmtCtx);
+ lowerExplicitExtents(converter, loc, ba, lbounds, extents, symMap,
+ stmtCtx);
+ symMap.addBoxSymbol(sym, dummyArg, lbounds, explicitParams, extents,
+ replace);
return;
+ }
}
- // Otherwise, it's a local variable or function result.
- mlir::Value local = createNewLocal(converter, loc, var, {});
- symMap.addSymbol(sym, local);
+
+ // For symbols reaching this point, all properties are constant and can be
+ // read/computed already into ssa values.
+
+ ba.match(
+ //===--------------------------------------------------------------===//
+ // Trivial case.
+ //===--------------------------------------------------------------===//
+ [&](const Fortran::lower::details::ScalarSym &) {
+ if (isDummy) {
+ // This is an argument.
+ if (!symMap.lookupSymbol(sym))
+ mlir::emitError(loc, "symbol \"")
+ << toStringRef(sym.name()) << "\" must already be in map";
+ return;
+ } else if (isResult) {
+ // Some Fortran results may be passed by argument (e.g. derived
+ // types)
+ if (symMap.lookupSymbol(sym))
+ return;
+ }
+ // Otherwise, it's a local variable or function result.
+ mlir::Value local = createNewLocal(converter, loc, var, preAlloc);
+ symMap.addSymbol(sym, local);
+ },
+
+ //===--------------------------------------------------------------===//
+ // The non-trivial cases are when we have an argument or local that has
+ // a repetition value. Arguments might be passed as simple pointers and
+ // need to be cast to a multi-dimensional array with constant bounds
+ // (possibly with a missing column), bounds computed in the callee
+ // (here), or with bounds from the caller (boxed somewhere else). Locals
+ // have the same properties except they are never boxed arguments from
+ // the caller and never having a missing column size.
+ //===--------------------------------------------------------------===//
+
+ [&](const Fortran::lower::details::ScalarStaticChar &x) {
+ TODO(loc, "mapSymbolAttributes ScalarStaticChar");
+ },
+
+ //===--------------------------------------------------------------===//
+
+ [&](const Fortran::lower::details::ScalarDynamicChar &x) {
+ TODO(loc, "mapSymbolAttributes ScalarDynamicChar");
+ },
+
+ //===--------------------------------------------------------------===//
+
+ [&](const Fortran::lower::details::StaticArray &x) {
+ // object shape is constant, not a character
+ mlir::Type castTy = builder.getRefType(converter.genType(var));
+ mlir::Value addr = symMap.lookupSymbol(sym).getAddr();
+ if (addr)
+ addr = builder.createConvert(loc, castTy, addr);
+ if (x.lboundAllOnes()) {
+ // if lower bounds are all ones, build simple shaped object
+ llvm::SmallVector<mlir::Value> shape;
+ for (int64_t i : x.shapes)
+ shape.push_back(genExtentValue(builder, loc, idxTy, i));
+ mlir::Value local =
+ isDummy ? addr : createNewLocal(converter, loc, var, preAlloc);
+ symMap.addSymbolWithShape(sym, local, shape, isDummy);
+ return;
+ }
+ // If object is an array process the lower bound and extent values by
+ // constructing constants and populating the lbounds and extents.
+ llvm::SmallVector<mlir::Value> extents;
+ llvm::SmallVector<mlir::Value> lbounds;
+ for (auto [fst, snd] : llvm::zip(x.lbounds, x.shapes)) {
+ lbounds.emplace_back(builder.createIntegerConstant(loc, idxTy, fst));
+ extents.emplace_back(genExtentValue(builder, loc, idxTy, snd));
+ }
+ mlir::Value local =
+ isDummy ? addr
+ : createNewLocal(converter, loc, var, preAlloc, extents);
+ assert(isDummy || Fortran::lower::isExplicitShape(sym));
+ symMap.addSymbolWithBounds(sym, local, extents, lbounds, isDummy);
+ },
+
+ //===--------------------------------------------------------------===//
+
+ [&](const Fortran::lower::details::DynamicArray &x) {
+ TODO(loc, "mapSymbolAttributes DynamicArray");
+ },
+
+ //===--------------------------------------------------------------===//
+
+ [&](const Fortran::lower::details::StaticArrayStaticChar &x) {
+ TODO(loc, "mapSymbolAttributes StaticArrayStaticChar");
+ },
+
+ //===--------------------------------------------------------------===//
+
+ [&](const Fortran::lower::details::StaticArrayDynamicChar &x) {
+ TODO(loc, "mapSymbolAttributes StaticArrayDynamicChar");
+ },
+
+ //===--------------------------------------------------------------===//
+
+ [&](const Fortran::lower::details::DynamicArrayStaticChar &x) {
+ TODO(loc, "mapSymbolAttributes DynamicArrayStaticChar");
+ },
+
+ //===--------------------------------------------------------------===//
+
+ [&](const Fortran::lower::details::DynamicArrayDynamicChar &x) {
+ TODO(loc, "mapSymbolAttributes DynamicArrayDynamicChar");
+ },
+
+ //===--------------------------------------------------------------===//
+
+ [&](const Fortran::lower::BoxAnalyzer::None &) {
+ mlir::emitError(loc, "symbol analysis failed on ")
+ << toStringRef(sym.name());
+ });
}
void Fortran::lower::instantiateVariable(AbstractConverter &converter,
diff --git a/flang/lib/Optimizer/Builder/MutableBox.cpp b/flang/lib/Optimizer/Builder/MutableBox.cpp
index 5584e7a939132..5a761e41e45b3 100644
--- a/flang/lib/Optimizer/Builder/MutableBox.cpp
+++ b/flang/lib/Optimizer/Builder/MutableBox.cpp
@@ -14,10 +14,67 @@
#include "flang/Lower/Todo.h"
#include "flang/Optimizer/Builder/Character.h"
#include "flang/Optimizer/Builder/FIRBuilder.h"
+#include "flang/Optimizer/Builder/Runtime/Derived.h"
+#include "flang/Optimizer/Builder/Runtime/Stop.h"
#include "flang/Optimizer/Dialect/FIROps.h"
#include "flang/Optimizer/Dialect/FIROpsSupport.h"
#include "flang/Optimizer/Support/FatalError.h"
+/// Create a fir.box describing the new address, bounds, and length parameters
+/// for a MutableBox \p box.
+static mlir::Value createNewFirBox(fir::FirOpBuilder &builder,
+ mlir::Location loc,
+ const fir::MutableBoxValue &box,
+ mlir::Value addr, mlir::ValueRange lbounds,
+ mlir::ValueRange extents,
+ mlir::ValueRange lengths) {
+ if (addr.getType().isa<fir::BoxType>())
+ // The entity is already boxed.
+ return builder.createConvert(loc, box.getBoxTy(), addr);
+
+ mlir::Value shape;
+ if (!extents.empty()) {
+ if (lbounds.empty()) {
+ auto shapeType =
+ fir::ShapeType::get(builder.getContext(), extents.size());
+ shape = builder.create<fir::ShapeOp>(loc, shapeType, extents);
+ } else {
+ llvm::SmallVector<mlir::Value> shapeShiftBounds;
+ for (auto [lb, extent] : llvm::zip(lbounds, extents)) {
+ shapeShiftBounds.emplace_back(lb);
+ shapeShiftBounds.emplace_back(extent);
+ }
+ auto shapeShiftType =
+ fir::ShapeShiftType::get(builder.getContext(), extents.size());
+ shape = builder.create<fir::ShapeShiftOp>(loc, shapeShiftType,
+ shapeShiftBounds);
+ }
+ } // Otherwise, this a scalar. Leave the shape empty.
+
+ // Ignore lengths if already constant in the box type (this would trigger an
+ // error in the embox).
+ llvm::SmallVector<mlir::Value> cleanedLengths;
+ auto cleanedAddr = addr;
+ if (auto charTy = box.getEleTy().dyn_cast<fir::CharacterType>()) {
+ // Cast address to box type so that both input and output type have
+ // unknown or constant lengths.
+ auto bt = box.getBaseTy();
+ auto addrTy = addr.getType();
+ auto type = addrTy.isa<fir::HeapType>() ? fir::HeapType::get(bt)
+ : addrTy.isa<fir::PointerType>() ? fir::PointerType::get(bt)
+ : builder.getRefType(bt);
+ cleanedAddr = builder.createConvert(loc, type, addr);
+ if (charTy.getLen() == fir::CharacterType::unknownLen())
+ cleanedLengths.append(lengths.begin(), lengths.end());
+ } else if (box.isDerivedWithLengthParameters()) {
+ TODO(loc, "updating mutablebox of derived type with length parameters");
+ cleanedLengths = lengths;
+ }
+ mlir::Value emptySlice;
+ return builder.create<fir::EmboxOp>(loc, box.getBoxTy(), cleanedAddr, shape,
+ emptySlice, cleanedLengths);
+}
+
//===----------------------------------------------------------------------===//
// MutableBoxValue writer and reader
//===----------------------------------------------------------------------===//
@@ -618,6 +675,47 @@ void fir::factory::disassociateMutableBox(fir::FirOpBuilder &builder,
MutablePropertyWriter{builder, loc, box}.setUnallocatedStatus();
}
+static llvm::SmallVector<mlir::Value>
+getNewLengths(fir::FirOpBuilder &builder, mlir::Location loc,
+ const fir::MutableBoxValue &box, mlir::ValueRange lenParams) {
+ llvm::SmallVector<mlir::Value> lengths;
+ auto idxTy = builder.getIndexType();
+ if (auto charTy = box.getEleTy().dyn_cast<fir::CharacterType>()) {
+ if (charTy.getLen() == fir::CharacterType::unknownLen()) {
+ if (box.hasNonDeferredLenParams())
+ lengths.emplace_back(
+ builder.createConvert(loc, idxTy, box.nonDeferredLenParams()[0]));
+ else if (!lenParams.empty())
+ lengths.emplace_back(builder.createConvert(loc, idxTy, lenParams[0]));
+ else
+ fir::emitFatalError(
+ loc, "could not deduce character lengths in character allocation");
+ }
+ }
+ return lengths;
+}
+
+static mlir::Value allocateAndInitNewStorage(fir::FirOpBuilder &builder,
+ mlir::Location loc,
+ const fir::MutableBoxValue &box,
+ mlir::ValueRange extents,
+ mlir::ValueRange lenParams,
+ llvm::StringRef allocName) {
+ auto lengths = getNewLengths(builder, loc, box, lenParams);
+ auto newStorage = builder.create<fir::AllocMemOp>(
+ loc, box.getBaseTy(), allocName, lengths, extents);
+ if (box.getEleTy().isa<fir::RecordType>()) {
+ // TODO: skip runtime initialization if this is not required. Currently,
+ // there is no way to know here if a derived type needs it or not. But the
+ // information is available at compile time and could be reflected here
+ // somehow.
+ mlir::Value irBox = createNewFirBox(builder, loc, box, newStorage,
+ llvm::None, extents, lengths);
+ fir::runtime::genDerivedTypeInitialize(builder, loc, irBox);
+ }
+ return newStorage;
+}
+
void fir::factory::genInlinedAllocation(fir::FirOpBuilder &builder,
mlir::Location loc,
const fir::MutableBoxValue &box,
@@ -655,73 +753,148 @@ void fir::factory::genInlinedDeallocate(fir::FirOpBuilder &builder,
MutablePropertyWriter{builder, loc, box}.setUnallocatedStatus();
}
-void fir::factory::genReallocIfNeeded(fir::FirOpBuilder &builder,
- mlir::Location loc,
- const fir::MutableBoxValue &box,
- mlir::ValueRange lbounds,
- mlir::ValueRange shape,
- mlir::ValueRange lengthParams) {
+fir::factory::MutableBoxReallocation
+fir::factory::genReallocIfNeeded(fir::FirOpBuilder &builder, mlir::Location loc,
+ const fir::MutableBoxValue &box,
+ mlir::ValueRange shape,
+ mlir::ValueRange lengthParams) {
// Implement 10.2.1.3 point 3 logic when lhs is an array.
auto reader = MutablePropertyReader(builder, loc, box);
auto addr = reader.readBaseAddress();
+ auto i1Type = builder.getI1Type();
+ auto addrType = addr.getType();
auto isAllocated = builder.genIsNotNull(loc, addr);
- builder.genIfThenElse(loc, isAllocated)
+ auto ifOp =
+ builder
+ .genIfOp(loc, {i1Type, addrType}, isAllocated,
+ /*withElseRegion=*/true)
+ .genThen([&]() {
+ // The box is allocated. Check if it must be reallocated and
+ // reallocate.
+ auto mustReallocate = builder.createBool(loc, false);
+ auto compareProperty = [&](mlir::Value previous,
+ mlir::Value required) {
+ auto castPrevious =
+ builder.createConvert(loc, required.getType(), previous);
+ auto cmp = builder.create<mlir::arith::CmpIOp>(
+ loc, mlir::arith::CmpIPredicate::ne, castPrevious, required);
+ mustReallocate = builder.create<mlir::arith::SelectOp>(
+ loc, cmp, cmp, mustReallocate);
+ };
+ llvm::SmallVector<mlir::Value> previousExtents = reader.readShape();
+ if (!shape.empty())
+ for (auto [previousExtent, requested] :
+ llvm::zip(previousExtents, shape))
+ compareProperty(previousExtent, requested);
+
+ if (box.isCharacter() && !box.hasNonDeferredLenParams()) {
+ // When the allocatable length is not deferred, it must not be
+ // reallocated in case of length mismatch, instead,
+ // padding/trimming will occur in later assignment to it.
+ assert(!lengthParams.empty() &&
+ "must provide length parameters for character");
+ compareProperty(reader.readCharacterLength(), lengthParams[0]);
+ } else if (box.isDerivedWithLengthParameters()) {
+ TODO(loc, "automatic allocation of derived type allocatable with "
+ "length parameters");
+ }
+ auto ifOp =
+ builder
+ .genIfOp(loc, {addrType}, mustReallocate,
+ /*withElseRegion=*/true)
+ .genThen([&]() {
+ // If shape or length mismatch, allocate new storage.
+ // When rhs is a scalar, keep the previous shape
+ auto extents = shape.empty()
+ ? mlir::ValueRange(previousExtents)
+ : shape;
+ auto heap = allocateAndInitNewStorage(
+ builder, loc, box, extents, lengthParams,
+ ".auto.alloc");
+ builder.create<fir::ResultOp>(loc, heap);
+ })
+ .genElse(
+ [&]() { builder.create<fir::ResultOp>(loc, addr); });
+ ifOp.end();
+ auto newAddr = ifOp.getResults()[0];
+ builder.create<fir::ResultOp>(
+ loc, mlir::ValueRange{mustReallocate, newAddr});
+ })
+ .genElse([&]() {
+ auto trueValue = builder.createBool(loc, true);
+ // The box is not yet allocated, simply allocate it.
+ if (shape.empty() && box.rank() != 0) {
+ // See 10.2.1.3 p3.
+ fir::runtime::genReportFatalUserError(
+ builder, loc,
+ "array left hand side must be allocated when the right hand "
+ "side is a scalar");
+ builder.create<fir::ResultOp>(loc,
+ mlir::ValueRange{trueValue, addr});
+ } else {
+ auto heap = allocateAndInitNewStorage(
+ builder, loc, box, shape, lengthParams, ".auto.alloc");
+ builder.create<fir::ResultOp>(loc,
+ mlir::ValueRange{trueValue, heap});
+ }
+ });
+ ifOp.end();
+ auto wasReallocated = ifOp.getResults()[0];
+ auto newAddr = ifOp.getResults()[1];
+ // Create an ExtentedValue for the new storage.
+ auto newValue = [&]() -> fir::ExtendedValue {
+ mlir::SmallVector<mlir::Value> extents;
+ if (box.hasRank()) {
+ if (shape.empty())
+ extents = reader.readShape();
+ else
+ extents.append(shape.begin(), shape.end());
+ }
+ if (box.isCharacter()) {
+ auto len = box.hasNonDeferredLenParams() ? reader.readCharacterLength()
+ : lengthParams[0];
+ if (box.hasRank())
+ return fir::CharArrayBoxValue{newAddr, len, extents};
+ return fir::CharBoxValue{newAddr, len};
+ }
+ if (box.isDerivedWithLengthParameters())
+ TODO(loc, "reallocation of derived type entities with length parameters");
+ if (box.hasRank())
+ return fir::ArrayBoxValue{newAddr, extents};
+ return newAddr;
+ }();
+ return {newValue, addr, wasReallocated, isAllocated};
+}
+
+void fir::factory::finalizeRealloc(fir::FirOpBuilder &builder,
+ mlir::Location loc,
+ const fir::MutableBoxValue &box,
+ mlir::ValueRange lbounds,
+ bool takeLboundsIfRealloc,
+ const MutableBoxReallocation &realloc) {
+ builder.genIfThen(loc, realloc.wasReallocated)
.genThen([&]() {
- // The box is allocated. Check if it must be reallocated and reallocate.
- mlir::Value mustReallocate = builder.createBool(loc, false);
- auto compareProperty = [&](mlir::Value previous, mlir::Value required) {
- auto castPrevious =
- builder.createConvert(loc, required.getType(), previous);
- // reallocate = reallocate || previous != required
- auto cmp = builder.create<arith::CmpIOp>(
- loc, arith::CmpIPredicate::ne, castPrevious, required);
- mustReallocate = builder.create<mlir::arith::SelectOp>(
- loc, cmp, cmp, mustReallocate);
- };
+ auto reader = MutablePropertyReader(builder, loc, box);
llvm::SmallVector<mlir::Value> previousLbounds;
- llvm::SmallVector<mlir::Value> previousExtents =
- reader.readShape(&previousLbounds);
- if (!shape.empty())
- for (auto [previousExtent, requested] :
- llvm::zip(previousExtents, shape))
- compareProperty(previousExtent, requested);
-
- if (box.isCharacter() && !box.hasNonDeferredLenParams()) {
- // When the allocatable length is not deferred, it must not be
- // reallocated in case of length mismatch, instead, padding/trimming
- // will ocur in later assignment to it.
- assert(!lengthParams.empty() &&
- "must provide length parameters for character");
- compareProperty(reader.readCharacterLength(), lengthParams[0]);
- } else if (box.isDerivedWithLengthParameters()) {
+ if (!takeLboundsIfRealloc && box.hasRank())
+ reader.readShape(&previousLbounds);
+ auto lbs =
+ takeLboundsIfRealloc ? lbounds : mlir::ValueRange{previousLbounds};
+ llvm::SmallVector<mlir::Value> lenParams;
+ if (box.isCharacter())
+ lenParams.push_back(fir::getLen(realloc.newValue));
+ if (box.isDerivedWithLengthParameters())
TODO(loc,
- "automatic allocation of derived type allocatable with length "
- "parameters");
- }
- builder.genIfThen(loc, mustReallocate)
- .genThen([&]() {
- // If shape or length mismatch, deallocate and reallocate.
- genFinalizeAndFree(builder, loc, addr);
- // When rhs is a scalar, keep the previous shape
- auto extents =
- shape.empty() ? mlir::ValueRange(previousExtents) : shape;
- auto lbs =
- shape.empty() ? mlir::ValueRange(previousLbounds) : lbounds;
- genInlinedAllocation(builder, loc, box, lbs, extents,
- lengthParams, ".auto.alloc");
- })
+ "reallocation of derived type entities with length parameters");
+ auto lengths = getNewLengths(builder, loc, box, lenParams);
+ auto heap = fir::getBase(realloc.newValue);
+ auto extents = fir::factory::getExtents(builder, loc, realloc.newValue);
+ builder.genIfThen(loc, realloc.oldAddressWasAllocated)
+ .genThen(
+ [&]() { genFinalizeAndFree(builder, loc, realloc.oldAddress); })
.end();
- })
- .genElse([&]() {
- // The box is not yet allocated, simply allocate it.
- if (shape.empty() && box.rank() != 0) {
- // TODO:
- // runtime error: right hand side must be allocated if right hand
- // side is a scalar and the box is an array.
- } else {
- genInlinedAllocation(builder, loc, box, lbounds, shape, lengthParams,
- ".auto.alloc");
- }
+ MutablePropertyWriter{builder, loc, box}.updateMutableBox(
+ heap, lbs, extents, lengths);
})
.end();
}
diff --git a/flang/lib/Optimizer/Builder/Runtime/Stop.cpp b/flang/lib/Optimizer/Builder/Runtime/Stop.cpp
index 4d1826c9669e8..588363029abc2 100644
--- a/flang/lib/Optimizer/Builder/Runtime/Stop.cpp
+++ b/flang/lib/Optimizer/Builder/Runtime/Stop.cpp
@@ -7,6 +7,7 @@
//===----------------------------------------------------------------------===//
#include "flang/Optimizer/Builder/Runtime/Stop.h"
+#include "flang/Optimizer/Builder/BoxValue.h"
#include "flang/Optimizer/Builder/FIRBuilder.h"
#include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
#include "flang/Runtime/stop.h"
@@ -20,3 +21,19 @@ void fir::runtime::genExit(fir::FirOpBuilder &builder, mlir::Location loc,
fir::runtime::createArguments(builder, loc, exitFunc.getType(), status);
builder.create<fir::CallOp>(loc, exitFunc, args);
}
+
+void fir::runtime::genReportFatalUserError(fir::FirOpBuilder &builder,
+ mlir::Location loc,
+ llvm::StringRef message) {
+ mlir::FuncOp crashFunc =
+ fir::runtime::getRuntimeFunc<mkRTKey(ReportFatalUserError)>(loc, builder);
+ mlir::FunctionType funcTy = crashFunc.getType();
+ mlir::Value msgVal = fir::getBase(
+ fir::factory::createStringLiteral(builder, loc, message.str() + '\0'));
+ mlir::Value sourceLine =
+ fir::factory::locationToLineNo(builder, loc, funcTy.getInput(2));
+ mlir::Value sourceFile = fir::factory::locationToFilename(builder, loc);
+ llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
+ builder, loc, funcTy, msgVal, sourceFile, sourceLine);
+ builder.create<fir::CallOp>(loc, crashFunc, args);
+}
diff --git a/flang/test/Lower/allocatable-assignment.f90 b/flang/test/Lower/allocatable-assignment.f90
new file mode 100644
index 0000000000000..94a21ca82f864
--- /dev/null
+++ b/flang/test/Lower/allocatable-assignment.f90
@@ -0,0 +1,76 @@
+! Test allocatable assignments
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! -----------------------------------------------------------------------------
+! Test simple scalar RHS
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func @_QPtest_simple_scalar(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<f32>>>{{.*}}) {
+subroutine test_simple_scalar(x)
+ real, allocatable :: x
+! CHECK: %[[VAL_1:.*]] = arith.constant 4.200000e+01 : f32
+! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<f32>>>
+! CHECK: %[[VAL_3:.*]] = fir.box_addr %[[VAL_2]] : (!fir.box<!fir.heap<f32>>) -> !fir.heap<f32>
+! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.heap<f32>) -> i64
+! CHECK: %[[VAL_5:.*]] = arith.constant 0 : i64
+! CHECK: %[[VAL_6:.*]] = arith.cmpi ne, %[[VAL_4]], %[[VAL_5]] : i64
+! CHECK: %[[VAL_7:.*]]:2 = fir.if %[[VAL_6]] -> (i1, !fir.heap<f32>) {
+! CHECK: %[[VAL_8:.*]] = arith.constant false
+! CHECK: %[[VAL_9:.*]] = fir.if %[[VAL_8]] -> (!fir.heap<f32>) {
+! CHECK: %[[VAL_10:.*]] = fir.allocmem f32 {uniq_name = ".auto.alloc"}
+! CHECK: fir.result %[[VAL_10]] : !fir.heap<f32>
+! CHECK: } else {
+! CHECK: fir.result %[[VAL_3]] : !fir.heap<f32>
+! CHECK: }
+! CHECK: fir.result %[[VAL_8]], %[[VAL_11:.*]] : i1, !fir.heap<f32>
+! CHECK: } else {
+! CHECK: %[[VAL_12:.*]] = arith.constant true
+! CHECK: %[[VAL_13:.*]] = fir.allocmem f32 {uniq_name = ".auto.alloc"}
+! CHECK: fir.result %[[VAL_12]], %[[VAL_13]] : i1, !fir.heap<f32>
+! CHECK: }
+! CHECK: fir.store %[[VAL_1]] to %[[VAL_14:.*]]#1 : !fir.heap<f32>
+! CHECK: fir.if %[[VAL_14]]#0 {
+! CHECK: fir.if %[[VAL_6]] {
+! CHECK: fir.freemem %[[VAL_3]]
+! CHECK: }
+! CHECK: %[[VAL_15:.*]] = fir.embox %[[VAL_14]]#1 : (!fir.heap<f32>) -> !fir.box<!fir.heap<f32>>
+! CHECK: fir.store %[[VAL_15]] to %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<f32>>>
+! CHECK: }
+ x = 42.
+end subroutine
+
+! CHECK-LABEL: func @_QPtest_simple_local_scalar() {
+subroutine test_simple_local_scalar()
+ real, allocatable :: x
+! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.heap<f32> {uniq_name = "_QFtest_simple_local_scalarEx.addr"}
+! CHECK: %[[VAL_2:.*]] = fir.zero_bits !fir.heap<f32>
+! CHECK: fir.store %[[VAL_2]] to %[[VAL_1]] : !fir.ref<!fir.heap<f32>>
+! CHECK: %[[VAL_3:.*]] = arith.constant 4.200000e+01 : f32
+! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_1]] : !fir.ref<!fir.heap<f32>>
+! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.heap<f32>) -> i64
+! CHECK: %[[VAL_6:.*]] = arith.constant 0 : i64
+! CHECK: %[[VAL_7:.*]] = arith.cmpi ne, %[[VAL_5]], %[[VAL_6]] : i64
+! CHECK: %[[VAL_8:.*]]:2 = fir.if %[[VAL_7]] -> (i1, !fir.heap<f32>) {
+! CHECK: %[[VAL_9:.*]] = arith.constant false
+! CHECK: %[[VAL_10:.*]] = fir.if %[[VAL_9]] -> (!fir.heap<f32>) {
+! CHECK: %[[VAL_11:.*]] = fir.allocmem f32 {uniq_name = ".auto.alloc"}
+! CHECK: fir.result %[[VAL_11]] : !fir.heap<f32>
+! CHECK: } else {
+! CHECK: fir.result %[[VAL_4]] : !fir.heap<f32>
+! CHECK: }
+! CHECK: fir.result %[[VAL_9]], %[[VAL_12:.*]] : i1, !fir.heap<f32>
+! CHECK: } else {
+! CHECK: %[[VAL_13:.*]] = arith.constant true
+! CHECK: %[[VAL_14:.*]] = fir.allocmem f32 {uniq_name = ".auto.alloc"}
+! CHECK: fir.result %[[VAL_13]], %[[VAL_14]] : i1, !fir.heap<f32>
+! CHECK: }
+! CHECK: fir.store %[[VAL_3]] to %[[VAL_15:.*]]#1 : !fir.heap<f32>
+! CHECK: fir.if %[[VAL_15]]#0 {
+! CHECK: fir.if %[[VAL_7]] {
+! CHECK: fir.freemem %[[VAL_4]]
+! CHECK: }
+! CHECK: fir.store %[[VAL_15]]#1 to %[[VAL_1]] : !fir.ref<!fir.heap<f32>>
+! CHECK: }
+ x = 42.
+end subroutine
More information about the flang-commits
mailing list