File: | build/source/flang/runtime/findloc.cpp |
Warning: | line 98, column 36 The left operand of '-' is a garbage value |
Press '?' to see keyboard shortcuts
Keyboard shortcuts:
1 | //===-- runtime/findloc.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 | // Implements FINDLOC for all required operand types and shapes and result | ||||||
10 | // integer kinds. | ||||||
11 | |||||||
12 | #include "reduction-templates.h" | ||||||
13 | #include "flang/Runtime/character.h" | ||||||
14 | #include "flang/Runtime/reduction.h" | ||||||
15 | #include <cinttypes> | ||||||
16 | #include <complex> | ||||||
17 | |||||||
18 | namespace Fortran::runtime { | ||||||
19 | |||||||
20 | template <TypeCategory CAT1, int KIND1, TypeCategory CAT2, int KIND2> | ||||||
21 | struct Equality { | ||||||
22 | using Type1 = CppTypeFor<CAT1, KIND1>; | ||||||
23 | using Type2 = CppTypeFor<CAT2, KIND2>; | ||||||
24 | bool operator()(const Descriptor &array, const SubscriptValue at[], | ||||||
25 | const Descriptor &target) const { | ||||||
26 | return *array.Element<Type1>(at) == *target.OffsetElement<Type2>(); | ||||||
27 | } | ||||||
28 | }; | ||||||
29 | |||||||
30 | template <int KIND1, int KIND2> | ||||||
31 | struct Equality<TypeCategory::Complex, KIND1, TypeCategory::Complex, KIND2> { | ||||||
32 | using Type1 = CppTypeFor<TypeCategory::Complex, KIND1>; | ||||||
33 | using Type2 = CppTypeFor<TypeCategory::Complex, KIND2>; | ||||||
34 | bool operator()(const Descriptor &array, const SubscriptValue at[], | ||||||
35 | const Descriptor &target) const { | ||||||
36 | const Type1 &xz{*array.Element<Type1>(at)}; | ||||||
37 | const Type2 &tz{*target.OffsetElement<Type2>()}; | ||||||
38 | return xz.real() == tz.real() && xz.imag() == tz.imag(); | ||||||
39 | } | ||||||
40 | }; | ||||||
41 | |||||||
42 | template <int KIND1, TypeCategory CAT2, int KIND2> | ||||||
43 | struct Equality<TypeCategory::Complex, KIND1, CAT2, KIND2> { | ||||||
44 | using Type1 = CppTypeFor<TypeCategory::Complex, KIND1>; | ||||||
45 | using Type2 = CppTypeFor<CAT2, KIND2>; | ||||||
46 | bool operator()(const Descriptor &array, const SubscriptValue at[], | ||||||
47 | const Descriptor &target) const { | ||||||
48 | const Type1 &z{*array.Element<Type1>(at)}; | ||||||
49 | return z.imag() == 0 && z.real() == *target.OffsetElement<Type2>(); | ||||||
50 | } | ||||||
51 | }; | ||||||
52 | |||||||
53 | template <TypeCategory CAT1, int KIND1, int KIND2> | ||||||
54 | struct Equality<CAT1, KIND1, TypeCategory::Complex, KIND2> { | ||||||
55 | using Type1 = CppTypeFor<CAT1, KIND1>; | ||||||
56 | using Type2 = CppTypeFor<TypeCategory::Complex, KIND2>; | ||||||
57 | bool operator()(const Descriptor &array, const SubscriptValue at[], | ||||||
58 | const Descriptor &target) const { | ||||||
59 | const Type2 &z{*target.OffsetElement<Type2>()}; | ||||||
60 | return *array.Element<Type1>(at) == z.real() && z.imag() == 0; | ||||||
61 | } | ||||||
62 | }; | ||||||
63 | |||||||
64 | template <int KIND> struct CharacterEquality { | ||||||
65 | using Type = CppTypeFor<TypeCategory::Character, KIND>; | ||||||
66 | bool operator()(const Descriptor &array, const SubscriptValue at[], | ||||||
67 | const Descriptor &target) const { | ||||||
68 | return CharacterScalarCompare<Type>(array.Element<Type>(at), | ||||||
69 | target.OffsetElement<Type>(), | ||||||
70 | array.ElementBytes() / static_cast<unsigned>(KIND), | ||||||
71 | target.ElementBytes() / static_cast<unsigned>(KIND)) == 0; | ||||||
72 | } | ||||||
73 | }; | ||||||
74 | |||||||
75 | struct LogicalEquivalence { | ||||||
76 | bool operator()(const Descriptor &array, const SubscriptValue at[], | ||||||
77 | const Descriptor &target) const { | ||||||
78 | return IsLogicalElementTrue(array, at) == | ||||||
79 | IsLogicalElementTrue(target, at /*ignored*/); | ||||||
80 | } | ||||||
81 | }; | ||||||
82 | |||||||
83 | template <typename EQUALITY> class LocationAccumulator { | ||||||
84 | public: | ||||||
85 | LocationAccumulator( | ||||||
86 | const Descriptor &array, const Descriptor &target, bool back) | ||||||
87 | : array_{array}, target_{target}, back_{back} { | ||||||
88 | Reinitialize(); | ||||||
89 | } | ||||||
90 | void Reinitialize() { | ||||||
91 | // per standard: result indices are all zero if no data | ||||||
92 | for (int j{0}; j < rank_; ++j) { | ||||||
93 | location_[j] = 0; | ||||||
94 | } | ||||||
95 | } | ||||||
96 | template <typename A> void GetResult(A *p, int zeroBasedDim = -1) { | ||||||
97 | if (zeroBasedDim
| ||||||
98 | *p = location_[zeroBasedDim] - | ||||||
| |||||||
99 | array_.GetDimension(zeroBasedDim).LowerBound() + 1; | ||||||
100 | } else { | ||||||
101 | for (int j{0}; j < rank_; ++j) { | ||||||
102 | p[j] = location_[j] - array_.GetDimension(j).LowerBound() + 1; | ||||||
103 | } | ||||||
104 | } | ||||||
105 | } | ||||||
106 | template <typename IGNORED> bool AccumulateAt(const SubscriptValue at[]) { | ||||||
107 | if (equality_(array_, at, target_)) { | ||||||
108 | for (int j{0}; j < rank_; ++j) { | ||||||
109 | location_[j] = at[j]; | ||||||
110 | } | ||||||
111 | return back_; | ||||||
112 | } else { | ||||||
113 | return true; | ||||||
114 | } | ||||||
115 | } | ||||||
116 | |||||||
117 | private: | ||||||
118 | const Descriptor &array_; | ||||||
119 | const Descriptor &target_; | ||||||
120 | const bool back_{false}; | ||||||
121 | const int rank_{array_.rank()}; | ||||||
122 | SubscriptValue location_[maxRank]; | ||||||
123 | const EQUALITY equality_{}; | ||||||
124 | }; | ||||||
125 | |||||||
126 | template <TypeCategory XCAT, int XKIND, TypeCategory TARGET_CAT> | ||||||
127 | struct TotalNumericFindlocHelper { | ||||||
128 | template <int TARGET_KIND> struct Functor { | ||||||
129 | void operator()(Descriptor &result, const Descriptor &x, | ||||||
130 | const Descriptor &target, int kind, int dim, const Descriptor *mask, | ||||||
131 | bool back, Terminator &terminator) const { | ||||||
132 | using Eq = Equality<XCAT, XKIND, TARGET_CAT, TARGET_KIND>; | ||||||
133 | using Accumulator = LocationAccumulator<Eq>; | ||||||
134 | Accumulator accumulator{x, target, back}; | ||||||
135 | DoTotalReduction<void>(x, dim, mask, accumulator, "FINDLOC", terminator); | ||||||
136 | ApplyIntegerKind<LocationResultHelper<Accumulator>::template Functor, | ||||||
137 | void>(kind, terminator, accumulator, result); | ||||||
138 | } | ||||||
139 | }; | ||||||
140 | }; | ||||||
141 | |||||||
142 | template <TypeCategory CAT, | ||||||
143 | template <TypeCategory XCAT, int XKIND, TypeCategory TARGET_CAT> | ||||||
144 | class HELPER> | ||||||
145 | struct NumericFindlocHelper { | ||||||
146 | template <int KIND> struct Functor { | ||||||
147 | void operator()(TypeCategory targetCat, int targetKind, Descriptor &result, | ||||||
148 | const Descriptor &x, const Descriptor &target, int kind, int dim, | ||||||
149 | const Descriptor *mask, bool back, Terminator &terminator) const { | ||||||
150 | switch (targetCat) { | ||||||
151 | case TypeCategory::Integer: | ||||||
152 | ApplyIntegerKind< | ||||||
153 | HELPER<CAT, KIND, TypeCategory::Integer>::template Functor, void>( | ||||||
154 | targetKind, terminator, result, x, target, kind, dim, mask, back, | ||||||
155 | terminator); | ||||||
156 | break; | ||||||
157 | case TypeCategory::Real: | ||||||
158 | ApplyFloatingPointKind< | ||||||
159 | HELPER<CAT, KIND, TypeCategory::Real>::template Functor, void>( | ||||||
160 | targetKind, terminator, result, x, target, kind, dim, mask, back, | ||||||
161 | terminator); | ||||||
162 | break; | ||||||
163 | case TypeCategory::Complex: | ||||||
164 | ApplyFloatingPointKind< | ||||||
165 | HELPER<CAT, KIND, TypeCategory::Complex>::template Functor, void>( | ||||||
166 | targetKind, terminator, result, x, target, kind, dim, mask, back, | ||||||
167 | terminator); | ||||||
168 | break; | ||||||
169 | default: | ||||||
170 | terminator.Crash( | ||||||
171 | "FINDLOC: bad target category %d for array category %d", | ||||||
172 | static_cast<int>(targetCat), static_cast<int>(CAT)); | ||||||
173 | } | ||||||
174 | } | ||||||
175 | }; | ||||||
176 | }; | ||||||
177 | |||||||
178 | template <int KIND> struct CharacterFindlocHelper { | ||||||
179 | void operator()(Descriptor &result, const Descriptor &x, | ||||||
180 | const Descriptor &target, int kind, const Descriptor *mask, bool back, | ||||||
181 | Terminator &terminator) { | ||||||
182 | using Accumulator = LocationAccumulator<CharacterEquality<KIND>>; | ||||||
183 | Accumulator accumulator{x, target, back}; | ||||||
184 | DoTotalReduction<void>(x, 0, mask, accumulator, "FINDLOC", terminator); | ||||||
185 | ApplyIntegerKind<LocationResultHelper<Accumulator>::template Functor, void>( | ||||||
186 | kind, terminator, accumulator, result); | ||||||
187 | } | ||||||
188 | }; | ||||||
189 | |||||||
190 | static void LogicalFindlocHelper(Descriptor &result, const Descriptor &x, | ||||||
191 | const Descriptor &target, int kind, const Descriptor *mask, bool back, | ||||||
192 | Terminator &terminator) { | ||||||
193 | using Accumulator = LocationAccumulator<LogicalEquivalence>; | ||||||
194 | Accumulator accumulator{x, target, back}; | ||||||
195 | DoTotalReduction<void>(x, 0, mask, accumulator, "FINDLOC", terminator); | ||||||
196 | ApplyIntegerKind<LocationResultHelper<Accumulator>::template Functor, void>( | ||||||
197 | kind, terminator, accumulator, result); | ||||||
198 | } | ||||||
199 | |||||||
200 | extern "C" { | ||||||
201 | void RTNAME(Findloc)_FortranAFindloc(Descriptor &result, const Descriptor &x, | ||||||
202 | const Descriptor &target, int kind, const char *source, int line, | ||||||
203 | const Descriptor *mask, bool back) { | ||||||
204 | int rank{x.rank()}; | ||||||
205 | SubscriptValue extent[1]{rank}; | ||||||
206 | result.Establish(TypeCategory::Integer, kind, nullptr, 1, extent, | ||||||
207 | CFI_attribute_allocatable2); | ||||||
208 | result.GetDimension(0).SetBounds(1, extent[0]); | ||||||
209 | Terminator terminator{source, line}; | ||||||
210 | if (int stat{result.Allocate()}) { | ||||||
211 | terminator.Crash( | ||||||
212 | "FINDLOC: could not allocate memory for result; STAT=%d", stat); | ||||||
213 | } | ||||||
214 | CheckIntegerKind(terminator, kind, "FINDLOC"); | ||||||
215 | auto xType{x.type().GetCategoryAndKind()}; | ||||||
216 | auto targetType{target.type().GetCategoryAndKind()}; | ||||||
217 | RUNTIME_CHECK(terminator, xType.has_value() && targetType.has_value())if (xType.has_value() && targetType.has_value()) ; else (terminator).CheckFailed("xType.has_value() && targetType.has_value()" , "flang/runtime/findloc.cpp", 217); | ||||||
218 | switch (xType->first) { | ||||||
219 | case TypeCategory::Integer: | ||||||
220 | ApplyIntegerKind<NumericFindlocHelper<TypeCategory::Integer, | ||||||
221 | TotalNumericFindlocHelper>::template Functor, | ||||||
222 | void>(xType->second, terminator, targetType->first, targetType->second, | ||||||
223 | result, x, target, kind, 0, mask, back, terminator); | ||||||
224 | break; | ||||||
225 | case TypeCategory::Real: | ||||||
226 | ApplyFloatingPointKind<NumericFindlocHelper<TypeCategory::Real, | ||||||
227 | TotalNumericFindlocHelper>::template Functor, | ||||||
228 | void>(xType->second, terminator, targetType->first, targetType->second, | ||||||
229 | result, x, target, kind, 0, mask, back, terminator); | ||||||
230 | break; | ||||||
231 | case TypeCategory::Complex: | ||||||
232 | ApplyFloatingPointKind<NumericFindlocHelper<TypeCategory::Complex, | ||||||
233 | TotalNumericFindlocHelper>::template Functor, | ||||||
234 | void>(xType->second, terminator, targetType->first, targetType->second, | ||||||
235 | result, x, target, kind, 0, mask, back, terminator); | ||||||
236 | break; | ||||||
237 | case TypeCategory::Character: | ||||||
238 | RUNTIME_CHECK(terminator,if (targetType->first == TypeCategory::Character && targetType->second == xType->second) ; else (terminator ).CheckFailed("targetType->first == TypeCategory::Character && targetType->second == xType->second" , "flang/runtime/findloc.cpp", 240) | ||||||
239 | targetType->first == TypeCategory::Character &&if (targetType->first == TypeCategory::Character && targetType->second == xType->second) ; else (terminator ).CheckFailed("targetType->first == TypeCategory::Character && targetType->second == xType->second" , "flang/runtime/findloc.cpp", 240) | ||||||
240 | targetType->second == xType->second)if (targetType->first == TypeCategory::Character && targetType->second == xType->second) ; else (terminator ).CheckFailed("targetType->first == TypeCategory::Character && targetType->second == xType->second" , "flang/runtime/findloc.cpp", 240); | ||||||
241 | ApplyCharacterKind<CharacterFindlocHelper, void>(xType->second, terminator, | ||||||
242 | result, x, target, kind, mask, back, terminator); | ||||||
243 | break; | ||||||
244 | case TypeCategory::Logical: | ||||||
245 | RUNTIME_CHECK(terminator, targetType->first == TypeCategory::Logical)if (targetType->first == TypeCategory::Logical) ; else (terminator ).CheckFailed("targetType->first == TypeCategory::Logical" , "flang/runtime/findloc.cpp", 245); | ||||||
246 | LogicalFindlocHelper(result, x, target, kind, mask, back, terminator); | ||||||
247 | break; | ||||||
248 | default: | ||||||
249 | terminator.Crash( | ||||||
250 | "FINDLOC: bad data type code (%d) for array", x.type().raw()); | ||||||
251 | } | ||||||
252 | } | ||||||
253 | } // extern "C" | ||||||
254 | |||||||
255 | // FINDLOC with DIM= | ||||||
256 | |||||||
257 | template <TypeCategory XCAT, int XKIND, TypeCategory TARGET_CAT> | ||||||
258 | struct PartialNumericFindlocHelper { | ||||||
259 | template <int TARGET_KIND> struct Functor { | ||||||
260 | void operator()(Descriptor &result, const Descriptor &x, | ||||||
261 | const Descriptor &target, int kind, int dim, const Descriptor *mask, | ||||||
262 | bool back, Terminator &terminator) const { | ||||||
263 | using Eq = Equality<XCAT, XKIND, TARGET_CAT, TARGET_KIND>; | ||||||
264 | using Accumulator = LocationAccumulator<Eq>; | ||||||
265 | Accumulator accumulator{x, target, back}; | ||||||
266 | ApplyIntegerKind<PartialLocationHelper<Accumulator>::template Functor, | ||||||
267 | void>(kind, terminator, result, x, dim, mask, terminator, "FINDLOC", | ||||||
268 | accumulator); | ||||||
269 | } | ||||||
270 | }; | ||||||
271 | }; | ||||||
272 | |||||||
273 | template <int KIND> struct PartialCharacterFindlocHelper { | ||||||
274 | void operator()(Descriptor &result, const Descriptor &x, | ||||||
275 | const Descriptor &target, int kind, int dim, const Descriptor *mask, | ||||||
276 | bool back, Terminator &terminator) { | ||||||
277 | using Accumulator = LocationAccumulator<CharacterEquality<KIND>>; | ||||||
278 | Accumulator accumulator{x, target, back}; | ||||||
279 | ApplyIntegerKind<PartialLocationHelper<Accumulator>::template Functor, | ||||||
280 | void>(kind, terminator, result, x, dim, mask, terminator, "FINDLOC", | ||||||
281 | accumulator); | ||||||
282 | } | ||||||
283 | }; | ||||||
284 | |||||||
285 | static void PartialLogicalFindlocHelper(Descriptor &result, const Descriptor &x, | ||||||
286 | const Descriptor &target, int kind, int dim, const Descriptor *mask, | ||||||
287 | bool back, Terminator &terminator) { | ||||||
288 | using Accumulator = LocationAccumulator<LogicalEquivalence>; | ||||||
289 | Accumulator accumulator{x, target, back}; | ||||||
290 | ApplyIntegerKind<PartialLocationHelper<Accumulator>::template Functor, void>( | ||||||
| |||||||
291 | kind, terminator, result, x, dim, mask, terminator, "FINDLOC", | ||||||
292 | accumulator); | ||||||
293 | } | ||||||
294 | |||||||
295 | extern "C" { | ||||||
296 | void RTNAME(FindlocDim)_FortranAFindlocDim(Descriptor &result, const Descriptor &x, | ||||||
297 | const Descriptor &target, int kind, int dim, const char *source, int line, | ||||||
298 | const Descriptor *mask, bool back) { | ||||||
299 | Terminator terminator{source, line}; | ||||||
300 | CheckIntegerKind(terminator, kind, "FINDLOC"); | ||||||
301 | auto xType{x.type().GetCategoryAndKind()}; | ||||||
302 | auto targetType{target.type().GetCategoryAndKind()}; | ||||||
303 | RUNTIME_CHECK(terminator, xType.has_value() && targetType.has_value())if (xType.has_value() && targetType.has_value()) ; else (terminator).CheckFailed("xType.has_value() && targetType.has_value()" , "flang/runtime/findloc.cpp", 303); | ||||||
| |||||||
304 | switch (xType->first) { | ||||||
305 | case TypeCategory::Integer: | ||||||
306 | ApplyIntegerKind<NumericFindlocHelper<TypeCategory::Integer, | ||||||
307 | PartialNumericFindlocHelper>::template Functor, | ||||||
308 | void>(xType->second, terminator, targetType->first, targetType->second, | ||||||
309 | result, x, target, kind, dim, mask, back, terminator); | ||||||
310 | break; | ||||||
311 | case TypeCategory::Real: | ||||||
312 | ApplyFloatingPointKind<NumericFindlocHelper<TypeCategory::Real, | ||||||
313 | PartialNumericFindlocHelper>::template Functor, | ||||||
314 | void>(xType->second, terminator, targetType->first, targetType->second, | ||||||
315 | result, x, target, kind, dim, mask, back, terminator); | ||||||
316 | break; | ||||||
317 | case TypeCategory::Complex: | ||||||
318 | ApplyFloatingPointKind<NumericFindlocHelper<TypeCategory::Complex, | ||||||
319 | PartialNumericFindlocHelper>::template Functor, | ||||||
320 | void>(xType->second, terminator, targetType->first, targetType->second, | ||||||
321 | result, x, target, kind, dim, mask, back, terminator); | ||||||
322 | break; | ||||||
323 | case TypeCategory::Character: | ||||||
324 | RUNTIME_CHECK(terminator,if (targetType->first == TypeCategory::Character && targetType->second == xType->second) ; else (terminator ).CheckFailed("targetType->first == TypeCategory::Character && targetType->second == xType->second" , "flang/runtime/findloc.cpp", 326) | ||||||
325 | targetType->first == TypeCategory::Character &&if (targetType->first == TypeCategory::Character && targetType->second == xType->second) ; else (terminator ).CheckFailed("targetType->first == TypeCategory::Character && targetType->second == xType->second" , "flang/runtime/findloc.cpp", 326) | ||||||
326 | targetType->second == xType->second)if (targetType->first == TypeCategory::Character && targetType->second == xType->second) ; else (terminator ).CheckFailed("targetType->first == TypeCategory::Character && targetType->second == xType->second" , "flang/runtime/findloc.cpp", 326); | ||||||
327 | ApplyCharacterKind<PartialCharacterFindlocHelper, void>(xType->second, | ||||||
328 | terminator, result, x, target, kind, dim, mask, back, terminator); | ||||||
329 | break; | ||||||
330 | case TypeCategory::Logical: | ||||||
331 | RUNTIME_CHECK(terminator, targetType->first == TypeCategory::Logical)if (targetType->first == TypeCategory::Logical) ; else (terminator ).CheckFailed("targetType->first == TypeCategory::Logical" , "flang/runtime/findloc.cpp", 331); | ||||||
332 | PartialLogicalFindlocHelper( | ||||||
333 | result, x, target, kind, dim, mask, back, terminator); | ||||||
334 | break; | ||||||
335 | default: | ||||||
336 | terminator.Crash( | ||||||
337 | "FINDLOC: bad data type code (%d) for array", x.type().raw()); | ||||||
338 | } | ||||||
339 | } | ||||||
340 | } // extern "C" | ||||||
341 | } // namespace Fortran::runtime |
1 | //===-- runtime/tools.h -----------------------------------------*- C++ -*-===// |
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 | #ifndef FORTRAN_RUNTIME_TOOLS_H_ |
10 | #define FORTRAN_RUNTIME_TOOLS_H_ |
11 | |
12 | #include "terminator.h" |
13 | #include "flang/Runtime/cpp-type.h" |
14 | #include "flang/Runtime/descriptor.h" |
15 | #include "flang/Runtime/memory.h" |
16 | #include <cstring> |
17 | #include <functional> |
18 | #include <map> |
19 | #include <type_traits> |
20 | |
21 | namespace Fortran::runtime { |
22 | |
23 | class Terminator; |
24 | |
25 | std::size_t TrimTrailingSpaces(const char *, std::size_t); |
26 | |
27 | OwningPtr<char> SaveDefaultCharacter( |
28 | const char *, std::size_t, const Terminator &); |
29 | |
30 | // For validating and recognizing default CHARACTER values in a |
31 | // case-insensitive manner. Returns the zero-based index into the |
32 | // null-terminated array of upper-case possibilities when the value is valid, |
33 | // or -1 when it has no match. |
34 | int IdentifyValue( |
35 | const char *value, std::size_t length, const char *possibilities[]); |
36 | |
37 | // Truncates or pads as necessary |
38 | void ToFortranDefaultCharacter( |
39 | char *to, std::size_t toLength, const char *from); |
40 | |
41 | // Utility for dealing with elemental LOGICAL arguments |
42 | inline bool IsLogicalElementTrue( |
43 | const Descriptor &logical, const SubscriptValue at[]) { |
44 | // A LOGICAL value is false if and only if all of its bytes are zero. |
45 | const char *p{logical.Element<char>(at)}; |
46 | for (std::size_t j{logical.ElementBytes()}; j-- > 0; ++p) { |
47 | if (*p) { |
48 | return true; |
49 | } |
50 | } |
51 | return false; |
52 | } |
53 | |
54 | // Check array conformability; a scalar 'x' conforms. Crashes on error. |
55 | void CheckConformability(const Descriptor &to, const Descriptor &x, |
56 | Terminator &, const char *funcName, const char *toName, |
57 | const char *fromName); |
58 | |
59 | // Helper to store integer value in result[at]. |
60 | template <int KIND> struct StoreIntegerAt { |
61 | void operator()(const Fortran::runtime::Descriptor &result, std::size_t at, |
62 | std::int64_t value) const { |
63 | *result.ZeroBasedIndexedElement<Fortran::runtime::CppTypeFor< |
64 | Fortran::common::TypeCategory::Integer, KIND>>(at) = value; |
65 | } |
66 | }; |
67 | |
68 | // Validate a KIND= argument |
69 | void CheckIntegerKind(Terminator &, int kind, const char *intrinsic); |
70 | |
71 | template <typename TO, typename FROM> |
72 | inline void PutContiguousConverted(TO *to, FROM *from, std::size_t count) { |
73 | while (count-- > 0) { |
74 | *to++ = *from++; |
75 | } |
76 | } |
77 | |
78 | static inline std::int64_t GetInt64( |
79 | const char *p, std::size_t bytes, Terminator &terminator) { |
80 | switch (bytes) { |
81 | case 1: |
82 | return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 1> *>(p); |
83 | case 2: |
84 | return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 2> *>(p); |
85 | case 4: |
86 | return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 4> *>(p); |
87 | case 8: |
88 | return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 8> *>(p); |
89 | default: |
90 | terminator.Crash("GetInt64: no case for %zd bytes", bytes); |
91 | } |
92 | } |
93 | |
94 | template <typename INT> |
95 | inline bool SetInteger(INT &x, int kind, std::int64_t value) { |
96 | switch (kind) { |
97 | case 1: |
98 | reinterpret_cast<CppTypeFor<TypeCategory::Integer, 1> &>(x) = value; |
99 | return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 1> &>(x); |
100 | case 2: |
101 | reinterpret_cast<CppTypeFor<TypeCategory::Integer, 2> &>(x) = value; |
102 | return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 2> &>(x); |
103 | case 4: |
104 | reinterpret_cast<CppTypeFor<TypeCategory::Integer, 4> &>(x) = value; |
105 | return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 4> &>(x); |
106 | case 8: |
107 | reinterpret_cast<CppTypeFor<TypeCategory::Integer, 8> &>(x) = value; |
108 | return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 8> &>(x); |
109 | default: |
110 | return false; |
111 | } |
112 | } |
113 | |
114 | // Maps intrinsic runtime type category and kind values to the appropriate |
115 | // instantiation of a function object template and calls it with the supplied |
116 | // arguments. |
117 | template <template <TypeCategory, int> class FUNC, typename RESULT, |
118 | typename... A> |
119 | inline RESULT ApplyType( |
120 | TypeCategory cat, int kind, Terminator &terminator, A &&...x) { |
121 | switch (cat) { |
122 | case TypeCategory::Integer: |
123 | switch (kind) { |
124 | case 1: |
125 | return FUNC<TypeCategory::Integer, 1>{}(std::forward<A>(x)...); |
126 | case 2: |
127 | return FUNC<TypeCategory::Integer, 2>{}(std::forward<A>(x)...); |
128 | case 4: |
129 | return FUNC<TypeCategory::Integer, 4>{}(std::forward<A>(x)...); |
130 | case 8: |
131 | return FUNC<TypeCategory::Integer, 8>{}(std::forward<A>(x)...); |
132 | #ifdef __SIZEOF_INT128__16 |
133 | case 16: |
134 | return FUNC<TypeCategory::Integer, 16>{}(std::forward<A>(x)...); |
135 | #endif |
136 | default: |
137 | terminator.Crash("not yet implemented: INTEGER(KIND=%d)", kind); |
138 | } |
139 | case TypeCategory::Real: |
140 | switch (kind) { |
141 | #if 0 // TODO: REAL(2 & 3) |
142 | case 2: |
143 | return FUNC<TypeCategory::Real, 2>{}(std::forward<A>(x)...); |
144 | case 3: |
145 | return FUNC<TypeCategory::Real, 3>{}(std::forward<A>(x)...); |
146 | #endif |
147 | case 4: |
148 | return FUNC<TypeCategory::Real, 4>{}(std::forward<A>(x)...); |
149 | case 8: |
150 | return FUNC<TypeCategory::Real, 8>{}(std::forward<A>(x)...); |
151 | case 10: |
152 | if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) { |
153 | return FUNC<TypeCategory::Real, 10>{}(std::forward<A>(x)...); |
154 | } |
155 | break; |
156 | case 16: |
157 | if constexpr (HasCppTypeFor<TypeCategory::Real, 16>) { |
158 | return FUNC<TypeCategory::Real, 16>{}(std::forward<A>(x)...); |
159 | } |
160 | break; |
161 | } |
162 | terminator.Crash("not yet implemented: REAL(KIND=%d)", kind); |
163 | case TypeCategory::Complex: |
164 | switch (kind) { |
165 | #if 0 // TODO: COMPLEX(2 & 3) |
166 | case 2: |
167 | return FUNC<TypeCategory::Complex, 2>{}(std::forward<A>(x)...); |
168 | case 3: |
169 | return FUNC<TypeCategory::Complex, 3>{}(std::forward<A>(x)...); |
170 | #endif |
171 | case 4: |
172 | return FUNC<TypeCategory::Complex, 4>{}(std::forward<A>(x)...); |
173 | case 8: |
174 | return FUNC<TypeCategory::Complex, 8>{}(std::forward<A>(x)...); |
175 | case 10: |
176 | if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) { |
177 | return FUNC<TypeCategory::Complex, 10>{}(std::forward<A>(x)...); |
178 | } |
179 | break; |
180 | case 16: |
181 | if constexpr (HasCppTypeFor<TypeCategory::Real, 16>) { |
182 | return FUNC<TypeCategory::Complex, 16>{}(std::forward<A>(x)...); |
183 | } |
184 | break; |
185 | } |
186 | terminator.Crash("not yet implemented: COMPLEX(KIND=%d)", kind); |
187 | case TypeCategory::Character: |
188 | switch (kind) { |
189 | case 1: |
190 | return FUNC<TypeCategory::Character, 1>{}(std::forward<A>(x)...); |
191 | case 2: |
192 | return FUNC<TypeCategory::Character, 2>{}(std::forward<A>(x)...); |
193 | case 4: |
194 | return FUNC<TypeCategory::Character, 4>{}(std::forward<A>(x)...); |
195 | default: |
196 | terminator.Crash("not yet implemented: CHARACTER(KIND=%d)", kind); |
197 | } |
198 | case TypeCategory::Logical: |
199 | switch (kind) { |
200 | case 1: |
201 | return FUNC<TypeCategory::Logical, 1>{}(std::forward<A>(x)...); |
202 | case 2: |
203 | return FUNC<TypeCategory::Logical, 2>{}(std::forward<A>(x)...); |
204 | case 4: |
205 | return FUNC<TypeCategory::Logical, 4>{}(std::forward<A>(x)...); |
206 | case 8: |
207 | return FUNC<TypeCategory::Logical, 8>{}(std::forward<A>(x)...); |
208 | default: |
209 | terminator.Crash("not yet implemented: LOGICAL(KIND=%d)", kind); |
210 | } |
211 | default: |
212 | terminator.Crash( |
213 | "not yet implemented: type category(%d)", static_cast<int>(cat)); |
214 | } |
215 | } |
216 | |
217 | // Maps a runtime INTEGER kind value to the appropriate instantiation of |
218 | // a function object template and calls it with the supplied arguments. |
219 | template <template <int KIND> class FUNC, typename RESULT, typename... A> |
220 | inline RESULT ApplyIntegerKind(int kind, Terminator &terminator, A &&...x) { |
221 | switch (kind) { |
222 | case 1: |
223 | return FUNC<1>{}(std::forward<A>(x)...); |
224 | case 2: |
225 | return FUNC<2>{}(std::forward<A>(x)...); |
226 | case 4: |
227 | return FUNC<4>{}(std::forward<A>(x)...); |
228 | case 8: |
229 | return FUNC<8>{}(std::forward<A>(x)...); |
230 | #ifdef __SIZEOF_INT128__16 |
231 | case 16: |
232 | return FUNC<16>{}(std::forward<A>(x)...); |
233 | #endif |
234 | default: |
235 | terminator.Crash("not yet implemented: INTEGER(KIND=%d)", kind); |
236 | } |
237 | } |
238 | |
239 | template <template <int KIND> class FUNC, typename RESULT, typename... A> |
240 | inline RESULT ApplyFloatingPointKind( |
241 | int kind, Terminator &terminator, A &&...x) { |
242 | switch (kind) { |
243 | #if 0 // TODO: REAL/COMPLEX (2 & 3) |
244 | case 2: |
245 | return FUNC<2>{}(std::forward<A>(x)...); |
246 | case 3: |
247 | return FUNC<3>{}(std::forward<A>(x)...); |
248 | #endif |
249 | case 4: |
250 | return FUNC<4>{}(std::forward<A>(x)...); |
251 | case 8: |
252 | return FUNC<8>{}(std::forward<A>(x)...); |
253 | case 10: |
254 | if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) { |
255 | return FUNC<10>{}(std::forward<A>(x)...); |
256 | } |
257 | break; |
258 | case 16: |
259 | if constexpr (HasCppTypeFor<TypeCategory::Real, 16>) { |
260 | return FUNC<16>{}(std::forward<A>(x)...); |
261 | } |
262 | break; |
263 | } |
264 | terminator.Crash("not yet implemented: REAL/COMPLEX(KIND=%d)", kind); |
265 | } |
266 | |
267 | template <template <int KIND> class FUNC, typename RESULT, typename... A> |
268 | inline RESULT ApplyCharacterKind(int kind, Terminator &terminator, A &&...x) { |
269 | switch (kind) { |
270 | case 1: |
271 | return FUNC<1>{}(std::forward<A>(x)...); |
272 | case 2: |
273 | return FUNC<2>{}(std::forward<A>(x)...); |
274 | case 4: |
275 | return FUNC<4>{}(std::forward<A>(x)...); |
276 | default: |
277 | terminator.Crash("not yet implemented: CHARACTER(KIND=%d)", kind); |
278 | } |
279 | } |
280 | |
281 | template <template <int KIND> class FUNC, typename RESULT, typename... A> |
282 | inline RESULT ApplyLogicalKind(int kind, Terminator &terminator, A &&...x) { |
283 | switch (kind) { |
284 | case 1: |
285 | return FUNC<1>{}(std::forward<A>(x)...); |
286 | case 2: |
287 | return FUNC<2>{}(std::forward<A>(x)...); |
288 | case 4: |
289 | return FUNC<4>{}(std::forward<A>(x)...); |
290 | case 8: |
291 | return FUNC<8>{}(std::forward<A>(x)...); |
292 | default: |
293 | terminator.Crash("not yet implemented: LOGICAL(KIND=%d)", kind); |
294 | } |
295 | } |
296 | |
297 | // Calculate result type of (X op Y) for *, //, DOT_PRODUCT, &c. |
298 | std::optional<std::pair<TypeCategory, int>> inline constexpr GetResultType( |
299 | TypeCategory xCat, int xKind, TypeCategory yCat, int yKind) { |
300 | int maxKind{std::max(xKind, yKind)}; |
301 | switch (xCat) { |
302 | case TypeCategory::Integer: |
303 | switch (yCat) { |
304 | case TypeCategory::Integer: |
305 | return std::make_pair(TypeCategory::Integer, maxKind); |
306 | case TypeCategory::Real: |
307 | case TypeCategory::Complex: |
308 | return std::make_pair(yCat, yKind); |
309 | default: |
310 | break; |
311 | } |
312 | break; |
313 | case TypeCategory::Real: |
314 | switch (yCat) { |
315 | case TypeCategory::Integer: |
316 | return std::make_pair(TypeCategory::Real, xKind); |
317 | case TypeCategory::Real: |
318 | case TypeCategory::Complex: |
319 | return std::make_pair(yCat, maxKind); |
320 | default: |
321 | break; |
322 | } |
323 | break; |
324 | case TypeCategory::Complex: |
325 | switch (yCat) { |
326 | case TypeCategory::Integer: |
327 | return std::make_pair(TypeCategory::Complex, xKind); |
328 | case TypeCategory::Real: |
329 | case TypeCategory::Complex: |
330 | return std::make_pair(TypeCategory::Complex, maxKind); |
331 | default: |
332 | break; |
333 | } |
334 | break; |
335 | case TypeCategory::Character: |
336 | if (yCat == TypeCategory::Character) { |
337 | return std::make_pair(TypeCategory::Character, maxKind); |
338 | } else { |
339 | return std::nullopt; |
340 | } |
341 | case TypeCategory::Logical: |
342 | if (yCat == TypeCategory::Logical) { |
343 | return std::make_pair(TypeCategory::Logical, maxKind); |
344 | } else { |
345 | return std::nullopt; |
346 | } |
347 | default: |
348 | break; |
349 | } |
350 | return std::nullopt; |
351 | } |
352 | |
353 | // Accumulate floating-point results in (at least) double precision |
354 | template <TypeCategory CAT, int KIND> |
355 | using AccumulationType = CppTypeFor<CAT, |
356 | CAT == TypeCategory::Real || CAT == TypeCategory::Complex |
357 | ? std::max(KIND, static_cast<int>(sizeof(double))) |
358 | : KIND>; |
359 | |
360 | // memchr() for any character type |
361 | template <typename CHAR> |
362 | static inline const CHAR *FindCharacter( |
363 | const CHAR *data, CHAR ch, std::size_t chars) { |
364 | const CHAR *end{data + chars}; |
365 | for (const CHAR *p{data}; p < end; ++p) { |
366 | if (*p == ch) { |
367 | return p; |
368 | } |
369 | } |
370 | return nullptr; |
371 | } |
372 | |
373 | template <> |
374 | inline const char *FindCharacter(const char *data, char ch, std::size_t chars) { |
375 | return reinterpret_cast<const char *>( |
376 | std::memchr(data, static_cast<int>(ch), chars)); |
377 | } |
378 | |
379 | } // namespace Fortran::runtime |
380 | #endif // FORTRAN_RUNTIME_TOOLS_H_ |
1 | //===-- runtime/reduction-templates.h -------------------------------------===// |
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 | // Generic function templates used by various reduction transformation |
10 | // intrinsic functions (SUM, PRODUCT, &c.) |
11 | // |
12 | // * Partial reductions (i.e., those with DIM= arguments that are not |
13 | // required to be 1 by the rank of the argument) return arrays that |
14 | // are dynamically allocated in a caller-supplied descriptor. |
15 | // * Total reductions (i.e., no DIM= argument) with FINDLOC, MAXLOC, & MINLOC |
16 | // return integer vectors of some kind, not scalars; a caller-supplied |
17 | // descriptor is used |
18 | // * Character-valued reductions (MAXVAL & MINVAL) return arbitrary |
19 | // length results, dynamically allocated in a caller-supplied descriptor |
20 | |
21 | #ifndef FORTRAN_RUNTIME_REDUCTION_TEMPLATES_H_ |
22 | #define FORTRAN_RUNTIME_REDUCTION_TEMPLATES_H_ |
23 | |
24 | #include "terminator.h" |
25 | #include "tools.h" |
26 | #include "flang/Runtime/cpp-type.h" |
27 | #include "flang/Runtime/descriptor.h" |
28 | |
29 | namespace Fortran::runtime { |
30 | |
31 | // Reductions are implemented with *accumulators*, which are instances of |
32 | // classes that incrementally build up the result (or an element thereof) during |
33 | // a traversal of the unmasked elements of an array. Each accumulator class |
34 | // supports a constructor (which captures a reference to the array), an |
35 | // AccumulateAt() member function that applies supplied subscripts to the |
36 | // array and does something with a scalar element, and a GetResult() |
37 | // member function that copies a final result into its destination. |
38 | |
39 | // Total reduction of the array argument to a scalar (or to a vector in the |
40 | // cases of FINDLOC, MAXLOC, & MINLOC). These are the cases without DIM= or |
41 | // cases where the argument has rank 1 and DIM=, if present, must be 1. |
42 | template <typename TYPE, typename ACCUMULATOR> |
43 | inline void DoTotalReduction(const Descriptor &x, int dim, |
44 | const Descriptor *mask, ACCUMULATOR &accumulator, const char *intrinsic, |
45 | Terminator &terminator) { |
46 | if (dim < 0 || dim > 1) { |
47 | terminator.Crash("%s: bad DIM=%d for ARRAY argument with rank %d", |
48 | intrinsic, dim, x.rank()); |
49 | } |
50 | SubscriptValue xAt[maxRank]; |
51 | x.GetLowerBounds(xAt); |
52 | if (mask) { |
53 | CheckConformability(x, *mask, terminator, intrinsic, "ARRAY", "MASK"); |
54 | SubscriptValue maskAt[maxRank]; |
55 | mask->GetLowerBounds(maskAt); |
56 | if (mask->rank() > 0) { |
57 | for (auto elements{x.Elements()}; elements--; |
58 | x.IncrementSubscripts(xAt), mask->IncrementSubscripts(maskAt)) { |
59 | if (IsLogicalElementTrue(*mask, maskAt)) { |
60 | if (!accumulator.template AccumulateAt<TYPE>(xAt)) |
61 | break; |
62 | } |
63 | } |
64 | return; |
65 | } else if (!IsLogicalElementTrue(*mask, maskAt)) { |
66 | // scalar MASK=.FALSE.: return identity value |
67 | return; |
68 | } |
69 | } |
70 | // No MASK=, or scalar MASK=.TRUE. |
71 | for (auto elements{x.Elements()}; elements--; x.IncrementSubscripts(xAt)) { |
72 | if (!accumulator.template AccumulateAt<TYPE>(xAt)) { |
73 | break; // cut short, result is known |
74 | } |
75 | } |
76 | } |
77 | |
78 | template <TypeCategory CAT, int KIND, typename ACCUMULATOR> |
79 | inline CppTypeFor<CAT, KIND> GetTotalReduction(const Descriptor &x, |
80 | const char *source, int line, int dim, const Descriptor *mask, |
81 | ACCUMULATOR &&accumulator, const char *intrinsic) { |
82 | Terminator terminator{source, line}; |
83 | RUNTIME_CHECK(terminator, TypeCode(CAT, KIND) == x.type())if (TypeCode(CAT, KIND) == x.type()) ; else (terminator).CheckFailed ("TypeCode(CAT, KIND) == x.type()", "flang/runtime/reduction-templates.h" , 83); |
84 | using CppType = CppTypeFor<CAT, KIND>; |
85 | DoTotalReduction<CppType>(x, dim, mask, accumulator, intrinsic, terminator); |
86 | CppType result; |
87 | #ifdef _MSC_VER // work around MSVC spurious error |
88 | accumulator.GetResult(&result); |
89 | #else |
90 | accumulator.template GetResult(&result); |
91 | #endif |
92 | return result; |
93 | } |
94 | |
95 | // For reductions on a dimension, e.g. SUM(array,DIM=2) where the shape |
96 | // of the array is [2,3,5], the shape of the result is [2,5] and |
97 | // result(j,k) = SUM(array(j,:,k)), possibly modified if the array has |
98 | // lower bounds other than one. This utility subroutine creates an |
99 | // array of subscripts [j,_,k] for result subscripts [j,k] so that the |
100 | // elements of array(j,:,k) can be reduced. |
101 | inline void GetExpandedSubscripts(SubscriptValue at[], |
102 | const Descriptor &descriptor, int zeroBasedDim, |
103 | const SubscriptValue from[]) { |
104 | descriptor.GetLowerBounds(at); |
105 | int rank{descriptor.rank()}; |
106 | int j{0}; |
107 | for (; j < zeroBasedDim; ++j) { |
108 | at[j] += from[j] - 1 /*lower bound*/; |
109 | } |
110 | for (++j; j < rank; ++j) { |
111 | at[j] += from[j - 1] - 1; |
112 | } |
113 | } |
114 | |
115 | template <typename TYPE, typename ACCUMULATOR> |
116 | inline void ReduceDimToScalar(const Descriptor &x, int zeroBasedDim, |
117 | SubscriptValue subscripts[], TYPE *result, ACCUMULATOR &accumulator) { |
118 | SubscriptValue xAt[maxRank]; |
119 | GetExpandedSubscripts(xAt, x, zeroBasedDim, subscripts); |
120 | const auto &dim{x.GetDimension(zeroBasedDim)}; |
121 | SubscriptValue at{dim.LowerBound()}; |
122 | for (auto n{dim.Extent()}; n-- > 0; ++at) { |
123 | xAt[zeroBasedDim] = at; |
124 | if (!accumulator.template AccumulateAt<TYPE>(xAt)) { |
125 | break; |
126 | } |
127 | } |
128 | #ifdef _MSC_VER // work around MSVC spurious error |
129 | accumulator.GetResult(result, zeroBasedDim); |
130 | #else |
131 | accumulator.template GetResult(result, zeroBasedDim); |
132 | #endif |
133 | } |
134 | |
135 | template <typename TYPE, typename ACCUMULATOR> |
136 | inline void ReduceDimMaskToScalar(const Descriptor &x, int zeroBasedDim, |
137 | SubscriptValue subscripts[], const Descriptor &mask, TYPE *result, |
138 | ACCUMULATOR &accumulator) { |
139 | SubscriptValue xAt[maxRank], maskAt[maxRank]; |
140 | GetExpandedSubscripts(xAt, x, zeroBasedDim, subscripts); |
141 | GetExpandedSubscripts(maskAt, mask, zeroBasedDim, subscripts); |
142 | const auto &xDim{x.GetDimension(zeroBasedDim)}; |
143 | SubscriptValue xPos{xDim.LowerBound()}; |
144 | const auto &maskDim{mask.GetDimension(zeroBasedDim)}; |
145 | SubscriptValue maskPos{maskDim.LowerBound()}; |
146 | for (auto n{x.GetDimension(zeroBasedDim).Extent()}; n-- > 0; |
147 | ++xPos, ++maskPos) { |
148 | maskAt[zeroBasedDim] = maskPos; |
149 | if (IsLogicalElementTrue(mask, maskAt)) { |
150 | xAt[zeroBasedDim] = xPos; |
151 | if (!accumulator.template AccumulateAt<TYPE>(xAt)) { |
152 | break; |
153 | } |
154 | } |
155 | } |
156 | #ifdef _MSC_VER // work around MSVC spurious error |
157 | accumulator.GetResult(result, zeroBasedDim); |
158 | #else |
159 | accumulator.template GetResult(result, zeroBasedDim); |
160 | #endif |
161 | } |
162 | |
163 | // Utility: establishes & allocates the result array for a partial |
164 | // reduction (i.e., one with DIM=). |
165 | static void CreatePartialReductionResult(Descriptor &result, |
166 | const Descriptor &x, std::size_t resultElementSize, int dim, |
167 | Terminator &terminator, const char *intrinsic, TypeCode typeCode) { |
168 | int xRank{x.rank()}; |
169 | if (dim < 1 || dim > xRank) { |
170 | terminator.Crash( |
171 | "%s: bad DIM=%d for ARRAY with rank %d", intrinsic, dim, xRank); |
172 | } |
173 | int zeroBasedDim{dim - 1}; |
174 | SubscriptValue resultExtent[maxRank]; |
175 | for (int j{0}; j < zeroBasedDim; ++j) { |
176 | resultExtent[j] = x.GetDimension(j).Extent(); |
177 | } |
178 | for (int j{zeroBasedDim + 1}; j < xRank; ++j) { |
179 | resultExtent[j - 1] = x.GetDimension(j).Extent(); |
180 | } |
181 | result.Establish(typeCode, resultElementSize, nullptr, xRank - 1, |
182 | resultExtent, CFI_attribute_allocatable2); |
183 | for (int j{0}; j + 1 < xRank; ++j) { |
184 | result.GetDimension(j).SetBounds(1, resultExtent[j]); |
185 | } |
186 | if (int stat{result.Allocate()}) { |
187 | terminator.Crash( |
188 | "%s: could not allocate memory for result; STAT=%d", intrinsic, stat); |
189 | } |
190 | } |
191 | |
192 | // Partial reductions with DIM= |
193 | |
194 | template <typename ACCUMULATOR, TypeCategory CAT, int KIND> |
195 | inline void PartialReduction(Descriptor &result, const Descriptor &x, |
196 | std::size_t resultElementSize, int dim, const Descriptor *mask, |
197 | Terminator &terminator, const char *intrinsic, ACCUMULATOR &accumulator) { |
198 | CreatePartialReductionResult(result, x, resultElementSize, dim, terminator, |
199 | intrinsic, TypeCode{CAT, KIND}); |
200 | SubscriptValue at[maxRank]; |
201 | result.GetLowerBounds(at); |
202 | INTERNAL_CHECK(result.rank() == 0 || at[0] == 1)if (result.rank() == 0 || at[0] == 1) ; else Terminator{"flang/runtime/reduction-templates.h" , 202}.CheckFailed("result.rank() == 0 || at[0] == 1"); |
203 | using CppType = CppTypeFor<CAT, KIND>; |
204 | if (mask) { |
205 | CheckConformability(x, *mask, terminator, intrinsic, "ARRAY", "MASK"); |
206 | SubscriptValue maskAt[maxRank]; // contents unused |
207 | if (mask->rank() > 0) { |
208 | for (auto n{result.Elements()}; n-- > 0; result.IncrementSubscripts(at)) { |
209 | accumulator.Reinitialize(); |
210 | ReduceDimMaskToScalar<CppType, ACCUMULATOR>( |
211 | x, dim - 1, at, *mask, result.Element<CppType>(at), accumulator); |
212 | } |
213 | return; |
214 | } else if (!IsLogicalElementTrue(*mask, maskAt)) { |
215 | // scalar MASK=.FALSE. |
216 | accumulator.Reinitialize(); |
217 | for (auto n{result.Elements()}; n-- > 0; result.IncrementSubscripts(at)) { |
218 | accumulator.GetResult(result.Element<CppType>(at)); |
219 | } |
220 | return; |
221 | } |
222 | } |
223 | // No MASK= or scalar MASK=.TRUE. |
224 | for (auto n{result.Elements()}; n-- > 0; result.IncrementSubscripts(at)) { |
225 | accumulator.Reinitialize(); |
226 | ReduceDimToScalar<CppType, ACCUMULATOR>( |
227 | x, dim - 1, at, result.Element<CppType>(at), accumulator); |
228 | } |
229 | } |
230 | |
231 | template <template <typename> class ACCUM> |
232 | struct PartialIntegerReductionHelper { |
233 | template <int KIND> struct Functor { |
234 | static constexpr int Intermediate{ |
235 | std::max(KIND, 4)}; // use at least "int" for intermediate results |
236 | void operator()(Descriptor &result, const Descriptor &x, int dim, |
237 | const Descriptor *mask, Terminator &terminator, |
238 | const char *intrinsic) const { |
239 | using Accumulator = |
240 | ACCUM<CppTypeFor<TypeCategory::Integer, Intermediate>>; |
241 | Accumulator accumulator{x}; |
242 | // Element size of the destination descriptor is the same |
243 | // as the element size of the source. |
244 | PartialReduction<Accumulator, TypeCategory::Integer, KIND>(result, x, |
245 | x.ElementBytes(), dim, mask, terminator, intrinsic, accumulator); |
246 | } |
247 | }; |
248 | }; |
249 | |
250 | template <template <typename> class INTEGER_ACCUM> |
251 | inline void PartialIntegerReduction(Descriptor &result, const Descriptor &x, |
252 | int dim, int kind, const Descriptor *mask, const char *intrinsic, |
253 | Terminator &terminator) { |
254 | ApplyIntegerKind< |
255 | PartialIntegerReductionHelper<INTEGER_ACCUM>::template Functor, void>( |
256 | kind, terminator, result, x, dim, mask, terminator, intrinsic); |
257 | } |
258 | |
259 | template <TypeCategory CAT, template <typename> class ACCUM> |
260 | struct PartialFloatingReductionHelper { |
261 | template <int KIND> struct Functor { |
262 | static constexpr int Intermediate{ |
263 | std::max(KIND, 8)}; // use at least "double" for intermediate results |
264 | void operator()(Descriptor &result, const Descriptor &x, int dim, |
265 | const Descriptor *mask, Terminator &terminator, |
266 | const char *intrinsic) const { |
267 | using Accumulator = ACCUM<CppTypeFor<TypeCategory::Real, Intermediate>>; |
268 | Accumulator accumulator{x}; |
269 | // Element size of the destination descriptor is the same |
270 | // as the element size of the source. |
271 | PartialReduction<Accumulator, CAT, KIND>(result, x, x.ElementBytes(), dim, |
272 | mask, terminator, intrinsic, accumulator); |
273 | } |
274 | }; |
275 | }; |
276 | |
277 | template <template <typename> class INTEGER_ACCUM, |
278 | template <typename> class REAL_ACCUM, |
279 | template <typename> class COMPLEX_ACCUM> |
280 | inline void TypedPartialNumericReduction(Descriptor &result, |
281 | const Descriptor &x, int dim, const char *source, int line, |
282 | const Descriptor *mask, const char *intrinsic) { |
283 | Terminator terminator{source, line}; |
284 | auto catKind{x.type().GetCategoryAndKind()}; |
285 | RUNTIME_CHECK(terminator, catKind.has_value())if (catKind.has_value()) ; else (terminator).CheckFailed("catKind.has_value()" , "flang/runtime/reduction-templates.h", 285); |
286 | switch (catKind->first) { |
287 | case TypeCategory::Integer: |
288 | PartialIntegerReduction<INTEGER_ACCUM>( |
289 | result, x, dim, catKind->second, mask, intrinsic, terminator); |
290 | break; |
291 | case TypeCategory::Real: |
292 | ApplyFloatingPointKind<PartialFloatingReductionHelper<TypeCategory::Real, |
293 | REAL_ACCUM>::template Functor, |
294 | void>(catKind->second, terminator, result, x, dim, mask, terminator, |
295 | intrinsic); |
296 | break; |
297 | case TypeCategory::Complex: |
298 | ApplyFloatingPointKind<PartialFloatingReductionHelper<TypeCategory::Complex, |
299 | COMPLEX_ACCUM>::template Functor, |
300 | void>(catKind->second, terminator, result, x, dim, mask, terminator, |
301 | intrinsic); |
302 | break; |
303 | default: |
304 | terminator.Crash("%s: bad type code %d", intrinsic, x.type().raw()); |
305 | } |
306 | } |
307 | |
308 | template <typename ACCUMULATOR> struct LocationResultHelper { |
309 | template <int KIND> struct Functor { |
310 | void operator()(ACCUMULATOR &accumulator, const Descriptor &result) const { |
311 | accumulator.GetResult( |
312 | result.OffsetElement<CppTypeFor<TypeCategory::Integer, KIND>>()); |
313 | } |
314 | }; |
315 | }; |
316 | |
317 | template <typename ACCUMULATOR> struct PartialLocationHelper { |
318 | template <int KIND> struct Functor { |
319 | void operator()(Descriptor &result, const Descriptor &x, int dim, |
320 | const Descriptor *mask, Terminator &terminator, const char *intrinsic, |
321 | ACCUMULATOR &accumulator) const { |
322 | // Element size of the destination descriptor is the size |
323 | // of {TypeCategory::Integer, KIND}. |
324 | PartialReduction<ACCUMULATOR, TypeCategory::Integer, KIND>(result, x, |
325 | Descriptor::BytesFor(TypeCategory::Integer, KIND), dim, mask, |
326 | terminator, intrinsic, accumulator); |
327 | } |
328 | }; |
329 | }; |
330 | |
331 | } // namespace Fortran::runtime |
332 | #endif // FORTRAN_RUNTIME_REDUCTION_TEMPLATES_H_ |