[flang-commits] [flang] c5cf1b9 - [flang] Lower allocate and deallocate statements
Valentin Clement via flang-commits
flang-commits at lists.llvm.org
Mon Mar 7 12:47:40 PST 2022
Author: Valentin Clement
Date: 2022-03-07T21:47:28+01:00
New Revision: c5cf1b903409e491d7599809dc18187363d7be21
URL: https://github.com/llvm/llvm-project/commit/c5cf1b903409e491d7599809dc18187363d7be21
DIFF: https://github.com/llvm/llvm-project/commit/c5cf1b903409e491d7599809dc18187363d7be21.diff
LOG: [flang] Lower allocate and deallocate statements
This patch add the lowering for the allocate
and the deallocate statements.
This patch is part of the upstreaming effort from fir-dev branch.
Reviewed By: PeteSteinfeld
Differential Revision: https://reviews.llvm.org/D121146
Co-authored-by: Eric Schweitz <eschweitz at nvidia.com>
Co-authored-by: Jean Perier <jperier at nvidia.com>
Co-authored-by: V Donaldson <vdonaldson at nvidia.com>
Added:
flang/test/Lower/allocatables.f90
Modified:
flang/include/flang/Lower/Allocatable.h
flang/lib/Lower/Allocatable.cpp
flang/lib/Lower/Bridge.cpp
Removed:
################################################################################
diff --git a/flang/include/flang/Lower/Allocatable.h b/flang/include/flang/Lower/Allocatable.h
index 1bb23feb84f17..24eafeb92a97e 100644
--- a/flang/include/flang/Lower/Allocatable.h
+++ b/flang/include/flang/Lower/Allocatable.h
@@ -26,6 +26,11 @@ namespace fir {
class MutableBoxValue;
} // namespace fir
+namespace Fortran::parser {
+struct AllocateStmt;
+struct DeallocateStmt;
+} // namespace Fortran::parser
+
namespace Fortran::lower {
class AbstractConverter;
@@ -33,6 +38,14 @@ namespace pft {
struct Variable;
}
+/// Lower an allocate statement to fir.
+void genAllocateStmt(Fortran::lower::AbstractConverter &,
+ const Fortran::parser::AllocateStmt &, mlir::Location);
+
+/// Lower a deallocate statement to fir.
+void genDeallocateStmt(Fortran::lower::AbstractConverter &,
+ const Fortran::parser::DeallocateStmt &, mlir::Location);
+
/// 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.
diff --git a/flang/lib/Lower/Allocatable.cpp b/flang/lib/Lower/Allocatable.cpp
index e56b8f5f10c0d..b852c249ba996 100644
--- a/flang/lib/Lower/Allocatable.cpp
+++ b/flang/lib/Lower/Allocatable.cpp
@@ -23,6 +23,8 @@
#include "flang/Optimizer/Dialect/FIROpsSupport.h"
#include "flang/Optimizer/Support/FatalError.h"
#include "flang/Parser/parse-tree.h"
+#include "flang/Runtime/allocatable.h"
+#include "flang/Runtime/pointer.h"
#include "flang/Semantics/tools.h"
#include "flang/Semantics/type.h"
#include "llvm/Support/CommandLine.h"
@@ -41,6 +43,516 @@ static llvm::cl::opt<bool> useDescForMutableBox(
llvm::cl::desc("Always use descriptors for POINTER and ALLOCATABLE"),
llvm::cl::init(false));
+//===----------------------------------------------------------------------===//
+// Error management
+//===----------------------------------------------------------------------===//
+
+namespace {
+// Manage STAT and ERRMSG specifier information across a sequence of runtime
+// calls for an ALLOCATE/DEALLOCATE stmt.
+struct ErrorManager {
+ void init(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ const Fortran::lower::SomeExpr *statExpr,
+ const Fortran::lower::SomeExpr *errMsgExpr) {
+ Fortran::lower::StatementContext stmtCtx;
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ hasStat = builder.createBool(loc, statExpr != nullptr);
+ statAddr = statExpr
+ ? fir::getBase(converter.genExprAddr(statExpr, stmtCtx, loc))
+ : mlir::Value{};
+ errMsgAddr =
+ statExpr && errMsgExpr
+ ? builder.createBox(loc,
+ converter.genExprAddr(errMsgExpr, stmtCtx, loc))
+ : builder.create<fir::AbsentOp>(
+ loc,
+ fir::BoxType::get(mlir::NoneType::get(builder.getContext())));
+ sourceFile = fir::factory::locationToFilename(builder, loc);
+ sourceLine = fir::factory::locationToLineNo(builder, loc,
+ builder.getIntegerType(32));
+ }
+
+ bool hasStatSpec() const { return static_cast<bool>(statAddr); }
+
+ void genStatCheck(fir::FirOpBuilder &builder, mlir::Location loc) {
+ if (statValue) {
+ mlir::Value zero =
+ builder.createIntegerConstant(loc, statValue.getType(), 0);
+ auto cmp = builder.create<mlir::arith::CmpIOp>(
+ loc, mlir::arith::CmpIPredicate::eq, statValue, zero);
+ auto ifOp = builder.create<fir::IfOp>(loc, cmp,
+ /*withElseRegion=*/false);
+ builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
+ }
+ }
+
+ void assignStat(fir::FirOpBuilder &builder, mlir::Location loc,
+ mlir::Value stat) {
+ if (hasStatSpec()) {
+ assert(stat && "missing stat value");
+ mlir::Value castStat = builder.createConvert(
+ loc, fir::dyn_cast_ptrEleTy(statAddr.getType()), stat);
+ builder.create<fir::StoreOp>(loc, castStat, statAddr);
+ statValue = stat;
+ }
+ }
+
+ mlir::Value hasStat;
+ mlir::Value errMsgAddr;
+ mlir::Value sourceFile;
+ mlir::Value sourceLine;
+
+private:
+ mlir::Value statAddr; // STAT variable address
+ mlir::Value statValue; // current runtime STAT value
+};
+
+//===----------------------------------------------------------------------===//
+// Allocatables runtime call generators
+//===----------------------------------------------------------------------===//
+
+using namespace Fortran::runtime;
+/// Generate a runtime call to set the bounds of an allocatable or pointer
+/// descriptor.
+static void genRuntimeSetBounds(fir::FirOpBuilder &builder, mlir::Location loc,
+ const fir::MutableBoxValue &box,
+ mlir::Value dimIndex, mlir::Value lowerBound,
+ mlir::Value upperBound) {
+ mlir::FuncOp callee =
+ box.isPointer()
+ ? fir::runtime::getRuntimeFunc<mkRTKey(PointerSetBounds)>(loc,
+ builder)
+ : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableSetBounds)>(
+ loc, builder);
+ llvm::SmallVector<mlir::Value> args{box.getAddr(), dimIndex, lowerBound,
+ upperBound};
+ llvm::SmallVector<mlir::Value> operands;
+ for (auto [fst, snd] : llvm::zip(args, callee.getType().getInputs()))
+ operands.emplace_back(builder.createConvert(loc, snd, fst));
+ builder.create<fir::CallOp>(loc, callee, operands);
+}
+
+/// Generate runtime call to set the lengths of a character allocatable or
+/// pointer descriptor.
+static void genRuntimeInitCharacter(fir::FirOpBuilder &builder,
+ mlir::Location loc,
+ const fir::MutableBoxValue &box,
+ mlir::Value len) {
+ mlir::FuncOp callee =
+ box.isPointer()
+ ? fir::runtime::getRuntimeFunc<mkRTKey(PointerNullifyCharacter)>(
+ loc, builder)
+ : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableInitCharacter)>(
+ loc, builder);
+ llvm::ArrayRef<mlir::Type> inputTypes = callee.getType().getInputs();
+ if (inputTypes.size() != 5)
+ fir::emitFatalError(
+ loc, "AllocatableInitCharacter runtime interface not as expected");
+ llvm::SmallVector<mlir::Value> args;
+ args.push_back(builder.createConvert(loc, inputTypes[0], box.getAddr()));
+ args.push_back(builder.createConvert(loc, inputTypes[1], len));
+ int kind = box.getEleTy().cast<fir::CharacterType>().getFKind();
+ args.push_back(builder.createIntegerConstant(loc, inputTypes[2], kind));
+ int rank = box.rank();
+ args.push_back(builder.createIntegerConstant(loc, inputTypes[3], rank));
+ // TODO: coarrays
+ int corank = 0;
+ args.push_back(builder.createIntegerConstant(loc, inputTypes[4], corank));
+ builder.create<fir::CallOp>(loc, callee, args);
+}
+
+/// Generate a sequence of runtime calls to allocate memory.
+static mlir::Value genRuntimeAllocate(fir::FirOpBuilder &builder,
+ mlir::Location loc,
+ const fir::MutableBoxValue &box,
+ ErrorManager &errorManager) {
+ mlir::FuncOp callee =
+ box.isPointer()
+ ? fir::runtime::getRuntimeFunc<mkRTKey(PointerAllocate)>(loc, builder)
+ : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableAllocate)>(loc,
+ builder);
+ llvm::SmallVector<mlir::Value> args{
+ box.getAddr(), errorManager.hasStat, errorManager.errMsgAddr,
+ errorManager.sourceFile, errorManager.sourceLine};
+ llvm::SmallVector<mlir::Value> operands;
+ for (auto [fst, snd] : llvm::zip(args, callee.getType().getInputs()))
+ operands.emplace_back(builder.createConvert(loc, snd, fst));
+ return builder.create<fir::CallOp>(loc, callee, operands).getResult(0);
+}
+
+/// Generate a runtime call to deallocate memory.
+static mlir::Value genRuntimeDeallocate(fir::FirOpBuilder &builder,
+ mlir::Location loc,
+ const fir::MutableBoxValue &box,
+ ErrorManager &errorManager) {
+ // Ensure fir.box is up-to-date before passing it to deallocate runtime.
+ mlir::Value boxAddress = fir::factory::getMutableIRBox(builder, loc, box);
+ mlir::FuncOp callee =
+ box.isPointer()
+ ? fir::runtime::getRuntimeFunc<mkRTKey(PointerDeallocate)>(loc,
+ builder)
+ : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableDeallocate)>(
+ loc, builder);
+ llvm::SmallVector<mlir::Value> args{
+ boxAddress, errorManager.hasStat, errorManager.errMsgAddr,
+ errorManager.sourceFile, errorManager.sourceLine};
+ llvm::SmallVector<mlir::Value> operands;
+ for (auto [fst, snd] : llvm::zip(args, callee.getType().getInputs()))
+ operands.emplace_back(builder.createConvert(loc, snd, fst));
+ return builder.create<fir::CallOp>(loc, callee, operands).getResult(0);
+}
+
+//===----------------------------------------------------------------------===//
+// Allocate statement implementation
+//===----------------------------------------------------------------------===//
+
+/// Helper to get symbol from AllocateObject.
+static const Fortran::semantics::Symbol &
+unwrapSymbol(const Fortran::parser::AllocateObject &allocObj) {
+ const Fortran::parser::Name &lastName =
+ Fortran::parser::GetLastName(allocObj);
+ assert(lastName.symbol);
+ return *lastName.symbol;
+}
+
+static fir::MutableBoxValue
+genMutableBoxValue(Fortran::lower::AbstractConverter &converter,
+ mlir::Location loc,
+ const Fortran::parser::AllocateObject &allocObj) {
+ const Fortran::lower::SomeExpr *expr = Fortran::semantics::GetExpr(allocObj);
+ assert(expr && "semantic analysis failure");
+ return converter.genExprMutableBox(loc, *expr);
+}
+
+/// Implement Allocate statement lowering.
+class AllocateStmtHelper {
+public:
+ AllocateStmtHelper(Fortran::lower::AbstractConverter &converter,
+ const Fortran::parser::AllocateStmt &stmt,
+ mlir::Location loc)
+ : converter{converter}, builder{converter.getFirOpBuilder()}, stmt{stmt},
+ loc{loc} {}
+
+ void lower() {
+ visitAllocateOptions();
+ lowerAllocateLengthParameters();
+ errorManager.init(converter, loc, statExpr, errMsgExpr);
+ if (sourceExpr || moldExpr)
+ TODO(loc, "lower MOLD/SOURCE expr in allocate");
+ mlir::OpBuilder::InsertPoint insertPt = builder.saveInsertionPoint();
+ for (const auto &allocation :
+ std::get<std::list<Fortran::parser::Allocation>>(stmt.t))
+ lowerAllocation(unwrapAllocation(allocation));
+ builder.restoreInsertionPoint(insertPt);
+ }
+
+private:
+ struct Allocation {
+ const Fortran::parser::Allocation &alloc;
+ const Fortran::semantics::DeclTypeSpec &type;
+ bool hasCoarraySpec() const {
+ return std::get<std::optional<Fortran::parser::AllocateCoarraySpec>>(
+ alloc.t)
+ .has_value();
+ }
+ const Fortran::parser::AllocateObject &getAllocObj() const {
+ return std::get<Fortran::parser::AllocateObject>(alloc.t);
+ }
+ const Fortran::semantics::Symbol &getSymbol() const {
+ return unwrapSymbol(getAllocObj());
+ }
+ const std::list<Fortran::parser::AllocateShapeSpec> &getShapeSpecs() const {
+ return std::get<std::list<Fortran::parser::AllocateShapeSpec>>(alloc.t);
+ }
+ };
+
+ Allocation unwrapAllocation(const Fortran::parser::Allocation &alloc) {
+ const auto &allocObj = std::get<Fortran::parser::AllocateObject>(alloc.t);
+ const Fortran::semantics::Symbol &symbol = unwrapSymbol(allocObj);
+ assert(symbol.GetType());
+ return Allocation{alloc, *symbol.GetType()};
+ }
+
+ void visitAllocateOptions() {
+ for (const auto &allocOption :
+ std::get<std::list<Fortran::parser::AllocOpt>>(stmt.t))
+ std::visit(
+ Fortran::common::visitors{
+ [&](const Fortran::parser::StatOrErrmsg &statOrErr) {
+ std::visit(
+ Fortran::common::visitors{
+ [&](const Fortran::parser::StatVariable &statVar) {
+ statExpr = Fortran::semantics::GetExpr(statVar);
+ },
+ [&](const Fortran::parser::MsgVariable &errMsgVar) {
+ errMsgExpr = Fortran::semantics::GetExpr(errMsgVar);
+ },
+ },
+ statOrErr.u);
+ },
+ [&](const Fortran::parser::AllocOpt::Source &source) {
+ sourceExpr = Fortran::semantics::GetExpr(source.v.value());
+ },
+ [&](const Fortran::parser::AllocOpt::Mold &mold) {
+ moldExpr = Fortran::semantics::GetExpr(mold.v.value());
+ },
+ },
+ allocOption.u);
+ }
+
+ void lowerAllocation(const Allocation &alloc) {
+ fir::MutableBoxValue boxAddr =
+ genMutableBoxValue(converter, loc, alloc.getAllocObj());
+ mlir::Value backupBox;
+
+ if (sourceExpr) {
+ genSourceAllocation(alloc, boxAddr);
+ } else if (moldExpr) {
+ genMoldAllocation(alloc, boxAddr);
+ } else {
+ genSimpleAllocation(alloc, boxAddr);
+ }
+ }
+
+ static bool lowerBoundsAreOnes(const Allocation &alloc) {
+ for (const Fortran::parser::AllocateShapeSpec &shapeSpec :
+ alloc.getShapeSpecs())
+ if (std::get<0>(shapeSpec.t))
+ return false;
+ return true;
+ }
+
+ /// Build name for the fir::allocmem generated for alloc.
+ std::string mangleAlloc(const Allocation &alloc) {
+ return converter.mangleName(alloc.getSymbol()) + ".alloc";
+ }
+
+ /// Generate allocation without runtime calls.
+ /// Only for intrinsic types. No coarrays, no polymorphism. No error recovery.
+ void genInlinedAllocation(const Allocation &alloc,
+ const fir::MutableBoxValue &box) {
+ llvm::SmallVector<mlir::Value> lbounds;
+ llvm::SmallVector<mlir::Value> extents;
+ Fortran::lower::StatementContext stmtCtx;
+ mlir::Type idxTy = builder.getIndexType();
+ bool lBoundsAreOnes = lowerBoundsAreOnes(alloc);
+ mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
+ for (const Fortran::parser::AllocateShapeSpec &shapeSpec :
+ alloc.getShapeSpecs()) {
+ mlir::Value lb;
+ if (!lBoundsAreOnes) {
+ if (const std::optional<Fortran::parser::BoundExpr> &lbExpr =
+ std::get<0>(shapeSpec.t)) {
+ lb = fir::getBase(converter.genExprValue(
+ Fortran::semantics::GetExpr(*lbExpr), stmtCtx, loc));
+ lb = builder.createConvert(loc, idxTy, lb);
+ } else {
+ lb = one;
+ }
+ lbounds.emplace_back(lb);
+ }
+ mlir::Value ub = fir::getBase(converter.genExprValue(
+ Fortran::semantics::GetExpr(std::get<1>(shapeSpec.t)), stmtCtx, loc));
+ ub = builder.createConvert(loc, idxTy, ub);
+ if (lb) {
+ mlir::Value
diff = builder.create<mlir::arith::SubIOp>(loc, ub, lb);
+ extents.emplace_back(
+ builder.create<mlir::arith::AddIOp>(loc,
diff , one));
+ } else {
+ extents.emplace_back(ub);
+ }
+ }
+ fir::factory::genInlinedAllocation(builder, loc, box, lbounds, extents,
+ lenParams, mangleAlloc(alloc));
+ }
+
+ void genSimpleAllocation(const Allocation &alloc,
+ const fir::MutableBoxValue &box) {
+ if (!box.isDerived() && !errorManager.hasStatSpec() &&
+ !alloc.type.IsPolymorphic() && !alloc.hasCoarraySpec() &&
+ !useAllocateRuntime) {
+ genInlinedAllocation(alloc, box);
+ return;
+ }
+ // Generate a sequence of runtime calls.
+ errorManager.genStatCheck(builder, loc);
+ if (box.isPointer()) {
+ // For pointers, the descriptor may still be uninitialized (see Fortran
+ // 2018 19.5.2.2). The allocation runtime needs to be given a descriptor
+ // with initialized rank, types and attributes. Initialize the descriptor
+ // here to ensure these constraints are fulfilled.
+ mlir::Value nullPointer = fir::factory::createUnallocatedBox(
+ builder, loc, box.getBoxTy(), box.nonDeferredLenParams());
+ builder.create<fir::StoreOp>(loc, nullPointer, box.getAddr());
+ } else {
+ assert(box.isAllocatable() && "must be an allocatable");
+ // For allocatables, sync the MutableBoxValue and descriptor before the
+ // calls in case it is tracked locally by a set of variables.
+ fir::factory::getMutableIRBox(builder, loc, box);
+ }
+ if (alloc.hasCoarraySpec())
+ TODO(loc, "coarray allocation");
+ if (alloc.type.IsPolymorphic())
+ genSetType(alloc, box);
+ genSetDeferredLengthParameters(alloc, box);
+ // Set bounds for arrays
+ mlir::Type idxTy = builder.getIndexType();
+ mlir::Type i32Ty = builder.getIntegerType(32);
+ Fortran::lower::StatementContext stmtCtx;
+ for (const auto &iter : llvm::enumerate(alloc.getShapeSpecs())) {
+ mlir::Value lb;
+ const auto &bounds = iter.value().t;
+ if (const std::optional<Fortran::parser::BoundExpr> &lbExpr =
+ std::get<0>(bounds))
+ lb = fir::getBase(converter.genExprValue(
+ Fortran::semantics::GetExpr(*lbExpr), stmtCtx, loc));
+ else
+ lb = builder.createIntegerConstant(loc, idxTy, 1);
+ mlir::Value ub = fir::getBase(converter.genExprValue(
+ Fortran::semantics::GetExpr(std::get<1>(bounds)), stmtCtx, loc));
+ mlir::Value dimIndex =
+ builder.createIntegerConstant(loc, i32Ty, iter.index());
+ // Runtime call
+ genRuntimeSetBounds(builder, loc, box, dimIndex, lb, ub);
+ }
+ mlir::Value stat = genRuntimeAllocate(builder, loc, box, errorManager);
+ fir::factory::syncMutableBoxFromIRBox(builder, loc, box);
+ errorManager.assignStat(builder, loc, stat);
+ }
+
+ /// Lower the length parameters that may be specified in the optional
+ /// type specification.
+ void lowerAllocateLengthParameters() {
+ const Fortran::semantics::DeclTypeSpec *typeSpec =
+ getIfAllocateStmtTypeSpec();
+ if (!typeSpec)
+ return;
+ if (const Fortran::semantics::DerivedTypeSpec *derived =
+ typeSpec->AsDerived())
+ if (Fortran::semantics::CountLenParameters(*derived) > 0)
+ TODO(loc, "TODO: setting derived type params in allocation");
+ if (typeSpec->category() ==
+ Fortran::semantics::DeclTypeSpec::Category::Character) {
+ Fortran::semantics::ParamValue lenParam =
+ typeSpec->characterTypeSpec().length();
+ if (Fortran::semantics::MaybeIntExpr intExpr = lenParam.GetExplicit()) {
+ Fortran::lower::StatementContext stmtCtx;
+ Fortran::lower::SomeExpr lenExpr{*intExpr};
+ lenParams.push_back(
+ fir::getBase(converter.genExprValue(lenExpr, stmtCtx, &loc)));
+ }
+ }
+ }
+
+ // Set length parameters in the box stored in boxAddr.
+ // This must be called before setting the bounds because it may use
+ // Init runtime calls that may set the bounds to zero.
+ void genSetDeferredLengthParameters(const Allocation &alloc,
+ const fir::MutableBoxValue &box) {
+ if (lenParams.empty())
+ return;
+ // TODO: in case a length parameter was not deferred, insert a runtime check
+ // that the length is the same (AllocatableCheckLengthParameter runtime
+ // call).
+ if (box.isCharacter())
+ genRuntimeInitCharacter(builder, loc, box, lenParams[0]);
+
+ if (box.isDerived())
+ TODO(loc, "derived type length parameters in allocate");
+ }
+
+ void genSourceAllocation(const Allocation &, const fir::MutableBoxValue &) {
+ TODO(loc, "SOURCE allocation lowering");
+ }
+ void genMoldAllocation(const Allocation &, const fir::MutableBoxValue &) {
+ TODO(loc, "MOLD allocation lowering");
+ }
+ void genSetType(const Allocation &, const fir::MutableBoxValue &) {
+ TODO(loc, "Polymorphic entity allocation lowering");
+ }
+
+ /// Returns a pointer to the DeclTypeSpec if a type-spec is provided in the
+ /// allocate statement. Returns a null pointer otherwise.
+ const Fortran::semantics::DeclTypeSpec *getIfAllocateStmtTypeSpec() const {
+ if (const auto &typeSpec =
+ std::get<std::optional<Fortran::parser::TypeSpec>>(stmt.t))
+ return typeSpec->declTypeSpec;
+ return nullptr;
+ }
+
+ Fortran::lower::AbstractConverter &converter;
+ fir::FirOpBuilder &builder;
+ const Fortran::parser::AllocateStmt &stmt;
+ const Fortran::lower::SomeExpr *sourceExpr{nullptr};
+ const Fortran::lower::SomeExpr *moldExpr{nullptr};
+ const Fortran::lower::SomeExpr *statExpr{nullptr};
+ const Fortran::lower::SomeExpr *errMsgExpr{nullptr};
+ // If the allocate has a type spec, lenParams contains the
+ // value of the length parameters that were specified inside.
+ llvm::SmallVector<mlir::Value> lenParams;
+ ErrorManager errorManager;
+
+ mlir::Location loc;
+};
+} // namespace
+
+void Fortran::lower::genAllocateStmt(
+ Fortran::lower::AbstractConverter &converter,
+ const Fortran::parser::AllocateStmt &stmt, mlir::Location loc) {
+ AllocateStmtHelper{converter, stmt, loc}.lower();
+ return;
+}
+
+//===----------------------------------------------------------------------===//
+// Deallocate statement implementation
+//===----------------------------------------------------------------------===//
+
+// Generate deallocation of a pointer/allocatable.
+static void genDeallocate(fir::FirOpBuilder &builder, mlir::Location loc,
+ const fir::MutableBoxValue &box,
+ ErrorManager &errorManager) {
+ // Deallocate intrinsic types inline.
+ if (!box.isDerived() && !errorManager.hasStatSpec() && !useAllocateRuntime) {
+ fir::factory::genInlinedDeallocate(builder, loc, box);
+ return;
+ }
+ // Use runtime calls to deallocate descriptor cases. Sync MutableBoxValue
+ // with its descriptor before and after calls if needed.
+ errorManager.genStatCheck(builder, loc);
+ mlir::Value stat = genRuntimeDeallocate(builder, loc, box, errorManager);
+ fir::factory::syncMutableBoxFromIRBox(builder, loc, box);
+ errorManager.assignStat(builder, loc, stat);
+}
+
+void Fortran::lower::genDeallocateStmt(
+ Fortran::lower::AbstractConverter &converter,
+ const Fortran::parser::DeallocateStmt &stmt, mlir::Location loc) {
+ const Fortran::lower::SomeExpr *statExpr{nullptr};
+ const Fortran::lower::SomeExpr *errMsgExpr{nullptr};
+ for (const Fortran::parser::StatOrErrmsg &statOrErr :
+ std::get<std::list<Fortran::parser::StatOrErrmsg>>(stmt.t))
+ std::visit(Fortran::common::visitors{
+ [&](const Fortran::parser::StatVariable &statVar) {
+ statExpr = Fortran::semantics::GetExpr(statVar);
+ },
+ [&](const Fortran::parser::MsgVariable &errMsgVar) {
+ errMsgExpr = Fortran::semantics::GetExpr(errMsgVar);
+ },
+ },
+ statOrErr.u);
+ ErrorManager errorManager;
+ errorManager.init(converter, loc, statExpr, errMsgExpr);
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ mlir::OpBuilder::InsertPoint insertPt = builder.saveInsertionPoint();
+ for (const Fortran::parser::AllocateObject &allocateObject :
+ std::get<std::list<Fortran::parser::AllocateObject>>(stmt.t)) {
+ fir::MutableBoxValue box =
+ genMutableBoxValue(converter, loc, allocateObject);
+ genDeallocate(builder, loc, box, errorManager);
+ }
+ builder.restoreInsertionPoint(insertPt);
+}
+
//===----------------------------------------------------------------------===//
// MutableBoxValue creation implementation
//===----------------------------------------------------------------------===//
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index 1eeab696c9d09..9b1215eed168c 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -12,6 +12,7 @@
#include "flang/Lower/Bridge.h"
#include "flang/Evaluate/tools.h"
+#include "flang/Lower/Allocatable.h"
#include "flang/Lower/CallInterface.h"
#include "flang/Lower/ConvertExpr.h"
#include "flang/Lower/ConvertType.h"
@@ -1265,11 +1266,11 @@ class FirConverter : public Fortran::lower::AbstractConverter {
//===--------------------------------------------------------------------===//
void genFIR(const Fortran::parser::AllocateStmt &stmt) {
- TODO(toLocation(), "AllocateStmt lowering");
+ Fortran::lower::genAllocateStmt(*this, stmt, toLocation());
}
void genFIR(const Fortran::parser::DeallocateStmt &stmt) {
- TODO(toLocation(), "DeallocateStmt lowering");
+ Fortran::lower::genDeallocateStmt(*this, stmt, toLocation());
}
void genFIR(const Fortran::parser::NullifyStmt &stmt) {
diff --git a/flang/test/Lower/allocatables.f90 b/flang/test/Lower/allocatables.f90
new file mode 100644
index 0000000000000..6c266fb97bd3b
--- /dev/null
+++ b/flang/test/Lower/allocatables.f90
@@ -0,0 +1,196 @@
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! Test lowering of allocatables using runtime for allocate/deallcoate statements.
+! CHECK-LABEL: _QPfooscalar
+subroutine fooscalar()
+ ! Test lowering of local allocatable specification
+ real, allocatable :: x
+ ! CHECK: %[[xAddrVar:.*]] = fir.alloca !fir.heap<f32> {{{.*}}uniq_name = "_QFfooscalarEx.addr"}
+ ! CHECK: %[[nullAddr:.*]] = fir.zero_bits !fir.heap<f32>
+ ! CHECK: fir.store %[[nullAddr]] to %[[xAddrVar]] : !fir.ref<!fir.heap<f32>>
+
+ ! Test allocation of local allocatables
+ allocate(x)
+ ! CHECK: %[[alloc:.*]] = fir.allocmem f32 {{{.*}}uniq_name = "_QFfooscalarEx.alloc"}
+ ! CHECK: fir.store %[[alloc]] to %[[xAddrVar]] : !fir.ref<!fir.heap<f32>>
+
+ ! Test reading allocatable bounds and extents
+ print *, x
+ ! CHECK: %[[xAddr1:.*]] = fir.load %[[xAddrVar]] : !fir.ref<!fir.heap<f32>>
+ ! CHECK: = fir.load %[[xAddr1]] : !fir.heap<f32>
+
+ ! Test deallocation
+ deallocate(x)
+ ! CHECK: %[[xAddr2:.*]] = fir.load %[[xAddrVar]] : !fir.ref<!fir.heap<f32>>
+ ! CHECK: fir.freemem %[[xAddr2]]
+ ! CHECK: %[[nullAddr1:.*]] = fir.zero_bits !fir.heap<f32>
+ ! fir.store %[[nullAddr1]] to %[[xAddrVar]] : !fir.ref<!fir.heap<f32>>
+end subroutine
+
+! CHECK-LABEL: _QPfoodim1
+subroutine foodim1()
+ ! Test lowering of local allocatable specification
+ real, allocatable :: x(:)
+ ! CHECK-DAG: %[[xAddrVar:.*]] = fir.alloca !fir.heap<!fir.array<?xf32>> {{{.*}}uniq_name = "_QFfoodim1Ex.addr"}
+ ! CHECK-DAG: %[[xLbVar:.*]] = fir.alloca index {{{.*}}uniq_name = "_QFfoodim1Ex.lb0"}
+ ! CHECK-DAG: %[[xExtVar:.*]] = fir.alloca index {{{.*}}uniq_name = "_QFfoodim1Ex.ext0"}
+ ! CHECK: %[[nullAddr:.*]] = fir.zero_bits !fir.heap<!fir.array<?xf32>>
+ ! CHECK: fir.store %[[nullAddr]] to %[[xAddrVar]] : !fir.ref<!fir.heap<!fir.array<?xf32>>>
+
+ ! Test allocation of local allocatables
+ allocate(x(42:100))
+ ! CHECK-DAG: %[[c42:.*]] = fir.convert %c42{{.*}} : (i32) -> index
+ ! CHECK-DAG: %[[c100:.*]] = fir.convert %c100_i32 : (i32) -> index
+ ! CHECK-DAG: %[[
diff :.*]] = arith.subi %[[c100]], %[[c42]] : index
+ ! CHECK: %[[extent:.*]] = arith.addi %[[
diff ]], %c1{{.*}} : index
+ ! CHECK: %[[alloc:.*]] = fir.allocmem !fir.array<?xf32>, %[[extent]] {{{.*}}uniq_name = "_QFfoodim1Ex.alloc"}
+ ! CHECK-DAG: fir.store %[[alloc]] to %[[xAddrVar]] : !fir.ref<!fir.heap<!fir.array<?xf32>>>
+ ! CHECK-DAG: fir.store %[[extent]] to %[[xExtVar]] : !fir.ref<index>
+ ! CHECK-DAG: fir.store %[[c42]] to %[[xLbVar]] : !fir.ref<index>
+
+ ! Test reading allocatable bounds and extents
+ print *, x(42)
+ ! CHECK-DAG: fir.load %[[xLbVar]] : !fir.ref<index>
+ ! CHECK-DAG: fir.load %[[xAddrVar]] : !fir.ref<!fir.heap<!fir.array<?xf32>>>
+
+ deallocate(x)
+ ! CHECK: %[[xAddr1:.*]] = fir.load %1 : !fir.ref<!fir.heap<!fir.array<?xf32>>>
+ ! CHECK: fir.freemem %[[xAddr1]]
+ ! CHECK: %[[nullAddr1:.*]] = fir.zero_bits !fir.heap<!fir.array<?xf32>>
+ ! CHECK: fir.store %[[nullAddr1]] to %[[xAddrVar]] : !fir.ref<!fir.heap<!fir.array<?xf32>>>
+end subroutine
+
+! CHECK-LABEL: _QPfoodim2
+subroutine foodim2()
+ ! Test lowering of local allocatable specification
+ real, allocatable :: x(:, :)
+ ! CHECK-DAG: fir.alloca !fir.heap<!fir.array<?x?xf32>> {{{.*}}uniq_name = "_QFfoodim2Ex.addr"}
+ ! CHECK-DAG: fir.alloca index {{{.*}}uniq_name = "_QFfoodim2Ex.lb0"}
+ ! CHECK-DAG: fir.alloca index {{{.*}}uniq_name = "_QFfoodim2Ex.ext0"}
+ ! CHECK-DAG: fir.alloca index {{{.*}}uniq_name = "_QFfoodim2Ex.lb1"}
+ ! CHECK-DAG: fir.alloca index {{{.*}}uniq_name = "_QFfoodim2Ex.ext1"}
+end subroutine
+
+! test lowering of character allocatables. Focus is placed on the length handling
+! CHECK-LABEL: _QPchar_deferred(
+subroutine char_deferred(n)
+ integer :: n
+ character(:), allocatable :: c
+ ! CHECK-DAG: %[[cAddrVar:.*]] = fir.alloca !fir.heap<!fir.char<1,?>> {{{.*}}uniq_name = "_QFchar_deferredEc.addr"}
+ ! CHECK-DAG: %[[cLenVar:.*]] = fir.alloca index {{{.*}}uniq_name = "_QFchar_deferredEc.len"}
+ allocate(character(10):: c)
+ ! CHECK: %[[c10:.]] = fir.convert %c10_i32 : (i32) -> index
+ ! CHECK: fir.allocmem !fir.char<1,?>(%[[c10]] : index) {{{.*}}uniq_name = "_QFchar_deferredEc.alloc"}
+ ! CHECK: fir.store %[[c10]] to %[[cLenVar]] : !fir.ref<index>
+ deallocate(c)
+ ! CHECK: fir.freemem %{{.*}}
+ allocate(character(n):: c)
+ ! CHECK: %[[n:.*]] = fir.load %arg0 : !fir.ref<i32>
+ ! CHECK: %[[ni:.*]] = fir.convert %[[n]] : (i32) -> index
+ ! CHECK: fir.allocmem !fir.char<1,?>(%[[ni]] : index) {{{.*}}uniq_name = "_QFchar_deferredEc.alloc"}
+ ! CHECK: fir.store %[[ni]] to %[[cLenVar]] : !fir.ref<index>
+
+ call bar(c)
+ ! CHECK-DAG: %[[cLen:.*]] = fir.load %[[cLenVar]] : !fir.ref<index>
+ ! CHECK-DAG: %[[cAddr:.*]] = fir.load %[[cAddrVar]] : !fir.ref<!fir.heap<!fir.char<1,?>>>
+ ! CHECK-DAG: %[[cAddrcast:.*]] = fir.convert %[[cAddr]] : (!fir.heap<!fir.char<1,?>>) -> !fir.ref<!fir.char<1,?>>
+ ! CHECK: fir.emboxchar %[[cAddrcast]], %[[cLen]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+end subroutine
+
+! CHECK-LABEL: _QPchar_explicit_cst(
+subroutine char_explicit_cst(n)
+ integer :: n
+ character(10), allocatable :: c
+ ! CHECK-DAG: %[[cLen:.*]] = arith.constant 10 : index
+ ! CHECK-DAG: %[[cAddrVar:.*]] = fir.alloca !fir.heap<!fir.char<1,10>> {{{.*}}uniq_name = "_QFchar_explicit_cstEc.addr"}
+ ! CHECK-NOT: "_QFchar_explicit_cstEc.len"
+ allocate(c)
+ ! CHECK: fir.allocmem !fir.char<1,10> {{{.*}}uniq_name = "_QFchar_explicit_cstEc.alloc"}
+ deallocate(c)
+ ! CHECK: fir.freemem %{{.*}}
+ allocate(character(n):: c)
+ ! CHECK: fir.allocmem !fir.char<1,10> {{{.*}}uniq_name = "_QFchar_explicit_cstEc.alloc"}
+ deallocate(c)
+ ! CHECK: fir.freemem %{{.*}}
+ allocate(character(10):: c)
+ ! CHECK: fir.allocmem !fir.char<1,10> {{{.*}}uniq_name = "_QFchar_explicit_cstEc.alloc"}
+ call bar(c)
+ ! CHECK: %[[cAddr:.*]] = fir.load %[[cAddrVar]] : !fir.ref<!fir.heap<!fir.char<1,10>>>
+ ! CHECK: %[[cAddrcast:.*]] = fir.convert %[[cAddr]] : (!fir.heap<!fir.char<1,10>>) -> !fir.ref<!fir.char<1,?>>
+ ! CHECK: fir.emboxchar %[[cAddrcast]], %[[cLen]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+end subroutine
+
+! CHECK-LABEL: _QPchar_explicit_dyn(
+subroutine char_explicit_dyn(l1, l2)
+ integer :: l1, l2
+ character(l1), allocatable :: c
+ ! CHECK-DAG: %[[cLen:.*]] = fir.load %arg0 : !fir.ref<i32>
+ ! CHECK-DAG: %[[cAddrVar:.*]] = fir.alloca !fir.heap<!fir.char<1,?>> {{{.*}}uniq_name = "_QFchar_explicit_dynEc.addr"}
+ ! CHECK-NOT: "_QFchar_explicit_dynEc.len"
+ allocate(c)
+ ! CHECK: %[[cLenCast1:.*]] = fir.convert %[[cLen]] : (i32) -> index
+ ! CHECK: fir.allocmem !fir.char<1,?>(%[[cLenCast1]] : index) {{{.*}}uniq_name = "_QFchar_explicit_dynEc.alloc"}
+ deallocate(c)
+ ! CHECK: fir.freemem %{{.*}}
+ allocate(character(l2):: c)
+ ! CHECK: %[[cLenCast2:.*]] = fir.convert %[[cLen]] : (i32) -> index
+ ! CHECK: fir.allocmem !fir.char<1,?>(%[[cLenCast2]] : index) {{{.*}}uniq_name = "_QFchar_explicit_dynEc.alloc"}
+ deallocate(c)
+ ! CHECK: fir.freemem %{{.*}}
+ allocate(character(10):: c)
+ ! CHECK: %[[cLenCast3:.*]] = fir.convert %[[cLen]] : (i32) -> index
+ ! CHECK: fir.allocmem !fir.char<1,?>(%[[cLenCast3]] : index) {{{.*}}uniq_name = "_QFchar_explicit_dynEc.alloc"}
+ call bar(c)
+ ! CHECK-DAG: %[[cLenCast4:.*]] = fir.convert %[[cLen]] : (i32) -> index
+ ! CHECK-DAG: %[[cAddr:.*]] = fir.load %[[cAddrVar]] : !fir.ref<!fir.heap<!fir.char<1,?>>>
+ ! CHECK-DAG: %[[cAddrcast:.*]] = fir.convert %[[cAddr]] : (!fir.heap<!fir.char<1,?>>) -> !fir.ref<!fir.char<1,?>>
+ ! CHECK: fir.emboxchar %[[cAddrcast]], %[[cLenCast4]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+end subroutine
+
+! CHECK-LABEL: _QPspecifiers(
+subroutine specifiers
+ allocatable jj1(:), jj2(:,:), jj3(:)
+ ! CHECK: [[STAT:%[0-9]+]] = fir.alloca i32 {{{.*}}uniq_name = "_QFspecifiersEsss"}
+ integer sss
+ character*30 :: mmm = "None"
+ ! CHECK: fir.call @_FortranAAllocatableSetBounds
+ ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableAllocate
+ ! CHECK: fir.store [[RESULT]] to [[STAT]]
+ ! CHECK: fir.if %{{[0-9]+}} {
+ ! CHECK: fir.call @_FortranAAllocatableSetBounds
+ ! CHECK: fir.call @_FortranAAllocatableSetBounds
+ ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableAllocate
+ ! CHECK: fir.store [[RESULT]] to [[STAT]]
+ ! CHECK: fir.if %{{[0-9]+}} {
+ ! CHECK: fir.call @_FortranAAllocatableSetBounds
+ ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableAllocate
+ ! CHECK: fir.store [[RESULT]] to [[STAT]]
+ ! CHECK-NOT: fir.if %{{[0-9]+}} {
+ ! CHECK-COUNT-2: }
+ ! CHECK-NOT: }
+ allocate(jj1(3), jj2(3,3), jj3(3), stat=sss, errmsg=mmm)
+ ! CHECK: fir.call @_FortranAAllocatableSetBounds
+ ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableAllocate
+ ! CHECK: fir.call @_FortranAAllocatableSetBounds
+ ! CHECK: fir.call @_FortranAAllocatableSetBounds
+ ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableAllocate
+ ! CHECK: fir.call @_FortranAAllocatableSetBounds
+ ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableAllocate
+ allocate(jj1(3), jj2(3,3), jj3(3), stat=sss, errmsg=mmm)
+ ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableDeallocate
+ ! CHECK: fir.store [[RESULT]] to [[STAT]]
+ ! CHECK: fir.if %{{[0-9]+}} {
+ ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableDeallocate
+ ! CHECK: fir.store [[RESULT]] to [[STAT]]
+ ! CHECK: fir.if %{{[0-9]+}} {
+ ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableDeallocate
+ ! CHECK: fir.store [[RESULT]] to [[STAT]]
+ ! CHECK-NOT: fir.if %{{[0-9]+}} {
+ ! CHECK-COUNT-2: }
+ ! CHECK-NOT: }
+ deallocate(jj1, jj2, jj3, stat=sss, errmsg=mmm)
+ ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableDeallocate
+ ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableDeallocate
+ ! CHECK: [[RESULT:%[0-9]+]] = fir.call @_FortranAAllocatableDeallocate
+ deallocate(jj1, jj2, jj3, stat=sss, errmsg=mmm)
+end subroutine specifiers
More information about the flang-commits
mailing list