mirror of
https://github.com/llvm/llvm-project.git
synced 2025-04-26 18:36:05 +00:00
478e516140
After a global device pointer is set through `c_f_pointer`, we need to sync the double descriptor so the version on the device is also up to date.
1197 lines
53 KiB
C++
1197 lines
53 KiB
C++
//===-- Allocatable.cpp -- Allocatable statements lowering ----------------===//
|
|
//
|
|
// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
|
|
// See https://llvm.org/LICENSE.txt for license information.
|
|
// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
|
|
//
|
|
//===----------------------------------------------------------------------===//
|
|
//
|
|
// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
|
|
//
|
|
//===----------------------------------------------------------------------===//
|
|
|
|
#include "flang/Lower/Allocatable.h"
|
|
#include "flang/Evaluate/tools.h"
|
|
#include "flang/Lower/AbstractConverter.h"
|
|
#include "flang/Lower/ConvertType.h"
|
|
#include "flang/Lower/ConvertVariable.h"
|
|
#include "flang/Lower/Cuda.h"
|
|
#include "flang/Lower/IterationSpace.h"
|
|
#include "flang/Lower/Mangler.h"
|
|
#include "flang/Lower/OpenACC.h"
|
|
#include "flang/Lower/PFTBuilder.h"
|
|
#include "flang/Lower/Runtime.h"
|
|
#include "flang/Lower/StatementContext.h"
|
|
#include "flang/Optimizer/Builder/CUFCommon.h"
|
|
#include "flang/Optimizer/Builder/FIRBuilder.h"
|
|
#include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
|
|
#include "flang/Optimizer/Builder/Todo.h"
|
|
#include "flang/Optimizer/Dialect/CUF/CUFOps.h"
|
|
#include "flang/Optimizer/Dialect/FIROps.h"
|
|
#include "flang/Optimizer/Dialect/FIROpsSupport.h"
|
|
#include "flang/Optimizer/HLFIR/HLFIROps.h"
|
|
#include "flang/Optimizer/Support/FatalError.h"
|
|
#include "flang/Optimizer/Support/InternalNames.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"
|
|
|
|
/// By default fir memory operation fir::AllocMemOp/fir::FreeMemOp are used.
|
|
/// This switch allow forcing the use of runtime and descriptors for everything.
|
|
/// This is mainly intended as a debug switch.
|
|
static llvm::cl::opt<bool> useAllocateRuntime(
|
|
"use-alloc-runtime",
|
|
llvm::cl::desc("Lower allocations to fortran runtime calls"),
|
|
llvm::cl::init(false));
|
|
/// Switch to force lowering of allocatable and pointers to descriptors in all
|
|
/// cases. This is now turned on by default since that is what will happen with
|
|
/// HLFIR lowering, so this allows getting early feedback of the impact.
|
|
/// If this turns out to cause performance regressions, a dedicated fir.box
|
|
/// "discretization pass" would make more sense to cover all the fir.box usage
|
|
/// (taking advantage of any future inlining for instance).
|
|
static llvm::cl::opt<bool> useDescForMutableBox(
|
|
"use-desc-for-alloc",
|
|
llvm::cl::desc("Always use descriptors for POINTER and ALLOCATABLE"),
|
|
llvm::cl::init(true));
|
|
|
|
//===----------------------------------------------------------------------===//
|
|
// 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(loc, statExpr, stmtCtx))
|
|
: mlir::Value{};
|
|
errMsgAddr =
|
|
statExpr && errMsgExpr
|
|
? builder.createBox(loc,
|
|
converter.genExprAddr(loc, errMsgExpr, stmtCtx))
|
|
: 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::func::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.getFunctionType().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, int64_t kind = 0) {
|
|
mlir::func::FuncOp callee =
|
|
box.isPointer()
|
|
? fir::runtime::getRuntimeFunc<mkRTKey(PointerNullifyCharacter)>(
|
|
loc, builder)
|
|
: fir::runtime::getRuntimeFunc<mkRTKey(
|
|
AllocatableInitCharacterForAllocate)>(loc, builder);
|
|
llvm::ArrayRef<mlir::Type> inputTypes = callee.getFunctionType().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));
|
|
if (kind == 0)
|
|
kind = mlir::cast<fir::CharacterType>(box.getEleTy()).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::func::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.getFunctionType().getInputs()))
|
|
operands.emplace_back(builder.createConvert(loc, snd, fst));
|
|
return builder.create<fir::CallOp>(loc, callee, operands).getResult(0);
|
|
}
|
|
|
|
/// Generate a sequence of runtime calls to allocate memory and assign with the
|
|
/// \p source.
|
|
static mlir::Value genRuntimeAllocateSource(fir::FirOpBuilder &builder,
|
|
mlir::Location loc,
|
|
const fir::MutableBoxValue &box,
|
|
fir::ExtendedValue source,
|
|
ErrorManager &errorManager) {
|
|
mlir::func::FuncOp callee =
|
|
box.isPointer()
|
|
? fir::runtime::getRuntimeFunc<mkRTKey(PointerAllocateSource)>(
|
|
loc, builder)
|
|
: fir::runtime::getRuntimeFunc<mkRTKey(AllocatableAllocateSource)>(
|
|
loc, builder);
|
|
llvm::SmallVector<mlir::Value> args{
|
|
box.getAddr(), fir::getBase(source),
|
|
errorManager.hasStat, errorManager.errMsgAddr,
|
|
errorManager.sourceFile, errorManager.sourceLine};
|
|
llvm::SmallVector<mlir::Value> operands;
|
|
for (auto [fst, snd] : llvm::zip(args, callee.getFunctionType().getInputs()))
|
|
operands.emplace_back(builder.createConvert(loc, snd, fst));
|
|
return builder.create<fir::CallOp>(loc, callee, operands).getResult(0);
|
|
}
|
|
|
|
/// Generate runtime call to apply mold to the descriptor.
|
|
static void genRuntimeAllocateApplyMold(fir::FirOpBuilder &builder,
|
|
mlir::Location loc,
|
|
const fir::MutableBoxValue &box,
|
|
fir::ExtendedValue mold, int rank) {
|
|
mlir::func::FuncOp callee =
|
|
box.isPointer()
|
|
? fir::runtime::getRuntimeFunc<mkRTKey(PointerApplyMold)>(loc,
|
|
builder)
|
|
: fir::runtime::getRuntimeFunc<mkRTKey(AllocatableApplyMold)>(
|
|
loc, builder);
|
|
llvm::SmallVector<mlir::Value> args{
|
|
fir::factory::getMutableIRBox(builder, loc, box), fir::getBase(mold),
|
|
builder.createIntegerConstant(
|
|
loc, callee.getFunctionType().getInputs()[2], rank)};
|
|
llvm::SmallVector<mlir::Value> operands;
|
|
for (auto [fst, snd] : llvm::zip(args, callee.getFunctionType().getInputs()))
|
|
operands.emplace_back(builder.createConvert(loc, snd, fst));
|
|
builder.create<fir::CallOp>(loc, callee, operands);
|
|
}
|
|
|
|
/// Generate a runtime call to deallocate memory.
|
|
static mlir::Value genRuntimeDeallocate(fir::FirOpBuilder &builder,
|
|
mlir::Location loc,
|
|
const fir::MutableBoxValue &box,
|
|
ErrorManager &errorManager,
|
|
mlir::Value declaredTypeDesc = {}) {
|
|
// Ensure fir.box is up-to-date before passing it to deallocate runtime.
|
|
mlir::Value boxAddress = fir::factory::getMutableIRBox(builder, loc, box);
|
|
mlir::func::FuncOp callee;
|
|
llvm::SmallVector<mlir::Value> args;
|
|
llvm::SmallVector<mlir::Value> operands;
|
|
if (box.isPolymorphic() || box.isUnlimitedPolymorphic()) {
|
|
callee = box.isPointer()
|
|
? fir::runtime::getRuntimeFunc<mkRTKey(
|
|
PointerDeallocatePolymorphic)>(loc, builder)
|
|
: fir::runtime::getRuntimeFunc<mkRTKey(
|
|
AllocatableDeallocatePolymorphic)>(loc, builder);
|
|
if (!declaredTypeDesc)
|
|
declaredTypeDesc = builder.createNullConstant(loc);
|
|
operands = fir::runtime::createArguments(
|
|
builder, loc, callee.getFunctionType(), boxAddress, declaredTypeDesc,
|
|
errorManager.hasStat, errorManager.errMsgAddr, errorManager.sourceFile,
|
|
errorManager.sourceLine);
|
|
} else {
|
|
callee = box.isPointer()
|
|
? fir::runtime::getRuntimeFunc<mkRTKey(PointerDeallocate)>(
|
|
loc, builder)
|
|
: fir::runtime::getRuntimeFunc<mkRTKey(AllocatableDeallocate)>(
|
|
loc, builder);
|
|
operands = fir::runtime::createArguments(
|
|
builder, loc, callee.getFunctionType(), boxAddress,
|
|
errorManager.hasStat, errorManager.errMsgAddr, errorManager.sourceFile,
|
|
errorManager.sourceLine);
|
|
}
|
|
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);
|
|
Fortran::lower::StatementContext stmtCtx;
|
|
if (sourceExpr)
|
|
sourceExv = converter.genExprBox(loc, *sourceExpr, stmtCtx);
|
|
if (moldExpr)
|
|
moldExv = converter.genExprBox(loc, *moldExpr, stmtCtx);
|
|
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))
|
|
Fortran::common::visit(
|
|
Fortran::common::visitors{
|
|
[&](const Fortran::parser::StatOrErrmsg &statOrErr) {
|
|
Fortran::common::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());
|
|
},
|
|
[&](const Fortran::parser::AllocOpt::Stream &stream) {
|
|
streamExpr = Fortran::semantics::GetExpr(stream.v.value());
|
|
},
|
|
[&](const Fortran::parser::AllocOpt::Pinned &pinned) {
|
|
pinnedExpr = Fortran::semantics::GetExpr(pinned.v.value());
|
|
},
|
|
},
|
|
allocOption.u);
|
|
}
|
|
|
|
void lowerAllocation(const Allocation &alloc) {
|
|
fir::MutableBoxValue boxAddr =
|
|
genMutableBoxValue(converter, loc, alloc.getAllocObj());
|
|
|
|
if (sourceExpr)
|
|
genSourceMoldAllocation(alloc, boxAddr, /*isSource=*/true);
|
|
else if (moldExpr)
|
|
genSourceMoldAllocation(alloc, boxAddr, /*isSource=*/false);
|
|
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(
|
|
loc, Fortran::semantics::GetExpr(*lbExpr), stmtCtx));
|
|
lb = builder.createConvert(loc, idxTy, lb);
|
|
} else {
|
|
lb = one;
|
|
}
|
|
lbounds.emplace_back(lb);
|
|
}
|
|
mlir::Value ub = fir::getBase(converter.genExprValue(
|
|
loc, Fortran::semantics::GetExpr(std::get<1>(shapeSpec.t)), stmtCtx));
|
|
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),
|
|
/*mustBeHeap=*/true);
|
|
}
|
|
|
|
void postAllocationAction(const Allocation &alloc) {
|
|
if (alloc.getSymbol().test(Fortran::semantics::Symbol::Flag::AccDeclare))
|
|
Fortran::lower::attachDeclarePostAllocAction(converter, builder,
|
|
alloc.getSymbol());
|
|
}
|
|
|
|
void setPinnedToFalse() {
|
|
if (!pinnedExpr)
|
|
return;
|
|
Fortran::lower::StatementContext stmtCtx;
|
|
mlir::Value pinned =
|
|
fir::getBase(converter.genExprAddr(loc, *pinnedExpr, stmtCtx));
|
|
mlir::Location loc = pinned.getLoc();
|
|
mlir::Value falseValue = builder.createBool(loc, false);
|
|
mlir::Value falseConv = builder.createConvert(
|
|
loc, fir::unwrapRefType(pinned.getType()), falseValue);
|
|
builder.create<fir::StoreOp>(loc, falseConv, pinned);
|
|
}
|
|
|
|
void genSimpleAllocation(const Allocation &alloc,
|
|
const fir::MutableBoxValue &box) {
|
|
bool isCudaSymbol = Fortran::semantics::HasCUDAAttr(alloc.getSymbol());
|
|
bool isCudaDeviceContext = cuf::isCUDADeviceContext(builder.getRegion());
|
|
bool inlineAllocation = !box.isDerived() && !errorManager.hasStatSpec() &&
|
|
!alloc.type.IsPolymorphic() &&
|
|
!alloc.hasCoarraySpec() && !useAllocateRuntime &&
|
|
!box.isPointer();
|
|
unsigned allocatorIdx = Fortran::lower::getAllocatorIdx(alloc.getSymbol());
|
|
|
|
if (inlineAllocation &&
|
|
((isCudaSymbol && isCudaDeviceContext) || !isCudaSymbol)) {
|
|
// Pointers must use PointerAllocate so that their deallocations
|
|
// can be validated.
|
|
genInlinedAllocation(alloc, box);
|
|
postAllocationAction(alloc);
|
|
setPinnedToFalse();
|
|
return;
|
|
}
|
|
|
|
// Generate a sequence of runtime calls.
|
|
errorManager.genStatCheck(builder, loc);
|
|
genAllocateObjectInit(box, allocatorIdx);
|
|
if (alloc.hasCoarraySpec())
|
|
TODO(loc, "coarray: allocation of a coarray object");
|
|
if (alloc.type.IsPolymorphic())
|
|
genSetType(alloc, box, loc);
|
|
genSetDeferredLengthParameters(alloc, box);
|
|
genAllocateObjectBounds(alloc, box);
|
|
mlir::Value stat;
|
|
if (!isCudaSymbol) {
|
|
stat = genRuntimeAllocate(builder, loc, box, errorManager);
|
|
setPinnedToFalse();
|
|
} else {
|
|
stat =
|
|
genCudaAllocate(builder, loc, box, errorManager, alloc.getSymbol());
|
|
}
|
|
fir::factory::syncMutableBoxFromIRBox(builder, loc, box);
|
|
postAllocationAction(alloc);
|
|
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, "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(loc, lenExpr, stmtCtx)));
|
|
}
|
|
}
|
|
}
|
|
|
|
// 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 genAllocateObjectInit(const fir::MutableBoxValue &box,
|
|
unsigned allocatorIdx) {
|
|
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(),
|
|
/*typeSourceBox=*/{}, allocatorIdx);
|
|
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);
|
|
}
|
|
}
|
|
|
|
void genAllocateObjectBounds(const Allocation &alloc,
|
|
const fir::MutableBoxValue &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(
|
|
loc, Fortran::semantics::GetExpr(*lbExpr), stmtCtx));
|
|
else
|
|
lb = builder.createIntegerConstant(loc, idxTy, 1);
|
|
mlir::Value ub = fir::getBase(converter.genExprValue(
|
|
loc, Fortran::semantics::GetExpr(std::get<1>(bounds)), stmtCtx));
|
|
mlir::Value dimIndex =
|
|
builder.createIntegerConstant(loc, i32Ty, iter.index());
|
|
// Runtime call
|
|
genRuntimeSetBounds(builder, loc, box, dimIndex, lb, ub);
|
|
}
|
|
if (sourceExpr && sourceExpr->Rank() > 0 &&
|
|
alloc.getShapeSpecs().size() == 0) {
|
|
// If the alloc object does not have shape list, get the bounds from the
|
|
// source expression.
|
|
mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
|
|
const auto *sourceBox = sourceExv.getBoxOf<fir::BoxValue>();
|
|
assert(sourceBox && "source expression should be lowered to one box");
|
|
for (int i = 0; i < sourceExpr->Rank(); ++i) {
|
|
auto dimVal = builder.createIntegerConstant(loc, idxTy, i);
|
|
auto dimInfo = builder.create<fir::BoxDimsOp>(
|
|
loc, idxTy, idxTy, idxTy, sourceBox->getAddr(), dimVal);
|
|
mlir::Value lb =
|
|
fir::factory::readLowerBound(builder, loc, sourceExv, i, one);
|
|
mlir::Value extent = dimInfo.getResult(1);
|
|
mlir::Value ub = builder.create<mlir::arith::SubIOp>(
|
|
loc, builder.create<mlir::arith::AddIOp>(loc, extent, lb), one);
|
|
mlir::Value dimIndex = builder.createIntegerConstant(loc, i32Ty, i);
|
|
genRuntimeSetBounds(builder, loc, box, dimIndex, lb, ub);
|
|
}
|
|
}
|
|
}
|
|
|
|
void genSourceMoldAllocation(const Allocation &alloc,
|
|
const fir::MutableBoxValue &box, bool isSource) {
|
|
unsigned allocatorIdx = Fortran::lower::getAllocatorIdx(alloc.getSymbol());
|
|
fir::ExtendedValue exv = isSource ? sourceExv : moldExv;
|
|
|
|
// Generate a sequence of runtime calls.
|
|
errorManager.genStatCheck(builder, loc);
|
|
genAllocateObjectInit(box, allocatorIdx);
|
|
if (alloc.hasCoarraySpec())
|
|
TODO(loc, "coarray: allocation of a coarray object");
|
|
// Set length of the allocate object if it has. Otherwise, get the length
|
|
// from source for the deferred length parameter.
|
|
const bool isDeferredLengthCharacter =
|
|
box.isCharacter() && !box.hasNonDeferredLenParams();
|
|
if (lenParams.empty() && isDeferredLengthCharacter)
|
|
lenParams.push_back(fir::factory::readCharLen(builder, loc, exv));
|
|
if (!isSource || alloc.type.IsPolymorphic())
|
|
genRuntimeAllocateApplyMold(builder, loc, box, exv,
|
|
alloc.getSymbol().Rank());
|
|
if (isDeferredLengthCharacter)
|
|
genSetDeferredLengthParameters(alloc, box);
|
|
genAllocateObjectBounds(alloc, box);
|
|
mlir::Value stat;
|
|
if (Fortran::semantics::HasCUDAAttr(alloc.getSymbol())) {
|
|
stat =
|
|
genCudaAllocate(builder, loc, box, errorManager, alloc.getSymbol());
|
|
} else {
|
|
if (isSource)
|
|
stat = genRuntimeAllocateSource(builder, loc, box, exv, errorManager);
|
|
else
|
|
stat = genRuntimeAllocate(builder, loc, box, errorManager);
|
|
setPinnedToFalse();
|
|
}
|
|
fir::factory::syncMutableBoxFromIRBox(builder, loc, box);
|
|
postAllocationAction(alloc);
|
|
errorManager.assignStat(builder, loc, stat);
|
|
}
|
|
|
|
/// Generate call to PointerNullifyDerived or AllocatableInitDerived
|
|
/// to set the dynamic type information.
|
|
void genInitDerived(const fir::MutableBoxValue &box, mlir::Value typeDescAddr,
|
|
int rank, int corank = 0) {
|
|
mlir::func::FuncOp callee =
|
|
box.isPointer()
|
|
? fir::runtime::getRuntimeFunc<mkRTKey(PointerNullifyDerived)>(
|
|
loc, builder)
|
|
: fir::runtime::getRuntimeFunc<mkRTKey(
|
|
AllocatableInitDerivedForAllocate)>(loc, builder);
|
|
|
|
llvm::ArrayRef<mlir::Type> inputTypes =
|
|
callee.getFunctionType().getInputs();
|
|
llvm::SmallVector<mlir::Value> args;
|
|
args.push_back(builder.createConvert(loc, inputTypes[0], box.getAddr()));
|
|
args.push_back(builder.createConvert(loc, inputTypes[1], typeDescAddr));
|
|
mlir::Value rankValue =
|
|
builder.createIntegerConstant(loc, inputTypes[2], rank);
|
|
mlir::Value corankValue =
|
|
builder.createIntegerConstant(loc, inputTypes[3], corank);
|
|
args.push_back(rankValue);
|
|
args.push_back(corankValue);
|
|
builder.create<fir::CallOp>(loc, callee, args);
|
|
}
|
|
|
|
/// Generate call to PointerNullifyIntrinsic or AllocatableInitIntrinsic to
|
|
/// set the dynamic type information for a polymorphic entity from an
|
|
/// intrinsic type spec.
|
|
void genInitIntrinsic(const fir::MutableBoxValue &box,
|
|
const TypeCategory category, int64_t kind, int rank,
|
|
int corank = 0) {
|
|
mlir::func::FuncOp callee =
|
|
box.isPointer()
|
|
? fir::runtime::getRuntimeFunc<mkRTKey(PointerNullifyIntrinsic)>(
|
|
loc, builder)
|
|
: fir::runtime::getRuntimeFunc<mkRTKey(
|
|
AllocatableInitIntrinsicForAllocate)>(loc, builder);
|
|
|
|
llvm::ArrayRef<mlir::Type> inputTypes =
|
|
callee.getFunctionType().getInputs();
|
|
llvm::SmallVector<mlir::Value> args;
|
|
args.push_back(builder.createConvert(loc, inputTypes[0], box.getAddr()));
|
|
mlir::Value categoryValue = builder.createIntegerConstant(
|
|
loc, inputTypes[1], static_cast<int32_t>(category));
|
|
mlir::Value kindValue =
|
|
builder.createIntegerConstant(loc, inputTypes[2], kind);
|
|
mlir::Value rankValue =
|
|
builder.createIntegerConstant(loc, inputTypes[3], rank);
|
|
mlir::Value corankValue =
|
|
builder.createIntegerConstant(loc, inputTypes[4], corank);
|
|
args.push_back(categoryValue);
|
|
args.push_back(kindValue);
|
|
args.push_back(rankValue);
|
|
args.push_back(corankValue);
|
|
builder.create<fir::CallOp>(loc, callee, args);
|
|
}
|
|
|
|
/// Generate call to the AllocatableInitDerived to set up the type descriptor
|
|
/// and other part of the descriptor for derived type.
|
|
void genSetType(const Allocation &alloc, const fir::MutableBoxValue &box,
|
|
mlir::Location loc) {
|
|
const Fortran::semantics::DeclTypeSpec *typeSpec =
|
|
getIfAllocateStmtTypeSpec();
|
|
|
|
// No type spec provided in allocate statement so the declared type spec is
|
|
// used.
|
|
if (!typeSpec)
|
|
typeSpec = &alloc.type;
|
|
assert(typeSpec && "type spec missing for polymorphic allocation");
|
|
|
|
// Set up the descriptor for allocation for intrinsic type spec on
|
|
// unlimited polymorphic entity.
|
|
if (typeSpec->AsIntrinsic() &&
|
|
fir::isUnlimitedPolymorphicType(fir::getBase(box).getType())) {
|
|
if (typeSpec->AsIntrinsic()->category() == TypeCategory::Character) {
|
|
genRuntimeInitCharacter(
|
|
builder, loc, box, lenParams[0],
|
|
Fortran::evaluate::ToInt64(typeSpec->AsIntrinsic()->kind())
|
|
.value());
|
|
} else {
|
|
genInitIntrinsic(
|
|
box, typeSpec->AsIntrinsic()->category(),
|
|
Fortran::evaluate::ToInt64(typeSpec->AsIntrinsic()->kind()).value(),
|
|
alloc.getSymbol().Rank());
|
|
}
|
|
return;
|
|
}
|
|
|
|
// Do not generate calls for non derived-type type spec.
|
|
if (!typeSpec->AsDerived())
|
|
return;
|
|
|
|
auto typeDescAddr = Fortran::lower::getTypeDescAddr(
|
|
converter, loc, typeSpec->derivedTypeSpec());
|
|
genInitDerived(box, typeDescAddr, alloc.getSymbol().Rank());
|
|
}
|
|
|
|
/// 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;
|
|
}
|
|
|
|
mlir::Value genCudaAllocate(fir::FirOpBuilder &builder, mlir::Location loc,
|
|
const fir::MutableBoxValue &box,
|
|
ErrorManager &errorManager,
|
|
const Fortran::semantics::Symbol &sym) {
|
|
Fortran::lower::StatementContext stmtCtx;
|
|
cuf::DataAttributeAttr cudaAttr =
|
|
Fortran::lower::translateSymbolCUFDataAttribute(builder.getContext(),
|
|
sym);
|
|
mlir::Value errmsg = errMsgExpr ? errorManager.errMsgAddr : nullptr;
|
|
mlir::Value stream =
|
|
streamExpr
|
|
? fir::getBase(converter.genExprValue(loc, *streamExpr, stmtCtx))
|
|
: nullptr;
|
|
mlir::Value pinned =
|
|
pinnedExpr
|
|
? fir::getBase(converter.genExprAddr(loc, *pinnedExpr, stmtCtx))
|
|
: nullptr;
|
|
mlir::Value source = sourceExpr ? fir::getBase(sourceExv) : nullptr;
|
|
|
|
// Keep return type the same as a standard AllocatableAllocate call.
|
|
mlir::Type retTy = fir::runtime::getModel<int>()(builder.getContext());
|
|
return builder
|
|
.create<cuf::AllocateOp>(
|
|
loc, retTy, box.getAddr(), errmsg, stream, pinned, source, cudaAttr,
|
|
errorManager.hasStatSpec() ? builder.getUnitAttr() : nullptr)
|
|
.getResult();
|
|
}
|
|
|
|
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};
|
|
const Fortran::lower::SomeExpr *pinnedExpr{nullptr};
|
|
const Fortran::lower::SomeExpr *streamExpr{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;
|
|
// 9.7.1.2(7) The source-expr is evaluated exactly once for each AllocateStmt.
|
|
fir::ExtendedValue sourceExv;
|
|
fir::ExtendedValue moldExv;
|
|
|
|
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();
|
|
}
|
|
|
|
//===----------------------------------------------------------------------===//
|
|
// Deallocate statement implementation
|
|
//===----------------------------------------------------------------------===//
|
|
|
|
static void preDeallocationAction(Fortran::lower::AbstractConverter &converter,
|
|
fir::FirOpBuilder &builder,
|
|
mlir::Value beginOpValue,
|
|
const Fortran::semantics::Symbol &sym) {
|
|
if (sym.test(Fortran::semantics::Symbol::Flag::AccDeclare))
|
|
Fortran::lower::attachDeclarePreDeallocAction(converter, builder,
|
|
beginOpValue, sym);
|
|
}
|
|
|
|
static void postDeallocationAction(Fortran::lower::AbstractConverter &converter,
|
|
fir::FirOpBuilder &builder,
|
|
const Fortran::semantics::Symbol &sym) {
|
|
if (sym.test(Fortran::semantics::Symbol::Flag::AccDeclare))
|
|
Fortran::lower::attachDeclarePostDeallocAction(converter, builder, sym);
|
|
}
|
|
|
|
static mlir::Value genCudaDeallocate(fir::FirOpBuilder &builder,
|
|
mlir::Location loc,
|
|
const fir::MutableBoxValue &box,
|
|
ErrorManager &errorManager,
|
|
const Fortran::semantics::Symbol &sym) {
|
|
cuf::DataAttributeAttr cudaAttr =
|
|
Fortran::lower::translateSymbolCUFDataAttribute(builder.getContext(),
|
|
sym);
|
|
mlir::Value errmsg =
|
|
mlir::isa<fir::AbsentOp>(errorManager.errMsgAddr.getDefiningOp())
|
|
? nullptr
|
|
: errorManager.errMsgAddr;
|
|
|
|
// Keep return type the same as a standard AllocatableAllocate call.
|
|
mlir::Type retTy = fir::runtime::getModel<int>()(builder.getContext());
|
|
return builder
|
|
.create<cuf::DeallocateOp>(
|
|
loc, retTy, box.getAddr(), errmsg, cudaAttr,
|
|
errorManager.hasStatSpec() ? builder.getUnitAttr() : nullptr)
|
|
.getResult();
|
|
}
|
|
|
|
// Generate deallocation of a pointer/allocatable.
|
|
static mlir::Value
|
|
genDeallocate(fir::FirOpBuilder &builder,
|
|
Fortran::lower::AbstractConverter &converter, mlir::Location loc,
|
|
const fir::MutableBoxValue &box, ErrorManager &errorManager,
|
|
mlir::Value declaredTypeDesc = {},
|
|
const Fortran::semantics::Symbol *symbol = nullptr) {
|
|
bool isCudaSymbol = symbol && Fortran::semantics::HasCUDAAttr(*symbol);
|
|
bool isCudaDeviceContext = cuf::isCUDADeviceContext(builder.getRegion());
|
|
bool inlineDeallocation =
|
|
!box.isDerived() && !box.isPolymorphic() && !box.hasAssumedRank() &&
|
|
!box.isUnlimitedPolymorphic() && !errorManager.hasStatSpec() &&
|
|
!useAllocateRuntime && !box.isPointer();
|
|
// Deallocate intrinsic types inline.
|
|
if (inlineDeallocation &&
|
|
((isCudaSymbol && isCudaDeviceContext) || !isCudaSymbol)) {
|
|
// Pointers must use PointerDeallocate so that their deallocations
|
|
// can be validated.
|
|
mlir::Value ret = fir::factory::genFreemem(builder, loc, box);
|
|
if (symbol)
|
|
postDeallocationAction(converter, builder, *symbol);
|
|
return ret;
|
|
}
|
|
// 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;
|
|
if (!isCudaSymbol)
|
|
stat =
|
|
genRuntimeDeallocate(builder, loc, box, errorManager, declaredTypeDesc);
|
|
else
|
|
stat = genCudaDeallocate(builder, loc, box, errorManager, *symbol);
|
|
fir::factory::syncMutableBoxFromIRBox(builder, loc, box);
|
|
if (symbol)
|
|
postDeallocationAction(converter, builder, *symbol);
|
|
errorManager.assignStat(builder, loc, stat);
|
|
return stat;
|
|
}
|
|
|
|
void Fortran::lower::genDeallocateBox(
|
|
Fortran::lower::AbstractConverter &converter,
|
|
const fir::MutableBoxValue &box, mlir::Location loc,
|
|
const Fortran::semantics::Symbol *sym, mlir::Value declaredTypeDesc) {
|
|
const Fortran::lower::SomeExpr *statExpr = nullptr;
|
|
const Fortran::lower::SomeExpr *errMsgExpr = nullptr;
|
|
ErrorManager errorManager;
|
|
errorManager.init(converter, loc, statExpr, errMsgExpr);
|
|
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
|
|
genDeallocate(builder, converter, loc, box, errorManager, declaredTypeDesc,
|
|
sym);
|
|
}
|
|
|
|
void Fortran::lower::genDeallocateIfAllocated(
|
|
Fortran::lower::AbstractConverter &converter,
|
|
const fir::MutableBoxValue &box, mlir::Location loc,
|
|
const Fortran::semantics::Symbol *sym) {
|
|
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
|
|
mlir::Value isAllocated =
|
|
fir::factory::genIsAllocatedOrAssociatedTest(builder, loc, box);
|
|
builder.genIfThen(loc, isAllocated)
|
|
.genThen([&]() {
|
|
if (mlir::Type eleType = box.getEleTy();
|
|
mlir::isa<fir::RecordType>(eleType) && box.isPolymorphic()) {
|
|
mlir::Value declaredTypeDesc = builder.create<fir::TypeDescOp>(
|
|
loc, mlir::TypeAttr::get(eleType));
|
|
genDeallocateBox(converter, box, loc, sym, declaredTypeDesc);
|
|
} else {
|
|
genDeallocateBox(converter, box, loc, sym);
|
|
}
|
|
})
|
|
.end();
|
|
}
|
|
|
|
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))
|
|
Fortran::common::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)) {
|
|
const Fortran::semantics::Symbol &symbol = unwrapSymbol(allocateObject);
|
|
fir::MutableBoxValue box =
|
|
genMutableBoxValue(converter, loc, allocateObject);
|
|
mlir::Value declaredTypeDesc = {};
|
|
if (box.isPolymorphic()) {
|
|
mlir::Type eleType = box.getEleTy();
|
|
if (mlir::isa<fir::RecordType>(eleType))
|
|
if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec =
|
|
symbol.GetType()->AsDerived()) {
|
|
declaredTypeDesc =
|
|
Fortran::lower::getTypeDescAddr(converter, loc, *derivedTypeSpec);
|
|
}
|
|
}
|
|
mlir::Value beginOpValue = genDeallocate(
|
|
builder, converter, loc, box, errorManager, declaredTypeDesc, &symbol);
|
|
preDeallocationAction(converter, builder, beginOpValue, symbol);
|
|
}
|
|
builder.restoreInsertionPoint(insertPt);
|
|
}
|
|
|
|
//===----------------------------------------------------------------------===//
|
|
// MutableBoxValue creation implementation
|
|
//===----------------------------------------------------------------------===//
|
|
|
|
/// Is this symbol a pointer to a pointer array that does not have the
|
|
/// CONTIGUOUS attribute ?
|
|
static inline bool
|
|
isNonContiguousArrayPointer(const Fortran::semantics::Symbol &sym) {
|
|
return Fortran::semantics::IsPointer(sym) && sym.Rank() != 0 &&
|
|
!sym.attrs().test(Fortran::semantics::Attr::CONTIGUOUS);
|
|
}
|
|
|
|
/// Is this symbol a polymorphic pointer?
|
|
static inline bool isPolymorphicPointer(const Fortran::semantics::Symbol &sym) {
|
|
return Fortran::semantics::IsPointer(sym) &&
|
|
Fortran::semantics::IsPolymorphic(sym);
|
|
}
|
|
|
|
/// Is this symbol a polymorphic allocatable?
|
|
static inline bool
|
|
isPolymorphicAllocatable(const Fortran::semantics::Symbol &sym) {
|
|
return Fortran::semantics::IsAllocatable(sym) &&
|
|
Fortran::semantics::IsPolymorphic(sym);
|
|
}
|
|
|
|
/// Is this a local procedure symbol in a procedure that contains internal
|
|
/// procedures ?
|
|
static bool mayBeCapturedInInternalProc(const Fortran::semantics::Symbol &sym) {
|
|
const Fortran::semantics::Scope &owner = sym.owner();
|
|
Fortran::semantics::Scope::Kind kind = owner.kind();
|
|
// Test if this is a procedure scope that contains a subprogram scope that is
|
|
// not an interface.
|
|
if (kind == Fortran::semantics::Scope::Kind::Subprogram ||
|
|
kind == Fortran::semantics::Scope::Kind::MainProgram)
|
|
for (const Fortran::semantics::Scope &childScope : owner.children())
|
|
if (childScope.kind() == Fortran::semantics::Scope::Kind::Subprogram)
|
|
if (const Fortran::semantics::Symbol *childSym = childScope.symbol())
|
|
if (const auto *details =
|
|
childSym->detailsIf<Fortran::semantics::SubprogramDetails>())
|
|
if (!details->isInterface())
|
|
return true;
|
|
return false;
|
|
}
|
|
|
|
/// In case it is safe to track the properties in variables outside a
|
|
/// descriptor, create the variables to hold the mutable properties of the
|
|
/// entity var. The variables are not initialized here.
|
|
static fir::MutableProperties
|
|
createMutableProperties(Fortran::lower::AbstractConverter &converter,
|
|
mlir::Location loc,
|
|
const Fortran::lower::pft::Variable &var,
|
|
mlir::ValueRange nonDeferredParams, bool alwaysUseBox) {
|
|
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
|
|
const Fortran::semantics::Symbol &sym = var.getSymbol();
|
|
// Globals and dummies may be associated, creating local variables would
|
|
// require keeping the values and descriptor before and after every single
|
|
// impure calls in the current scope (not only the ones taking the variable as
|
|
// arguments. All.) Volatile means the variable may change in ways not defined
|
|
// per Fortran, so lowering can most likely not keep the descriptor and values
|
|
// in sync as needed.
|
|
// Pointers to non contiguous arrays need to be represented with a fir.box to
|
|
// account for the discontiguity.
|
|
// Pointer/Allocatable in internal procedure are descriptors in the host link,
|
|
// and it would increase complexity to sync this descriptor with the local
|
|
// values every time the host link is escaping.
|
|
if (alwaysUseBox || var.isGlobal() || Fortran::semantics::IsDummy(sym) ||
|
|
Fortran::semantics::IsFunctionResult(sym) ||
|
|
sym.attrs().test(Fortran::semantics::Attr::VOLATILE) ||
|
|
isNonContiguousArrayPointer(sym) || useAllocateRuntime ||
|
|
useDescForMutableBox || mayBeCapturedInInternalProc(sym) ||
|
|
isPolymorphicPointer(sym) || isPolymorphicAllocatable(sym))
|
|
return {};
|
|
fir::MutableProperties mutableProperties;
|
|
std::string name = converter.mangleName(sym);
|
|
mlir::Type baseAddrTy = converter.genType(sym);
|
|
if (auto boxType = mlir::dyn_cast<fir::BaseBoxType>(baseAddrTy))
|
|
baseAddrTy = boxType.getEleTy();
|
|
// Allocate and set a variable to hold the address.
|
|
// It will be set to null in setUnallocatedStatus.
|
|
mutableProperties.addr = builder.allocateLocal(
|
|
loc, baseAddrTy, name + ".addr", "",
|
|
/*shape=*/std::nullopt, /*typeparams=*/std::nullopt);
|
|
// Allocate variables to hold lower bounds and extents.
|
|
int rank = sym.Rank();
|
|
mlir::Type idxTy = builder.getIndexType();
|
|
for (decltype(rank) i = 0; i < rank; ++i) {
|
|
mlir::Value lboundVar = builder.allocateLocal(
|
|
loc, idxTy, name + ".lb" + std::to_string(i), "",
|
|
/*shape=*/std::nullopt, /*typeparams=*/std::nullopt);
|
|
mlir::Value extentVar = builder.allocateLocal(
|
|
loc, idxTy, name + ".ext" + std::to_string(i), "",
|
|
/*shape=*/std::nullopt, /*typeparams=*/std::nullopt);
|
|
mutableProperties.lbounds.emplace_back(lboundVar);
|
|
mutableProperties.extents.emplace_back(extentVar);
|
|
}
|
|
|
|
// Allocate variable to hold deferred length parameters.
|
|
mlir::Type eleTy = baseAddrTy;
|
|
if (auto newTy = fir::dyn_cast_ptrEleTy(eleTy))
|
|
eleTy = newTy;
|
|
if (auto seqTy = mlir::dyn_cast<fir::SequenceType>(eleTy))
|
|
eleTy = seqTy.getEleTy();
|
|
if (auto record = mlir::dyn_cast<fir::RecordType>(eleTy))
|
|
if (record.getNumLenParams() != 0)
|
|
TODO(loc, "deferred length type parameters.");
|
|
if (fir::isa_char(eleTy) && nonDeferredParams.empty()) {
|
|
mlir::Value lenVar =
|
|
builder.allocateLocal(loc, builder.getCharacterLengthType(),
|
|
name + ".len", "", /*shape=*/std::nullopt,
|
|
/*typeparams=*/std::nullopt);
|
|
mutableProperties.deferredParams.emplace_back(lenVar);
|
|
}
|
|
return mutableProperties;
|
|
}
|
|
|
|
fir::MutableBoxValue Fortran::lower::createMutableBox(
|
|
Fortran::lower::AbstractConverter &converter, mlir::Location loc,
|
|
const Fortran::lower::pft::Variable &var, mlir::Value boxAddr,
|
|
mlir::ValueRange nonDeferredParams, bool alwaysUseBox, unsigned allocator) {
|
|
fir::MutableProperties mutableProperties = createMutableProperties(
|
|
converter, loc, var, nonDeferredParams, alwaysUseBox);
|
|
fir::MutableBoxValue box(boxAddr, nonDeferredParams, mutableProperties);
|
|
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
|
|
if (!var.isGlobal() && !Fortran::semantics::IsDummy(var.getSymbol()))
|
|
fir::factory::disassociateMutableBox(builder, loc, box,
|
|
/*polymorphicSetType=*/false,
|
|
allocator);
|
|
return box;
|
|
}
|
|
|
|
//===----------------------------------------------------------------------===//
|
|
// MutableBoxValue reading interface implementation
|
|
//===----------------------------------------------------------------------===//
|
|
|
|
bool Fortran::lower::isArraySectionWithoutVectorSubscript(
|
|
const Fortran::lower::SomeExpr &expr) {
|
|
return expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) &&
|
|
!Fortran::evaluate::UnwrapWholeSymbolDataRef(expr) &&
|
|
!Fortran::evaluate::HasVectorSubscript(expr);
|
|
}
|
|
|
|
void Fortran::lower::associateMutableBox(
|
|
Fortran::lower::AbstractConverter &converter, mlir::Location loc,
|
|
const fir::MutableBoxValue &box, const Fortran::lower::SomeExpr &source,
|
|
mlir::ValueRange lbounds, Fortran::lower::StatementContext &stmtCtx) {
|
|
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
|
|
if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(source)) {
|
|
fir::factory::disassociateMutableBox(builder, loc, box);
|
|
cuf::genPointerSync(box.getAddr(), builder);
|
|
return;
|
|
}
|
|
if (converter.getLoweringOptions().getLowerToHighLevelFIR()) {
|
|
fir::ExtendedValue rhs = converter.genExprAddr(loc, source, stmtCtx);
|
|
fir::factory::associateMutableBox(builder, loc, box, rhs, lbounds);
|
|
cuf::genPointerSync(box.getAddr(), builder);
|
|
return;
|
|
}
|
|
// The right hand side is not be evaluated into a temp. Array sections can
|
|
// typically be represented as a value of type `!fir.box`. However, an
|
|
// expression that uses vector subscripts cannot be emboxed. In that case,
|
|
// generate a reference to avoid having to later use a fir.rebox to implement
|
|
// the pointer association.
|
|
fir::ExtendedValue rhs = isArraySectionWithoutVectorSubscript(source)
|
|
? converter.genExprBox(loc, source, stmtCtx)
|
|
: converter.genExprAddr(loc, source, stmtCtx);
|
|
|
|
fir::factory::associateMutableBox(builder, loc, box, rhs, lbounds);
|
|
}
|
|
|
|
bool Fortran::lower::isWholeAllocatable(const Fortran::lower::SomeExpr &expr) {
|
|
if (const Fortran::semantics::Symbol *sym =
|
|
Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr))
|
|
return Fortran::semantics::IsAllocatable(sym->GetUltimate());
|
|
return false;
|
|
}
|
|
|
|
bool Fortran::lower::isWholePointer(const Fortran::lower::SomeExpr &expr) {
|
|
if (const Fortran::semantics::Symbol *sym =
|
|
Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr))
|
|
return Fortran::semantics::IsPointer(sym->GetUltimate());
|
|
return false;
|
|
}
|
|
|
|
mlir::Value Fortran::lower::getAssumedCharAllocatableOrPointerLen(
|
|
fir::FirOpBuilder &builder, mlir::Location loc,
|
|
const Fortran::semantics::Symbol &sym, mlir::Value box) {
|
|
// Read length from fir.box (explicit expr cannot safely be re-evaluated
|
|
// here).
|
|
auto readLength = [&]() {
|
|
fir::BoxValue boxLoad =
|
|
builder.create<fir::LoadOp>(loc, fir::getBase(box)).getResult();
|
|
return fir::factory::readCharLen(builder, loc, boxLoad);
|
|
};
|
|
if (Fortran::semantics::IsOptional(sym)) {
|
|
mlir::IndexType idxTy = builder.getIndexType();
|
|
// It is not safe to unconditionally read boxes of optionals in case
|
|
// they are absents. According to 15.5.2.12 3 (9), it is illegal to
|
|
// inquire the length of absent optional, even if non deferred, so
|
|
// it's fine to use undefOp in this case.
|
|
auto isPresent = builder.create<fir::IsPresentOp>(loc, builder.getI1Type(),
|
|
fir::getBase(box));
|
|
mlir::Value len =
|
|
builder.genIfOp(loc, {idxTy}, isPresent, true)
|
|
.genThen(
|
|
[&]() { builder.create<fir::ResultOp>(loc, readLength()); })
|
|
.genElse([&]() {
|
|
auto undef = builder.create<fir::UndefOp>(loc, idxTy);
|
|
builder.create<fir::ResultOp>(loc, undef.getResult());
|
|
})
|
|
.getResults()[0];
|
|
return len;
|
|
}
|
|
|
|
return readLength();
|
|
}
|
|
|
|
mlir::Value Fortran::lower::getTypeDescAddr(
|
|
AbstractConverter &converter, mlir::Location loc,
|
|
const Fortran::semantics::DerivedTypeSpec &typeSpec) {
|
|
mlir::Type typeDesc =
|
|
Fortran::lower::translateDerivedTypeToFIRType(converter, typeSpec);
|
|
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
|
|
return builder.create<fir::TypeDescOp>(loc, mlir::TypeAttr::get(typeDesc));
|
|
}
|