Index: flang/runtime/CMakeLists.txt =================================================================== --- flang/runtime/CMakeLists.txt +++ flang/runtime/CMakeLists.txt @@ -51,6 +51,7 @@ io-stmt.cpp main.cpp memory.cpp + misc-intrinsic.cpp numeric.cpp reduction.cpp stat.cpp Index: flang/runtime/descriptor.h =================================================================== --- flang/runtime/descriptor.h +++ flang/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) { Index: flang/runtime/descriptor.cpp =================================================================== --- flang/runtime/descriptor.cpp +++ flang/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()); } Index: flang/runtime/misc-intrinsic.h =================================================================== --- /dev/null +++ flang/runtime/misc-intrinsic.h @@ -0,0 +1,29 @@ +//===-- runtime/misc-intrensic.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 + +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_ Index: flang/runtime/misc-intrinsic.cpp =================================================================== --- /dev/null +++ flang/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 +#include + +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(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()}; + 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(sourceAt), toMove); + to += toMove; + resultBytes -= toMove; + --sourceElements; + source.IncrementSubscripts(sourceAt); + } + if (resultBytes > 0) { + std::memset(to, 0, resultBytes); + } +} + +} // extern "C" +} // namespace Fortran::runtime Index: flang/unittests/RuntimeGTest/CMakeLists.txt =================================================================== --- flang/unittests/RuntimeGTest/CMakeLists.txt +++ flang/unittests/RuntimeGTest/CMakeLists.txt @@ -1,6 +1,7 @@ add_flang_unittest(FlangRuntimeTests CharacterTest.cpp CrashHandlerFixture.cpp + MiscIntrinsic.cpp Numeric.cpp NumericalFormatTest.cpp Reduction.cpp Index: flang/unittests/RuntimeGTest/MiscIntrinsic.cpp =================================================================== --- /dev/null +++ flang/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( + std::vector{}, std::vector{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(), 4.0); + result.Destroy(); +} + +TEST(MiscIntrinsic, TransferMold) { + StaticDescriptor<2, true, 2> staticDesc[2]; + auto &result{staticDesc[0].descriptor()}; + auto source{MakeArray( + std::vector{3}, std::vector{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()[0], 1.1F); + EXPECT_EQ(result.OffsetElement()[1], 2.2F); + EXPECT_EQ(result.OffsetElement()[2], 3.3F); + EXPECT_EQ(result.OffsetElement()[3], 0.0F); + result.Destroy(); +} + +TEST(MiscIntrinsic, TransferSize) { + StaticDescriptor<2, true, 2> staticDesc[2]; + auto &result{staticDesc[0].descriptor()}; + auto source{MakeArray( + std::vector{3}, std::vector{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()[0], 1.1F); + EXPECT_EQ(result.OffsetElement()[1], 2.2F); + result.Destroy(); +} Index: flang/unittests/RuntimeGTest/Reduction.cpp =================================================================== --- flang/unittests/RuntimeGTest/Reduction.cpp +++ flang/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 -static void StoreElement(void *p, const A &x, std::size_t bytes) { - std::memcpy(p, &x, bytes); -} - -template -static void StoreElement( - void *p, const std::basic_string &str, std::size_t bytes) { - ASSERT_LE(bytes, sizeof(CHAR) * str.size()); - std::memcpy(p, str.data(), bytes); -} - -template -static OwningPtr MakeArray(const std::vector &shape, - const std::vector &data, std::size_t elemLen = KIND) { - auto rank{static_cast(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()}; - for (const auto &x : data) { - StoreElement(p, x, elemLen); - p += elemLen; - } - return result; -} - TEST(Reductions, SumInt4) { auto array{MakeArray( std::vector{2, 3}, std::vector{1, 2, 3, 4, 5, 6})}; Index: flang/unittests/RuntimeGTest/tools.h =================================================================== --- /dev/null +++ flang/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 +#include +#include + +namespace Fortran::runtime { + +template +static void StoreElement(void *p, const A &x, std::size_t bytes) { + std::memcpy(p, &x, bytes); +} + +template +static void StoreElement( + void *p, const std::basic_string &str, std::size_t bytes) { + ASSERT_LE(bytes, sizeof(CHAR) * str.size()); + std::memcpy(p, str.data(), bytes); +} + +template +static OwningPtr MakeArray(const std::vector &shape, + const std::vector &data, std::size_t elemLen = KIND) { + auto rank{static_cast(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()}; + for (A x : data) { + StoreElement(p, x, elemLen); + p += elemLen; + } + return result; +} + +} // namespace Fortran::runtime +#endif // FORTRAN_UNITTESTS_RUNTIME_TOOLS_H_