Bug Summary

File:build/source/flang/runtime/extrema.cpp
Warning:line 87, column 5
Dereference of null pointer

Annotated Source Code

Press '?' to see keyboard shortcuts

clang -cc1 -cc1 -triple x86_64-pc-linux-gnu -analyze -disable-free -clear-ast-before-backend -disable-llvm-verifier -discard-value-names -main-file-name extrema.cpp -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=cplusplus -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -analyzer-config-compatibility-mode=true -mrelocation-model pic -pic-level 2 -mframe-pointer=none -relaxed-aliasing -fmath-errno -ffp-contract=on -fno-rounding-math -mconstructor-aliases -funwind-tables=2 -target-cpu x86-64 -tune-cpu generic -debugger-tuning=gdb -ffunction-sections -fdata-sections -fcoverage-compilation-dir=/build/source/build-llvm/tools/clang/stage2-bins -resource-dir /usr/lib/llvm-17/lib/clang/17 -isystem /build/source/llvm/../mlir/include -isystem tools/mlir/include -isystem tools/clang/include -isystem /build/source/llvm/../clang/include -D FLANG_INCLUDE_TESTS=1 -D FLANG_LITTLE_ENDIAN=1 -D FLANG_VENDOR="Debian " -D _DEBUG -D _GLIBCXX_ASSERTIONS -D _GNU_SOURCE -D _LIBCPP_ENABLE_ASSERTIONS -D __STDC_CONSTANT_MACROS -D __STDC_FORMAT_MACROS -D __STDC_LIMIT_MACROS -I tools/flang/runtime -I /build/source/flang/runtime -I /build/source/flang/include -I tools/flang/include -I include -I /build/source/llvm/include -D _FORTIFY_SOURCE=2 -D NDEBUG -U _GLIBCXX_ASSERTIONS -U _LIBCPP_ENABLE_ASSERTIONS -U NDEBUG -internal-isystem /usr/lib/gcc/x86_64-linux-gnu/10/../../../../include/c++/10 -internal-isystem /usr/lib/gcc/x86_64-linux-gnu/10/../../../../include/x86_64-linux-gnu/c++/10 -internal-isystem /usr/lib/gcc/x86_64-linux-gnu/10/../../../../include/c++/10/backward -internal-isystem /usr/lib/llvm-17/lib/clang/17/include -internal-isystem /usr/local/include -internal-isystem /usr/lib/gcc/x86_64-linux-gnu/10/../../../../x86_64-linux-gnu/include -internal-externc-isystem /usr/include/x86_64-linux-gnu -internal-externc-isystem /include -internal-externc-isystem /usr/include -fmacro-prefix-map=/build/source/build-llvm/tools/clang/stage2-bins=build-llvm/tools/clang/stage2-bins -fmacro-prefix-map=/build/source/= -fcoverage-prefix-map=/build/source/build-llvm/tools/clang/stage2-bins=build-llvm/tools/clang/stage2-bins -fcoverage-prefix-map=/build/source/= -source-date-epoch 1683717183 -O2 -Wno-unused-command-line-argument -Wno-unused-parameter -Wwrite-strings -Wno-missing-field-initializers -Wno-long-long -Wno-maybe-uninitialized -Wno-class-memaccess -Wno-redundant-move -Wno-pessimizing-move -Wno-noexcept-type -Wno-comment -Wno-misleading-indentation -Wno-deprecated-copy -Wno-ctad-maybe-unsupported -std=c++17 -fdeprecated-macro -fdebug-compilation-dir=/build/source/build-llvm/tools/clang/stage2-bins -fdebug-prefix-map=/build/source/build-llvm/tools/clang/stage2-bins=build-llvm/tools/clang/stage2-bins -fdebug-prefix-map=/build/source/= -ferror-limit 19 -fvisibility-inlines-hidden -stack-protector 2 -fgnuc-version=4.2.1 -fcolor-diagnostics -vectorize-loops -vectorize-slp -analyzer-output=html -analyzer-config stable-report-filename=true -faddrsig -D__GCC_HAVE_DWARF2_CFI_ASM=1 -o /tmp/scan-build-2023-05-10-133810-16478-1 -x c++ /build/source/flang/runtime/extrema.cpp

/build/source/flang/runtime/extrema.cpp

→
1//===-- runtime/extrema.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 MAXLOC, MINLOC, MAXVAL, & MINVAL for all required operand types
10// and shapes and (for MAXLOC & MINLOC) result integer kinds. Also implements
11// NORM2 using common infrastructure.
12
13#include "reduction-templates.h"
14#include "flang/Runtime/character.h"
15#include "flang/Runtime/float128.h"
16#include "flang/Runtime/reduction.h"
17#include <algorithm>
18#include <cfloat>
19#include <cinttypes>
20#include <cmath>
21#include <optional>
22
23namespace Fortran::runtime {
24
25// MAXLOC & MINLOC
26
27template <typename T, bool IS_MAX, bool BACK> struct NumericCompare {
28 using Type = T;
29 explicit NumericCompare(std::size_t /*elemLen; ignored*/) {}
30 bool operator()(const T &value, const T &previous) const {
31 if (value == previous) {
32 return BACK;
33 } else if constexpr (IS_MAX) {
34 return value > previous;
35 } else {
36 return value < previous;
37 }
38 }
39};
40
41template <typename T, bool IS_MAX, bool BACK> class CharacterCompare {
42public:
43 using Type = T;
44 explicit CharacterCompare(std::size_t elemLen)
45 : chars_{elemLen / sizeof(T)} {}
46 bool operator()(const T &value, const T &previous) const {
47 int cmp{CharacterScalarCompare<T>(&value, &previous, chars_, chars_)};
48 if (cmp == 0) {
49 return BACK;
50 } else if constexpr (IS_MAX) {
51 return cmp > 0;
52 } else {
53 return cmp < 0;
54 }
55 }
56
57private:
58 std::size_t chars_;
59};
60
61template <typename COMPARE> class ExtremumLocAccumulator {
62public:
63 using Type = typename COMPARE::Type;
64 ExtremumLocAccumulator(const Descriptor &array)
65 : array_{array}, argRank_{array.rank()}, compare_{array.ElementBytes()} {
66 Reinitialize();
67 }
68 void Reinitialize() {
69 // per standard: result indices are all zero if no data
70 for (int j{0}; j < argRank_; ++j) {
71 extremumLoc_[j] = 0;
72 }
73 previous_ = nullptr;
74 }
75 int argRank() const { return argRank_; }
76 template <typename A> void GetResult(A *p, int zeroBasedDim = -1) {
77 if (zeroBasedDim >= 0) {
78 *p = extremumLoc_[zeroBasedDim] -
79 array_.GetDimension(zeroBasedDim).LowerBound() + 1;
80 } else {
81 for (int j{0}; j < argRank_; ++j) {
82 p[j] = extremumLoc_[j] - array_.GetDimension(j).LowerBound() + 1;
83 }
84 }
85 }
86 template <typename IGNORED> bool AccumulateAt(const SubscriptValue at[]) {
87 const auto &value{*array_.Element<Type>(at)};
24
←
Dereference of null pointer
88 if (!previous_ || compare_(value, *previous_)) {
89 previous_ = &value;
90 for (int j{0}; j < argRank_; ++j) {
91 extremumLoc_[j] = at[j];
92 }
93 }
94 return true;
95 }
96
97private:
98 const Descriptor &array_;
99 int argRank_;
100 SubscriptValue extremumLoc_[maxRank];
101 const Type *previous_{nullptr};
102 COMPARE compare_;
103};
104
105template <typename ACCUMULATOR, typename CPPTYPE>
106static void LocationHelper(const char *intrinsic, Descriptor &result,
107 const Descriptor &x, int kind, const Descriptor *mask,
108 Terminator &terminator) {
109 ACCUMULATOR accumulator{x};
110 DoTotalReduction<CPPTYPE>(x, 0, mask, accumulator, intrinsic, terminator);
14
←
Calling 'DoTotalReduction<char, Fortran::runtime::ExtremumLocAccumulator<Fortran::runtime::NumericCompare<char, false, false>>>'
→
111 ApplyIntegerKind<LocationResultHelper<ACCUMULATOR>::template Functor, void>(
112 kind, terminator, accumulator, result);
113}
114
115template <TypeCategory CAT, int KIND, bool IS_MAX,
116 template <typename, bool, bool> class COMPARE>
117inline void DoMaxOrMinLoc(const char *intrinsic, Descriptor &result,
118 const Descriptor &x, int kind, const char *source, int line,
119 const Descriptor *mask, bool back) {
120 using CppType = CppTypeFor<CAT, KIND>;
121 Terminator terminator{source, line};
122 if (back) {
11
←
Assuming 'back' is false
→
12
←
Taking false branch
→
123 LocationHelper<ExtremumLocAccumulator<COMPARE<CppType, IS_MAX, true>>,
124 CppType>(intrinsic, result, x, kind, mask, terminator);
125 } else {
126 LocationHelper<ExtremumLocAccumulator<COMPARE<CppType, IS_MAX, false>>,
13
←
Calling 'LocationHelper<Fortran::runtime::ExtremumLocAccumulator<Fortran::runtime::NumericCompare<char, false, false>>, char>'
→
127 CppType>(intrinsic, result, x, kind, mask, terminator);
128 }
129}
130
131template <bool IS_MAX> struct CharacterMaxOrMinLocHelper {
132 template <int KIND> struct Functor {
133 void operator()(const char *intrinsic, Descriptor &result,
134 const Descriptor &x, int kind, const char *source, int line,
135 const Descriptor *mask, bool back) const {
136 DoMaxOrMinLoc<TypeCategory::Character, KIND, IS_MAX, NumericCompare>(
10
←
Calling 'DoMaxOrMinLoc<Fortran::common::TypeCategory::Character, 1, false, Fortran::runtime::NumericCompare>'
→
137 intrinsic, result, x, kind, source, line, mask, back);
138 }
139 };
140};
141
142template <bool IS_MAX>
143inline void CharacterMaxOrMinLoc(const char *intrinsic, Descriptor &result,
144 const Descriptor &x, int kind, const char *source, int line,
145 const Descriptor *mask, bool back) {
146 int rank{x.rank()};
147 SubscriptValue extent[1]{rank};
148 result.Establish(TypeCategory::Integer, kind, nullptr, 1, extent,
149 CFI_attribute_allocatable2);
150 result.GetDimension(0).SetBounds(1, extent[0]);
151 Terminator terminator{source, line};
152 if (int stat{result.Allocate()}) {
2
←
Assuming 'stat' is 0
→
3
←
Taking false branch
→
153 terminator.Crash(
154 "%s: could not allocate memory for result; STAT=%d", intrinsic, stat);
155 }
156 CheckIntegerKind(terminator, kind, intrinsic);
157 auto catKind{x.type().GetCategoryAndKind()};
158 RUNTIME_CHECK(terminator, catKind.has_value())if (catKind.has_value()) ; else (terminator).CheckFailed("catKind.has_value()"
, "flang/runtime/extrema.cpp", 158);
4
←
Assuming the condition is true
→
5
←
Taking true branch
→
159 switch (catKind->first) {
6
←
Control jumps to 'case Character:' at line 160
→
160 case TypeCategory::Character:
161 ApplyCharacterKind<CharacterMaxOrMinLocHelper<IS_MAX>::template Functor,
7
←
Calling 'ApplyCharacterKind<Fortran::runtime::CharacterMaxOrMinLocHelper<false>::Functor, void, const char *&, Fortran::runtime::Descriptor &, const Fortran::runtime::Descriptor &, int &, const char *&, int &, const Fortran::runtime::Descriptor *&, bool &>'
→
162 void>(catKind->second, terminator, intrinsic, result, x, kind, source,
163 line, mask, back);
164 break;
165 default:
166 terminator.Crash(
167 "%s: bad data type code (%d) for array", intrinsic, x.type().raw());
168 }
169}
170
171template <TypeCategory CAT, int KIND, bool IS_MAXVAL>
172inline void TotalNumericMaxOrMinLoc(const char *intrinsic, Descriptor &result,
173 const Descriptor &x, int kind, const char *source, int line,
174 const Descriptor *mask, bool back) {
175 int rank{x.rank()};
176 SubscriptValue extent[1]{rank};
177 result.Establish(TypeCategory::Integer, kind, nullptr, 1, extent,
178 CFI_attribute_allocatable2);
179 result.GetDimension(0).SetBounds(1, extent[0]);
180 Terminator terminator{source, line};
181 if (int stat{result.Allocate()}) {
182 terminator.Crash(
183 "%s: could not allocate memory for result; STAT=%d", intrinsic, stat);
184 }
185 CheckIntegerKind(terminator, kind, intrinsic);
186 RUNTIME_CHECK(terminator, TypeCode(CAT, KIND) == x.type())if (TypeCode(CAT, KIND) == x.type()) ; else (terminator).CheckFailed
("TypeCode(CAT, KIND) == x.type()", "flang/runtime/extrema.cpp"
, 186);
187 DoMaxOrMinLoc<CAT, KIND, IS_MAXVAL, NumericCompare>(
188 intrinsic, result, x, kind, source, line, mask, back);
189}
190
191extern "C" {
192void RTNAME(MaxlocCharacter)_FortranAMaxlocCharacter(Descriptor &result, const Descriptor &x, int kind,
193 const char *source, int line, const Descriptor *mask, bool back) {
194 CharacterMaxOrMinLoc<true>(
195 "MAXLOC", result, x, kind, source, line, mask, back);
196}
197void RTNAME(MaxlocInteger1)_FortranAMaxlocInteger1(Descriptor &result, const Descriptor &x, int kind,
198 const char *source, int line, const Descriptor *mask, bool back) {
199 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 1, true>(
200 "MAXLOC", result, x, kind, source, line, mask, back);
201}
202void RTNAME(MaxlocInteger2)_FortranAMaxlocInteger2(Descriptor &result, const Descriptor &x, int kind,
203 const char *source, int line, const Descriptor *mask, bool back) {
204 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 2, true>(
205 "MAXLOC", result, x, kind, source, line, mask, back);
206}
207void RTNAME(MaxlocInteger4)_FortranAMaxlocInteger4(Descriptor &result, const Descriptor &x, int kind,
208 const char *source, int line, const Descriptor *mask, bool back) {
209 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 4, true>(
210 "MAXLOC", result, x, kind, source, line, mask, back);
211}
212void RTNAME(MaxlocInteger8)_FortranAMaxlocInteger8(Descriptor &result, const Descriptor &x, int kind,
213 const char *source, int line, const Descriptor *mask, bool back) {
214 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 8, true>(
215 "MAXLOC", result, x, kind, source, line, mask, back);
216}
217#ifdef __SIZEOF_INT128__16
218void RTNAME(MaxlocInteger16)_FortranAMaxlocInteger16(Descriptor &result, const Descriptor &x, int kind,
219 const char *source, int line, const Descriptor *mask, bool back) {
220 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 16, true>(
221 "MAXLOC", result, x, kind, source, line, mask, back);
222}
223#endif
224void RTNAME(MaxlocReal4)_FortranAMaxlocReal4(Descriptor &result, const Descriptor &x, int kind,
225 const char *source, int line, const Descriptor *mask, bool back) {
226 TotalNumericMaxOrMinLoc<TypeCategory::Real, 4, true>(
227 "MAXLOC", result, x, kind, source, line, mask, back);
228}
229void RTNAME(MaxlocReal8)_FortranAMaxlocReal8(Descriptor &result, const Descriptor &x, int kind,
230 const char *source, int line, const Descriptor *mask, bool back) {
231 TotalNumericMaxOrMinLoc<TypeCategory::Real, 8, true>(
232 "MAXLOC", result, x, kind, source, line, mask, back);
233}
234#if LDBL_MANT_DIG64 == 64
235void RTNAME(MaxlocReal10)_FortranAMaxlocReal10(Descriptor &result, const Descriptor &x, int kind,
236 const char *source, int line, const Descriptor *mask, bool back) {
237 TotalNumericMaxOrMinLoc<TypeCategory::Real, 10, true>(
238 "MAXLOC", result, x, kind, source, line, mask, back);
239}
240#endif
241#if LDBL_MANT_DIG64 == 113 || HAS_FLOAT1281
242void RTNAME(MaxlocReal16)_FortranAMaxlocReal16(Descriptor &result, const Descriptor &x, int kind,
243 const char *source, int line, const Descriptor *mask, bool back) {
244 TotalNumericMaxOrMinLoc<TypeCategory::Real, 16, true>(
245 "MAXLOC", result, x, kind, source, line, mask, back);
246}
247#endif
248void RTNAME(MinlocCharacter)_FortranAMinlocCharacter(Descriptor &result, const Descriptor &x, int kind,
249 const char *source, int line, const Descriptor *mask, bool back) {
250 CharacterMaxOrMinLoc<false>(
1
Calling 'CharacterMaxOrMinLoc<false>'
→
251 "MINLOC", result, x, kind, source, line, mask, back);
252}
253void RTNAME(MinlocInteger1)_FortranAMinlocInteger1(Descriptor &result, const Descriptor &x, int kind,
254 const char *source, int line, const Descriptor *mask, bool back) {
255 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 1, false>(
256 "MINLOC", result, x, kind, source, line, mask, back);
257}
258void RTNAME(MinlocInteger2)_FortranAMinlocInteger2(Descriptor &result, const Descriptor &x, int kind,
259 const char *source, int line, const Descriptor *mask, bool back) {
260 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 2, false>(
261 "MINLOC", result, x, kind, source, line, mask, back);
262}
263void RTNAME(MinlocInteger4)_FortranAMinlocInteger4(Descriptor &result, const Descriptor &x, int kind,
264 const char *source, int line, const Descriptor *mask, bool back) {
265 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 4, false>(
266 "MINLOC", result, x, kind, source, line, mask, back);
267}
268void RTNAME(MinlocInteger8)_FortranAMinlocInteger8(Descriptor &result, const Descriptor &x, int kind,
269 const char *source, int line, const Descriptor *mask, bool back) {
270 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 8, false>(
271 "MINLOC", result, x, kind, source, line, mask, back);
272}
273#ifdef __SIZEOF_INT128__16
274void RTNAME(MinlocInteger16)_FortranAMinlocInteger16(Descriptor &result, const Descriptor &x, int kind,
275 const char *source, int line, const Descriptor *mask, bool back) {
276 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 16, false>(
277 "MINLOC", result, x, kind, source, line, mask, back);
278}
279#endif
280void RTNAME(MinlocReal4)_FortranAMinlocReal4(Descriptor &result, const Descriptor &x, int kind,
281 const char *source, int line, const Descriptor *mask, bool back) {
282 TotalNumericMaxOrMinLoc<TypeCategory::Real, 4, false>(
283 "MINLOC", result, x, kind, source, line, mask, back);
284}
285void RTNAME(MinlocReal8)_FortranAMinlocReal8(Descriptor &result, const Descriptor &x, int kind,
286 const char *source, int line, const Descriptor *mask, bool back) {
287 TotalNumericMaxOrMinLoc<TypeCategory::Real, 8, false>(
288 "MINLOC", result, x, kind, source, line, mask, back);
289}
290#if LDBL_MANT_DIG64 == 64
291void RTNAME(MinlocReal10)_FortranAMinlocReal10(Descriptor &result, const Descriptor &x, int kind,
292 const char *source, int line, const Descriptor *mask, bool back) {
293 TotalNumericMaxOrMinLoc<TypeCategory::Real, 10, false>(
294 "MINLOC", result, x, kind, source, line, mask, back);
295}
296#endif
297#if LDBL_MANT_DIG64 == 113 || HAS_FLOAT1281
298void RTNAME(MinlocReal16)_FortranAMinlocReal16(Descriptor &result, const Descriptor &x, int kind,
299 const char *source, int line, const Descriptor *mask, bool back) {
300 TotalNumericMaxOrMinLoc<TypeCategory::Real, 16, false>(
301 "MINLOC", result, x, kind, source, line, mask, back);
302}
303#endif
304} // extern "C"
305
306// MAXLOC/MINLOC with DIM=
307
308template <TypeCategory CAT, int KIND, bool IS_MAX,
309 template <typename, bool, bool> class COMPARE, bool BACK>
310static void DoPartialMaxOrMinLocDirection(const char *intrinsic,
311 Descriptor &result, const Descriptor &x, int kind, int dim,
312 const Descriptor *mask, Terminator &terminator) {
313 using CppType = CppTypeFor<CAT, KIND>;
314 using Accumulator = ExtremumLocAccumulator<COMPARE<CppType, IS_MAX, BACK>>;
315 Accumulator accumulator{x};
316 ApplyIntegerKind<PartialLocationHelper<Accumulator>::template Functor, void>(
317 kind, terminator, result, x, dim, mask, terminator, intrinsic,
318 accumulator);
319}
320
321template <TypeCategory CAT, int KIND, bool IS_MAX,
322 template <typename, bool, bool> class COMPARE>
323inline void DoPartialMaxOrMinLoc(const char *intrinsic, Descriptor &result,
324 const Descriptor &x, int kind, int dim, const Descriptor *mask, bool back,
325 Terminator &terminator) {
326 if (back) {
327 DoPartialMaxOrMinLocDirection<CAT, KIND, IS_MAX, COMPARE, true>(
328 intrinsic, result, x, kind, dim, mask, terminator);
329 } else {
330 DoPartialMaxOrMinLocDirection<CAT, KIND, IS_MAX, COMPARE, false>(
331 intrinsic, result, x, kind, dim, mask, terminator);
332 }
333}
334
335template <TypeCategory CAT, bool IS_MAX,
336 template <typename, bool, bool> class COMPARE>
337struct DoPartialMaxOrMinLocHelper {
338 template <int KIND> struct Functor {
339 void operator()(const char *intrinsic, Descriptor &result,
340 const Descriptor &x, int kind, int dim, const Descriptor *mask,
341 bool back, Terminator &terminator) const {
342 DoPartialMaxOrMinLoc<CAT, KIND, IS_MAX, COMPARE>(
343 intrinsic, result, x, kind, dim, mask, back, terminator);
344 }
345 };
346};
347
348template <bool IS_MAX>
349inline void TypedPartialMaxOrMinLoc(const char *intrinsic, Descriptor &result,
350 const Descriptor &x, int kind, int dim, const char *source, int line,
351 const Descriptor *mask, bool back) {
352 Terminator terminator{source, line};
353 CheckIntegerKind(terminator, kind, intrinsic);
354 auto catKind{x.type().GetCategoryAndKind()};
355 RUNTIME_CHECK(terminator, catKind.has_value())if (catKind.has_value()) ; else (terminator).CheckFailed("catKind.has_value()"
, "flang/runtime/extrema.cpp", 355);
356 const Descriptor *maskToUse{mask};
357 SubscriptValue maskAt[maxRank]; // contents unused
358 if (mask && mask->rank() == 0) {
359 if (IsLogicalElementTrue(*mask, maskAt)) {
360 // A scalar MASK that's .TRUE. In this case, just get rid of the MASK.
361 maskToUse = nullptr;
362 } else {
363 // For scalar MASK arguments that are .FALSE., return all zeroes
364
365 // Element size of the destination descriptor is the size
366 // of {TypeCategory::Integer, kind}.
367 CreatePartialReductionResult(result, x,
368 Descriptor::BytesFor(TypeCategory::Integer, kind), dim, terminator,
369 intrinsic, TypeCode{TypeCategory::Integer, kind});
370 std::memset(
371 result.OffsetElement(), 0, result.Elements() * result.ElementBytes());
372 return;
373 }
374 }
375 switch (catKind->first) {
376 case TypeCategory::Integer:
377 ApplyIntegerKind<DoPartialMaxOrMinLocHelper<TypeCategory::Integer, IS_MAX,
378 NumericCompare>::template Functor,
379 void>(catKind->second, terminator, intrinsic, result, x, kind, dim,
380 maskToUse, back, terminator);
381 break;
382 case TypeCategory::Real:
383 ApplyFloatingPointKind<DoPartialMaxOrMinLocHelper<TypeCategory::Real,
384 IS_MAX, NumericCompare>::template Functor,
385 void>(catKind->second, terminator, intrinsic, result, x, kind, dim,
386 maskToUse, back, terminator);
387 break;
388 case TypeCategory::Character:
389 ApplyCharacterKind<DoPartialMaxOrMinLocHelper<TypeCategory::Character,
390 IS_MAX, CharacterCompare>::template Functor,
391 void>(catKind->second, terminator, intrinsic, result, x, kind, dim,
392 maskToUse, back, terminator);
393 break;
394 default:
395 terminator.Crash(
396 "%s: bad data type code (%d) for array", intrinsic, x.type().raw());
397 }
398}
399
400extern "C" {
401void RTNAME(MaxlocDim)_FortranAMaxlocDim(Descriptor &result, const Descriptor &x, int kind,
402 int dim, const char *source, int line, const Descriptor *mask, bool back) {
403 TypedPartialMaxOrMinLoc<true>(
404 "MAXLOC", result, x, kind, dim, source, line, mask, back);
405}
406void RTNAME(MinlocDim)_FortranAMinlocDim(Descriptor &result, const Descriptor &x, int kind,
407 int dim, const char *source, int line, const Descriptor *mask, bool back) {
408 TypedPartialMaxOrMinLoc<false>(
409 "MINLOC", result, x, kind, dim, source, line, mask, back);
410}
411} // extern "C"
412
413// MAXVAL and MINVAL
414
415template <TypeCategory CAT, int KIND, bool IS_MAXVAL, typename Enable = void>
416struct MaxOrMinIdentity {
417 using Type = CppTypeFor<CAT, KIND>;
418 static constexpr Type Value() {
419 return IS_MAXVAL ? std::numeric_limits<Type>::lowest()
420 : std::numeric_limits<Type>::max();
421 }
422};
423
424// std::numeric_limits<> may not know int128_t
425template <bool IS_MAXVAL>
426struct MaxOrMinIdentity<TypeCategory::Integer, 16, IS_MAXVAL> {
427 using Type = CppTypeFor<TypeCategory::Integer, 16>;
428 static constexpr Type Value() {
429 return IS_MAXVAL ? Type{1} << 127 : ~Type{0} >> 1;
430 }
431};
432
433#if HAS_FLOAT1281
434// std::numeric_limits<> may not support __float128.
435//
436// Usage of GCC quadmath.h's FLT128_MAX is complicated by the fact that
437// even GCC complains about 'Q' literal suffix under -Wpedantic.
438// We just recreate FLT128_MAX ourselves.
439//
440// This specialization must engage only when
441// CppTypeFor<TypeCategory::Real, 16> is __float128.
442template <bool IS_MAXVAL>
443struct MaxOrMinIdentity<TypeCategory::Real, 16, IS_MAXVAL,
444 typename std::enable_if_t<
445 std::is_same_v<CppTypeFor<TypeCategory::Real, 16>, __float128>>> {
446 using Type = __float128;
447 static Type Value() {
448 // Create a buffer to store binary representation of __float128 constant.
449 constexpr std::size_t alignment =
450 std::max(alignof(Type), alignof(std::uint64_t));
451 alignas(alignment) char data[sizeof(Type)];
452
453 // First, verify that our interpretation of __float128 format is correct,
454 // e.g. by checking at least one known constant.
455 *reinterpret_cast<Type *>(data) = Type(1.0);
456 if (*reinterpret_cast<std::uint64_t *>(data) != 0 ||
457 *(reinterpret_cast<std::uint64_t *>(data) + 1) != 0x3FFF000000000000) {
458 Terminator terminator{__FILE__"flang/runtime/extrema.cpp", __LINE__458};
459 terminator.Crash("not yet implemented: no full support for __float128");
460 }
461
462 // Recreate FLT128_MAX.
463 *reinterpret_cast<std::uint64_t *>(data) = 0xFFFFFFFFFFFFFFFF;
464 *(reinterpret_cast<std::uint64_t *>(data) + 1) = 0x7FFEFFFFFFFFFFFF;
465 Type max = *reinterpret_cast<Type *>(data);
466 return IS_MAXVAL ? -max : max;
467 }
468};
469#endif // HAS_FLOAT128
470
471template <TypeCategory CAT, int KIND, bool IS_MAXVAL>
472class NumericExtremumAccumulator {
473public:
474 using Type = CppTypeFor<CAT, KIND>;
475 explicit NumericExtremumAccumulator(const Descriptor &array)
476 : array_{array} {}
477 void Reinitialize() {
478 extremum_ = MaxOrMinIdentity<CAT, KIND, IS_MAXVAL>::Value();
479 }
480 template <typename A> void GetResult(A *p, int /*zeroBasedDim*/ = -1) const {
481 *p = extremum_;
482 }
483 bool Accumulate(Type x) {
484 if constexpr (IS_MAXVAL) {
485 if (x > extremum_) {
486 extremum_ = x;
487 }
488 } else if (x < extremum_) {
489 extremum_ = x;
490 }
491 return true;
492 }
493 template <typename A> bool AccumulateAt(const SubscriptValue at[]) {
494 return Accumulate(*array_.Element<A>(at));
495 }
496
497private:
498 const Descriptor &array_;
499 Type extremum_{MaxOrMinIdentity<CAT, KIND, IS_MAXVAL>::Value()};
500};
501
502template <TypeCategory CAT, int KIND, bool IS_MAXVAL>
503inline CppTypeFor<CAT, KIND> TotalNumericMaxOrMin(const Descriptor &x,
504 const char *source, int line, int dim, const Descriptor *mask,
505 const char *intrinsic) {
506 return GetTotalReduction<CAT, KIND>(x, source, line, dim, mask,
507 NumericExtremumAccumulator<CAT, KIND, IS_MAXVAL>{x}, intrinsic);
508}
509
510template <TypeCategory CAT, int KIND, typename ACCUMULATOR>
511static void DoMaxMinNorm2(Descriptor &result, const Descriptor &x, int dim,
512 const Descriptor *mask, const char *intrinsic, Terminator &terminator) {
513 using Type = CppTypeFor<CAT, KIND>;
514 ACCUMULATOR accumulator{x};
515 if (dim == 0 || x.rank() == 1) {
516 // Total reduction
517
518 // Element size of the destination descriptor is the same
519 // as the element size of the source.
520 result.Establish(x.type(), x.ElementBytes(), nullptr, 0, nullptr,
521 CFI_attribute_allocatable2);
522 if (int stat{result.Allocate()}) {
523 terminator.Crash(
524 "%s: could not allocate memory for result; STAT=%d", intrinsic, stat);
525 }
526 DoTotalReduction<Type>(x, dim, mask, accumulator, intrinsic, terminator);
527 accumulator.GetResult(result.OffsetElement<Type>());
528 } else {
529 // Partial reduction
530
531 // Element size of the destination descriptor is the same
532 // as the element size of the source.
533 PartialReduction<ACCUMULATOR, CAT, KIND>(result, x, x.ElementBytes(), dim,
534 mask, terminator, intrinsic, accumulator);
535 }
536}
537
538template <TypeCategory CAT, bool IS_MAXVAL> struct MaxOrMinHelper {
539 template <int KIND> struct Functor {
540 void operator()(Descriptor &result, const Descriptor &x, int dim,
541 const Descriptor *mask, const char *intrinsic,
542 Terminator &terminator) const {
543 DoMaxMinNorm2<CAT, KIND,
544 NumericExtremumAccumulator<CAT, KIND, IS_MAXVAL>>(
545 result, x, dim, mask, intrinsic, terminator);
546 }
547 };
548};
549
550template <bool IS_MAXVAL>
551inline void NumericMaxOrMin(Descriptor &result, const Descriptor &x, int dim,
552 const char *source, int line, const Descriptor *mask,
553 const char *intrinsic) {
554 Terminator terminator{source, line};
555 auto type{x.type().GetCategoryAndKind()};
556 RUNTIME_CHECK(terminator, type)if (type) ; else (terminator).CheckFailed("type", "flang/runtime/extrema.cpp"
, 556);
557 switch (type->first) {
558 case TypeCategory::Integer:
559 ApplyIntegerKind<
560 MaxOrMinHelper<TypeCategory::Integer, IS_MAXVAL>::template Functor,
561 void>(
562 type->second, terminator, result, x, dim, mask, intrinsic, terminator);
563 break;
564 case TypeCategory::Real:
565 ApplyFloatingPointKind<
566 MaxOrMinHelper<TypeCategory::Real, IS_MAXVAL>::template Functor, void>(
567 type->second, terminator, result, x, dim, mask, intrinsic, terminator);
568 break;
569 default:
570 terminator.Crash("%s: bad type code %d", intrinsic, x.type().raw());
571 }
572}
573
574template <int KIND, bool IS_MAXVAL> class CharacterExtremumAccumulator {
575public:
576 using Type = CppTypeFor<TypeCategory::Character, KIND>;
577 explicit CharacterExtremumAccumulator(const Descriptor &array)
578 : array_{array}, charLen_{array_.ElementBytes() / KIND} {}
579 void Reinitialize() { extremum_ = nullptr; }
580 template <typename A> void GetResult(A *p, int /*zeroBasedDim*/ = -1) const {
581 static_assert(std::is_same_v<A, Type>);
582 std::size_t byteSize{array_.ElementBytes()};
583 if (extremum_) {
584 std::memcpy(p, extremum_, byteSize);
585 } else {
586 // Empty array; fill with character 0 for MAXVAL.
587 // For MINVAL, fill with 127 if ASCII as required
588 // by the standard, otherwise set all of the bits.
589 std::memset(p, IS_MAXVAL ? 0 : KIND == 1 ? 127 : 255, byteSize);
590 }
591 }
592 bool Accumulate(const Type *x) {
593 if (!extremum_) {
594 extremum_ = x;
595 } else {
596 int cmp{CharacterScalarCompare(x, extremum_, charLen_, charLen_)};
597 if (IS_MAXVAL == (cmp > 0)) {
598 extremum_ = x;
599 }
600 }
601 return true;
602 }
603 template <typename A> bool AccumulateAt(const SubscriptValue at[]) {
604 return Accumulate(array_.Element<A>(at));
605 }
606
607private:
608 const Descriptor &array_;
609 std::size_t charLen_;
610 const Type *extremum_{nullptr};
611};
612
613template <bool IS_MAXVAL> struct CharacterMaxOrMinHelper {
614 template <int KIND> struct Functor {
615 void operator()(Descriptor &result, const Descriptor &x, int dim,
616 const Descriptor *mask, const char *intrinsic,
617 Terminator &terminator) const {
618 DoMaxMinNorm2<TypeCategory::Character, KIND,
619 CharacterExtremumAccumulator<KIND, IS_MAXVAL>>(
620 result, x, dim, mask, intrinsic, terminator);
621 }
622 };
623};
624
625template <bool IS_MAXVAL>
626inline void CharacterMaxOrMin(Descriptor &result, const Descriptor &x, int dim,
627 const char *source, int line, const Descriptor *mask,
628 const char *intrinsic) {
629 Terminator terminator{source, line};
630 auto type{x.type().GetCategoryAndKind()};
631 RUNTIME_CHECK(terminator, type && type->first == TypeCategory::Character)if (type && type->first == TypeCategory::Character
) ; else (terminator).CheckFailed("type && type->first == TypeCategory::Character"
, "flang/runtime/extrema.cpp", 631);
632 ApplyCharacterKind<CharacterMaxOrMinHelper<IS_MAXVAL>::template Functor,
633 void>(
634 type->second, terminator, result, x, dim, mask, intrinsic, terminator);
635}
636
637extern "C" {
638CppTypeFor<TypeCategory::Integer, 1> RTNAME(MaxvalInteger1)_FortranAMaxvalInteger1(const Descriptor &x,
639 const char *source, int line, int dim, const Descriptor *mask) {
640 return TotalNumericMaxOrMin<TypeCategory::Integer, 1, true>(
641 x, source, line, dim, mask, "MAXVAL");
642}
643CppTypeFor<TypeCategory::Integer, 2> RTNAME(MaxvalInteger2)_FortranAMaxvalInteger2(const Descriptor &x,
644 const char *source, int line, int dim, const Descriptor *mask) {
645 return TotalNumericMaxOrMin<TypeCategory::Integer, 2, true>(
646 x, source, line, dim, mask, "MAXVAL");
647}
648CppTypeFor<TypeCategory::Integer, 4> RTNAME(MaxvalInteger4)_FortranAMaxvalInteger4(const Descriptor &x,
649 const char *source, int line, int dim, const Descriptor *mask) {
650 return TotalNumericMaxOrMin<TypeCategory::Integer, 4, true>(
651 x, source, line, dim, mask, "MAXVAL");
652}
653CppTypeFor<TypeCategory::Integer, 8> RTNAME(MaxvalInteger8)_FortranAMaxvalInteger8(const Descriptor &x,
654 const char *source, int line, int dim, const Descriptor *mask) {
655 return TotalNumericMaxOrMin<TypeCategory::Integer, 8, true>(
656 x, source, line, dim, mask, "MAXVAL");
657}
658#ifdef __SIZEOF_INT128__16
659CppTypeFor<TypeCategory::Integer, 16> RTNAME(MaxvalInteger16)_FortranAMaxvalInteger16(
660 const Descriptor &x, const char *source, int line, int dim,
661 const Descriptor *mask) {
662 return TotalNumericMaxOrMin<TypeCategory::Integer, 16, true>(
663 x, source, line, dim, mask, "MAXVAL");
664}
665#endif
666
667// TODO: REAL(2 & 3)
668CppTypeFor<TypeCategory::Real, 4> RTNAME(MaxvalReal4)_FortranAMaxvalReal4(const Descriptor &x,
669 const char *source, int line, int dim, const Descriptor *mask) {
670 return TotalNumericMaxOrMin<TypeCategory::Real, 4, true>(
671 x, source, line, dim, mask, "MAXVAL");
672}
673CppTypeFor<TypeCategory::Real, 8> RTNAME(MaxvalReal8)_FortranAMaxvalReal8(const Descriptor &x,
674 const char *source, int line, int dim, const Descriptor *mask) {
675 return TotalNumericMaxOrMin<TypeCategory::Real, 8, true>(
676 x, source, line, dim, mask, "MAXVAL");
677}
678#if LDBL_MANT_DIG64 == 64
679CppTypeFor<TypeCategory::Real, 10> RTNAME(MaxvalReal10)_FortranAMaxvalReal10(const Descriptor &x,
680 const char *source, int line, int dim, const Descriptor *mask) {
681 return TotalNumericMaxOrMin<TypeCategory::Real, 10, true>(
682 x, source, line, dim, mask, "MAXVAL");
683}
684#endif
685#if LDBL_MANT_DIG64 == 113 || HAS_FLOAT1281
686CppTypeFor<TypeCategory::Real, 16> RTNAME(MaxvalReal16)_FortranAMaxvalReal16(const Descriptor &x,
687 const char *source, int line, int dim, const Descriptor *mask) {
688 return TotalNumericMaxOrMin<TypeCategory::Real, 16, true>(
689 x, source, line, dim, mask, "MAXVAL");
690}
691#endif
692
693void RTNAME(MaxvalCharacter)_FortranAMaxvalCharacter(Descriptor &result, const Descriptor &x,
694 const char *source, int line, const Descriptor *mask) {
695 CharacterMaxOrMin<true>(result, x, 0, source, line, mask, "MAXVAL");
696}
697
698CppTypeFor<TypeCategory::Integer, 1> RTNAME(MinvalInteger1)_FortranAMinvalInteger1(const Descriptor &x,
699 const char *source, int line, int dim, const Descriptor *mask) {
700 return TotalNumericMaxOrMin<TypeCategory::Integer, 1, false>(
701 x, source, line, dim, mask, "MINVAL");
702}
703CppTypeFor<TypeCategory::Integer, 2> RTNAME(MinvalInteger2)_FortranAMinvalInteger2(const Descriptor &x,
704 const char *source, int line, int dim, const Descriptor *mask) {
705 return TotalNumericMaxOrMin<TypeCategory::Integer, 2, false>(
706 x, source, line, dim, mask, "MINVAL");
707}
708CppTypeFor<TypeCategory::Integer, 4> RTNAME(MinvalInteger4)_FortranAMinvalInteger4(const Descriptor &x,
709 const char *source, int line, int dim, const Descriptor *mask) {
710 return TotalNumericMaxOrMin<TypeCategory::Integer, 4, false>(
711 x, source, line, dim, mask, "MINVAL");
712}
713CppTypeFor<TypeCategory::Integer, 8> RTNAME(MinvalInteger8)_FortranAMinvalInteger8(const Descriptor &x,
714 const char *source, int line, int dim, const Descriptor *mask) {
715 return TotalNumericMaxOrMin<TypeCategory::Integer, 8, false>(
716 x, source, line, dim, mask, "MINVAL");
717}
718#ifdef __SIZEOF_INT128__16
719CppTypeFor<TypeCategory::Integer, 16> RTNAME(MinvalInteger16)_FortranAMinvalInteger16(
720 const Descriptor &x, const char *source, int line, int dim,
721 const Descriptor *mask) {
722 return TotalNumericMaxOrMin<TypeCategory::Integer, 16, false>(
723 x, source, line, dim, mask, "MINVAL");
724}
725#endif
726
727// TODO: REAL(2 & 3)
728CppTypeFor<TypeCategory::Real, 4> RTNAME(MinvalReal4)_FortranAMinvalReal4(const Descriptor &x,
729 const char *source, int line, int dim, const Descriptor *mask) {
730 return TotalNumericMaxOrMin<TypeCategory::Real, 4, false>(
731 x, source, line, dim, mask, "MINVAL");
732}
733CppTypeFor<TypeCategory::Real, 8> RTNAME(MinvalReal8)_FortranAMinvalReal8(const Descriptor &x,
734 const char *source, int line, int dim, const Descriptor *mask) {
735 return TotalNumericMaxOrMin<TypeCategory::Real, 8, false>(
736 x, source, line, dim, mask, "MINVAL");
737}
738#if LDBL_MANT_DIG64 == 64
739CppTypeFor<TypeCategory::Real, 10> RTNAME(MinvalReal10)_FortranAMinvalReal10(const Descriptor &x,
740 const char *source, int line, int dim, const Descriptor *mask) {
741 return TotalNumericMaxOrMin<TypeCategory::Real, 10, false>(
742 x, source, line, dim, mask, "MINVAL");
743}
744#endif
745#if LDBL_MANT_DIG64 == 113 || HAS_FLOAT1281
746CppTypeFor<TypeCategory::Real, 16> RTNAME(MinvalReal16)_FortranAMinvalReal16(const Descriptor &x,
747 const char *source, int line, int dim, const Descriptor *mask) {
748 return TotalNumericMaxOrMin<TypeCategory::Real, 16, false>(
749 x, source, line, dim, mask, "MINVAL");
750}
751#endif
752
753void RTNAME(MinvalCharacter)_FortranAMinvalCharacter(Descriptor &result, const Descriptor &x,
754 const char *source, int line, const Descriptor *mask) {
755 CharacterMaxOrMin<false>(result, x, 0, source, line, mask, "MINVAL");
756}
757
758void RTNAME(MaxvalDim)_FortranAMaxvalDim(Descriptor &result, const Descriptor &x, int dim,
759 const char *source, int line, const Descriptor *mask) {
760 if (x.type().IsCharacter()) {
761 CharacterMaxOrMin<true>(result, x, dim, source, line, mask, "MAXVAL");
762 } else {
763 NumericMaxOrMin<true>(result, x, dim, source, line, mask, "MAXVAL");
764 }
765}
766void RTNAME(MinvalDim)_FortranAMinvalDim(Descriptor &result, const Descriptor &x, int dim,
767 const char *source, int line, const Descriptor *mask) {
768 if (x.type().IsCharacter()) {
769 CharacterMaxOrMin<false>(result, x, dim, source, line, mask, "MINVAL");
770 } else {
771 NumericMaxOrMin<false>(result, x, dim, source, line, mask, "MINVAL");
772 }
773}
774} // extern "C"
775
776// NORM2
777
778template <int KIND> class Norm2Accumulator {
779public:
780 using Type = CppTypeFor<TypeCategory::Real, KIND>;
781 // Use at least double precision for accumulators.
782 // Don't use __float128, it doesn't work with abs() or sqrt() yet.
783 static constexpr int largestLDKind {
784#if LDBL_MANT_DIG64 == 113
785 16
786#elif LDBL_MANT_DIG64 == 64
787 10
788#else
789 8
790#endif
791 };
792 using AccumType =
793 CppTypeFor<TypeCategory::Real, std::clamp(KIND, 8, largestLDKind)>;
794 explicit Norm2Accumulator(const Descriptor &array) : array_{array} {}
795 void Reinitialize() { max_ = sum_ = 0; }
796 template <typename A> void GetResult(A *p, int /*zeroBasedDim*/ = -1) const {
797 // m * sqrt(1 + sum((others(:)/m)**2))
798 *p = static_cast<Type>(max_ * std::sqrt(1 + sum_));
799 }
800 bool Accumulate(Type x) {
801 auto absX{std::abs(static_cast<AccumType>(x))};
802 if (!max_) {
803 max_ = x;
804 } else if (absX > max_) {
805 auto t{max_ / absX}; // < 1.0
806 auto tsq{t * t};
807 sum_ *= tsq; // scale sum to reflect change to the max
808 sum_ += tsq; // include a term for the previous max
809 max_ = absX;
810 } else { // absX <= max_
811 auto t{absX / max_};
812 sum_ += t * t;
813 }
814 return true;
815 }
816 template <typename A> bool AccumulateAt(const SubscriptValue at[]) {
817 return Accumulate(*array_.Element<A>(at));
818 }
819
820private:
821 const Descriptor &array_;
822 AccumType max_{0}; // value (m) with largest magnitude
823 AccumType sum_{0}; // sum((others(:)/m)**2)
824};
825
826template <int KIND> struct Norm2Helper {
827 void operator()(Descriptor &result, const Descriptor &x, int dim,
828 const Descriptor *mask, Terminator &terminator) const {
829 DoMaxMinNorm2<TypeCategory::Real, KIND, Norm2Accumulator<KIND>>(
830 result, x, dim, mask, "NORM2", terminator);
831 }
832};
833
834extern "C" {
835// TODO: REAL(2 & 3)
836CppTypeFor<TypeCategory::Real, 4> RTNAME(Norm2_4)_FortranANorm2_4(
837 const Descriptor &x, const char *source, int line, int dim) {
838 return GetTotalReduction<TypeCategory::Real, 4>(
839 x, source, line, dim, nullptr, Norm2Accumulator<4>{x}, "NORM2");
840}
841CppTypeFor<TypeCategory::Real, 8> RTNAME(Norm2_8)_FortranANorm2_8(
842 const Descriptor &x, const char *source, int line, int dim) {
843 return GetTotalReduction<TypeCategory::Real, 8>(
844 x, source, line, dim, nullptr, Norm2Accumulator<8>{x}, "NORM2");
845}
846#if LDBL_MANT_DIG64 == 64
847CppTypeFor<TypeCategory::Real, 10> RTNAME(Norm2_10)_FortranANorm2_10(
848 const Descriptor &x, const char *source, int line, int dim) {
849 return GetTotalReduction<TypeCategory::Real, 10>(
850 x, source, line, dim, nullptr, Norm2Accumulator<10>{x}, "NORM2");
851}
852#endif
853#if LDBL_MANT_DIG64 == 113
854CppTypeFor<TypeCategory::Real, 16> RTNAME(Norm2_16)_FortranANorm2_16(
855 const Descriptor &x, const char *source, int line, int dim) {
856 return GetTotalReduction<TypeCategory::Real, 16>(
857 x, source, line, dim, nullptr, Norm2Accumulator<16>{x}, "NORM2");
858}
859#endif
860
861void RTNAME(Norm2Dim)_FortranANorm2Dim(Descriptor &result, const Descriptor &x, int dim,
862 const char *source, int line) {
863 Terminator terminator{source, line};
864 auto type{x.type().GetCategoryAndKind()};
865 RUNTIME_CHECK(terminator, type)if (type) ; else (terminator).CheckFailed("type", "flang/runtime/extrema.cpp"
, 865);
866 if (type->first == TypeCategory::Real) {
867 ApplyFloatingPointKind<Norm2Helper, void>(
868 type->second, terminator, result, x, dim, nullptr, terminator);
869 } else {
870 terminator.Crash("NORM2: bad type code %d", x.type().raw());
871 }
872}
873} // extern "C"
874} // namespace Fortran::runtime
←

/build/source/flang/runtime/tools.h

→
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
21namespace Fortran::runtime {
22
23class Terminator;
24
25std::size_t TrimTrailingSpaces(const char *, std::size_t);
26
27OwningPtr<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.
34int IdentifyValue(
35 const char *value, std::size_t length, const char *possibilities[]);
36
37// Truncates or pads as necessary
38void ToFortranDefaultCharacter(
39 char *to, std::size_t toLength, const char *from);
40
41// Utility for dealing with elemental LOGICAL arguments
42inline 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.
55void 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].
60template <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
69void CheckIntegerKind(Terminator &, int kind, const char *intrinsic);
70
71template <typename TO, typename FROM>
72inline void PutContiguousConverted(TO *to, FROM *from, std::size_t count) {
73 while (count-- > 0) {
74 *to++ = *from++;
75 }
76}
77
78static 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
94template <typename INT>
95inline 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.
117template <template <TypeCategory, int> class FUNC, typename RESULT,
118 typename... A>
119inline 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.
219template <template <int KIND> class FUNC, typename RESULT, typename... A>
220inline 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
239template <template <int KIND> class FUNC, typename RESULT, typename... A>
240inline 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
267template <template <int KIND> class FUNC, typename RESULT, typename... A>
268inline RESULT ApplyCharacterKind(int kind, Terminator &terminator, A &&...x) {
269 switch (kind) {
8
←
Control jumps to 'case 1:' at line 270
→
270 case 1:
271 return FUNC<1>{}(std::forward<A>(x)...);
9
←
Calling 'Functor::operator()'
→
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
281template <template <int KIND> class FUNC, typename RESULT, typename... A>
282inline 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.
298std::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
354template <TypeCategory CAT, int KIND>
355using 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
361template <typename CHAR>
362static 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
373template <>
374inline 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_
←

/build/source/flang/runtime/reduction-templates.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
29namespace 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.
42template <typename TYPE, typename ACCUMULATOR>
43inline void DoTotalReduction(const Descriptor &x, int dim,
44 const Descriptor *mask, ACCUMULATOR &accumulator, const char *intrinsic,
45 Terminator &terminator) {
46 if (dim
14.1
'dim' is >= 0
14.1
'dim' is >= 0
14.1
'dim' is >= 0
 < 0 || dim
14.2
'dim' is <= 1
14.2
'dim' is <= 1
14.2
'dim' is <= 1
 > 1) {
15
←
Taking false branch
→
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) {
16
←
Assuming 'mask' is null
→
17
←
Taking false branch
→
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)) {
18
←
Loop condition is true. Entering loop body
→
20
←
Loop condition is true. Entering loop body
→
22
←
Loop condition is true. Entering loop body
→
72 if (!accumulator.template AccumulateAt<TYPE>(xAt)) {
19
←
Taking false branch
→
21
←
Taking false branch
→
23
←
Calling 'ExtremumLocAccumulator::AccumulateAt'
→
73 break; // cut short, result is known
74 }
75 }
76}
77
78template <TypeCategory CAT, int KIND, typename ACCUMULATOR>
79inline 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.
101inline 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
115template <typename TYPE, typename ACCUMULATOR>
116inline 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
135template <typename TYPE, typename ACCUMULATOR>
136inline 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=).
165static 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
194template <typename ACCUMULATOR, TypeCategory CAT, int KIND>
195inline 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
231template <template <typename> class ACCUM>
232struct 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
250template <template <typename> class INTEGER_ACCUM>
251inline 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
259template <TypeCategory CAT, template <typename> class ACCUM>
260struct 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
277template <template <typename> class INTEGER_ACCUM,
278 template <typename> class REAL_ACCUM,
279 template <typename> class COMPLEX_ACCUM>
280inline 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
308template <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
317template <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_