[flang-commits] [flang] c1db35f - [flang] Implement more transformational intrinsic functions in runtime
peter klausler via flang-commits
flang-commits at lists.llvm.org
Thu May 20 13:28:14 PDT 2021
Author: peter klausler
Date: 2021-05-20T13:22:01-07:00
New Revision: c1db35f0c232a8672d44f2531d178d4da35b5b3c
URL: https://github.com/llvm/llvm-project/commit/c1db35f0c232a8672d44f2531d178d4da35b5b3c
DIFF: https://github.com/llvm/llvm-project/commit/c1db35f0c232a8672d44f2531d178d4da35b5b3c.diff
LOG: [flang] Implement more transformational intrinsic functions in runtime
Define APIs, naively implement, and add basic sanity unit tests for
the transformational intrinsic functions CSHIFT, EOSHIFT, PACK,
SPREAD, TRANSPOSE, and UNPACK. These are the remaining transformational
intrinsic functions that rearrange data without regard to type
(except for default boundary values in EOSHIFT); RESHAPE was already
in place as a stress test for the runtime's descriptor handling
facilities.
Code is in place to create copies of allocatable/automatic
components when transforming arrays of derived type, but it won't
do anything until we have derived type information being passed to the
runtime from the frontend.
Differential Revision: https://reviews.llvm.org/D102857
Added:
flang/runtime/copy.cpp
flang/runtime/copy.h
flang/unittests/RuntimeGTest/Transformational.cpp
Modified:
flang/module/__fortran_type_info.f90
flang/runtime/CMakeLists.txt
flang/runtime/allocatable.cpp
flang/runtime/descriptor.h
flang/runtime/tools.cpp
flang/runtime/tools.h
flang/runtime/transformational.cpp
flang/runtime/transformational.h
flang/runtime/type-info.h
flang/unittests/Evaluate/reshape.cpp
flang/unittests/RuntimeGTest/CMakeLists.txt
flang/unittests/RuntimeGTest/Matmul.cpp
flang/unittests/RuntimeGTest/Namelist.cpp
flang/unittests/RuntimeGTest/Reduction.cpp
Removed:
################################################################################
diff --git a/flang/module/__fortran_type_info.f90 b/flang/module/__fortran_type_info.f90
index 6fce352c162e8..c2a9ed16e10b5 100644
--- a/flang/module/__fortran_type_info.f90
+++ b/flang/module/__fortran_type_info.f90
@@ -30,7 +30,7 @@
! applied, appear in the initial entries in the same order as they
! appear in the parent type's bindings, if any. They are followed
! by new local bindings in alphabetic order of theing binding names.
- type(Binding), pointer :: binding(:)
+ type(Binding), pointer, contiguous :: binding(:)
character(len=:), pointer :: name
integer(kind=int64) :: sizeInBytes
type(DerivedType), pointer :: parent
@@ -38,14 +38,14 @@
! component to point to the pristine original definition.
type(DerivedType), pointer :: uninstantiated
integer(kind=int64) :: typeHash
- integer(kind=int64), pointer :: kindParameter(:) ! values of instance
- integer(1), pointer :: lenParameterKind(:) ! INTEGER kinds of LEN types
+ integer(kind=int64), pointer, contiguous :: kindParameter(:) ! values of instance
+ integer(1), pointer, contiguous :: lenParameterKind(:) ! INTEGER kinds of LEN types
! Data components appear in alphabetic order.
! The parent component, if any, appears explicitly.
- type(Component), pointer :: component(:) ! data components
- type(ProcPtrComponent), pointer :: procptr(:) ! procedure pointers
+ type(Component), pointer, contiguous :: component(:) ! data components
+ type(ProcPtrComponent), pointer, contiguous :: procptr(:) ! procedure pointers
! Special bindings of the ancestral types are not duplicated here.
- type(SpecialBinding), pointer :: special(:)
+ type(SpecialBinding), pointer, contiguous :: special(:)
end type
type :: Binding
@@ -86,8 +86,8 @@
integer(kind=int64) :: offset
type(Value) :: characterLen ! for category == Character
type(DerivedType), pointer :: derived ! for category == Derived
- type(Value), pointer :: lenValue(:) ! (SIZE(derived%lenParameterKind))
- type(Value), pointer :: bounds(:, :) ! (2, rank): lower, upper
+ type(Value), pointer, contiguous :: lenValue(:) ! (SIZE(derived%lenParameterKind))
+ type(Value), pointer, contiguous :: bounds(:, :) ! (2, rank): lower, upper
type(__builtin_c_ptr) :: initialization
end type
diff --git a/flang/runtime/CMakeLists.txt b/flang/runtime/CMakeLists.txt
index a484c94b0da1b..7d5c88e78825d 100644
--- a/flang/runtime/CMakeLists.txt
+++ b/flang/runtime/CMakeLists.txt
@@ -35,6 +35,7 @@ add_flang_library(FortranRuntime
allocatable.cpp
buffer.cpp
complex-reduction.c
+ copy.cpp
character.cpp
connection.cpp
derived.cpp
diff --git a/flang/runtime/allocatable.cpp b/flang/runtime/allocatable.cpp
index addc1b78d5d17..f14122948f5e9 100644
--- a/flang/runtime/allocatable.cpp
+++ b/flang/runtime/allocatable.cpp
@@ -1,4 +1,4 @@
-//===-- runtime/allocatable.cpp ---------------------------------*- C++ -*-===//
+//===-- runtime/allocatable.cpp -------------------------------------------===//
//
// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
// See https://llvm.org/LICENSE.txt for license information.
diff --git a/flang/runtime/copy.cpp b/flang/runtime/copy.cpp
new file mode 100644
index 0000000000000..458b8f0a16dac
--- /dev/null
+++ b/flang/runtime/copy.cpp
@@ -0,0 +1,64 @@
+//===-- runtime/copy.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 "copy.h"
+#include "allocatable.h"
+#include "descriptor.h"
+#include "terminator.h"
+#include "type-info.h"
+#include <cstring>
+
+namespace Fortran::runtime {
+
+void CopyElement(const Descriptor &to, const SubscriptValue toAt[],
+ const Descriptor &from, const SubscriptValue fromAt[],
+ Terminator &terminator) {
+ char *toPtr{to.Element<char>(toAt)};
+ const char *fromPtr{from.Element<const char>(fromAt)};
+ RUNTIME_CHECK(terminator, to.ElementBytes() == from.ElementBytes());
+ std::memcpy(toPtr, fromPtr, to.ElementBytes());
+ if (const auto *addendum{to.Addendum()}) {
+ if (const auto *derived{addendum->derivedType()}) {
+ RUNTIME_CHECK(terminator,
+ from.Addendum() && derived == from.Addendum()->derivedType());
+ const Descriptor &componentDesc{derived->component.descriptor()};
+ const typeInfo::Component *component{
+ componentDesc.OffsetElement<typeInfo::Component>()};
+ std::size_t nComponents{componentDesc.Elements()};
+ for (std::size_t j{0}; j < nComponents; ++j, ++component) {
+ if (component->genre == typeInfo::Component::Genre::Allocatable ||
+ component->genre == typeInfo::Component::Genre::Automatic) {
+ Descriptor &toDesc{
+ *reinterpret_cast<Descriptor *>(toPtr + component->offset)};
+ if (toDesc.raw().base_addr != nullptr) {
+ toDesc.set_base_addr(nullptr);
+ RUNTIME_CHECK(terminator, toDesc.Allocate() == CFI_SUCCESS);
+ const Descriptor &fromDesc{*reinterpret_cast<const Descriptor *>(
+ fromPtr + component->offset)};
+ CopyArray(toDesc, fromDesc, terminator);
+ }
+ }
+ }
+ }
+ }
+}
+
+void CopyArray(
+ const Descriptor &to, const Descriptor &from, Terminator &terminator) {
+ std::size_t elements{to.Elements()};
+ RUNTIME_CHECK(terminator, elements == from.Elements());
+ SubscriptValue toAt[maxRank], fromAt[maxRank];
+ to.GetLowerBounds(toAt);
+ from.GetLowerBounds(fromAt);
+ while (elements-- > 0) {
+ CopyElement(to, toAt, from, fromAt, terminator);
+ to.IncrementSubscripts(toAt);
+ from.IncrementSubscripts(fromAt);
+ }
+}
+} // namespace Fortran::runtime
diff --git a/flang/runtime/copy.h b/flang/runtime/copy.h
new file mode 100644
index 0000000000000..6de4455868403
--- /dev/null
+++ b/flang/runtime/copy.h
@@ -0,0 +1,28 @@
+//===-- runtime/copy.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
+//
+//===----------------------------------------------------------------------===//
+
+// Utilities that copy data in a type-aware fashion, allocating & duplicating
+// allocatable/automatic components of derived types along the way.
+
+#ifndef FORTRAN_RUNTIME_COPY_H_
+#define FORTRAN_RUNTIME_COPY_H_
+
+#include "descriptor.h"
+
+namespace Fortran::runtime {
+
+// Assigns to uninitialized storage.
+// Duplicates allocatable & automatic components.
+void CopyElement(const Descriptor &to, const SubscriptValue toAt[],
+ const Descriptor &from, const SubscriptValue fromAt[], Terminator &);
+
+// Copies data from one allocated descriptor's array to another.
+void CopyArray(const Descriptor &to, const Descriptor &from, Terminator &);
+
+} // namespace Fortran::runtime
+#endif // FORTRAN_RUNTIME_COPY_H_
diff --git a/flang/runtime/descriptor.h b/flang/runtime/descriptor.h
index d86c136faff38..5e03ad05b253b 100644
--- a/flang/runtime/descriptor.h
+++ b/flang/runtime/descriptor.h
@@ -246,10 +246,18 @@ class Descriptor {
return nullptr;
}
- void GetLowerBounds(SubscriptValue subscript[]) const {
+ int GetLowerBounds(SubscriptValue subscript[]) const {
for (int j{0}; j < raw_.rank; ++j) {
subscript[j] = GetDimension(j).LowerBound();
}
+ return raw_.rank;
+ }
+
+ int GetShape(SubscriptValue subscript[]) const {
+ for (int j{0}; j < raw_.rank; ++j) {
+ subscript[j] = GetDimension(j).Extent();
+ }
+ return raw_.rank;
}
// When the passed subscript vector contains the last (or first)
diff --git a/flang/runtime/tools.cpp b/flang/runtime/tools.cpp
index 2d036f54e8f34..c67da77e0c118 100644
--- a/flang/runtime/tools.cpp
+++ b/flang/runtime/tools.cpp
@@ -106,5 +106,4 @@ void CheckIntegerKind(Terminator &terminator, int kind, const char *intrinsic) {
terminator.Crash("%s: bad KIND=%d argument", intrinsic, kind);
}
}
-
} // namespace Fortran::runtime
diff --git a/flang/runtime/tools.h b/flang/runtime/tools.h
index ee8c439b6cb55..d4a070868abc5 100644
--- a/flang/runtime/tools.h
+++ b/flang/runtime/tools.h
@@ -66,7 +66,8 @@ inline void PutContiguousConverted(TO *to, FROM *from, std::size_t count) {
}
}
-static inline std::int64_t GetInt64(const char *p, std::size_t bytes) {
+static inline std::int64_t GetInt64(
+ const char *p, std::size_t bytes, Terminator &terminator) {
switch (bytes) {
case 1:
return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 1> *>(p);
@@ -77,8 +78,7 @@ static inline std::int64_t GetInt64(const char *p, std::size_t bytes) {
case 8:
return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 8> *>(p);
default:
- Terminator{__FILE__, __LINE__}.Crash(
- "GetInt64: no case for %zd bytes", bytes);
+ terminator.Crash("GetInt64: no case for %zd bytes", bytes);
}
}
@@ -333,6 +333,5 @@ std::optional<std::pair<TypeCategory, int>> inline constexpr GetResultType(
}
return std::nullopt;
}
-
} // namespace Fortran::runtime
#endif // FORTRAN_RUNTIME_TOOLS_H_
diff --git a/flang/runtime/transformational.cpp b/flang/runtime/transformational.cpp
index 07a34c198da11..e7cd089399f52 100644
--- a/flang/runtime/transformational.cpp
+++ b/flang/runtime/transformational.cpp
@@ -6,19 +6,357 @@
//
//===----------------------------------------------------------------------===//
+// Implements the transformational intrinsic functions of Fortran 2018 that
+// rearrange or duplicate data without (much) regard to type. These are
+// CSHIFT, EOSHIFT, PACK, RESHAPE, SPREAD, TRANSPOSE, and UNPACK.
+//
+// Many of these are defined in the 2018 standard with text that makes sense
+// only if argument arrays have lower bounds of one. Rather than interpret
+// these cases as implying a hidden constraint, these implementations
+// work with arbitrary lower bounds. This may be technically an extension
+// of the standard but it more likely to conform with its intent.
+
#include "transformational.h"
+#include "copy.h"
#include "terminator.h"
#include "tools.h"
#include <algorithm>
-#include <cinttypes>
namespace Fortran::runtime {
+// Utility for CSHIFT & EOSHIFT rank > 1 cases that determines the shift count
+// for each of the vector sections of the result.
+class ShiftControl {
+public:
+ ShiftControl(const Descriptor &s, Terminator &t, int dim)
+ : shift_{s}, terminator_{t}, shiftRank_{s.rank()}, dim_{dim} {}
+ void Init(const Descriptor &source) {
+ int rank{source.rank()};
+ RUNTIME_CHECK(terminator_, shiftRank_ == 0 || shiftRank_ == rank - 1);
+ auto catAndKind{shift_.type().GetCategoryAndKind()};
+ RUNTIME_CHECK(
+ terminator_, catAndKind && catAndKind->first == TypeCategory::Integer);
+ shiftElemLen_ = catAndKind->second;
+ if (shiftRank_ > 0) {
+ int k{0};
+ for (int j{0}; j < rank; ++j) {
+ if (j + 1 != dim_) {
+ const Dimension &shiftDim{shift_.GetDimension(k)};
+ lb_[k++] = shiftDim.LowerBound();
+ RUNTIME_CHECK(terminator_,
+ shiftDim.Extent() == source.GetDimension(j).Extent());
+ }
+ }
+ } else {
+ shiftCount_ =
+ GetInt64(shift_.OffsetElement<char>(), shiftElemLen_, terminator_);
+ }
+ }
+ SubscriptValue GetShift(const SubscriptValue resultAt[]) const {
+ if (shiftRank_ > 0) {
+ SubscriptValue shiftAt[maxRank];
+ int k{0};
+ for (int j{0}; j < shiftRank_ + 1; ++j) {
+ if (j + 1 != dim_) {
+ shiftAt[k] = lb_[k] + resultAt[j] - 1;
+ ++k;
+ }
+ }
+ return GetInt64(
+ shift_.Element<char>(shiftAt), shiftElemLen_, terminator_);
+ } else {
+ return shiftCount_; // invariant count extracted in Init()
+ }
+ }
+
+private:
+ const Descriptor &shift_;
+ Terminator &terminator_;
+ int shiftRank_;
+ int dim_;
+ SubscriptValue lb_[maxRank];
+ std::size_t shiftElemLen_;
+ SubscriptValue shiftCount_{};
+};
+
+// Fill an EOSHIFT result with default boundary values
+static void DefaultInitialize(
+ const Descriptor &result, Terminator &terminator) {
+ auto catAndKind{result.type().GetCategoryAndKind()};
+ RUNTIME_CHECK(
+ terminator, catAndKind && catAndKind->first != TypeCategory::Derived);
+ std::size_t elementLen{result.ElementBytes()};
+ std::size_t bytes{result.Elements() * elementLen};
+ if (catAndKind->first == TypeCategory::Character) {
+ switch (int kind{catAndKind->second}) {
+ case 1:
+ std::fill_n(result.OffsetElement<char>(), bytes, ' ');
+ break;
+ case 2:
+ std::fill_n(result.OffsetElement<char16_t>(), bytes / 2,
+ static_cast<char16_t>(' '));
+ break;
+ case 4:
+ std::fill_n(result.OffsetElement<char32_t>(), bytes / 4,
+ static_cast<char32_t>(' '));
+ break;
+ default:
+ terminator.Crash("EOSHIFT: bad CHARACTER kind %d", kind);
+ }
+ } else {
+ std::memset(result.raw().base_addr, 0, bytes);
+ }
+}
+
+static inline std::size_t AllocateResult(Descriptor &result,
+ const Descriptor &source, int rank, const SubscriptValue extent[],
+ Terminator &terminator, const char *function) {
+ std::size_t elementLen{source.ElementBytes()};
+ const DescriptorAddendum *sourceAddendum{source.Addendum()};
+ result.Establish(source.type(), elementLen, nullptr, rank, extent,
+ CFI_attribute_allocatable, sourceAddendum != nullptr);
+ if (sourceAddendum) {
+ *result.Addendum() = *sourceAddendum;
+ }
+ for (int j{0}; j < rank; ++j) {
+ result.GetDimension(j).SetBounds(1, extent[j]);
+ }
+ if (int stat{result.Allocate()}) {
+ terminator.Crash(
+ "%s: Could not allocate memory for result (stat=%d)", function, stat);
+ }
+ return elementLen;
+}
+
+extern "C" {
+
+// CSHIFT of rank > 1
+void RTNAME(Cshift)(Descriptor &result, const Descriptor &source,
+ const Descriptor &shift, int dim, const char *sourceFile, int line) {
+ Terminator terminator{sourceFile, line};
+ int rank{source.rank()};
+ RUNTIME_CHECK(terminator, rank > 1);
+ RUNTIME_CHECK(terminator, dim >= 1 && dim <= rank);
+ ShiftControl shiftControl{shift, terminator, dim};
+ shiftControl.Init(source);
+ SubscriptValue extent[maxRank];
+ source.GetShape(extent);
+ AllocateResult(result, source, rank, extent, terminator, "CSHIFT");
+ SubscriptValue resultAt[maxRank];
+ for (int j{0}; j < rank; ++j) {
+ resultAt[j] = 1;
+ }
+ SubscriptValue sourceLB[maxRank];
+ source.GetLowerBounds(sourceLB);
+ SubscriptValue dimExtent{extent[dim - 1]};
+ SubscriptValue dimLB{sourceLB[dim - 1]};
+ SubscriptValue &resDim{resultAt[dim - 1]};
+ for (std::size_t n{result.Elements()}; n > 0; n -= dimExtent) {
+ SubscriptValue shiftCount{shiftControl.GetShift(resultAt)};
+ SubscriptValue sourceAt[maxRank];
+ for (int j{0}; j < rank; ++j) {
+ sourceAt[j] = sourceLB[j] + resultAt[j] - 1;
+ }
+ SubscriptValue &sourceDim{sourceAt[dim - 1]};
+ sourceDim = dimLB + shiftCount % dimExtent;
+ if (shiftCount < 0) {
+ sourceDim += dimExtent;
+ }
+ for (resDim = 1; resDim <= dimExtent; ++resDim) {
+ CopyElement(result, resultAt, source, sourceAt, terminator);
+ if (++sourceDim == dimLB + dimExtent) {
+ sourceDim = dimLB;
+ }
+ }
+ result.IncrementSubscripts(resultAt);
+ }
+}
+
+// CSHIFT of vector
+void RTNAME(CshiftVector)(Descriptor &result, const Descriptor &source,
+ std::int64_t shift, const char *sourceFile, int line) {
+ Terminator terminator{sourceFile, line};
+ RUNTIME_CHECK(terminator, source.rank() == 1);
+ const Dimension &sourceDim{source.GetDimension(0)};
+ SubscriptValue extent{sourceDim.Extent()};
+ AllocateResult(result, source, 1, &extent, terminator, "CSHIFT");
+ SubscriptValue lb{sourceDim.LowerBound()};
+ for (SubscriptValue j{0}; j < extent; ++j) {
+ SubscriptValue resultAt{1 + j};
+ SubscriptValue sourceAt{lb + (j + shift) % extent};
+ CopyElement(result, &resultAt, source, &sourceAt, terminator);
+ }
+}
+
+// EOSHIFT of rank > 1
+void RTNAME(Eoshift)(Descriptor &result, const Descriptor &source,
+ const Descriptor &shift, const Descriptor *boundary, int dim,
+ const char *sourceFile, int line) {
+ Terminator terminator{sourceFile, line};
+ SubscriptValue extent[maxRank];
+ int rank{source.GetShape(extent)};
+ RUNTIME_CHECK(terminator, rank > 1);
+ RUNTIME_CHECK(terminator, dim >= 1 && dim <= rank);
+ std::size_t elementLen{
+ AllocateResult(result, source, rank, extent, terminator, "EOSHIFT")};
+ int boundaryRank{-1};
+ if (boundary) {
+ boundaryRank = boundary->rank();
+ RUNTIME_CHECK(terminator, boundaryRank == 0 || boundaryRank == rank - 1);
+ RUNTIME_CHECK(terminator,
+ boundary->type() == source.type() &&
+ boundary->ElementBytes() == elementLen);
+ if (boundaryRank > 0) {
+ int k{0};
+ for (int j{0}; j < rank; ++j) {
+ if (j != dim - 1) {
+ RUNTIME_CHECK(
+ terminator, boundary->GetDimension(k).Extent() == extent[j]);
+ ++k;
+ }
+ }
+ }
+ }
+ ShiftControl shiftControl{shift, terminator, dim};
+ shiftControl.Init(source);
+ SubscriptValue resultAt[maxRank];
+ for (int j{0}; j < rank; ++j) {
+ resultAt[j] = 1;
+ }
+ if (!boundary) {
+ DefaultInitialize(result, terminator);
+ }
+ SubscriptValue sourceLB[maxRank];
+ source.GetLowerBounds(sourceLB);
+ SubscriptValue boundaryAt[maxRank];
+ if (boundaryRank > 0) {
+ boundary->GetLowerBounds(boundaryAt);
+ }
+ SubscriptValue dimExtent{extent[dim - 1]};
+ SubscriptValue dimLB{sourceLB[dim - 1]};
+ SubscriptValue &resDim{resultAt[dim - 1]};
+ for (std::size_t n{result.Elements()}; n > 0; n -= dimExtent) {
+ SubscriptValue shiftCount{shiftControl.GetShift(resultAt)};
+ SubscriptValue sourceAt[maxRank];
+ for (int j{0}; j < rank; ++j) {
+ sourceAt[j] = sourceLB[j] + resultAt[j] - 1;
+ }
+ SubscriptValue &sourceDim{sourceAt[dim - 1]};
+ sourceDim = dimLB + shiftCount;
+ for (resDim = 1; resDim <= dimExtent; ++resDim) {
+ if (sourceDim >= dimLB && sourceDim < dimLB + dimExtent) {
+ CopyElement(result, resultAt, source, sourceAt, terminator);
+ } else if (boundary) {
+ CopyElement(result, resultAt, *boundary, boundaryAt, terminator);
+ }
+ ++sourceDim;
+ }
+ result.IncrementSubscripts(resultAt);
+ if (boundaryRank > 0) {
+ boundary->IncrementSubscripts(boundaryAt);
+ }
+ }
+}
+
+// EOSHIFT of vector
+void RTNAME(EoshiftVector)(Descriptor &result, const Descriptor &source,
+ std::int64_t shift, const Descriptor *boundary, const char *sourceFile,
+ int line) {
+ Terminator terminator{sourceFile, line};
+ RUNTIME_CHECK(terminator, source.rank() == 1);
+ SubscriptValue extent{source.GetDimension(0).Extent()};
+ std::size_t elementLen{
+ AllocateResult(result, source, 1, &extent, terminator, "EOSHIFT")};
+ std::optional<int> blankFill; // kind of character
+ if (boundary) {
+ RUNTIME_CHECK(terminator, boundary->rank() == 0);
+ RUNTIME_CHECK(terminator,
+ boundary->type() == source.type() &&
+ boundary->ElementBytes() == elementLen);
+ }
+ if (!boundary) {
+ DefaultInitialize(result, terminator);
+ }
+ SubscriptValue lb{source.GetDimension(0).LowerBound()};
+ for (SubscriptValue j{1}; j <= extent; ++j) {
+ SubscriptValue sourceAt{lb + j - 1 + shift};
+ if (sourceAt >= lb && sourceAt < lb + extent) {
+ CopyElement(result, &j, source, &sourceAt, terminator);
+ }
+ }
+}
+
+// PACK
+void RTNAME(Pack)(Descriptor &result, const Descriptor &source,
+ const Descriptor &mask, const Descriptor *vector, const char *sourceFile,
+ int line) {
+ Terminator terminator{sourceFile, line};
+ CheckConformability(source, mask, terminator, "PACK", "ARRAY=", "MASK=");
+ auto maskType{mask.type().GetCategoryAndKind()};
+ RUNTIME_CHECK(
+ terminator, maskType && maskType->first == TypeCategory::Logical);
+ SubscriptValue trues{0};
+ if (mask.rank() == 0) {
+ if (IsLogicalElementTrue(mask, nullptr)) {
+ trues = source.Elements();
+ }
+ } else {
+ SubscriptValue maskAt[maxRank];
+ mask.GetLowerBounds(maskAt);
+ for (std::size_t n{mask.Elements()}; n > 0; --n) {
+ if (IsLogicalElementTrue(mask, maskAt)) {
+ ++trues;
+ }
+ mask.IncrementSubscripts(maskAt);
+ }
+ }
+ SubscriptValue extent{trues};
+ if (vector) {
+ RUNTIME_CHECK(terminator, vector->rank() == 1);
+ RUNTIME_CHECK(terminator,
+ source.type() == vector->type() &&
+ source.ElementBytes() == vector->ElementBytes());
+ extent = vector->GetDimension(0).Extent();
+ RUNTIME_CHECK(terminator, extent >= trues);
+ }
+ AllocateResult(result, source, 1, &extent, terminator, "PACK");
+ SubscriptValue sourceAt[maxRank], resultAt{1};
+ source.GetLowerBounds(sourceAt);
+ if (mask.rank() == 0) {
+ if (IsLogicalElementTrue(mask, nullptr)) {
+ for (SubscriptValue n{trues}; n > 0; --n) {
+ CopyElement(result, &resultAt, source, sourceAt, terminator);
+ ++resultAt;
+ source.IncrementSubscripts(sourceAt);
+ }
+ }
+ } else {
+ SubscriptValue maskAt[maxRank];
+ mask.GetLowerBounds(maskAt);
+ for (std::size_t n{source.Elements()}; n > 0; --n) {
+ if (IsLogicalElementTrue(mask, maskAt)) {
+ CopyElement(result, &resultAt, source, sourceAt, terminator);
+ ++resultAt;
+ }
+ source.IncrementSubscripts(sourceAt);
+ mask.IncrementSubscripts(maskAt);
+ }
+ }
+ if (vector) {
+ SubscriptValue vectorAt{
+ vector->GetDimension(0).LowerBound() + resultAt - 1};
+ for (; resultAt <= extent; ++resultAt, ++vectorAt) {
+ CopyElement(result, &resultAt, *vector, &vectorAt, terminator);
+ }
+ }
+}
+
// F2018 16.9.163
OwningPtr<Descriptor> RTNAME(Reshape)(const Descriptor &source,
- const Descriptor &shape, const Descriptor *pad, const Descriptor *order) {
+ const Descriptor &shape, const Descriptor *pad, const Descriptor *order,
+ const char *sourceFile, int line) {
// Compute and check the rank of the result.
- Terminator terminator{__FILE__, __LINE__};
+ Terminator terminator{sourceFile, line};
RUNTIME_CHECK(terminator, shape.rank() == 1);
RUNTIME_CHECK(terminator, shape.type().IsInteger());
SubscriptValue resultRank{shape.GetDimension(0).Extent()};
@@ -33,8 +371,8 @@ OwningPtr<Descriptor> RTNAME(Reshape)(const Descriptor &source,
SubscriptValue shapeSubscript{shape.GetDimension(0).LowerBound()};
for (SubscriptValue j{0}; j < resultRank; ++j, ++shapeSubscript) {
lowerBound[j] = 1;
- resultExtent[j] =
- GetInt64(shape.Element<char>(&shapeSubscript), shapeElementBytes);
+ resultExtent[j] = GetInt64(
+ shape.Element<char>(&shapeSubscript), shapeElementBytes, terminator);
RUNTIME_CHECK(terminator, resultExtent[j] >= 0);
resultElements *= resultExtent[j];
}
@@ -59,8 +397,8 @@ OwningPtr<Descriptor> RTNAME(Reshape)(const Descriptor &source,
std::uint64_t values{0};
SubscriptValue orderSubscript{order->GetDimension(0).LowerBound()};
for (SubscriptValue j{0}; j < resultRank; ++j, ++orderSubscript) {
- auto k{GetInt64(
- order->OffsetElement<char>(orderSubscript), shapeElementBytes)};
+ auto k{GetInt64(order->OffsetElement<char>(orderSubscript),
+ shapeElementBytes, terminator)};
RUNTIME_CHECK(
terminator, k >= 1 && k <= resultRank && !((values >> k) & 1));
values |= std::uint64_t{1} << k;
@@ -109,8 +447,7 @@ OwningPtr<Descriptor> RTNAME(Reshape)(const Descriptor &source,
std::size_t resultElement{0};
std::size_t elementsFromSource{std::min(resultElements, sourceElements)};
for (; resultElement < elementsFromSource; ++resultElement) {
- std::memcpy(result->Element<void>(resultSubscript),
- source.Element<const void>(sourceSubscript), elementBytes);
+ CopyElement(*result, resultSubscript, source, sourceSubscript, terminator);
source.IncrementSubscripts(sourceSubscript);
result->IncrementSubscripts(resultSubscript, dimOrder);
}
@@ -119,8 +456,7 @@ OwningPtr<Descriptor> RTNAME(Reshape)(const Descriptor &source,
SubscriptValue padSubscript[maxRank];
pad->GetLowerBounds(padSubscript);
for (; resultElement < resultElements; ++resultElement) {
- std::memcpy(result->Element<void>(resultSubscript),
- pad->Element<const void>(padSubscript), elementBytes);
+ CopyElement(*result, resultSubscript, *pad, padSubscript, terminator);
pad->IncrementSubscripts(padSubscript);
result->IncrementSubscripts(resultSubscript, dimOrder);
}
@@ -128,4 +464,94 @@ OwningPtr<Descriptor> RTNAME(Reshape)(const Descriptor &source,
return result;
}
+
+// SPREAD
+void RTNAME(Spread)(Descriptor &result, const Descriptor &source, int dim,
+ std::int64_t ncopies, const char *sourceFile, int line) {
+ Terminator terminator{sourceFile, line};
+ int rank{source.rank() + 1};
+ RUNTIME_CHECK(terminator, rank <= maxRank);
+ ncopies = std::max<std::int64_t>(ncopies, 0);
+ SubscriptValue extent[maxRank];
+ int k{0};
+ for (int j{0}; j < rank; ++j) {
+ extent[j] = j == dim - 1 ? ncopies : source.GetDimension(k++).Extent();
+ }
+ AllocateResult(result, source, rank, extent, terminator, "SPREAD");
+ SubscriptValue resultAt[maxRank];
+ for (int j{0}; j < rank; ++j) {
+ resultAt[j] = 1;
+ }
+ SubscriptValue &resultDim{resultAt[dim - 1]};
+ SubscriptValue sourceAt[maxRank];
+ source.GetLowerBounds(sourceAt);
+ for (std::size_t n{result.Elements()}; n > 0; n -= ncopies) {
+ for (resultDim = 1; resultDim <= ncopies; ++resultDim) {
+ CopyElement(result, resultAt, source, sourceAt, terminator);
+ }
+ result.IncrementSubscripts(resultAt);
+ source.IncrementSubscripts(sourceAt);
+ }
+}
+
+// TRANSPOSE
+void RTNAME(Transpose)(Descriptor &result, const Descriptor &matrix,
+ const char *sourceFile, int line) {
+ Terminator terminator{sourceFile, line};
+ RUNTIME_CHECK(terminator, matrix.rank() == 2);
+ SubscriptValue extent[2]{
+ matrix.GetDimension(1).Extent(), matrix.GetDimension(0).Extent()};
+ AllocateResult(result, matrix, 2, extent, terminator, "TRANSPOSE");
+ SubscriptValue resultAt[2]{1, 1};
+ SubscriptValue matrixLB[2];
+ matrix.GetLowerBounds(matrixLB);
+ for (std::size_t n{result.Elements()}; n-- > 0;
+ result.IncrementSubscripts(resultAt)) {
+ SubscriptValue matrixAt[2]{
+ matrixLB[0] + resultAt[1] - 1, matrixLB[1] + resultAt[0] - 1};
+ CopyElement(result, resultAt, matrix, matrixAt, terminator);
+ }
+}
+
+// UNPACK
+void RTNAME(Unpack)(Descriptor &result, const Descriptor &vector,
+ const Descriptor &mask, const Descriptor &field, const char *sourceFile,
+ int line) {
+ Terminator terminator{sourceFile, line};
+ RUNTIME_CHECK(terminator, vector.rank() == 1);
+ int rank{mask.rank()};
+ RUNTIME_CHECK(terminator, rank > 0);
+ SubscriptValue extent[maxRank];
+ mask.GetShape(extent);
+ CheckConformability(mask, field, terminator, "UNPACK", "MASK=", "FIELD=");
+ std::size_t elementLen{
+ AllocateResult(result, field, rank, extent, terminator, "UNPACK")};
+ RUNTIME_CHECK(terminator,
+ vector.type() == field.type() && vector.ElementBytes() == elementLen);
+ SubscriptValue resultAt[maxRank], maskAt[maxRank], fieldAt[maxRank],
+ vectorAt{vector.GetDimension(0).LowerBound()};
+ for (int j{0}; j < rank; ++j) {
+ resultAt[j] = 1;
+ }
+ mask.GetLowerBounds(maskAt);
+ field.GetLowerBounds(fieldAt);
+ SubscriptValue vectorLeft{vector.GetDimension(0).Extent()};
+ for (std::size_t n{result.Elements()}; n-- > 0;) {
+ if (IsLogicalElementTrue(mask, maskAt)) {
+ if (vectorLeft-- == 0) {
+ terminator.Crash("UNPACK: VECTOR= argument has fewer elements than "
+ "MASK= has .TRUE. entries");
+ }
+ CopyElement(result, resultAt, vector, &vectorAt, terminator);
+ ++vectorAt;
+ } else {
+ CopyElement(result, resultAt, field, fieldAt, terminator);
+ }
+ result.IncrementSubscripts(resultAt);
+ mask.IncrementSubscripts(maskAt);
+ field.IncrementSubscripts(fieldAt);
+ }
+}
+
+} // extern "C"
} // namespace Fortran::runtime
diff --git a/flang/runtime/transformational.h b/flang/runtime/transformational.h
index 1994fca58235c..85d2ae5e8e3bd 100644
--- a/flang/runtime/transformational.h
+++ b/flang/runtime/transformational.h
@@ -6,6 +6,14 @@
//
//===----------------------------------------------------------------------===//
+// Defines the API for the type-independent transformational intrinsic functions
+// that rearrange data in arrays: CSHIFT, EOSHIFT, PACK, RESHAPE, SPREAD,
+// TRANSPOSE, and UNPACK.
+// These are naive allocating implementations; optimized forms that manipulate
+// pointer descriptors or that supply functional views of arrays remain to
+// be defined and may instead be part of lowering (see docs/ArrayComposition.md)
+// for details).
+
#ifndef FORTRAN_RUNTIME_TRANSFORMATIONAL_H_
#define FORTRAN_RUNTIME_TRANSFORMATIONAL_H_
@@ -14,9 +22,41 @@
#include "memory.h"
namespace Fortran::runtime {
+extern "C" {
+
+void RTNAME(Cshift)(Descriptor &result, const Descriptor &source,
+ const Descriptor &shift, int dim = 1, const char *sourceFile = nullptr,
+ int line = 0);
+void RTNAME(CshiftVector)(Descriptor &result, const Descriptor &source,
+ std::int64_t shift, const char *sourceFile = nullptr, int line = 0);
+
+void RTNAME(Eoshift)(Descriptor &result, const Descriptor &source,
+ const Descriptor &shift, const Descriptor *boundary = nullptr, int dim = 1,
+ const char *sourceFile = nullptr, int line = 0);
+void RTNAME(EoshiftVector)(Descriptor &result, const Descriptor &source,
+ std::int64_t shift, const Descriptor *boundary = nullptr,
+ const char *sourceFile = nullptr, int line = 0);
+
+void RTNAME(Pack)(Descriptor &result, const Descriptor &source,
+ const Descriptor &mask, const Descriptor *vector = nullptr,
+ const char *sourceFile = nullptr, int line = 0);
+// TODO: redo API
OwningPtr<Descriptor> RTNAME(Reshape)(const Descriptor &source,
const Descriptor &shape, const Descriptor *pad = nullptr,
- const Descriptor *order = nullptr);
-}
+ const Descriptor *order = nullptr, const char *sourceFile = nullptr,
+ int line = 0);
+
+void RTNAME(Spread)(Descriptor &result, const Descriptor &source, int dim,
+ std::int64_t ncopies, const char *sourceFile = nullptr, int line = 0);
+
+void RTNAME(Transpose)(Descriptor &result, const Descriptor &matrix,
+ const char *sourceFile = nullptr, int line = 0);
+
+void RTNAME(Unpack)(Descriptor &result, const Descriptor &vector,
+ const Descriptor &mask, const Descriptor &field,
+ const char *sourceFile = nullptr, int line = 0);
+
+} // extern "C"
+} // namespace Fortran::runtime
#endif // FORTRAN_RUNTIME_TRANSFORMATIONAL_H_
diff --git a/flang/runtime/type-info.h b/flang/runtime/type-info.h
index 4f933e8bb5a53..c83a5f2f517e1 100644
--- a/flang/runtime/type-info.h
+++ b/flang/runtime/type-info.h
@@ -27,12 +27,13 @@ class DerivedType {
// It includes all of the ancestor types' bindings, if any, first,
// with any overrides from descendants already applied to them. Local
// bindings then follow in alphabetic order of binding name.
- StaticDescriptor<1> binding; // TYPE(BINDING), DIMENSION(:), POINTER
+ StaticDescriptor<1, true>
+ binding; // TYPE(BINDING), DIMENSION(:), POINTER, CONTIGUOUS
StaticDescriptor<0> name; // CHARACTER(:), POINTER
std::uint64_t sizeInBytes{0};
- StaticDescriptor<0> parent; // TYPE(DERIVEDTYPE), POINTER
+ StaticDescriptor<0, true> parent; // TYPE(DERIVEDTYPE), POINTER
// Instantiations of a parameterized derived type with KIND type
// parameters will point this data member to the description of
@@ -40,7 +41,7 @@ class DerivedType {
// module via use association. The original uninstantiated derived
// type description will point to itself. Derived types that have
// no KIND type parameters will have a null pointer here.
- StaticDescriptor<0> uninstantiated; // TYPE(DERIVEDTYPE), POINTER
+ StaticDescriptor<0, true> uninstantiated; // TYPE(DERIVEDTYPE), POINTER
// TODO: flags for SEQUENCE, BIND(C), any PRIVATE component(? see 7.5.2)
std::uint64_t typeHash{0};
@@ -52,14 +53,16 @@ class DerivedType {
// This array of local data components includes the parent component.
// Components are in alphabetic order.
// It does not include procedure pointer components.
- StaticDescriptor<1, true> component; // TYPE(COMPONENT), POINTER, DIMENSION(:)
+ StaticDescriptor<1, true>
+ component; // TYPE(COMPONENT), POINTER, DIMENSION(:), CONTIGUOUS
// Procedure pointer components
- StaticDescriptor<1, true> procPtr; // TYPE(PROCPTR), POINTER, DIMENSION(:)
+ StaticDescriptor<1, true>
+ procPtr; // TYPE(PROCPTR), POINTER, DIMENSION(:), CONTIGUOUS
// Does not include special bindings from ancestral types.
StaticDescriptor<1, true>
- special; // TYPE(SPECIALBINDING), POINTER, DIMENSION(:)
+ special; // TYPE(SPECIALBINDING), POINTER, DIMENSION(:), CONTIGUOUS
std::size_t LenParameters() const {
return lenParameterKind.descriptor().Elements();
@@ -95,8 +98,10 @@ struct Component {
std::uint64_t offset{0};
Value characterLen; // for TypeCategory::Character
StaticDescriptor<0, true> derivedType; // TYPE(DERIVEDTYPE), POINTER
- StaticDescriptor<1, true> lenValue; // TYPE(VALUE), POINTER, DIMENSION(:)
- StaticDescriptor<2, true> bounds; // TYPE(VALUE), POINTER, DIMENSION(2,:)
+ StaticDescriptor<1, true>
+ lenValue; // TYPE(VALUE), POINTER, DIMENSION(:), CONTIGUOUS
+ StaticDescriptor<2, true>
+ bounds; // TYPE(VALUE), POINTER, DIMENSION(2,:), CONTIGUOUS
char *initialization{nullptr}; // for Genre::Data and Pointer
// TODO: cobounds
// TODO: `PRIVATE` attribute
diff --git a/flang/unittests/Evaluate/reshape.cpp b/flang/unittests/Evaluate/reshape.cpp
index a51acdb5fca88..c3aa8f4b76bcc 100644
--- a/flang/unittests/Evaluate/reshape.cpp
+++ b/flang/unittests/Evaluate/reshape.cpp
@@ -52,7 +52,8 @@ int main() {
MATCH(2, pad.GetDimension(1).Extent());
MATCH(3, pad.GetDimension(2).Extent());
- auto result{RTNAME(Reshape)(*source, *shape, &pad)};
+ auto result{
+ RTNAME(Reshape)(*source, *shape, &pad, nullptr, __FILE__, __LINE__)};
TEST(result.get() != nullptr);
result->Check();
MATCH(sizeof(std::int32_t), result->ElementBytes());
diff --git a/flang/unittests/RuntimeGTest/CMakeLists.txt b/flang/unittests/RuntimeGTest/CMakeLists.txt
index 3d45cf6dc877b..13bfadf66a528 100644
--- a/flang/unittests/RuntimeGTest/CMakeLists.txt
+++ b/flang/unittests/RuntimeGTest/CMakeLists.txt
@@ -2,6 +2,7 @@ add_flang_unittest(FlangRuntimeTests
CharacterTest.cpp
CrashHandlerFixture.cpp
Format.cpp
+ ListInputTest.cpp
Matmul.cpp
MiscIntrinsic.cpp
Namelist.cpp
@@ -10,7 +11,7 @@ add_flang_unittest(FlangRuntimeTests
Random.cpp
Reduction.cpp
RuntimeCrashTest.cpp
- ListInputTest.cpp
+ Transformational.cpp
)
target_link_libraries(FlangRuntimeTests
diff --git a/flang/unittests/RuntimeGTest/Matmul.cpp b/flang/unittests/RuntimeGTest/Matmul.cpp
index ae9e7a84236c8..1f0c756bc5d72 100644
--- a/flang/unittests/RuntimeGTest/Matmul.cpp
+++ b/flang/unittests/RuntimeGTest/Matmul.cpp
@@ -27,7 +27,7 @@ TEST(Matmul, Basic) {
std::vector<int>{3, 2}, std::vector<std::int16_t>{6, 7, 8, 9, 10, 11})};
auto v{MakeArray<TypeCategory::Integer, 8>(
std::vector<int>{2}, std::vector<std::int64_t>{-1, -2})};
- StaticDescriptor<2> statDesc;
+ StaticDescriptor<2, true> statDesc;
Descriptor &result{statDesc.descriptor()};
RTNAME(Matmul)(result, *x, *y, __FILE__, __LINE__);
diff --git a/flang/unittests/RuntimeGTest/Namelist.cpp b/flang/unittests/RuntimeGTest/Namelist.cpp
index fc38cee47f86f..77eec4e341322 100644
--- a/flang/unittests/RuntimeGTest/Namelist.cpp
+++ b/flang/unittests/RuntimeGTest/Namelist.cpp
@@ -34,7 +34,7 @@ TEST(NamelistTests, BasicSanity) {
static constexpr int numLines{12};
static constexpr int lineLength{32};
static char buffer[numLines][lineLength];
- StaticDescriptor<1> statDescs[1];
+ StaticDescriptor<1, true> statDescs[1];
Descriptor &internalDesc{statDescs[0].descriptor()};
SubscriptValue extent[]{numLines};
internalDesc.Establish(TypeCode{CFI_type_char}, /*elementBytes=*/lineLength,
@@ -136,7 +136,7 @@ TEST(NamelistTests, Subscripts) {
const NamelistGroup::Item items[]{{"a", *aDesc}};
const NamelistGroup group{"justa", 1, items};
static char t1[]{"&justa A(0,1:-1:-2)=1 2/"};
- StaticDescriptor<1> statDescs[2];
+ StaticDescriptor<1, true> statDescs[2];
Descriptor &internalDesc{statDescs[0].descriptor()};
internalDesc.Establish(TypeCode{CFI_type_char},
/*elementBytes=*/std::strlen(t1), t1, 0, nullptr, CFI_attribute_pointer);
diff --git a/flang/unittests/RuntimeGTest/Reduction.cpp b/flang/unittests/RuntimeGTest/Reduction.cpp
index 5a2c6fb80b379..4c01cf468bcb7 100644
--- a/flang/unittests/RuntimeGTest/Reduction.cpp
+++ b/flang/unittests/RuntimeGTest/Reduction.cpp
@@ -1,4 +1,4 @@
-//===-- flang/unittests/RuntimeGTest/Reductions.cpp -------------*- C++ -*-===//
+//===-- flang/unittests/RuntimeGTest/Reductions.cpp -----------------------===//
//
// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
// See https://llvm.org/LICENSE.txt for license information.
@@ -34,7 +34,7 @@ TEST(Reductions, DimMaskProductInt4) {
shape, std::vector<std::int32_t>{1, 2, 3, 4, 5, 6})};
auto mask{MakeArray<TypeCategory::Logical, 1>(
shape, std::vector<bool>{true, false, false, true, true, true})};
- StaticDescriptor<1> statDesc;
+ StaticDescriptor<1, true> statDesc;
Descriptor &prod{statDesc.descriptor()};
RTNAME(ProductDim)(prod, *array, 1, __FILE__, __LINE__, &*mask);
EXPECT_EQ(prod.rank(), 1);
@@ -66,7 +66,7 @@ TEST(Reductions, DoubleMaxMinNorm2) {
double norm2Error{
std::abs(naiveNorm2 - RTNAME(Norm2_8)(*array, __FILE__, __LINE__))};
EXPECT_LE(norm2Error, 0.000001 * naiveNorm2);
- StaticDescriptor<2> statDesc;
+ StaticDescriptor<2, true> statDesc;
Descriptor &loc{statDesc.descriptor()};
RTNAME(Maxloc)
(loc, *array, /*KIND=*/8, __FILE__, __LINE__, /*MASK=*/nullptr,
@@ -146,7 +146,7 @@ TEST(Reductions, Character) {
std::vector<int> shape{2, 3};
auto array{MakeArray<TypeCategory::Character, 1>(shape,
std::vector<std::string>{"abc", "def", "ghi", "jkl", "mno", "abc"}, 3)};
- StaticDescriptor<1> statDesc[2];
+ StaticDescriptor<1, true> statDesc[2];
Descriptor &res{statDesc[0].descriptor()};
RTNAME(MaxvalCharacter)(res, *array, __FILE__, __LINE__);
EXPECT_EQ(res.rank(), 0);
@@ -245,7 +245,7 @@ TEST(Reductions, Logical) {
EXPECT_EQ(RTNAME(Any)(*array, __FILE__, __LINE__), true);
EXPECT_EQ(RTNAME(Parity)(*array, __FILE__, __LINE__), false);
EXPECT_EQ(RTNAME(Count)(*array, __FILE__, __LINE__), 2);
- StaticDescriptor<2> statDesc[2];
+ StaticDescriptor<2, true> statDesc[2];
Descriptor &res{statDesc[0].descriptor()};
RTNAME(AllDim)(res, *array, /*DIM=*/1, __FILE__, __LINE__);
EXPECT_EQ(res.rank(), 1);
@@ -344,7 +344,7 @@ TEST(Reductions, FindlocNumeric) {
std::numeric_limits<double>::quiet_NaN(),
std::numeric_limits<double>::infinity()})};
ASSERT_EQ(realArray->ElementBytes(), sizeof(double));
- StaticDescriptor<2> statDesc[2];
+ StaticDescriptor<2, true> statDesc[2];
Descriptor &res{statDesc[0].descriptor()};
// Find the first zero
Descriptor &target{statDesc[1].descriptor()};
diff --git a/flang/unittests/RuntimeGTest/Transformational.cpp b/flang/unittests/RuntimeGTest/Transformational.cpp
new file mode 100644
index 0000000000000..00495fc04a94d
--- /dev/null
+++ b/flang/unittests/RuntimeGTest/Transformational.cpp
@@ -0,0 +1,203 @@
+//===-- flang/unittests/RuntimeGTest/Transformational.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 "../../runtime/transformational.h"
+#include "gtest/gtest.h"
+#include "tools.h"
+#include "../../runtime/type-code.h"
+
+using namespace Fortran::runtime;
+using Fortran::common::TypeCategory;
+
+TEST(Transformational, Shifts) {
+ // ARRAY 1 3 5
+ // 2 4 6
+ auto array{MakeArray<TypeCategory::Integer, 4>(
+ std::vector<int>{2, 3}, std::vector<std::int32_t>{1, 2, 3, 4, 5, 6})};
+ array->GetDimension(0).SetLowerBound(0); // shouldn't matter
+ array->GetDimension(1).SetLowerBound(-1);
+ StaticDescriptor<2, true> statDesc;
+ Descriptor &result{statDesc.descriptor()};
+
+ auto shift3{MakeArray<TypeCategory::Integer, 8>(
+ std::vector<int>{3}, std::vector<std::int64_t>{1, -1, 2})};
+ RTNAME(Cshift)(result, *array, *shift3, 1, __FILE__, __LINE__);
+ EXPECT_EQ(result.type(), array->type());
+ EXPECT_EQ(result.rank(), 2);
+ EXPECT_EQ(result.GetDimension(0).LowerBound(), 1);
+ EXPECT_EQ(result.GetDimension(0).Extent(), 2);
+ EXPECT_EQ(result.GetDimension(1).LowerBound(), 1);
+ EXPECT_EQ(result.GetDimension(1).Extent(), 3);
+ EXPECT_EQ(result.type(), (TypeCode{TypeCategory::Integer, 4}));
+ static std::int32_t cshiftExpect1[6]{2, 1, 4, 3, 5, 6};
+ for (int j{0}; j < 6; ++j) {
+ EXPECT_EQ(
+ *result.ZeroBasedIndexedElement<std::int32_t>(j), cshiftExpect1[j]);
+ }
+ result.Destroy();
+
+ auto shift2{MakeArray<TypeCategory::Integer, 1>(
+ std::vector<int>{2}, std::vector<std::int8_t>{1, -1})};
+ shift2->GetDimension(0).SetLowerBound(-1); // shouldn't matter
+ shift2->GetDimension(1).SetLowerBound(2);
+ RTNAME(Cshift)(result, *array, *shift2, 2, __FILE__, __LINE__);
+ EXPECT_EQ(result.type(), array->type());
+ EXPECT_EQ(result.rank(), 2);
+ EXPECT_EQ(result.GetDimension(0).LowerBound(), 1);
+ EXPECT_EQ(result.GetDimension(0).Extent(), 2);
+ EXPECT_EQ(result.GetDimension(1).LowerBound(), 1);
+ EXPECT_EQ(result.GetDimension(1).Extent(), 3);
+ EXPECT_EQ(result.type(), (TypeCode{TypeCategory::Integer, 4}));
+ static std::int32_t cshiftExpect2[6]{3, 6, 5, 2, 1, 4};
+ for (int j{0}; j < 6; ++j) {
+ EXPECT_EQ(
+ *result.ZeroBasedIndexedElement<std::int32_t>(j), cshiftExpect2[j]);
+ }
+ result.Destroy();
+
+ auto boundary{MakeArray<TypeCategory::Integer, 4>(
+ std::vector<int>{3}, std::vector<std::int32_t>{-1, -2, -3})};
+ boundary->GetDimension(0).SetLowerBound(9); // shouldn't matter
+ RTNAME(Eoshift)(result, *array, *shift3, &*boundary, 1, __FILE__, __LINE__);
+ EXPECT_EQ(result.type(), array->type());
+ EXPECT_EQ(result.rank(), 2);
+ EXPECT_EQ(result.GetDimension(0).LowerBound(), 1);
+ EXPECT_EQ(result.GetDimension(0).Extent(), 2);
+ EXPECT_EQ(result.GetDimension(1).LowerBound(), 1);
+ EXPECT_EQ(result.GetDimension(1).Extent(), 3);
+ EXPECT_EQ(result.type(), (TypeCode{TypeCategory::Integer, 4}));
+ static std::int32_t eoshiftExpect1[6]{2, -1, -2, 3, -3, -3};
+ for (int j{0}; j < 6; ++j) {
+ EXPECT_EQ(
+ *result.ZeroBasedIndexedElement<std::int32_t>(j), eoshiftExpect1[j]);
+ }
+ result.Destroy();
+}
+
+TEST(Transformational, Pack) {
+ // ARRAY 1 3 5
+ // 2 4 6
+ auto array{MakeArray<TypeCategory::Integer, 4>(
+ std::vector<int>{2, 3}, std::vector<std::int32_t>{1, 2, 3, 4, 5, 6})};
+ array->GetDimension(0).SetLowerBound(2); // shouldn't matter
+ array->GetDimension(1).SetLowerBound(-1);
+ auto mask{MakeArray<TypeCategory::Logical, 1>(std::vector<int>{2, 3},
+ std::vector<std::uint8_t>{false, true, true, false, false, true})};
+ mask->GetDimension(0).SetLowerBound(0); // shouldn't matter
+ mask->GetDimension(1).SetLowerBound(2);
+ StaticDescriptor<1, true> statDesc;
+ Descriptor &result{statDesc.descriptor()};
+
+ RTNAME(Pack)(result, *array, *mask, nullptr, __FILE__, __LINE__);
+ EXPECT_EQ(result.type(), array->type());
+ EXPECT_EQ(result.rank(), 1);
+ EXPECT_EQ(result.GetDimension(0).LowerBound(), 1);
+ EXPECT_EQ(result.GetDimension(0).Extent(), 3);
+ static std::int32_t packExpect1[3]{2, 3, 6};
+ for (int j{0}; j < 3; ++j) {
+ EXPECT_EQ(*result.ZeroBasedIndexedElement<std::int32_t>(j), packExpect1[j])
+ << " at " << j;
+ }
+ result.Destroy();
+
+ auto vector{MakeArray<TypeCategory::Integer, 4>(
+ std::vector<int>{5}, std::vector<std::int32_t>{-1, -2, -3, -4, -5})};
+ RTNAME(Pack)(result, *array, *mask, &*vector, __FILE__, __LINE__);
+ EXPECT_EQ(result.type(), array->type());
+ EXPECT_EQ(result.rank(), 1);
+ EXPECT_EQ(result.GetDimension(0).LowerBound(), 1);
+ EXPECT_EQ(result.GetDimension(0).Extent(), 5);
+ static std::int32_t packExpect2[5]{2, 3, 6, -4, -5};
+ for (int j{0}; j < 5; ++j) {
+ EXPECT_EQ(*result.ZeroBasedIndexedElement<std::int32_t>(j), packExpect2[j])
+ << " at " << j;
+ }
+ result.Destroy();
+}
+
+TEST(Transformational, Spread) {
+ auto array{MakeArray<TypeCategory::Integer, 4>(
+ std::vector<int>{3}, std::vector<std::int32_t>{1, 2, 3})};
+ array->GetDimension(0).SetLowerBound(2); // shouldn't matter
+ StaticDescriptor<2, true> statDesc;
+ Descriptor &result{statDesc.descriptor()};
+
+ RTNAME(Spread)(result, *array, 1, 2, __FILE__, __LINE__);
+ EXPECT_EQ(result.type(), array->type());
+ EXPECT_EQ(result.rank(), 2);
+ EXPECT_EQ(result.GetDimension(0).LowerBound(), 1);
+ EXPECT_EQ(result.GetDimension(0).Extent(), 2);
+ EXPECT_EQ(result.GetDimension(1).LowerBound(), 1);
+ EXPECT_EQ(result.GetDimension(1).Extent(), 3);
+ for (int j{0}; j < 6; ++j) {
+ EXPECT_EQ(*result.ZeroBasedIndexedElement<std::int32_t>(j), 1 + j / 2);
+ }
+ result.Destroy();
+
+ RTNAME(Spread)(result, *array, 2, 2, __FILE__, __LINE__);
+ EXPECT_EQ(result.type(), array->type());
+ EXPECT_EQ(result.rank(), 2);
+ EXPECT_EQ(result.GetDimension(0).LowerBound(), 1);
+ EXPECT_EQ(result.GetDimension(0).Extent(), 3);
+ EXPECT_EQ(result.GetDimension(1).LowerBound(), 1);
+ EXPECT_EQ(result.GetDimension(1).Extent(), 2);
+ for (int j{0}; j < 6; ++j) {
+ EXPECT_EQ(*result.ZeroBasedIndexedElement<std::int32_t>(j), 1 + j % 3);
+ }
+ result.Destroy();
+}
+
+TEST(Transformational, Transpose) {
+ // ARRAY 1 3 5
+ // 2 4 6
+ auto array{MakeArray<TypeCategory::Integer, 4>(
+ std::vector<int>{2, 3}, std::vector<std::int32_t>{1, 2, 3, 4, 5, 6})};
+ array->GetDimension(0).SetLowerBound(2); // shouldn't matter
+ array->GetDimension(1).SetLowerBound(-6);
+ StaticDescriptor<2, true> statDesc;
+ Descriptor &result{statDesc.descriptor()};
+ RTNAME(Transpose)(result, *array, __FILE__, __LINE__);
+ EXPECT_EQ(result.type(), array->type());
+ EXPECT_EQ(result.rank(), 2);
+ EXPECT_EQ(result.GetDimension(0).LowerBound(), 1);
+ EXPECT_EQ(result.GetDimension(0).Extent(), 3);
+ EXPECT_EQ(result.GetDimension(1).LowerBound(), 1);
+ EXPECT_EQ(result.GetDimension(1).Extent(), 2);
+ static std::int32_t expect[6]{1, 3, 5, 2, 4, 6};
+ for (int j{0}; j < 6; ++j) {
+ EXPECT_EQ(*result.ZeroBasedIndexedElement<std::int32_t>(j), expect[j]);
+ }
+ result.Destroy();
+}
+
+TEST(Transformational, Unpack) {
+ auto vector{MakeArray<TypeCategory::Integer, 4>(
+ std::vector<int>{4}, std::vector<std::int32_t>{1, 2, 3, 4})};
+ vector->GetDimension(0).SetLowerBound(2); // shouldn't matter
+ auto mask{MakeArray<TypeCategory::Logical, 1>(std::vector<int>{2, 3},
+ std::vector<std::uint8_t>{false, true, true, false, false, true})};
+ mask->GetDimension(0).SetLowerBound(0); // shouldn't matter
+ mask->GetDimension(1).SetLowerBound(2);
+ auto field{MakeArray<TypeCategory::Integer, 4>(std::vector<int>{2, 3},
+ std::vector<std::int32_t>{-1, -2, -3, -4, -5, -6})};
+ field->GetDimension(0).SetLowerBound(-1); // shouldn't matter
+ StaticDescriptor<2, true> statDesc;
+ Descriptor &result{statDesc.descriptor()};
+ RTNAME(Unpack)(result, *vector, *mask, *field, __FILE__, __LINE__);
+ EXPECT_EQ(result.type(), vector->type());
+ EXPECT_EQ(result.rank(), 2);
+ EXPECT_EQ(result.GetDimension(0).LowerBound(), 1);
+ EXPECT_EQ(result.GetDimension(0).Extent(), 2);
+ EXPECT_EQ(result.GetDimension(1).LowerBound(), 1);
+ EXPECT_EQ(result.GetDimension(1).Extent(), 3);
+ static std::int32_t expect[6]{-1, 1, 2, -4, -5, 3};
+ for (int j{0}; j < 6; ++j) {
+ EXPECT_EQ(*result.ZeroBasedIndexedElement<std::int32_t>(j), expect[j]);
+ }
+ result.Destroy();
+}
More information about the flang-commits
mailing list