867 lines · cpp
1//===-- lib/runtime/assign.cpp ----------------------------------*- C++ -*-===//2//3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.4// See https://llvm.org/LICENSE.txt for license information.5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception6//7//===----------------------------------------------------------------------===//8 9#include "flang/Runtime/assign.h"10#include "flang-rt/runtime/assign-impl.h"11#include "flang-rt/runtime/derived.h"12#include "flang-rt/runtime/descriptor.h"13#include "flang-rt/runtime/stat.h"14#include "flang-rt/runtime/terminator.h"15#include "flang-rt/runtime/tools.h"16#include "flang-rt/runtime/type-info.h"17#include "flang-rt/runtime/work-queue.h"18 19namespace Fortran::runtime {20 21// Predicate: is the left-hand side of an assignment an allocated allocatable22// that must be deallocated?23static inline RT_API_ATTRS bool MustDeallocateLHS(24 Descriptor &to, const Descriptor &from, Terminator &terminator, int flags) {25 // Top-level assignments to allocatable variables (*not* components)26 // may first deallocate existing content if there's about to be a27 // change in type or shape; see F'2018 10.2.1.3(3).28 if (!(flags & MaybeReallocate)) {29 return false;30 }31 if (!to.IsAllocatable() || !to.IsAllocated()) {32 return false;33 }34 if (to.type() != from.type()) {35 return true;36 }37 if (!(flags & ExplicitLengthCharacterLHS) && to.type().IsCharacter() &&38 to.ElementBytes() != from.ElementBytes()) {39 return true;40 }41 if (flags & PolymorphicLHS) {42 DescriptorAddendum *toAddendum{to.Addendum()};43 const typeInfo::DerivedType *toDerived{44 toAddendum ? toAddendum->derivedType() : nullptr};45 const DescriptorAddendum *fromAddendum{from.Addendum()};46 const typeInfo::DerivedType *fromDerived{47 fromAddendum ? fromAddendum->derivedType() : nullptr};48 if (toDerived != fromDerived) {49 return true;50 }51 if (fromDerived) {52 // Distinct LEN parameters? Deallocate53 std::size_t lenParms{fromDerived->LenParameters()};54 for (std::size_t j{0}; j < lenParms; ++j) {55 if (toAddendum->LenParameterValue(j) !=56 fromAddendum->LenParameterValue(j)) {57 return true;58 }59 }60 }61 }62 if (from.rank() > 0) {63 // Distinct shape? Deallocate64 int rank{to.rank()};65 for (int j{0}; j < rank; ++j) {66 const auto &toDim{to.GetDimension(j)};67 const auto &fromDim{from.GetDimension(j)};68 if (toDim.Extent() != fromDim.Extent()) {69 return true;70 }71 if ((flags & UpdateLHSBounds) &&72 toDim.LowerBound() != fromDim.LowerBound()) {73 return true;74 }75 }76 }77 // Not reallocating; may have to update bounds78 if (flags & UpdateLHSBounds) {79 int rank{to.rank()};80 for (int j{0}; j < rank; ++j) {81 to.GetDimension(j).SetLowerBound(from.GetDimension(j).LowerBound());82 }83 }84 return false;85}86 87// Utility: allocate the allocatable left-hand side, either because it was88// originally deallocated or because it required reallocation89static RT_API_ATTRS int AllocateAssignmentLHS(90 Descriptor &to, const Descriptor &from, Terminator &terminator, int flags) {91 DescriptorAddendum *toAddendum{to.Addendum()};92 const typeInfo::DerivedType *derived{nullptr};93 if (toAddendum) {94 derived = toAddendum->derivedType();95 }96 if (const DescriptorAddendum * fromAddendum{from.Addendum()}) {97 if (!derived || (flags & PolymorphicLHS)) {98 derived = fromAddendum->derivedType();99 }100 if (toAddendum && derived) {101 std::size_t lenParms{derived->LenParameters()};102 for (std::size_t j{0}; j < lenParms; ++j) {103 toAddendum->SetLenParameterValue(j, fromAddendum->LenParameterValue(j));104 }105 }106 } else {107 derived = nullptr;108 }109 if (toAddendum) {110 toAddendum->set_derivedType(derived);111 }112 to.raw().type = from.raw().type;113 if (derived) {114 to.raw().elem_len = derived->sizeInBytes();115 } else if (!(flags & ExplicitLengthCharacterLHS)) {116 to.raw().elem_len = from.ElementBytes();117 }118 // subtle: leave bounds in place when "from" is scalar (10.2.1.3(3))119 int rank{from.rank()};120 auto stride{static_cast<SubscriptValue>(to.ElementBytes())};121 for (int j{0}; j < rank; ++j) {122 auto &toDim{to.GetDimension(j)};123 const auto &fromDim{from.GetDimension(j)};124 toDim.SetBounds(fromDim.LowerBound(), fromDim.UpperBound());125 toDim.SetByteStride(stride);126 stride *= toDim.Extent();127 }128 return ReturnError(terminator, to.Allocate(kNoAsyncObject));129}130 131// least <= 0, most >= 0132static RT_API_ATTRS void MaximalByteOffsetRange(133 const Descriptor &desc, std::int64_t &least, std::int64_t &most) {134 least = most = 0;135 if (desc.ElementBytes() == 0) {136 return;137 }138 int n{desc.raw().rank};139 for (int j{0}; j < n; ++j) {140 const auto &dim{desc.GetDimension(j)};141 auto extent{dim.Extent()};142 if (extent > 0) {143 auto sm{dim.ByteStride()};144 if (sm < 0) {145 least += (extent - 1) * sm;146 } else {147 most += (extent - 1) * sm;148 }149 }150 }151 most += desc.ElementBytes() - 1;152}153 154static inline RT_API_ATTRS bool RangesOverlap(const char *aStart,155 const char *aEnd, const char *bStart, const char *bEnd) {156 return aEnd >= bStart && bEnd >= aStart;157}158 159// Predicate: could the left-hand and right-hand sides of the assignment160// possibly overlap in memory? Note that the descriptors themeselves161// are included in the test.162static RT_API_ATTRS bool MayAlias(const Descriptor &x, const Descriptor &y) {163 const char *xBase{x.OffsetElement()};164 const char *yBase{y.OffsetElement()};165 if (!xBase || !yBase) {166 return false; // not both allocated167 }168 const char *xDesc{reinterpret_cast<const char *>(&x)};169 const char *xDescLast{xDesc + x.SizeInBytes() - 1};170 const char *yDesc{reinterpret_cast<const char *>(&y)};171 const char *yDescLast{yDesc + y.SizeInBytes() - 1};172 std::int64_t xLeast, xMost, yLeast, yMost;173 MaximalByteOffsetRange(x, xLeast, xMost);174 MaximalByteOffsetRange(y, yLeast, yMost);175 if (RangesOverlap(xDesc, xDescLast, yBase + yLeast, yBase + yMost) ||176 RangesOverlap(yDesc, yDescLast, xBase + xLeast, xBase + xMost)) {177 // A descriptor overlaps with the storage described by the other;178 // this can arise when an allocatable or pointer component is179 // being assigned to/from.180 return true;181 }182 if (!RangesOverlap(183 xBase + xLeast, xBase + xMost, yBase + yLeast, yBase + yMost)) {184 return false; // no storage overlap185 }186 // TODO: check dimensions: if any is independent, return false187 return true;188}189 190static RT_API_ATTRS void DoScalarDefinedAssignment(const Descriptor &to,191 const Descriptor &from, const typeInfo::DerivedType &derived,192 const typeInfo::SpecialBinding &special) {193 bool toIsDesc{special.IsArgDescriptor(0)};194 bool fromIsDesc{special.IsArgDescriptor(1)};195 const auto *bindings{196 derived.binding().OffsetElement<const typeInfo::Binding>()};197 if (toIsDesc) {198 if (fromIsDesc) {199 auto *p{special.GetProc<void (*)(const Descriptor &, const Descriptor &)>(200 bindings)};201 p(to, from);202 } else {203 auto *p{special.GetProc<void (*)(const Descriptor &, void *)>(bindings)};204 p(to, from.raw().base_addr);205 }206 } else {207 if (fromIsDesc) {208 auto *p{special.GetProc<void (*)(void *, const Descriptor &)>(bindings)};209 p(to.raw().base_addr, from);210 } else {211 auto *p{special.GetProc<void (*)(void *, void *)>(bindings)};212 p(to.raw().base_addr, from.raw().base_addr);213 }214 }215}216 217static RT_API_ATTRS void DoElementalDefinedAssignment(const Descriptor &to,218 const Descriptor &from, const typeInfo::DerivedType &derived,219 const typeInfo::SpecialBinding &special) {220 SubscriptValue toAt[maxRank], fromAt[maxRank];221 to.GetLowerBounds(toAt);222 from.GetLowerBounds(fromAt);223 StaticDescriptor<maxRank, true, 8 /*?*/> statDesc[2];224 Descriptor &toElementDesc{statDesc[0].descriptor()};225 Descriptor &fromElementDesc{statDesc[1].descriptor()};226 toElementDesc.Establish(derived, nullptr, 0, nullptr, CFI_attribute_pointer);227 fromElementDesc.Establish(228 derived, nullptr, 0, nullptr, CFI_attribute_pointer);229 for (std::size_t toElements{to.InlineElements()}; toElements-- > 0;230 to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {231 toElementDesc.set_base_addr(to.Element<char>(toAt));232 fromElementDesc.set_base_addr(from.Element<char>(fromAt));233 DoScalarDefinedAssignment(toElementDesc, fromElementDesc, derived, special);234 }235}236 237template <typename CHAR>238static RT_API_ATTRS void BlankPadCharacterAssignment(Descriptor &to,239 const Descriptor &from, SubscriptValue toAt[], SubscriptValue fromAt[],240 std::size_t elements, std::size_t toElementBytes,241 std::size_t fromElementBytes) {242 std::size_t padding{(toElementBytes - fromElementBytes) / sizeof(CHAR)};243 std::size_t copiedCharacters{fromElementBytes / sizeof(CHAR)};244 for (; elements-- > 0;245 to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {246 CHAR *p{to.Element<CHAR>(toAt)};247 runtime::memmove(248 p, from.Element<std::add_const_t<CHAR>>(fromAt), fromElementBytes);249 p += copiedCharacters;250 for (auto n{padding}; n-- > 0;) {251 *p++ = CHAR{' '};252 }253 }254}255 256RT_OFFLOAD_API_GROUP_BEGIN257 258// Common implementation of assignments, both intrinsic assignments and259// those cases of polymorphic user-defined ASSIGNMENT(=) TBPs that could not260// be resolved in semantics. Most assignment statements do not need any261// of the capabilities of this function -- but when the LHS is allocatable,262// the type might have a user-defined ASSIGNMENT(=), or the type might be263// finalizable, this function should be used.264// When "to" is not a whole allocatable, "from" is an array, and defined265// assignments are not used, "to" and "from" only need to have the same number266// of elements, but their shape need not to conform (the assignment is done in267// element sequence order). This facilitates some internal usages, like when268// dealing with array constructors.269RT_API_ATTRS void Assign(Descriptor &to, const Descriptor &from,270 Terminator &terminator, int flags, MemmoveFct memmoveFct) {271 WorkQueue workQueue{terminator};272 if (workQueue.BeginAssign(to, from, flags, memmoveFct, nullptr) ==273 StatContinue) {274 workQueue.Run();275 }276}277 278RT_API_ATTRS int AssignTicket::Begin(WorkQueue &workQueue) {279 bool mustDeallocateLHS{(flags_ & DeallocateLHS) ||280 MustDeallocateLHS(to_, *from_, workQueue.terminator(), flags_)};281 DescriptorAddendum *toAddendum{to_.Addendum()};282 toDerived_ = toAddendum ? toAddendum->derivedType() : nullptr;283 if (toDerived_ && (flags_ & NeedFinalization) &&284 toDerived_->noFinalizationNeeded()) {285 flags_ &= ~NeedFinalization;286 }287 if (MayAlias(to_, *from_)) {288 if (mustDeallocateLHS) {289 // Convert the LHS into a temporary, then make it look deallocated.290 toDeallocate_ = &tempDescriptor_.descriptor();291 runtime::memcpy(292 reinterpret_cast<void *>(toDeallocate_), &to_, to_.SizeInBytes());293 to_.set_base_addr(nullptr);294 if (toDerived_ && (flags_ & NeedFinalization)) {295 int status{workQueue.BeginFinalize(*toDeallocate_, *toDerived_)};296 if (status == StatContinue) {297 // tempDescriptor_ state must outlive pending child ticket298 persist_ = true;299 } else if (status != StatOk) {300 return status;301 }302 flags_ &= ~NeedFinalization;303 }304 } else if (!IsSimpleMemmove()) {305 // Handle LHS/RHS aliasing by copying RHS into a temp, then306 // recursively assigning from that temp.307 auto descBytes{from_->SizeInBytes()};308 Descriptor &newFrom{tempDescriptor_.descriptor()};309 persist_ = true; // tempDescriptor_ state must outlive child tickets310 runtime::memcpy(reinterpret_cast<void *>(&newFrom), from_, descBytes);311 // Pretend the temporary descriptor is for an ALLOCATABLE312 // entity, otherwise, the Deallocate() below will not313 // free the descriptor memory.314 newFrom.raw().attribute = CFI_attribute_allocatable;315 if (int stat{ReturnError(316 workQueue.terminator(), newFrom.Allocate(kNoAsyncObject))};317 stat != StatOk) {318 if (stat == StatContinue) {319 persist_ = true;320 }321 return stat;322 }323 if (HasDynamicComponent(*from_)) {324 // If 'from' has allocatable/automatic component, we cannot325 // just make a shallow copy of the descriptor member.326 // This will still leave data overlap in 'to' and 'newFrom'.327 // For example:328 // type t329 // character, allocatable :: c(:)330 // end type t331 // type(t) :: x(3)332 // x(2:3) = x(1:2)333 // We have to make a deep copy into 'newFrom' in this case.334 if (const DescriptorAddendum *addendum{newFrom.Addendum()}) {335 if (const auto *derived{addendum->derivedType()}) {336 if (!derived->noInitializationNeeded()) {337 if (int status{workQueue.BeginInitialize(newFrom, *derived)};338 status != StatOk && status != StatContinue) {339 return status;340 }341 }342 }343 }344 static constexpr int nestedFlags{MaybeReallocate | PolymorphicLHS};345 if (int status{workQueue.BeginAssign(346 newFrom, *from_, nestedFlags, memmoveFct_, nullptr)};347 status != StatOk && status != StatContinue) {348 return status;349 }350 } else {351 ShallowCopy(newFrom, *from_, true, from_->IsContiguous());352 }353 from_ = &newFrom; // this is why from_ has to be a pointer354 flags_ &= NeedFinalization | ComponentCanBeDefinedAssignment |355 ExplicitLengthCharacterLHS | CanBeDefinedAssignment;356 toDeallocate_ = &newFrom;357 }358 }359 if (to_.IsAllocatable()) {360 if (mustDeallocateLHS) {361 if (!toDeallocate_ && to_.IsAllocated()) {362 toDeallocate_ = &to_;363 }364 } else if (to_.rank() != from_->rank() && !to_.IsAllocated()) {365 workQueue.terminator().Crash("Assign: mismatched ranks (%d != %d) in "366 "assignment to unallocated allocatable",367 to_.rank(), from_->rank());368 }369 } else if (!to_.IsAllocated()) {370 workQueue.terminator().Crash(371 "Assign: left-hand side variable is neither allocated nor allocatable");372 }373 if (toDerived_ && to_.IsAllocated()) {374 // Schedule finalization or destruction of the LHS.375 if (flags_ & NeedFinalization) {376 if (int status{workQueue.BeginFinalize(to_, *toDerived_)};377 status != StatOk && status != StatContinue) {378 return status;379 }380 } else if (!toDerived_->noDestructionNeeded()) {381 // F'2023 9.7.3.2 p7: "When an intrinsic assignment statement (10.2.1.3)382 // is executed, any noncoarray allocated allocatable subobject of the383 // variable is deallocated before the assignment takes place."384 if (int status{385 workQueue.BeginDestroy(to_, *toDerived_, /*finalize=*/false)};386 status != StatOk && status != StatContinue) {387 return status;388 }389 }390 }391 return StatContinue;392}393 394RT_API_ATTRS int AssignTicket::Continue(WorkQueue &workQueue) {395 if (done_) {396 // All child tickets are complete; can release this ticket's state.397 if (toDeallocate_) {398 toDeallocate_->Deallocate();399 }400 return StatOk;401 }402 // All necessary finalization or destruction that was initiated by Begin()403 // has been completed. Deallocation may be pending, and if it's for the LHS,404 // do it now so that the LHS gets reallocated.405 if (toDeallocate_ == &to_) {406 toDeallocate_ = nullptr;407 to_.Deallocate();408 }409 // Allocate the LHS if needed410 if (!to_.IsAllocated()) {411 if (int stat{412 AllocateAssignmentLHS(to_, *from_, workQueue.terminator(), flags_)};413 stat != StatOk) {414 return stat;415 }416 const auto *addendum{to_.Addendum()};417 toDerived_ = addendum ? addendum->derivedType() : nullptr;418 if (toDerived_) {419 if (!toDerived_->noInitializationNeeded()) {420 if (int status{workQueue.BeginInitialize(to_, *toDerived_)};421 status != StatOk) {422 return status;423 }424 }425 }426 }427 // Check for a user-defined assignment type-bound procedure;428 // see 10.2.1.4-5.429 // Note that the aliasing and LHS (re)allocation handling above430 // needs to run even with CanBeDefinedAssignment flag, since431 // Assign() can be invoked recursively for component-wise assignments.432 // The declared type (if known) must be used for generic resolution433 // of ASSIGNMENT(=) to a binding, but that binding can be overridden.434 if (declaredType_ && (flags_ & CanBeDefinedAssignment)) {435 if (to_.rank() == 0) {436 if (const auto *special{declaredType_->FindSpecialBinding(437 typeInfo::SpecialBinding::Which::ScalarAssignment)}) {438 DoScalarDefinedAssignment(to_, *from_, *toDerived_, *special);439 done_ = true;440 return StatContinue;441 }442 }443 if (const auto *special{declaredType_->FindSpecialBinding(444 typeInfo::SpecialBinding::Which::ElementalAssignment)}) {445 DoElementalDefinedAssignment(to_, *from_, *toDerived_, *special);446 done_ = true;447 return StatContinue;448 }449 }450 // Intrinsic assignment451 std::size_t toElements{to_.InlineElements()};452 if (from_->rank() > 0) {453 std::size_t fromElements{from_->InlineElements()};454 if (toElements != fromElements) {455 workQueue.terminator().Crash("Assign: mismatching element counts in "456 "array assignment (to %zd, from %zd)",457 toElements, fromElements);458 }459 }460 if (to_.type() != from_->type()) {461 workQueue.terminator().Crash(462 "Assign: mismatching types (to code %d != from code %d)",463 to_.type().raw(), from_->type().raw());464 }465 std::size_t toElementBytes{to_.ElementBytes()};466 std::size_t fromElementBytes{from_->ElementBytes()};467 if (toElementBytes > fromElementBytes && !to_.type().IsCharacter()) {468 workQueue.terminator().Crash("Assign: mismatching non-character element "469 "sizes (to %zd bytes != from %zd bytes)",470 toElementBytes, fromElementBytes);471 }472 if (toDerived_) {473 if (toDerived_->noDefinedAssignment()) { // componentwise474 if (int status{workQueue.BeginDerivedAssign<true>(475 to_, *from_, *toDerived_, flags_, memmoveFct_, toDeallocate_)};476 status != StatOk && status != StatContinue) {477 return status;478 }479 } else { // elementwise480 if (int status{workQueue.BeginDerivedAssign<false>(481 to_, *from_, *toDerived_, flags_, memmoveFct_, toDeallocate_)};482 status != StatOk && status != StatContinue) {483 return status;484 }485 }486 toDeallocate_ = nullptr;487 } else if (IsSimpleMemmove()) {488 memmoveFct_(to_.raw().base_addr, from_->raw().base_addr,489 toElements * toElementBytes);490 } else {491 // Scalar expansion of the RHS is implied by using the same empty492 // subscript values on each (seemingly) elemental reference into493 // "from".494 SubscriptValue toAt[maxRank];495 to_.GetLowerBounds(toAt);496 SubscriptValue fromAt[maxRank];497 from_->GetLowerBounds(fromAt);498 if (toElementBytes > fromElementBytes) { // blank padding499 switch (to_.type().raw()) {500 case CFI_type_signed_char:501 case CFI_type_char:502 BlankPadCharacterAssignment<char>(to_, *from_, toAt, fromAt, toElements,503 toElementBytes, fromElementBytes);504 break;505 case CFI_type_char16_t:506 BlankPadCharacterAssignment<char16_t>(to_, *from_, toAt, fromAt,507 toElements, toElementBytes, fromElementBytes);508 break;509 case CFI_type_char32_t:510 BlankPadCharacterAssignment<char32_t>(to_, *from_, toAt, fromAt,511 toElements, toElementBytes, fromElementBytes);512 break;513 default:514 workQueue.terminator().Crash(515 "unexpected type code %d in blank padded Assign()",516 to_.type().raw());517 }518 } else { // elemental copies, possibly with character truncation519 for (std::size_t n{toElements}; n-- > 0;520 to_.IncrementSubscripts(toAt), from_->IncrementSubscripts(fromAt)) {521 memmoveFct_(to_.Element<char>(toAt), from_->Element<const char>(fromAt),522 toElementBytes);523 }524 }525 }526 if (persist_) {527 // tempDescriptor_ must outlive pending child ticket(s)528 done_ = true;529 return StatContinue;530 } else {531 if (toDeallocate_) {532 toDeallocate_->Deallocate();533 toDeallocate_ = nullptr;534 }535 return StatOk;536 }537}538 539template <bool IS_COMPONENTWISE>540RT_API_ATTRS int DerivedAssignTicket<IS_COMPONENTWISE>::Begin(541 WorkQueue &workQueue) {542 if (toIsContiguous_ && fromIsContiguous_ &&543 this->derived_.noDestructionNeeded() &&544 this->derived_.noDefinedAssignment() &&545 this->instance_.rank() == this->from_->rank()) {546 if (std::size_t elementBytes{this->instance_.ElementBytes()};547 elementBytes == this->from_->ElementBytes()) {548 // Fastest path. Both LHS and RHS are contiguous, RHS is not a scalar549 // to be expanded, the types have the same size, and there are no550 // allocatable components or defined ASSIGNMENT(=) at any level.551 memmoveFct_(this->instance_.template OffsetElement<char>(),552 this->from_->template OffsetElement<const char *>(),553 this->instance_.InlineElements() * elementBytes);554 return StatOk;555 }556 }557 // Use PolymorphicLHS for components so that the right things happen558 // when the components are polymorphic; when they're not, they're both559 // not, and their declared types will match.560 int nestedFlags{MaybeReallocate | PolymorphicLHS};561 if (flags_ & ComponentCanBeDefinedAssignment) {562 nestedFlags |= CanBeDefinedAssignment | ComponentCanBeDefinedAssignment;563 }564 flags_ = nestedFlags;565 // Copy procedure pointer components566 const Descriptor &procPtrDesc{this->derived_.procPtr()};567 bool noDataComponents{this->IsComplete()};568 if (std::size_t numProcPtrs{procPtrDesc.InlineElements()}) {569 for (std::size_t k{0}; k < numProcPtrs; ++k) {570 const auto &procPtr{571 *procPtrDesc.ZeroBasedIndexedElement<typeInfo::ProcPtrComponent>(k)};572 // Loop only over elements573 if (k > 0) {574 Elementwise::Reset();575 }576 for (; !Elementwise::IsComplete(); Elementwise::Advance()) {577 memmoveFct_(this->instance_.template ElementComponent<char>(578 this->subscripts_, procPtr.offset),579 this->from_->template ElementComponent<const char>(580 this->fromSubscripts_, procPtr.offset),581 sizeof(typeInfo::ProcedurePointer));582 }583 }584 if (noDataComponents) {585 return StatOk;586 }587 Elementwise::Reset();588 }589 if (noDataComponents) {590 return StatOk;591 }592 return StatContinue;593}594template RT_API_ATTRS int DerivedAssignTicket<false>::Begin(WorkQueue &);595template RT_API_ATTRS int DerivedAssignTicket<true>::Begin(WorkQueue &);596 597template <bool IS_COMPONENTWISE>598RT_API_ATTRS int DerivedAssignTicket<IS_COMPONENTWISE>::Continue(599 WorkQueue &workQueue) {600 while (!this->IsComplete()) {601 // Copy the data components (incl. the parent) first.602 switch (this->component_->genre()) {603 case typeInfo::Component::Genre::Data:604 if (this->component_->category() == TypeCategory::Derived) {605 Descriptor &toCompDesc{this->componentDescriptor_.descriptor()};606 Descriptor &fromCompDesc{this->fromComponentDescriptor_.descriptor()};607 this->component_->CreatePointerDescriptor(toCompDesc, this->instance_,608 workQueue.terminator(), this->subscripts_);609 this->component_->CreatePointerDescriptor(fromCompDesc, *this->from_,610 workQueue.terminator(), this->fromSubscripts_);611 const auto *componentDerived{this->component_->derivedType()};612 this->Advance();613 if (int status{workQueue.BeginAssign(toCompDesc, fromCompDesc, flags_,614 memmoveFct_, componentDerived)};615 status != StatOk) {616 return status;617 }618 } else { // Component has intrinsic type; simply copy raw bytes619 std::size_t componentByteSize{620 this->component_->SizeInBytes(this->instance_)};621 if (IS_COMPONENTWISE && toIsContiguous_ && fromIsContiguous_) {622 std::size_t offset{623 static_cast<std::size_t>(this->component_->offset())};624 char *to{this->instance_.template OffsetElement<char>(offset)};625 const char *from{626 this->from_->template OffsetElement<const char>(offset)};627 std::size_t toElementStride{this->instance_.ElementBytes()};628 std::size_t fromElementStride{629 this->from_->rank() == 0 ? 0 : this->from_->ElementBytes()};630 if (toElementStride == fromElementStride &&631 toElementStride == componentByteSize) {632 memmoveFct_(to, from, this->elements_ * componentByteSize);633 } else {634 for (std::size_t n{this->elements_}; n--;635 to += toElementStride, from += fromElementStride) {636 memmoveFct_(to, from, componentByteSize);637 }638 }639 this->SkipToNextComponent();640 } else {641 memmoveFct_(642 this->instance_.template Element<char>(this->subscripts_) +643 this->component_->offset(),644 this->from_->template Element<const char>(this->fromSubscripts_) +645 this->component_->offset(),646 componentByteSize);647 this->Advance();648 }649 }650 break;651 case typeInfo::Component::Genre::Pointer:652 case typeInfo::Component::Genre::PointerDevice: {653 std::size_t componentByteSize{654 this->component_->SizeInBytes(this->instance_)};655 if (IS_COMPONENTWISE && toIsContiguous_ && fromIsContiguous_) {656 std::size_t offset{657 static_cast<std::size_t>(this->component_->offset())};658 char *to{this->instance_.template OffsetElement<char>(offset)};659 const char *from{660 this->from_->template OffsetElement<const char>(offset)};661 std::size_t toElementStride{this->instance_.ElementBytes()};662 std::size_t fromElementStride{663 this->from_->rank() == 0 ? 0 : this->from_->ElementBytes()};664 if (toElementStride == fromElementStride &&665 toElementStride == componentByteSize) {666 memmoveFct_(to, from, this->elements_ * componentByteSize);667 } else {668 for (std::size_t n{this->elements_}; n--;669 to += toElementStride, from += fromElementStride) {670 memmoveFct_(to, from, componentByteSize);671 }672 }673 this->SkipToNextComponent();674 } else {675 memmoveFct_(this->instance_.template Element<char>(this->subscripts_) +676 this->component_->offset(),677 this->from_->template Element<const char>(this->fromSubscripts_) +678 this->component_->offset(),679 componentByteSize);680 this->Advance();681 }682 } break;683 case typeInfo::Component::Genre::Allocatable:684 case typeInfo::Component::Genre::AllocatableDevice:685 case typeInfo::Component::Genre::Automatic: {686 auto *toDesc{reinterpret_cast<Descriptor *>(687 this->instance_.template Element<char>(this->subscripts_) +688 this->component_->offset())};689 const auto *fromDesc{reinterpret_cast<const Descriptor *>(690 this->from_->template Element<char>(this->fromSubscripts_) +691 this->component_->offset())};692 const auto *componentDerived{this->component_->derivedType()};693 if (toDesc->IsAllocatable() && !fromDesc->IsAllocated()) {694 if (toDesc->IsAllocated()) {695 if (this->phase_ == 0) {696 if (componentDerived && !componentDerived->noDestructionNeeded()) {697 if (int status{workQueue.BeginDestroy(698 *toDesc, *componentDerived, /*finalize=*/false)};699 status != StatOk) {700 this->phase_++;701 return status;702 }703 }704 }705 toDesc->Deallocate();706 }707 this->Advance();708 } else {709 // Allocatable components of the LHS are unconditionally710 // deallocated before assignment (F'2018 10.2.1.3(13)(1)),711 // unlike a "top-level" assignment to a variable, where712 // deallocation is optional.713 int nestedFlags{flags_};714 if (!componentDerived ||715 (componentDerived->noFinalizationNeeded() &&716 componentDerived->noInitializationNeeded() &&717 componentDerived->noDestructionNeeded())) {718 // The actual deallocation might be avoidable when the existing719 // location can be reoccupied.720 nestedFlags |= MaybeReallocate | UpdateLHSBounds;721 } else {722 // Force LHS deallocation with DeallocateLHS flag.723 nestedFlags |= DeallocateLHS;724 }725 this->Advance();726 if (int status{workQueue.BeginAssign(*toDesc, *fromDesc, nestedFlags,727 memmoveFct_, componentDerived)};728 status != StatOk) {729 return status;730 }731 }732 } break;733 }734 }735 if (deallocateAfter_) {736 deallocateAfter_->Deallocate();737 }738 return StatOk;739}740template RT_API_ATTRS int DerivedAssignTicket<false>::Continue(WorkQueue &);741template RT_API_ATTRS int DerivedAssignTicket<true>::Continue(WorkQueue &);742 743RT_API_ATTRS void DoFromSourceAssign(Descriptor &alloc,744 const Descriptor &source, Terminator &terminator, MemmoveFct memmoveFct) {745 if (alloc.rank() > 0 && source.rank() == 0) {746 // The value of each element of allocate object becomes the value of source.747 DescriptorAddendum *allocAddendum{alloc.Addendum()};748 SubscriptValue allocAt[maxRank];749 alloc.GetLowerBounds(allocAt);750 std::size_t allocElementBytes{alloc.ElementBytes()};751 if (const typeInfo::DerivedType *allocDerived{752 allocAddendum ? allocAddendum->derivedType() : nullptr}) {753 // Handle derived type or short character source754 for (std::size_t n{alloc.InlineElements()}; n-- > 0;755 alloc.IncrementSubscripts(allocAt)) {756 StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;757 Descriptor &allocElement{statDesc.descriptor()};758 allocElement.Establish(*allocDerived,759 reinterpret_cast<void *>(alloc.Element<char>(allocAt)), 0);760 Assign(allocElement, source, terminator, NoAssignFlags, memmoveFct);761 }762 } else if (allocElementBytes > source.ElementBytes()) {763 // Scalar expansion of short character source764 for (std::size_t n{alloc.InlineElements()}; n-- > 0;765 alloc.IncrementSubscripts(allocAt)) {766 StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;767 Descriptor &allocElement{statDesc.descriptor()};768 allocElement.Establish(source.type(), allocElementBytes,769 reinterpret_cast<void *>(alloc.Element<char>(allocAt)), 0);770 Assign(allocElement, source, terminator, NoAssignFlags, memmoveFct);771 }772 } else { // intrinsic type scalar expansion, same data size773 for (std::size_t n{alloc.InlineElements()}; n-- > 0;774 alloc.IncrementSubscripts(allocAt)) {775 memmoveFct(alloc.Element<char>(allocAt), source.raw().base_addr,776 allocElementBytes);777 }778 }779 } else {780 Assign(alloc, source, terminator, NoAssignFlags, memmoveFct);781 }782}783 784RT_OFFLOAD_API_GROUP_END785 786extern "C" {787RT_EXT_API_GROUP_BEGIN788 789void RTDEF(Assign)(Descriptor &to, const Descriptor &from,790 const char *sourceFile, int sourceLine) {791 Terminator terminator{sourceFile, sourceLine};792 // All top-level defined assignments can be recognized in semantics and793 // will have been already been converted to calls, so don't check for794 // defined assignment apart from components.795 Assign(to, from, terminator,796 MaybeReallocate | NeedFinalization | ComponentCanBeDefinedAssignment);797}798 799void RTDEF(AssignTemporary)(Descriptor &to, const Descriptor &from,800 const char *sourceFile, int sourceLine) {801 Terminator terminator{sourceFile, sourceLine};802 // Initialize the "to" if it is of derived type that needs initialization.803 if (const DescriptorAddendum * addendum{to.Addendum()}) {804 if (const auto *derived{addendum->derivedType()}) {805 // Do not invoke the initialization, if the descriptor is unallocated.806 // AssignTemporary() is used for component-by-component assignments,807 // for example, for structure constructors. This means that the LHS808 // may be an allocatable component with unallocated status.809 // The initialization will just fail in this case. By skipping810 // the initialization we let Assign() automatically allocate811 // and initialize the component according to the RHS.812 // So we only need to initialize the LHS here if it is allocated.813 // Note that initializing already initialized entity has no visible814 // effect, though, it is assumed that the compiler does not initialize815 // the temporary and leaves the initialization to this runtime code.816 if (!derived->noInitializationNeeded() && to.IsAllocated()) {817 if (ReturnError(terminator, Initialize(to, *derived, terminator)) !=818 StatOk) {819 return;820 }821 }822 }823 }824 Assign(to, from, terminator, MaybeReallocate | PolymorphicLHS);825}826 827void RTDEF(CopyInAssign)(Descriptor &temp, const Descriptor &var,828 const char *sourceFile, int sourceLine) {829 Terminator terminator{sourceFile, sourceLine};830 temp = var;831 temp.set_base_addr(nullptr);832 temp.raw().attribute = CFI_attribute_allocatable;833 temp.Allocate(kNoAsyncObject);834 ShallowCopy(temp, var);835}836 837void RTDEF(CopyOutAssign)(838 Descriptor *var, Descriptor &temp, const char *sourceFile, int sourceLine) {839 Terminator terminator{sourceFile, sourceLine};840 // Copyout from the temporary must not cause any finalizations841 // for LHS. The variable must be properly initialized already.842 if (var) {843 ShallowCopy(*var, temp);844 }845 temp.Deallocate();846}847 848void RTDEF(AssignExplicitLengthCharacter)(Descriptor &to,849 const Descriptor &from, const char *sourceFile, int sourceLine) {850 Terminator terminator{sourceFile, sourceLine};851 Assign(to, from, terminator,852 MaybeReallocate | NeedFinalization | ComponentCanBeDefinedAssignment |853 ExplicitLengthCharacterLHS);854}855 856void RTDEF(AssignPolymorphic)(Descriptor &to, const Descriptor &from,857 const char *sourceFile, int sourceLine) {858 Terminator terminator{sourceFile, sourceLine};859 Assign(to, from, terminator,860 MaybeReallocate | NeedFinalization | ComponentCanBeDefinedAssignment |861 PolymorphicLHS);862}863 864RT_EXT_API_GROUP_END865} // extern "C"866} // namespace Fortran::runtime867