Magic-Mirror/llvm-capstone
1
0
Fork 0
mirror of https://github.com/capstone-engine/llvm-capstone.git synced 2025-02-26 13:26:22 +00:00
Code Issues Actions 2 Packages Projects Releases Wiki Activity

[flang] Lower allocate and deallocate statements

Browse Source 
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@nvidia.com>
Co-authored-by: Jean Perier <jperier@nvidia.com>
Co-authored-by: V Donaldson <vdonaldson@nvidia.com>
This commit is contained in:
Valentin Clement 2022-03-07 21:22:28 +01:00
parent 844a9c0ef4
commit c5cf1b9034
No known key found for this signature in database
GPG Key ID: 086D54783C928776
4 changed files with 724 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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.

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

@ -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
//===----------------------------------------------------------------------===//

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

@ -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 @@ private:
//===--------------------------------------------------------------------===//
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) {

196
flang/test/Lower/allocatables.f90 Normal file
View File

@ -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