892 lines · cpp
1//===-- lib/runtime/extrema.cpp ---------------------------------*- 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-exception6//7//===----------------------------------------------------------------------===//8 9// Implements MAXLOC, MINLOC, MAXVAL, & MINVAL for all required operand types10// and shapes and (for MAXLOC & MINLOC) result integer kinds. Also implements11// NORM2 using common infrastructure.12 13#include "flang-rt/runtime/reduction-templates.h"14#include "flang/Common/float128.h"15#include "flang/Runtime/character.h"16#include "flang/Runtime/reduction.h"17#include <algorithm>18#include <cfloat>19#include <cinttypes>20#include <cmath>21#include <type_traits>22 23namespace Fortran::runtime {24 25// MAXLOC & MINLOC26 27template <typename T, bool IS_MAX, bool BACK> struct NumericCompare {28 using Type = T;29 explicit RT_API_ATTRS NumericCompare(std::size_t /*elemLen; ignored*/) {}30 RT_API_ATTRS bool operator()(const T &value, const T &previous) const {31 if (std::is_floating_point_v<T> && previous != previous) {32 return BACK || value == value; // replace NaN33 } else if (value == previous) {34 return BACK;35 } else if constexpr (IS_MAX) {36 return value > previous;37 } else {38 return value < previous;39 }40 }41};42 43template <typename T, bool IS_MAX, bool BACK> class CharacterCompare {44public:45 using Type = T;46 explicit RT_API_ATTRS CharacterCompare(std::size_t elemLen)47 : chars_{elemLen / sizeof(T)} {}48 RT_API_ATTRS bool operator()(const T &value, const T &previous) const {49 int cmp{CharacterScalarCompare<T>(&value, &previous, chars_, chars_)};50 if (cmp == 0) {51 return BACK;52 } else if constexpr (IS_MAX) {53 return cmp > 0;54 } else {55 return cmp < 0;56 }57 }58 59private:60 std::size_t chars_;61};62 63template <typename COMPARE> class ExtremumLocAccumulator {64public:65 using Type = typename COMPARE::Type;66 RT_API_ATTRS ExtremumLocAccumulator(const Descriptor &array)67 : array_{array}, argRank_{array.rank()}, compare_{array.ElementBytes()} {68 Reinitialize();69 }70 RT_API_ATTRS void Reinitialize() {71 // per standard: result indices are all zero if no data72 for (int j{0}; j < argRank_; ++j) {73 extremumLoc_[j] = 0;74 }75 previous_ = nullptr;76 }77 RT_API_ATTRS int argRank() const { return argRank_; }78 template <typename A>79 RT_API_ATTRS void GetResult(A *p, int zeroBasedDim = -1) {80 if (zeroBasedDim >= 0) {81 *p = extremumLoc_[zeroBasedDim];82 } else {83 for (int j{0}; j < argRank_; ++j) {84 p[j] = extremumLoc_[j];85 }86 }87 }88 template <typename IGNORED>89 RT_API_ATTRS bool AccumulateAt(const SubscriptValue at[]) {90 const auto &value{*array_.Element<Type>(at)};91 if (!previous_ || compare_(value, *previous_)) {92 previous_ = &value;93 for (int j{0}; j < argRank_; ++j) {94 extremumLoc_[j] = at[j] - array_.GetDimension(j).LowerBound() + 1;95 }96 }97 return true;98 }99 100private:101 const Descriptor &array_;102 int argRank_;103 SubscriptValue extremumLoc_[maxRank];104 const Type *previous_{nullptr};105 COMPARE compare_;106};107 108template <typename ACCUMULATOR, typename CPPTYPE>109static RT_API_ATTRS void LocationHelper(const char *intrinsic,110 Descriptor &result, const Descriptor &x, int kind, const Descriptor *mask,111 Terminator &terminator) {112 ACCUMULATOR accumulator{x};113 DoTotalReduction<CPPTYPE>(x, 0, mask, accumulator, intrinsic, terminator);114 ApplyIntegerKind<LocationResultHelper<ACCUMULATOR>::template Functor, void>(115 kind, terminator, accumulator, result);116}117 118template <TypeCategory CAT, int KIND, bool IS_MAX,119 template <typename, bool, bool> class COMPARE>120inline RT_API_ATTRS void DoMaxOrMinLoc(const char *intrinsic,121 Descriptor &result, const Descriptor &x, int kind, const char *source,122 int line, const Descriptor *mask, bool back) {123 using CppType = CppTypeFor<CAT, KIND>;124 Terminator terminator{source, line};125 if (back) {126 LocationHelper<ExtremumLocAccumulator<COMPARE<CppType, IS_MAX, true>>,127 CppType>(intrinsic, result, x, kind, mask, terminator);128 } else {129 LocationHelper<ExtremumLocAccumulator<COMPARE<CppType, IS_MAX, false>>,130 CppType>(intrinsic, result, x, kind, mask, terminator);131 }132}133 134template <bool IS_MAX> struct CharacterMaxOrMinLocHelper {135 template <int KIND> struct Functor {136 RT_API_ATTRS void operator()(const char *intrinsic, Descriptor &result,137 const Descriptor &x, int kind, const char *source, int line,138 const Descriptor *mask, bool back) const {139 DoMaxOrMinLoc<TypeCategory::Character, KIND, IS_MAX, CharacterCompare>(140 intrinsic, result, x, kind, source, line, mask, back);141 }142 };143};144 145template <bool IS_MAX>146inline RT_API_ATTRS void CharacterMaxOrMinLoc(const char *intrinsic,147 Descriptor &result, const Descriptor &x, int kind, const char *source,148 int line, const Descriptor *mask, bool back) {149 int rank{x.rank()};150 SubscriptValue extent[1]{rank};151 result.Establish(TypeCategory::Integer, kind, nullptr, 1, extent,152 CFI_attribute_allocatable);153 result.GetDimension(0).SetBounds(1, extent[0]);154 Terminator terminator{source, line};155 if (int stat{result.Allocate(kNoAsyncObject)}) {156 terminator.Crash(157 "%s: could not allocate memory for result; STAT=%d", intrinsic, stat);158 }159 CheckIntegerKind(terminator, kind, intrinsic);160 auto catKind{x.type().GetCategoryAndKind()};161 RUNTIME_CHECK(terminator, catKind.has_value());162 switch (catKind->first) {163 case TypeCategory::Character:164 ApplyCharacterKind<CharacterMaxOrMinLocHelper<IS_MAX>::template Functor,165 void>(catKind->second, terminator, intrinsic, result, x, kind, source,166 line, mask, back);167 break;168 default:169 terminator.Crash(170 "%s: bad data type code (%d) for array", intrinsic, x.type().raw());171 }172}173 174template <TypeCategory CAT, int KIND, bool IS_MAXVAL>175inline RT_API_ATTRS void TotalNumericMaxOrMinLoc(const char *intrinsic,176 Descriptor &result, const Descriptor &x, int kind, const char *source,177 int line, const Descriptor *mask, bool back) {178 int rank{x.rank()};179 SubscriptValue extent[1]{rank};180 result.Establish(TypeCategory::Integer, kind, nullptr, 1, extent,181 CFI_attribute_allocatable);182 result.GetDimension(0).SetBounds(1, extent[0]);183 Terminator terminator{source, line};184 if (int stat{result.Allocate(kNoAsyncObject)}) {185 terminator.Crash(186 "%s: could not allocate memory for result; STAT=%d", intrinsic, stat);187 }188 CheckIntegerKind(terminator, kind, intrinsic);189 RUNTIME_CHECK(terminator, TypeCode(CAT, KIND) == x.type());190 DoMaxOrMinLoc<CAT, KIND, IS_MAXVAL, NumericCompare>(191 intrinsic, result, x, kind, source, line, mask, back);192}193 194extern "C" {195RT_EXT_API_GROUP_BEGIN196 197void RTDEF(MaxlocCharacter)(Descriptor &result, const Descriptor &x, int kind,198 const char *source, int line, const Descriptor *mask, bool back) {199 CharacterMaxOrMinLoc<true>(200 "MAXLOC", result, x, kind, source, line, mask, back);201}202void RTDEF(MaxlocInteger1)(Descriptor &result, const Descriptor &x, int kind,203 const char *source, int line, const Descriptor *mask, bool back) {204 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 1, true>(205 "MAXLOC", result, x, kind, source, line, mask, back);206}207void RTDEF(MaxlocInteger2)(Descriptor &result, const Descriptor &x, int kind,208 const char *source, int line, const Descriptor *mask, bool back) {209 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 2, true>(210 "MAXLOC", result, x, kind, source, line, mask, back);211}212void RTDEF(MaxlocInteger4)(Descriptor &result, const Descriptor &x, int kind,213 const char *source, int line, const Descriptor *mask, bool back) {214 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 4, true>(215 "MAXLOC", result, x, kind, source, line, mask, back);216}217void RTDEF(MaxlocInteger8)(Descriptor &result, const Descriptor &x, int kind,218 const char *source, int line, const Descriptor *mask, bool back) {219 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 8, true>(220 "MAXLOC", result, x, kind, source, line, mask, back);221}222#ifdef __SIZEOF_INT128__223void RTDEF(MaxlocInteger16)(Descriptor &result, const Descriptor &x, int kind,224 const char *source, int line, const Descriptor *mask, bool back) {225 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 16, true>(226 "MAXLOC", result, x, kind, source, line, mask, back);227}228#endif229void RTDEF(MaxlocUnsigned1)(Descriptor &result, const Descriptor &x, int kind,230 const char *source, int line, const Descriptor *mask, bool back) {231 TotalNumericMaxOrMinLoc<TypeCategory::Unsigned, 1, true>(232 "MAXLOC", result, x, kind, source, line, mask, back);233}234void RTDEF(MaxlocUnsigned2)(Descriptor &result, const Descriptor &x, int kind,235 const char *source, int line, const Descriptor *mask, bool back) {236 TotalNumericMaxOrMinLoc<TypeCategory::Unsigned, 2, true>(237 "MAXLOC", result, x, kind, source, line, mask, back);238}239void RTDEF(MaxlocUnsigned4)(Descriptor &result, const Descriptor &x, int kind,240 const char *source, int line, const Descriptor *mask, bool back) {241 TotalNumericMaxOrMinLoc<TypeCategory::Unsigned, 4, true>(242 "MAXLOC", result, x, kind, source, line, mask, back);243}244void RTDEF(MaxlocUnsigned8)(Descriptor &result, const Descriptor &x, int kind,245 const char *source, int line, const Descriptor *mask, bool back) {246 TotalNumericMaxOrMinLoc<TypeCategory::Unsigned, 8, true>(247 "MAXLOC", result, x, kind, source, line, mask, back);248}249#ifdef __SIZEOF_INT128__250void RTDEF(MaxlocUnsigned16)(Descriptor &result, const Descriptor &x, int kind,251 const char *source, int line, const Descriptor *mask, bool back) {252 TotalNumericMaxOrMinLoc<TypeCategory::Unsigned, 16, true>(253 "MAXLOC", result, x, kind, source, line, mask, back);254}255#endif256void RTDEF(MaxlocReal4)(Descriptor &result, const Descriptor &x, int kind,257 const char *source, int line, const Descriptor *mask, bool back) {258 TotalNumericMaxOrMinLoc<TypeCategory::Real, 4, true>(259 "MAXLOC", result, x, kind, source, line, mask, back);260}261void RTDEF(MaxlocReal8)(Descriptor &result, const Descriptor &x, int kind,262 const char *source, int line, const Descriptor *mask, bool back) {263 TotalNumericMaxOrMinLoc<TypeCategory::Real, 8, true>(264 "MAXLOC", result, x, kind, source, line, mask, back);265}266#if HAS_FLOAT80267void RTDEF(MaxlocReal10)(Descriptor &result, const Descriptor &x, int kind,268 const char *source, int line, const Descriptor *mask, bool back) {269 TotalNumericMaxOrMinLoc<TypeCategory::Real, 10, true>(270 "MAXLOC", result, x, kind, source, line, mask, back);271}272#endif273#if HAS_LDBL128 || HAS_FLOAT128274void RTDEF(MaxlocReal16)(Descriptor &result, const Descriptor &x, int kind,275 const char *source, int line, const Descriptor *mask, bool back) {276 TotalNumericMaxOrMinLoc<TypeCategory::Real, 16, true>(277 "MAXLOC", result, x, kind, source, line, mask, back);278}279#endif280void RTDEF(MinlocCharacter)(Descriptor &result, const Descriptor &x, int kind,281 const char *source, int line, const Descriptor *mask, bool back) {282 CharacterMaxOrMinLoc<false>(283 "MINLOC", result, x, kind, source, line, mask, back);284}285void RTDEF(MinlocInteger1)(Descriptor &result, const Descriptor &x, int kind,286 const char *source, int line, const Descriptor *mask, bool back) {287 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 1, false>(288 "MINLOC", result, x, kind, source, line, mask, back);289}290void RTDEF(MinlocInteger2)(Descriptor &result, const Descriptor &x, int kind,291 const char *source, int line, const Descriptor *mask, bool back) {292 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 2, false>(293 "MINLOC", result, x, kind, source, line, mask, back);294}295void RTDEF(MinlocInteger4)(Descriptor &result, const Descriptor &x, int kind,296 const char *source, int line, const Descriptor *mask, bool back) {297 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 4, false>(298 "MINLOC", result, x, kind, source, line, mask, back);299}300void RTDEF(MinlocInteger8)(Descriptor &result, const Descriptor &x, int kind,301 const char *source, int line, const Descriptor *mask, bool back) {302 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 8, false>(303 "MINLOC", result, x, kind, source, line, mask, back);304}305#ifdef __SIZEOF_INT128__306void RTDEF(MinlocInteger16)(Descriptor &result, const Descriptor &x, int kind,307 const char *source, int line, const Descriptor *mask, bool back) {308 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 16, false>(309 "MINLOC", result, x, kind, source, line, mask, back);310}311#endif312void RTDEF(MinlocUnsigned1)(Descriptor &result, const Descriptor &x, int kind,313 const char *source, int line, const Descriptor *mask, bool back) {314 TotalNumericMaxOrMinLoc<TypeCategory::Unsigned, 1, false>(315 "MINLOC", result, x, kind, source, line, mask, back);316}317void RTDEF(MinlocUnsigned2)(Descriptor &result, const Descriptor &x, int kind,318 const char *source, int line, const Descriptor *mask, bool back) {319 TotalNumericMaxOrMinLoc<TypeCategory::Unsigned, 2, false>(320 "MINLOC", result, x, kind, source, line, mask, back);321}322void RTDEF(MinlocUnsigned4)(Descriptor &result, const Descriptor &x, int kind,323 const char *source, int line, const Descriptor *mask, bool back) {324 TotalNumericMaxOrMinLoc<TypeCategory::Unsigned, 4, false>(325 "MINLOC", result, x, kind, source, line, mask, back);326}327void RTDEF(MinlocUnsigned8)(Descriptor &result, const Descriptor &x, int kind,328 const char *source, int line, const Descriptor *mask, bool back) {329 TotalNumericMaxOrMinLoc<TypeCategory::Unsigned, 8, false>(330 "MINLOC", result, x, kind, source, line, mask, back);331}332#ifdef __SIZEOF_INT128__333void RTDEF(MinlocUnsigned16)(Descriptor &result, const Descriptor &x, int kind,334 const char *source, int line, const Descriptor *mask, bool back) {335 TotalNumericMaxOrMinLoc<TypeCategory::Unsigned, 16, false>(336 "MINLOC", result, x, kind, source, line, mask, back);337}338#endif339void RTDEF(MinlocReal4)(Descriptor &result, const Descriptor &x, int kind,340 const char *source, int line, const Descriptor *mask, bool back) {341 TotalNumericMaxOrMinLoc<TypeCategory::Real, 4, false>(342 "MINLOC", result, x, kind, source, line, mask, back);343}344void RTDEF(MinlocReal8)(Descriptor &result, const Descriptor &x, int kind,345 const char *source, int line, const Descriptor *mask, bool back) {346 TotalNumericMaxOrMinLoc<TypeCategory::Real, 8, false>(347 "MINLOC", result, x, kind, source, line, mask, back);348}349#if HAS_FLOAT80350void RTDEF(MinlocReal10)(Descriptor &result, const Descriptor &x, int kind,351 const char *source, int line, const Descriptor *mask, bool back) {352 TotalNumericMaxOrMinLoc<TypeCategory::Real, 10, false>(353 "MINLOC", result, x, kind, source, line, mask, back);354}355#endif356#if HAS_LDBL128 || HAS_FLOAT128357void RTDEF(MinlocReal16)(Descriptor &result, const Descriptor &x, int kind,358 const char *source, int line, const Descriptor *mask, bool back) {359 TotalNumericMaxOrMinLoc<TypeCategory::Real, 16, false>(360 "MINLOC", result, x, kind, source, line, mask, back);361}362#endif363 364RT_EXT_API_GROUP_END365} // extern "C"366 367// MAXLOC/MINLOC with DIM=368 369template <TypeCategory CAT, int KIND, bool IS_MAX,370 template <typename, bool, bool> class COMPARE, bool BACK>371static RT_API_ATTRS void DoPartialMaxOrMinLocDirection(const char *intrinsic,372 Descriptor &result, const Descriptor &x, int kind, int dim,373 const Descriptor *mask, Terminator &terminator) {374 using CppType = CppTypeFor<CAT, KIND>;375 using Accumulator = ExtremumLocAccumulator<COMPARE<CppType, IS_MAX, BACK>>;376 Accumulator accumulator{x};377 ApplyIntegerKind<PartialLocationHelper<Accumulator>::template Functor, void>(378 kind, terminator, result, x, dim, mask, terminator, intrinsic,379 accumulator);380}381 382template <TypeCategory CAT, int KIND, bool IS_MAX,383 template <typename, bool, bool> class COMPARE>384inline RT_API_ATTRS void DoPartialMaxOrMinLoc(const char *intrinsic,385 Descriptor &result, const Descriptor &x, int kind, int dim,386 const Descriptor *mask, bool back, Terminator &terminator) {387 if (back) {388 DoPartialMaxOrMinLocDirection<CAT, KIND, IS_MAX, COMPARE, true>(389 intrinsic, result, x, kind, dim, mask, terminator);390 } else {391 DoPartialMaxOrMinLocDirection<CAT, KIND, IS_MAX, COMPARE, false>(392 intrinsic, result, x, kind, dim, mask, terminator);393 }394}395 396template <TypeCategory CAT, bool IS_MAX,397 template <typename, bool, bool> class COMPARE>398struct DoPartialMaxOrMinLocHelper {399 template <int KIND> struct Functor {400 // NVCC inlines more aggressively which causes too many specializations of401 // this function to be inlined causing compiler timeouts. Set as402 // noinline to allow compilation to complete.403 RT_API_ATTRS RT_DEVICE_NOINLINE void operator()(const char *intrinsic,404 Descriptor &result, const Descriptor &x, int kind, int dim,405 const Descriptor *mask, bool back, Terminator &terminator) const {406 DoPartialMaxOrMinLoc<CAT, KIND, IS_MAX, COMPARE>(407 intrinsic, result, x, kind, dim, mask, back, terminator);408 }409 };410};411 412template <bool IS_MAX>413inline RT_API_ATTRS void TypedPartialMaxOrMinLoc(const char *intrinsic,414 Descriptor &result, const Descriptor &x, int kind, int dim,415 const char *source, int line, const Descriptor *mask, bool back) {416 Terminator terminator{source, line};417 CheckIntegerKind(terminator, kind, intrinsic);418 auto catKind{x.type().GetCategoryAndKind()};419 RUNTIME_CHECK(terminator, catKind.has_value());420 const Descriptor *maskToUse{mask};421 SubscriptValue maskAt[maxRank]; // contents unused422 if (mask && mask->rank() == 0) {423 if (IsLogicalElementTrue(*mask, maskAt)) {424 // A scalar MASK that's .TRUE. In this case, just get rid of the MASK.425 maskToUse = nullptr;426 } else {427 // For scalar MASK arguments that are .FALSE., return all zeroes428 429 // Element size of the destination descriptor is the size430 // of {TypeCategory::Integer, kind}.431 CreatePartialReductionResult(result, x,432 Descriptor::BytesFor(TypeCategory::Integer, kind), dim, terminator,433 intrinsic, TypeCode{TypeCategory::Integer, kind});434 runtime::memset(435 result.OffsetElement(), 0, result.Elements() * result.ElementBytes());436 return;437 }438 }439 switch (catKind->first) {440 case TypeCategory::Integer:441 ApplyIntegerKind<DoPartialMaxOrMinLocHelper<TypeCategory::Integer, IS_MAX,442 NumericCompare>::template Functor,443 void>(catKind->second, terminator, intrinsic, result, x, kind, dim,444 maskToUse, back, terminator);445 break;446 case TypeCategory::Unsigned:447 ApplyIntegerKind<DoPartialMaxOrMinLocHelper<TypeCategory::Unsigned, IS_MAX,448 NumericCompare>::template Functor,449 void>(catKind->second, terminator, intrinsic, result, x, kind, dim,450 maskToUse, back, terminator);451 break;452 case TypeCategory::Real:453 ApplyFloatingPointKind<DoPartialMaxOrMinLocHelper<TypeCategory::Real,454 IS_MAX, NumericCompare>::template Functor,455 void>(catKind->second, terminator, intrinsic, result, x, kind, dim,456 maskToUse, back, terminator);457 break;458 case TypeCategory::Character:459 ApplyCharacterKind<DoPartialMaxOrMinLocHelper<TypeCategory::Character,460 IS_MAX, CharacterCompare>::template Functor,461 void>(catKind->second, terminator, intrinsic, result, x, kind, dim,462 maskToUse, back, terminator);463 break;464 default:465 terminator.Crash(466 "%s: bad data type code (%d) for array", intrinsic, x.type().raw());467 }468}469 470extern "C" {471RT_EXT_API_GROUP_BEGIN472 473void RTDEF(MaxlocDim)(Descriptor &result, const Descriptor &x, int kind,474 int dim, const char *source, int line, const Descriptor *mask, bool back) {475 TypedPartialMaxOrMinLoc<true>(476 "MAXLOC", result, x, kind, dim, source, line, mask, back);477}478void RTDEF(MinlocDim)(Descriptor &result, const Descriptor &x, int kind,479 int dim, const char *source, int line, const Descriptor *mask, bool back) {480 TypedPartialMaxOrMinLoc<false>(481 "MINLOC", result, x, kind, dim, source, line, mask, back);482}483 484RT_EXT_API_GROUP_END485} // extern "C"486 487// MAXVAL and MINVAL488 489template <TypeCategory CAT, int KIND, bool IS_MAXVAL>490class NumericExtremumAccumulator {491public:492 using Type = CppTypeFor<CAT, KIND>;493 explicit RT_API_ATTRS NumericExtremumAccumulator(const Descriptor &array)494 : array_{array} {}495 RT_API_ATTRS void Reinitialize() {496 any_ = false;497 extremum_ = MaxOrMinIdentity<CAT, KIND, IS_MAXVAL>::Value();498 }499 template <typename A>500 RT_API_ATTRS void GetResult(A *p, int /*zeroBasedDim*/ = -1) const {501 *p = extremum_;502 }503 RT_API_ATTRS bool Accumulate(Type x) {504 if (!any_) {505 extremum_ = x;506 any_ = true;507 } else if (CAT == TypeCategory::Real && extremum_ != extremum_) {508 extremum_ = x; // replace NaN509 } else if constexpr (IS_MAXVAL) {510 if (x > extremum_) {511 extremum_ = x;512 }513 } else if (x < extremum_) {514 extremum_ = x;515 }516 return true;517 }518 template <typename A>519 RT_API_ATTRS bool AccumulateAt(const SubscriptValue at[]) {520 return Accumulate(*array_.Element<A>(at));521 }522 523private:524 const Descriptor &array_;525 bool any_{false};526 Type extremum_{MaxOrMinIdentity<CAT, KIND, IS_MAXVAL>::Value()};527};528 529template <TypeCategory CAT, int KIND, bool IS_MAXVAL>530inline RT_API_ATTRS CppTypeFor<CAT, KIND> TotalNumericMaxOrMin(531 const Descriptor &x, const char *source, int line, int dim,532 const Descriptor *mask, const char *intrinsic) {533 return GetTotalReduction<CAT, KIND>(x, source, line, dim, mask,534 NumericExtremumAccumulator<CAT, KIND, IS_MAXVAL>{x}, intrinsic);535}536 537template <TypeCategory CAT, bool IS_MAXVAL> struct MaxOrMinHelper {538 template <int KIND> struct Functor {539 RT_API_ATTRS void operator()(Descriptor &result, const Descriptor &x,540 int dim, const Descriptor *mask, const char *intrinsic,541 Terminator &terminator) const {542 DoMaxMinNorm2<CAT, KIND,543 NumericExtremumAccumulator<CAT, KIND, IS_MAXVAL>>(544 result, x, dim, mask, intrinsic, terminator);545 }546 };547};548 549template <bool IS_MAXVAL>550inline RT_API_ATTRS void NumericMaxOrMin(Descriptor &result,551 const Descriptor &x, int dim, const char *source, int line,552 const Descriptor *mask, const char *intrinsic) {553 Terminator terminator{source, line};554 auto type{x.type().GetCategoryAndKind()};555 RUNTIME_CHECK(terminator, type);556 switch (type->first) {557 case TypeCategory::Integer:558 ApplyIntegerKind<559 MaxOrMinHelper<TypeCategory::Integer, IS_MAXVAL>::template Functor,560 void>(561 type->second, terminator, result, x, dim, mask, intrinsic, terminator);562 break;563 case TypeCategory::Unsigned:564 ApplyIntegerKind<565 MaxOrMinHelper<TypeCategory::Unsigned, IS_MAXVAL>::template Functor,566 void>(567 type->second, terminator, result, x, dim, mask, intrinsic, terminator);568 break;569 case TypeCategory::Real:570 ApplyFloatingPointKind<571 MaxOrMinHelper<TypeCategory::Real, IS_MAXVAL>::template Functor, void>(572 type->second, terminator, result, x, dim, mask, intrinsic, terminator);573 break;574 default:575 terminator.Crash("%s: bad type code %d", intrinsic, x.type().raw());576 }577}578 579template <int KIND, bool IS_MAXVAL> class CharacterExtremumAccumulator {580public:581 using Type = CppTypeFor<TypeCategory::Character, KIND>;582 explicit RT_API_ATTRS CharacterExtremumAccumulator(const Descriptor &array)583 : array_{array}, charLen_{array_.ElementBytes() / KIND} {}584 RT_API_ATTRS void Reinitialize() { extremum_ = nullptr; }585 template <typename A>586 RT_API_ATTRS void GetResult(A *p, int /*zeroBasedDim*/ = -1) const {587 static_assert(std::is_same_v<A, Type>);588 std::size_t byteSize{array_.ElementBytes()};589 if (extremum_) {590 runtime::memcpy(p, extremum_, byteSize);591 } else {592 // Empty array; fill with character 0 for MAXVAL.593 // For MINVAL, set all of the bits.594 runtime::memset(p, IS_MAXVAL ? 0 : 255, byteSize);595 }596 }597 RT_API_ATTRS bool Accumulate(const Type *x) {598 if (!extremum_) {599 extremum_ = x;600 } else {601 int cmp{CharacterScalarCompare(x, extremum_, charLen_, charLen_)};602 if (IS_MAXVAL == (cmp > 0)) {603 extremum_ = x;604 }605 }606 return true;607 }608 template <typename A>609 RT_API_ATTRS bool AccumulateAt(const SubscriptValue at[]) {610 return Accumulate(array_.Element<A>(at));611 }612 613private:614 const Descriptor &array_;615 std::size_t charLen_;616 const Type *extremum_{nullptr};617};618 619template <bool IS_MAXVAL> struct CharacterMaxOrMinHelper {620 template <int KIND> struct Functor {621 RT_API_ATTRS void operator()(Descriptor &result, const Descriptor &x,622 int dim, const Descriptor *mask, const char *intrinsic,623 Terminator &terminator) const {624 DoMaxMinNorm2<TypeCategory::Character, KIND,625 CharacterExtremumAccumulator<KIND, IS_MAXVAL>>(626 result, x, dim, mask, intrinsic, terminator);627 }628 };629};630 631template <bool IS_MAXVAL>632inline RT_API_ATTRS void CharacterMaxOrMin(Descriptor &result,633 const Descriptor &x, int dim, const char *source, int line,634 const Descriptor *mask, const char *intrinsic) {635 Terminator terminator{source, line};636 auto type{x.type().GetCategoryAndKind()};637 RUNTIME_CHECK(terminator, type && type->first == TypeCategory::Character);638 ApplyCharacterKind<CharacterMaxOrMinHelper<IS_MAXVAL>::template Functor,639 void>(640 type->second, terminator, result, x, dim, mask, intrinsic, terminator);641}642 643extern "C" {644RT_EXT_API_GROUP_BEGIN645 646CppTypeFor<TypeCategory::Integer, 1> RTDEF(MaxvalInteger1)(const Descriptor &x,647 const char *source, int line, int dim, const Descriptor *mask) {648 return TotalNumericMaxOrMin<TypeCategory::Integer, 1, true>(649 x, source, line, dim, mask, "MAXVAL");650}651CppTypeFor<TypeCategory::Integer, 2> RTDEF(MaxvalInteger2)(const Descriptor &x,652 const char *source, int line, int dim, const Descriptor *mask) {653 return TotalNumericMaxOrMin<TypeCategory::Integer, 2, true>(654 x, source, line, dim, mask, "MAXVAL");655}656CppTypeFor<TypeCategory::Integer, 4> RTDEF(MaxvalInteger4)(const Descriptor &x,657 const char *source, int line, int dim, const Descriptor *mask) {658 return TotalNumericMaxOrMin<TypeCategory::Integer, 4, true>(659 x, source, line, dim, mask, "MAXVAL");660}661CppTypeFor<TypeCategory::Integer, 8> RTDEF(MaxvalInteger8)(const Descriptor &x,662 const char *source, int line, int dim, const Descriptor *mask) {663 return TotalNumericMaxOrMin<TypeCategory::Integer, 8, true>(664 x, source, line, dim, mask, "MAXVAL");665}666#ifdef __SIZEOF_INT128__667CppTypeFor<TypeCategory::Integer, 16> RTDEF(MaxvalInteger16)(668 const Descriptor &x, const char *source, int line, int dim,669 const Descriptor *mask) {670 return TotalNumericMaxOrMin<TypeCategory::Integer, 16, true>(671 x, source, line, dim, mask, "MAXVAL");672}673#endif674 675CppTypeFor<TypeCategory::Unsigned, 1> RTDEF(MaxvalUnsigned1)(676 const Descriptor &x, const char *source, int line, int dim,677 const Descriptor *mask) {678 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 1, true>(679 x, source, line, dim, mask, "MAXVAL");680}681CppTypeFor<TypeCategory::Unsigned, 2> RTDEF(MaxvalUnsigned2)(682 const Descriptor &x, const char *source, int line, int dim,683 const Descriptor *mask) {684 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 2, true>(685 x, source, line, dim, mask, "MAXVAL");686}687CppTypeFor<TypeCategory::Unsigned, 4> RTDEF(MaxvalUnsigned4)(688 const Descriptor &x, const char *source, int line, int dim,689 const Descriptor *mask) {690 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 4, true>(691 x, source, line, dim, mask, "MAXVAL");692}693CppTypeFor<TypeCategory::Unsigned, 8> RTDEF(MaxvalUnsigned8)(694 const Descriptor &x, const char *source, int line, int dim,695 const Descriptor *mask) {696 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 8, true>(697 x, source, line, dim, mask, "MAXVAL");698}699#ifdef __SIZEOF_INT128__700CppTypeFor<TypeCategory::Unsigned, 16> RTDEF(MaxvalUnsigned16)(701 const Descriptor &x, const char *source, int line, int dim,702 const Descriptor *mask) {703 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 16, true>(704 x, source, line, dim, mask, "MAXVAL");705}706#endif707 708// TODO: REAL(2 & 3)709CppTypeFor<TypeCategory::Real, 4> RTDEF(MaxvalReal4)(const Descriptor &x,710 const char *source, int line, int dim, const Descriptor *mask) {711 return TotalNumericMaxOrMin<TypeCategory::Real, 4, true>(712 x, source, line, dim, mask, "MAXVAL");713}714CppTypeFor<TypeCategory::Real, 8> RTDEF(MaxvalReal8)(const Descriptor &x,715 const char *source, int line, int dim, const Descriptor *mask) {716 return TotalNumericMaxOrMin<TypeCategory::Real, 8, true>(717 x, source, line, dim, mask, "MAXVAL");718}719#if HAS_FLOAT80720CppTypeFor<TypeCategory::Real, 10> RTDEF(MaxvalReal10)(const Descriptor &x,721 const char *source, int line, int dim, const Descriptor *mask) {722 return TotalNumericMaxOrMin<TypeCategory::Real, 10, true>(723 x, source, line, dim, mask, "MAXVAL");724}725#endif726#if HAS_LDBL128 || HAS_FLOAT128727CppTypeFor<TypeCategory::Real, 16> RTDEF(MaxvalReal16)(const Descriptor &x,728 const char *source, int line, int dim, const Descriptor *mask) {729 return TotalNumericMaxOrMin<TypeCategory::Real, 16, true>(730 x, source, line, dim, mask, "MAXVAL");731}732#endif733 734void RTDEF(MaxvalCharacter)(Descriptor &result, const Descriptor &x,735 const char *source, int line, const Descriptor *mask) {736 CharacterMaxOrMin<true>(result, x, 0, source, line, mask, "MAXVAL");737}738 739CppTypeFor<TypeCategory::Integer, 1> RTDEF(MinvalInteger1)(const Descriptor &x,740 const char *source, int line, int dim, const Descriptor *mask) {741 return TotalNumericMaxOrMin<TypeCategory::Integer, 1, false>(742 x, source, line, dim, mask, "MINVAL");743}744CppTypeFor<TypeCategory::Integer, 2> RTDEF(MinvalInteger2)(const Descriptor &x,745 const char *source, int line, int dim, const Descriptor *mask) {746 return TotalNumericMaxOrMin<TypeCategory::Integer, 2, false>(747 x, source, line, dim, mask, "MINVAL");748}749CppTypeFor<TypeCategory::Integer, 4> RTDEF(MinvalInteger4)(const Descriptor &x,750 const char *source, int line, int dim, const Descriptor *mask) {751 return TotalNumericMaxOrMin<TypeCategory::Integer, 4, false>(752 x, source, line, dim, mask, "MINVAL");753}754CppTypeFor<TypeCategory::Integer, 8> RTDEF(MinvalInteger8)(const Descriptor &x,755 const char *source, int line, int dim, const Descriptor *mask) {756 return TotalNumericMaxOrMin<TypeCategory::Integer, 8, false>(757 x, source, line, dim, mask, "MINVAL");758}759#ifdef __SIZEOF_INT128__760CppTypeFor<TypeCategory::Integer, 16> RTDEF(MinvalInteger16)(761 const Descriptor &x, const char *source, int line, int dim,762 const Descriptor *mask) {763 return TotalNumericMaxOrMin<TypeCategory::Integer, 16, false>(764 x, source, line, dim, mask, "MINVAL");765}766#endif767 768CppTypeFor<TypeCategory::Unsigned, 1> RTDEF(MinvalUnsigned1)(769 const Descriptor &x, const char *source, int line, int dim,770 const Descriptor *mask) {771 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 1, false>(772 x, source, line, dim, mask, "MINVAL");773}774CppTypeFor<TypeCategory::Unsigned, 2> RTDEF(MinvalUnsigned2)(775 const Descriptor &x, const char *source, int line, int dim,776 const Descriptor *mask) {777 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 2, false>(778 x, source, line, dim, mask, "MINVAL");779}780CppTypeFor<TypeCategory::Unsigned, 4> RTDEF(MinvalUnsigned4)(781 const Descriptor &x, const char *source, int line, int dim,782 const Descriptor *mask) {783 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 4, false>(784 x, source, line, dim, mask, "MINVAL");785}786CppTypeFor<TypeCategory::Unsigned, 8> RTDEF(MinvalUnsigned8)(787 const Descriptor &x, const char *source, int line, int dim,788 const Descriptor *mask) {789 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 8, false>(790 x, source, line, dim, mask, "MINVAL");791}792#ifdef __SIZEOF_INT128__793CppTypeFor<TypeCategory::Unsigned, 16> RTDEF(MinvalUnsigned16)(794 const Descriptor &x, const char *source, int line, int dim,795 const Descriptor *mask) {796 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 16, false>(797 x, source, line, dim, mask, "MINVAL");798}799#endif800 801// TODO: REAL(2 & 3)802CppTypeFor<TypeCategory::Real, 4> RTDEF(MinvalReal4)(const Descriptor &x,803 const char *source, int line, int dim, const Descriptor *mask) {804 return TotalNumericMaxOrMin<TypeCategory::Real, 4, false>(805 x, source, line, dim, mask, "MINVAL");806}807CppTypeFor<TypeCategory::Real, 8> RTDEF(MinvalReal8)(const Descriptor &x,808 const char *source, int line, int dim, const Descriptor *mask) {809 return TotalNumericMaxOrMin<TypeCategory::Real, 8, false>(810 x, source, line, dim, mask, "MINVAL");811}812#if HAS_FLOAT80813CppTypeFor<TypeCategory::Real, 10> RTDEF(MinvalReal10)(const Descriptor &x,814 const char *source, int line, int dim, const Descriptor *mask) {815 return TotalNumericMaxOrMin<TypeCategory::Real, 10, false>(816 x, source, line, dim, mask, "MINVAL");817}818#endif819#if HAS_LDBL128 || HAS_FLOAT128820CppTypeFor<TypeCategory::Real, 16> RTDEF(MinvalReal16)(const Descriptor &x,821 const char *source, int line, int dim, const Descriptor *mask) {822 return TotalNumericMaxOrMin<TypeCategory::Real, 16, false>(823 x, source, line, dim, mask, "MINVAL");824}825#endif826 827void RTDEF(MinvalCharacter)(Descriptor &result, const Descriptor &x,828 const char *source, int line, const Descriptor *mask) {829 CharacterMaxOrMin<false>(result, x, 0, source, line, mask, "MINVAL");830}831 832void RTDEF(MaxvalDim)(Descriptor &result, const Descriptor &x, int dim,833 const char *source, int line, const Descriptor *mask) {834 if (x.type().IsCharacter()) {835 CharacterMaxOrMin<true>(result, x, dim, source, line, mask, "MAXVAL");836 } else {837 NumericMaxOrMin<true>(result, x, dim, source, line, mask, "MAXVAL");838 }839}840void RTDEF(MinvalDim)(Descriptor &result, const Descriptor &x, int dim,841 const char *source, int line, const Descriptor *mask) {842 if (x.type().IsCharacter()) {843 CharacterMaxOrMin<false>(result, x, dim, source, line, mask, "MINVAL");844 } else {845 NumericMaxOrMin<false>(result, x, dim, source, line, mask, "MINVAL");846 }847}848 849RT_EXT_API_GROUP_END850} // extern "C"851 852// NORM2853 854extern "C" {855RT_EXT_API_GROUP_BEGIN856 857// TODO: REAL(2 & 3)858CppTypeFor<TypeCategory::Real, 4> RTDEF(Norm2_4)(859 const Descriptor &x, const char *source, int line, int dim) {860 return GetTotalReduction<TypeCategory::Real, 4>(861 x, source, line, dim, nullptr, Norm2Accumulator<4>{x}, "NORM2");862}863CppTypeFor<TypeCategory::Real, 8> RTDEF(Norm2_8)(864 const Descriptor &x, const char *source, int line, int dim) {865 return GetTotalReduction<TypeCategory::Real, 8>(866 x, source, line, dim, nullptr, Norm2Accumulator<8>{x}, "NORM2");867}868#if HAS_FLOAT80869CppTypeFor<TypeCategory::Real, 10> RTDEF(Norm2_10)(870 const Descriptor &x, const char *source, int line, int dim) {871 return GetTotalReduction<TypeCategory::Real, 10>(872 x, source, line, dim, nullptr, Norm2Accumulator<10>{x}, "NORM2");873}874#endif875 876void RTDEF(Norm2Dim)(Descriptor &result, const Descriptor &x, int dim,877 const char *source, int line) {878 Terminator terminator{source, line};879 auto type{x.type().GetCategoryAndKind()};880 RUNTIME_CHECK(terminator, type);881 if (type->first == TypeCategory::Real) {882 ApplyFloatingPointKind<Norm2Helper, void, true>(883 type->second, terminator, result, x, dim, nullptr, terminator);884 } else {885 terminator.Crash("NORM2: bad type code %d", x.type().raw());886 }887}888 889RT_EXT_API_GROUP_END890} // extern "C"891} // namespace Fortran::runtime892