diff --git a/flang-rt/include/flang-rt/runtime/environment.h b/flang-rt/include/flang-rt/runtime/environment.h index 16258b3bbba9b..e579f6012ce86 100644 --- a/flang-rt/include/flang-rt/runtime/environment.h +++ b/flang-rt/include/flang-rt/runtime/environment.h @@ -64,6 +64,9 @@ struct ExecutionEnvironment { bool defaultUTF8{false}; // DEFAULT_UTF8 bool checkPointerDeallocation{true}; // FORT_CHECK_POINTER_DEALLOCATION + enum InternalDebugging { WorkQueue = 1 }; + int internalDebugging{0}; // FLANG_RT_DEBUG + // CUDA related variables std::size_t cudaStackLimit{0}; // ACC_OFFLOAD_STACK_SIZE bool cudaDeviceIsManaged{false}; // NV_CUDAFOR_DEVICE_IS_MANAGED diff --git a/flang-rt/include/flang-rt/runtime/stat.h b/flang-rt/include/flang-rt/runtime/stat.h index 070d0bf8673fb..dc372de53506a 100644 --- a/flang-rt/include/flang-rt/runtime/stat.h +++ b/flang-rt/include/flang-rt/runtime/stat.h @@ -24,7 +24,7 @@ class Terminator; enum Stat { StatOk = 0, // required to be zero by Fortran - // Interoperable STAT= codes + // Interoperable STAT= codes (>= 11) StatBaseNull = CFI_ERROR_BASE_ADDR_NULL, StatBaseNotNull = CFI_ERROR_BASE_ADDR_NOT_NULL, StatInvalidElemLen = CFI_INVALID_ELEM_LEN, @@ -36,7 +36,7 @@ enum Stat { StatMemAllocation = CFI_ERROR_MEM_ALLOCATION, StatOutOfBounds = CFI_ERROR_OUT_OF_BOUNDS, - // Standard STAT= values + // Standard STAT= values (>= 101) StatFailedImage = FORTRAN_RUNTIME_STAT_FAILED_IMAGE, StatLocked = FORTRAN_RUNTIME_STAT_LOCKED, StatLockedOtherImage = FORTRAN_RUNTIME_STAT_LOCKED_OTHER_IMAGE, @@ -49,10 +49,14 @@ enum Stat { // Additional "processor-defined" STAT= values StatInvalidArgumentNumber = FORTRAN_RUNTIME_STAT_INVALID_ARG_NUMBER, StatMissingArgument = FORTRAN_RUNTIME_STAT_MISSING_ARG, - StatValueTooShort = FORTRAN_RUNTIME_STAT_VALUE_TOO_SHORT, + StatValueTooShort = FORTRAN_RUNTIME_STAT_VALUE_TOO_SHORT, // -1 StatMoveAllocSameAllocatable = FORTRAN_RUNTIME_STAT_MOVE_ALLOC_SAME_ALLOCATABLE, StatBadPointerDeallocation = FORTRAN_RUNTIME_STAT_BAD_POINTER_DEALLOCATION, + + // Dummy status for work queue continuation, declared here to perhaps + // avoid collisions + StatContinue = 201 }; RT_API_ATTRS const char *StatErrorString(int); diff --git a/flang-rt/include/flang-rt/runtime/type-info.h b/flang-rt/include/flang-rt/runtime/type-info.h index 5e79efde164f2..9bde3adba87f5 100644 --- a/flang-rt/include/flang-rt/runtime/type-info.h +++ b/flang-rt/include/flang-rt/runtime/type-info.h @@ -240,6 +240,7 @@ class DerivedType { RT_API_ATTRS bool noFinalizationNeeded() const { return noFinalizationNeeded_; } + RT_API_ATTRS bool noDefinedAssignment() const { return noDefinedAssignment_; } RT_API_ATTRS std::size_t LenParameters() const { return lenParameterKind().Elements(); @@ -322,6 +323,7 @@ class DerivedType { bool noInitializationNeeded_{false}; bool noDestructionNeeded_{false}; bool noFinalizationNeeded_{false}; + bool noDefinedAssignment_{false}; }; } // namespace Fortran::runtime::typeInfo 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..878b18373e1d2 --- /dev/null +++ b/flang-rt/include/flang-rt/runtime/work-queue.h @@ -0,0 +1,548 @@ +//===-- 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 comprises a list of tickets. Each ticket class has a Begin() +// member function, which 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 +// StatContinue. When that status is not StatOk, then the whole queue +// is shut down. +// +// By returning StatContinue 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 ComponentsOverElements, 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 StatContinue. +// 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 StatContinue). +// 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/connection.h" +#include "flang-rt/runtime/descriptor.h" +#include "flang-rt/runtime/stat.h" +#include "flang-rt/runtime/type-info.h" +#include "flang/Common/api-attrs.h" +#include "flang/Runtime/freestanding-tools.h" +#include + +namespace Fortran::runtime::io { +class IoStatementState; +struct NonTbpDefinedIoTable; +} // namespace Fortran::runtime::io + +namespace Fortran::runtime { +class Terminator; +class WorkQueue; + +// Ticket worker base classes + +template class ImmediateTicketRunner { +public: + RT_API_ATTRS explicit ImmediateTicketRunner(TICKET &ticket) + : ticket_{ticket} {} + RT_API_ATTRS int Run(WorkQueue &workQueue) { + int status{ticket_.Begin(workQueue)}; + while (status == StatContinue) { + status = ticket_.Continue(workQueue); + } + return status; + } + +private: + TICKET &ticket_; +}; + +// Base class for ticket workers that operate elementwise over descriptors +class Elementwise { +protected: + RT_API_ATTRS Elementwise( + const Descriptor &instance, const Descriptor *from = nullptr) + : instance_{instance}, from_{from} { + instance_.GetLowerBounds(subscripts_); + if (from_) { + from_->GetLowerBounds(fromSubscripts_); + } + } + RT_API_ATTRS bool IsComplete() const { return elementAt_ >= elements_; } + RT_API_ATTRS void Advance() { + ++elementAt_; + instance_.IncrementSubscripts(subscripts_); + if (from_) { + from_->IncrementSubscripts(fromSubscripts_); + } + } + RT_API_ATTRS void SkipToEnd() { elementAt_ = elements_; } + RT_API_ATTRS void Reset() { + elementAt_ = 0; + instance_.GetLowerBounds(subscripts_); + if (from_) { + from_->GetLowerBounds(fromSubscripts_); + } + } + + const Descriptor &instance_, *from_{nullptr}; + std::size_t elements_{instance_.Elements()}; + std::size_t elementAt_{0}; + SubscriptValue subscripts_[common::maxRank]; + SubscriptValue fromSubscripts_[common::maxRank]; +}; + +// Base class for ticket workers that operate over derived type components. +class Componentwise { +protected: + RT_API_ATTRS Componentwise(const typeInfo::DerivedType &); + RT_API_ATTRS bool IsComplete() const { return componentAt_ >= components_; } + RT_API_ATTRS void Advance() { + ++componentAt_; + GetComponent(); + } + RT_API_ATTRS void SkipToEnd() { + component_ = nullptr; + componentAt_ = components_; + } + RT_API_ATTRS void Reset() { + component_ = nullptr; + componentAt_ = 0; + GetComponent(); + } + RT_API_ATTRS void GetComponent(); + + const typeInfo::DerivedType &derived_; + std::size_t components_{0}, componentAt_{0}; + const typeInfo::Component *component_{nullptr}; + StaticDescriptor componentDescriptor_; +}; + +// Base class for ticket workers that operate over derived type components +// in an outer loop, and elements in an inner loop. +class ComponentsOverElements : protected Componentwise, protected Elementwise { +protected: + RT_API_ATTRS ComponentsOverElements(const Descriptor &instance, + const typeInfo::DerivedType &derived, const Descriptor *from = nullptr) + : Componentwise{derived}, Elementwise{instance, from} { + if (Elementwise::IsComplete()) { + Componentwise::SkipToEnd(); + } + } + RT_API_ATTRS bool IsComplete() const { return Componentwise::IsComplete(); } + RT_API_ATTRS void Advance() { + SkipToNextElement(); + if (Elementwise::IsComplete()) { + Elementwise::Reset(); + Componentwise::Advance(); + } + } + RT_API_ATTRS void SkipToNextElement() { + phase_ = 0; + Elementwise::Advance(); + } + RT_API_ATTRS void SkipToNextComponent() { + phase_ = 0; + Elementwise::Reset(); + Componentwise::Advance(); + } + RT_API_ATTRS void Reset() { + phase_ = 0; + Elementwise::Reset(); + Componentwise::Reset(); + } + + int phase_{0}; +}; + +// Base class for ticket workers that operate over elements in an outer loop, +// type components in an inner loop. +class ElementsOverComponents : protected Elementwise, protected Componentwise { +protected: + RT_API_ATTRS ElementsOverComponents(const Descriptor &instance, + const typeInfo::DerivedType &derived, const Descriptor *from = nullptr) + : Elementwise{instance, from}, Componentwise{derived} { + if (Componentwise::IsComplete()) { + Elementwise::SkipToEnd(); + } + } + RT_API_ATTRS bool IsComplete() const { return Elementwise::IsComplete(); } + RT_API_ATTRS void Advance() { + SkipToNextComponent(); + if (Componentwise::IsComplete()) { + Componentwise::Reset(); + Elementwise::Advance(); + } + } + RT_API_ATTRS void SkipToNextComponent() { + phase_ = 0; + Componentwise::Advance(); + } + RT_API_ATTRS void SkipToNextElement() { + phase_ = 0; + Componentwise::Reset(); + Elementwise::Advance(); + } + + int phase_{0}; +}; + +// Ticket worker classes + +// Implements derived type instance initialization +class InitializeTicket : public ImmediateTicketRunner, + private ComponentsOverElements { +public: + RT_API_ATTRS InitializeTicket( + const Descriptor &instance, const typeInfo::DerivedType &derived) + : ImmediateTicketRunner{*this}, + ComponentsOverElements{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 + : public ImmediateTicketRunner, + private ComponentsOverElements { +public: + RT_API_ATTRS InitializeCloneTicket(const Descriptor &clone, + const Descriptor &original, const typeInfo::DerivedType &derived, + bool hasStat, const Descriptor *errMsg) + : ImmediateTicketRunner{*this}, + ComponentsOverElements{original, derived}, clone_{clone}, + hasStat_{hasStat}, errMsg_{errMsg} {} + RT_API_ATTRS int Begin(WorkQueue &) { return StatContinue; } + RT_API_ATTRS int Continue(WorkQueue &); + +private: + const Descriptor &clone_; + bool hasStat_{false}; + const Descriptor *errMsg_{nullptr}; + StaticDescriptor cloneComponentDescriptor_; +}; + +// Implements derived type instance finalization +class FinalizeTicket : public ImmediateTicketRunner, + private ComponentsOverElements { +public: + RT_API_ATTRS FinalizeTicket( + const Descriptor &instance, const typeInfo::DerivedType &derived) + : ImmediateTicketRunner{*this}, + ComponentsOverElements{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 : public ImmediateTicketRunner, + private ComponentsOverElements { +public: + RT_API_ATTRS DestroyTicket(const Descriptor &instance, + const typeInfo::DerivedType &derived, bool finalize) + : ImmediateTicketRunner{*this}, + ComponentsOverElements{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 ImmediateTicketRunner { +public: + RT_API_ATTRS AssignTicket( + Descriptor &to, const Descriptor &from, int flags, MemmoveFct memmoveFct) + : ImmediateTicketRunner{*this}, 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 tempDescriptor_; + const typeInfo::DerivedType *toDerived_{nullptr}; + Descriptor *toDeallocate_{nullptr}; + bool persist_{false}; + bool done_{false}; +}; + +// Implements derived type intrinsic assignment. +template +class DerivedAssignTicket + : public ImmediateTicketRunner>, + private std::conditional_t { +public: + using Base = std::conditional_t; + RT_API_ATTRS DerivedAssignTicket(const Descriptor &to, const Descriptor &from, + const typeInfo::DerivedType &derived, int flags, MemmoveFct memmoveFct, + Descriptor *deallocateAfter) + : ImmediateTicketRunner{*this}, + Base{to, derived, &from}, flags_{flags}, memmoveFct_{memmoveFct}, + deallocateAfter_{deallocateAfter} {} + RT_API_ATTRS int Begin(WorkQueue &); + RT_API_ATTRS int Continue(WorkQueue &); + +private: + static constexpr bool isComponentwise_{IS_COMPONENTWISE}; + bool toIsContiguous_{this->instance_.IsContiguous()}; + bool fromIsContiguous_{this->from_->IsContiguous()}; + int flags_{0}; + MemmoveFct memmoveFct_{nullptr}; + Descriptor *deallocateAfter_{nullptr}; + StaticDescriptor fromComponentDescriptor_; +}; + +namespace io::descr { + +template +class DescriptorIoTicket + : public ImmediateTicketRunner>, + private Elementwise { +public: + RT_API_ATTRS DescriptorIoTicket(io::IoStatementState &io, + const Descriptor &descriptor, const io::NonTbpDefinedIoTable *table, + bool &anyIoTookPlace) + : ImmediateTicketRunner(*this), + Elementwise{descriptor}, io_{io}, table_{table}, + anyIoTookPlace_{anyIoTookPlace} {} + RT_API_ATTRS int Begin(WorkQueue &); + RT_API_ATTRS int Continue(WorkQueue &); + RT_API_ATTRS bool &anyIoTookPlace() { return anyIoTookPlace_; } + +private: + io::IoStatementState &io_; + const io::NonTbpDefinedIoTable *table_{nullptr}; + bool &anyIoTookPlace_; + common::optional nonTbpSpecial_; + const typeInfo::DerivedType *derived_{nullptr}; + const typeInfo::SpecialBinding *special_{nullptr}; + StaticDescriptor elementDescriptor_; +}; + +template +class DerivedIoTicket : public ImmediateTicketRunner>, + private ElementsOverComponents { +public: + RT_API_ATTRS DerivedIoTicket(io::IoStatementState &io, + const Descriptor &descriptor, const typeInfo::DerivedType &derived, + const io::NonTbpDefinedIoTable *table, bool &anyIoTookPlace) + : ImmediateTicketRunner(*this), + ElementsOverComponents{descriptor, derived}, io_{io}, table_{table}, + anyIoTookPlace_{anyIoTookPlace} {} + RT_API_ATTRS int Begin(WorkQueue &) { return StatContinue; } + RT_API_ATTRS int Continue(WorkQueue &); + +private: + io::IoStatementState &io_; + const io::NonTbpDefinedIoTable *table_{nullptr}; + bool &anyIoTookPlace_; +}; + +} // namespace io::descr + +struct NullTicket { + RT_API_ATTRS int Begin(WorkQueue &) const { return StatOk; } + RT_API_ATTRS int Continue(WorkQueue &) const { return StatOk; } +}; + +struct Ticket { + RT_API_ATTRS int Continue(WorkQueue &); + bool begun{false}; + std::variant, + DerivedAssignTicket, + io::descr::DescriptorIoTicket, + io::descr::DescriptorIoTicket, + io::descr::DerivedIoTicket, + io::descr::DerivedIoTicket> + 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_; }; + + // APIs for particular tasks. These can return StatOk if the work is + // completed immediately. + RT_API_ATTRS int BeginInitialize( + const Descriptor &descriptor, const typeInfo::DerivedType &derived) { + if (runTicketsImmediately_) { + return InitializeTicket{descriptor, derived}.Run(*this); + } else { + StartTicket().u.emplace(descriptor, derived); + return StatContinue; + } + } + RT_API_ATTRS int BeginInitializeClone(const Descriptor &clone, + const Descriptor &original, const typeInfo::DerivedType &derived, + bool hasStat, const Descriptor *errMsg) { + if (runTicketsImmediately_) { + return InitializeCloneTicket{clone, original, derived, hasStat, errMsg} + .Run(*this); + } else { + StartTicket().u.emplace( + clone, original, derived, hasStat, errMsg); + return StatContinue; + } + } + RT_API_ATTRS int BeginFinalize( + const Descriptor &descriptor, const typeInfo::DerivedType &derived) { + if (runTicketsImmediately_) { + return FinalizeTicket{descriptor, derived}.Run(*this); + } else { + StartTicket().u.emplace(descriptor, derived); + return StatContinue; + } + } + RT_API_ATTRS int BeginDestroy(const Descriptor &descriptor, + const typeInfo::DerivedType &derived, bool finalize) { + if (runTicketsImmediately_) { + return DestroyTicket{descriptor, derived, finalize}.Run(*this); + } else { + StartTicket().u.emplace(descriptor, derived, finalize); + return StatContinue; + } + } + RT_API_ATTRS int BeginAssign(Descriptor &to, const Descriptor &from, + int flags, MemmoveFct memmoveFct) { + if (runTicketsImmediately_) { + return AssignTicket{to, from, flags, memmoveFct}.Run(*this); + } else { + StartTicket().u.emplace(to, from, flags, memmoveFct); + return StatContinue; + } + } + template + RT_API_ATTRS int BeginDerivedAssign(Descriptor &to, const Descriptor &from, + const typeInfo::DerivedType &derived, int flags, MemmoveFct memmoveFct, + Descriptor *deallocateAfter) { + if (runTicketsImmediately_) { + return DerivedAssignTicket{ + to, from, derived, flags, memmoveFct, deallocateAfter} + .Run(*this); + } else { + StartTicket().u.emplace>( + to, from, derived, flags, memmoveFct, deallocateAfter); + return StatContinue; + } + } + template + RT_API_ATTRS int BeginDescriptorIo(io::IoStatementState &io, + const Descriptor &descriptor, const io::NonTbpDefinedIoTable *table, + bool &anyIoTookPlace) { + if (runTicketsImmediately_) { + return io::descr::DescriptorIoTicket{ + io, descriptor, table, anyIoTookPlace} + .Run(*this); + } else { + StartTicket().u.emplace>( + io, descriptor, table, anyIoTookPlace); + return StatContinue; + } + } + template + RT_API_ATTRS int BeginDerivedIo(io::IoStatementState &io, + const Descriptor &descriptor, const typeInfo::DerivedType &derived, + const io::NonTbpDefinedIoTable *table, bool &anyIoTookPlace) { + if (runTicketsImmediately_) { + return io::descr::DerivedIoTicket{ + io, descriptor, derived, table, anyIoTookPlace} + .Run(*this); + } else { + StartTicket().u.emplace>( + io, descriptor, derived, table, anyIoTookPlace); + return StatContinue; + } + } + + RT_API_ATTRS int Run(); + +private: +#if RT_DEVICE_COMPILATION + // Always use the work queue on a GPU device to avoid recursion. + static constexpr bool runTicketsImmediately_{false}; +#else + // Avoid the work queue overhead on the host, unless it needs + // debugging, which is so much easier there. + static constexpr bool runTicketsImmediately_{true}; +#endif + + // 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 a3f63b4315644..332c0872e065f 100644 --- a/flang-rt/lib/runtime/CMakeLists.txt +++ b/flang-rt/lib/runtime/CMakeLists.txt @@ -68,6 +68,7 @@ set(supported_sources type-info.cpp unit.cpp utf.cpp + work-queue.cpp ) # List of source not used for GPU offloading. @@ -131,6 +132,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 bf67b5dc8b645..41b130cc8f257 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 { @@ -102,11 +103,7 @@ static RT_API_ATTRS int AllocateAssignmentLHS( toDim.SetByteStride(stride); stride *= toDim.Extent(); } - int result{ReturnError(terminator, to.Allocate(kNoAsyncObject))}; - if (result == StatOk && derived && !derived->noInitializationNeeded()) { - result = ReturnError(terminator, Initialize(to, *derived, terminator)); - } - return result; + return ReturnError(terminator, to.Allocate(kNoAsyncObject)); } // least <= 0, most >= 0 @@ -231,6 +228,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 @@ -244,275 +243,453 @@ 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 deferredDeallocStatDesc; - Descriptor *deferDeallocation{nullptr}; - if (MayAlias(to, from)) { + WorkQueue workQueue{terminator}; + if (workQueue.BeginAssign(to, from, flags, memmoveFct) == StatContinue) { + 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; + } + 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(deferDeallocation), &to, to.SizeInBytes()); - to.set_base_addr(nullptr); - } else if (!isSimpleMemmove()) { + reinterpret_cast(toDeallocate_), &to_, to_.SizeInBytes()); + to_.set_base_addr(nullptr); + if (toDerived_ && (flags_ & NeedFinalization)) { + if (int status{workQueue.BeginFinalize(*toDeallocate_, *toDerived_)}; + status != StatOk && status != StatContinue) { + return status; + } + flags_ &= ~NeedFinalization; + } + } else if (!IsSimpleMemmove()) { // Handle LHS/RHS aliasing by copying RHS into a temp, then // recursively assigning from that temp. - auto descBytes{from.SizeInBytes()}; - StaticDescriptor staticDesc; - Descriptor &newFrom{staticDesc.descriptor()}; - std::memcpy(reinterpret_cast(&newFrom), &from, descBytes); + auto descBytes{from_->SizeInBytes()}; + Descriptor &newFrom{tempDescriptor_.descriptor()}; + persist_ = true; // tempDescriptor_ state must outlive child tickets + std::memcpy(reinterpret_cast(&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(kNoAsyncObject))}; - 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(kNoAsyncObject))}; + 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()) { + if (int status{workQueue.BeginInitialize(newFrom, *derived)}; + status != StatOk && status != StatContinue) { + return status; + } + } + } + } + static constexpr int nestedFlags{MaybeReallocate | PolymorphicLHS}; + if (int status{workQueue.BeginAssign( + newFrom, *from_, nestedFlags, memmoveFct_)}; + status != StatOk && status != StatContinue) { + return status; } - Assign(to, newFrom, terminator, - flags & - (NeedFinalization | ComponentCanBeDefinedAssignment | - ExplicitLengthCharacterLHS | CanBeDefinedAssignment)); - newFrom.Deallocate(); + } else { + ShallowCopy(newFrom, *from_, true, from_->IsContiguous()); } - return; + from_ = &newFrom; + flags_ &= NeedFinalization | ComponentCanBeDefinedAssignment | + ExplicitLengthCharacterLHS | CanBeDefinedAssignment; + toDeallocate_ = &newFrom; } } - 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; + } 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) { + if (int status{workQueue.BeginFinalize(to_, *toDerived_)}; + status != StatOk && status != StatContinue) { + return status; + } + } else if (!toDerived_->noDestructionNeeded()) { + if (int status{ + workQueue.BeginDestroy(to_, *toDerived_, /*finalize=*/false)}; + status != StatOk && status != StatContinue) { + return status; } - flags &= ~NeedFinalization; - toElementBytes = to.ElementBytes(); // may have changed - toDerived = toAddendum ? toAddendum->derivedType() : 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 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( + return StatContinue; +} + +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(); + } + // Allocate the LHS if needed + if (!to_.IsAllocated()) { + if (int stat{ + AllocateAssignmentLHS(to_, *from_, workQueue.terminator(), flags_)}; + stat != StatOk) { + return stat; + } + const auto *addendum{to_.Addendum()}; + toDerived_ = addendum ? addendum->derivedType() : nullptr; + if (toDerived_ && !toDerived_->noInitializationNeeded()) { + if (int status{workQueue.BeginInitialize(to_, *toDerived_)}; + status != StatOk) { + return status; + } + } + } + // Check for a user-defined assignment type-bound procedure; + // see 10.2.1.4-5. + // Note that the aliasing and LHS (re)allocation handling above + // needs to run even with CanBeDefinedAssignment flag, since + // Assign() can be invoked recursively for component-wise assignments. + if (toDerived_ && (flags_ & CanBeDefinedAssignment)) { + if (to_.rank() == 0) { + if (const auto *special{toDerived_->FindSpecialBinding( typeInfo::SpecialBinding::Which::ScalarAssignment)}) { - return DoScalarDefinedAssignment(to, from, *special); + DoScalarDefinedAssignment(to_, *from_, *special); + done_ = true; + return StatContinue; } } - if (const auto *special{toDerived->FindSpecialBinding( + if (const auto *special{toDerived_->FindSpecialBinding( typeInfo::SpecialBinding::Which::ElementalAssignment)}) { - return DoElementalDefinedAssignment(to, from, *toDerived, *special); + DoElementalDefinedAssignment(to_, *from_, *toDerived_, *special); + done_ = true; + return StatContinue; } } - 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()); + // Intrinsic assignment + 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( - 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 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(toAt) + comp.offset(), - from.Element(fromAt) + comp.offset(), - componentByteSize); - } - break; - case typeInfo::Component::Genre::Pointer: { - std::size_t componentByteSize{comp.SizeInBytes(to)}; - memmoveFct(to.Element(toAt) + comp.offset(), - from.Element(fromAt) + comp.offset(), - componentByteSize); - } break; - case typeInfo::Component::Genre::Allocatable: - case typeInfo::Component::Genre::Automatic: { - auto *toDesc{reinterpret_cast( - to.Element(toAt) + comp.offset())}; - const auto *fromDesc{reinterpret_cast( - from.Element(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; - } + if (toDerived_) { + if (toDerived_->noDefinedAssignment()) { // componentwise + if (int status{workQueue.BeginDerivedAssign( + to_, *from_, *toDerived_, flags_, memmoveFct_, toDeallocate_)}; + status != StatOk && status != StatContinue) { + return status; } - // 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( - k)}; - memmoveFct(to.Element(toAt) + procPtr.offset, - from.Element(fromAt) + procPtr.offset, - sizeof(typeInfo::ProcedurePointer)); + } else { // elementwise + if (int status{workQueue.BeginDerivedAssign( + to_, *from_, *toDerived_, flags_, memmoveFct_, toDeallocate_)}; + status != StatOk && status != StatContinue) { + return status; } } - } 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()) { + 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(to, from, toAt, fromAt, toElements, + BlankPadCharacterAssignment(to_, *from_, toAt, fromAt, toElements, toElementBytes, fromElementBytes); break; case CFI_type_char16_t: - BlankPadCharacterAssignment(to, from, toAt, fromAt, + BlankPadCharacterAssignment(to_, *from_, toAt, fromAt, toElements, toElementBytes, fromElementBytes); break; case CFI_type_char32_t: - BlankPadCharacterAssignment(to, from, toAt, fromAt, + BlankPadCharacterAssignment(to_, *from_, toAt, fromAt, toElements, toElementBytes, fromElementBytes); break; default: - terminator.Crash("unexpected type code %d in blank padded Assign()", - to.type().raw()); + 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(toAt), from.Element(fromAt), + to_.IncrementSubscripts(toAt), from_->IncrementSubscripts(fromAt)) { + memmoveFct_(to_.Element(toAt), from_->Element(fromAt), toElementBytes); } } } - 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 (persist_) { + done_ = true; + return StatContinue; + } else { + if (toDeallocate_) { + toDeallocate_->Deallocate(); + toDeallocate_ = nullptr; + } + return StatOk; } } -RT_OFFLOAD_API_GROUP_BEGIN +template +RT_API_ATTRS int DerivedAssignTicket::Begin( + WorkQueue &workQueue) { + if (toIsContiguous_ && fromIsContiguous_ && + this->derived_.noDestructionNeeded() && + this->derived_.noDefinedAssignment() && + this->instance_.rank() == this->from_->rank()) { + if (std::size_t elementBytes{this->instance_.ElementBytes()}; + elementBytes == this->from_->ElementBytes()) { + // Fastest path. Both LHS and RHS are contiguous, RHS is not a scalar + // to be expanded, the types have the same size, and there are no + // allocatable components or defined ASSIGNMENT(=) at any level. + memmoveFct_(this->instance_.template OffsetElement(), + this->from_->template OffsetElement(), + this->instance_.Elements() * elementBytes); + return StatOk; + } + } + // 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{this->derived_.procPtr()}; + bool noDataComponents{this->IsComplete()}; + if (std::size_t numProcPtrs{procPtrDesc.Elements()}) { + for (std::size_t k{0}; k < numProcPtrs; ++k) { + const auto &procPtr{ + *procPtrDesc.ZeroBasedIndexedElement(k)}; + // Loop only over elements + if (noDataComponents) { + Elementwise::Reset(); + } + for (; !Elementwise::IsComplete(); Elementwise::Advance()) { + memmoveFct_(this->instance_.template ElementComponent( + this->subscripts_, procPtr.offset), + this->from_->template ElementComponent( + this->fromSubscripts_, procPtr.offset), + sizeof(typeInfo::ProcedurePointer)); + } + } + if (noDataComponents) { + return StatOk; + } + Elementwise::Reset(); + } + if (noDataComponents) { + return StatOk; + } + return StatContinue; +} +template RT_API_ATTRS int DerivedAssignTicket::Begin(WorkQueue &); +template RT_API_ATTRS int DerivedAssignTicket::Begin(WorkQueue &); + +template +RT_API_ATTRS int DerivedAssignTicket::Continue( + WorkQueue &workQueue) { + while (!this->IsComplete()) { + // Copy the data components (incl. the parent) first. + switch (this->component_->genre()) { + case typeInfo::Component::Genre::Data: + if (this->component_->category() == TypeCategory::Derived) { + Descriptor &toCompDesc{this->componentDescriptor_.descriptor()}; + Descriptor &fromCompDesc{this->fromComponentDescriptor_.descriptor()}; + this->component_->CreatePointerDescriptor(toCompDesc, this->instance_, + workQueue.terminator(), this->subscripts_); + this->component_->CreatePointerDescriptor(fromCompDesc, *this->from_, + workQueue.terminator(), this->fromSubscripts_); + this->Advance(); + if (int status{workQueue.BeginAssign( + toCompDesc, fromCompDesc, flags_, memmoveFct_)}; + status != StatOk) { + return status; + } + } else { // Component has intrinsic type; simply copy raw bytes + std::size_t componentByteSize{ + this->component_->SizeInBytes(this->instance_)}; + if (IS_COMPONENTWISE && toIsContiguous_ && fromIsContiguous_) { + std::size_t offset{this->component_->offset()}; + char *to{this->instance_.template OffsetElement(offset)}; + const char *from{ + this->from_->template OffsetElement(offset)}; + std::size_t toElementStride{this->instance_.ElementBytes()}; + std::size_t fromElementStride{ + this->from_->rank() == 0 ? 0 : this->from_->ElementBytes()}; + if (toElementStride == fromElementStride && + toElementStride == componentByteSize) { + memmoveFct_(to, from, this->elements_ * componentByteSize); + } else { + for (std::size_t n{this->elements_}; n--; + to += toElementStride, from += fromElementStride) { + memmoveFct_(to, from, componentByteSize); + } + } + this->Componentwise::Advance(); + } else { + memmoveFct_( + this->instance_.template Element(this->subscripts_) + + this->component_->offset(), + this->from_->template Element(this->fromSubscripts_) + + this->component_->offset(), + componentByteSize); + this->Advance(); + } + } + break; + case typeInfo::Component::Genre::Pointer: { + std::size_t componentByteSize{ + this->component_->SizeInBytes(this->instance_)}; + if (IS_COMPONENTWISE && toIsContiguous_ && fromIsContiguous_) { + std::size_t offset{this->component_->offset()}; + char *to{this->instance_.template OffsetElement(offset)}; + const char *from{ + this->from_->template OffsetElement(offset)}; + std::size_t toElementStride{this->instance_.ElementBytes()}; + std::size_t fromElementStride{ + this->from_->rank() == 0 ? 0 : this->from_->ElementBytes()}; + if (toElementStride == fromElementStride && + toElementStride == componentByteSize) { + memmoveFct_(to, from, this->elements_ * componentByteSize); + } else { + for (std::size_t n{this->elements_}; n--; + to += toElementStride, from += fromElementStride) { + memmoveFct_(to, from, componentByteSize); + } + } + this->Componentwise::Advance(); + } else { + memmoveFct_(this->instance_.template Element(this->subscripts_) + + this->component_->offset(), + this->from_->template Element(this->fromSubscripts_) + + this->component_->offset(), + componentByteSize); + this->Advance(); + } + } break; + case typeInfo::Component::Genre::Allocatable: + case typeInfo::Component::Genre::Automatic: { + auto *toDesc{reinterpret_cast( + this->instance_.template Element(this->subscripts_) + + this->component_->offset())}; + const auto *fromDesc{reinterpret_cast( + this->from_->template Element(this->fromSubscripts_) + + this->component_->offset())}; + if (toDesc->IsAllocatable() && !fromDesc->IsAllocated()) { + if (toDesc->IsAllocated()) { + if (this->phase_ == 0) { + this->phase_++; + if (const auto *componentDerived{this->component_->derivedType()}; + componentDerived && !componentDerived->noDestructionNeeded()) { + if (int status{workQueue.BeginDestroy( + *toDesc, *componentDerived, /*finalize=*/false)}; + status != StatOk) { + return status; + } + } + } + toDesc->Deallocate(); + } + this->Advance(); + } 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. + this->Advance(); + int nestedFlags{flags_}; + if (this->derived_.noFinalizationNeeded() && + this->derived_.noInitializationNeeded() && + this->derived_.noDestructionNeeded()) { + // The actual deallocation may be avoided, if the existing + // location can be reoccupied. + } else { + // Force LHS deallocation with DeallocateLHS flag. + nestedFlags |= DeallocateLHS; + } + if (int status{workQueue.BeginAssign( + *toDesc, *fromDesc, nestedFlags, memmoveFct_)}; + status != StatOk) { + return status; + } + } + } break; + } + } + if (deallocateAfter_) { + deallocateAfter_->Deallocate(); + } + return StatOk; +} +template RT_API_ATTRS int DerivedAssignTicket::Continue(WorkQueue &); +template RT_API_ATTRS int DerivedAssignTicket::Continue(WorkQueue &); RT_API_ATTRS void DoFromSourceAssign(Descriptor &alloc, const Descriptor &source, Terminator &terminator, MemmoveFct memmoveFct) { @@ -582,7 +759,6 @@ void RTDEF(AssignTemporary)(Descriptor &to, const Descriptor &from, } } } - Assign(to, from, terminator, MaybeReallocate | PolymorphicLHS); } @@ -599,7 +775,6 @@ void RTDEF(CopyInAssign)(Descriptor &temp, const Descriptor &var, void RTDEF(CopyOutAssign)( Descriptor *var, Descriptor &temp, const char *sourceFile, int sourceLine) { Terminator terminator{sourceFile, sourceLine}; - // Copyout from the temporary must not cause any finalizations // for LHS. The variable must be properly initialized already. if (var) { diff --git a/flang-rt/lib/runtime/derived.cpp b/flang-rt/lib/runtime/derived.cpp index 35037036f63e7..8ab737c701b01 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,193 @@ 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 auto &comp{ - *componentDesc.ZeroBasedIndexedElement(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(at, comp.offset())}; - comp.EstablishDescriptor(allocDesc, instance, terminator); + const typeInfo::DerivedType &derived, Terminator &terminator, bool, + const Descriptor *) { + WorkQueue workQueue{terminator}; + int status{workQueue.BeginInitialize(instance, derived)}; + return status == StatContinue ? workQueue.Run() : status; +} + +RT_API_ATTRS int InitializeTicket::Begin(WorkQueue &) { + // Initialize procedure pointer components in each element + const Descriptor &procPtrDesc{derived_.procPtr()}; + if (std::size_t numProcPtrs{procPtrDesc.Elements()}) { + bool noDataComponents{IsComplete()}; + for (std::size_t k{0}; k < numProcPtrs; ++k) { + const auto &comp{ + *procPtrDesc.ZeroBasedIndexedElement(k)}; + // Loop only over elements + if (noDataComponents) { + Elementwise::Reset(); + } + for (; !Elementwise::IsComplete(); Elementwise::Advance()) { + auto &pptr{*instance_.ElementComponent( + subscripts_, comp.offset)}; + pptr = comp.procInitialization; + } + } + if (noDataComponents) { + return StatOk; + } + Elementwise::Reset(); + } + return StatContinue; +} + +RT_API_ATTRS int InitializeTicket::Continue(WorkQueue &workQueue) { + while (!IsComplete()) { + if (component_->genre() == typeInfo::Component::Genre::Allocatable) { + // Establish allocatable descriptors + for (; !Elementwise::IsComplete(); Elementwise::Advance()) { + Descriptor &allocDesc{*instance_.ElementComponent( + 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(kNoAsyncObject), 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()}) { + SkipToNextComponent(); + } 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(at, comp.offset())}; + std::size_t bytes{component_->SizeInBytes(instance_)}; + for (; !Elementwise::IsComplete(); Elementwise::Advance()) { + char *ptr{instance_.ElementComponent( + subscripts_, component_->offset())}; std::memcpy(ptr, init, bytes); } - } else if (comp.genre() == typeInfo::Component::Genre::Pointer) { + SkipToNextComponent(); + } 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(at, comp.offset())}; - comp.EstablishDescriptor(ptrDesc, instance, terminator); + for (; !Elementwise::IsComplete(); Elementwise::Advance()) { + Descriptor &ptrDesc{*instance_.ElementComponent( + 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()) { + SkipToNextComponent(); + } 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 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(at, comp.offset()), comp.rank(), - extents); - stat = Initialize(compDesc, compType, terminator, hasStat, errMsg); - if (stat != StatOk) { - break; - } + GetComponentExtents(extents, *component_, instance_); + Descriptor &compDesc{componentDescriptor_.descriptor()}; + const typeInfo::DerivedType &compType{*component_->derivedType()}; + compDesc.Establish(compType, + instance_.ElementComponent(subscripts_, component_->offset()), + component_->rank(), extents); + Advance(); + if (int status{workQueue.BeginInitialize(compDesc, compType)}; + status != StatOk) { + return status; } + } else { + SkipToNextComponent(); } } - // 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(k)}; - SubscriptValue at[maxRank]; - instance.GetLowerBounds(at); - for (std::size_t j{0}; j++ < elements; instance.IncrementSubscripts(at)) { - auto &pptr{*instance.ElementComponent( - at, comp.offset)}; - pptr = comp.procInitialization; - } - } - 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}; + int status{workQueue.BeginInitializeClone( + clone, original, derived, hasStat, errMsg)}; + return status == StatContinue ? workQueue.Run() : status; } - // 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(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(at, comp.offset())}; - Descriptor &cloneDesc{ - *clone.ElementComponent(at, comp.offset())}; - if (origDesc.IsAllocated()) { +} + +RT_API_ATTRS int InitializeCloneTicket::Continue(WorkQueue &workQueue) { + while (!IsComplete()) { + if (component_->genre() == typeInfo::Component::Genre::Allocatable) { + Descriptor &origDesc{*instance_.ElementComponent( + subscripts_, component_->offset())}; + if (origDesc.IsAllocated()) { + Descriptor &cloneDesc{*clone_.ElementComponent( + subscripts_, component_->offset())}; + if (phase_ == 0) { + ++phase_; cloneDesc.ApplyMold(origDesc, origDesc.rank()); - stat = ReturnError( - terminator, cloneDesc.Allocate(kNoAsyncObject), 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(kNoAsyncObject), 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. + if (int status{workQueue.BeginInitialize(cloneDesc, *derived)}; + status != StatOk) { + return status; } } } } } - 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. + if (int status{workQueue.BeginInitializeClone( + cloneDesc, origDesc, *derived, hasStat_, errMsg_)}; + status != StatOk) { + return status; + } + } + } } } - } 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 origStaticDesc; - StaticDescriptor cloneStaticDesc; - Descriptor &origDesc{origStaticDesc.descriptor()}; - Descriptor &cloneDesc{cloneStaticDesc.descriptor()}; - // Initialize each element. - for (std::size_t j{0}; j < elements; ++j, orig.IncrementSubscripts(at)) { + Advance(); + } 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(at, comp.offset()), comp.rank(), - extents); + instance_.ElementComponent(subscripts_, component_->offset()), + component_->rank(), extents); cloneDesc.Establish(compType, - clone.ElementComponent(at, comp.offset()), comp.rank(), - extents); - stat = InitializeClone( - cloneDesc, origDesc, compType, terminator, hasStat, errMsg); - if (stat != StatOk) { - break; + clone_.ElementComponent(subscripts_, component_->offset()), + component_->rank(), extents); + Advance(); + if (int status{workQueue.BeginInitializeClone( + cloneDesc, origDesc, compType, hasStat_, errMsg_)}; + status != StatOk) { + return status; } + } else { + SkipToNextComponent(); } + } else { + SkipToNextComponent(); + } + } + 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}; + if (workQueue.BeginFinalize(descriptor, derived) == StatContinue) { + workQueue.Run(); } } - return stat; } static RT_API_ATTRS const typeInfo::SpecialBinding *FindFinal( @@ -221,7 +235,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 +272,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(kNoAsyncObject) == CFI_SUCCESS); + RUNTIME_CHECK(terminator, copy.Allocate(kNoAsyncObject) == CFI_SUCCESS); ShallowCopyDiscontiguousToContiguous(copy, descriptor); argDescriptor = © } @@ -284,87 +296,94 @@ 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(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()) { + finalizableParentType_ = nullptr; + } else { + SkipToNextComponent(); + } + } + return StatContinue; +} + +RT_API_ATTRS int FinalizeTicket::Continue(WorkQueue &workQueue) { + while (!IsComplete()) { + 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(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( + subscripts_, component_->offset())}; + Advance(); + if (compDesc.IsAllocated()) { + if (const DescriptorAddendum *addendum{compDesc.Addendum()}) { + if (const typeInfo::DerivedType *compDynamicType{ + addendum->derivedType()}) { + if (!compDynamicType->noFinalizationNeeded()) { + if (int status{ + workQueue.BeginFinalize(compDesc, *compDynamicType)}; + status != StatOk) { + return status; } } } } } - } 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(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( + subscripts_, component_->offset())}; + Advance(); + if (compDesc.IsAllocated()) { + if (int status{workQueue.BeginFinalize(compDesc, *compType)}; + status != StatOk) { + return status; } } + } else { + SkipToNextComponent(); } - } 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 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(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(subscripts_, component_->offset()), + component_->rank(), extents); + Advance(); + if (int status{workQueue.BeginFinalize(compDesc, compType)}; + status != StatOk) { + return status; } + } else { + SkipToNextComponent(); } } - if (recurse) { - StaticDescriptor 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(); + const auto &parentType{*finalizableParentType_}; + finalizableParentType_ = nullptr; + // Don't return StatOk here if the nested FInalize is still running; + // it needs this->componentDescriptor_. + return workQueue.BeginFinalize(tmpDesc, parentType); } + return StatOk; } // The order of finalization follows Fortran 2018 7.5.6.2, with @@ -373,51 +392,71 @@ 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}; + if (workQueue.BeginDestroy(descriptor, derived, finalize) == StatContinue) { + workQueue.Run(); + } } - if (finalize && !derived.noFinalizationNeeded()) { - Finalize(descriptor, derived, terminator); +} + +RT_API_ATTRS int DestroyTicket::Begin(WorkQueue &workQueue) { + if (finalize_ && !derived_.noFinalizationNeeded()) { + if (int status{workQueue.BeginFinalize(instance_, derived_)}; + status != StatOk && status != StatContinue) { + return status; + } } + return StatContinue; +} + +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(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(at, comp.offset())}; - if (destroyComp) { - Destroy(*d, /*finalize=*/false, *comp.derivedType(), terminator); + while (!IsComplete()) { + const auto *componentDerived{component_->derivedType()}; + if (component_->genre() == typeInfo::Component::Genre::Allocatable || + component_->genre() == typeInfo::Component::Genre::Automatic) { + Descriptor *d{instance_.ElementComponent( + subscripts_, component_->offset())}; + if (d->IsAllocated()) { + if (phase_ == 0) { + ++phase_; + if (componentDerived && !componentDerived->noDestructionNeeded()) { + if (int status{workQueue.BeginDestroy( + *d, *componentDerived, /*finalize=*/false)}; + status != StatOk) { + return status; + } + } } d->Deallocate(); - descriptor.IncrementSubscripts(at); } - } else if (destroyComp && - comp.genre() == typeInfo::Component::Genre::Data) { - SubscriptValue extents[maxRank]; - GetComponentExtents(extents, comp, descriptor); - StaticDescriptor staticDescriptor; - Descriptor &compDesc{staticDescriptor.descriptor()}; - const typeInfo::DerivedType &compType{*comp.derivedType()}; - for (std::size_t j{0}; j++ < elements; - descriptor.IncrementSubscripts(at)) { + Advance(); + } else if (component_->genre() == typeInfo::Component::Genre::Data) { + if (!componentDerived || componentDerived->noDestructionNeeded()) { + SkipToNextComponent(); + } else { + SubscriptValue extents[maxRank]; + GetComponentExtents(extents, *component_, instance_); + Descriptor &compDesc{componentDescriptor_.descriptor()}; + const typeInfo::DerivedType &compType{*componentDerived}; compDesc.Establish(compType, - descriptor.ElementComponent(at, comp.offset()), comp.rank(), - extents); - Destroy(compDesc, /*finalize=*/false, *comp.derivedType(), terminator); + instance_.ElementComponent(subscripts_, component_->offset()), + component_->rank(), extents); + Advance(); + if (int status{workQueue.BeginDestroy( + compDesc, *componentDerived, /*finalize=*/false)}; + status != StatOk) { + return status; + } } + } else { + SkipToNextComponent(); } } + return StatOk; } RT_API_ATTRS bool HasDynamicComponent(const Descriptor &descriptor) { diff --git a/flang-rt/lib/runtime/descriptor-io.cpp b/flang-rt/lib/runtime/descriptor-io.cpp index 3db1455af52fe..364724b89ba0d 100644 --- a/flang-rt/lib/runtime/descriptor-io.cpp +++ b/flang-rt/lib/runtime/descriptor-io.cpp @@ -7,15 +7,44 @@ //===----------------------------------------------------------------------===// #include "descriptor-io.h" +#include "edit-input.h" +#include "edit-output.h" +#include "unit.h" +#include "flang-rt/runtime/descriptor.h" +#include "flang-rt/runtime/io-stmt.h" +#include "flang-rt/runtime/namelist.h" +#include "flang-rt/runtime/terminator.h" +#include "flang-rt/runtime/type-info.h" +#include "flang-rt/runtime/work-queue.h" +#include "flang/Common/optional.h" #include "flang/Common/restorer.h" +#include "flang/Common/uint128.h" +#include "flang/Runtime/cpp-type.h" #include "flang/Runtime/freestanding-tools.h" +// Implementation of I/O data list item transfers based on descriptors. +// (All I/O items come through here so that the code is exercised for test; +// some scalar I/O data transfer APIs could be changed to bypass their use +// of descriptors in the future for better efficiency.) + namespace Fortran::runtime::io::descr { RT_OFFLOAD_API_GROUP_BEGIN +template +inline RT_API_ATTRS A &ExtractElement(IoStatementState &io, + const Descriptor &descriptor, const SubscriptValue subscripts[]) { + A *p{descriptor.Element(subscripts)}; + if (!p) { + io.GetIoErrorHandler().Crash("Bad address for I/O item -- null base " + "address or subscripts out of range"); + } + return *p; +} + // Defined formatted I/O (maybe) -Fortran::common::optional DefinedFormattedIo(IoStatementState &io, - const Descriptor &descriptor, const typeInfo::DerivedType &derived, +static RT_API_ATTRS Fortran::common::optional DefinedFormattedIo( + IoStatementState &io, const Descriptor &descriptor, + const typeInfo::DerivedType &derived, const typeInfo::SpecialBinding &special, const SubscriptValue subscripts[]) { Fortran::common::optional peek{ @@ -104,8 +133,8 @@ Fortran::common::optional DefinedFormattedIo(IoStatementState &io, } // Defined unformatted I/O -bool DefinedUnformattedIo(IoStatementState &io, const Descriptor &descriptor, - const typeInfo::DerivedType &derived, +static RT_API_ATTRS bool DefinedUnformattedIo(IoStatementState &io, + const Descriptor &descriptor, const typeInfo::DerivedType &derived, const typeInfo::SpecialBinding &special) { // Unformatted I/O must have an external unit (or child thereof). IoErrorHandler &handler{io.GetIoErrorHandler()}; @@ -152,5 +181,619 @@ bool DefinedUnformattedIo(IoStatementState &io, const Descriptor &descriptor, return handler.GetIoStat() == IostatOk; } +// Per-category descriptor-based I/O templates + +// TODO (perhaps as a nontrivial but small starter project): implement +// automatic repetition counts, like "10*3.14159", for list-directed and +// NAMELIST array output. + +template +inline RT_API_ATTRS bool FormattedIntegerIO(IoStatementState &io, + const Descriptor &descriptor, [[maybe_unused]] bool isSigned) { + std::size_t numElements{descriptor.Elements()}; + SubscriptValue subscripts[maxRank]; + descriptor.GetLowerBounds(subscripts); + using IntType = CppTypeFor; + bool anyInput{false}; + for (std::size_t j{0}; j < numElements; ++j) { + if (auto edit{io.GetNextDataEdit()}) { + IntType &x{ExtractElement(io, descriptor, subscripts)}; + if constexpr (DIR == Direction::Output) { + if (!EditIntegerOutput(io, *edit, x, isSigned)) { + return false; + } + } else if (edit->descriptor != DataEdit::ListDirectedNullValue) { + if (EditIntegerInput( + io, *edit, reinterpret_cast(&x), KIND, isSigned)) { + anyInput = true; + } else { + return anyInput && edit->IsNamelist(); + } + } + if (!descriptor.IncrementSubscripts(subscripts) && j + 1 < numElements) { + io.GetIoErrorHandler().Crash( + "FormattedIntegerIO: subscripts out of bounds"); + } + } else { + return false; + } + } + return true; +} + +template +inline RT_API_ATTRS bool FormattedRealIO( + IoStatementState &io, const Descriptor &descriptor) { + std::size_t numElements{descriptor.Elements()}; + SubscriptValue subscripts[maxRank]; + descriptor.GetLowerBounds(subscripts); + using RawType = typename RealOutputEditing::BinaryFloatingPoint; + bool anyInput{false}; + for (std::size_t j{0}; j < numElements; ++j) { + if (auto edit{io.GetNextDataEdit()}) { + RawType &x{ExtractElement(io, descriptor, subscripts)}; + if constexpr (DIR == Direction::Output) { + if (!RealOutputEditing{io, x}.Edit(*edit)) { + return false; + } + } else if (edit->descriptor != DataEdit::ListDirectedNullValue) { + if (EditRealInput(io, *edit, reinterpret_cast(&x))) { + anyInput = true; + } else { + return anyInput && edit->IsNamelist(); + } + } + if (!descriptor.IncrementSubscripts(subscripts) && j + 1 < numElements) { + io.GetIoErrorHandler().Crash( + "FormattedRealIO: subscripts out of bounds"); + } + } else { + return false; + } + } + return true; +} + +template +inline RT_API_ATTRS bool FormattedComplexIO( + IoStatementState &io, const Descriptor &descriptor) { + std::size_t numElements{descriptor.Elements()}; + SubscriptValue subscripts[maxRank]; + descriptor.GetLowerBounds(subscripts); + bool isListOutput{ + io.get_if>() != nullptr}; + using RawType = typename RealOutputEditing::BinaryFloatingPoint; + bool anyInput{false}; + for (std::size_t j{0}; j < numElements; ++j) { + RawType *x{&ExtractElement(io, descriptor, subscripts)}; + if (isListOutput) { + DataEdit rEdit, iEdit; + rEdit.descriptor = DataEdit::ListDirectedRealPart; + iEdit.descriptor = DataEdit::ListDirectedImaginaryPart; + rEdit.modes = iEdit.modes = io.mutableModes(); + if (!RealOutputEditing{io, x[0]}.Edit(rEdit) || + !RealOutputEditing{io, x[1]}.Edit(iEdit)) { + return false; + } + } else { + for (int k{0}; k < 2; ++k, ++x) { + auto edit{io.GetNextDataEdit()}; + if (!edit) { + return false; + } else if constexpr (DIR == Direction::Output) { + if (!RealOutputEditing{io, *x}.Edit(*edit)) { + return false; + } + } else if (edit->descriptor == DataEdit::ListDirectedNullValue) { + break; + } else if (EditRealInput( + io, *edit, reinterpret_cast(x))) { + anyInput = true; + } else { + return anyInput && edit->IsNamelist(); + } + } + } + if (!descriptor.IncrementSubscripts(subscripts) && j + 1 < numElements) { + io.GetIoErrorHandler().Crash( + "FormattedComplexIO: subscripts out of bounds"); + } + } + return true; +} + +template +inline RT_API_ATTRS bool FormattedCharacterIO( + IoStatementState &io, const Descriptor &descriptor) { + std::size_t numElements{descriptor.Elements()}; + SubscriptValue subscripts[maxRank]; + descriptor.GetLowerBounds(subscripts); + std::size_t length{descriptor.ElementBytes() / sizeof(A)}; + auto *listOutput{io.get_if>()}; + bool anyInput{false}; + for (std::size_t j{0}; j < numElements; ++j) { + A *x{&ExtractElement(io, descriptor, subscripts)}; + if (listOutput) { + if (!ListDirectedCharacterOutput(io, *listOutput, x, length)) { + return false; + } + } else if (auto edit{io.GetNextDataEdit()}) { + if constexpr (DIR == Direction::Output) { + if (!EditCharacterOutput(io, *edit, x, length)) { + return false; + } + } else { // input + if (edit->descriptor != DataEdit::ListDirectedNullValue) { + if (EditCharacterInput(io, *edit, x, length)) { + anyInput = true; + } else { + return anyInput && edit->IsNamelist(); + } + } + } + } else { + return false; + } + if (!descriptor.IncrementSubscripts(subscripts) && j + 1 < numElements) { + io.GetIoErrorHandler().Crash( + "FormattedCharacterIO: subscripts out of bounds"); + } + } + return true; +} + +template +inline RT_API_ATTRS bool FormattedLogicalIO( + IoStatementState &io, const Descriptor &descriptor) { + std::size_t numElements{descriptor.Elements()}; + SubscriptValue subscripts[maxRank]; + descriptor.GetLowerBounds(subscripts); + auto *listOutput{io.get_if>()}; + using IntType = CppTypeFor; + bool anyInput{false}; + for (std::size_t j{0}; j < numElements; ++j) { + IntType &x{ExtractElement(io, descriptor, subscripts)}; + if (listOutput) { + if (!ListDirectedLogicalOutput(io, *listOutput, x != 0)) { + return false; + } + } else if (auto edit{io.GetNextDataEdit()}) { + if constexpr (DIR == Direction::Output) { + if (!EditLogicalOutput(io, *edit, x != 0)) { + return false; + } + } else { + if (edit->descriptor != DataEdit::ListDirectedNullValue) { + bool truth{}; + if (EditLogicalInput(io, *edit, truth)) { + x = truth; + anyInput = true; + } else { + return anyInput && edit->IsNamelist(); + } + } + } + } else { + return false; + } + if (!descriptor.IncrementSubscripts(subscripts) && j + 1 < numElements) { + io.GetIoErrorHandler().Crash( + "FormattedLogicalIO: subscripts out of bounds"); + } + } + return true; +} + +template +RT_API_ATTRS int DerivedIoTicket::Continue(WorkQueue &workQueue) { + while (!IsComplete()) { + if (component_->genre() == typeInfo::Component::Genre::Data) { + // Create a descriptor for the component + Descriptor &compDesc{componentDescriptor_.descriptor()}; + component_->CreatePointerDescriptor( + compDesc, instance_, io_.GetIoErrorHandler(), subscripts_); + Advance(); + if (int status{workQueue.BeginDescriptorIo( + io_, compDesc, table_, anyIoTookPlace_)}; + status != StatOk) { + return status; + } + } else { + // Component is itself a descriptor + char *pointer{ + instance_.Element(subscripts_) + component_->offset()}; + const Descriptor &compDesc{ + *reinterpret_cast(pointer)}; + Advance(); + if (compDesc.IsAllocated()) { + if (int status{workQueue.BeginDescriptorIo( + io_, compDesc, table_, anyIoTookPlace_)}; + status != StatOk) { + return status; + } + } + } + } + return StatOk; +} + +template RT_API_ATTRS int DerivedIoTicket::Continue( + WorkQueue &); +template RT_API_ATTRS int DerivedIoTicket::Continue( + WorkQueue &); + +template +RT_API_ATTRS int DescriptorIoTicket::Begin(WorkQueue &workQueue) { + IoErrorHandler &handler{io_.GetIoErrorHandler()}; + if (handler.InError()) { + return handler.GetIoStat(); + } + if (!io_.get_if>()) { + handler.Crash("DescriptorIO() called for wrong I/O direction"); + return handler.GetIoStat(); + } + if constexpr (DIR == Direction::Input) { + if (!io_.BeginReadingRecord()) { + return StatOk; + } + } + if (!io_.get_if>()) { + // Unformatted I/O + IoErrorHandler &handler{io_.GetIoErrorHandler()}; + const DescriptorAddendum *addendum{instance_.Addendum()}; + if (const typeInfo::DerivedType *type{ + addendum ? addendum->derivedType() : nullptr}) { + // derived type unformatted I/O + if (table_) { + if (const auto *definedIo{table_->Find(*type, + DIR == Direction::Input + ? common::DefinedIo::ReadUnformatted + : common::DefinedIo::WriteUnformatted)}) { + if (definedIo->subroutine) { + typeInfo::SpecialBinding special{DIR == Direction::Input + ? typeInfo::SpecialBinding::Which::ReadUnformatted + : typeInfo::SpecialBinding::Which::WriteUnformatted, + definedIo->subroutine, definedIo->isDtvArgPolymorphic, false, + false}; + if (DefinedUnformattedIo(io_, instance_, *type, special)) { + anyIoTookPlace_ = true; + return StatOk; + } + } else { + int status{workQueue.BeginDerivedIo( + io_, instance_, *type, table_, anyIoTookPlace_)}; + return status == StatContinue ? StatOk : status; // done here + } + } + } + if (const typeInfo::SpecialBinding *special{ + type->FindSpecialBinding(DIR == Direction::Input + ? typeInfo::SpecialBinding::Which::ReadUnformatted + : typeInfo::SpecialBinding::Which::WriteUnformatted)}) { + if (!table_ || !table_->ignoreNonTbpEntries || special->isTypeBound()) { + // defined derived type unformatted I/O + if (DefinedUnformattedIo(io_, instance_, *type, *special)) { + anyIoTookPlace_ = true; + return StatOk; + } else { + return IostatEnd; + } + } + } + // Default derived type unformatted I/O + // TODO: If no component at any level has defined READ or WRITE + // (as appropriate), the elements are contiguous, and no byte swapping + // is active, do a block transfer via the code below. + int status{workQueue.BeginDerivedIo( + io_, instance_, *type, table_, anyIoTookPlace_)}; + return status == StatContinue ? StatOk : status; // done here + } else { + // intrinsic type unformatted I/O + auto *externalUnf{io_.get_if>()}; + ChildUnformattedIoStatementState *childUnf{nullptr}; + InquireIOLengthState *inq{nullptr}; + bool swapEndianness{false}; + if (externalUnf) { + swapEndianness = externalUnf->unit().swapEndianness(); + } else { + childUnf = io_.get_if>(); + if (!childUnf) { + inq = DIR == Direction::Output ? io_.get_if() + : nullptr; + RUNTIME_CHECK(handler, inq != nullptr); + } + } + std::size_t elementBytes{instance_.ElementBytes()}; + std::size_t swappingBytes{elementBytes}; + if (auto maybeCatAndKind{instance_.type().GetCategoryAndKind()}) { + // Byte swapping units can be smaller than elements, namely + // for COMPLEX and CHARACTER. + if (maybeCatAndKind->first == TypeCategory::Character) { + // swap each character position independently + swappingBytes = maybeCatAndKind->second; // kind + } else if (maybeCatAndKind->first == TypeCategory::Complex) { + // swap real and imaginary components independently + swappingBytes /= 2; + } + } + using CharType = + std::conditional_t; + auto Transfer{[=](CharType &x, std::size_t totalBytes) -> bool { + if constexpr (DIR == Direction::Output) { + return externalUnf ? externalUnf->Emit(&x, totalBytes, swappingBytes) + : childUnf ? childUnf->Emit(&x, totalBytes, swappingBytes) + : inq->Emit(&x, totalBytes, swappingBytes); + } else { + return externalUnf + ? externalUnf->Receive(&x, totalBytes, swappingBytes) + : childUnf->Receive(&x, totalBytes, swappingBytes); + } + }}; + if (!swapEndianness && + instance_.IsContiguous()) { // contiguous unformatted I/O + char &x{ExtractElement(io_, instance_, subscripts_)}; + if (Transfer(x, elements_ * elementBytes)) { + anyIoTookPlace_ = true; + } else { + return IostatEnd; + } + } else { // non-contiguous or byte-swapped intrinsic type unformatted I/O + for (; !IsComplete(); Advance()) { + char &x{ExtractElement(io_, instance_, subscripts_)}; + if (Transfer(x, elementBytes)) { + anyIoTookPlace_ = true; + } else { + return IostatEnd; + } + } + } + } + // Unformatted I/O never needs to call Continue(). + return StatOk; + } + // Formatted I/O + if (auto catAndKind{instance_.type().GetCategoryAndKind()}) { + TypeCategory cat{catAndKind->first}; + int kind{catAndKind->second}; + bool any{false}; + switch (cat) { + case TypeCategory::Integer: + switch (kind) { + case 1: + any = FormattedIntegerIO<1, DIR>(io_, instance_, true); + break; + case 2: + any = FormattedIntegerIO<2, DIR>(io_, instance_, true); + break; + case 4: + any = FormattedIntegerIO<4, DIR>(io_, instance_, true); + break; + case 8: + any = FormattedIntegerIO<8, DIR>(io_, instance_, true); + break; + case 16: + any = FormattedIntegerIO<16, DIR>(io_, instance_, true); + break; + default: + handler.Crash( + "not yet implemented: INTEGER(KIND=%d) in formatted IO", kind); + return IostatEnd; + } + break; + case TypeCategory::Unsigned: + switch (kind) { + case 1: + any = FormattedIntegerIO<1, DIR>(io_, instance_, false); + break; + case 2: + any = FormattedIntegerIO<2, DIR>(io_, instance_, false); + break; + case 4: + any = FormattedIntegerIO<4, DIR>(io_, instance_, false); + break; + case 8: + any = FormattedIntegerIO<8, DIR>(io_, instance_, false); + break; + case 16: + any = FormattedIntegerIO<16, DIR>(io_, instance_, false); + break; + default: + handler.Crash( + "not yet implemented: UNSIGNED(KIND=%d) in formatted IO", kind); + return IostatEnd; + } + break; + case TypeCategory::Real: + switch (kind) { + case 2: + any = FormattedRealIO<2, DIR>(io_, instance_); + break; + case 3: + any = FormattedRealIO<3, DIR>(io_, instance_); + break; + case 4: + any = FormattedRealIO<4, DIR>(io_, instance_); + break; + case 8: + any = FormattedRealIO<8, DIR>(io_, instance_); + break; + case 10: + any = FormattedRealIO<10, DIR>(io_, instance_); + break; + // TODO: case double/double + case 16: + any = FormattedRealIO<16, DIR>(io_, instance_); + break; + default: + handler.Crash( + "not yet implemented: REAL(KIND=%d) in formatted IO", kind); + return IostatEnd; + } + break; + case TypeCategory::Complex: + switch (kind) { + case 2: + any = FormattedComplexIO<2, DIR>(io_, instance_); + break; + case 3: + any = FormattedComplexIO<3, DIR>(io_, instance_); + break; + case 4: + any = FormattedComplexIO<4, DIR>(io_, instance_); + break; + case 8: + any = FormattedComplexIO<8, DIR>(io_, instance_); + break; + case 10: + any = FormattedComplexIO<10, DIR>(io_, instance_); + break; + // TODO: case double/double + case 16: + any = FormattedComplexIO<16, DIR>(io_, instance_); + break; + default: + handler.Crash( + "not yet implemented: COMPLEX(KIND=%d) in formatted IO", kind); + return IostatEnd; + } + break; + case TypeCategory::Character: + switch (kind) { + case 1: + any = FormattedCharacterIO(io_, instance_); + break; + case 2: + any = FormattedCharacterIO(io_, instance_); + break; + case 4: + any = FormattedCharacterIO(io_, instance_); + break; + default: + handler.Crash( + "not yet implemented: CHARACTER(KIND=%d) in formatted IO", kind); + return IostatEnd; + } + break; + case TypeCategory::Logical: + switch (kind) { + case 1: + any = FormattedLogicalIO<1, DIR>(io_, instance_); + break; + case 2: + any = FormattedLogicalIO<2, DIR>(io_, instance_); + break; + case 4: + any = FormattedLogicalIO<4, DIR>(io_, instance_); + break; + case 8: + any = FormattedLogicalIO<8, DIR>(io_, instance_); + break; + default: + handler.Crash( + "not yet implemented: LOGICAL(KIND=%d) in formatted IO", kind); + return IostatEnd; + } + break; + case TypeCategory::Derived: { + // Derived type information must be present for formatted I/O. + IoErrorHandler &handler{io_.GetIoErrorHandler()}; + const DescriptorAddendum *addendum{instance_.Addendum()}; + RUNTIME_CHECK(handler, addendum != nullptr); + derived_ = addendum->derivedType(); + RUNTIME_CHECK(handler, derived_ != nullptr); + if (table_) { + if (const auto *definedIo{table_->Find(*derived_, + DIR == Direction::Input ? common::DefinedIo::ReadFormatted + : common::DefinedIo::WriteFormatted)}) { + if (definedIo->subroutine) { + nonTbpSpecial_.emplace(DIR == Direction::Input + ? typeInfo::SpecialBinding::Which::ReadFormatted + : typeInfo::SpecialBinding::Which::WriteFormatted, + definedIo->subroutine, definedIo->isDtvArgPolymorphic, false, + false); + special_ = &*nonTbpSpecial_; + } + } + } + if (!special_) { + if (const typeInfo::SpecialBinding *binding{ + derived_->FindSpecialBinding(DIR == Direction::Input + ? typeInfo::SpecialBinding::Which::ReadFormatted + : typeInfo::SpecialBinding::Which::WriteFormatted)}) { + if (!table_ || !table_->ignoreNonTbpEntries || + binding->isTypeBound()) { + special_ = binding; + } + } + } + return StatContinue; + } + } + if (any) { + anyIoTookPlace_ = true; + } else { + return IostatEnd; + } + } else { + handler.Crash("DescriptorIO: bad type code (%d) in descriptor", + static_cast(instance_.type().raw())); + return handler.GetIoStat(); + } + return StatOk; +} + +template RT_API_ATTRS int DescriptorIoTicket::Begin( + WorkQueue &); +template RT_API_ATTRS int DescriptorIoTicket::Begin( + WorkQueue &); + +template +RT_API_ATTRS int DescriptorIoTicket::Continue(WorkQueue &workQueue) { + // Only derived type formatted I/O gets here. + while (!IsComplete()) { + if (special_) { + if (auto defined{DefinedFormattedIo( + io_, instance_, *derived_, *special_, subscripts_)}) { + anyIoTookPlace_ |= *defined; + Advance(); + continue; + } + } + Descriptor &elementDesc{elementDescriptor_.descriptor()}; + elementDesc.Establish( + *derived_, nullptr, 0, nullptr, CFI_attribute_pointer); + elementDesc.set_base_addr(instance_.Element(subscripts_)); + Advance(); + if (int status{workQueue.BeginDerivedIo( + io_, elementDesc, *derived_, table_, anyIoTookPlace_)}; + status != StatOk) { + return status; + } + } + return StatOk; +} + +template RT_API_ATTRS int DescriptorIoTicket::Continue( + WorkQueue &); +template RT_API_ATTRS int DescriptorIoTicket::Continue( + WorkQueue &); + +template +RT_API_ATTRS bool DescriptorIO(IoStatementState &io, + const Descriptor &descriptor, const NonTbpDefinedIoTable *table) { + bool anyIoTookPlace{false}; + WorkQueue workQueue{io.GetIoErrorHandler()}; + if (workQueue.BeginDescriptorIo(io, descriptor, table, anyIoTookPlace) == + StatContinue) { + workQueue.Run(); + } + return anyIoTookPlace; +} + +template RT_API_ATTRS bool DescriptorIO( + IoStatementState &, const Descriptor &, const NonTbpDefinedIoTable *); +template RT_API_ATTRS bool DescriptorIO( + IoStatementState &, const Descriptor &, const NonTbpDefinedIoTable *); + RT_OFFLOAD_API_GROUP_END } // namespace Fortran::runtime::io::descr diff --git a/flang-rt/lib/runtime/descriptor-io.h b/flang-rt/lib/runtime/descriptor-io.h index eb60f106c9203..88ad59bd24b53 100644 --- a/flang-rt/lib/runtime/descriptor-io.h +++ b/flang-rt/lib/runtime/descriptor-io.h @@ -9,619 +9,27 @@ #ifndef FLANG_RT_RUNTIME_DESCRIPTOR_IO_H_ #define FLANG_RT_RUNTIME_DESCRIPTOR_IO_H_ -// Implementation of I/O data list item transfers based on descriptors. -// (All I/O items come through here so that the code is exercised for test; -// some scalar I/O data transfer APIs could be changed to bypass their use -// of descriptors in the future for better efficiency.) +#include "flang-rt/runtime/connection.h" -#include "edit-input.h" -#include "edit-output.h" -#include "unit.h" -#include "flang-rt/runtime/descriptor.h" -#include "flang-rt/runtime/io-stmt.h" -#include "flang-rt/runtime/namelist.h" -#include "flang-rt/runtime/terminator.h" -#include "flang-rt/runtime/type-info.h" -#include "flang/Common/optional.h" -#include "flang/Common/uint128.h" -#include "flang/Runtime/cpp-type.h" +namespace Fortran::runtime { +class Descriptor; +} // namespace Fortran::runtime -namespace Fortran::runtime::io::descr { -template -inline RT_API_ATTRS A &ExtractElement(IoStatementState &io, - const Descriptor &descriptor, const SubscriptValue subscripts[]) { - A *p{descriptor.Element(subscripts)}; - if (!p) { - io.GetIoErrorHandler().Crash("Bad address for I/O item -- null base " - "address or subscripts out of range"); - } - return *p; -} - -// Per-category descriptor-based I/O templates - -// TODO (perhaps as a nontrivial but small starter project): implement -// automatic repetition counts, like "10*3.14159", for list-directed and -// NAMELIST array output. - -template -inline RT_API_ATTRS bool FormattedIntegerIO(IoStatementState &io, - const Descriptor &descriptor, [[maybe_unused]] bool isSigned) { - std::size_t numElements{descriptor.Elements()}; - SubscriptValue subscripts[maxRank]; - descriptor.GetLowerBounds(subscripts); - using IntType = CppTypeFor; - bool anyInput{false}; - for (std::size_t j{0}; j < numElements; ++j) { - if (auto edit{io.GetNextDataEdit()}) { - IntType &x{ExtractElement(io, descriptor, subscripts)}; - if constexpr (DIR == Direction::Output) { - if (!EditIntegerOutput(io, *edit, x, isSigned)) { - return false; - } - } else if (edit->descriptor != DataEdit::ListDirectedNullValue) { - if (EditIntegerInput( - io, *edit, reinterpret_cast(&x), KIND, isSigned)) { - anyInput = true; - } else { - return anyInput && edit->IsNamelist(); - } - } - if (!descriptor.IncrementSubscripts(subscripts) && j + 1 < numElements) { - io.GetIoErrorHandler().Crash( - "FormattedIntegerIO: subscripts out of bounds"); - } - } else { - return false; - } - } - return true; -} - -template -inline RT_API_ATTRS bool FormattedRealIO( - IoStatementState &io, const Descriptor &descriptor) { - std::size_t numElements{descriptor.Elements()}; - SubscriptValue subscripts[maxRank]; - descriptor.GetLowerBounds(subscripts); - using RawType = typename RealOutputEditing::BinaryFloatingPoint; - bool anyInput{false}; - for (std::size_t j{0}; j < numElements; ++j) { - if (auto edit{io.GetNextDataEdit()}) { - RawType &x{ExtractElement(io, descriptor, subscripts)}; - if constexpr (DIR == Direction::Output) { - if (!RealOutputEditing{io, x}.Edit(*edit)) { - return false; - } - } else if (edit->descriptor != DataEdit::ListDirectedNullValue) { - if (EditRealInput(io, *edit, reinterpret_cast(&x))) { - anyInput = true; - } else { - return anyInput && edit->IsNamelist(); - } - } - if (!descriptor.IncrementSubscripts(subscripts) && j + 1 < numElements) { - io.GetIoErrorHandler().Crash( - "FormattedRealIO: subscripts out of bounds"); - } - } else { - return false; - } - } - return true; -} +namespace Fortran::runtime::io { +class IoStatementState; +struct NonTbpDefinedIoTable; +} // namespace Fortran::runtime::io -template -inline RT_API_ATTRS bool FormattedComplexIO( - IoStatementState &io, const Descriptor &descriptor) { - std::size_t numElements{descriptor.Elements()}; - SubscriptValue subscripts[maxRank]; - descriptor.GetLowerBounds(subscripts); - bool isListOutput{ - io.get_if>() != nullptr}; - using RawType = typename RealOutputEditing::BinaryFloatingPoint; - bool anyInput{false}; - for (std::size_t j{0}; j < numElements; ++j) { - RawType *x{&ExtractElement(io, descriptor, subscripts)}; - if (isListOutput) { - DataEdit rEdit, iEdit; - rEdit.descriptor = DataEdit::ListDirectedRealPart; - iEdit.descriptor = DataEdit::ListDirectedImaginaryPart; - rEdit.modes = iEdit.modes = io.mutableModes(); - if (!RealOutputEditing{io, x[0]}.Edit(rEdit) || - !RealOutputEditing{io, x[1]}.Edit(iEdit)) { - return false; - } - } else { - for (int k{0}; k < 2; ++k, ++x) { - auto edit{io.GetNextDataEdit()}; - if (!edit) { - return false; - } else if constexpr (DIR == Direction::Output) { - if (!RealOutputEditing{io, *x}.Edit(*edit)) { - return false; - } - } else if (edit->descriptor == DataEdit::ListDirectedNullValue) { - break; - } else if (EditRealInput( - io, *edit, reinterpret_cast(x))) { - anyInput = true; - } else { - return anyInput && edit->IsNamelist(); - } - } - } - if (!descriptor.IncrementSubscripts(subscripts) && j + 1 < numElements) { - io.GetIoErrorHandler().Crash( - "FormattedComplexIO: subscripts out of bounds"); - } - } - return true; -} - -template -inline RT_API_ATTRS bool FormattedCharacterIO( - IoStatementState &io, const Descriptor &descriptor) { - std::size_t numElements{descriptor.Elements()}; - SubscriptValue subscripts[maxRank]; - descriptor.GetLowerBounds(subscripts); - std::size_t length{descriptor.ElementBytes() / sizeof(A)}; - auto *listOutput{io.get_if>()}; - bool anyInput{false}; - for (std::size_t j{0}; j < numElements; ++j) { - A *x{&ExtractElement(io, descriptor, subscripts)}; - if (listOutput) { - if (!ListDirectedCharacterOutput(io, *listOutput, x, length)) { - return false; - } - } else if (auto edit{io.GetNextDataEdit()}) { - if constexpr (DIR == Direction::Output) { - if (!EditCharacterOutput(io, *edit, x, length)) { - return false; - } - } else { // input - if (edit->descriptor != DataEdit::ListDirectedNullValue) { - if (EditCharacterInput(io, *edit, x, length)) { - anyInput = true; - } else { - return anyInput && edit->IsNamelist(); - } - } - } - } else { - return false; - } - if (!descriptor.IncrementSubscripts(subscripts) && j + 1 < numElements) { - io.GetIoErrorHandler().Crash( - "FormattedCharacterIO: subscripts out of bounds"); - } - } - return true; -} - -template -inline RT_API_ATTRS bool FormattedLogicalIO( - IoStatementState &io, const Descriptor &descriptor) { - std::size_t numElements{descriptor.Elements()}; - SubscriptValue subscripts[maxRank]; - descriptor.GetLowerBounds(subscripts); - auto *listOutput{io.get_if>()}; - using IntType = CppTypeFor; - bool anyInput{false}; - for (std::size_t j{0}; j < numElements; ++j) { - IntType &x{ExtractElement(io, descriptor, subscripts)}; - if (listOutput) { - if (!ListDirectedLogicalOutput(io, *listOutput, x != 0)) { - return false; - } - } else if (auto edit{io.GetNextDataEdit()}) { - if constexpr (DIR == Direction::Output) { - if (!EditLogicalOutput(io, *edit, x != 0)) { - return false; - } - } else { - if (edit->descriptor != DataEdit::ListDirectedNullValue) { - bool truth{}; - if (EditLogicalInput(io, *edit, truth)) { - x = truth; - anyInput = true; - } else { - return anyInput && edit->IsNamelist(); - } - } - } - } else { - return false; - } - if (!descriptor.IncrementSubscripts(subscripts) && j + 1 < numElements) { - io.GetIoErrorHandler().Crash( - "FormattedLogicalIO: subscripts out of bounds"); - } - } - return true; -} +namespace Fortran::runtime::io::descr { template -static RT_API_ATTRS bool DescriptorIO(IoStatementState &, const Descriptor &, +RT_API_ATTRS bool DescriptorIO(IoStatementState &, const Descriptor &, const NonTbpDefinedIoTable * = nullptr); -// For intrinsic (not defined) derived type I/O, formatted & unformatted -template -static RT_API_ATTRS bool DefaultComponentIO(IoStatementState &io, - const typeInfo::Component &component, const Descriptor &origDescriptor, - const SubscriptValue origSubscripts[], Terminator &terminator, - const NonTbpDefinedIoTable *table) { -#if !defined(RT_DEVICE_AVOID_RECURSION) - if (component.genre() == typeInfo::Component::Genre::Data) { - // Create a descriptor for the component - StaticDescriptor statDesc; - Descriptor &desc{statDesc.descriptor()}; - component.CreatePointerDescriptor( - desc, origDescriptor, terminator, origSubscripts); - return DescriptorIO(io, desc, table); - } else { - // Component is itself a descriptor - char *pointer{ - origDescriptor.Element(origSubscripts) + component.offset()}; - const Descriptor &compDesc{*reinterpret_cast(pointer)}; - return compDesc.IsAllocated() && DescriptorIO(io, compDesc, table); - } -#else - terminator.Crash("not yet implemented: component IO"); -#endif -} - -template -static RT_API_ATTRS bool DefaultComponentwiseFormattedIO(IoStatementState &io, - const Descriptor &descriptor, const typeInfo::DerivedType &type, - const NonTbpDefinedIoTable *table, const SubscriptValue subscripts[]) { - IoErrorHandler &handler{io.GetIoErrorHandler()}; - const Descriptor &compArray{type.component()}; - RUNTIME_CHECK(handler, compArray.rank() == 1); - std::size_t numComponents{compArray.Elements()}; - SubscriptValue at[maxRank]; - compArray.GetLowerBounds(at); - for (std::size_t k{0}; k < numComponents; - ++k, compArray.IncrementSubscripts(at)) { - const typeInfo::Component &component{ - *compArray.Element(at)}; - if (!DefaultComponentIO( - io, component, descriptor, subscripts, handler, table)) { - // Return true for NAMELIST input if any component appeared. - auto *listInput{ - io.get_if>()}; - return DIR == Direction::Input && k > 0 && listInput && - listInput->inNamelistSequence(); - } - } - return true; -} - -template -static RT_API_ATTRS bool DefaultComponentwiseUnformattedIO(IoStatementState &io, - const Descriptor &descriptor, const typeInfo::DerivedType &type, - const NonTbpDefinedIoTable *table) { - IoErrorHandler &handler{io.GetIoErrorHandler()}; - const Descriptor &compArray{type.component()}; - RUNTIME_CHECK(handler, compArray.rank() == 1); - std::size_t numComponents{compArray.Elements()}; - std::size_t numElements{descriptor.Elements()}; - SubscriptValue subscripts[maxRank]; - descriptor.GetLowerBounds(subscripts); - for (std::size_t j{0}; j < numElements; - ++j, descriptor.IncrementSubscripts(subscripts)) { - SubscriptValue at[maxRank]; - compArray.GetLowerBounds(at); - for (std::size_t k{0}; k < numComponents; - ++k, compArray.IncrementSubscripts(at)) { - const typeInfo::Component &component{ - *compArray.Element(at)}; - if (!DefaultComponentIO( - io, component, descriptor, subscripts, handler, table)) { - return false; - } - } - } - return true; -} - -RT_API_ATTRS Fortran::common::optional DefinedFormattedIo( - IoStatementState &, const Descriptor &, const typeInfo::DerivedType &, - const typeInfo::SpecialBinding &, const SubscriptValue[]); - -template -static RT_API_ATTRS bool FormattedDerivedTypeIO(IoStatementState &io, - const Descriptor &descriptor, const NonTbpDefinedIoTable *table) { - IoErrorHandler &handler{io.GetIoErrorHandler()}; - // Derived type information must be present for formatted I/O. - const DescriptorAddendum *addendum{descriptor.Addendum()}; - RUNTIME_CHECK(handler, addendum != nullptr); - const typeInfo::DerivedType *type{addendum->derivedType()}; - RUNTIME_CHECK(handler, type != nullptr); - Fortran::common::optional nonTbpSpecial; - const typeInfo::SpecialBinding *special{nullptr}; - if (table) { - if (const auto *definedIo{table->Find(*type, - DIR == Direction::Input ? common::DefinedIo::ReadFormatted - : common::DefinedIo::WriteFormatted)}) { - if (definedIo->subroutine) { - nonTbpSpecial.emplace(DIR == Direction::Input - ? typeInfo::SpecialBinding::Which::ReadFormatted - : typeInfo::SpecialBinding::Which::WriteFormatted, - definedIo->subroutine, definedIo->isDtvArgPolymorphic, false, - false); - special = &*nonTbpSpecial; - } - } - } - if (!special) { - if (const typeInfo::SpecialBinding * - binding{type->FindSpecialBinding(DIR == Direction::Input - ? typeInfo::SpecialBinding::Which::ReadFormatted - : typeInfo::SpecialBinding::Which::WriteFormatted)}) { - if (!table || !table->ignoreNonTbpEntries || binding->isTypeBound()) { - special = binding; - } - } - } - SubscriptValue subscripts[maxRank]; - descriptor.GetLowerBounds(subscripts); - std::size_t numElements{descriptor.Elements()}; - for (std::size_t j{0}; j < numElements; - ++j, descriptor.IncrementSubscripts(subscripts)) { - Fortran::common::optional result; - if (special) { - result = DefinedFormattedIo(io, descriptor, *type, *special, subscripts); - } - if (!result) { - result = DefaultComponentwiseFormattedIO( - io, descriptor, *type, table, subscripts); - } - if (!result.value()) { - // Return true for NAMELIST input if we got anything. - auto *listInput{ - io.get_if>()}; - return DIR == Direction::Input && j > 0 && listInput && - listInput->inNamelistSequence(); - } - } - return true; -} - -RT_API_ATTRS bool DefinedUnformattedIo(IoStatementState &, const Descriptor &, - const typeInfo::DerivedType &, const typeInfo::SpecialBinding &); +extern template RT_API_ATTRS bool DescriptorIO( + IoStatementState &, const Descriptor &, const NonTbpDefinedIoTable *); +extern template RT_API_ATTRS bool DescriptorIO( + IoStatementState &, const Descriptor &, const NonTbpDefinedIoTable *); -// Unformatted I/O -template -static RT_API_ATTRS bool UnformattedDescriptorIO(IoStatementState &io, - const Descriptor &descriptor, const NonTbpDefinedIoTable *table = nullptr) { - IoErrorHandler &handler{io.GetIoErrorHandler()}; - const DescriptorAddendum *addendum{descriptor.Addendum()}; - if (const typeInfo::DerivedType * - type{addendum ? addendum->derivedType() : nullptr}) { - // derived type unformatted I/O - if (table) { - if (const auto *definedIo{table->Find(*type, - DIR == Direction::Input ? common::DefinedIo::ReadUnformatted - : common::DefinedIo::WriteUnformatted)}) { - if (definedIo->subroutine) { - typeInfo::SpecialBinding special{DIR == Direction::Input - ? typeInfo::SpecialBinding::Which::ReadUnformatted - : typeInfo::SpecialBinding::Which::WriteUnformatted, - definedIo->subroutine, definedIo->isDtvArgPolymorphic, false, - false}; - if (Fortran::common::optional wasDefined{ - DefinedUnformattedIo(io, descriptor, *type, special)}) { - return *wasDefined; - } - } else { - return DefaultComponentwiseUnformattedIO( - io, descriptor, *type, table); - } - } - } - if (const typeInfo::SpecialBinding * - special{type->FindSpecialBinding(DIR == Direction::Input - ? typeInfo::SpecialBinding::Which::ReadUnformatted - : typeInfo::SpecialBinding::Which::WriteUnformatted)}) { - if (!table || !table->ignoreNonTbpEntries || special->isTypeBound()) { - // defined derived type unformatted I/O - return DefinedUnformattedIo(io, descriptor, *type, *special); - } - } - // Default derived type unformatted I/O - // TODO: If no component at any level has defined READ or WRITE - // (as appropriate), the elements are contiguous, and no byte swapping - // is active, do a block transfer via the code below. - return DefaultComponentwiseUnformattedIO(io, descriptor, *type, table); - } else { - // intrinsic type unformatted I/O - auto *externalUnf{io.get_if>()}; - auto *childUnf{io.get_if>()}; - auto *inq{ - DIR == Direction::Output ? io.get_if() : nullptr}; - RUNTIME_CHECK(handler, externalUnf || childUnf || inq); - std::size_t elementBytes{descriptor.ElementBytes()}; - std::size_t numElements{descriptor.Elements()}; - std::size_t swappingBytes{elementBytes}; - if (auto maybeCatAndKind{descriptor.type().GetCategoryAndKind()}) { - // Byte swapping units can be smaller than elements, namely - // for COMPLEX and CHARACTER. - if (maybeCatAndKind->first == TypeCategory::Character) { - // swap each character position independently - swappingBytes = maybeCatAndKind->second; // kind - } else if (maybeCatAndKind->first == TypeCategory::Complex) { - // swap real and imaginary components independently - swappingBytes /= 2; - } - } - SubscriptValue subscripts[maxRank]; - descriptor.GetLowerBounds(subscripts); - using CharType = - std::conditional_t; - auto Transfer{[=](CharType &x, std::size_t totalBytes) -> bool { - if constexpr (DIR == Direction::Output) { - return externalUnf ? externalUnf->Emit(&x, totalBytes, swappingBytes) - : childUnf ? childUnf->Emit(&x, totalBytes, swappingBytes) - : inq->Emit(&x, totalBytes, swappingBytes); - } else { - return externalUnf ? externalUnf->Receive(&x, totalBytes, swappingBytes) - : childUnf->Receive(&x, totalBytes, swappingBytes); - } - }}; - bool swapEndianness{externalUnf && externalUnf->unit().swapEndianness()}; - if (!swapEndianness && - descriptor.IsContiguous()) { // contiguous unformatted I/O - char &x{ExtractElement(io, descriptor, subscripts)}; - return Transfer(x, numElements * elementBytes); - } else { // non-contiguous or byte-swapped intrinsic type unformatted I/O - for (std::size_t j{0}; j < numElements; ++j) { - char &x{ExtractElement(io, descriptor, subscripts)}; - if (!Transfer(x, elementBytes)) { - return false; - } - if (!descriptor.IncrementSubscripts(subscripts) && - j + 1 < numElements) { - handler.Crash("DescriptorIO: subscripts out of bounds"); - } - } - return true; - } - } -} - -template -static RT_API_ATTRS bool DescriptorIO(IoStatementState &io, - const Descriptor &descriptor, const NonTbpDefinedIoTable *table) { - IoErrorHandler &handler{io.GetIoErrorHandler()}; - if (handler.InError()) { - return false; - } - if (!io.get_if>()) { - handler.Crash("DescriptorIO() called for wrong I/O direction"); - return false; - } - if constexpr (DIR == Direction::Input) { - if (!io.BeginReadingRecord()) { - return false; - } - } - if (!io.get_if>()) { - return UnformattedDescriptorIO(io, descriptor, table); - } - if (auto catAndKind{descriptor.type().GetCategoryAndKind()}) { - TypeCategory cat{catAndKind->first}; - int kind{catAndKind->second}; - switch (cat) { - case TypeCategory::Integer: - switch (kind) { - case 1: - return FormattedIntegerIO<1, DIR>(io, descriptor, true); - case 2: - return FormattedIntegerIO<2, DIR>(io, descriptor, true); - case 4: - return FormattedIntegerIO<4, DIR>(io, descriptor, true); - case 8: - return FormattedIntegerIO<8, DIR>(io, descriptor, true); - case 16: - return FormattedIntegerIO<16, DIR>(io, descriptor, true); - default: - handler.Crash( - "not yet implemented: INTEGER(KIND=%d) in formatted IO", kind); - return false; - } - case TypeCategory::Unsigned: - switch (kind) { - case 1: - return FormattedIntegerIO<1, DIR>(io, descriptor, false); - case 2: - return FormattedIntegerIO<2, DIR>(io, descriptor, false); - case 4: - return FormattedIntegerIO<4, DIR>(io, descriptor, false); - case 8: - return FormattedIntegerIO<8, DIR>(io, descriptor, false); - case 16: - return FormattedIntegerIO<16, DIR>(io, descriptor, false); - default: - handler.Crash( - "not yet implemented: UNSIGNED(KIND=%d) in formatted IO", kind); - return false; - } - case TypeCategory::Real: - switch (kind) { - case 2: - return FormattedRealIO<2, DIR>(io, descriptor); - case 3: - return FormattedRealIO<3, DIR>(io, descriptor); - case 4: - return FormattedRealIO<4, DIR>(io, descriptor); - case 8: - return FormattedRealIO<8, DIR>(io, descriptor); - case 10: - return FormattedRealIO<10, DIR>(io, descriptor); - // TODO: case double/double - case 16: - return FormattedRealIO<16, DIR>(io, descriptor); - default: - handler.Crash( - "not yet implemented: REAL(KIND=%d) in formatted IO", kind); - return false; - } - case TypeCategory::Complex: - switch (kind) { - case 2: - return FormattedComplexIO<2, DIR>(io, descriptor); - case 3: - return FormattedComplexIO<3, DIR>(io, descriptor); - case 4: - return FormattedComplexIO<4, DIR>(io, descriptor); - case 8: - return FormattedComplexIO<8, DIR>(io, descriptor); - case 10: - return FormattedComplexIO<10, DIR>(io, descriptor); - // TODO: case double/double - case 16: - return FormattedComplexIO<16, DIR>(io, descriptor); - default: - handler.Crash( - "not yet implemented: COMPLEX(KIND=%d) in formatted IO", kind); - return false; - } - case TypeCategory::Character: - switch (kind) { - case 1: - return FormattedCharacterIO(io, descriptor); - case 2: - return FormattedCharacterIO(io, descriptor); - case 4: - return FormattedCharacterIO(io, descriptor); - default: - handler.Crash( - "not yet implemented: CHARACTER(KIND=%d) in formatted IO", kind); - return false; - } - case TypeCategory::Logical: - switch (kind) { - case 1: - return FormattedLogicalIO<1, DIR>(io, descriptor); - case 2: - return FormattedLogicalIO<2, DIR>(io, descriptor); - case 4: - return FormattedLogicalIO<4, DIR>(io, descriptor); - case 8: - return FormattedLogicalIO<8, DIR>(io, descriptor); - default: - handler.Crash( - "not yet implemented: LOGICAL(KIND=%d) in formatted IO", kind); - return false; - } - case TypeCategory::Derived: - return FormattedDerivedTypeIO(io, descriptor, table); - } - } - handler.Crash("DescriptorIO: bad type code (%d) in descriptor", - static_cast(descriptor.type().raw())); - return false; -} } // namespace Fortran::runtime::io::descr #endif // FLANG_RT_RUNTIME_DESCRIPTOR_IO_H_ diff --git a/flang-rt/lib/runtime/environment.cpp b/flang-rt/lib/runtime/environment.cpp index 1d5304254ed0e..0f0564403c0e2 100644 --- a/flang-rt/lib/runtime/environment.cpp +++ b/flang-rt/lib/runtime/environment.cpp @@ -143,6 +143,10 @@ void ExecutionEnvironment::Configure(int ac, const char *av[], } } + if (auto *x{std::getenv("FLANG_RT_DEBUG")}) { + internalDebugging = std::strtol(x, nullptr, 10); + } + if (auto *x{std::getenv("ACC_OFFLOAD_STACK_SIZE")}) { char *end; auto n{std::strtoul(x, &end, 10)}; diff --git a/flang-rt/lib/runtime/namelist.cpp b/flang-rt/lib/runtime/namelist.cpp index b0cf2180fc6d4..1bef387a9771f 100644 --- a/flang-rt/lib/runtime/namelist.cpp +++ b/flang-rt/lib/runtime/namelist.cpp @@ -10,6 +10,7 @@ #include "descriptor-io.h" #include "flang-rt/runtime/emit-encoded.h" #include "flang-rt/runtime/io-stmt.h" +#include "flang-rt/runtime/type-info.h" #include "flang/Runtime/io-api.h" #include #include diff --git a/flang-rt/lib/runtime/tools.cpp b/flang-rt/lib/runtime/tools.cpp index b08195cd31e05..24d05f369fcbe 100644 --- a/flang-rt/lib/runtime/tools.cpp +++ b/flang-rt/lib/runtime/tools.cpp @@ -205,7 +205,7 @@ RT_API_ATTRS void ShallowCopyInner(const Descriptor &to, const Descriptor &from, // Doing the recursion upwards instead of downwards puts the more common // cases earlier in the if-chain and has a tangible impact on performance. template struct ShallowCopyRankSpecialize { - static bool execute(const Descriptor &to, const Descriptor &from, + static RT_API_ATTRS bool execute(const Descriptor &to, const Descriptor &from, bool toIsContiguous, bool fromIsContiguous) { if (to.rank() == RANK && from.rank() == RANK) { ShallowCopyInner(to, from, toIsContiguous, fromIsContiguous); @@ -217,7 +217,7 @@ template struct ShallowCopyRankSpecialize { }; template struct ShallowCopyRankSpecialize { - static bool execute(const Descriptor &to, const Descriptor &from, + static RT_API_ATTRS bool execute(const Descriptor &to, const Descriptor &from, bool toIsContiguous, bool fromIsContiguous) { return false; } 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(subscripts) + offset_); - } else { - descriptor.set_base_addr(container.OffsetElement() + offset_); + offset += container.SubscriptsToByteOffset(subscripts); } + descriptor.set_base_addr(container.OffsetElement() + 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..a508ecb637102 --- /dev/null +++ b/flang-rt/lib/runtime/work-queue.cpp @@ -0,0 +1,161 @@ +//===-- 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/environment.h" +#include "flang-rt/runtime/memory.h" +#include "flang-rt/runtime/type-info.h" +#include "flang/Common/visit.h" + +namespace Fortran::runtime { + +#if !defined(RT_DEVICE_COMPILATION) +// FLANG_RT_DEBUG code is disabled when false. +static constexpr bool enableDebugOutput{false}; +#endif + +RT_OFFLOAD_API_GROUP_BEGIN + +RT_API_ATTRS Componentwise::Componentwise(const typeInfo::DerivedType &derived) + : derived_{derived}, components_{derived_.component().Elements()} { + GetComponent(); +} + +RT_API_ATTRS void Componentwise::GetComponent() { + if (IsComplete()) { + component_ = nullptr; + } else { + const Descriptor &componentDesc{derived_.component()}; + component_ = componentDesc.ZeroBasedIndexedElement( + componentAt_); + } +} + +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) { + FreeMemory(firstFree_); + } + firstFree_ = next; + } +} + +RT_API_ATTRS Ticket &WorkQueue::StartTicket() { + if (!firstFree_) { + void *p{AllocateMemoryOrCrash(terminator_, sizeof(TicketList))}; + firstFree_ = new (p) 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; +#if !defined(RT_DEVICE_COMPILATION) + if (enableDebugOutput && + (executionEnvironment.internalDebugging & + ExecutionEnvironment::WorkQueue)) { + std::fprintf(stderr, "WQ: new ticket\n"); + } +#endif + return newTicket->ticket; +} + +RT_API_ATTRS int WorkQueue::Run() { + while (last_) { + TicketList *at{last_}; + insertAfter_ = last_; +#if !defined(RT_DEVICE_COMPILATION) + if (enableDebugOutput && + (executionEnvironment.internalDebugging & + ExecutionEnvironment::WorkQueue)) { + std::fprintf(stderr, "WQ: %zd %s\n", at->ticket.u.index(), + at->ticket.begun ? "Continue" : "Begin"); + } +#endif + int stat{at->ticket.Continue(*this)}; +#if !defined(RT_DEVICE_COMPILATION) + if (enableDebugOutput && + (executionEnvironment.internalDebugging & + ExecutionEnvironment::WorkQueue)) { + std::fprintf(stderr, "WQ: ... stat %d\n", stat); + } +#endif + 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 != StatContinue) { + 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 diff --git a/flang-rt/unittests/Runtime/ExternalIOTest.cpp b/flang-rt/unittests/Runtime/ExternalIOTest.cpp index 3833e48be3dd6..6c148b1de6f82 100644 --- a/flang-rt/unittests/Runtime/ExternalIOTest.cpp +++ b/flang-rt/unittests/Runtime/ExternalIOTest.cpp @@ -184,7 +184,7 @@ TEST(ExternalIOTests, TestSequentialFixedUnformatted) { io = IONAME(BeginInquireIoLength)(__FILE__, __LINE__); for (int j{1}; j <= 3; ++j) { ASSERT_TRUE(IONAME(OutputDescriptor)(io, desc)) - << "OutputDescriptor() for InquireIoLength"; + << "OutputDescriptor() for InquireIoLength " << j; } ASSERT_EQ(IONAME(GetIoLength)(io), 3 * recl) << "GetIoLength"; ASSERT_EQ(IONAME(EndIoStatement)(io), IostatOk) diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md index 78d871c593e1d..871749934810c 100644 --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -858,6 +858,16 @@ print *, [(j,j=1,10)] warning since such values may have become defined by the time the nested expression's value is required. +* Intrinsic assignment of arrays is defined elementally, and intrinsic + assignment of derived type components is defined componentwise. + However, when intrinsic assignment takes place for an array of derived + type, the order of the loop nesting is not defined. + Some compilers will loop over the elements, assigning all of the components + of each element before proceeding to the next element. + This compiler loops over all of the components, and assigns all of + the elements for each component before proceeding to the next component. + A program using defined assignment might be able to detect the difference. + ## De Facto Standard Features * `EXTENDS_TYPE_OF()` returns `.TRUE.` if both of its arguments have the 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/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h index 3839bc1d2a215..79f7032aac312 100644 --- a/flang/include/flang/Semantics/tools.h +++ b/flang/include/flang/Semantics/tools.h @@ -182,9 +182,12 @@ const Symbol *HasImpureFinal( const Symbol &, std::optional rank = std::nullopt); // Is this type finalizable or does it contain any polymorphic allocatable // ultimate components? -bool MayRequireFinalization(const DerivedTypeSpec &derived); +bool MayRequireFinalization(const DerivedTypeSpec &); // Does this type have an allocatable direct component? -bool HasAllocatableDirectComponent(const DerivedTypeSpec &derived); +bool HasAllocatableDirectComponent(const DerivedTypeSpec &); +// Does this type have any defined assignment at any level (or any polymorphic +// allocatable)? +bool MayHaveDefinedAssignment(const DerivedTypeSpec &); bool IsInBlankCommon(const Symbol &); bool IsAssumedLengthCharacter(const Symbol &); diff --git a/flang/lib/Semantics/runtime-type-info.cpp b/flang/lib/Semantics/runtime-type-info.cpp index ccc5e37c840a9..2a862e0e2858b 100644 --- a/flang/lib/Semantics/runtime-type-info.cpp +++ b/flang/lib/Semantics/runtime-type-info.cpp @@ -661,6 +661,10 @@ const Symbol *RuntimeTableBuilder::DescribeType( AddValue(dtValues, derivedTypeSchema_, "nofinalizationneeded"s, IntExpr<1>( derivedTypeSpec && !MayRequireFinalization(*derivedTypeSpec))); + // Similarly, a flag to enable optimized runtime assignment. + AddValue(dtValues, derivedTypeSchema_, "nodefinedassignment"s, + IntExpr<1>( + derivedTypeSpec && !MayHaveDefinedAssignment(*derivedTypeSpec))); } dtObject.get().set_init(MaybeExpr{ StructureExpr(Structure(derivedTypeSchema_, std::move(dtValues)))}); diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp index 1d1e3ac044166..3247addc905ba 100644 --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -813,6 +813,38 @@ bool HasAllocatableDirectComponent(const DerivedTypeSpec &derived) { return std::any_of(directs.begin(), directs.end(), IsAllocatable); } +static bool MayHaveDefinedAssignment( + const DerivedTypeSpec &derived, std::set &checked) { + if (const Scope *scope{derived.GetScope()}; + scope && checked.find(scope) == checked.end()) { + checked.insert(scope); + for (const auto &[_, symbolRef] : *scope) { + if (const auto *generic{symbolRef->detailsIf()}) { + if (generic->kind().IsAssignment()) { + return true; + } + } else if (symbolRef->has() && + !IsPointer(*symbolRef)) { + if (const DeclTypeSpec *type{symbolRef->GetType()}) { + if (type->IsPolymorphic()) { + return true; + } else if (const DerivedTypeSpec *derived{type->AsDerived()}) { + if (MayHaveDefinedAssignment(*derived, checked)) { + return true; + } + } + } + } + } + } + return false; +} + +bool MayHaveDefinedAssignment(const DerivedTypeSpec &derived) { + std::set checked; + return MayHaveDefinedAssignment(derived, checked); +} + bool IsAssumedLengthCharacter(const Symbol &symbol) { if (const DeclTypeSpec * type{symbol.GetType()}) { return type->category() == DeclTypeSpec::Character && diff --git a/flang/module/__fortran_type_info.f90 b/flang/module/__fortran_type_info.f90 index b30a6bf697563..7226b06504d28 100644 --- a/flang/module/__fortran_type_info.f90 +++ b/flang/module/__fortran_type_info.f90 @@ -52,7 +52,8 @@ integer(1) :: noInitializationNeeded ! 1 if no component w/ init integer(1) :: noDestructionNeeded ! 1 if no component w/ dealloc/final integer(1) :: noFinalizationNeeded ! 1 if nothing finalizeable - integer(1) :: __padding0(4) + integer(1) :: noDefinedAssignment ! 1 if no defined ASSIGNMENT(=) + integer(1) :: __padding0(3) end type type :: Binding diff --git a/flang/test/Lower/volatile-openmp.f90 b/flang/test/Lower/volatile-openmp.f90 index 28f0bf78f33c9..2e05b652822b5 100644 --- a/flang/test/Lower/volatile-openmp.f90 +++ b/flang/test/Lower/volatile-openmp.f90 @@ -23,11 +23,11 @@ ! CHECK: %[[VAL_11:.*]] = fir.address_of(@_QFEcontainer) : !fir.ref>>}>> ! CHECK: %[[VAL_12:.*]] = fir.volatile_cast %[[VAL_11]] : (!fir.ref>>}>>) -> !fir.ref>>}>, volatile> ! CHECK: %[[VAL_13:.*]]:2 = hlfir.declare %[[VAL_12]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFEcontainer"} : (!fir.ref>>}>, volatile>) -> (!fir.ref>>}>, volatile>, !fir.ref>>}>, volatile>) -! CHECK: %[[VAL_14:.*]] = fir.address_of(@_QFE.c.t) : !fir.ref>>,genre:i8,category:i8,kind:i8,rank:i8,__padding0:!fir.array<4xi8>,offset:i64,characterlen:!fir.type<_QM__fortran_type_infoTvalue{{[<]?}}{genre:i8,__padding0:!fir.array<7xi8>,value:i64}{{[>]?}}>,derived:!fir.box,name:!fir.box>>}>>>>,name:!fir.box>>,sizeinbytes:i64,uninstantiated:!fir.box>>,kindparameter:!fir.box>>,lenparameterkind:!fir.box>>,component:!fir.box>>>,procptr:!fir.box>>,offset:i64,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}>>>>,special:!fir.box,proc:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}{{[>]?}}>>>>,specialbitset:i32,hasparent:i8,noinitializationneeded:i8,nodestructionneeded:i8,nofinalizationneeded:i8,__padding0:!fir.array<4xi8>}>>>,lenvalue:!fir.box,value:i64}{{[>]?}}>>>>,bounds:!fir.box,value:i64}{{[>]?}}>>>>,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>}>>> +! CHECK: %[[VAL_14:.*]] = fir.address_of(@_QFE.c.t) : !fir.ref>>,genre:i8,category:i8,kind:i8,rank:i8,__padding0:!fir.array<4xi8>,offset:i64,characterlen:!fir.type<_QM__fortran_type_infoTvalue{{[<]?}}{genre:i8,__padding0:!fir.array<7xi8>,value:i64}{{[>]?}}>,derived:!fir.box,name:!fir.box>>}>>>>,name:!fir.box>>,sizeinbytes:i64,uninstantiated:!fir.box>>,kindparameter:!fir.box>>,lenparameterkind:!fir.box>>,component:!fir.box>>>,procptr:!fir.box>>,offset:i64,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}>>>>,special:!fir.box,proc:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}{{[>]?}}>>>>,specialbitset:i32,hasparent:i8,noinitializationneeded:i8,nodestructionneeded:i8,nofinalizationneeded:i8,nodefinedassignment:i8,__padding0:!fir.array<3xi8>}>>>,lenvalue:!fir.box,value:i64}{{[>]?}}>>>>,bounds:!fir.box,value:i64}{{[>]?}}>>>>,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>}>>> ! CHECK: %[[VAL_15:.*]] = fir.shape_shift %[[VAL_0]], %[[VAL_1]] : (index, index) -> !fir.shapeshift<1> -! CHECK: %[[VAL_16:.*]]:2 = hlfir.declare %[[VAL_14]](%[[VAL_15]]) {fortran_attrs = #fir.var_attrs, uniq_name = "_QFE.c.t"} : (!fir.ref>>,genre:i8,category:i8,kind:i8,rank:i8,__padding0:!fir.array<4xi8>,offset:i64,characterlen:!fir.type<_QM__fortran_type_infoTvalue{{[<]?}}{genre:i8,__padding0:!fir.array<7xi8>,value:i64}{{[>]?}}>,derived:!fir.box,name:!fir.box>>}>>>>,name:!fir.box>>,sizeinbytes:i64,uninstantiated:!fir.box>>,kindparameter:!fir.box>>,lenparameterkind:!fir.box>>,component:!fir.box>>>,procptr:!fir.box>>,offset:i64,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}>>>>,special:!fir.box,proc:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}{{[>]?}}>>>>,specialbitset:i32,hasparent:i8,noinitializationneeded:i8,nodestructionneeded:i8,nofinalizationneeded:i8,__padding0:!fir.array<4xi8>}>>>,lenvalue:!fir.box,value:i64}{{[>]?}}>>>>,bounds:!fir.box,value:i64}{{[>]?}}>>>>,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>}>>>, !fir.shapeshift<1>) -> (!fir.box>>,genre:i8,category:i8,kind:i8,rank:i8,__padding0:!fir.array<4xi8>,offset:i64,characterlen:!fir.type<_QM__fortran_type_infoTvalue{{[<]?}}{genre:i8,__padding0:!fir.array<7xi8>,value:i64}{{[>]?}}>,derived:!fir.box,name:!fir.box>>}>>>>,name:!fir.box>>,sizeinbytes:i64,uninstantiated:!fir.box>>,kindparameter:!fir.box>>,lenparameterkind:!fir.box>>,component:!fir.box>>>,procptr:!fir.box>>,offset:i64,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}>>>>,special:!fir.box,proc:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}{{[>]?}}>>>>,specialbitset:i32,hasparent:i8,noinitializationneeded:i8,nodestructionneeded:i8,nofinalizationneeded:i8,__padding0:!fir.array<4xi8>}>>>,lenvalue:!fir.box,value:i64}{{[>]?}}>>>>,bounds:!fir.box,value:i64}{{[>]?}}>>>>,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>}>>>, !fir.ref>>,genre:i8,category:i8,kind:i8,rank:i8,__padding0:!fir.array<4xi8>,offset:i64,characterlen:!fir.type<_QM__fortran_type_infoTvalue{{[<]?}}{genre:i8,__padding0:!fir.array<7xi8>,value:i64}{{[>]?}}>,derived:!fir.box,name:!fir.box>>}>>>>,name:!fir.box>>,sizeinbytes:i64,uninstantiated:!fir.box>>,kindparameter:!fir.box>>,lenparameterkind:!fir.box>>,component:!fir.box>>>,procptr:!fir.box>>,offset:i64,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}>>>>,special:!fir.box,proc:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}{{[>]?}}>>>>,specialbitset:i32,hasparent:i8,noinitializationneeded:i8,nodestructionneeded:i8,nofinalizationneeded:i8,__padding0:!fir.array<4xi8>}>>>,lenvalue:!fir.box,value:i64}{{[>]?}}>>>>,bounds:!fir.box,value:i64}{{[>]?}}>>>>,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>}>>>) -! CHECK: %[[VAL_17:.*]] = fir.address_of(@_QFE.dt.t) : !fir.ref,name:!fir.box>>}>>>>,name:!fir.box>>,sizeinbytes:i64,uninstantiated:!fir.box>>,kindparameter:!fir.box>>,lenparameterkind:!fir.box>>,component:!fir.box>>,genre:i8,category:i8,kind:i8,rank:i8,__padding0:!fir.array<4xi8>,offset:i64,characterlen:!fir.type<_QM__fortran_type_infoTvalue{{[<]?}}{genre:i8,__padding0:!fir.array<7xi8>,value:i64}{{[>]?}}>,derived:!fir.box>>,lenvalue:!fir.box,value:i64}{{[>]?}}>>>>,bounds:!fir.box,value:i64}{{[>]?}}>>>>,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>}>>>>,procptr:!fir.box>>,offset:i64,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}>>>>,special:!fir.box,proc:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}{{[>]?}}>>>>,specialbitset:i32,hasparent:i8,noinitializationneeded:i8,nodestructionneeded:i8,nofinalizationneeded:i8,__padding0:!fir.array<4xi8>}>> -! CHECK: %[[VAL_18:.*]]:2 = hlfir.declare %[[VAL_17]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFE.dt.t"} : (!fir.ref,name:!fir.box>>}>>>>,name:!fir.box>>,sizeinbytes:i64,uninstantiated:!fir.box>>,kindparameter:!fir.box>>,lenparameterkind:!fir.box>>,component:!fir.box>>,genre:i8,category:i8,kind:i8,rank:i8,__padding0:!fir.array<4xi8>,offset:i64,characterlen:!fir.type<_QM__fortran_type_infoTvalue{{[<]?}}{genre:i8,__padding0:!fir.array<7xi8>,value:i64}{{[>]?}}>,derived:!fir.box>>,lenvalue:!fir.box,value:i64}{{[>]?}}>>>>,bounds:!fir.box,value:i64}{{[>]?}}>>>>,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>}>>>>,procptr:!fir.box>>,offset:i64,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}>>>>,special:!fir.box,proc:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}{{[>]?}}>>>>,specialbitset:i32,hasparent:i8,noinitializationneeded:i8,nodestructionneeded:i8,nofinalizationneeded:i8,__padding0:!fir.array<4xi8>}>>) -> (!fir.ref,name:!fir.box>>}>>>>,name:!fir.box>>,sizeinbytes:i64,uninstantiated:!fir.box>>,kindparameter:!fir.box>>,lenparameterkind:!fir.box>>,component:!fir.box>>,genre:i8,category:i8,kind:i8,rank:i8,__padding0:!fir.array<4xi8>,offset:i64,characterlen:!fir.type<_QM__fortran_type_infoTvalue{{[<]?}}{genre:i8,__padding0:!fir.array<7xi8>,value:i64}{{[>]?}}>,derived:!fir.box>>,lenvalue:!fir.box,value:i64}{{[>]?}}>>>>,bounds:!fir.box,value:i64}{{[>]?}}>>>>,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>}>>>>,procptr:!fir.box>>,offset:i64,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}>>>>,special:!fir.box,proc:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}{{[>]?}}>>>>,specialbitset:i32,hasparent:i8,noinitializationneeded:i8,nodestructionneeded:i8,nofinalizationneeded:i8,__padding0:!fir.array<4xi8>}>>, !fir.ref,name:!fir.box>>}>>>>,name:!fir.box>>,sizeinbytes:i64,uninstantiated:!fir.box>>,kindparameter:!fir.box>>,lenparameterkind:!fir.box>>,component:!fir.box>>,genre:i8,category:i8,kind:i8,rank:i8,__padding0:!fir.array<4xi8>,offset:i64,characterlen:!fir.type<_QM__fortran_type_infoTvalue{{[<]?}}{genre:i8,__padding0:!fir.array<7xi8>,value:i64}{{[>]?}}>,derived:!fir.box>>,lenvalue:!fir.box,value:i64}{{[>]?}}>>>>,bounds:!fir.box,value:i64}{{[>]?}}>>>>,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>}>>>>,procptr:!fir.box>>,offset:i64,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}>>>>,special:!fir.box,proc:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}{{[>]?}}>>>>,specialbitset:i32,hasparent:i8,noinitializationneeded:i8,nodestructionneeded:i8,nofinalizationneeded:i8,__padding0:!fir.array<4xi8>}>>) +! CHECK: %[[VAL_16:.*]]:2 = hlfir.declare %[[VAL_14]](%[[VAL_15]]) {fortran_attrs = #fir.var_attrs, uniq_name = "_QFE.c.t"} : (!fir.ref>>,genre:i8,category:i8,kind:i8,rank:i8,__padding0:!fir.array<4xi8>,offset:i64,characterlen:!fir.type<_QM__fortran_type_infoTvalue{{[<]?}}{genre:i8,__padding0:!fir.array<7xi8>,value:i64}{{[>]?}}>,derived:!fir.box,name:!fir.box>>}>>>>,name:!fir.box>>,sizeinbytes:i64,uninstantiated:!fir.box>>,kindparameter:!fir.box>>,lenparameterkind:!fir.box>>,component:!fir.box>>>,procptr:!fir.box>>,offset:i64,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}>>>>,special:!fir.box,proc:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}{{[>]?}}>>>>,specialbitset:i32,hasparent:i8,noinitializationneeded:i8,nodestructionneeded:i8,nofinalizationneeded:i8,nodefinedassignment:i8,__padding0:!fir.array<3xi8>}>>>,lenvalue:!fir.box,value:i64}{{[>]?}}>>>>,bounds:!fir.box,value:i64}{{[>]?}}>>>>,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>}>>>, !fir.shapeshift<1>) -> (!fir.box>>,genre:i8,category:i8,kind:i8,rank:i8,__padding0:!fir.array<4xi8>,offset:i64,characterlen:!fir.type<_QM__fortran_type_infoTvalue{{[<]?}}{genre:i8,__padding0:!fir.array<7xi8>,value:i64}{{[>]?}}>,derived:!fir.box,name:!fir.box>>}>>>>,name:!fir.box>>,sizeinbytes:i64,uninstantiated:!fir.box>>,kindparameter:!fir.box>>,lenparameterkind:!fir.box>>,component:!fir.box>>>,procptr:!fir.box>>,offset:i64,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}>>>>,special:!fir.box,proc:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}{{[>]?}}>>>>,specialbitset:i32,hasparent:i8,noinitializationneeded:i8,nodestructionneeded:i8,nofinalizationneeded:i8,nodefinedassignment:i8,__padding0:!fir.array<3xi8>}>>>,lenvalue:!fir.box,value:i64}{{[>]?}}>>>>,bounds:!fir.box,value:i64}{{[>]?}}>>>>,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>}>>>, !fir.ref>>,genre:i8,category:i8,kind:i8,rank:i8,__padding0:!fir.array<4xi8>,offset:i64,characterlen:!fir.type<_QM__fortran_type_infoTvalue{{[<]?}}{genre:i8,__padding0:!fir.array<7xi8>,value:i64}{{[>]?}}>,derived:!fir.box,name:!fir.box>>}>>>>,name:!fir.box>>,sizeinbytes:i64,uninstantiated:!fir.box>>,kindparameter:!fir.box>>,lenparameterkind:!fir.box>>,component:!fir.box>>>,procptr:!fir.box>>,offset:i64,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}>>>>,special:!fir.box,proc:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}{{[>]?}}>>>>,specialbitset:i32,hasparent:i8,noinitializationneeded:i8,nodestructionneeded:i8,nofinalizationneeded:i8,nodefinedassignment:i8,__padding0:!fir.array<3xi8>}>>>,lenvalue:!fir.box,value:i64}{{[>]?}}>>>>,bounds:!fir.box,value:i64}{{[>]?}}>>>>,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>}>>>) +! CHECK: %[[VAL_17:.*]] = fir.address_of(@_QFE.dt.t) : !fir.ref,name:!fir.box>>}>>>>,name:!fir.box>>,sizeinbytes:i64,uninstantiated:!fir.box>>,kindparameter:!fir.box>>,lenparameterkind:!fir.box>>,component:!fir.box>>,genre:i8,category:i8,kind:i8,rank:i8,__padding0:!fir.array<4xi8>,offset:i64,characterlen:!fir.type<_QM__fortran_type_infoTvalue{{[<]?}}{genre:i8,__padding0:!fir.array<7xi8>,value:i64}{{[>]?}}>,derived:!fir.box>>,lenvalue:!fir.box,value:i64}{{[>]?}}>>>>,bounds:!fir.box,value:i64}{{[>]?}}>>>>,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>}>>>>,procptr:!fir.box>>,offset:i64,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}>>>>,special:!fir.box,proc:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}{{[>]?}}>>>>,specialbitset:i32,hasparent:i8,noinitializationneeded:i8,nodestructionneeded:i8,nofinalizationneeded:i8,nodefinedassignment:i8,__padding0:!fir.array<3xi8>}>> +! CHECK: %[[VAL_18:.*]]:2 = hlfir.declare %[[VAL_17]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFE.dt.t"} : (!fir.ref,name:!fir.box>>}>>>>,name:!fir.box>>,sizeinbytes:i64,uninstantiated:!fir.box>>,kindparameter:!fir.box>>,lenparameterkind:!fir.box>>,component:!fir.box>>,genre:i8,category:i8,kind:i8,rank:i8,__padding0:!fir.array<4xi8>,offset:i64,characterlen:!fir.type<_QM__fortran_type_infoTvalue{{[<]?}}{genre:i8,__padding0:!fir.array<7xi8>,value:i64}{{[>]?}}>,derived:!fir.box>>,lenvalue:!fir.box,value:i64}{{[>]?}}>>>>,bounds:!fir.box,value:i64}{{[>]?}}>>>>,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>}>>>>,procptr:!fir.box>>,offset:i64,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}>>>>,special:!fir.box,proc:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}{{[>]?}}>>>>,specialbitset:i32,hasparent:i8,noinitializationneeded:i8,nodestructionneeded:i8,nofinalizationneeded:i8,nodefinedassignment:i8,__padding0:!fir.array<3xi8>}>>) -> (!fir.ref,name:!fir.box>>}>>>>,name:!fir.box>>,sizeinbytes:i64,uninstantiated:!fir.box>>,kindparameter:!fir.box>>,lenparameterkind:!fir.box>>,component:!fir.box>>,genre:i8,category:i8,kind:i8,rank:i8,__padding0:!fir.array<4xi8>,offset:i64,characterlen:!fir.type<_QM__fortran_type_infoTvalue{{[<]?}}{genre:i8,__padding0:!fir.array<7xi8>,value:i64}{{[>]?}}>,derived:!fir.box>>,lenvalue:!fir.box,value:i64}{{[>]?}}>>>>,bounds:!fir.box,value:i64}{{[>]?}}>>>>,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>}>>>>,procptr:!fir.box>>,offset:i64,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}>>>>,special:!fir.box,proc:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}{{[>]?}}>>>>,specialbitset:i32,hasparent:i8,noinitializationneeded:i8,nodestructionneeded:i8,nofinalizationneeded:i8,nodefinedassignment:i8,__padding0:!fir.array<3xi8>}>>, !fir.ref,name:!fir.box>>}>>>>,name:!fir.box>>,sizeinbytes:i64,uninstantiated:!fir.box>>,kindparameter:!fir.box>>,lenparameterkind:!fir.box>>,component:!fir.box>>,genre:i8,category:i8,kind:i8,rank:i8,__padding0:!fir.array<4xi8>,offset:i64,characterlen:!fir.type<_QM__fortran_type_infoTvalue{{[<]?}}{genre:i8,__padding0:!fir.array<7xi8>,value:i64}{{[>]?}}>,derived:!fir.box>>,lenvalue:!fir.box,value:i64}{{[>]?}}>>>>,bounds:!fir.box,value:i64}{{[>]?}}>>>>,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>}>>>>,procptr:!fir.box>>,offset:i64,initialization:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}>>>>,special:!fir.box,proc:!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>}{{[>]?}}>>>>,specialbitset:i32,hasparent:i8,noinitializationneeded:i8,nodestructionneeded:i8,nofinalizationneeded:i8,nodefinedassignment:i8,__padding0:!fir.array<3xi8>}>>) ! CHECK: %[[VAL_19:.*]] = hlfir.designate %[[VAL_13]]#0{"array"} {fortran_attrs = #fir.var_attrs} : (!fir.ref>>}>, volatile>) -> !fir.ref>>, volatile> ! CHECK: %[[VAL_20:.*]] = fir.load %[[VAL_19]] : !fir.ref>>, volatile> ! CHECK: %[[VAL_21:.*]]:3 = fir.box_dims %[[VAL_20]], %[[VAL_0]] : (!fir.box>>, index) -> (index, index, index) diff --git a/flang/test/Semantics/typeinfo01.f90 b/flang/test/Semantics/typeinfo01.f90 index d228cd2a84ca4..7dc92504aeebf 100644 --- a/flang/test/Semantics/typeinfo01.f90 +++ b/flang/test/Semantics/typeinfo01.f90 @@ -8,7 +8,7 @@ module m01 end type !CHECK: Module scope: m01 !CHECK: .c.t1, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(component) shape: 0_8:0_8 init:[component::component(name=.n.n,genre=1_1,category=0_1,kind=4_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL())] -!CHECK: .dt.t1, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t1,sizeinbytes=4_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t1,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) +!CHECK: .dt.t1, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t1,sizeinbytes=4_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t1,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) !CHECK: .n.n, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: CHARACTER(1_8,1) init:"n" !CHECK: .n.t1, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: CHARACTER(2_8,1) init:"t1" !CHECK: DerivedType scope: t1 @@ -23,8 +23,8 @@ module m02 end type !CHECK: .c.child, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(component) shape: 0_8:1_8 init:[component::component(name=.n.parent,genre=1_1,category=6_1,kind=0_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=.dt.parent,lenvalue=NULL(),bounds=NULL(),initialization=NULL()),component(name=.n.cn,genre=1_1,category=0_1,kind=4_1,rank=0_1,offset=4_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL())] !CHECK: .c.parent, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(component) shape: 0_8:0_8 init:[component::component(name=.n.pn,genre=1_1,category=0_1,kind=4_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL())] -!CHECK: .dt.child, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.child,sizeinbytes=8_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.child,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=1_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) -!CHECK: .dt.parent, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.parent,sizeinbytes=4_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.parent,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) +!CHECK: .dt.child, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.child,sizeinbytes=8_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.child,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=1_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) +!CHECK: .dt.parent, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.parent,sizeinbytes=4_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.parent,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) end module module m03 @@ -35,7 +35,7 @@ module m03 type(kpdt(4)) :: x !CHECK: .c.kpdt.4, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(component) shape: 0_8:0_8 init:[component::component(name=.n.a,genre=1_1,category=2_1,kind=4_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL())] !CHECK: .dt.kpdt, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(name=.n.kpdt,uninstantiated=NULL(),kindparameter=.kp.kpdt,lenparameterkind=NULL()) -!CHECK: .dt.kpdt.4, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.kpdt,sizeinbytes=4_8,uninstantiated=.dt.kpdt,kindparameter=.kp.kpdt.4,lenparameterkind=NULL(),component=.c.kpdt.4,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) +!CHECK: .dt.kpdt.4, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.kpdt,sizeinbytes=4_8,uninstantiated=.dt.kpdt,kindparameter=.kp.kpdt.4,lenparameterkind=NULL(),component=.c.kpdt.4,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) !CHECK: .kp.kpdt.4, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: INTEGER(8) shape: 0_8:0_8 init:[INTEGER(8)::4_8] end module @@ -49,7 +49,7 @@ module m04 subroutine s1(x) class(tbps), intent(in) :: x end subroutine -!CHECK: .dt.tbps, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.tbps,name=.n.tbps,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) +!CHECK: .dt.tbps, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.tbps,name=.n.tbps,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) !CHECK: .v.tbps, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:1_8 init:[binding::binding(proc=s1,name=.n.b1),binding(proc=s1,name=.n.b2)] end module @@ -61,7 +61,7 @@ module m05 subroutine s1(x) class(t), intent(in) :: x end subroutine -!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=8_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=.p.t,special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) +!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=8_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=.p.t,special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) !CHECK: .p.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(procptrcomponent) shape: 0_8:0_8 init:[procptrcomponent::procptrcomponent(name=.n.p1,offset=0_8,initialization=s1)] end module @@ -85,8 +85,8 @@ subroutine s2(x, y) class(t), intent(in) :: y end subroutine !CHECK: .c.t2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(component) shape: 0_8:0_8 init:[component::component(name=.n.t,genre=1_1,category=6_1,kind=0_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=.dt.t,lenvalue=NULL(),bounds=NULL(),initialization=NULL())] -!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=2_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) -!CHECK: .dt.t2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t2,name=.n.t2,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t2,procptr=NULL(),special=.s.t2,specialbitset=2_4,hasparent=1_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) +!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=2_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=0_1) +!CHECK: .dt.t2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t2,name=.n.t2,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t2,procptr=NULL(),special=.s.t2,specialbitset=2_4,hasparent=1_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=0_1) !CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=1_1,isargdescriptorset=3_1,istypebound=1_1,isargcontiguousset=0_1,proc=s1)] !CHECK: .s.t2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=1_1,isargdescriptorset=3_1,istypebound=1_1,isargcontiguousset=0_1,proc=s2)] !CHECK: .v.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=s1,name=.n.s1)] @@ -113,8 +113,8 @@ subroutine s2(x, y) class(t2), intent(in) :: y end subroutine !CHECK: .c.t2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(component) shape: 0_8:0_8 init:[component::component(name=.n.t,genre=1_1,category=6_1,kind=0_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=.dt.t,lenvalue=NULL(),bounds=NULL(),initialization=NULL())] -!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=2_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) -!CHECK: .dt.t2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t2,name=.n.t2,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t2,procptr=NULL(),special=.s.t2,specialbitset=2_4,hasparent=1_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) +!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=2_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=0_1) +!CHECK: .dt.t2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t2,name=.n.t2,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t2,procptr=NULL(),special=.s.t2,specialbitset=2_4,hasparent=1_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=0_1) !CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=1_1,isargdescriptorset=3_1,istypebound=1_1,isargcontiguousset=0_1,proc=s1)] !CHECK: .s.t2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=1_1,isargdescriptorset=3_1,istypebound=1_1,isargcontiguousset=0_1,proc=s2)] !CHECK: .v.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=s1,name=.n.s1)] @@ -132,7 +132,7 @@ impure elemental subroutine s1(x, y) class(t), intent(out) :: x class(t), intent(in) :: y end subroutine -!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=4_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) +!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=4_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=0_1) !CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=2_1,isargdescriptorset=3_1,istypebound=1_1,isargcontiguousset=0_1,proc=s1)] !CHECK: .v.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=s1,name=.n.s1)] end module @@ -155,7 +155,7 @@ impure elemental subroutine s3(x) subroutine s4(x) type(t), contiguous :: x(:,:,:) end subroutine -!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=7296_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=0_1,nofinalizationneeded=0_1) +!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=7296_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=0_1,nofinalizationneeded=0_1,nodefinedassignment=1_1) !CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=7_1,isargdescriptorset=0_1,istypebound=1_1,isargcontiguousset=0_1,proc=s3),specialbinding(which=10_1,isargdescriptorset=1_1,istypebound=1_1,isargcontiguousset=0_1,proc=s1),specialbinding(which=11_1,isargdescriptorset=0_1,istypebound=1_1,isargcontiguousset=1_1,proc=s2),specialbinding(which=12_1,isargdescriptorset=1_1,istypebound=1_1,isargcontiguousset=1_1,proc=s4)] end module @@ -197,7 +197,7 @@ subroutine wu(x,u,iostat,iomsg) integer, intent(out) :: iostat character(len=*), intent(inout) :: iomsg end subroutine -!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=120_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) +!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=120_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) !CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=3_1,isargdescriptorset=1_1,istypebound=1_1,isargcontiguousset=0_1,proc=rf),specialbinding(which=4_1,isargdescriptorset=1_1,istypebound=1_1,isargcontiguousset=0_1,proc=ru),specialbinding(which=5_1,isargdescriptorset=1_1,istypebound=1_1,isargcontiguousset=0_1,proc=wf),specialbinding(which=6_1,isargdescriptorset=1_1,istypebound=1_1,isargcontiguousset=0_1,proc=wu)] !CHECK: .v.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(binding) shape: 0_8:3_8 init:[binding::binding(proc=rf,name=.n.rf),binding(proc=ru,name=.n.ru),binding(proc=wf,name=.n.wf),binding(proc=wu,name=.n.wu)] end module @@ -246,7 +246,7 @@ subroutine wu(x,u,iostat,iomsg) integer, intent(out) :: iostat character(len=*), intent(inout) :: iomsg end subroutine -!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=120_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) +!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=120_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) !CHECK: .s.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=3_1,isargdescriptorset=0_1,istypebound=0_1,isargcontiguousset=0_1,proc=rf),specialbinding(which=4_1,isargdescriptorset=0_1,istypebound=0_1,isargcontiguousset=0_1,proc=ru),specialbinding(which=5_1,isargdescriptorset=0_1,istypebound=0_1,isargcontiguousset=0_1,proc=wf),specialbinding(which=6_1,isargdescriptorset=0_1,istypebound=0_1,isargcontiguousset=0_1,proc=wu)] end module @@ -263,7 +263,7 @@ module m11 !CHECK: .c.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(component) shape: 0_8:3_8 init:[component::component(name=.n.allocatable,genre=3_1,category=2_1,kind=4_1,rank=1_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL()),component(name=.n.pointer,genre=2_1,category=2_1,kind=4_1,rank=0_1,offset=48_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=.di.t.pointer),component(name=.n.chauto,genre=4_1,category=4_1,kind=1_1,rank=0_1,offset=72_8,characterlen=value(genre=3_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL()),component(name=.n.automatic,genre=4_1,category=2_1,kind=4_1,rank=1_1,offset=96_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=.b.t.automatic,initialization=NULL())] !CHECK: .di.t.pointer, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(.dp.t.pointer) init:.dp.t.pointer(pointer=target) !CHECK: .dp.t.pointer (CompilerCreated): DerivedType components: pointer -!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=144_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=.lpk.t,component=.c.t,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=0_1,nofinalizationneeded=1_1) +!CHECK: .dt.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=144_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=.lpk.t,component=.c.t,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=0_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) !CHECK: .lpk.t, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: INTEGER(1) shape: 0_8:0_8 init:[INTEGER(1)::8_1] !CHECK: DerivedType scope: .dp.t.pointer size=24 alignment=8 instantiation of .dp.t.pointer !CHECK: pointer, POINTER size=24 offset=0: ObjectEntity type: REAL(4) diff --git a/flang/test/Semantics/typeinfo03.f90 b/flang/test/Semantics/typeinfo03.f90 index f0c0a817da4a4..e2552d0a21d6f 100644 --- a/flang/test/Semantics/typeinfo03.f90 +++ b/flang/test/Semantics/typeinfo03.f90 @@ -6,4 +6,4 @@ module m class(*), pointer :: sp, ap(:) end type end module -!CHECK: .dt.haspointer, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.haspointer,sizeinbytes=104_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.haspointer,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) +!CHECK: .dt.haspointer, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.haspointer,sizeinbytes=104_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.haspointer,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) diff --git a/flang/test/Semantics/typeinfo04.f90 b/flang/test/Semantics/typeinfo04.f90 index de8464321a409..94dd2199db35a 100644 --- a/flang/test/Semantics/typeinfo04.f90 +++ b/flang/test/Semantics/typeinfo04.f90 @@ -7,18 +7,18 @@ module m contains final :: final end type -!CHECK: .dt.finalizable, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.finalizable,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.finalizable,specialbitset=128_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=0_1,nofinalizationneeded=0_1) +!CHECK: .dt.finalizable, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.finalizable,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.finalizable,specialbitset=128_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=0_1,nofinalizationneeded=0_1,nodefinedassignment=1_1) type, abstract :: t1 end type -!CHECK: .dt.t1, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(name=.n.t1,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) +!CHECK: .dt.t1, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(name=.n.t1,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) type, abstract :: t2 real, allocatable :: a(:) end type -!CHECK: .dt.t2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(name=.n.t2,sizeinbytes=48_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t2,procptr=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=0_1,nofinalizationneeded=1_1) +!CHECK: .dt.t2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(name=.n.t2,sizeinbytes=48_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t2,procptr=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=0_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) type, abstract :: t3 type(finalizable) :: x end type -!CHECK: .dt.t3, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(name=.n.t3,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t3,procptr=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=0_1,nofinalizationneeded=0_1) +!CHECK: .dt.t3, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(name=.n.t3,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t3,procptr=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=0_1,nofinalizationneeded=0_1,nodefinedassignment=1_1) contains impure elemental subroutine final(x) type(finalizable), intent(in out) :: x diff --git a/flang/test/Semantics/typeinfo05.f90 b/flang/test/Semantics/typeinfo05.f90 index 2a7f12a153eb8..df1aecf3821de 100644 --- a/flang/test/Semantics/typeinfo05.f90 +++ b/flang/test/Semantics/typeinfo05.f90 @@ -7,10 +7,10 @@ program main type t1 type(t2), pointer :: b end type t1 -!CHECK: .dt.t1, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t1,sizeinbytes=40_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t1,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) +!CHECK: .dt.t1, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t1,sizeinbytes=40_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t1,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) type :: t2 type(t1) :: a end type t2 -! CHECK: .dt.t2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t2,sizeinbytes=40_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t2,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) +! CHECK: .dt.t2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t2,sizeinbytes=40_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t2,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) end program main diff --git a/flang/test/Semantics/typeinfo06.f90 b/flang/test/Semantics/typeinfo06.f90 index 2385709a8eb44..22f37b1a4369d 100644 --- a/flang/test/Semantics/typeinfo06.f90 +++ b/flang/test/Semantics/typeinfo06.f90 @@ -7,10 +7,10 @@ program main type t1 type(t2), allocatable :: b end type t1 -!CHECK: .dt.t1, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t1,sizeinbytes=40_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t1,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=0_1,nofinalizationneeded=1_1) +!CHECK: .dt.t1, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t1,sizeinbytes=40_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t1,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=0_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) type :: t2 type(t1) :: a end type t2 -! CHECK: .dt.t2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t2,sizeinbytes=40_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t2,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=0_1,nofinalizationneeded=1_1) +! CHECK: .dt.t2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t2,sizeinbytes=40_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t2,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=0_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) end program main diff --git a/flang/test/Semantics/typeinfo07.f90 b/flang/test/Semantics/typeinfo07.f90 index e8766d9811db8..ab20d6f601106 100644 --- a/flang/test/Semantics/typeinfo07.f90 +++ b/flang/test/Semantics/typeinfo07.f90 @@ -16,7 +16,7 @@ type(t_container_extension) :: wrapper end type end -! CHECK: .dt.t_container, SAVE, TARGET (CompilerCreated, ReadOnly): {{.*}}noinitializationneeded=0_1,nodestructionneeded=0_1,nofinalizationneeded=0_1) -! CHECK: .dt.t_container_extension, SAVE, TARGET (CompilerCreated, ReadOnly): {{.*}}noinitializationneeded=0_1,nodestructionneeded=0_1,nofinalizationneeded=0_1) -! CHECK: .dt.t_container_not_polymorphic, SAVE, TARGET (CompilerCreated, ReadOnly): {{.*}}noinitializationneeded=0_1,nodestructionneeded=0_1,nofinalizationneeded=1_1) -! CHECK: .dt.t_container_wrapper, SAVE, TARGET (CompilerCreated, ReadOnly): {{.*}}noinitializationneeded=0_1,nodestructionneeded=0_1,nofinalizationneeded=0_1) +! CHECK: .dt.t_container, SAVE, TARGET (CompilerCreated, ReadOnly): {{.*}}noinitializationneeded=0_1,nodestructionneeded=0_1,nofinalizationneeded=0_1,nodefinedassignment=0_1) +! CHECK: .dt.t_container_extension, SAVE, TARGET (CompilerCreated, ReadOnly): {{.*}}noinitializationneeded=0_1,nodestructionneeded=0_1,nofinalizationneeded=0_1,nodefinedassignment=0_1) +! CHECK: .dt.t_container_not_polymorphic, SAVE, TARGET (CompilerCreated, ReadOnly): {{.*}}noinitializationneeded=0_1,nodestructionneeded=0_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) +! CHECK: .dt.t_container_wrapper, SAVE, TARGET (CompilerCreated, ReadOnly): {{.*}}noinitializationneeded=0_1,nodestructionneeded=0_1,nofinalizationneeded=0_1,nodefinedassignment=0_1) diff --git a/flang/test/Semantics/typeinfo08.f90 b/flang/test/Semantics/typeinfo08.f90 index 689cf469dee3b..391a66f3d6664 100644 --- a/flang/test/Semantics/typeinfo08.f90 +++ b/flang/test/Semantics/typeinfo08.f90 @@ -13,7 +13,7 @@ module m !CHECK: Module scope: m size=0 alignment=1 sourceRange=113 bytes !CHECK: .c.s, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(component) shape: 0_8:0_8 init:[component::component(name=.n.t1,genre=1_1,category=6_1,kind=0_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),lenvalue=NULL(),bounds=NULL(),initialization=NULL())] -!CHECK: .dt.s, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.s,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=.lpk.s,component=.c.s,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1) +!CHECK: .dt.s, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.s,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=.lpk.s,component=.c.s,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) !CHECK: .lpk.s, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: INTEGER(1) shape: 0_8:0_8 init:[INTEGER(1)::4_1] !CHECK: .n.s, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: CHARACTER(1_8,1) init:"s" !CHECK: .n.t1, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: CHARACTER(2_8,1) init:"t1" diff --git a/flang/test/Semantics/typeinfo11.f90 b/flang/test/Semantics/typeinfo11.f90 index 92efc8f9ea54b..08e0b95abb763 100644 --- a/flang/test/Semantics/typeinfo11.f90 +++ b/flang/test/Semantics/typeinfo11.f90 @@ -14,4 +14,4 @@ type(t2) x end -!CHECK: .dt.t2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t2,sizeinbytes=40_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t2,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=0_1,nofinalizationneeded=0_1) +!CHECK: .dt.t2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t2,sizeinbytes=40_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t2,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=0_1,nofinalizationneeded=0_1,nodefinedassignment=0_1) diff --git a/flang/test/Semantics/typeinfo12.f90 b/flang/test/Semantics/typeinfo12.f90 new file mode 100644 index 0000000000000..6b23b63d28b1d --- /dev/null +++ b/flang/test/Semantics/typeinfo12.f90 @@ -0,0 +1,67 @@ +!RUN: bbc --dump-symbols %s | FileCheck %s +!Check "nodefinedassignment" settings. + +module m01 + + type hasAsst1 + contains + procedure asst1 + generic :: assignment(=) => asst1 + end type +!CHECK: .dt.hasasst1, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.hasasst1,name=.n.hasasst1,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.hasasst1,specialbitset=4_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=0_1) + + type hasAsst2 ! no defined assignment relevant to the runtime + end type + interface assignment(=) + procedure asst2 + end interface +!CHECK: .dt.hasasst2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.hasasst2,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) + + type test1 + type(hasAsst1) c + end type +!CHECK: .dt.test1, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.test1,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.test1,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=0_1) + + type test2 + type(hasAsst2) c + end type +!CHECK: .dt.test2, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.test2,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.test2,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) + + type test3 + type(hasAsst1), pointer :: p + end type +!CHECK: .dt.test3, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.test3,sizeinbytes=40_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.test3,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) + + type test4 + type(hasAsst2), pointer :: p + end type +!CHECK: .dt.test4, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.test4,sizeinbytes=40_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.test4,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) + + type, extends(hasAsst1) :: test5 + end type +!CHECK: .dt.test5, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.test5,name=.n.test5,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.test5,procptr=NULL(),special=.s.test5,specialbitset=4_4,hasparent=1_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=0_1) + + type, extends(hasAsst2) :: test6 + end type +!CHECK: .dt.test6, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.test6,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.test6,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=1_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) + + type test7 + type(test7), allocatable :: c + end type +!CHECK: .dt.test7, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.test7,sizeinbytes=40_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.test7,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=0_1,nofinalizationneeded=1_1,nodefinedassignment=1_1) + + type test8 + class(test8), allocatable :: c + end type +!CHECK: .dt.test8, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.test8,sizeinbytes=40_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.test8,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=0_1,nodestructionneeded=0_1,nofinalizationneeded=0_1,nodefinedassignment=0_1) + + contains + impure elemental subroutine asst1(left, right) + class(hasAsst1), intent(out) :: left + class(hasAsst1), intent(in) :: right + end + impure elemental subroutine asst2(left, right) + class(hasAsst2), intent(out) :: left + class(hasAsst2), intent(in) :: right + end +end