//===-- runtime/derived.cpp -----------------------------------------------===//
//
// 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
//
//===----------------------------------------------------------------------===//
#include "derived.h"
#include "stat.h"
#include "terminator.h"
#include "tools.h"
#include "type-info.h"
#include "flang/Runtime/descriptor.h"
namespace Fortran::runtime {
RT_OFFLOAD_API_GROUP_BEGIN
// Fill "extents" array with the extents of component "comp" from derived type
// instance "derivedInstance".
static RT_API_ATTRS void GetComponentExtents(SubscriptValue (&extents)[maxRank],
const typeInfo::Component &comp, const Descriptor &derivedInstance) {
const typeInfo::Value *bounds{comp.bounds()};
for (int dim{0}; dim < comp.rank(); ++dim) {
auto lb{bounds[2 * dim].GetValue(&derivedInstance).value_or(0)};
auto ub{bounds[2 * dim + 1].GetValue(&derivedInstance).value_or(0)};
extents[dim] = ub >= lb ? static_cast<SubscriptValue>(ub - lb + 1) : 0;
}
}
RT_API_ATTRS int Initialize(const Descriptor &instance,
const typeInfo::DerivedType &derived, Terminator &terminator, bool hasStat,
const Descriptor *errMsg) {
const Descriptor &componentDesc{derived.component()};
std::size_t elements{instance.Elements()};
int stat{StatOk};
// Initialize data components in each element; the per-element iterations
// constitute the inner loops, not the outer ones
std::size_t myComponents{componentDesc.Elements()};
for (std::size_t k{0}; k < myComponents; ++k) {
const auto &comp{
*componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
SubscriptValue at[maxRank];
instance.GetLowerBounds(at);
if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
comp.genre() == typeInfo::Component::Genre::Automatic) {
for (std::size_t j{0}; j++ < elements; instance.IncrementSubscripts(at)) {
Descriptor &allocDesc{
*instance.ElementComponent<Descriptor>(at, comp.offset())};
comp.EstablishDescriptor(allocDesc, instance, terminator);
allocDesc.raw().attribute = CFI_attribute_allocatable;
if (comp.genre() == typeInfo::Component::Genre::Automatic) {
stat = ReturnError(terminator, allocDesc.Allocate(), errMsg, hasStat);
if (stat == StatOk) {
if (const DescriptorAddendum * addendum{allocDesc.Addendum()}) {
if (const auto *derived{addendum->derivedType()}) {
if (!derived->noInitializationNeeded()) {
stat = Initialize(
allocDesc, *derived, terminator, hasStat, errMsg);
}
}
}
}
if (stat != StatOk) {
break;
}
}
}
} else if (const void *init{comp.initialization()}) {
// Explicit initialization of data pointers and
// non-allocatable non-automatic components
std::size_t bytes{comp.SizeInBytes(instance)};
for (std::size_t j{0}; j++ < elements; instance.IncrementSubscripts(at)) {
char *ptr{instance.ElementComponent<char>(at, comp.offset())};
std::memcpy(ptr, init, bytes);
}
} else if (comp.genre() == typeInfo::Component::Genre::Pointer) {
// Data pointers without explicit initialization are established
// so that they are valid right-hand side targets of pointer
// assignment statements.
for (std::size_t j{0}; j++ < elements; instance.IncrementSubscripts(at)) {
Descriptor &ptrDesc{
*instance.ElementComponent<Descriptor>(at, comp.offset())};
comp.EstablishDescriptor(ptrDesc, instance, terminator);
ptrDesc.raw().attribute = CFI_attribute_pointer;
}
} else if (comp.genre() == typeInfo::Component::Genre::Data &&
comp.derivedType() && !comp.derivedType()->noInitializationNeeded()) {
// Default initialization of non-pointer non-allocatable/automatic
// data component. Handles parent component's elements. Recursive.
SubscriptValue extents[maxRank];
GetComponentExtents(extents, comp, instance);
StaticDescriptor<maxRank, true, 0> staticDescriptor;
Descriptor &compDesc{staticDescriptor.descriptor()};
const typeInfo::DerivedType &compType{*comp.derivedType()};
for (std::size_t j{0}; j++ < elements; instance.IncrementSubscripts(at)) {
compDesc.Establish(compType,
instance.ElementComponent<char>(at, comp.offset()), comp.rank(),
extents);
stat = Initialize(compDesc, compType, terminator, hasStat, errMsg);
if (stat != StatOk) {
break;
}
}
}
}
// Initialize procedure pointer components in each element
const Descriptor &procPtrDesc{derived.procPtr()};
std::size_t myProcPtrs{procPtrDesc.Elements()};
for (std::size_t k{0}; k < myProcPtrs; ++k) {
const auto &comp{
*procPtrDesc.ZeroBasedIndexedElement<typeInfo::ProcPtrComponent>(k)};
SubscriptValue at[maxRank];
instance.GetLowerBounds(at);
for (std::size_t j{0}; j++ < elements; instance.IncrementSubscripts(at)) {
auto &pptr{*instance.ElementComponent<typeInfo::ProcedurePointer>(
at, comp.offset)};
pptr = comp.procInitialization;
}
}
return stat;
}
static RT_API_ATTRS const typeInfo::SpecialBinding *FindFinal(
const typeInfo::DerivedType &derived, int rank) {
if (const auto *ranked{derived.FindSpecialBinding(
typeInfo::SpecialBinding::RankFinal(rank))}) {
return ranked;
} else if (const auto *assumed{derived.FindSpecialBinding(
typeInfo::SpecialBinding::Which::AssumedRankFinal)}) {
return assumed;
} else {
return derived.FindSpecialBinding(
typeInfo::SpecialBinding::Which::ElementalFinal);
}
}
static RT_API_ATTRS void CallFinalSubroutine(const Descriptor &descriptor,
const typeInfo::DerivedType &derived, Terminator *terminator) {
if (const auto *special{FindFinal(derived, descriptor.rank())}) {
if (special->which() == typeInfo::SpecialBinding::Which::ElementalFinal) {
std::size_t elements{descriptor.Elements()};
SubscriptValue at[maxRank];
descriptor.GetLowerBounds(at);
if (special->IsArgDescriptor(0)) {
StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
Descriptor &elemDesc{statDesc.descriptor()};
elemDesc = descriptor;
elemDesc.raw().attribute = CFI_attribute_pointer;
elemDesc.raw().rank = 0;
auto *p{special->GetProc<void (*)(const Descriptor &)>()};
for (std::size_t j{0}; j++ < elements;
descriptor.IncrementSubscripts(at)) {
elemDesc.set_base_addr(descriptor.Element<char>(at));
p(elemDesc);
}
} else {
auto *p{special->GetProc<void (*)(char *)>()};
for (std::size_t j{0}; j++ < elements;
descriptor.IncrementSubscripts(at)) {
p(descriptor.Element<char>(at));
}
}
} else {
StaticDescriptor<maxRank, true, 10> statDesc;
Descriptor ©{statDesc.descriptor()};
const Descriptor *argDescriptor{&descriptor};
if (descriptor.rank() > 0 && special->IsArgContiguous(0) &&
!descriptor.IsContiguous()) {
// The FINAL subroutine demands a contiguous array argument, but
// this INTENT(OUT) or intrinsic assignment LHS isn't contiguous.
// Finalize a shallow copy of the data.
copy = descriptor;
copy.set_base_addr(nullptr);
copy.raw().attribute = CFI_attribute_allocatable;
Terminator stubTerminator{"CallFinalProcedure() in Fortran runtime", 0};
RUNTIME_CHECK(terminator ? *terminator : stubTerminator,
copy.Allocate() == CFI_SUCCESS);
ShallowCopyDiscontiguousToContiguous(copy, descriptor);
argDescriptor = ©
}
if (special->IsArgDescriptor(0)) {
StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
Descriptor &tmpDesc{statDesc.descriptor()};
tmpDesc = *argDescriptor;
tmpDesc.raw().attribute = CFI_attribute_pointer;
tmpDesc.Addendum()->set_derivedType(&derived);
auto *p{special->GetProc<void (*)(const Descriptor &)>()};
p(tmpDesc);
} else {
auto *p{special->GetProc<void (*)(char *)>()};
p(argDescriptor->OffsetElement<char>());
}
if (argDescriptor == ©) {
ShallowCopyContiguousToDiscontiguous(descriptor, copy);
copy.Deallocate();
}
}
}
}
// Fortran 2018 subclause 7.5.6.2
RT_API_ATTRS void Finalize(const Descriptor &descriptor,
const typeInfo::DerivedType &derived, Terminator *terminator) {
if (derived.noFinalizationNeeded() || !descriptor.IsAllocated()) {
return;
}
CallFinalSubroutine(descriptor, derived, terminator);
const auto *parentType{derived.GetParentType()};
bool recurse{parentType && !parentType->noFinalizationNeeded()};
// If there's a finalizable parent component, handle it last, as required
// by the Fortran standard (7.5.6.2), and do so recursively with the same
// descriptor so that the rank is preserved.
const Descriptor &componentDesc{derived.component()};
std::size_t myComponents{componentDesc.Elements()};
std::size_t elements{descriptor.Elements()};
for (auto k{recurse ? std::size_t{1}
/* skip first component, it's the parent */
: 0};
k < myComponents; ++k) {
const auto &comp{
*componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
SubscriptValue at[maxRank];
descriptor.GetLowerBounds(at);
if (comp.genre() == typeInfo::Component::Genre::Allocatable &&
comp.category() == TypeCategory::Derived) {
// Component may be polymorphic or unlimited polymorphic. Need to use the
// dynamic type to check whether finalization is needed.
for (std::size_t j{0}; j++ < elements;
descriptor.IncrementSubscripts(at)) {
const Descriptor &compDesc{
*descriptor.ElementComponent<Descriptor>(at, comp.offset())};
if (compDesc.IsAllocated()) {
if (const DescriptorAddendum * addendum{compDesc.Addendum()}) {
if (const typeInfo::DerivedType *
compDynamicType{addendum->derivedType()}) {
if (!compDynamicType->noFinalizationNeeded()) {
Finalize(compDesc, *compDynamicType, terminator);
}
}
}
}
}
} else if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
comp.genre() == typeInfo::Component::Genre::Automatic) {
if (const typeInfo::DerivedType * compType{comp.derivedType()}) {
if (!compType->noFinalizationNeeded()) {
for (std::size_t j{0}; j++ < elements;
descriptor.IncrementSubscripts(at)) {
const Descriptor &compDesc{
*descriptor.ElementComponent<Descriptor>(at, comp.offset())};
if (compDesc.IsAllocated()) {
Finalize(compDesc, *compType, terminator);
}
}
}
}
} else if (comp.genre() == typeInfo::Component::Genre::Data &&
comp.derivedType() && !comp.derivedType()->noFinalizationNeeded()) {
SubscriptValue extents[maxRank];
GetComponentExtents(extents, comp, descriptor);
StaticDescriptor<maxRank, true, 0> staticDescriptor;
Descriptor &compDesc{staticDescriptor.descriptor()};
const typeInfo::DerivedType &compType{*comp.derivedType()};
for (std::size_t j{0}; j++ < elements;
descriptor.IncrementSubscripts(at)) {
compDesc.Establish(compType,
descriptor.ElementComponent<char>(at, comp.offset()), comp.rank(),
extents);
Finalize(compDesc, compType, terminator);
}
}
}
if (recurse) {
StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
Descriptor &tmpDesc{statDesc.descriptor()};
tmpDesc = descriptor;
tmpDesc.raw().attribute = CFI_attribute_pointer;
tmpDesc.Addendum()->set_derivedType(parentType);
tmpDesc.raw().elem_len = parentType->sizeInBytes();
Finalize(tmpDesc, *parentType, terminator);
}
}
// The order of finalization follows Fortran 2018 7.5.6.2, with
// elementwise finalization of non-parent components taking place
// before parent component finalization, and with all finalization
// preceding any deallocation.
RT_API_ATTRS void Destroy(const Descriptor &descriptor, bool finalize,
const typeInfo::DerivedType &derived, Terminator *terminator) {
if (derived.noDestructionNeeded() || !descriptor.IsAllocated()) {
return;
}
if (finalize && !derived.noFinalizationNeeded()) {
Finalize(descriptor, derived, terminator);
}
// Deallocate all direct and indirect allocatable and automatic components.
// Contrary to finalization, the order of deallocation does not matter.
const Descriptor &componentDesc{derived.component()};
std::size_t myComponents{componentDesc.Elements()};
std::size_t elements{descriptor.Elements()};
SubscriptValue at[maxRank];
descriptor.GetLowerBounds(at);
for (std::size_t k{0}; k < myComponents; ++k) {
const auto &comp{
*componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
const bool destroyComp{
comp.derivedType() && !comp.derivedType()->noDestructionNeeded()};
if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
comp.genre() == typeInfo::Component::Genre::Automatic) {
for (std::size_t j{0}; j < elements; ++j) {
Descriptor *d{
descriptor.ElementComponent<Descriptor>(at, comp.offset())};
if (destroyComp) {
Destroy(*d, /*finalize=*/false, *comp.derivedType(), terminator);
}
d->Deallocate();
descriptor.IncrementSubscripts(at);
}
} else if (destroyComp &&
comp.genre() == typeInfo::Component::Genre::Data) {
SubscriptValue extents[maxRank];
GetComponentExtents(extents, comp, descriptor);
StaticDescriptor<maxRank, true, 0> staticDescriptor;
Descriptor &compDesc{staticDescriptor.descriptor()};
const typeInfo::DerivedType &compType{*comp.derivedType()};
for (std::size_t j{0}; j++ < elements;
descriptor.IncrementSubscripts(at)) {
compDesc.Establish(compType,
descriptor.ElementComponent<char>(at, comp.offset()), comp.rank(),
extents);
Destroy(compDesc, /*finalize=*/false, *comp.derivedType(), terminator);
}
}
}
}
RT_API_ATTRS bool HasDynamicComponent(const Descriptor &descriptor) {
if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
if (const auto *derived = addendum->derivedType()) {
// Destruction is needed if and only if there are direct or indirect
// allocatable or automatic components.
return !derived->noDestructionNeeded();
}
}
return false;
}
RT_OFFLOAD_API_GROUP_END
} // namespace Fortran::runtime
Codebase Browser
llvm