1 //===-- runtime/transformational.cpp --------------------------------------===//
2 //
3 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
4 // See https://llvm.org/LICENSE.txt for license information.
5 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
6 //
7 //===----------------------------------------------------------------------===//
8 
9 #include "transformational.h"
10 #include "memory.h"
11 #include "terminator.h"
12 #include "flang/Evaluate/integer.h"
13 #include <algorithm>
14 #include <cinttypes>
15 
16 namespace Fortran::runtime {
17 
18 static inline std::int64_t GetInt64(const char *p, std::size_t bytes) {
19   switch (bytes) {
20   case 1: return *reinterpret_cast<const std::int8_t *>(p);
21   case 2: return *reinterpret_cast<const std::int16_t *>(p);
22   case 4: return *reinterpret_cast<const std::int32_t *>(p);
23   case 8: return *reinterpret_cast<const std::int64_t *>(p);
24   default:
25     Terminator terminator{__FILE__, __LINE__};
26     terminator.Crash("no case for %dz bytes", bytes);
27   }
28 }
29 
30 // F2018 16.9.163
31 OwningPtr<Descriptor> RESHAPE(const Descriptor &source, const Descriptor &shape,
32     const Descriptor *pad, const Descriptor *order) {
33   // Compute and check the rank of the result.
34   Terminator terminator{__FILE__, __LINE__};
35   RUNTIME_CHECK(terminator, shape.rank() == 1);
36   RUNTIME_CHECK(terminator, shape.type().IsInteger());
37   SubscriptValue resultRank{shape.GetDimension(0).Extent()};
38   RUNTIME_CHECK(terminator,
39       resultRank >= 0 && resultRank <= static_cast<SubscriptValue>(maxRank));
40 
41   // Extract and check the shape of the result; compute its element count.
42   SubscriptValue lowerBound[maxRank];  // all 1's
43   SubscriptValue resultExtent[maxRank];
44   std::size_t shapeElementBytes{shape.ElementBytes()};
45   std::size_t resultElements{1};
46   SubscriptValue shapeSubscript{shape.GetDimension(0).LowerBound()};
47   for (SubscriptValue j{0}; j < resultRank; ++j, ++shapeSubscript) {
48     lowerBound[j] = 1;
49     resultExtent[j] =
50         GetInt64(shape.Element<char>(&shapeSubscript), shapeElementBytes);
51     RUNTIME_CHECK(terminator, resultExtent[j] >= 0);
52     resultElements *= resultExtent[j];
53   }
54 
55   // Check that there are sufficient elements in the SOURCE=, or that
56   // the optional PAD= argument is present and nonempty.
57   std::size_t elementBytes{source.ElementBytes()};
58   std::size_t sourceElements{source.Elements()};
59   std::size_t padElements{pad ? pad->Elements() : 0};
60   if (resultElements < sourceElements) {
61     RUNTIME_CHECK(terminator, padElements > 0);
62     RUNTIME_CHECK(terminator, pad->ElementBytes() == elementBytes);
63   }
64 
65   // Extract and check the optional ORDER= argument, which must be a
66   // permutation of [1..resultRank].
67   int dimOrder[maxRank];
68   if (order) {
69     RUNTIME_CHECK(terminator, order->rank() == 1);
70     RUNTIME_CHECK(terminator, order->type().IsInteger());
71     RUNTIME_CHECK(terminator, order->GetDimension(0).Extent() == resultRank);
72     std::uint64_t values{0};
73     SubscriptValue orderSubscript{order->GetDimension(0).LowerBound()};
74     for (SubscriptValue j{0}; j < resultRank; ++j, ++orderSubscript) {
75       auto k{GetInt64(
76           order->OffsetElement<char>(orderSubscript), shapeElementBytes)};
77       RUNTIME_CHECK(
78           terminator, k >= 1 && k <= resultRank && !((values >> k) & 1));
79       values |= std::uint64_t{1} << k;
80       dimOrder[k - 1] = j;
81     }
82   } else {
83     for (int j{0}; j < resultRank; ++j) {
84       dimOrder[j] = j;
85     }
86   }
87 
88   // Create and populate the result's descriptor.
89   const DescriptorAddendum *sourceAddendum{source.Addendum()};
90   const DerivedType *sourceDerivedType{
91       sourceAddendum ? sourceAddendum->derivedType() : nullptr};
92   OwningPtr<Descriptor> result;
93   if (sourceDerivedType) {
94     result = Descriptor::Create(*sourceDerivedType, nullptr, resultRank,
95         resultExtent, CFI_attribute_allocatable);
96   } else {
97     result = Descriptor::Create(source.type(), elementBytes, nullptr,
98         resultRank, resultExtent,
99         CFI_attribute_allocatable);  // TODO rearrange these arguments
100   }
101   DescriptorAddendum *resultAddendum{result->Addendum()};
102   RUNTIME_CHECK(terminator, resultAddendum);
103   resultAddendum->flags() |= DescriptorAddendum::DoNotFinalize;
104   if (sourceDerivedType) {
105     std::size_t lenParameters{sourceDerivedType->lenParameters()};
106     for (std::size_t j{0}; j < lenParameters; ++j) {
107       resultAddendum->SetLenParameterValue(
108           j, sourceAddendum->LenParameterValue(j));
109     }
110   }
111   // Allocate storage for the result's data.
112   int status{result->Allocate(lowerBound, resultExtent, elementBytes)};
113   if (status != CFI_SUCCESS) {
114     terminator.Crash("RESHAPE: Allocate failed (error %d)", status);
115   }
116 
117   // Populate the result's elements.
118   SubscriptValue resultSubscript[maxRank];
119   result->GetLowerBounds(resultSubscript);
120   SubscriptValue sourceSubscript[maxRank];
121   source.GetLowerBounds(sourceSubscript);
122   std::size_t resultElement{0};
123   std::size_t elementsFromSource{std::min(resultElements, sourceElements)};
124   for (; resultElement < elementsFromSource; ++resultElement) {
125     std::memcpy(result->Element<void>(resultSubscript),
126         source.Element<const void>(sourceSubscript), elementBytes);
127     source.IncrementSubscripts(sourceSubscript);
128     result->IncrementSubscripts(resultSubscript, dimOrder);
129   }
130   if (resultElement < resultElements) {
131     // Remaining elements come from the optional PAD= argument.
132     SubscriptValue padSubscript[maxRank];
133     pad->GetLowerBounds(padSubscript);
134     for (; resultElement < resultElements; ++resultElement) {
135       std::memcpy(result->Element<void>(resultSubscript),
136           pad->Element<const void>(padSubscript), elementBytes);
137       pad->IncrementSubscripts(padSubscript);
138       result->IncrementSubscripts(resultSubscript, dimOrder);
139     }
140   }
141 
142   return result;
143 }
144 }
145