diff --git a/flang/include/flang/Lower/AbstractConverter.h b/flang/include/flang/Lower/AbstractConverter.h --- a/flang/include/flang/Lower/AbstractConverter.h +++ b/flang/include/flang/Lower/AbstractConverter.h @@ -99,6 +99,12 @@ 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 --- /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 --- /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 &&lens) + : ScalarSym{sym}, lens{std::move(lens)} {} + +private: + llvm::SmallVector 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 charLen() const { + if (auto *l = std::get_if(&len)) + return {*l}; + return llvm::None; + } + + static constexpr bool staticSize() { return false; } + static constexpr bool isChar() { return true; } + +private: + std::variant len; +}; + +/// Scalar of dependent type Derived, dynamic LEN(s). +struct ScalarDynamicDerived : ScalarSym { + ScalarDynamicDerived(const Fortran::semantics::Symbol &sym, + llvm::SmallVectorImpl &&lens) + : ScalarSym{sym}, lens{std::move(lens)} {} + +private: + llvm::SmallVector lens; +}; + +struct LBoundsAndShape { + LBoundsAndShape(llvm::SmallVectorImpl &&lbounds, + llvm::SmallVectorImpl &&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 lbounds; + llvm::SmallVector shapes; +}; + +/// Array of T with statically known origin (lbounds) and shape. +struct StaticArray : ScalarSym, LBoundsAndShape { + StaticArray(const Fortran::semantics::Symbol &sym, + llvm::SmallVectorImpl &&lbounds, + llvm::SmallVectorImpl &&shapes) + : ScalarSym{sym}, LBoundsAndShape{std::move(lbounds), std::move(shapes)} { + } + + static constexpr bool staticSize() { return LBoundsAndShape::staticSize(); } +}; + +struct DynamicBound { + DynamicBound( + llvm::SmallVectorImpl &&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 bounds; +}; + +/// Array of T with dynamic origin and/or shape. +struct DynamicArray : ScalarSym, DynamicBound { + DynamicArray( + const Fortran::semantics::Symbol &sym, + llvm::SmallVectorImpl &&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 &&lbounds, + llvm::SmallVectorImpl &&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 &&lbounds, + llvm::SmallVectorImpl &&shapes) + : ScalarDynamicChar{sym, len}, LBoundsAndShape{std::move(lbounds), + std::move(shapes)} {} + StaticArrayDynamicChar(const Fortran::semantics::Symbol &sym, + llvm::SmallVectorImpl &&lbounds, + llvm::SmallVectorImpl &&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 &&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 &&bounds) + : ScalarDynamicChar{sym, len}, DynamicBound{std::move(bounds)} {} + DynamicArrayDynamicChar( + const Fortran::semantics::Symbol &sym, + llvm::SmallVectorImpl &&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(); + return det && det->IsArray(); +} + +inline bool isExplicitShape(const Fortran::semantics::Symbol &sym) { + const auto *det = + sym.GetUltimate().detailsIf(); + 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 { +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; + + //===--------------------------------------------------------------------===// + // Constructor + //===--------------------------------------------------------------------===// + + BoxAnalyzer() : box{None{}} {} + + operator bool() const { return !std::holds_alternative(box); } + + bool isTrivial() const { return std::holds_alternative(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 getCharLenConst() const { + using A = llvm::Optional; + 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 getCharLenExpr() const { + using A = llvm::Optional; + 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 staticLBound() const { + using A = llvm::ArrayRef; + 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 staticShape() const { + using A = llvm::ArrayRef; + 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 dynamicBound() const { + using A = llvm::ArrayRef; + 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 lbounds; + llvm::SmallVector shapes; + llvm::SmallVector 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 + 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 + 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() + .shape(); + } + + // Get the constant LEN of a CHARACTER, if it exists. + llvm::Optional + charLenConstant(const Fortran::semantics::Symbol &sym) { + if (llvm::Optional expr = charLenVariable(sym)) + if (std::optional 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 + 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()) + if (objectDetails->init()) + if (const auto *charExpr = std::get_if< + Fortran::evaluate::Expr>( + &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 --- a/flang/include/flang/Lower/ConvertExpr.h +++ b/flang/include/flang/Lower/ConvertExpr.h @@ -52,6 +52,12 @@ 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 --- 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 @@ 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 --- 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 @@ /// 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 --- 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 @@ /// 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 --- /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 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 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()) + 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()) + 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()) + eleTy = seqTy.getEleTy(); + if (auto record = eleTy.dyn_cast()) + 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 --- 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 @@ 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 @@ fir::ExtendedValue rhs = isNumericScalar ? genExprValue(assign.rhs, stmtCtx) : genExprAddr(assign.rhs, stmtCtx); + bool lhsIsWholeAllocatable = isWholeAllocatable(assign.lhs); + llvm::Optional lhsRealloc; + llvm::Optional lhsMutableBox; + auto lhs = [&]() -> fir::ExtendedValue { + if (lhsIsWholeAllocatable) { + lhsMutableBox = genExprMutableBox(loc, assign.lhs); + llvm::SmallVector lengthParams; + if (const fir::CharBoxValue *charBox = rhs.getCharBox()) + lengthParams.push_back(charBox->getLen()); + else if (fir::isDerivedWithLengthParameters(rhs)) + TODO(loc, "assignment to derived type allocatable with " + "length parameters"); + lhsRealloc = fir::factory::genReallocIfNeeded( + *builder, loc, *lhsMutableBox, + /*shape=*/llvm::None, lengthParams); + return lhsRealloc->newValue; + } + return genExprAddr(assign.lhs, stmtCtx); + }(); if (isNumericScalar) { // Fortran 2018 10.2.1.3 p8 and p9 // Conversions should have been inserted by semantic analysis, // but they can be incorrect between the rhs and lhs. Correct // that here. - mlir::Value addr = - fir::getBase(genExprAddr(assign.lhs, stmtCtx)); + mlir::Value addr = fir::getBase(lhs); mlir::Value val = fir::getBase(rhs); // A function with multiple entry points returning different // types tags all result variables with one of the largest @@ -550,6 +575,11 @@ } 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 --- 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 --- a/flang/lib/Lower/ConvertExpr.cpp +++ b/flang/lib/Lower/ConvertExpr.cpp @@ -174,6 +174,62 @@ 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(); + if (!mutableBox) + fir::emitFatalError(getLoc(), "expr was not lowered to MutableBoxValue"); + return *mutableBox; + } + + template + ExtValue genMutableBoxValueImpl(const T &) { + // NULL() case should not be handled here. + fir::emitFatalError(getLoc(), "NULL() must be lowered in its context"); + } + + template + ExtValue + genMutableBoxValueImpl(const Fortran::evaluate::FunctionRef &funRef) { + return genRawProcedureRef(funRef, converter.genType(toEvExpr(funRef))); + } + + template + ExtValue + genMutableBoxValueImpl(const Fortran::evaluate::Designator &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 + ExtValue genMutableBoxValueImpl(const Fortran::evaluate::Expr &expr) { + return std::visit([&](const auto &x) { return genMutableBoxValueImpl(x); }, + expr.u); + } + mlir::Location getLoc() { return location; } template @@ -1235,6 +1291,19 @@ 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 --- 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 @@ 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()) + 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 - + 1` case. + auto diff = builder.create(loc, idxTy, ub, lb); + mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1); + return builder.create(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 &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 lowerBounds, + llvm::SmallVectorImpl &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(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(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 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 lbounds; + llvm::SmallVector extents; + llvm::SmallVector 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 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 extents; + llvm::SmallVector 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 --- 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()) + // 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(loc, shapeType, extents); + } else { + llvm::SmallVector shapeShiftBounds; + for (auto [lb, extent] : llvm::zip(lbounds, extents)) { + shapeShiftBounds.emplace_back(lb); + shapeShiftBounds.emplace_back(extent); + } + auto shapeShiftType = + fir::ShapeShiftType::get(builder.getContext(), extents.size()); + shape = builder.create(loc, shapeShiftType, + shapeShiftBounds); + } + } // 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 cleanedLengths; + auto cleanedAddr = addr; + if (auto charTy = box.getEleTy().dyn_cast()) { + // Cast address to box type so that both input and output type have + // unknown or constant lengths. + auto bt = box.getBaseTy(); + auto addrTy = addr.getType(); + auto type = addrTy.isa() ? fir::HeapType::get(bt) + : addrTy.isa() ? fir::PointerType::get(bt) + : builder.getRefType(bt); + cleanedAddr = builder.createConvert(loc, type, addr); + if (charTy.getLen() == fir::CharacterType::unknownLen()) + cleanedLengths.append(lengths.begin(), lengths.end()); + } else if (box.isDerivedWithLengthParameters()) { + TODO(loc, "updating mutablebox of derived type with length parameters"); + cleanedLengths = lengths; + } + mlir::Value emptySlice; + return builder.create(loc, box.getBoxTy(), cleanedAddr, shape, + emptySlice, cleanedLengths); +} + //===----------------------------------------------------------------------===// // MutableBoxValue writer and reader //===----------------------------------------------------------------------===// @@ -618,6 +675,47 @@ MutablePropertyWriter{builder, loc, box}.setUnallocatedStatus(); } +static llvm::SmallVector +getNewLengths(fir::FirOpBuilder &builder, mlir::Location loc, + const fir::MutableBoxValue &box, mlir::ValueRange lenParams) { + llvm::SmallVector lengths; + auto idxTy = builder.getIndexType(); + if (auto charTy = box.getEleTy().dyn_cast()) { + if (charTy.getLen() == fir::CharacterType::unknownLen()) { + if (box.hasNonDeferredLenParams()) + lengths.emplace_back( + builder.createConvert(loc, idxTy, box.nonDeferredLenParams()[0])); + else if (!lenParams.empty()) + lengths.emplace_back(builder.createConvert(loc, idxTy, lenParams[0])); + else + fir::emitFatalError( + loc, "could not deduce character lengths in character allocation"); + } + } + 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( + loc, box.getBaseTy(), allocName, lengths, extents); + if (box.getEleTy().isa()) { + // TODO: skip runtime initialization if this is not required. Currently, + // there is no way to know here if a derived type needs it or not. But the + // information is available at compile time and could be reflected here + // somehow. + mlir::Value irBox = 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 @@ 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( + loc, mlir::arith::CmpIPredicate::ne, castPrevious, required); + mustReallocate = builder.create( + loc, cmp, cmp, mustReallocate); + }; + llvm::SmallVector 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(loc, heap); + }) + .genElse( + [&]() { builder.create(loc, addr); }); + ifOp.end(); + auto newAddr = ifOp.getResults()[0]; + builder.create( + 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(loc, + mlir::ValueRange{trueValue, addr}); + } else { + auto heap = allocateAndInitNewStorage( + builder, loc, box, shape, lengthParams, ".auto.alloc"); + builder.create(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 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( - loc, arith::CmpIPredicate::ne, castPrevious, required); - mustReallocate = builder.create( - loc, cmp, cmp, mustReallocate); - }; + auto reader = MutablePropertyReader(builder, loc, box); llvm::SmallVector previousLbounds; - llvm::SmallVector 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 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 --- 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 @@ fir::runtime::createArguments(builder, loc, exitFunc.getType(), status); builder.create(loc, exitFunc, args); } + +void fir::runtime::genReportFatalUserError(fir::FirOpBuilder &builder, + mlir::Location loc, + llvm::StringRef message) { + mlir::FuncOp crashFunc = + fir::runtime::getRuntimeFunc(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 args = fir::runtime::createArguments( + builder, loc, funcTy, msgVal, sourceFile, sourceLine); + builder.create(loc, crashFunc, args); +} diff --git a/flang/test/Lower/allocatable-assignment.f90 b/flang/test/Lower/allocatable-assignment.f90 new file mode 100644 --- /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>>{{.*}}) { +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>> +! CHECK: %[[VAL_3:.*]] = fir.box_addr %[[VAL_2]] : (!fir.box>) -> !fir.heap +! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.heap) -> i64 +! CHECK: %[[VAL_5:.*]] = arith.constant 0 : i64 +! CHECK: %[[VAL_6:.*]] = arith.cmpi ne, %[[VAL_4]], %[[VAL_5]] : i64 +! CHECK: %[[VAL_7:.*]]:2 = fir.if %[[VAL_6]] -> (i1, !fir.heap) { +! CHECK: %[[VAL_8:.*]] = arith.constant false +! CHECK: %[[VAL_9:.*]] = fir.if %[[VAL_8]] -> (!fir.heap) { +! CHECK: %[[VAL_10:.*]] = fir.allocmem f32 {uniq_name = ".auto.alloc"} +! CHECK: fir.result %[[VAL_10]] : !fir.heap +! CHECK: } else { +! CHECK: fir.result %[[VAL_3]] : !fir.heap +! CHECK: } +! CHECK: fir.result %[[VAL_8]], %[[VAL_11:.*]] : i1, !fir.heap +! CHECK: } else { +! CHECK: %[[VAL_12:.*]] = arith.constant true +! CHECK: %[[VAL_13:.*]] = fir.allocmem f32 {uniq_name = ".auto.alloc"} +! CHECK: fir.result %[[VAL_12]], %[[VAL_13]] : i1, !fir.heap +! CHECK: } +! CHECK: fir.store %[[VAL_1]] to %[[VAL_14:.*]]#1 : !fir.heap +! 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) -> !fir.box> +! CHECK: fir.store %[[VAL_15]] to %[[VAL_0]] : !fir.ref>> +! 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 {uniq_name = "_QFtest_simple_local_scalarEx.addr"} +! CHECK: %[[VAL_2:.*]] = fir.zero_bits !fir.heap +! CHECK: fir.store %[[VAL_2]] to %[[VAL_1]] : !fir.ref> +! CHECK: %[[VAL_3:.*]] = arith.constant 4.200000e+01 : f32 +! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_1]] : !fir.ref> +! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.heap) -> 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) { +! CHECK: %[[VAL_9:.*]] = arith.constant false +! CHECK: %[[VAL_10:.*]] = fir.if %[[VAL_9]] -> (!fir.heap) { +! CHECK: %[[VAL_11:.*]] = fir.allocmem f32 {uniq_name = ".auto.alloc"} +! CHECK: fir.result %[[VAL_11]] : !fir.heap +! CHECK: } else { +! CHECK: fir.result %[[VAL_4]] : !fir.heap +! CHECK: } +! CHECK: fir.result %[[VAL_9]], %[[VAL_12:.*]] : i1, !fir.heap +! 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 +! CHECK: } +! CHECK: fir.store %[[VAL_3]] to %[[VAL_15:.*]]#1 : !fir.heap +! 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> +! CHECK: } + x = 42. +end subroutine