[flang] TRANSFER() intrinsic function

[klausler]

Summary

API, implementation, and unit tests for the intrinsic
function TRANSFER.

[tskeith]

flang/runtime/misc-intrinsic.h

2

Typo: "intrensic"

[klausler]

Fix typo in comment (thanks!)

flang/runtime/CMakeLists.txt

add_flang_library(FortranRuntime
   format.cpp
   internal-unit.cpp
   iostat.cpp
   io-api.cpp
   io-error.cpp
   io-stmt.cpp
   main.cpp
   memory.cpp
+  misc-intrinsic.cpp
   numeric.cpp
   reduction.cpp
   stat.cpp
   stop.cpp
   terminator.cpp
   tools.cpp
   transformational.cpp
   type-code.cpp
   unit.cpp
   unit-map.cpp
 
   LINK_LIBS
   FortranDecimal
 )

flang/runtime/descriptor.h

enum Flags {
     ImplicitAllocatable = 0x002, // compiler-created allocatable
     DoNotFinalize = 0x004, // compiler temporary
     Target = 0x008, // TARGET attribute
   };
 
   explicit DescriptorAddendum(
       const typeInfo::DerivedType *dt = nullptr, std::uint64_t flags = 0)
       : derivedType_{dt}, flags_{flags} {}
+  DescriptorAddendum &operator=(const DescriptorAddendum &);
 
   const typeInfo::DerivedType *derivedType() const { return derivedType_; }
   DescriptorAddendum &set_derivedType(const typeInfo::DerivedType *dt) {
     derivedType_ = dt;
     return *this;
   }
   std::uint64_t &flags() { return flags_; }
   const std::uint64_t &flags() const { return flags_; }

flang/runtime/descriptor.cpp

for (int j{0}; j < raw_.rank; ++j) {
     std::fprintf(f, "         sm          %jd\n",
         static_cast<std::intmax_t>(raw_.dim[j].sm));
   }
   if (const DescriptorAddendum * addendum{Addendum()}) {
     addendum->Dump(f);
   }
 }
 
+DescriptorAddendum &DescriptorAddendum::operator=(
+    const DescriptorAddendum &that) {
+  derivedType_ = that.derivedType_;
+  flags_ = that.flags_;
+  auto lenParms{that.LenParameters()};
+  for (std::size_t j{0}; j < lenParms; ++j) {
+    len_[j] = that.len_[j];
+  }
+  return *this;
+}
+
 std::size_t DescriptorAddendum::SizeInBytes() const {
   return SizeInBytes(LenParameters());
 }
 
 std::size_t DescriptorAddendum::LenParameters() const {
   const auto *type{derivedType()};
   return type ? type->LenParameters() : 0;
 }
 
 void DescriptorAddendum::Dump(FILE *f) const {
   std::fprintf(
       f, "  derivedType @ %p\n", reinterpret_cast<const void *>(derivedType_));
   std::fprintf(f, "  flags 0x%jx\n", static_cast<std::intmax_t>(flags_));
   // TODO: LEN parameter values
 }
 } // namespace Fortran::runtime

flang/runtime/misc-intrinsic.h

+//===-- runtime/misc-intrinsic.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
+//
+//===----------------------------------------------------------------------===//
+
+// Miscellaneous intrinsic procedures
+
+#ifndef FORTRAN_RUNTIME_MISC_INTRINSIC_H_
+#define FORTRAN_RUNTIME_MISC_INTRINSIC_H_
+
+#include "entry-names.h"
+#include <cstdint>
+
+namespace Fortran::runtime {
+
+class Descriptor;
+
+extern "C" {
+void RTNAME(Transfer)(Descriptor &result, const Descriptor &source,
+    const Descriptor &mold, const char *sourceFile, int line);
+void RTNAME(TransferSize)(Descriptor &result, const Descriptor &source,
+    const Descriptor &mold, const char *sourceFile, int line,
+    std::int64_t size);
+} // extern "C"
+} // namespace Fortran::runtime
+#endif // FORTRAN_RUNTIME_MISC_INTRINSIC_H_

flang/runtime/misc-intrinsic.cpp

+//===-- runtime/misc-intrinsic.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 "misc-intrinsic.h"
+#include "descriptor.h"
+#include "terminator.h"
+#include <algorithm>
+#include <cstring>
+
+namespace Fortran::runtime {
+extern "C" {
+
+void RTNAME(Transfer)(Descriptor &result, const Descriptor &source,
+    const Descriptor &mold, const char *sourceFile, int line) {
+  if (mold.rank() > 0) {
+    std::size_t moldElementBytes{mold.ElementBytes()};
+    std::size_t elements{
+        (source.Elements() * source.ElementBytes() + moldElementBytes - 1) /
+        moldElementBytes};
+    return RTNAME(TransferSize)(result, source, mold, sourceFile, line,
+        static_cast<std::int64_t>(elements));
+  } else {
+    return RTNAME(TransferSize)(result, source, mold, sourceFile, line, 1);
+  }
+}
+
+void RTNAME(TransferSize)(Descriptor &result, const Descriptor &source,
+    const Descriptor &mold, const char *sourceFile, int line,
+    std::int64_t size) {
+  int rank{mold.rank() > 0 ? 1 : 0};
+  std::size_t elementBytes{mold.ElementBytes()};
+  result.Establish(mold.type(), elementBytes, nullptr, rank, nullptr,
+      CFI_attribute_allocatable, mold.Addendum() != nullptr);
+  if (rank > 0) {
+    result.GetDimension(0).SetBounds(1, size);
+  }
+  if (const DescriptorAddendum * addendum{mold.Addendum()}) {
+    *result.Addendum() = *addendum;
+    auto &flags{result.Addendum()->flags()};
+    flags &= ~DescriptorAddendum::StaticDescriptor;
+    flags |= DescriptorAddendum::DoNotFinalize;
+  }
+  if (int stat{result.Allocate()}) {
+    Terminator{sourceFile, line}.Crash(
+        "TRANSFER: could not allocate memory for result; STAT=%d", stat);
+  }
+  char *to{result.OffsetElement<char>()};
+  std::size_t resultBytes{size * elementBytes};
+  const std::size_t sourceElementBytes{source.ElementBytes()};
+  std::size_t sourceElements{source.Elements()};
+  SubscriptValue sourceAt[maxRank];
+  source.GetLowerBounds(sourceAt);
+  while (resultBytes > 0 && sourceElements > 0) {
+    std::size_t toMove{std::min(resultBytes, sourceElementBytes)};
+    std::memcpy(to, source.Element<char>(sourceAt), toMove);
+    to += toMove;
+    resultBytes -= toMove;
+    --sourceElements;
+    source.IncrementSubscripts(sourceAt);
+  }
+  if (resultBytes > 0) {
+    std::memset(to, 0, resultBytes);
+  }
+}
+
+} // extern "C"
+} // namespace Fortran::runtime

flang/unittests/RuntimeGTest/CMakeLists.txt

 add_flang_unittest(FlangRuntimeTests
   CharacterTest.cpp
   CrashHandlerFixture.cpp
+  MiscIntrinsic.cpp
   Numeric.cpp
   NumericalFormatTest.cpp
   Reduction.cpp
   RuntimeCrashTest.cpp
 )
 
 target_link_libraries(FlangRuntimeTests
   PRIVATE
   FortranRuntime
 )

flang/unittests/RuntimeGTest/MiscIntrinsic.cpp

+//===-- flang/unittests/RuntimeGTest/MiscIntrinsic.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 "gtest/gtest.h"
+#include "tools.h"
+#include "../../runtime/allocatable.h"
+#include "../../runtime/cpp-type.h"
+#include "../../runtime/descriptor.h"
+#include "../../runtime/misc-intrinsic.h"
+
+using namespace Fortran::runtime;
+
+// TRANSFER examples from Fortran 2018
+
+TEST(MiscIntrinsic, TransferScalar) {
+  StaticDescriptor<2, true, 2> staticDesc[2];
+  auto &result{staticDesc[0].descriptor()};
+  auto source{MakeArray<TypeCategory::Integer, 4>(
+      std::vector<int>{}, std::vector<std::int32_t>{1082130432})};
+  auto &mold{staticDesc[1].descriptor()};
+  mold.Establish(TypeCategory::Real, 4, nullptr, 0);
+  RTNAME(Transfer)(result, *source, mold, __FILE__, __LINE__);
+  EXPECT_EQ(result.rank(), 0);
+  EXPECT_EQ(result.type().raw(), (TypeCode{TypeCategory::Real, 4}.raw()));
+  EXPECT_EQ(*result.OffsetElement<float>(), 4.0);
+  result.Destroy();
+}
+
+TEST(MiscIntrinsic, TransferMold) {
+  StaticDescriptor<2, true, 2> staticDesc[2];
+  auto &result{staticDesc[0].descriptor()};
+  auto source{MakeArray<TypeCategory::Real, 4>(
+      std::vector<int>{3}, std::vector<float>{1.1F, 2.2F, 3.3F})};
+  auto &mold{staticDesc[1].descriptor()};
+  SubscriptValue extent[1]{1};
+  mold.Establish(TypeCategory::Complex, 4, nullptr, 1, extent);
+  RTNAME(Transfer)(result, *source, mold, __FILE__, __LINE__);
+  EXPECT_EQ(result.rank(), 1);
+  EXPECT_EQ(result.GetDimension(0).LowerBound(), 1);
+  EXPECT_EQ(result.GetDimension(0).Extent(), 2);
+  EXPECT_EQ(result.type().raw(), (TypeCode{TypeCategory::Complex, 4}.raw()));
+  EXPECT_EQ(result.OffsetElement<float>()[0], 1.1F);
+  EXPECT_EQ(result.OffsetElement<float>()[1], 2.2F);
+  EXPECT_EQ(result.OffsetElement<float>()[2], 3.3F);
+  EXPECT_EQ(result.OffsetElement<float>()[3], 0.0F);
+  result.Destroy();
+}
+
+TEST(MiscIntrinsic, TransferSize) {
+  StaticDescriptor<2, true, 2> staticDesc[2];
+  auto &result{staticDesc[0].descriptor()};
+  auto source{MakeArray<TypeCategory::Real, 4>(
+      std::vector<int>{3}, std::vector<float>{1.1F, 2.2F, 3.3F})};
+  auto &mold{staticDesc[1].descriptor()};
+  SubscriptValue extent[1]{1};
+  mold.Establish(TypeCategory::Complex, 4, nullptr, 1, extent);
+  RTNAME(TransferSize)(result, *source, mold, __FILE__, __LINE__, 1);
+  EXPECT_EQ(result.rank(), 1);
+  EXPECT_EQ(result.GetDimension(0).LowerBound(), 1);
+  EXPECT_EQ(result.GetDimension(0).Extent(), 1);
+  EXPECT_EQ(result.type().raw(), (TypeCode{TypeCategory::Complex, 4}.raw()));
+  EXPECT_EQ(result.OffsetElement<float>()[0], 1.1F);
+  EXPECT_EQ(result.OffsetElement<float>()[1], 2.2F);
+  result.Destroy();
+}

flang/unittests/RuntimeGTest/Reduction.cpp

 //===-- flang/unittests/RuntimeGTest/Reductions.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 "../../runtime/reduction.h"
 #include "gtest/gtest.h"
+#include "tools.h"
 #include "../../runtime/allocatable.h"
 #include "../../runtime/cpp-type.h"
 #include "../../runtime/descriptor.h"
 #include "../../runtime/type-code.h"
 #include <cstdint>
 #include <cstring>
 #include <string>
 #include <vector>
 
 using namespace Fortran::runtime;
 using Fortran::common::TypeCategory;
 
-template <typename A>
-static void StoreElement(void *p, const A &x, std::size_t bytes) {
-  std::memcpy(p, &x, bytes);
-}
-
-template <typename CHAR>
-static void StoreElement(
-    void *p, const std::basic_string<CHAR> &str, std::size_t bytes) {
-  ASSERT_LE(bytes, sizeof(CHAR) * str.size());
-  std::memcpy(p, str.data(), bytes);
-}
-
-template <TypeCategory CAT, int KIND, typename A>
-static OwningPtr<Descriptor> MakeArray(const std::vector<int> &shape,
-    const std::vector<A> &data, std::size_t elemLen = KIND) {
-  auto rank{static_cast<int>(shape.size())};
-  auto result{Descriptor::Create(TypeCode{CAT, KIND}, elemLen, nullptr, rank,
-      nullptr, CFI_attribute_allocatable)};
-  for (int j{0}; j < rank; ++j) {
-    result->GetDimension(j).SetBounds(1, shape[j]);
-  }
-  int stat{result->Allocate()};
-  EXPECT_EQ(stat, 0) << stat;
-  EXPECT_LE(data.size(), result->Elements());
-  char *p{result->OffsetElement<char>()};
-  for (const auto &x : data) {
-    StoreElement(p, x, elemLen);
-    p += elemLen;
-  }
-  return result;
-}
-
 TEST(Reductions, SumInt4) {
   auto array{MakeArray<TypeCategory::Integer, 4>(
       std::vector<int>{2, 3}, std::vector<std::int32_t>{1, 2, 3, 4, 5, 6})};
   std::int32_t sum{RTNAME(SumInteger4)(*array, __FILE__, __LINE__)};
   EXPECT_EQ(sum, 21) << sum;
 }
 
 TEST(Reductions, DimMaskProductInt4) {

flang/unittests/RuntimeGTest/tools.h

+//===-- flang/unittests/RuntimeGTest/tools.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
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_UNITTESTS_RUNTIME_TOOLS_H_
+#define FORTRAN_UNITTESTS_RUNTIME_TOOLS_H_
+
+#include "gtest/gtest.h"
+#include "../../runtime/allocatable.h"
+#include "../../runtime/cpp-type.h"
+#include "../../runtime/descriptor.h"
+#include "../../runtime/type-code.h"
+#include <cstdint>
+#include <cstring>
+#include <vector>
+
+namespace Fortran::runtime {
+
+template <typename A>
+static void StoreElement(void *p, const A &x, std::size_t bytes) {
+  std::memcpy(p, &x, bytes);
+}
+
+template <typename CHAR>
+static void StoreElement(
+    void *p, const std::basic_string<CHAR> &str, std::size_t bytes) {
+  ASSERT_LE(bytes, sizeof(CHAR) * str.size());
+  std::memcpy(p, str.data(), bytes);
+}
+
+template <TypeCategory CAT, int KIND, typename A>
+static OwningPtr<Descriptor> MakeArray(const std::vector<int> &shape,
+    const std::vector<A> &data, std::size_t elemLen = KIND) {
+  auto rank{static_cast<int>(shape.size())};
+  auto result{Descriptor::Create(TypeCode{CAT, KIND}, elemLen, nullptr, rank,
+      nullptr, CFI_attribute_allocatable)};
+  for (int j{0}; j < rank; ++j) {
+    result->GetDimension(j).SetBounds(1, shape[j]);
+  }
+  int stat{result->Allocate()};
+  EXPECT_EQ(stat, 0) << stat;
+  EXPECT_LE(data.size(), result->Elements());
+  char *p{result->OffsetElement<char>()};
+  for (A x : data) {
+    StoreElement(p, x, elemLen);
+    p += elemLen;
+  }
+  return result;
+}
+
+} // namespace Fortran::runtime
+#endif // FORTRAN_UNITTESTS_RUNTIME_TOOLS_H_