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/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 23 namespace Fortran::runtime { 24 25 // MAXLOC & MINLOC 26 27 template <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 NaN 33 } 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 43 template <typename T, bool IS_MAX, bool BACK> class CharacterCompare { 44 public: 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 59 private: 60 std::size_t chars_; 61 }; 62 63 template <typename COMPARE> class ExtremumLocAccumulator { 64 public: 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 data 72 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 100 private: 101 const Descriptor &array_; 102 int argRank_; 103 SubscriptValue extremumLoc_[maxRank]; 104 const Type *previous_{nullptr}; 105 COMPARE compare_; 106 }; 107 108 template <typename ACCUMULATOR, typename CPPTYPE> 109 static 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 118 template <TypeCategory CAT, int KIND, bool IS_MAX, 119 template <typename, bool, bool> class COMPARE> 120 inline 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 134 template <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 145 template <bool IS_MAX> 146 inline 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()}) { 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 174 template <TypeCategory CAT, int KIND, bool IS_MAXVAL> 175 inline 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()}) { 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 194 extern "C" { 195 RT_EXT_API_GROUP_BEGIN 196 197 void 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 } 202 void 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 } 207 void 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 } 212 void 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 } 217 void 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__ 223 void 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 #endif 229 void 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 } 234 void 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 } 239 void 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 } 244 void 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__ 250 void 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 #endif 256 void 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 } 261 void 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_FLOAT80 267 void 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 #endif 273 #if HAS_LDBL128 || HAS_FLOAT128 274 void 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 #endif 280 void 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 } 285 void 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 } 290 void 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 } 295 void 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 } 300 void 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__ 306 void 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 #endif 312 void 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 } 317 void 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 } 322 void 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 } 327 void 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__ 333 void 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 #endif 339 void 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 } 344 void 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_FLOAT80 350 void 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 #endif 356 #if HAS_LDBL128 || HAS_FLOAT128 357 void 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 #endif 363 364 RT_EXT_API_GROUP_END 365 } // extern "C" 366 367 // MAXLOC/MINLOC with DIM= 368 369 template <TypeCategory CAT, int KIND, bool IS_MAX, 370 template <typename, bool, bool> class COMPARE, bool BACK> 371 static 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 382 template <TypeCategory CAT, int KIND, bool IS_MAX, 383 template <typename, bool, bool> class COMPARE> 384 inline 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 396 template <TypeCategory CAT, bool IS_MAX, 397 template <typename, bool, bool> class COMPARE> 398 struct DoPartialMaxOrMinLocHelper { 399 template <int KIND> struct Functor { 400 RT_API_ATTRS void operator()(const char *intrinsic, Descriptor &result, 401 const Descriptor &x, int kind, int dim, const Descriptor *mask, 402 bool back, Terminator &terminator) const { 403 DoPartialMaxOrMinLoc<CAT, KIND, IS_MAX, COMPARE>( 404 intrinsic, result, x, kind, dim, mask, back, terminator); 405 } 406 }; 407 }; 408 409 template <bool IS_MAX> 410 inline RT_API_ATTRS void TypedPartialMaxOrMinLoc(const char *intrinsic, 411 Descriptor &result, const Descriptor &x, int kind, int dim, 412 const char *source, int line, const Descriptor *mask, bool back) { 413 Terminator terminator{source, line}; 414 CheckIntegerKind(terminator, kind, intrinsic); 415 auto catKind{x.type().GetCategoryAndKind()}; 416 RUNTIME_CHECK(terminator, catKind.has_value()); 417 const Descriptor *maskToUse{mask}; 418 SubscriptValue maskAt[maxRank]; // contents unused 419 if (mask && mask->rank() == 0) { 420 if (IsLogicalElementTrue(*mask, maskAt)) { 421 // A scalar MASK that's .TRUE. In this case, just get rid of the MASK. 422 maskToUse = nullptr; 423 } else { 424 // For scalar MASK arguments that are .FALSE., return all zeroes 425 426 // Element size of the destination descriptor is the size 427 // of {TypeCategory::Integer, kind}. 428 CreatePartialReductionResult(result, x, 429 Descriptor::BytesFor(TypeCategory::Integer, kind), dim, terminator, 430 intrinsic, TypeCode{TypeCategory::Integer, kind}); 431 std::memset( 432 result.OffsetElement(), 0, result.Elements() * result.ElementBytes()); 433 return; 434 } 435 } 436 switch (catKind->first) { 437 case TypeCategory::Integer: 438 ApplyIntegerKind<DoPartialMaxOrMinLocHelper<TypeCategory::Integer, IS_MAX, 439 NumericCompare>::template Functor, 440 void>(catKind->second, terminator, intrinsic, result, x, kind, dim, 441 maskToUse, back, terminator); 442 break; 443 case TypeCategory::Unsigned: 444 ApplyIntegerKind<DoPartialMaxOrMinLocHelper<TypeCategory::Unsigned, IS_MAX, 445 NumericCompare>::template Functor, 446 void>(catKind->second, terminator, intrinsic, result, x, kind, dim, 447 maskToUse, back, terminator); 448 break; 449 case TypeCategory::Real: 450 ApplyFloatingPointKind<DoPartialMaxOrMinLocHelper<TypeCategory::Real, 451 IS_MAX, NumericCompare>::template Functor, 452 void>(catKind->second, terminator, intrinsic, result, x, kind, dim, 453 maskToUse, back, terminator); 454 break; 455 case TypeCategory::Character: 456 ApplyCharacterKind<DoPartialMaxOrMinLocHelper<TypeCategory::Character, 457 IS_MAX, CharacterCompare>::template Functor, 458 void>(catKind->second, terminator, intrinsic, result, x, kind, dim, 459 maskToUse, back, terminator); 460 break; 461 default: 462 terminator.Crash( 463 "%s: bad data type code (%d) for array", intrinsic, x.type().raw()); 464 } 465 } 466 467 extern "C" { 468 RT_EXT_API_GROUP_BEGIN 469 470 void RTDEF(MaxlocDim)(Descriptor &result, const Descriptor &x, int kind, 471 int dim, const char *source, int line, const Descriptor *mask, bool back) { 472 TypedPartialMaxOrMinLoc<true>( 473 "MAXLOC", result, x, kind, dim, source, line, mask, back); 474 } 475 void RTDEF(MinlocDim)(Descriptor &result, const Descriptor &x, int kind, 476 int dim, const char *source, int line, const Descriptor *mask, bool back) { 477 TypedPartialMaxOrMinLoc<false>( 478 "MINLOC", result, x, kind, dim, source, line, mask, back); 479 } 480 481 RT_EXT_API_GROUP_END 482 } // extern "C" 483 484 // MAXVAL and MINVAL 485 486 template <TypeCategory CAT, int KIND, bool IS_MAXVAL> 487 class NumericExtremumAccumulator { 488 public: 489 using Type = CppTypeFor<CAT, KIND>; 490 explicit RT_API_ATTRS NumericExtremumAccumulator(const Descriptor &array) 491 : array_{array} {} 492 RT_API_ATTRS void Reinitialize() { 493 any_ = false; 494 extremum_ = MaxOrMinIdentity<CAT, KIND, IS_MAXVAL>::Value(); 495 } 496 template <typename A> 497 RT_API_ATTRS void GetResult(A *p, int /*zeroBasedDim*/ = -1) const { 498 *p = extremum_; 499 } 500 RT_API_ATTRS bool Accumulate(Type x) { 501 if (!any_) { 502 extremum_ = x; 503 any_ = true; 504 } else if (CAT == TypeCategory::Real && extremum_ != extremum_) { 505 extremum_ = x; // replace NaN 506 } else if constexpr (IS_MAXVAL) { 507 if (x > extremum_) { 508 extremum_ = x; 509 } 510 } else if (x < extremum_) { 511 extremum_ = x; 512 } 513 return true; 514 } 515 template <typename A> 516 RT_API_ATTRS bool AccumulateAt(const SubscriptValue at[]) { 517 return Accumulate(*array_.Element<A>(at)); 518 } 519 520 private: 521 const Descriptor &array_; 522 bool any_{false}; 523 Type extremum_{MaxOrMinIdentity<CAT, KIND, IS_MAXVAL>::Value()}; 524 }; 525 526 template <TypeCategory CAT, int KIND, bool IS_MAXVAL> 527 inline RT_API_ATTRS CppTypeFor<CAT, KIND> TotalNumericMaxOrMin( 528 const Descriptor &x, const char *source, int line, int dim, 529 const Descriptor *mask, const char *intrinsic) { 530 return GetTotalReduction<CAT, KIND>(x, source, line, dim, mask, 531 NumericExtremumAccumulator<CAT, KIND, IS_MAXVAL>{x}, intrinsic); 532 } 533 534 template <TypeCategory CAT, bool IS_MAXVAL> struct MaxOrMinHelper { 535 template <int KIND> struct Functor { 536 RT_API_ATTRS void operator()(Descriptor &result, const Descriptor &x, 537 int dim, const Descriptor *mask, const char *intrinsic, 538 Terminator &terminator) const { 539 DoMaxMinNorm2<CAT, KIND, 540 NumericExtremumAccumulator<CAT, KIND, IS_MAXVAL>>( 541 result, x, dim, mask, intrinsic, terminator); 542 } 543 }; 544 }; 545 546 template <bool IS_MAXVAL> 547 inline RT_API_ATTRS void NumericMaxOrMin(Descriptor &result, 548 const Descriptor &x, int dim, const char *source, int line, 549 const Descriptor *mask, const char *intrinsic) { 550 Terminator terminator{source, line}; 551 auto type{x.type().GetCategoryAndKind()}; 552 RUNTIME_CHECK(terminator, type); 553 switch (type->first) { 554 case TypeCategory::Integer: 555 ApplyIntegerKind< 556 MaxOrMinHelper<TypeCategory::Integer, IS_MAXVAL>::template Functor, 557 void>( 558 type->second, terminator, result, x, dim, mask, intrinsic, terminator); 559 break; 560 case TypeCategory::Unsigned: 561 ApplyIntegerKind< 562 MaxOrMinHelper<TypeCategory::Unsigned, IS_MAXVAL>::template Functor, 563 void>( 564 type->second, terminator, result, x, dim, mask, intrinsic, terminator); 565 break; 566 case TypeCategory::Real: 567 ApplyFloatingPointKind< 568 MaxOrMinHelper<TypeCategory::Real, IS_MAXVAL>::template Functor, void>( 569 type->second, terminator, result, x, dim, mask, intrinsic, terminator); 570 break; 571 default: 572 terminator.Crash("%s: bad type code %d", intrinsic, x.type().raw()); 573 } 574 } 575 576 template <int KIND, bool IS_MAXVAL> class CharacterExtremumAccumulator { 577 public: 578 using Type = CppTypeFor<TypeCategory::Character, KIND>; 579 explicit RT_API_ATTRS CharacterExtremumAccumulator(const Descriptor &array) 580 : array_{array}, charLen_{array_.ElementBytes() / KIND} {} 581 RT_API_ATTRS void Reinitialize() { extremum_ = nullptr; } 582 template <typename A> 583 RT_API_ATTRS void GetResult(A *p, int /*zeroBasedDim*/ = -1) const { 584 static_assert(std::is_same_v<A, Type>); 585 std::size_t byteSize{array_.ElementBytes()}; 586 if (extremum_) { 587 std::memcpy(p, extremum_, byteSize); 588 } else { 589 // Empty array; fill with character 0 for MAXVAL. 590 // For MINVAL, set all of the bits. 591 std::memset(p, IS_MAXVAL ? 0 : 255, byteSize); 592 } 593 } 594 RT_API_ATTRS bool Accumulate(const Type *x) { 595 if (!extremum_) { 596 extremum_ = x; 597 } else { 598 int cmp{CharacterScalarCompare(x, extremum_, charLen_, charLen_)}; 599 if (IS_MAXVAL == (cmp > 0)) { 600 extremum_ = x; 601 } 602 } 603 return true; 604 } 605 template <typename A> 606 RT_API_ATTRS bool AccumulateAt(const SubscriptValue at[]) { 607 return Accumulate(array_.Element<A>(at)); 608 } 609 610 private: 611 const Descriptor &array_; 612 std::size_t charLen_; 613 const Type *extremum_{nullptr}; 614 }; 615 616 template <bool IS_MAXVAL> struct CharacterMaxOrMinHelper { 617 template <int KIND> struct Functor { 618 RT_API_ATTRS void operator()(Descriptor &result, const Descriptor &x, 619 int dim, const Descriptor *mask, const char *intrinsic, 620 Terminator &terminator) const { 621 DoMaxMinNorm2<TypeCategory::Character, KIND, 622 CharacterExtremumAccumulator<KIND, IS_MAXVAL>>( 623 result, x, dim, mask, intrinsic, terminator); 624 } 625 }; 626 }; 627 628 template <bool IS_MAXVAL> 629 inline RT_API_ATTRS void CharacterMaxOrMin(Descriptor &result, 630 const Descriptor &x, int dim, const char *source, int line, 631 const Descriptor *mask, const char *intrinsic) { 632 Terminator terminator{source, line}; 633 auto type{x.type().GetCategoryAndKind()}; 634 RUNTIME_CHECK(terminator, type && type->first == TypeCategory::Character); 635 ApplyCharacterKind<CharacterMaxOrMinHelper<IS_MAXVAL>::template Functor, 636 void>( 637 type->second, terminator, result, x, dim, mask, intrinsic, terminator); 638 } 639 640 extern "C" { 641 RT_EXT_API_GROUP_BEGIN 642 643 CppTypeFor<TypeCategory::Integer, 1> RTDEF(MaxvalInteger1)(const Descriptor &x, 644 const char *source, int line, int dim, const Descriptor *mask) { 645 return TotalNumericMaxOrMin<TypeCategory::Integer, 1, true>( 646 x, source, line, dim, mask, "MAXVAL"); 647 } 648 CppTypeFor<TypeCategory::Integer, 2> RTDEF(MaxvalInteger2)(const Descriptor &x, 649 const char *source, int line, int dim, const Descriptor *mask) { 650 return TotalNumericMaxOrMin<TypeCategory::Integer, 2, true>( 651 x, source, line, dim, mask, "MAXVAL"); 652 } 653 CppTypeFor<TypeCategory::Integer, 4> RTDEF(MaxvalInteger4)(const Descriptor &x, 654 const char *source, int line, int dim, const Descriptor *mask) { 655 return TotalNumericMaxOrMin<TypeCategory::Integer, 4, true>( 656 x, source, line, dim, mask, "MAXVAL"); 657 } 658 CppTypeFor<TypeCategory::Integer, 8> RTDEF(MaxvalInteger8)(const Descriptor &x, 659 const char *source, int line, int dim, const Descriptor *mask) { 660 return TotalNumericMaxOrMin<TypeCategory::Integer, 8, true>( 661 x, source, line, dim, mask, "MAXVAL"); 662 } 663 #ifdef __SIZEOF_INT128__ 664 CppTypeFor<TypeCategory::Integer, 16> RTDEF(MaxvalInteger16)( 665 const Descriptor &x, const char *source, int line, int dim, 666 const Descriptor *mask) { 667 return TotalNumericMaxOrMin<TypeCategory::Integer, 16, true>( 668 x, source, line, dim, mask, "MAXVAL"); 669 } 670 #endif 671 672 CppTypeFor<TypeCategory::Unsigned, 1> RTDEF(MaxvalUnsigned1)( 673 const Descriptor &x, const char *source, int line, int dim, 674 const Descriptor *mask) { 675 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 1, true>( 676 x, source, line, dim, mask, "MAXVAL"); 677 } 678 CppTypeFor<TypeCategory::Unsigned, 2> RTDEF(MaxvalUnsigned2)( 679 const Descriptor &x, const char *source, int line, int dim, 680 const Descriptor *mask) { 681 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 2, true>( 682 x, source, line, dim, mask, "MAXVAL"); 683 } 684 CppTypeFor<TypeCategory::Unsigned, 4> RTDEF(MaxvalUnsigned4)( 685 const Descriptor &x, const char *source, int line, int dim, 686 const Descriptor *mask) { 687 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 4, true>( 688 x, source, line, dim, mask, "MAXVAL"); 689 } 690 CppTypeFor<TypeCategory::Unsigned, 8> RTDEF(MaxvalUnsigned8)( 691 const Descriptor &x, const char *source, int line, int dim, 692 const Descriptor *mask) { 693 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 8, true>( 694 x, source, line, dim, mask, "MAXVAL"); 695 } 696 #ifdef __SIZEOF_INT128__ 697 CppTypeFor<TypeCategory::Unsigned, 16> RTDEF(MaxvalUnsigned16)( 698 const Descriptor &x, const char *source, int line, int dim, 699 const Descriptor *mask) { 700 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 16, true>( 701 x, source, line, dim, mask, "MAXVAL"); 702 } 703 #endif 704 705 // TODO: REAL(2 & 3) 706 CppTypeFor<TypeCategory::Real, 4> RTDEF(MaxvalReal4)(const Descriptor &x, 707 const char *source, int line, int dim, const Descriptor *mask) { 708 return TotalNumericMaxOrMin<TypeCategory::Real, 4, true>( 709 x, source, line, dim, mask, "MAXVAL"); 710 } 711 CppTypeFor<TypeCategory::Real, 8> RTDEF(MaxvalReal8)(const Descriptor &x, 712 const char *source, int line, int dim, const Descriptor *mask) { 713 return TotalNumericMaxOrMin<TypeCategory::Real, 8, true>( 714 x, source, line, dim, mask, "MAXVAL"); 715 } 716 #if HAS_FLOAT80 717 CppTypeFor<TypeCategory::Real, 10> RTDEF(MaxvalReal10)(const Descriptor &x, 718 const char *source, int line, int dim, const Descriptor *mask) { 719 return TotalNumericMaxOrMin<TypeCategory::Real, 10, true>( 720 x, source, line, dim, mask, "MAXVAL"); 721 } 722 #endif 723 #if HAS_LDBL128 || HAS_FLOAT128 724 CppTypeFor<TypeCategory::Real, 16> RTDEF(MaxvalReal16)(const Descriptor &x, 725 const char *source, int line, int dim, const Descriptor *mask) { 726 return TotalNumericMaxOrMin<TypeCategory::Real, 16, true>( 727 x, source, line, dim, mask, "MAXVAL"); 728 } 729 #endif 730 731 void RTDEF(MaxvalCharacter)(Descriptor &result, const Descriptor &x, 732 const char *source, int line, const Descriptor *mask) { 733 CharacterMaxOrMin<true>(result, x, 0, source, line, mask, "MAXVAL"); 734 } 735 736 CppTypeFor<TypeCategory::Integer, 1> RTDEF(MinvalInteger1)(const Descriptor &x, 737 const char *source, int line, int dim, const Descriptor *mask) { 738 return TotalNumericMaxOrMin<TypeCategory::Integer, 1, false>( 739 x, source, line, dim, mask, "MINVAL"); 740 } 741 CppTypeFor<TypeCategory::Integer, 2> RTDEF(MinvalInteger2)(const Descriptor &x, 742 const char *source, int line, int dim, const Descriptor *mask) { 743 return TotalNumericMaxOrMin<TypeCategory::Integer, 2, false>( 744 x, source, line, dim, mask, "MINVAL"); 745 } 746 CppTypeFor<TypeCategory::Integer, 4> RTDEF(MinvalInteger4)(const Descriptor &x, 747 const char *source, int line, int dim, const Descriptor *mask) { 748 return TotalNumericMaxOrMin<TypeCategory::Integer, 4, false>( 749 x, source, line, dim, mask, "MINVAL"); 750 } 751 CppTypeFor<TypeCategory::Integer, 8> RTDEF(MinvalInteger8)(const Descriptor &x, 752 const char *source, int line, int dim, const Descriptor *mask) { 753 return TotalNumericMaxOrMin<TypeCategory::Integer, 8, false>( 754 x, source, line, dim, mask, "MINVAL"); 755 } 756 #ifdef __SIZEOF_INT128__ 757 CppTypeFor<TypeCategory::Integer, 16> RTDEF(MinvalInteger16)( 758 const Descriptor &x, const char *source, int line, int dim, 759 const Descriptor *mask) { 760 return TotalNumericMaxOrMin<TypeCategory::Integer, 16, false>( 761 x, source, line, dim, mask, "MINVAL"); 762 } 763 #endif 764 765 CppTypeFor<TypeCategory::Unsigned, 1> RTDEF(MinvalUnsigned1)( 766 const Descriptor &x, const char *source, int line, int dim, 767 const Descriptor *mask) { 768 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 1, false>( 769 x, source, line, dim, mask, "MINVAL"); 770 } 771 CppTypeFor<TypeCategory::Unsigned, 2> RTDEF(MinvalUnsigned2)( 772 const Descriptor &x, const char *source, int line, int dim, 773 const Descriptor *mask) { 774 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 2, false>( 775 x, source, line, dim, mask, "MINVAL"); 776 } 777 CppTypeFor<TypeCategory::Unsigned, 4> RTDEF(MinvalUnsigned4)( 778 const Descriptor &x, const char *source, int line, int dim, 779 const Descriptor *mask) { 780 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 4, false>( 781 x, source, line, dim, mask, "MINVAL"); 782 } 783 CppTypeFor<TypeCategory::Unsigned, 8> RTDEF(MinvalUnsigned8)( 784 const Descriptor &x, const char *source, int line, int dim, 785 const Descriptor *mask) { 786 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 8, false>( 787 x, source, line, dim, mask, "MINVAL"); 788 } 789 #ifdef __SIZEOF_INT128__ 790 CppTypeFor<TypeCategory::Unsigned, 16> RTDEF(MinvalUnsigned16)( 791 const Descriptor &x, const char *source, int line, int dim, 792 const Descriptor *mask) { 793 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 16, false>( 794 x, source, line, dim, mask, "MINVAL"); 795 } 796 #endif 797 798 // TODO: REAL(2 & 3) 799 CppTypeFor<TypeCategory::Real, 4> RTDEF(MinvalReal4)(const Descriptor &x, 800 const char *source, int line, int dim, const Descriptor *mask) { 801 return TotalNumericMaxOrMin<TypeCategory::Real, 4, false>( 802 x, source, line, dim, mask, "MINVAL"); 803 } 804 CppTypeFor<TypeCategory::Real, 8> RTDEF(MinvalReal8)(const Descriptor &x, 805 const char *source, int line, int dim, const Descriptor *mask) { 806 return TotalNumericMaxOrMin<TypeCategory::Real, 8, false>( 807 x, source, line, dim, mask, "MINVAL"); 808 } 809 #if HAS_FLOAT80 810 CppTypeFor<TypeCategory::Real, 10> RTDEF(MinvalReal10)(const Descriptor &x, 811 const char *source, int line, int dim, const Descriptor *mask) { 812 return TotalNumericMaxOrMin<TypeCategory::Real, 10, false>( 813 x, source, line, dim, mask, "MINVAL"); 814 } 815 #endif 816 #if HAS_LDBL128 || HAS_FLOAT128 817 CppTypeFor<TypeCategory::Real, 16> RTDEF(MinvalReal16)(const Descriptor &x, 818 const char *source, int line, int dim, const Descriptor *mask) { 819 return TotalNumericMaxOrMin<TypeCategory::Real, 16, false>( 820 x, source, line, dim, mask, "MINVAL"); 821 } 822 #endif 823 824 void RTDEF(MinvalCharacter)(Descriptor &result, const Descriptor &x, 825 const char *source, int line, const Descriptor *mask) { 826 CharacterMaxOrMin<false>(result, x, 0, source, line, mask, "MINVAL"); 827 } 828 829 void RTDEF(MaxvalDim)(Descriptor &result, const Descriptor &x, int dim, 830 const char *source, int line, const Descriptor *mask) { 831 if (x.type().IsCharacter()) { 832 CharacterMaxOrMin<true>(result, x, dim, source, line, mask, "MAXVAL"); 833 } else { 834 NumericMaxOrMin<true>(result, x, dim, source, line, mask, "MAXVAL"); 835 } 836 } 837 void RTDEF(MinvalDim)(Descriptor &result, const Descriptor &x, int dim, 838 const char *source, int line, const Descriptor *mask) { 839 if (x.type().IsCharacter()) { 840 CharacterMaxOrMin<false>(result, x, dim, source, line, mask, "MINVAL"); 841 } else { 842 NumericMaxOrMin<false>(result, x, dim, source, line, mask, "MINVAL"); 843 } 844 } 845 846 RT_EXT_API_GROUP_END 847 } // extern "C" 848 849 // NORM2 850 851 extern "C" { 852 RT_EXT_API_GROUP_BEGIN 853 854 // TODO: REAL(2 & 3) 855 CppTypeFor<TypeCategory::Real, 4> RTDEF(Norm2_4)( 856 const Descriptor &x, const char *source, int line, int dim) { 857 return GetTotalReduction<TypeCategory::Real, 4>( 858 x, source, line, dim, nullptr, Norm2Accumulator<4>{x}, "NORM2"); 859 } 860 CppTypeFor<TypeCategory::Real, 8> RTDEF(Norm2_8)( 861 const Descriptor &x, const char *source, int line, int dim) { 862 return GetTotalReduction<TypeCategory::Real, 8>( 863 x, source, line, dim, nullptr, Norm2Accumulator<8>{x}, "NORM2"); 864 } 865 #if HAS_FLOAT80 866 CppTypeFor<TypeCategory::Real, 10> RTDEF(Norm2_10)( 867 const Descriptor &x, const char *source, int line, int dim) { 868 return GetTotalReduction<TypeCategory::Real, 10>( 869 x, source, line, dim, nullptr, Norm2Accumulator<10>{x}, "NORM2"); 870 } 871 #endif 872 873 void RTDEF(Norm2Dim)(Descriptor &result, const Descriptor &x, int dim, 874 const char *source, int line) { 875 Terminator terminator{source, line}; 876 auto type{x.type().GetCategoryAndKind()}; 877 RUNTIME_CHECK(terminator, type); 878 if (type->first == TypeCategory::Real) { 879 ApplyFloatingPointKind<Norm2Helper, void, true>( 880 type->second, terminator, result, x, dim, nullptr, terminator); 881 } else { 882 terminator.Crash("NORM2: bad type code %d", x.type().raw()); 883 } 884 } 885 886 RT_EXT_API_GROUP_END 887 } // extern "C" 888 } // namespace Fortran::runtime 889