flang/runtime/assign.cpp

//===-- runtime/assign.cpp ------------------------------------------------===//
//
// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
// See https://llvm.org/LICENSE.txt for license information.
// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
//
//===----------------------------------------------------------------------===//

#include "flang/Runtime/assign.h"
#include "derived.h"
#include "stat.h"
#include "terminator.h"
#include "type-info.h"
#include "flang/Runtime/descriptor.h"

namespace Fortran::runtime {

static void DoScalarDefinedAssignment(const Descriptor &to,
    const Descriptor &from, const typeInfo::SpecialBinding &special) {
  bool toIsDesc{special.IsArgDescriptor(0)};
  bool fromIsDesc{special.IsArgDescriptor(1)};
  if (toIsDesc) {
    if (fromIsDesc) {
      auto *p{
          special.GetProc<void (*)(const Descriptor &, const Descriptor &)>()};
      p(to, from);
    } else {
      auto *p{special.GetProc<void (*)(const Descriptor &, void *)>()};
      p(to, from.raw().base_addr);
    }
  } else {
    if (fromIsDesc) {
      auto *p{special.GetProc<void (*)(void *, const Descriptor &)>()};
      p(to.raw().base_addr, from);
    } else {
      auto *p{special.GetProc<void (*)(void *, void *)>()};
      p(to.raw().base_addr, from.raw().base_addr);
    }
  }
}

static void DoElementalDefinedAssignment(const Descriptor &to,
    const Descriptor &from, const typeInfo::SpecialBinding &special,
    std::size_t toElements, SubscriptValue toAt[], SubscriptValue fromAt[]) {
  StaticDescriptor<maxRank, true, 8 /*?*/> statDesc[2];
  Descriptor &toElementDesc{statDesc[0].descriptor()};
  Descriptor &fromElementDesc{statDesc[1].descriptor()};
  toElementDesc = to;
  toElementDesc.raw().attribute = CFI_attribute_pointer;
  toElementDesc.raw().rank = 0;
  fromElementDesc = from;
  fromElementDesc.raw().attribute = CFI_attribute_pointer;
  fromElementDesc.raw().rank = 0;
  for (std::size_t j{0}; j < toElements;
       ++j, to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
    toElementDesc.set_base_addr(to.Element<char>(toAt));
    fromElementDesc.set_base_addr(from.Element<char>(fromAt));
    DoScalarDefinedAssignment(toElementDesc, fromElementDesc, special);
  }
}

void Assign(Descriptor &to, const Descriptor &from, Terminator &terminator) {
  DescriptorAddendum *toAddendum{to.Addendum()};
  const typeInfo::DerivedType *toDerived{
      toAddendum ? toAddendum->derivedType() : nullptr};
  const DescriptorAddendum *fromAddendum{from.Addendum()};
  const typeInfo::DerivedType *fromDerived{
      fromAddendum ? fromAddendum->derivedType() : nullptr};
  bool wasJustAllocated{false};
  if (to.IsAllocatable()) {
    std::size_t lenParms{fromDerived ? fromDerived->LenParameters() : 0};
    if (to.IsAllocated()) {
      // Top-level assignments to allocatable variables (*not* components)
      // may first deallocate existing content if there's about to be a
      // change in type or shape; see F'2018 10.2.1.3(3).
      bool deallocate{false};
      if (to.type() != from.type()) {
        deallocate = true;
      } else if (toDerived != fromDerived) {
        deallocate = true;
      } else {
        if (toAddendum) {
          // Distinct LEN parameters? Deallocate
          for (std::size_t j{0}; j < lenParms; ++j) {
            if (toAddendum->LenParameterValue(j) !=
                fromAddendum->LenParameterValue(j)) {
              deallocate = true;
              break;
            }
          }
        }
        if (from.rank() > 0) {
          // Distinct shape? Deallocate
          int rank{to.rank()};
          for (int j{0}; j < rank; ++j) {
            if (to.GetDimension(j).Extent() != from.GetDimension(j).Extent()) {
              deallocate = true;
              break;
            }
          }
        }
      }
      if (deallocate) {
        to.Destroy(true /*finalize*/);
      }
    } else if (to.rank() != from.rank()) {
      terminator.Crash("Assign: mismatched ranks (%d != %d) in assignment to "
                       "unallocated allocatable",
          to.rank(), from.rank());
    }
    if (!to.IsAllocated()) {
      to.raw().type = from.raw().type;
      to.raw().elem_len = from.ElementBytes();
      if (toAddendum) {
        toDerived = fromDerived;
        toAddendum->set_derivedType(toDerived);
        for (std::size_t j{0}; j < lenParms; ++j) {
          toAddendum->SetLenParameterValue(
              j, fromAddendum->LenParameterValue(j));
        }
      }
      // subtle: leave bounds in place when "from" is scalar (10.2.1.3(3))
      int rank{from.rank()};
      auto stride{static_cast<SubscriptValue>(to.ElementBytes())};
      for (int j{0}; j < rank; ++j) {
        auto &toDim{to.GetDimension(j)};
        const auto &fromDim{from.GetDimension(j)};
        toDim.SetBounds(fromDim.LowerBound(), fromDim.UpperBound());
        toDim.SetByteStride(stride);
        stride *= toDim.Extent();
      }
      ReturnError(terminator, to.Allocate());
      if (fromDerived && !fromDerived->noInitializationNeeded()) {
        ReturnError(terminator, Initialize(to, *toDerived, terminator));
      }
      wasJustAllocated = true;
    }
  }
  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());
  }
  if (to.type() != from.type()) {
    terminator.Crash("Assign: mismatching types (to code %d != from code %d)",
        to.type().raw(), from.type().raw());
  }
  std::size_t elementBytes{to.ElementBytes()};
  if (elementBytes != from.ElementBytes()) {
    terminator.Crash(
        "Assign: mismatching element sizes (to %zd bytes != from %zd bytes)",
        elementBytes, from.ElementBytes());
  }
  if (toDerived) { // Derived type assignment
    // Check for defined assignment type-bound procedures (10.2.1.4-5)
    if (to.rank() == 0) {
      if (const auto *special{toDerived->FindSpecialBinding(
              typeInfo::SpecialBinding::Which::ScalarAssignment)}) {
        return DoScalarDefinedAssignment(to, from, *special);
      }
    }
    if (const auto *special{toDerived->FindSpecialBinding(
            typeInfo::SpecialBinding::Which::ElementalAssignment)}) {
      return DoElementalDefinedAssignment(
          to, from, *special, toElements, toAt, fromAt);
    }
    // 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 (!wasJustAllocated && !toDerived->noFinalizationNeeded()) {
      Finalize(to, *toDerived);
    }
    // Copy the data components (incl. the parent) first.
    const Descriptor &componentDesc{toDerived->component()};
    std::size_t numComponents{componentDesc.Elements()};
    for (std::size_t k{0}; k < numComponents; ++k) {
      const auto &comp{
          *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(
              k)}; // TODO: exploit contiguity here
      switch (comp.genre()) {
      case typeInfo::Component::Genre::Data:
        if (comp.category() == TypeCategory::Derived) {
          StaticDescriptor<maxRank, true, 10 /*?*/> statDesc[2];
          Descriptor &toCompDesc{statDesc[0].descriptor()};
          Descriptor &fromCompDesc{statDesc[1].descriptor()};
          for (std::size_t j{0}; j < toElements; ++j,
               to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
            comp.CreatePointerDescriptor(toCompDesc, to, terminator, toAt);
            comp.CreatePointerDescriptor(
                fromCompDesc, from, terminator, fromAt);
            Assign(toCompDesc, fromCompDesc, terminator);
          }
        } else { // Component has intrinsic type; simply copy raw bytes
          std::size_t componentByteSize{comp.SizeInBytes(to)};
          for (std::size_t j{0}; j < toElements; ++j,
               to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
            std::memmove(to.Element<char>(toAt) + comp.offset(),
                from.Element<const char>(fromAt) + comp.offset(),
                componentByteSize);
          }
        }
        break;
      case typeInfo::Component::Genre::Pointer: {
        std::size_t componentByteSize{comp.SizeInBytes(to)};
        for (std::size_t j{0}; j < toElements; ++j,
             to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
          std::memmove(to.Element<char>(toAt) + comp.offset(),
              from.Element<const char>(fromAt) + comp.offset(),
              componentByteSize);
        }
      } break;
      case typeInfo::Component::Genre::Allocatable:
      case typeInfo::Component::Genre::Automatic:
        for (std::size_t j{0}; j < toElements; ++j,
             to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
          auto *toDesc{reinterpret_cast<Descriptor *>(
              to.Element<char>(toAt) + comp.offset())};
          const auto *fromDesc{reinterpret_cast<const Descriptor *>(
              from.Element<char>(fromAt) + comp.offset())};
          if (toDesc->IsAllocatable()) {
            if (toDesc->IsAllocated()) {
              // 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.
              // TODO: Consider skipping this step and deferring the
              // deallocation to the recursive activation of Assign(),
              // which might be able to avoid deallocation/reallocation
              // when the existing allocation can be reoccupied.
              toDesc->Destroy(false /*already finalized*/);
            }
            if (!fromDesc->IsAllocated()) {
              continue; // F'2018 10.2.1.3(13)(2)
            }
          }
          Assign(*toDesc, *fromDesc, terminator);
        }
        break;
      }
    }
    // Copy procedure pointer components
    const Descriptor &procPtrDesc{toDerived->procPtr()};
    std::size_t numProcPtrs{procPtrDesc.Elements()};
    for (std::size_t k{0}; k < numProcPtrs; ++k) {
      const auto &procPtr{
          *procPtrDesc.ZeroBasedIndexedElement<typeInfo::ProcPtrComponent>(k)};
      for (std::size_t j{0}; j < toElements; ++j, to.IncrementSubscripts(toAt),
           from.IncrementSubscripts(fromAt)) {
        std::memmove(to.Element<char>(toAt) + procPtr.offset,
            from.Element<const char>(fromAt) + procPtr.offset,
            sizeof(typeInfo::ProcedurePointer));
      }
    }
  } else { // intrinsic type, intrinsic assignment
    if (to.rank() == from.rank() && to.IsContiguous() && from.IsContiguous()) {
      // Everything is contiguous; do a single big copy
      std::memmove(
          to.raw().base_addr, from.raw().base_addr, toElements * elementBytes);
    } else { // elemental copies
      for (std::size_t n{toElements}; n-- > 0;
           to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
        std::memmove(to.Element<char>(toAt), from.Element<const char>(fromAt),
            elementBytes);
      }
    }
  }
}

extern "C" {
void RTNAME(Assign)(Descriptor &to, const Descriptor &from,
    const char *sourceFile, int sourceLine) {
  Terminator terminator{sourceFile, sourceLine};
  Assign(to, from, terminator);
}

} // extern "C"
} // namespace Fortran::runtime