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