[flang] TRANSFER() intrinsic function
API, implementation, and unit tests for the intrinsic
function TRANSFER.
Differential Revision: https://reviews.llvm.org/D99799
GitOrigin-RevId: 78a39d2a41661719e8d973830568571d75cd4b09
diff --git a/runtime/CMakeLists.txt b/runtime/CMakeLists.txt
index 49ac98d..6f95ff8 100644
--- a/runtime/CMakeLists.txt
+++ b/runtime/CMakeLists.txt
@@ -51,6 +51,7 @@
io-stmt.cpp
main.cpp
memory.cpp
+ misc-intrinsic.cpp
numeric.cpp
reduction.cpp
stat.cpp
diff --git a/runtime/descriptor.cpp b/runtime/descriptor.cpp
index 54069fe..3a75025 100644
--- a/runtime/descriptor.cpp
+++ b/runtime/descriptor.cpp
@@ -260,6 +260,17 @@
}
}
+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());
}
diff --git a/runtime/descriptor.h b/runtime/descriptor.h
index d909822..2ce90f3 100644
--- a/runtime/descriptor.h
+++ b/runtime/descriptor.h
@@ -93,6 +93,7 @@
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) {
diff --git a/runtime/misc-intrinsic.cpp b/runtime/misc-intrinsic.cpp
new file mode 100644
index 0000000..7b4fa5f
--- /dev/null
+++ b/runtime/misc-intrinsic.cpp
@@ -0,0 +1,72 @@
+//===-- 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
diff --git a/runtime/misc-intrinsic.h b/runtime/misc-intrinsic.h
new file mode 100644
index 0000000..16fa355
--- /dev/null
+++ b/runtime/misc-intrinsic.h
@@ -0,0 +1,29 @@
+//===-- 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_
diff --git a/unittests/RuntimeGTest/CMakeLists.txt b/unittests/RuntimeGTest/CMakeLists.txt
index 1d4e2d0..38f08d7 100644
--- a/unittests/RuntimeGTest/CMakeLists.txt
+++ b/unittests/RuntimeGTest/CMakeLists.txt
@@ -1,6 +1,7 @@
add_flang_unittest(FlangRuntimeTests
CharacterTest.cpp
CrashHandlerFixture.cpp
+ MiscIntrinsic.cpp
Numeric.cpp
NumericalFormatTest.cpp
Reduction.cpp
diff --git a/unittests/RuntimeGTest/MiscIntrinsic.cpp b/unittests/RuntimeGTest/MiscIntrinsic.cpp
new file mode 100644
index 0000000..62213d0
--- /dev/null
+++ b/unittests/RuntimeGTest/MiscIntrinsic.cpp
@@ -0,0 +1,70 @@
+//===-- 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();
+}
diff --git a/unittests/RuntimeGTest/Reduction.cpp b/unittests/RuntimeGTest/Reduction.cpp
index e8471b6..111b567 100644
--- a/unittests/RuntimeGTest/Reduction.cpp
+++ b/unittests/RuntimeGTest/Reduction.cpp
@@ -8,6 +8,7 @@
#include "../../runtime/reduction.h"
#include "gtest/gtest.h"
+#include "tools.h"
#include "../../runtime/allocatable.h"
#include "../../runtime/cpp-type.h"
#include "../../runtime/descriptor.h"
@@ -20,38 +21,6 @@
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})};
diff --git a/unittests/RuntimeGTest/tools.h b/unittests/RuntimeGTest/tools.h
new file mode 100644
index 0000000..c2c31dc
--- /dev/null
+++ b/unittests/RuntimeGTest/tools.h
@@ -0,0 +1,56 @@
+//===-- 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_
