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