517 lines · cpp
1//===-- lib/runtime/derived.cpp ---------------------------------*- C++ -*-===//2//3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.4// See https://llvm.org/LICENSE.txt for license information.5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception6//7//===----------------------------------------------------------------------===//8 9#include "flang-rt/runtime/derived.h"10#include "flang-rt/runtime/descriptor.h"11#include "flang-rt/runtime/stat.h"12#include "flang-rt/runtime/terminator.h"13#include "flang-rt/runtime/tools.h"14#include "flang-rt/runtime/type-info.h"15#include "flang-rt/runtime/work-queue.h"16 17namespace Fortran::runtime {18 19RT_OFFLOAD_API_GROUP_BEGIN20 21// Fill "extents" array with the extents of component "comp" from derived type22// instance "derivedInstance".23static RT_API_ATTRS void GetComponentExtents(SubscriptValue (&extents)[maxRank],24 const typeInfo::Component &comp, const Descriptor &derivedInstance) {25 const typeInfo::Value *bounds{comp.bounds()};26 for (int dim{0}; dim < comp.rank(); ++dim) {27 auto lb{bounds[2 * dim].GetValue(&derivedInstance).value_or(0)};28 auto ub{bounds[2 * dim + 1].GetValue(&derivedInstance).value_or(0)};29 extents[dim] = ub >= lb ? static_cast<SubscriptValue>(ub - lb + 1) : 0;30 }31}32 33RT_API_ATTRS int Initialize(const Descriptor &instance,34 const typeInfo::DerivedType &derived, Terminator &terminator, bool,35 const Descriptor *) {36 WorkQueue workQueue{terminator};37 int status{workQueue.BeginInitialize(instance, derived)};38 return status == StatContinue ? workQueue.Run() : status;39}40 41RT_API_ATTRS int InitializeTicket::Begin(WorkQueue &) {42 if (elements_ == 0) {43 return StatOk;44 } else {45 // Initialize procedure pointer components in the first element,46 // whence they will be copied later into all others.47 const Descriptor &procPtrDesc{derived_.procPtr()};48 std::size_t numProcPtrs{procPtrDesc.InlineElements()};49 char *raw{instance_.OffsetElement<char>()};50 const auto *ppComponent{51 procPtrDesc.OffsetElement<typeInfo::ProcPtrComponent>()};52 for (std::size_t k{0}; k < numProcPtrs; ++k, ++ppComponent) {53 auto &pptr{*reinterpret_cast<typeInfo::ProcedurePointer *>(54 raw + ppComponent->offset)};55 pptr = ppComponent->procInitialization;56 }57 return StatContinue;58 }59}60 61RT_API_ATTRS int InitializeTicket::Continue(WorkQueue &workQueue) {62 // Initialize the data components of the first element.63 char *rawInstance{instance_.OffsetElement<char>()};64 for (; !Componentwise::IsComplete(); SkipToNextComponent()) {65 char *rawComponent{rawInstance + component_->offset()};66 if (component_->genre() == typeInfo::Component::Genre::Allocatable ||67 component_->genre() == typeInfo::Component::Genre::AllocatableDevice) {68 Descriptor &allocDesc{*reinterpret_cast<Descriptor *>(rawComponent)};69 component_->EstablishDescriptor(70 allocDesc, instance_, workQueue.terminator());71 } else if (const void *init{component_->initialization()}) {72 // Explicit initialization of data pointers and73 // non-allocatable non-automatic components74 std::size_t bytes{component_->SizeInBytes(instance_)};75 runtime::memcpy(rawComponent, init, bytes);76 } else if (component_->genre() == typeInfo::Component::Genre::Pointer ||77 component_->genre() == typeInfo::Component::Genre::PointerDevice) {78 // Data pointers without explicit initialization are established79 // so that they are valid right-hand side targets of pointer80 // assignment statements.81 Descriptor &ptrDesc{*reinterpret_cast<Descriptor *>(rawComponent)};82 component_->EstablishDescriptor(83 ptrDesc, instance_, workQueue.terminator());84 } else if (component_->genre() == typeInfo::Component::Genre::Data &&85 component_->derivedType() &&86 !component_->derivedType()->noInitializationNeeded()) {87 // Default initialization of non-pointer non-allocatable/automatic88 // data component. Handles parent component's elements.89 SubscriptValue extents[maxRank];90 GetComponentExtents(extents, *component_, instance_);91 Descriptor &compDesc{componentDescriptor_.descriptor()};92 const typeInfo::DerivedType &compType{*component_->derivedType()};93 compDesc.Establish(compType, rawComponent, component_->rank(), extents);94 if (int status{workQueue.BeginInitialize(compDesc, compType)};95 status != StatOk) {96 SkipToNextComponent();97 return status;98 }99 }100 }101 // The first element is now complete. Copy it into the others.102 if (elements_ < 2) {103 } else {104 auto elementBytes{static_cast<SubscriptValue>(instance_.ElementBytes())};105 if (auto stride{instance_.FixedStride()}) {106 if (*stride == elementBytes) { // contiguous107 for (std::size_t done{1}; done < elements_;) {108 std::size_t chunk{elements_ - done};109 if (chunk > done) {110 chunk = done;111 }112 char *uninitialized{rawInstance + done * *stride};113 runtime::memcpy(uninitialized, rawInstance, chunk * *stride);114 done += chunk;115 }116 } else {117 for (std::size_t done{1}; done < elements_; ++done) {118 char *uninitialized{rawInstance + done * *stride};119 runtime::memcpy(uninitialized, rawInstance, elementBytes);120 }121 }122 } else { // one at a time with subscription123 for (Elementwise::Advance(); !Elementwise::IsComplete();124 Elementwise::Advance()) {125 char *element{instance_.Element<char>(subscripts_)};126 runtime::memcpy(element, rawInstance, elementBytes);127 }128 }129 }130 return StatOk;131}132 133RT_API_ATTRS int InitializeClone(const Descriptor &clone,134 const Descriptor &original, const typeInfo::DerivedType &derived,135 Terminator &terminator, bool hasStat, const Descriptor *errMsg) {136 if (original.IsPointer() || !original.IsAllocated()) {137 return StatOk; // nothing to do138 } else {139 WorkQueue workQueue{terminator};140 int status{workQueue.BeginInitializeClone(141 clone, original, derived, hasStat, errMsg)};142 return status == StatContinue ? workQueue.Run() : status;143 }144}145 146RT_API_ATTRS int InitializeCloneTicket::Continue(WorkQueue &workQueue) {147 while (!IsComplete()) {148 if (component_->genre() == typeInfo::Component::Genre::Allocatable ||149 component_->genre() == typeInfo::Component::Genre::AllocatableDevice) {150 Descriptor &origDesc{*instance_.ElementComponent<Descriptor>(151 subscripts_, component_->offset())};152 if (origDesc.IsAllocated()) {153 Descriptor &cloneDesc{*clone_.ElementComponent<Descriptor>(154 subscripts_, component_->offset())};155 if (phase_ == 0) {156 ++phase_;157 cloneDesc.ApplyMold(origDesc, origDesc.rank());158 if (int stat{ReturnError(workQueue.terminator(),159 cloneDesc.Allocate(kNoAsyncObject), errMsg_, hasStat_)};160 stat != StatOk) {161 return stat;162 }163 if (const DescriptorAddendum *addendum{cloneDesc.Addendum()}) {164 if (const typeInfo::DerivedType *derived{addendum->derivedType()}) {165 if (!derived->noInitializationNeeded()) {166 // Perform default initialization for the allocated element.167 if (int status{workQueue.BeginInitialize(cloneDesc, *derived)};168 status != StatOk) {169 return status;170 }171 }172 }173 }174 }175 if (phase_ == 1) {176 ++phase_;177 if (const DescriptorAddendum *addendum{cloneDesc.Addendum()}) {178 if (const typeInfo::DerivedType *derived{addendum->derivedType()}) {179 // Initialize derived type's allocatables.180 if (int status{workQueue.BeginInitializeClone(181 cloneDesc, origDesc, *derived, hasStat_, errMsg_)};182 status != StatOk) {183 return status;184 }185 }186 }187 }188 }189 Advance();190 } else if (component_->genre() == typeInfo::Component::Genre::Data) {191 if (component_->derivedType()) {192 // Handle nested derived types.193 const typeInfo::DerivedType &compType{*component_->derivedType()};194 SubscriptValue extents[maxRank];195 GetComponentExtents(extents, *component_, instance_);196 Descriptor &origDesc{componentDescriptor_.descriptor()};197 Descriptor &cloneDesc{cloneComponentDescriptor_.descriptor()};198 origDesc.Establish(compType,199 instance_.ElementComponent<char>(subscripts_, component_->offset()),200 component_->rank(), extents);201 cloneDesc.Establish(compType,202 clone_.ElementComponent<char>(subscripts_, component_->offset()),203 component_->rank(), extents);204 Advance();205 if (int status{workQueue.BeginInitializeClone(206 cloneDesc, origDesc, compType, hasStat_, errMsg_)};207 status != StatOk) {208 return status;209 }210 } else {211 SkipToNextComponent();212 }213 } else {214 SkipToNextComponent();215 }216 }217 return StatOk;218}219 220// Fortran 2018 subclause 7.5.6.2221RT_API_ATTRS void Finalize(const Descriptor &descriptor,222 const typeInfo::DerivedType &derived, Terminator *terminator) {223 if (!derived.noFinalizationNeeded() && descriptor.IsAllocated()) {224 Terminator stubTerminator{"Finalize() in Fortran runtime", 0};225 WorkQueue workQueue{terminator ? *terminator : stubTerminator};226 if (workQueue.BeginFinalize(descriptor, derived) == StatContinue) {227 workQueue.Run();228 }229 }230}231 232static RT_API_ATTRS const typeInfo::SpecialBinding *FindFinal(233 const typeInfo::DerivedType &derived, int rank) {234 if (const auto *ranked{derived.FindSpecialBinding(235 typeInfo::SpecialBinding::RankFinal(rank))}) {236 return ranked;237 } else if (const auto *assumed{derived.FindSpecialBinding(238 typeInfo::SpecialBinding::Which::AssumedRankFinal)}) {239 return assumed;240 } else {241 return derived.FindSpecialBinding(242 typeInfo::SpecialBinding::Which::ElementalFinal);243 }244}245 246static RT_API_ATTRS void CallFinalSubroutine(const Descriptor &descriptor,247 const typeInfo::DerivedType &derived, Terminator &terminator) {248 if (const auto *special{FindFinal(derived, descriptor.rank())}) {249 if (special->which() == typeInfo::SpecialBinding::Which::ElementalFinal) {250 std::size_t elements{descriptor.InlineElements()};251 SubscriptValue at[maxRank];252 descriptor.GetLowerBounds(at);253 if (special->IsArgDescriptor(0)) {254 StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;255 Descriptor &elemDesc{statDesc.descriptor()};256 elemDesc = descriptor;257 elemDesc.raw().attribute = CFI_attribute_pointer;258 elemDesc.raw().rank = 0;259 auto *p{special->GetProc<void (*)(const Descriptor &)>()};260 for (std::size_t j{0}; j++ < elements;261 descriptor.IncrementSubscripts(at)) {262 elemDesc.set_base_addr(descriptor.Element<char>(at));263 p(elemDesc);264 }265 } else {266 auto *p{special->GetProc<void (*)(char *)>()};267 for (std::size_t j{0}; j++ < elements;268 descriptor.IncrementSubscripts(at)) {269 p(descriptor.Element<char>(at));270 }271 }272 } else {273 StaticDescriptor<maxRank, true, 10> statDesc;274 Descriptor ©{statDesc.descriptor()};275 const Descriptor *argDescriptor{&descriptor};276 if (descriptor.rank() > 0 && special->specialCaseFlag() &&277 !descriptor.IsContiguous()) {278 // The FINAL subroutine demands a contiguous array argument, but279 // this INTENT(OUT) or intrinsic assignment LHS isn't contiguous.280 // Finalize a shallow copy of the data.281 copy = descriptor;282 copy.set_base_addr(nullptr);283 copy.raw().attribute = CFI_attribute_allocatable;284 RUNTIME_CHECK(terminator, copy.Allocate(kNoAsyncObject) == CFI_SUCCESS);285 ShallowCopyDiscontiguousToContiguous(copy, descriptor);286 argDescriptor = ©287 }288 if (special->IsArgDescriptor(0)) {289 StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;290 Descriptor &tmpDesc{statDesc.descriptor()};291 tmpDesc = *argDescriptor;292 tmpDesc.raw().attribute = CFI_attribute_pointer;293 tmpDesc.Addendum()->set_derivedType(&derived);294 auto *p{special->GetProc<void (*)(const Descriptor &)>()};295 p(tmpDesc);296 } else {297 auto *p{special->GetProc<void (*)(char *)>()};298 p(argDescriptor->OffsetElement<char>());299 }300 if (argDescriptor == ©) {301 ShallowCopyContiguousToDiscontiguous(descriptor, copy);302 copy.Deallocate();303 }304 }305 }306}307 308RT_API_ATTRS int FinalizeTicket::Begin(WorkQueue &workQueue) {309 CallFinalSubroutine(instance_, derived_, workQueue.terminator());310 // If there's a finalizable parent component, handle it last, as required311 // by the Fortran standard (7.5.6.2), and do so recursively with the same312 // descriptor so that the rank is preserved.313 finalizableParentType_ = derived_.GetParentType();314 if (finalizableParentType_) {315 if (finalizableParentType_->noFinalizationNeeded()) {316 finalizableParentType_ = nullptr;317 } else {318 SkipToNextComponent();319 }320 }321 return StatContinue;322}323 324RT_API_ATTRS int FinalizeTicket::Continue(WorkQueue &workQueue) {325 while (!IsComplete()) {326 if ((component_->genre() == typeInfo::Component::Genre::Allocatable ||327 component_->genre() ==328 typeInfo::Component::Genre::AllocatableDevice) &&329 component_->category() == TypeCategory::Derived) {330 // Component may be polymorphic or unlimited polymorphic. Need to use the331 // dynamic type to check whether finalization is needed.332 const Descriptor &compDesc{*instance_.ElementComponent<Descriptor>(333 subscripts_, component_->offset())};334 Advance();335 if (compDesc.IsAllocated()) {336 if (const DescriptorAddendum *addendum{compDesc.Addendum()}) {337 if (const typeInfo::DerivedType *compDynamicType{338 addendum->derivedType()}) {339 if (!compDynamicType->noFinalizationNeeded()) {340 if (int status{341 workQueue.BeginFinalize(compDesc, *compDynamicType)};342 status != StatOk) {343 return status;344 }345 }346 }347 }348 }349 } else if (component_->genre() == typeInfo::Component::Genre::Allocatable ||350 component_->genre() == typeInfo::Component::Genre::AllocatableDevice ||351 component_->genre() == typeInfo::Component::Genre::Automatic) {352 if (const typeInfo::DerivedType *compType{component_->derivedType()};353 compType && !compType->noFinalizationNeeded()) {354 const Descriptor &compDesc{*instance_.ElementComponent<Descriptor>(355 subscripts_, component_->offset())};356 Advance();357 if (compDesc.IsAllocated()) {358 if (int status{workQueue.BeginFinalize(compDesc, *compType)};359 status != StatOk) {360 return status;361 }362 }363 } else {364 SkipToNextComponent();365 }366 } else if (component_->genre() == typeInfo::Component::Genre::Data &&367 component_->derivedType() &&368 !component_->derivedType()->noFinalizationNeeded()) {369 // todo: calculate and use fixedStride_ here as in DestroyTicket to370 // avoid subscripts and repeated descriptor establishment.371 SubscriptValue extents[maxRank];372 GetComponentExtents(extents, *component_, instance_);373 Descriptor &compDesc{componentDescriptor_.descriptor()};374 const typeInfo::DerivedType &compType{*component_->derivedType()};375 compDesc.Establish(compType,376 instance_.ElementComponent<char>(subscripts_, component_->offset()),377 component_->rank(), extents);378 Advance();379 if (int status{workQueue.BeginFinalize(compDesc, compType)};380 status != StatOk) {381 return status;382 }383 } else {384 SkipToNextComponent();385 }386 }387 // Last, do the parent component, if any and finalizable.388 if (finalizableParentType_) {389 Descriptor &tmpDesc{componentDescriptor_.descriptor()};390 tmpDesc = instance_;391 tmpDesc.raw().attribute = CFI_attribute_pointer;392 tmpDesc.Addendum()->set_derivedType(finalizableParentType_);393 tmpDesc.raw().elem_len = finalizableParentType_->sizeInBytes();394 const auto &parentType{*finalizableParentType_};395 finalizableParentType_ = nullptr;396 // Don't return StatOk here if the nested FInalize is still running;397 // it needs this->componentDescriptor_.398 return workQueue.BeginFinalize(tmpDesc, parentType);399 }400 return StatOk;401}402 403// The order of finalization follows Fortran 2018 7.5.6.2, with404// elementwise finalization of non-parent components taking place405// before parent component finalization, and with all finalization406// preceding any deallocation.407RT_API_ATTRS void Destroy(const Descriptor &descriptor, bool finalize,408 const typeInfo::DerivedType &derived, Terminator *terminator) {409 if (descriptor.IsAllocated() && !derived.noDestructionNeeded()) {410 Terminator stubTerminator{"Destroy() in Fortran runtime", 0};411 WorkQueue workQueue{terminator ? *terminator : stubTerminator};412 if (workQueue.BeginDestroy(descriptor, derived, finalize) == StatContinue) {413 workQueue.Run();414 }415 }416}417 418RT_API_ATTRS int DestroyTicket::Begin(WorkQueue &workQueue) {419 if (finalize_ && !derived_.noFinalizationNeeded()) {420 if (int status{workQueue.BeginFinalize(instance_, derived_)};421 status != StatOk && status != StatContinue) {422 return status;423 }424 }425 return StatContinue;426}427 428RT_API_ATTRS int DestroyTicket::Continue(WorkQueue &workQueue) {429 // Deallocate all direct and indirect allocatable and automatic components.430 // Contrary to finalization, the order of deallocation does not matter.431 while (!IsComplete()) {432 const auto *componentDerived{component_->derivedType()};433 if (component_->genre() == typeInfo::Component::Genre::Allocatable ||434 component_->genre() == typeInfo::Component::Genre::AllocatableDevice) {435 if (fixedStride_ &&436 (!componentDerived || componentDerived->noDestructionNeeded())) {437 // common fast path, just deallocate in every element438 char *p{instance_.OffsetElement<char>(component_->offset())};439 for (std::size_t j{0}; j < elements_; ++j, p += *fixedStride_) {440 Descriptor &d{*reinterpret_cast<Descriptor *>(p)};441 d.Deallocate();442 }443 SkipToNextComponent();444 } else {445 Descriptor &d{*instance_.ElementComponent<Descriptor>(446 subscripts_, component_->offset())};447 if (d.IsAllocated()) {448 if (componentDerived && !componentDerived->noDestructionNeeded() &&449 phase_ == 0) {450 if (int status{workQueue.BeginDestroy(451 d, *componentDerived, /*finalize=*/false)};452 status != StatOk) {453 ++phase_;454 return status;455 }456 }457 d.Deallocate();458 }459 Advance();460 }461 } else if (component_->genre() == typeInfo::Component::Genre::Data) {462 if (!componentDerived || componentDerived->noDestructionNeeded()) {463 SkipToNextComponent();464 } else if (fixedStride_) {465 // faster path, no need for subscripts, can reuse descriptor466 char *p{instance_.OffsetElement<char>(467 elementAt_ * *fixedStride_ + component_->offset())};468 Descriptor &compDesc{componentDescriptor_.descriptor()};469 const typeInfo::DerivedType &compType{*componentDerived};470 compDesc.UncheckedScalarEstablish(compType, p);471 for (std::size_t j{elementAt_}; j < elements_;472 ++j, p += *fixedStride_) {473 compDesc.set_base_addr(p);474 ++elementAt_;475 if (int status{workQueue.BeginDestroy(476 compDesc, compType, /*finalize=*/false)};477 status != StatOk) {478 return status;479 }480 }481 SkipToNextComponent();482 } else {483 SubscriptValue extents[maxRank];484 GetComponentExtents(extents, *component_, instance_);485 Descriptor &compDesc{componentDescriptor_.descriptor()};486 const typeInfo::DerivedType &compType{*componentDerived};487 compDesc.Establish(compType,488 instance_.ElementComponent<char>(subscripts_, component_->offset()),489 component_->rank(), extents);490 Advance();491 if (int status{492 workQueue.BeginDestroy(compDesc, compType, /*finalize=*/false)};493 status != StatOk) {494 return status;495 }496 }497 } else {498 SkipToNextComponent();499 }500 }501 return StatOk;502}503 504RT_API_ATTRS bool HasDynamicComponent(const Descriptor &descriptor) {505 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {506 if (const auto *derived = addendum->derivedType()) {507 // Destruction is needed if and only if there are direct or indirect508 // allocatable or automatic components.509 return !derived->noDestructionNeeded();510 }511 }512 return false;513}514 515RT_OFFLOAD_API_GROUP_END516} // namespace Fortran::runtime517