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 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( + 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(statAddr); } + + void genStatCheck(fir::FirOpBuilder &builder, mlir::Location loc) { + if (statValue) { + mlir::Value zero = + builder.createIntegerConstant(loc, statValue.getType(), 0); + auto cmp = builder.create( + loc, mlir::arith::CmpIPredicate::eq, statValue, zero); + auto ifOp = builder.create(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(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(loc, + builder) + : fir::runtime::getRuntimeFunc( + loc, builder); + llvm::SmallVector args{box.getAddr(), dimIndex, lowerBound, + upperBound}; + llvm::SmallVector operands; + for (auto [fst, snd] : llvm::zip(args, callee.getType().getInputs())) + operands.emplace_back(builder.createConvert(loc, snd, fst)); + builder.create(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( + loc, builder) + : fir::runtime::getRuntimeFunc( + loc, builder); + llvm::ArrayRef inputTypes = callee.getType().getInputs(); + if (inputTypes.size() != 5) + fir::emitFatalError( + loc, "AllocatableInitCharacter runtime interface not as expected"); + llvm::SmallVector 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().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(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(loc, builder) + : fir::runtime::getRuntimeFunc(loc, + builder); + llvm::SmallVector args{ + box.getAddr(), errorManager.hasStat, errorManager.errMsgAddr, + errorManager.sourceFile, errorManager.sourceLine}; + llvm::SmallVector operands; + for (auto [fst, snd] : llvm::zip(args, callee.getType().getInputs())) + operands.emplace_back(builder.createConvert(loc, snd, fst)); + return builder.create(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(loc, + builder) + : fir::runtime::getRuntimeFunc( + loc, builder); + llvm::SmallVector args{ + boxAddress, errorManager.hasStat, errorManager.errMsgAddr, + errorManager.sourceFile, errorManager.sourceLine}; + llvm::SmallVector operands; + for (auto [fst, snd] : llvm::zip(args, callee.getType().getInputs())) + operands.emplace_back(builder.createConvert(loc, snd, fst)); + return builder.create(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>(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>( + alloc.t) + .has_value(); + } + const Fortran::parser::AllocateObject &getAllocObj() const { + return std::get(alloc.t); + } + const Fortran::semantics::Symbol &getSymbol() const { + return unwrapSymbol(getAllocObj()); + } + const std::list &getShapeSpecs() const { + return std::get>(alloc.t); + } + }; + + Allocation unwrapAllocation(const Fortran::parser::Allocation &alloc) { + const auto &allocObj = std::get(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>(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 lbounds; + llvm::SmallVector 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 &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(loc, ub, lb); + extents.emplace_back( + builder.create(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(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 &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>(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 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>(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>(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 {{{.*}}uniq_name = "_QFfooscalarEx.addr"} + ! CHECK: %[[nullAddr:.*]] = fir.zero_bits !fir.heap + ! CHECK: fir.store %[[nullAddr]] to %[[xAddrVar]] : !fir.ref> + + ! Test allocation of local allocatables + allocate(x) + ! CHECK: %[[alloc:.*]] = fir.allocmem f32 {{{.*}}uniq_name = "_QFfooscalarEx.alloc"} + ! CHECK: fir.store %[[alloc]] to %[[xAddrVar]] : !fir.ref> + + ! Test reading allocatable bounds and extents + print *, x + ! CHECK: %[[xAddr1:.*]] = fir.load %[[xAddrVar]] : !fir.ref> + ! CHECK: = fir.load %[[xAddr1]] : !fir.heap + + ! Test deallocation + deallocate(x) + ! CHECK: %[[xAddr2:.*]] = fir.load %[[xAddrVar]] : !fir.ref> + ! CHECK: fir.freemem %[[xAddr2]] + ! CHECK: %[[nullAddr1:.*]] = fir.zero_bits !fir.heap + ! fir.store %[[nullAddr1]] to %[[xAddrVar]] : !fir.ref> +end subroutine + +! CHECK-LABEL: _QPfoodim1 +subroutine foodim1() + ! Test lowering of local allocatable specification + real, allocatable :: x(:) + ! CHECK-DAG: %[[xAddrVar:.*]] = fir.alloca !fir.heap> {{{.*}}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> + ! CHECK: fir.store %[[nullAddr]] to %[[xAddrVar]] : !fir.ref>> + + ! 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, %[[extent]] {{{.*}}uniq_name = "_QFfoodim1Ex.alloc"} + ! CHECK-DAG: fir.store %[[alloc]] to %[[xAddrVar]] : !fir.ref>> + ! CHECK-DAG: fir.store %[[extent]] to %[[xExtVar]] : !fir.ref + ! CHECK-DAG: fir.store %[[c42]] to %[[xLbVar]] : !fir.ref + + ! Test reading allocatable bounds and extents + print *, x(42) + ! CHECK-DAG: fir.load %[[xLbVar]] : !fir.ref + ! CHECK-DAG: fir.load %[[xAddrVar]] : !fir.ref>> + + deallocate(x) + ! CHECK: %[[xAddr1:.*]] = fir.load %1 : !fir.ref>> + ! CHECK: fir.freemem %[[xAddr1]] + ! CHECK: %[[nullAddr1:.*]] = fir.zero_bits !fir.heap> + ! CHECK: fir.store %[[nullAddr1]] to %[[xAddrVar]] : !fir.ref>> +end subroutine + +! CHECK-LABEL: _QPfoodim2 +subroutine foodim2() + ! Test lowering of local allocatable specification + real, allocatable :: x(:, :) + ! CHECK-DAG: fir.alloca !fir.heap> {{{.*}}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> {{{.*}}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 + deallocate(c) + ! CHECK: fir.freemem %{{.*}} + allocate(character(n):: c) + ! CHECK: %[[n:.*]] = fir.load %arg0 : !fir.ref + ! 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 + + call bar(c) + ! CHECK-DAG: %[[cLen:.*]] = fir.load %[[cLenVar]] : !fir.ref + ! CHECK-DAG: %[[cAddr:.*]] = fir.load %[[cAddrVar]] : !fir.ref>> + ! CHECK-DAG: %[[cAddrcast:.*]] = fir.convert %[[cAddr]] : (!fir.heap>) -> !fir.ref> + ! CHECK: fir.emboxchar %[[cAddrcast]], %[[cLen]] : (!fir.ref>, 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> {{{.*}}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>> + ! CHECK: %[[cAddrcast:.*]] = fir.convert %[[cAddr]] : (!fir.heap>) -> !fir.ref> + ! CHECK: fir.emboxchar %[[cAddrcast]], %[[cLen]] : (!fir.ref>, 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 + ! CHECK-DAG: %[[cAddrVar:.*]] = fir.alloca !fir.heap> {{{.*}}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>> + ! CHECK-DAG: %[[cAddrcast:.*]] = fir.convert %[[cAddr]] : (!fir.heap>) -> !fir.ref> + ! CHECK: fir.emboxchar %[[cAddrcast]], %[[cLenCast4]] : (!fir.ref>, 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