[flang-commits] [flang] [llvm] [flang][runtime] Replace recursion with iterative work queue (WORK IN PROGRESS) (PR #137727)
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Tue Apr 29 14:47:31 PDT 2025
https://github.com/klausler updated https://github.com/llvm/llvm-project/pull/137727
>From 93dc0e7ffd735a7cc076d91ce4f098d1b42a8366 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Wed, 23 Apr 2025 14:44:23 -0700
Subject: [PATCH] [flang][runtime] Replace recursion with iterative work queue
Recursion, both direct and indirect, prevents accurate stack size
calculation at link time for GPU device code. Restructure these
recursive (often mutually so) routines in the Fortran runtime
with new implementations based on an iterative work queue with
suspendable/resumable work tickets: Assign, Initialize, initializeClone,
Finalize, and Destroy.
Default derived type I/O is also recursive, but already disabled.
It can be added to this new framework later if the overall approach
succeeds.
Note that derived type FINAL subroutine calls, defined assignments,
and defined I/O procedures all perform callbacks into user code,
which may well reenter the runtime library. This kind of recursion
is not handled by this change, although it may be possible to do so
in the future using thread-local work queues.
The effects of this restructuring on CPU performance are yet to be
measured.
---
.../include/flang-rt/runtime/work-queue.h | 289 ++++++++++
flang-rt/lib/runtime/CMakeLists.txt | 10 +
flang-rt/lib/runtime/assign.cpp | 542 ++++++++++--------
flang-rt/lib/runtime/derived.cpp | 487 ++++++++--------
flang-rt/lib/runtime/type-info.cpp | 6 +-
flang-rt/lib/runtime/work-queue.cpp | 175 ++++++
flang/include/flang/Runtime/assign.h | 2 +-
flang/runtime/CMakeLists.txt | 2 +
8 files changed, 1027 insertions(+), 486 deletions(-)
create mode 100644 flang-rt/include/flang-rt/runtime/work-queue.h
create mode 100644 flang-rt/lib/runtime/work-queue.cpp
diff --git a/flang-rt/include/flang-rt/runtime/work-queue.h b/flang-rt/include/flang-rt/runtime/work-queue.h
new file mode 100644
index 0000000000000..743c9ffcf0ede
--- /dev/null
+++ b/flang-rt/include/flang-rt/runtime/work-queue.h
@@ -0,0 +1,289 @@
+//===-- include/flang-rt/runtime/work-queue.h -------------------*- C++ -*-===//
+//
+// 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
+//
+//===----------------------------------------------------------------------===//
+
+// Internal runtime utilities for work queues that replace the use of recursion
+// for better GPU device support.
+//
+// A work queue is a list of tickets. Each ticket class has a Begin()
+// member function that is called once, and a Continue() member function
+// that can be called zero or more times. A ticket's execution terminates
+// when either of these member functions returns a status other than
+// StatOkContinue, and if that status is not StatOk, then the whole queue
+// is shut down.
+//
+// By returning StatOkContinue from its Continue() member function,
+// a ticket suspends its execution so that any nested tickets that it
+// may have created can be run to completion. It is the reponsibility
+// of each ticket class to maintain resumption information in its state
+// and manage its own progress. Most ticket classes inherit from
+// class ComponentTicketBase, which implements an outer loop over all
+// components of a derived type, and an inner loop over all elements
+// of a descriptor, possibly with multiple phases of execution per element.
+//
+// Tickets are created by WorkQueue::Begin...() member functions.
+// There is one of these for each "top level" recursive function in the
+// Fortran runtime support library that has been restructured into this
+// ticket framework.
+//
+// When the work queue is running tickets, it always selects the last ticket
+// on the list for execution -- "work stack" might have been a more accurate
+// name for this framework. This ticket may, while doing its job, create
+// new tickets, and since those are pushed after the active one, the first
+// such nested ticket will be the next one executed to completion -- i.e.,
+// the order of nested WorkQueue::Begin...() calls is respected.
+// Note that a ticket's Continue() member function won't be called again
+// until all nested tickets have run to completion and it is once again
+// the last ticket on the queue.
+//
+// Example for an assignment to a derived type:
+// 1. Assign() is called, and its work queue is created. It calls
+// WorkQueue::BeginAssign() and then WorkQueue::Run().
+// 2. Run calls AssignTicket::Begin(), which pushes a tickets via
+// BeginFinalize() and returns StatOkContinue.
+// 3. FinalizeTicket::Begin() and FinalizeTicket::Continue() are called
+// until one of them returns StatOk, which ends the finalization ticket.
+// 4. AssignTicket::Continue() is then called; it creates a DerivedAssignTicket
+// and then returns StatOk, which ends the ticket.
+// 5. At this point, only one ticket remains. DerivedAssignTicket::Begin()
+// and ::Continue() are called until they are done (not StatOkContinue).
+// Along the way, it may create nested AssignTickets for components,
+// and suspend itself so that they may each run to completion.
+
+#ifndef FLANG_RT_RUNTIME_WORK_QUEUE_H_
+#define FLANG_RT_RUNTIME_WORK_QUEUE_H_
+
+#include "flang-rt/runtime/descriptor.h"
+#include "flang-rt/runtime/stat.h"
+#include "flang/Common/api-attrs.h"
+#include "flang/Runtime/freestanding-tools.h"
+#include <flang/Common/variant.h>
+
+namespace Fortran::runtime {
+class Terminator;
+class WorkQueue;
+namespace typeInfo {
+class DerivedType;
+class Component;
+} // namespace typeInfo
+
+// Ticket workers
+
+// Ticket workers return status codes. Returning StatOkContinue means
+// that the ticket is incomplete and must be resumed; any other value
+// means that the ticket is complete, and if not StatOk, the whole
+// queue can be shut down due to an error.
+static constexpr int StatOkContinue{1234};
+
+struct NullTicket {
+ RT_API_ATTRS int Begin(WorkQueue &) const { return StatOk; }
+ RT_API_ATTRS int Continue(WorkQueue &) const { return StatOk; }
+};
+
+// Base class for ticket workers that operate elementwise over descriptors
+// TODO: if ComponentTicketBase remains this class' only client,
+// merge them for better comprehensibility.
+class ElementalTicketBase {
+protected:
+ RT_API_ATTRS ElementalTicketBase(const Descriptor &instance)
+ : instance_{instance} {
+ instance_.GetLowerBounds(subscripts_);
+ }
+ RT_API_ATTRS bool CueUpNextItem() const { return elementAt_ < elements_; }
+ RT_API_ATTRS void AdvanceToNextElement() {
+ phase_ = 0;
+ ++elementAt_;
+ instance_.IncrementSubscripts(subscripts_);
+ }
+ RT_API_ATTRS void Reset() {
+ phase_ = 0;
+ elementAt_ = 0;
+ instance_.GetLowerBounds(subscripts_);
+ }
+
+ const Descriptor &instance_;
+ std::size_t elements_{instance_.Elements()};
+ std::size_t elementAt_{0};
+ int phase_{0};
+ SubscriptValue subscripts_[common::maxRank];
+};
+
+// Base class for ticket workers that operate over derived type components
+// in an outer loop, and elements in an inner loop.
+class ComponentTicketBase : protected ElementalTicketBase {
+protected:
+ RT_API_ATTRS ComponentTicketBase(
+ const Descriptor &instance, const typeInfo::DerivedType &derived);
+ RT_API_ATTRS bool CueUpNextItem();
+ RT_API_ATTRS void AdvanceToNextComponent() { elementAt_ = elements_; }
+
+ const typeInfo::DerivedType &derived_;
+ const typeInfo::Component *component_{nullptr};
+ std::size_t components_{0}, componentAt_{0};
+ StaticDescriptor<common::maxRank, true, 0> componentDescriptor_;
+};
+
+// Implements derived type instance initialization
+class InitializeTicket : private ComponentTicketBase {
+public:
+ RT_API_ATTRS InitializeTicket(
+ const Descriptor &instance, const typeInfo::DerivedType &derived)
+ : ComponentTicketBase{instance, derived} {}
+ RT_API_ATTRS int Begin(WorkQueue &);
+ RT_API_ATTRS int Continue(WorkQueue &);
+};
+
+// Initializes one derived type instance from the value of another
+class InitializeCloneTicket : private ComponentTicketBase {
+public:
+ RT_API_ATTRS InitializeCloneTicket(const Descriptor &clone,
+ const Descriptor &original, const typeInfo::DerivedType &derived,
+ bool hasStat, const Descriptor *errMsg)
+ : ComponentTicketBase{original, derived}, clone_{clone},
+ hasStat_{hasStat}, errMsg_{errMsg} {}
+ RT_API_ATTRS int Begin(WorkQueue &) { return StatOkContinue; }
+ RT_API_ATTRS int Continue(WorkQueue &);
+
+private:
+ const Descriptor &clone_;
+ bool hasStat_{false};
+ const Descriptor *errMsg_{nullptr};
+ StaticDescriptor<common::maxRank, true, 0> cloneComponentDescriptor_;
+};
+
+// Implements derived type instance finalization
+class FinalizeTicket : private ComponentTicketBase {
+public:
+ RT_API_ATTRS FinalizeTicket(
+ const Descriptor &instance, const typeInfo::DerivedType &derived)
+ : ComponentTicketBase{instance, derived} {}
+ RT_API_ATTRS int Begin(WorkQueue &);
+ RT_API_ATTRS int Continue(WorkQueue &);
+
+private:
+ const typeInfo::DerivedType *finalizableParentType_{nullptr};
+};
+
+// Implements derived type instance destruction
+class DestroyTicket : private ComponentTicketBase {
+public:
+ RT_API_ATTRS DestroyTicket(const Descriptor &instance,
+ const typeInfo::DerivedType &derived, bool finalize)
+ : ComponentTicketBase{instance, derived}, finalize_{finalize} {}
+ RT_API_ATTRS int Begin(WorkQueue &);
+ RT_API_ATTRS int Continue(WorkQueue &);
+
+private:
+ bool finalize_{false};
+};
+
+// Implements general intrinsic assignment
+class AssignTicket {
+public:
+ RT_API_ATTRS AssignTicket(
+ Descriptor &to, const Descriptor &from, int flags, MemmoveFct memmoveFct)
+ : to_{to}, from_{&from}, flags_{flags}, memmoveFct_{memmoveFct} {}
+ RT_API_ATTRS int Begin(WorkQueue &);
+ RT_API_ATTRS int Continue(WorkQueue &);
+
+private:
+ RT_API_ATTRS bool IsSimpleMemmove() const {
+ return !toDerived_ && to_.rank() == from_->rank() && to_.IsContiguous() &&
+ from_->IsContiguous() && to_.ElementBytes() == from_->ElementBytes();
+ }
+ RT_API_ATTRS Descriptor &GetTempDescriptor();
+
+ Descriptor &to_;
+ const Descriptor *from_{nullptr};
+ int flags_{0}; // enum AssignFlags
+ MemmoveFct memmoveFct_{nullptr};
+ StaticDescriptor<common::maxRank, true, 0> tempDescriptor_;
+ const typeInfo::DerivedType *toDerived_{nullptr};
+ Descriptor *toDeallocate_{nullptr};
+ bool persist_{false};
+ bool done_{false};
+};
+
+// Implements derived type intrinsic assignment
+class DerivedAssignTicket : private ComponentTicketBase {
+public:
+ RT_API_ATTRS DerivedAssignTicket(const Descriptor &to, const Descriptor &from,
+ const typeInfo::DerivedType &derived, int flags, MemmoveFct memmoveFct,
+ Descriptor *deallocateAfter)
+ : ComponentTicketBase{to, derived}, from_{from}, flags_{flags},
+ memmoveFct_{memmoveFct}, deallocateAfter_{deallocateAfter} {}
+ RT_API_ATTRS int Begin(WorkQueue &);
+ RT_API_ATTRS int Continue(WorkQueue &);
+ RT_API_ATTRS void AdvanceToNextElement();
+
+private:
+ const Descriptor &from_;
+ int flags_{0};
+ MemmoveFct memmoveFct_{nullptr};
+ Descriptor *deallocateAfter_{nullptr};
+ SubscriptValue fromSubscripts_[common::maxRank];
+ StaticDescriptor<common::maxRank, true, 0> fromComponentDescriptor_;
+};
+
+struct Ticket {
+ RT_API_ATTRS int Continue(WorkQueue &);
+ bool begun{false};
+ std::variant<NullTicket, InitializeTicket, InitializeCloneTicket,
+ FinalizeTicket, DestroyTicket, AssignTicket, DerivedAssignTicket>
+ u;
+};
+
+class WorkQueue {
+public:
+ RT_API_ATTRS explicit WorkQueue(Terminator &terminator)
+ : terminator_{terminator} {
+ for (int j{1}; j < numStatic_; ++j) {
+ static_[j].previous = &static_[j - 1];
+ static_[j - 1].next = &static_[j];
+ }
+ }
+ RT_API_ATTRS ~WorkQueue();
+ RT_API_ATTRS Terminator &terminator() { return terminator_; };
+
+ RT_API_ATTRS void BeginInitialize(
+ const Descriptor &descriptor, const typeInfo::DerivedType &derived);
+ RT_API_ATTRS void BeginInitializeClone(const Descriptor &clone,
+ const Descriptor &original, const typeInfo::DerivedType &derived,
+ bool hasStat, const Descriptor *errMsg);
+ RT_API_ATTRS void BeginFinalize(
+ const Descriptor &descriptor, const typeInfo::DerivedType &derived);
+ RT_API_ATTRS void BeginDestroy(const Descriptor &descriptor,
+ const typeInfo::DerivedType &derived, bool finalize);
+ RT_API_ATTRS void BeginAssign(
+ Descriptor &to, const Descriptor &from, int flags, MemmoveFct memmoveFct);
+ RT_API_ATTRS void BeginDerivedAssign(Descriptor &to, const Descriptor &from,
+ const typeInfo::DerivedType &derived, int flags, MemmoveFct memmoveFct,
+ Descriptor *deallocateAfter);
+
+ RT_API_ATTRS int Run();
+
+private:
+ // Most uses of the work queue won't go very deep.
+ static constexpr int numStatic_{2};
+
+ struct TicketList {
+ bool isStatic{true};
+ Ticket ticket;
+ TicketList *previous{nullptr}, *next{nullptr};
+ };
+
+ RT_API_ATTRS Ticket &StartTicket();
+ RT_API_ATTRS void Stop();
+
+ Terminator &terminator_;
+ TicketList *first_{nullptr}, *last_{nullptr}, *insertAfter_{nullptr};
+ TicketList static_[numStatic_];
+ TicketList *firstFree_{static_};
+};
+
+} // namespace Fortran::runtime
+#endif // FLANG_RT_RUNTIME_WORK_QUEUE_H_
diff --git a/flang-rt/lib/runtime/CMakeLists.txt b/flang-rt/lib/runtime/CMakeLists.txt
index c5e7bdce5b2fd..a0ebcf4157ff5 100644
--- a/flang-rt/lib/runtime/CMakeLists.txt
+++ b/flang-rt/lib/runtime/CMakeLists.txt
@@ -12,6 +12,14 @@ find_package(Backtrace)
set(HAVE_BACKTRACE ${Backtrace_FOUND})
set(BACKTRACE_HEADER ${Backtrace_HEADER})
+# BE ADVISED: If you are about to add a new source file to one or more
+# of "supported_sources", "host_sources", or "gpu_sources" lists, you
+# probably need to also add that file to "flang/runtime/CMakeLists.txt",
+# which still exists and is still used for some purposes. If you do not,
+# you will get confusing unsatisfied external references when unit tests
+# are linked. I don't know why things are this way or whether anybody
+# is going to fix it. Hope this helps!
+
# List of files that are buildable for all devices.
set(supported_sources
${FLANG_SOURCE_DIR}/lib/Decimal/binary-to-decimal.cpp
@@ -67,6 +75,7 @@ set(supported_sources
type-info.cpp
unit.cpp
utf.cpp
+ work-queue.cpp
)
# List of source not used for GPU offloading.
@@ -130,6 +139,7 @@ set(gpu_sources
type-code.cpp
type-info.cpp
utf.cpp
+ work-queue.cpp
complex-powi.cpp
reduce.cpp
reduction.cpp
diff --git a/flang-rt/lib/runtime/assign.cpp b/flang-rt/lib/runtime/assign.cpp
index 4a813cd489022..054d9672bcf11 100644
--- a/flang-rt/lib/runtime/assign.cpp
+++ b/flang-rt/lib/runtime/assign.cpp
@@ -14,6 +14,7 @@
#include "flang-rt/runtime/terminator.h"
#include "flang-rt/runtime/tools.h"
#include "flang-rt/runtime/type-info.h"
+#include "flang-rt/runtime/work-queue.h"
namespace Fortran::runtime {
@@ -99,11 +100,7 @@ static RT_API_ATTRS int AllocateAssignmentLHS(
toDim.SetByteStride(stride);
stride *= toDim.Extent();
}
- int result{ReturnError(terminator, to.Allocate(kNoAsyncId))};
- if (result == StatOk && derived && !derived->noInitializationNeeded()) {
- result = ReturnError(terminator, Initialize(to, *derived, terminator));
- }
- return result;
+ return ReturnError(terminator, to.Allocate(kNoAsyncId));
}
// least <= 0, most >= 0
@@ -228,6 +225,8 @@ static RT_API_ATTRS void BlankPadCharacterAssignment(Descriptor &to,
}
}
+RT_OFFLOAD_API_GROUP_BEGIN
+
// Common implementation of assignments, both intrinsic assignments and
// those cases of polymorphic user-defined ASSIGNMENT(=) TBPs that could not
// be resolved in semantics. Most assignment statements do not need any
@@ -241,274 +240,339 @@ static RT_API_ATTRS void BlankPadCharacterAssignment(Descriptor &to,
// dealing with array constructors.
RT_API_ATTRS void Assign(Descriptor &to, const Descriptor &from,
Terminator &terminator, int flags, MemmoveFct memmoveFct) {
- bool mustDeallocateLHS{(flags & DeallocateLHS) ||
- MustDeallocateLHS(to, from, terminator, flags)};
- DescriptorAddendum *toAddendum{to.Addendum()};
- const typeInfo::DerivedType *toDerived{
- toAddendum ? toAddendum->derivedType() : nullptr};
- if (toDerived && (flags & NeedFinalization) &&
- toDerived->noFinalizationNeeded()) {
- flags &= ~NeedFinalization;
- }
- std::size_t toElementBytes{to.ElementBytes()};
- std::size_t fromElementBytes{from.ElementBytes()};
- // The following lambda definition violates the conding style,
- // but cuda-11.8 nvcc hits an internal error with the brace initialization.
- auto isSimpleMemmove = [&]() {
- return !toDerived && to.rank() == from.rank() && to.IsContiguous() &&
- from.IsContiguous() && toElementBytes == fromElementBytes;
- };
- StaticDescriptor<maxRank, true, 10 /*?*/> deferredDeallocStatDesc;
- Descriptor *deferDeallocation{nullptr};
- if (MayAlias(to, from)) {
+ WorkQueue workQueue{terminator};
+ workQueue.BeginAssign(to, from, flags, memmoveFct);
+ workQueue.Run();
+}
+
+RT_API_ATTRS int AssignTicket::Begin(WorkQueue &workQueue) {
+ bool mustDeallocateLHS{(flags_ & DeallocateLHS) ||
+ MustDeallocateLHS(to_, *from_, workQueue.terminator(), flags_)};
+ DescriptorAddendum *toAddendum{to_.Addendum()};
+ toDerived_ = toAddendum ? toAddendum->derivedType() : nullptr;
+ if (toDerived_ && (flags_ & NeedFinalization) &&
+ toDerived_->noFinalizationNeeded()) {
+ flags_ &= ~NeedFinalization;
+ }
+ const typeInfo::SpecialBinding *scalarDefinedAssignment{nullptr};
+ const typeInfo::SpecialBinding *elementalDefinedAssignment{nullptr};
+ if (toDerived_ && (flags_ & CanBeDefinedAssignment)) {
+ // Check for a user-defined assignment type-bound procedure;
+ // see 10.2.1.4-5. A user-defined assignment TBP defines all of
+ // the semantics, including allocatable (re)allocation and any
+ // finalization.
+ //
+ // Note that the aliasing and LHS (re)allocation handling below
+ // needs to run even with CanBeDefinedAssignment flag, since
+ // Assign() can be invoked recursively for component-wise assignments.
+ if (to_.rank() == 0) {
+ scalarDefinedAssignment = toDerived_->FindSpecialBinding(
+ typeInfo::SpecialBinding::Which::ScalarAssignment);
+ }
+ if (!scalarDefinedAssignment) {
+ elementalDefinedAssignment = toDerived_->FindSpecialBinding(
+ typeInfo::SpecialBinding::Which::ElementalAssignment);
+ }
+ }
+ if (MayAlias(to_, *from_)) {
if (mustDeallocateLHS) {
- deferDeallocation = &deferredDeallocStatDesc.descriptor();
+ // Convert the LHS into a temporary, then make it look deallocated.
+ toDeallocate_ = &tempDescriptor_.descriptor();
+ persist_ = true; // tempDescriptor_ state must outlive child tickets
std::memcpy(
- reinterpret_cast<void *>(deferDeallocation), &to, to.SizeInBytes());
- to.set_base_addr(nullptr);
- } else if (!isSimpleMemmove()) {
+ reinterpret_cast<void *>(toDeallocate_), &to_, to_.SizeInBytes());
+ to_.set_base_addr(nullptr);
+ } else if (!IsSimpleMemmove() || scalarDefinedAssignment ||
+ elementalDefinedAssignment) {
// Handle LHS/RHS aliasing by copying RHS into a temp, then
// recursively assigning from that temp.
- auto descBytes{from.SizeInBytes()};
- StaticDescriptor<maxRank, true, 16> staticDesc;
- Descriptor &newFrom{staticDesc.descriptor()};
- std::memcpy(reinterpret_cast<void *>(&newFrom), &from, descBytes);
+ auto descBytes{from_->SizeInBytes()};
+ Descriptor &newFrom{tempDescriptor_.descriptor()};
+ persist_ = true; // tempDescriptor_ state must outlive child tickets
+ std::memcpy(reinterpret_cast<void *>(&newFrom), from_, descBytes);
// Pretend the temporary descriptor is for an ALLOCATABLE
// entity, otherwise, the Deallocate() below will not
// free the descriptor memory.
newFrom.raw().attribute = CFI_attribute_allocatable;
- auto stat{ReturnError(terminator, newFrom.Allocate(kNoAsyncId))};
- if (stat == StatOk) {
- if (HasDynamicComponent(from)) {
- // If 'from' has allocatable/automatic component, we cannot
- // just make a shallow copy of the descriptor member.
- // This will still leave data overlap in 'to' and 'newFrom'.
- // For example:
- // type t
- // character, allocatable :: c(:)
- // end type t
- // type(t) :: x(3)
- // x(2:3) = x(1:2)
- // We have to make a deep copy into 'newFrom' in this case.
- RTNAME(AssignTemporary)
- (newFrom, from, terminator.sourceFileName(), terminator.sourceLine());
- } else {
- ShallowCopy(newFrom, from, true, from.IsContiguous());
+ if (int stat{ReturnError(
+ workQueue.terminator(), newFrom.Allocate(kNoAsyncId))};
+ stat != StatOk) {
+ return stat;
+ }
+ if (HasDynamicComponent(*from_)) {
+ // If 'from' has allocatable/automatic component, we cannot
+ // just make a shallow copy of the descriptor member.
+ // This will still leave data overlap in 'to' and 'newFrom'.
+ // For example:
+ // type t
+ // character, allocatable :: c(:)
+ // end type t
+ // type(t) :: x(3)
+ // x(2:3) = x(1:2)
+ // We have to make a deep copy into 'newFrom' in this case.
+ if (const DescriptorAddendum * addendum{newFrom.Addendum()}) {
+ if (const auto *derived{addendum->derivedType()}) {
+ if (!derived->noInitializationNeeded()) {
+ workQueue.BeginInitialize(newFrom, *derived);
+ }
+ }
}
- Assign(to, newFrom, terminator,
- flags &
- (NeedFinalization | ComponentCanBeDefinedAssignment |
- ExplicitLengthCharacterLHS | CanBeDefinedAssignment));
- newFrom.Deallocate();
+ workQueue.BeginAssign(
+ newFrom, *from_, MaybeReallocate | PolymorphicLHS, memmoveFct_);
+ } else {
+ ShallowCopy(newFrom, *from_, true, from_->IsContiguous());
}
- return;
+ from_ = &newFrom;
+ flags_ &= NeedFinalization | ComponentCanBeDefinedAssignment |
+ ExplicitLengthCharacterLHS | CanBeDefinedAssignment;
+ toDeallocate_ = &newFrom;
}
+ if (toDeallocate_ && toDerived_ && (flags_ & NeedFinalization)) {
+ // Schedule finalization for the RHS temporary or old LHS.
+ workQueue.BeginFinalize(*toDeallocate_, *toDerived_);
+ flags_ &= ~NeedFinalization;
+ }
+ }
+ if (scalarDefinedAssignment) {
+ DoScalarDefinedAssignment(to_, *from_, *scalarDefinedAssignment);
+ done_ = true;
+ return StatOkContinue;
+ } else if (elementalDefinedAssignment) {
+ DoElementalDefinedAssignment(
+ to_, *from_, *toDerived_, *elementalDefinedAssignment);
+ done_ = true;
+ return StatOk;
}
- if (to.IsAllocatable()) {
+ if (to_.IsAllocatable()) {
if (mustDeallocateLHS) {
- if (deferDeallocation) {
- if ((flags & NeedFinalization) && toDerived) {
- Finalize(*deferDeallocation, *toDerived, &terminator);
- flags &= ~NeedFinalization;
- }
- } else {
- to.Destroy((flags & NeedFinalization) != 0, /*destroyPointers=*/false,
- &terminator);
- flags &= ~NeedFinalization;
+ if (!toDeallocate_ && to_.IsAllocated()) {
+ toDeallocate_ = &to_;
}
- } else if (to.rank() != from.rank() && !to.IsAllocated()) {
- terminator.Crash("Assign: mismatched ranks (%d != %d) in assignment to "
- "unallocated allocatable",
- to.rank(), from.rank());
+ } else if (to_.rank() != from_->rank() && !to_.IsAllocated()) {
+ workQueue.terminator().Crash("Assign: mismatched ranks (%d != %d) in "
+ "assignment to unallocated allocatable",
+ to_.rank(), from_->rank());
}
- if (!to.IsAllocated()) {
- if (AllocateAssignmentLHS(to, from, terminator, flags) != StatOk) {
- return;
- }
- flags &= ~NeedFinalization;
- toElementBytes = to.ElementBytes(); // may have changed
+ } else if (!to_.IsAllocated()) {
+ workQueue.terminator().Crash(
+ "Assign: left-hand side variable is neither allocated nor allocatable");
+ }
+ if (toDerived_ && to_.IsAllocated()) {
+ // Schedule finalization or destruction of the LHS.
+ if (flags_ & NeedFinalization) {
+ workQueue.BeginFinalize(to_, *toDerived_);
+ } else if (!toDerived_->noDestructionNeeded()) {
+ workQueue.BeginDestroy(to_, *toDerived_, /*finalize=*/false);
}
}
- if (toDerived && (flags & CanBeDefinedAssignment)) {
- // Check for a user-defined assignment type-bound procedure;
- // see 10.2.1.4-5. A user-defined assignment TBP defines all of
- // the semantics, including allocatable (re)allocation and any
- // finalization.
- //
- // Note that the aliasing and LHS (re)allocation handling above
- // needs to run even with CanBeDefinedAssignment flag, when
- // the Assign() is invoked recursively for component-per-component
- // assignments.
- if (to.rank() == 0) {
- if (const auto *special{toDerived->FindSpecialBinding(
- typeInfo::SpecialBinding::Which::ScalarAssignment)}) {
- return DoScalarDefinedAssignment(to, from, *special);
+ return StatOkContinue;
+}
+
+RT_API_ATTRS int AssignTicket::Continue(WorkQueue &workQueue) {
+ if (done_) {
+ // All child tickets are complete; can release this ticket's state.
+ if (toDeallocate_) {
+ toDeallocate_->Deallocate();
+ }
+ return StatOk;
+ }
+ // All necessary finalization or destruction that was initiated by Begin()
+ // has been completed. Deallocation may be pending, and if it's for the LHS,
+ // do it now so that the LHS gets reallocated.
+ if (toDeallocate_ == &to_) {
+ toDeallocate_ = nullptr;
+ to_.Deallocate();
+ }
+ if (!to_.IsAllocated()) {
+ if (int stat{
+ AllocateAssignmentLHS(to_, *from_, workQueue.terminator(), flags_)};
+ stat != StatOk) {
+ return stat;
+ }
+ if (const auto *addendum{from_->Addendum()}) {
+ if (const auto *derived{addendum->derivedType()}) {
+ toDerived_ = derived;
}
}
- if (const auto *special{toDerived->FindSpecialBinding(
- typeInfo::SpecialBinding::Which::ElementalAssignment)}) {
- return DoElementalDefinedAssignment(to, from, *toDerived, *special);
+ if (toDerived_ && !toDerived_->noInitializationNeeded()) {
+ workQueue.BeginInitialize(to_, *toDerived_);
}
}
- SubscriptValue toAt[maxRank];
- to.GetLowerBounds(toAt);
- // Scalar expansion of the RHS is implied by using the same empty
- // subscript values on each (seemingly) elemental reference into
- // "from".
- SubscriptValue fromAt[maxRank];
- from.GetLowerBounds(fromAt);
- std::size_t toElements{to.Elements()};
- if (from.rank() > 0 && toElements != from.Elements()) {
- terminator.Crash("Assign: mismatching element counts in array assignment "
- "(to %zd, from %zd)",
- toElements, from.Elements());
+ std::size_t toElements{to_.Elements()};
+ if (from_->rank() > 0 && toElements != from_->Elements()) {
+ workQueue.terminator().Crash("Assign: mismatching element counts in array "
+ "assignment (to %zd, from %zd)",
+ toElements, from_->Elements());
}
- if (to.type() != from.type()) {
- terminator.Crash("Assign: mismatching types (to code %d != from code %d)",
- to.type().raw(), from.type().raw());
+ if (to_.type() != from_->type()) {
+ workQueue.terminator().Crash(
+ "Assign: mismatching types (to code %d != from code %d)",
+ to_.type().raw(), from_->type().raw());
}
- if (toElementBytes > fromElementBytes && !to.type().IsCharacter()) {
- terminator.Crash("Assign: mismatching non-character element sizes (to %zd "
- "bytes != from %zd bytes)",
+ std::size_t toElementBytes{to_.ElementBytes()};
+ std::size_t fromElementBytes{from_->ElementBytes()};
+ if (toElementBytes > fromElementBytes && !to_.type().IsCharacter()) {
+ workQueue.terminator().Crash("Assign: mismatching non-character element "
+ "sizes (to %zd bytes != from %zd bytes)",
toElementBytes, fromElementBytes);
}
- if (const typeInfo::DerivedType *
- updatedToDerived{toAddendum ? toAddendum->derivedType() : nullptr}) {
- // Derived type intrinsic assignment, which is componentwise and elementwise
- // for all components, including parent components (10.2.1.2-3).
- // The target is first finalized if still necessary (7.5.6.3(1))
- if (flags & NeedFinalization) {
- Finalize(to, *updatedToDerived, &terminator);
- } else if (updatedToDerived && !updatedToDerived->noDestructionNeeded()) {
- Destroy(to, /*finalize=*/false, *updatedToDerived, &terminator);
- }
- // Copy the data components (incl. the parent) first.
- const Descriptor &componentDesc{updatedToDerived->component()};
- std::size_t numComponents{componentDesc.Elements()};
- for (std::size_t j{0}; j < toElements;
- ++j, to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
- for (std::size_t k{0}; k < numComponents; ++k) {
- const auto &comp{
- *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(
- k)}; // TODO: exploit contiguity here
- // Use PolymorphicLHS for components so that the right things happen
- // when the components are polymorphic; when they're not, they're both
- // not, and their declared types will match.
- int nestedFlags{MaybeReallocate | PolymorphicLHS};
- if (flags & ComponentCanBeDefinedAssignment) {
- nestedFlags |=
- CanBeDefinedAssignment | ComponentCanBeDefinedAssignment;
- }
- switch (comp.genre()) {
- case typeInfo::Component::Genre::Data:
- if (comp.category() == TypeCategory::Derived) {
- StaticDescriptor<maxRank, true, 10 /*?*/> statDesc[2];
- Descriptor &toCompDesc{statDesc[0].descriptor()};
- Descriptor &fromCompDesc{statDesc[1].descriptor()};
- comp.CreatePointerDescriptor(toCompDesc, to, terminator, toAt);
- comp.CreatePointerDescriptor(
- fromCompDesc, from, terminator, fromAt);
- Assign(toCompDesc, fromCompDesc, terminator, nestedFlags);
- } else { // Component has intrinsic type; simply copy raw bytes
- std::size_t componentByteSize{comp.SizeInBytes(to)};
- memmoveFct(to.Element<char>(toAt) + comp.offset(),
- from.Element<const char>(fromAt) + comp.offset(),
- componentByteSize);
- }
+ if (toDerived_) {
+ workQueue.BeginDerivedAssign(
+ to_, *from_, *toDerived_, flags_, memmoveFct_, toDeallocate_);
+ toDeallocate_ = nullptr;
+ } else {
+ if (IsSimpleMemmove()) {
+ memmoveFct_(to_.raw().base_addr, from_->raw().base_addr,
+ toElements * toElementBytes);
+ } else {
+ // Scalar expansion of the RHS is implied by using the same empty
+ // subscript values on each (seemingly) elemental reference into
+ // "from".
+ SubscriptValue toAt[maxRank];
+ to_.GetLowerBounds(toAt);
+ SubscriptValue fromAt[maxRank];
+ from_->GetLowerBounds(fromAt);
+ if (toElementBytes > fromElementBytes) { // blank padding
+ switch (to_.type().raw()) {
+ case CFI_type_signed_char:
+ case CFI_type_char:
+ BlankPadCharacterAssignment<char>(to_, *from_, toAt, fromAt,
+ toElements, toElementBytes, fromElementBytes);
break;
- case typeInfo::Component::Genre::Pointer: {
- std::size_t componentByteSize{comp.SizeInBytes(to)};
- memmoveFct(to.Element<char>(toAt) + comp.offset(),
- from.Element<const char>(fromAt) + comp.offset(),
- componentByteSize);
- } break;
- case typeInfo::Component::Genre::Allocatable:
- case typeInfo::Component::Genre::Automatic: {
- auto *toDesc{reinterpret_cast<Descriptor *>(
- to.Element<char>(toAt) + comp.offset())};
- const auto *fromDesc{reinterpret_cast<const Descriptor *>(
- from.Element<char>(fromAt) + comp.offset())};
- // Allocatable components of the LHS are unconditionally
- // deallocated before assignment (F'2018 10.2.1.3(13)(1)),
- // unlike a "top-level" assignment to a variable, where
- // deallocation is optional.
- //
- // Be careful not to destroy/reallocate the LHS, if there is
- // overlap between LHS and RHS (it seems that partial overlap
- // is not possible, though).
- // Invoke Assign() recursively to deal with potential aliasing.
- if (toDesc->IsAllocatable()) {
- if (!fromDesc->IsAllocated()) {
- // No aliasing.
- //
- // If to is not allocated, the Destroy() call is a no-op.
- // This is just a shortcut, because the recursive Assign()
- // below would initiate the destruction for to.
- // No finalization is required.
- toDesc->Destroy(
- /*finalize=*/false, /*destroyPointers=*/false, &terminator);
- continue; // F'2018 10.2.1.3(13)(2)
- }
- }
- // Force LHS deallocation with DeallocateLHS flag.
- // The actual deallocation may be avoided, if the existing
- // location can be reoccupied.
- Assign(*toDesc, *fromDesc, terminator, nestedFlags | DeallocateLHS);
- } break;
+ case CFI_type_char16_t:
+ BlankPadCharacterAssignment<char16_t>(to_, *from_, toAt, fromAt,
+ toElements, toElementBytes, fromElementBytes);
+ break;
+ case CFI_type_char32_t:
+ BlankPadCharacterAssignment<char32_t>(to_, *from_, toAt, fromAt,
+ toElements, toElementBytes, fromElementBytes);
+ break;
+ default:
+ workQueue.terminator().Crash(
+ "unexpected type code %d in blank padded Assign()",
+ to_.type().raw());
+ }
+ } else { // elemental copies, possibly with character truncation
+ for (std::size_t n{toElements}; n-- > 0;
+ to_.IncrementSubscripts(toAt), from_->IncrementSubscripts(fromAt)) {
+ memmoveFct_(to_.Element<char>(toAt),
+ from_->Element<const char>(fromAt), toElementBytes);
}
- }
- // Copy procedure pointer components
- const Descriptor &procPtrDesc{updatedToDerived->procPtr()};
- std::size_t numProcPtrs{procPtrDesc.Elements()};
- for (std::size_t k{0}; k < numProcPtrs; ++k) {
- const auto &procPtr{
- *procPtrDesc.ZeroBasedIndexedElement<typeInfo::ProcPtrComponent>(
- k)};
- memmoveFct(to.Element<char>(toAt) + procPtr.offset,
- from.Element<const char>(fromAt) + procPtr.offset,
- sizeof(typeInfo::ProcedurePointer));
}
}
- } else { // intrinsic type, intrinsic assignment
- if (isSimpleMemmove()) {
- memmoveFct(to.raw().base_addr, from.raw().base_addr,
- toElements * toElementBytes);
- } else if (toElementBytes > fromElementBytes) { // blank padding
- switch (to.type().raw()) {
- case CFI_type_signed_char:
- case CFI_type_char:
- BlankPadCharacterAssignment<char>(to, from, toAt, fromAt, toElements,
- toElementBytes, fromElementBytes);
- break;
- case CFI_type_char16_t:
- BlankPadCharacterAssignment<char16_t>(to, from, toAt, fromAt,
- toElements, toElementBytes, fromElementBytes);
- break;
- case CFI_type_char32_t:
- BlankPadCharacterAssignment<char32_t>(to, from, toAt, fromAt,
- toElements, toElementBytes, fromElementBytes);
- break;
- default:
- terminator.Crash("unexpected type code %d in blank padded Assign()",
- to.type().raw());
+ }
+ if (persist_) {
+ done_ = true;
+ return StatOkContinue;
+ }
+ if (toDeallocate_) {
+ toDeallocate_->Deallocate();
+ toDeallocate_ = nullptr;
+ }
+ return StatOk;
+}
+
+RT_API_ATTRS int DerivedAssignTicket::Begin(WorkQueue &workQueue) {
+ from_.GetLowerBounds(fromSubscripts_);
+ // Use PolymorphicLHS for components so that the right things happen
+ // when the components are polymorphic; when they're not, they're both
+ // not, and their declared types will match.
+ int nestedFlags{MaybeReallocate | PolymorphicLHS};
+ if (flags_ & ComponentCanBeDefinedAssignment) {
+ nestedFlags |= CanBeDefinedAssignment | ComponentCanBeDefinedAssignment;
+ }
+ flags_ = nestedFlags;
+ // Copy procedure pointer components
+ const Descriptor &procPtrDesc{derived_.procPtr()};
+ std::size_t numProcPtrs{procPtrDesc.Elements()};
+ for (std::size_t k{0}; k < numProcPtrs; ++k) {
+ const auto &procPtr{
+ *procPtrDesc.ZeroBasedIndexedElement<typeInfo::ProcPtrComponent>(k)};
+ memmoveFct_(instance_.Element<char>(subscripts_) + procPtr.offset,
+ from_.Element<const char>(fromSubscripts_) + procPtr.offset,
+ sizeof(typeInfo::ProcedurePointer));
+ }
+ return StatOkContinue;
+}
+
+RT_API_ATTRS int DerivedAssignTicket::Continue(WorkQueue &workQueue) {
+ for (; CueUpNextItem(); AdvanceToNextElement()) {
+ // Copy the data components (incl. the parent) first.
+ switch (component_->genre()) {
+ case typeInfo::Component::Genre::Data:
+ if (component_->category() == TypeCategory::Derived) {
+ Descriptor &toCompDesc{componentDescriptor_.descriptor()};
+ Descriptor &fromCompDesc{fromComponentDescriptor_.descriptor()};
+ component_->CreatePointerDescriptor(
+ toCompDesc, instance_, workQueue.terminator(), subscripts_);
+ component_->CreatePointerDescriptor(
+ fromCompDesc, from_, workQueue.terminator(), fromSubscripts_);
+ AdvanceToNextElement();
+ workQueue.BeginAssign(toCompDesc, fromCompDesc, flags_, memmoveFct_);
+ return StatOkContinue;
+ } else { // Component has intrinsic type; simply copy raw bytes
+ std::size_t componentByteSize{component_->SizeInBytes(instance_)};
+ memmoveFct_(instance_.Element<char>(subscripts_) + component_->offset(),
+ from_.Element<const char>(fromSubscripts_) + component_->offset(),
+ componentByteSize);
}
- } else { // elemental copies, possibly with character truncation
- for (std::size_t n{toElements}; n-- > 0;
- to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
- memmoveFct(to.Element<char>(toAt), from.Element<const char>(fromAt),
- toElementBytes);
+ break;
+ case typeInfo::Component::Genre::Pointer: {
+ std::size_t componentByteSize{component_->SizeInBytes(instance_)};
+ memmoveFct_(instance_.Element<char>(subscripts_) + component_->offset(),
+ from_.Element<const char>(fromSubscripts_) + component_->offset(),
+ componentByteSize);
+ } break;
+ case typeInfo::Component::Genre::Allocatable:
+ case typeInfo::Component::Genre::Automatic: {
+ auto *toDesc{reinterpret_cast<Descriptor *>(
+ instance_.Element<char>(subscripts_) + component_->offset())};
+ const auto *fromDesc{reinterpret_cast<const Descriptor *>(
+ from_.Element<char>(fromSubscripts_) + component_->offset())};
+ if (toDesc->IsAllocatable() && !fromDesc->IsAllocated()) {
+ if (toDesc->IsAllocated()) {
+ if (phase_ == 0) {
+ ++phase_;
+ if (const auto *componentDerived{component_->derivedType()};
+ componentDerived && !componentDerived->noDestructionNeeded()) {
+ workQueue.BeginDestroy(
+ *toDesc, *componentDerived, /*finalize=*/false);
+ return StatOkContinue;
+ }
+ }
+ toDesc->Deallocate();
+ }
+ } else {
+ // Allocatable components of the LHS are unconditionally
+ // deallocated before assignment (F'2018 10.2.1.3(13)(1)),
+ // unlike a "top-level" assignment to a variable, where
+ // deallocation is optional.
+ //
+ // Be careful not to destroy/reallocate the LHS, if there is
+ // overlap between LHS and RHS (it seems that partial overlap
+ // is not possible, though).
+ // Invoke Assign() recursively to deal with potential aliasing.
+ // Force LHS deallocation with DeallocateLHS flag.
+ // The actual deallocation may be avoided, if the existing
+ // location can be reoccupied.
+ workQueue.BeginAssign(
+ *toDesc, *fromDesc, flags_ | DeallocateLHS, memmoveFct_);
+ AdvanceToNextElement();
+ return StatOkContinue;
}
+ } break;
}
}
- if (deferDeallocation) {
- // deferDeallocation is used only when LHS is an allocatable.
- // The finalization has already been run for it.
- deferDeallocation->Destroy(
- /*finalize=*/false, /*destroyPointers=*/false, &terminator);
+ if (deallocateAfter_) {
+ deallocateAfter_->Deallocate();
}
+ return StatOk;
}
-RT_OFFLOAD_API_GROUP_BEGIN
+RT_API_ATTRS void DerivedAssignTicket::AdvanceToNextElement() {
+ ComponentTicketBase::AdvanceToNextElement();
+ from_.IncrementSubscripts(fromSubscripts_);
+}
RT_API_ATTRS void DoFromSourceAssign(Descriptor &alloc,
const Descriptor &source, Terminator &terminator, MemmoveFct memmoveFct) {
@@ -578,7 +642,6 @@ void RTDEF(AssignTemporary)(Descriptor &to, const Descriptor &from,
}
}
}
-
Assign(to, from, terminator, MaybeReallocate | PolymorphicLHS);
}
@@ -597,8 +660,9 @@ void RTDEF(CopyOutAssign)(
// Copyout from the temporary must not cause any finalizations
// for LHS. The variable must be properly initialized already.
- if (var)
+ if (var) {
Assign(*var, temp, terminator, NoAssignFlags);
+ }
temp.Destroy(/*finalize=*/false, /*destroyPointers=*/false, &terminator);
}
diff --git a/flang-rt/lib/runtime/derived.cpp b/flang-rt/lib/runtime/derived.cpp
index c46ea806a430a..0f461f529fae6 100644
--- a/flang-rt/lib/runtime/derived.cpp
+++ b/flang-rt/lib/runtime/derived.cpp
@@ -12,6 +12,7 @@
#include "flang-rt/runtime/terminator.h"
#include "flang-rt/runtime/tools.h"
#include "flang-rt/runtime/type-info.h"
+#include "flang-rt/runtime/work-queue.h"
namespace Fortran::runtime {
@@ -30,180 +31,174 @@ static RT_API_ATTRS void GetComponentExtents(SubscriptValue (&extents)[maxRank],
}
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 typeInfo::DerivedType &derived, Terminator &terminator, bool,
+ const Descriptor *) {
+ WorkQueue workQueue{terminator};
+ workQueue.BeginInitialize(instance, derived);
+ return workQueue.Run();
+}
+
+RT_API_ATTRS int InitializeTicket::Begin(WorkQueue &) {
+ // 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{
- *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
+ *procPtrDesc.ZeroBasedIndexedElement<typeInfo::ProcPtrComponent>(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);
+ 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 StatOkContinue;
+}
+
+RT_API_ATTRS int InitializeTicket::Continue(WorkQueue &workQueue) {
+ while (CueUpNextItem()) {
+ if (component_->genre() == typeInfo::Component::Genre::Allocatable) {
+ // Establish allocatable descriptors
+ for (; elementAt_ < elements_; AdvanceToNextElement()) {
+ Descriptor &allocDesc{*instance_.ElementComponent<Descriptor>(
+ subscripts_, component_->offset())};
+ component_->EstablishDescriptor(
+ allocDesc, instance_, workQueue.terminator());
allocDesc.raw().attribute = CFI_attribute_allocatable;
- if (comp.genre() == typeInfo::Component::Genre::Automatic) {
- stat = ReturnError(
- terminator, allocDesc.Allocate(kNoAsyncId), 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()}) {
+ } else if (const void *init{component_->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::size_t bytes{component_->SizeInBytes(instance_)};
+ for (; elementAt_ < elements_; AdvanceToNextElement()) {
+ char *ptr{instance_.ElementComponent<char>(
+ subscripts_, component_->offset())};
std::memcpy(ptr, init, bytes);
}
- } else if (comp.genre() == typeInfo::Component::Genre::Pointer) {
+ } else if (component_->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);
+ for (; elementAt_ < elements_; AdvanceToNextElement()) {
+ Descriptor &ptrDesc{*instance_.ElementComponent<Descriptor>(
+ subscripts_, component_->offset())};
+ component_->EstablishDescriptor(
+ ptrDesc, instance_, workQueue.terminator());
ptrDesc.raw().attribute = CFI_attribute_pointer;
}
- } else if (comp.genre() == typeInfo::Component::Genre::Data &&
- comp.derivedType() && !comp.derivedType()->noInitializationNeeded()) {
+ } else if (component_->genre() == typeInfo::Component::Genre::Data &&
+ component_->derivedType() &&
+ !component_->derivedType()->noInitializationNeeded()) {
// Default initialization of non-pointer non-allocatable/automatic
- // data component. Handles parent component's elements. Recursive.
+ // data component. Handles parent component's elements.
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;
+ GetComponentExtents(extents, *component_, instance_);
+ Descriptor &compDesc{componentDescriptor_.descriptor()};
+ const typeInfo::DerivedType &compType{*component_->derivedType()};
+ compDesc.Establish(compType,
+ instance_.ElementComponent<char>(subscripts_, component_->offset()),
+ component_->rank(), extents);
+ AdvanceToNextElement();
+ workQueue.BeginInitialize(compDesc, compType);
+ return StatOkContinue;
+ } else {
+ AdvanceToNextComponent();
}
}
- return stat;
+ return StatOk;
}
RT_API_ATTRS int InitializeClone(const Descriptor &clone,
- const Descriptor &orig, const typeInfo::DerivedType &derived,
+ const Descriptor &original, const typeInfo::DerivedType &derived,
Terminator &terminator, bool hasStat, const Descriptor *errMsg) {
- const Descriptor &componentDesc{derived.component()};
- std::size_t elements{orig.Elements()};
- int stat{StatOk};
-
- // Skip pointers and unallocated variables.
- if (orig.IsPointer() || !orig.IsAllocated()) {
- return stat;
+ if (original.IsPointer() || !original.IsAllocated()) {
+ return StatOk; // nothing to do
+ } else {
+ WorkQueue workQueue{terminator};
+ workQueue.BeginInitializeClone(clone, original, derived, hasStat, errMsg);
+ return workQueue.Run();
}
- // Initialize each data component.
- std::size_t components{componentDesc.Elements()};
- for (std::size_t i{0}; i < components; ++i) {
- const typeInfo::Component &comp{
- *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(i)};
- SubscriptValue at[maxRank];
- orig.GetLowerBounds(at);
- // Allocate allocatable components that are also allocated in the original
- // object.
- if (comp.genre() == typeInfo::Component::Genre::Allocatable) {
- // Initialize each element.
- for (std::size_t j{0}; j < elements; ++j, orig.IncrementSubscripts(at)) {
- Descriptor &origDesc{
- *orig.ElementComponent<Descriptor>(at, comp.offset())};
- Descriptor &cloneDesc{
- *clone.ElementComponent<Descriptor>(at, comp.offset())};
- if (origDesc.IsAllocated()) {
+}
+
+RT_API_ATTRS int InitializeCloneTicket::Continue(WorkQueue &workQueue) {
+ while (CueUpNextItem()) {
+ if (component_->genre() == typeInfo::Component::Genre::Allocatable) {
+ Descriptor &origDesc{*instance_.ElementComponent<Descriptor>(
+ subscripts_, component_->offset())};
+ if (origDesc.IsAllocated()) {
+ Descriptor &cloneDesc{*clone_.ElementComponent<Descriptor>(
+ subscripts_, component_->offset())};
+ if (phase_ == 0) {
+ ++phase_;
cloneDesc.ApplyMold(origDesc, origDesc.rank());
- stat = ReturnError(
- terminator, cloneDesc.Allocate(kNoAsyncId), errMsg, hasStat);
- if (stat == StatOk) {
- if (const DescriptorAddendum * addendum{cloneDesc.Addendum()}) {
- if (const typeInfo::DerivedType *
- derived{addendum->derivedType()}) {
- if (!derived->noInitializationNeeded()) {
- // Perform default initialization for the allocated element.
- stat = Initialize(
- cloneDesc, *derived, terminator, hasStat, errMsg);
- }
- // Initialize derived type's allocatables.
- if (stat == StatOk) {
- stat = InitializeClone(cloneDesc, origDesc, *derived,
- terminator, hasStat, errMsg);
- }
+ if (int stat{ReturnError(workQueue.terminator(),
+ cloneDesc.Allocate(kNoAsyncId), errMsg_, hasStat_)};
+ stat != StatOk) {
+ return stat;
+ }
+ if (const DescriptorAddendum * addendum{cloneDesc.Addendum()}) {
+ if (const typeInfo::DerivedType *
+ derived{addendum->derivedType()}) {
+ if (!derived->noInitializationNeeded()) {
+ // Perform default initialization for the allocated element.
+ workQueue.BeginInitialize(cloneDesc, *derived);
+ return StatOkContinue;
}
}
}
}
- if (stat != StatOk) {
- break;
+ if (phase_ == 1) {
+ ++phase_;
+ if (const DescriptorAddendum * addendum{cloneDesc.Addendum()}) {
+ if (const typeInfo::DerivedType *
+ derived{addendum->derivedType()}) {
+ // Initialize derived type's allocatables.
+ workQueue.BeginInitializeClone(
+ cloneDesc, origDesc, *derived, hasStat_, errMsg_);
+ return StatOkContinue;
+ }
+ }
}
}
- } else if (comp.genre() == typeInfo::Component::Genre::Data &&
- comp.derivedType()) {
- // Handle nested derived types.
- const typeInfo::DerivedType &compType{*comp.derivedType()};
- SubscriptValue extents[maxRank];
- GetComponentExtents(extents, comp, orig);
- // Data components don't have descriptors, allocate them.
- StaticDescriptor<maxRank, true, 0> origStaticDesc;
- StaticDescriptor<maxRank, true, 0> cloneStaticDesc;
- Descriptor &origDesc{origStaticDesc.descriptor()};
- Descriptor &cloneDesc{cloneStaticDesc.descriptor()};
- // Initialize each element.
- for (std::size_t j{0}; j < elements; ++j, orig.IncrementSubscripts(at)) {
+ AdvanceToNextElement();
+ } else if (component_->genre() == typeInfo::Component::Genre::Data) {
+ if (component_->derivedType()) {
+ // Handle nested derived types.
+ const typeInfo::DerivedType &compType{*component_->derivedType()};
+ SubscriptValue extents[maxRank];
+ GetComponentExtents(extents, *component_, instance_);
+ Descriptor &origDesc{componentDescriptor_.descriptor()};
+ Descriptor &cloneDesc{cloneComponentDescriptor_.descriptor()};
origDesc.Establish(compType,
- orig.ElementComponent<char>(at, comp.offset()), comp.rank(),
- extents);
+ instance_.ElementComponent<char>(subscripts_, component_->offset()),
+ component_->rank(), extents);
cloneDesc.Establish(compType,
- clone.ElementComponent<char>(at, comp.offset()), comp.rank(),
- extents);
- stat = InitializeClone(
- cloneDesc, origDesc, compType, terminator, hasStat, errMsg);
- if (stat != StatOk) {
- break;
- }
+ clone_.ElementComponent<char>(subscripts_, component_->offset()),
+ component_->rank(), extents);
+ workQueue.BeginInitializeClone(
+ cloneDesc, origDesc, compType, hasStat_, errMsg_);
+ AdvanceToNextElement();
+ return StatOkContinue; // will resume at next element in this component
+ } else {
+ AdvanceToNextComponent();
}
+ } else {
+ AdvanceToNextComponent();
}
}
- return stat;
+ return StatOk;
+}
+
+// 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()) {
+ Terminator stubTerminator{"Finalize() in Fortran runtime", 0};
+ WorkQueue workQueue{terminator ? *terminator : stubTerminator};
+ workQueue.BeginFinalize(descriptor, derived);
+ workQueue.Run();
+ }
}
static RT_API_ATTRS const typeInfo::SpecialBinding *FindFinal(
@@ -221,7 +216,7 @@ static RT_API_ATTRS const typeInfo::SpecialBinding *FindFinal(
}
static RT_API_ATTRS void CallFinalSubroutine(const Descriptor &descriptor,
- const typeInfo::DerivedType &derived, Terminator *terminator) {
+ 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()};
@@ -258,9 +253,7 @@ static RT_API_ATTRS void CallFinalSubroutine(const Descriptor &descriptor,
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(kNoAsyncId) == CFI_SUCCESS);
+ RUNTIME_CHECK(terminator, copy.Allocate(kNoAsyncId) == CFI_SUCCESS);
ShallowCopyDiscontiguousToContiguous(copy, descriptor);
argDescriptor = ©
}
@@ -284,86 +277,84 @@ static RT_API_ATTRS void CallFinalSubroutine(const Descriptor &descriptor,
}
}
-// 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()};
+RT_API_ATTRS int FinalizeTicket::Begin(WorkQueue &workQueue) {
+ CallFinalSubroutine(instance_, derived_, workQueue.terminator());
// 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) {
+ finalizableParentType_ = derived_.GetParentType();
+ if (finalizableParentType_) {
+ if (!finalizableParentType_->noFinalizationNeeded()) {
+ componentAt_ = 1;
+ } else {
+ finalizableParentType_ = nullptr;
+ }
+ }
+ return StatOkContinue;
+}
+
+RT_API_ATTRS int FinalizeTicket::Continue(WorkQueue &workQueue) {
+ while (CueUpNextItem()) {
+ if (component_->genre() == typeInfo::Component::Genre::Allocatable &&
+ component_->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);
- }
+ const Descriptor &compDesc{*instance_.ElementComponent<Descriptor>(
+ subscripts_, component_->offset())};
+ AdvanceToNextElement();
+ if (compDesc.IsAllocated()) {
+ if (const DescriptorAddendum * addendum{compDesc.Addendum()}) {
+ if (const typeInfo::DerivedType *
+ compDynamicType{addendum->derivedType()}) {
+ if (!compDynamicType->noFinalizationNeeded()) {
+ workQueue.BeginFinalize(compDesc, *compDynamicType);
+ return StatOkContinue;
}
}
}
}
- } 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 (component_->genre() == typeInfo::Component::Genre::Allocatable ||
+ component_->genre() == typeInfo::Component::Genre::Automatic) {
+ if (const typeInfo::DerivedType * compType{component_->derivedType()};
+ compType && !compType->noFinalizationNeeded()) {
+ const Descriptor &compDesc{*instance_.ElementComponent<Descriptor>(
+ subscripts_, component_->offset())};
+ AdvanceToNextElement();
+ if (compDesc.IsAllocated()) {
+ workQueue.BeginFinalize(compDesc, *compType);
}
+ } else {
+ AdvanceToNextComponent();
}
- } else if (comp.genre() == typeInfo::Component::Genre::Data &&
- comp.derivedType() && !comp.derivedType()->noFinalizationNeeded()) {
+ } else if (component_->genre() == typeInfo::Component::Genre::Data &&
+ component_->derivedType() &&
+ !component_->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);
- }
+ GetComponentExtents(extents, *component_, instance_);
+ Descriptor &compDesc{componentDescriptor_.descriptor()};
+ const typeInfo::DerivedType &compType{*component_->derivedType()};
+ compDesc.Establish(compType,
+ instance_.ElementComponent<char>(subscripts_, component_->offset()),
+ component_->rank(), extents);
+ AdvanceToNextElement();
+ workQueue.BeginFinalize(compDesc, compType);
+ return StatOkContinue;
+ } else {
+ AdvanceToNextComponent();
}
}
- if (recurse) {
- StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
- Descriptor &tmpDesc{statDesc.descriptor()};
- tmpDesc = descriptor;
+ // Last, do the parent component, if any and finalizable.
+ if (finalizableParentType_) {
+ Descriptor &tmpDesc{componentDescriptor_.descriptor()};
+ tmpDesc = instance_;
tmpDesc.raw().attribute = CFI_attribute_pointer;
- tmpDesc.Addendum()->set_derivedType(parentType);
- tmpDesc.raw().elem_len = parentType->sizeInBytes();
- Finalize(tmpDesc, *parentType, terminator);
+ tmpDesc.Addendum()->set_derivedType(finalizableParentType_);
+ tmpDesc.raw().elem_len = finalizableParentType_->sizeInBytes();
+ workQueue.BeginFinalize(tmpDesc, *finalizableParentType_);
+ finalizableParentType_ = nullptr;
+ return StatOkContinue;
+ } else {
+ return StatOk;
}
}
@@ -373,51 +364,61 @@ RT_API_ATTRS void Finalize(const Descriptor &descriptor,
// 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 (!derived.noFinalizationNeeded() && descriptor.IsAllocated()) {
+ Terminator stubTerminator{"Destroy() in Fortran runtime", 0};
+ WorkQueue workQueue{terminator ? *terminator : stubTerminator};
+ workQueue.BeginDestroy(descriptor, derived, finalize);
+ workQueue.Run();
}
- if (finalize && !derived.noFinalizationNeeded()) {
- Finalize(descriptor, derived, terminator);
+}
+
+RT_API_ATTRS int DestroyTicket::Begin(WorkQueue &workQueue) {
+ if (finalize_ && !derived_.noFinalizationNeeded()) {
+ workQueue.BeginFinalize(instance_, derived_);
}
+ return StatOkContinue;
+}
+
+RT_API_ATTRS int DestroyTicket::Continue(WorkQueue &workQueue) {
// 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);
+ while (CueUpNextItem()) {
+ const auto *componentDerived{component_->derivedType()};
+ if (component_->genre() == typeInfo::Component::Genre::Allocatable ||
+ component_->genre() == typeInfo::Component::Genre::Automatic) {
+ Descriptor *d{instance_.ElementComponent<Descriptor>(
+ subscripts_, component_->offset())};
+ if (d->IsAllocated()) {
+ if (phase_ == 0) {
+ ++phase_;
+ if (componentDerived && !componentDerived->noDestructionNeeded()) {
+ workQueue.BeginDestroy(*d, *componentDerived, /*finalize=*/false);
+ return StatOkContinue;
+ }
}
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)) {
+ AdvanceToNextElement();
+ } else if (component_->genre() == typeInfo::Component::Genre::Data) {
+ if (!componentDerived || componentDerived->noDestructionNeeded()) {
+ AdvanceToNextComponent();
+ } else {
+ SubscriptValue extents[maxRank];
+ GetComponentExtents(extents, *component_, instance_);
+ Descriptor &compDesc{componentDescriptor_.descriptor()};
+ const typeInfo::DerivedType &compType{*componentDerived};
compDesc.Establish(compType,
- descriptor.ElementComponent<char>(at, comp.offset()), comp.rank(),
- extents);
- Destroy(compDesc, /*finalize=*/false, *comp.derivedType(), terminator);
+ instance_.ElementComponent<char>(subscripts_, component_->offset()),
+ component_->rank(), extents);
+ AdvanceToNextElement();
+ workQueue.BeginDestroy(compDesc, *componentDerived, /*finalize=*/false);
+ return StatOkContinue;
}
+ } else {
+ AdvanceToNextComponent();
}
}
+ return StatOk;
}
RT_API_ATTRS bool HasDynamicComponent(const Descriptor &descriptor) {
diff --git a/flang-rt/lib/runtime/type-info.cpp b/flang-rt/lib/runtime/type-info.cpp
index 82182696d70c6..451213202acef 100644
--- a/flang-rt/lib/runtime/type-info.cpp
+++ b/flang-rt/lib/runtime/type-info.cpp
@@ -140,11 +140,11 @@ RT_API_ATTRS void Component::CreatePointerDescriptor(Descriptor &descriptor,
const SubscriptValue *subscripts) const {
RUNTIME_CHECK(terminator, genre_ == Genre::Data);
EstablishDescriptor(descriptor, container, terminator);
+ std::size_t offset{offset_};
if (subscripts) {
- descriptor.set_base_addr(container.Element<char>(subscripts) + offset_);
- } else {
- descriptor.set_base_addr(container.OffsetElement<char>() + offset_);
+ offset += container.SubscriptsToByteOffset(subscripts);
}
+ descriptor.set_base_addr(container.OffsetElement<char>() + offset);
descriptor.raw().attribute = CFI_attribute_pointer;
}
diff --git a/flang-rt/lib/runtime/work-queue.cpp b/flang-rt/lib/runtime/work-queue.cpp
new file mode 100644
index 0000000000000..0ae50e72bb3a9
--- /dev/null
+++ b/flang-rt/lib/runtime/work-queue.cpp
@@ -0,0 +1,175 @@
+//===-- lib/runtime/work-queue.cpp ------------------------------*- C++ -*-===//
+//
+// 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 "flang-rt/runtime/work-queue.h"
+#include "flang-rt/runtime/type-info.h"
+#include "flang/Common/visit.h"
+
+namespace Fortran::runtime {
+
+RT_OFFLOAD_API_GROUP_BEGIN
+
+RT_API_ATTRS ComponentTicketBase::ComponentTicketBase(
+ const Descriptor &instance, const typeInfo::DerivedType &derived)
+ : ElementalTicketBase{instance}, derived_{derived},
+ components_{derived.component().Elements()} {}
+
+RT_API_ATTRS bool ComponentTicketBase::CueUpNextItem() {
+ bool elementsDone{!ElementalTicketBase::CueUpNextItem()};
+ if (elementsDone) {
+ component_ = nullptr;
+ ++componentAt_;
+ }
+ if (!component_) {
+ if (componentAt_ >= components_) {
+ return false; // done!
+ }
+ const Descriptor &componentDesc{derived_.component()};
+ component_ = componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(
+ componentAt_);
+ if (elementsDone) {
+ ElementalTicketBase::Reset();
+ }
+ }
+ return true;
+}
+
+RT_API_ATTRS int Ticket::Continue(WorkQueue &workQueue) {
+ if (!begun) {
+ begun = true;
+ return common::visit(
+ [&workQueue](
+ auto &specificTicket) { return specificTicket.Begin(workQueue); },
+ u);
+ } else {
+ return common::visit(
+ [&workQueue](auto &specificTicket) {
+ return specificTicket.Continue(workQueue);
+ },
+ u);
+ }
+}
+
+RT_API_ATTRS WorkQueue::~WorkQueue() {
+ if (last_) {
+ if ((last_->next = firstFree_)) {
+ last_->next->previous = last_;
+ }
+ firstFree_ = first_;
+ first_ = last_ = nullptr;
+ }
+ while (firstFree_) {
+ TicketList *next{firstFree_->next};
+ if (!firstFree_->isStatic) {
+ delete firstFree_;
+ }
+ firstFree_ = next;
+ }
+}
+
+RT_API_ATTRS void WorkQueue::BeginInitialize(
+ const Descriptor &descriptor, const typeInfo::DerivedType &derived) {
+ StartTicket().u.emplace<InitializeTicket>(descriptor, derived);
+}
+
+RT_API_ATTRS void WorkQueue::BeginInitializeClone(const Descriptor &clone,
+ const Descriptor &original, const typeInfo::DerivedType &derived,
+ bool hasStat, const Descriptor *errMsg) {
+ StartTicket().u.emplace<InitializeCloneTicket>(
+ clone, original, derived, hasStat, errMsg);
+}
+
+RT_API_ATTRS void WorkQueue::BeginFinalize(
+ const Descriptor &descriptor, const typeInfo::DerivedType &derived) {
+ StartTicket().u.emplace<FinalizeTicket>(descriptor, derived);
+}
+
+RT_API_ATTRS void WorkQueue::BeginDestroy(const Descriptor &descriptor,
+ const typeInfo::DerivedType &derived, bool finalize) {
+ StartTicket().u.emplace<DestroyTicket>(descriptor, derived, finalize);
+}
+
+RT_API_ATTRS void WorkQueue::BeginAssign(
+ Descriptor &to, const Descriptor &from, int flags, MemmoveFct memmoveFct) {
+ StartTicket().u.emplace<AssignTicket>(to, from, flags, memmoveFct);
+}
+
+RT_API_ATTRS void WorkQueue::BeginDerivedAssign(Descriptor &to,
+ const Descriptor &from, const typeInfo::DerivedType &derived, int flags,
+ MemmoveFct memmoveFct, Descriptor *deallocateAfter) {
+ StartTicket().u.emplace<DerivedAssignTicket>(
+ to, from, derived, flags, memmoveFct, deallocateAfter);
+}
+
+RT_API_ATTRS Ticket &WorkQueue::StartTicket() {
+ if (!firstFree_) {
+ firstFree_ = new TicketList;
+ firstFree_->isStatic = false;
+ }
+ TicketList *newTicket{firstFree_};
+ if ((firstFree_ = newTicket->next)) {
+ firstFree_->previous = nullptr;
+ }
+ TicketList *after{insertAfter_ ? insertAfter_->next : nullptr};
+ if ((newTicket->previous = insertAfter_ ? insertAfter_ : last_)) {
+ newTicket->previous->next = newTicket;
+ } else {
+ first_ = newTicket;
+ }
+ if ((newTicket->next = after)) {
+ after->previous = newTicket;
+ } else {
+ last_ = newTicket;
+ }
+ newTicket->ticket.begun = false;
+ return newTicket->ticket;
+}
+
+RT_API_ATTRS int WorkQueue::Run() {
+ while (last_) {
+ TicketList *at{last_};
+ insertAfter_ = last_;
+ int stat{at->ticket.Continue(*this)};
+ insertAfter_ = nullptr;
+ if (stat == StatOk) {
+ if (at->previous) {
+ at->previous->next = at->next;
+ } else {
+ first_ = at->next;
+ }
+ if (at->next) {
+ at->next->previous = at->previous;
+ } else {
+ last_ = at->previous;
+ }
+ if ((at->next = firstFree_)) {
+ at->next->previous = at;
+ }
+ at->previous = nullptr;
+ firstFree_ = at;
+ } else if (stat != StatOkContinue) {
+ Stop();
+ return stat;
+ }
+ }
+ return StatOk;
+}
+
+RT_API_ATTRS void WorkQueue::Stop() {
+ if (last_) {
+ if ((last_->next = firstFree_)) {
+ last_->next->previous = last_;
+ }
+ firstFree_ = first_;
+ first_ = last_ = nullptr;
+ }
+}
+
+RT_OFFLOAD_API_GROUP_END
+
+} // namespace Fortran::runtime
\ No newline at end of file
diff --git a/flang/include/flang/Runtime/assign.h b/flang/include/flang/Runtime/assign.h
index bc80997a1bec2..eb1f63184a177 100644
--- a/flang/include/flang/Runtime/assign.h
+++ b/flang/include/flang/Runtime/assign.h
@@ -38,7 +38,7 @@ enum AssignFlags {
ComponentCanBeDefinedAssignment = 1 << 3,
ExplicitLengthCharacterLHS = 1 << 4,
PolymorphicLHS = 1 << 5,
- DeallocateLHS = 1 << 6
+ DeallocateLHS = 1 << 6,
};
#ifdef RT_DEVICE_COMPILATION
diff --git a/flang/runtime/CMakeLists.txt b/flang/runtime/CMakeLists.txt
index f9378d4ed4312..e02fce789d539 100644
--- a/flang/runtime/CMakeLists.txt
+++ b/flang/runtime/CMakeLists.txt
@@ -222,6 +222,7 @@ set(sources
unit-map.cpp
unit.cpp
utf.cpp
+ work-queue.cpp
${FORTRAN_MODULE_OBJECTS}
)
@@ -281,6 +282,7 @@ set(supported_files
type-info.cpp
unit.cpp
utf.cpp
+ work-queue.cpp
)
runtime_source_files(supported_files SUBDIR "runtime")
More information about the flang-commits
mailing list