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 "stat.h" 13 #include "terminator.h" 14 #include "flang/Common/optional.h" 15 #include "flang/Runtime/cpp-type.h" 16 #include "flang/Runtime/descriptor.h" 17 #include "flang/Runtime/freestanding-tools.h" 18 #include "flang/Runtime/memory.h" 19 #include <cstring> 20 #include <functional> 21 #include <map> 22 #include <type_traits> 23 24 /// \macro RT_PRETTY_FUNCTION 25 /// Gets a user-friendly looking function signature for the current scope 26 /// using the best available method on each platform. The exact format of the 27 /// resulting string is implementation specific and non-portable, so this should 28 /// only be used, for example, for logging or diagnostics. 29 /// Copy of LLVM_PRETTY_FUNCTION 30 #if defined(_MSC_VER) 31 #define RT_PRETTY_FUNCTION __FUNCSIG__ 32 #elif defined(__GNUC__) || defined(__clang__) 33 #define RT_PRETTY_FUNCTION __PRETTY_FUNCTION__ 34 #else 35 #define RT_PRETTY_FUNCTION __func__ 36 #endif 37 38 #if defined(RT_DEVICE_COMPILATION) 39 // Use the pseudo lock and pseudo file unit implementations 40 // for the device. 41 #define RT_USE_PSEUDO_LOCK 1 42 #define RT_USE_PSEUDO_FILE_UNIT 1 43 #endif 44 45 namespace Fortran::runtime { 46 47 class Terminator; 48 49 RT_API_ATTRS std::size_t TrimTrailingSpaces(const char *, std::size_t); 50 51 RT_API_ATTRS OwningPtr<char> SaveDefaultCharacter( 52 const char *, std::size_t, const Terminator &); 53 54 // For validating and recognizing default CHARACTER values in a 55 // case-insensitive manner. Returns the zero-based index into the 56 // null-terminated array of upper-case possibilities when the value is valid, 57 // or -1 when it has no match. 58 RT_API_ATTRS int IdentifyValue( 59 const char *value, std::size_t length, const char *possibilities[]); 60 61 // Truncates or pads as necessary 62 RT_API_ATTRS void ToFortranDefaultCharacter( 63 char *to, std::size_t toLength, const char *from); 64 65 // Utilities for dealing with elemental LOGICAL arguments 66 inline RT_API_ATTRS bool IsLogicalElementTrue( 67 const Descriptor &logical, const SubscriptValue at[]) { 68 // A LOGICAL value is false if and only if all of its bytes are zero. 69 const char *p{logical.Element<char>(at)}; 70 for (std::size_t j{logical.ElementBytes()}; j-- > 0; ++p) { 71 if (*p) { 72 return true; 73 } 74 } 75 return false; 76 } 77 inline RT_API_ATTRS bool IsLogicalScalarTrue(const Descriptor &logical) { 78 // A LOGICAL value is false if and only if all of its bytes are zero. 79 const char *p{logical.OffsetElement<char>()}; 80 for (std::size_t j{logical.ElementBytes()}; j-- > 0; ++p) { 81 if (*p) { 82 return true; 83 } 84 } 85 return false; 86 } 87 88 // Check array conformability; a scalar 'x' conforms. Crashes on error. 89 RT_API_ATTRS void CheckConformability(const Descriptor &to, const Descriptor &x, 90 Terminator &, const char *funcName, const char *toName, 91 const char *fromName); 92 93 // Helper to store integer value in result[at]. 94 template <int KIND> struct StoreIntegerAt { 95 RT_API_ATTRS void operator()(const Fortran::runtime::Descriptor &result, 96 std::size_t at, std::int64_t value) const { 97 *result.ZeroBasedIndexedElement<Fortran::runtime::CppTypeFor< 98 Fortran::common::TypeCategory::Integer, KIND>>(at) = value; 99 } 100 }; 101 102 // Helper to store floating value in result[at]. 103 template <int KIND> struct StoreFloatingPointAt { 104 RT_API_ATTRS void operator()(const Fortran::runtime::Descriptor &result, 105 std::size_t at, std::double_t value) const { 106 *result.ZeroBasedIndexedElement<Fortran::runtime::CppTypeFor< 107 Fortran::common::TypeCategory::Real, KIND>>(at) = value; 108 } 109 }; 110 111 // Validate a KIND= argument 112 RT_API_ATTRS void CheckIntegerKind( 113 Terminator &, int kind, const char *intrinsic); 114 115 template <typename TO, typename FROM> 116 inline RT_API_ATTRS void PutContiguousConverted( 117 TO *to, FROM *from, std::size_t count) { 118 while (count-- > 0) { 119 *to++ = *from++; 120 } 121 } 122 123 static inline RT_API_ATTRS std::int64_t GetInt64( 124 const char *p, std::size_t bytes, Terminator &terminator) { 125 switch (bytes) { 126 case 1: 127 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 1> *>(p); 128 case 2: 129 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 2> *>(p); 130 case 4: 131 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 4> *>(p); 132 case 8: 133 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 8> *>(p); 134 default: 135 terminator.Crash("GetInt64: no case for %zd bytes", bytes); 136 } 137 } 138 139 static inline RT_API_ATTRS Fortran::common::optional<std::int64_t> GetInt64Safe( 140 const char *p, std::size_t bytes, Terminator &terminator) { 141 switch (bytes) { 142 case 1: 143 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 1> *>(p); 144 case 2: 145 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 2> *>(p); 146 case 4: 147 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 4> *>(p); 148 case 8: 149 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 8> *>(p); 150 case 16: { 151 using Int128 = CppTypeFor<TypeCategory::Integer, 16>; 152 auto n{*reinterpret_cast<const Int128 *>(p)}; 153 std::int64_t result{static_cast<std::int64_t>(n)}; 154 if (static_cast<Int128>(result) == n) { 155 return result; 156 } 157 return Fortran::common::nullopt; 158 } 159 default: 160 terminator.Crash("GetInt64Safe: no case for %zd bytes", bytes); 161 } 162 } 163 164 template <typename INT> 165 inline RT_API_ATTRS bool SetInteger(INT &x, int kind, std::int64_t value) { 166 switch (kind) { 167 case 1: 168 reinterpret_cast<CppTypeFor<TypeCategory::Integer, 1> &>(x) = value; 169 return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 1> &>(x); 170 case 2: 171 reinterpret_cast<CppTypeFor<TypeCategory::Integer, 2> &>(x) = value; 172 return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 2> &>(x); 173 case 4: 174 reinterpret_cast<CppTypeFor<TypeCategory::Integer, 4> &>(x) = value; 175 return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 4> &>(x); 176 case 8: 177 reinterpret_cast<CppTypeFor<TypeCategory::Integer, 8> &>(x) = value; 178 return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 8> &>(x); 179 default: 180 return false; 181 } 182 } 183 184 // Maps intrinsic runtime type category and kind values to the appropriate 185 // instantiation of a function object template and calls it with the supplied 186 // arguments. 187 template <template <TypeCategory, int> class FUNC, typename RESULT, 188 typename... A> 189 inline RT_API_ATTRS RESULT ApplyType( 190 TypeCategory cat, int kind, Terminator &terminator, A &&...x) { 191 switch (cat) { 192 case TypeCategory::Integer: 193 switch (kind) { 194 case 1: 195 return FUNC<TypeCategory::Integer, 1>{}(std::forward<A>(x)...); 196 case 2: 197 return FUNC<TypeCategory::Integer, 2>{}(std::forward<A>(x)...); 198 case 4: 199 return FUNC<TypeCategory::Integer, 4>{}(std::forward<A>(x)...); 200 case 8: 201 return FUNC<TypeCategory::Integer, 8>{}(std::forward<A>(x)...); 202 #if defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T 203 case 16: 204 return FUNC<TypeCategory::Integer, 16>{}(std::forward<A>(x)...); 205 #endif 206 default: 207 terminator.Crash("not yet implemented: INTEGER(KIND=%d)", kind); 208 } 209 case TypeCategory::Unsigned: 210 switch (kind) { 211 case 1: 212 return FUNC<TypeCategory::Unsigned, 1>{}(std::forward<A>(x)...); 213 case 2: 214 return FUNC<TypeCategory::Unsigned, 2>{}(std::forward<A>(x)...); 215 case 4: 216 return FUNC<TypeCategory::Unsigned, 4>{}(std::forward<A>(x)...); 217 case 8: 218 return FUNC<TypeCategory::Unsigned, 8>{}(std::forward<A>(x)...); 219 #if defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T 220 case 16: 221 return FUNC<TypeCategory::Unsigned, 16>{}(std::forward<A>(x)...); 222 #endif 223 default: 224 terminator.Crash("not yet implemented: UNSIGNED(KIND=%d)", kind); 225 } 226 case TypeCategory::Real: 227 switch (kind) { 228 #if 0 // TODO: REAL(2 & 3) 229 case 2: 230 return FUNC<TypeCategory::Real, 2>{}(std::forward<A>(x)...); 231 case 3: 232 return FUNC<TypeCategory::Real, 3>{}(std::forward<A>(x)...); 233 #endif 234 case 4: 235 return FUNC<TypeCategory::Real, 4>{}(std::forward<A>(x)...); 236 case 8: 237 return FUNC<TypeCategory::Real, 8>{}(std::forward<A>(x)...); 238 case 10: 239 if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) { 240 return FUNC<TypeCategory::Real, 10>{}(std::forward<A>(x)...); 241 } 242 break; 243 case 16: 244 if constexpr (HasCppTypeFor<TypeCategory::Real, 16>) { 245 return FUNC<TypeCategory::Real, 16>{}(std::forward<A>(x)...); 246 } 247 break; 248 } 249 terminator.Crash("not yet implemented: REAL(KIND=%d)", kind); 250 case TypeCategory::Complex: 251 switch (kind) { 252 #if 0 // TODO: COMPLEX(2 & 3) 253 case 2: 254 return FUNC<TypeCategory::Complex, 2>{}(std::forward<A>(x)...); 255 case 3: 256 return FUNC<TypeCategory::Complex, 3>{}(std::forward<A>(x)...); 257 #endif 258 case 4: 259 return FUNC<TypeCategory::Complex, 4>{}(std::forward<A>(x)...); 260 case 8: 261 return FUNC<TypeCategory::Complex, 8>{}(std::forward<A>(x)...); 262 case 10: 263 if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) { 264 return FUNC<TypeCategory::Complex, 10>{}(std::forward<A>(x)...); 265 } 266 break; 267 case 16: 268 if constexpr (HasCppTypeFor<TypeCategory::Real, 16>) { 269 return FUNC<TypeCategory::Complex, 16>{}(std::forward<A>(x)...); 270 } 271 break; 272 } 273 terminator.Crash("not yet implemented: COMPLEX(KIND=%d)", kind); 274 case TypeCategory::Character: 275 switch (kind) { 276 case 1: 277 return FUNC<TypeCategory::Character, 1>{}(std::forward<A>(x)...); 278 case 2: 279 return FUNC<TypeCategory::Character, 2>{}(std::forward<A>(x)...); 280 case 4: 281 return FUNC<TypeCategory::Character, 4>{}(std::forward<A>(x)...); 282 default: 283 terminator.Crash("not yet implemented: CHARACTER(KIND=%d)", kind); 284 } 285 case TypeCategory::Logical: 286 switch (kind) { 287 case 1: 288 return FUNC<TypeCategory::Logical, 1>{}(std::forward<A>(x)...); 289 case 2: 290 return FUNC<TypeCategory::Logical, 2>{}(std::forward<A>(x)...); 291 case 4: 292 return FUNC<TypeCategory::Logical, 4>{}(std::forward<A>(x)...); 293 case 8: 294 return FUNC<TypeCategory::Logical, 8>{}(std::forward<A>(x)...); 295 default: 296 terminator.Crash("not yet implemented: LOGICAL(KIND=%d)", kind); 297 } 298 default: 299 terminator.Crash( 300 "not yet implemented: type category(%d)", static_cast<int>(cat)); 301 } 302 } 303 304 // Maps a runtime INTEGER kind value to the appropriate instantiation of 305 // a function object template and calls it with the supplied arguments. 306 template <template <int KIND> class FUNC, typename RESULT, typename... A> 307 inline RT_API_ATTRS RESULT ApplyIntegerKind( 308 int kind, Terminator &terminator, A &&...x) { 309 switch (kind) { 310 case 1: 311 return FUNC<1>{}(std::forward<A>(x)...); 312 case 2: 313 return FUNC<2>{}(std::forward<A>(x)...); 314 case 4: 315 return FUNC<4>{}(std::forward<A>(x)...); 316 case 8: 317 return FUNC<8>{}(std::forward<A>(x)...); 318 #if defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T 319 case 16: 320 return FUNC<16>{}(std::forward<A>(x)...); 321 #endif 322 default: 323 terminator.Crash("not yet implemented: INTEGER/UNSIGNED(KIND=%d)", kind); 324 } 325 } 326 327 template <template <int KIND> class FUNC, typename RESULT, 328 bool NEEDSMATH = false, typename... A> 329 inline RT_API_ATTRS RESULT ApplyFloatingPointKind( 330 int kind, Terminator &terminator, A &&...x) { 331 switch (kind) { 332 #if 0 // TODO: REAL/COMPLEX (2 & 3) 333 case 2: 334 return FUNC<2>{}(std::forward<A>(x)...); 335 case 3: 336 return FUNC<3>{}(std::forward<A>(x)...); 337 #endif 338 case 4: 339 return FUNC<4>{}(std::forward<A>(x)...); 340 case 8: 341 return FUNC<8>{}(std::forward<A>(x)...); 342 case 10: 343 if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) { 344 return FUNC<10>{}(std::forward<A>(x)...); 345 } 346 break; 347 case 16: 348 if constexpr (HasCppTypeFor<TypeCategory::Real, 16>) { 349 // If FUNC implemenation relies on FP math functions, 350 // then we should not be here. The compiler should have 351 // generated a call to an entry in FortranFloat128Math 352 // library. 353 if constexpr (!NEEDSMATH) { 354 return FUNC<16>{}(std::forward<A>(x)...); 355 } 356 } 357 break; 358 } 359 terminator.Crash("not yet implemented: REAL/COMPLEX(KIND=%d)", kind); 360 } 361 362 template <template <int KIND> class FUNC, typename RESULT, typename... A> 363 inline RT_API_ATTRS RESULT ApplyCharacterKind( 364 int kind, Terminator &terminator, A &&...x) { 365 switch (kind) { 366 case 1: 367 return FUNC<1>{}(std::forward<A>(x)...); 368 case 2: 369 return FUNC<2>{}(std::forward<A>(x)...); 370 case 4: 371 return FUNC<4>{}(std::forward<A>(x)...); 372 default: 373 terminator.Crash("not yet implemented: CHARACTER(KIND=%d)", kind); 374 } 375 } 376 377 template <template <int KIND> class FUNC, typename RESULT, typename... A> 378 inline RT_API_ATTRS RESULT ApplyLogicalKind( 379 int kind, Terminator &terminator, A &&...x) { 380 switch (kind) { 381 case 1: 382 return FUNC<1>{}(std::forward<A>(x)...); 383 case 2: 384 return FUNC<2>{}(std::forward<A>(x)...); 385 case 4: 386 return FUNC<4>{}(std::forward<A>(x)...); 387 case 8: 388 return FUNC<8>{}(std::forward<A>(x)...); 389 default: 390 terminator.Crash("not yet implemented: LOGICAL(KIND=%d)", kind); 391 } 392 } 393 394 // Calculate result type of (X op Y) for *, //, DOT_PRODUCT, &c. 395 Fortran::common::optional< 396 std::pair<TypeCategory, int>> inline constexpr RT_API_ATTRS 397 GetResultType(TypeCategory xCat, int xKind, TypeCategory yCat, int yKind) { 398 int maxKind{std::max(xKind, yKind)}; 399 switch (xCat) { 400 case TypeCategory::Integer: 401 switch (yCat) { 402 case TypeCategory::Integer: 403 return std::make_pair(TypeCategory::Integer, maxKind); 404 case TypeCategory::Real: 405 case TypeCategory::Complex: 406 #if !(defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T) 407 if (xKind == 16) { 408 break; 409 } 410 #endif 411 return std::make_pair(yCat, yKind); 412 default: 413 break; 414 } 415 break; 416 case TypeCategory::Unsigned: 417 switch (yCat) { 418 case TypeCategory::Unsigned: 419 return std::make_pair(TypeCategory::Unsigned, maxKind); 420 case TypeCategory::Real: 421 case TypeCategory::Complex: 422 #if !(defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T) 423 if (xKind == 16) { 424 break; 425 } 426 #endif 427 return std::make_pair(yCat, yKind); 428 default: 429 break; 430 } 431 break; 432 case TypeCategory::Real: 433 switch (yCat) { 434 case TypeCategory::Integer: 435 case TypeCategory::Unsigned: 436 #if !(defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T) 437 if (yKind == 16) { 438 break; 439 } 440 #endif 441 return std::make_pair(TypeCategory::Real, xKind); 442 case TypeCategory::Real: 443 case TypeCategory::Complex: 444 return std::make_pair(yCat, maxKind); 445 default: 446 break; 447 } 448 break; 449 case TypeCategory::Complex: 450 switch (yCat) { 451 case TypeCategory::Integer: 452 case TypeCategory::Unsigned: 453 #if !(defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T) 454 if (yKind == 16) { 455 break; 456 } 457 #endif 458 return std::make_pair(TypeCategory::Complex, xKind); 459 case TypeCategory::Real: 460 case TypeCategory::Complex: 461 return std::make_pair(TypeCategory::Complex, maxKind); 462 default: 463 break; 464 } 465 break; 466 case TypeCategory::Character: 467 if (yCat == TypeCategory::Character) { 468 return std::make_pair(TypeCategory::Character, maxKind); 469 } else { 470 return Fortran::common::nullopt; 471 } 472 case TypeCategory::Logical: 473 if (yCat == TypeCategory::Logical) { 474 return std::make_pair(TypeCategory::Logical, maxKind); 475 } else { 476 return Fortran::common::nullopt; 477 } 478 default: 479 break; 480 } 481 return Fortran::common::nullopt; 482 } 483 484 // Accumulate floating-point results in (at least) double precision 485 template <TypeCategory CAT, int KIND> 486 using AccumulationType = CppTypeFor<CAT, 487 CAT == TypeCategory::Real || CAT == TypeCategory::Complex 488 ? std::max(KIND, static_cast<int>(sizeof(double))) 489 : KIND>; 490 491 // memchr() for any character type 492 template <typename CHAR> 493 static inline RT_API_ATTRS const CHAR *FindCharacter( 494 const CHAR *data, CHAR ch, std::size_t chars) { 495 const CHAR *end{data + chars}; 496 for (const CHAR *p{data}; p < end; ++p) { 497 if (*p == ch) { 498 return p; 499 } 500 } 501 return nullptr; 502 } 503 504 template <> 505 inline RT_API_ATTRS const char *FindCharacter( 506 const char *data, char ch, std::size_t chars) { 507 return reinterpret_cast<const char *>( 508 runtime::memchr(data, static_cast<int>(ch), chars)); 509 } 510 511 // Copy payload data from one allocated descriptor to another. 512 // Assumes element counts and element sizes match, and that both 513 // descriptors are allocated. 514 RT_API_ATTRS void ShallowCopyDiscontiguousToDiscontiguous( 515 const Descriptor &to, const Descriptor &from); 516 RT_API_ATTRS void ShallowCopyDiscontiguousToContiguous( 517 const Descriptor &to, const Descriptor &from); 518 RT_API_ATTRS void ShallowCopyContiguousToDiscontiguous( 519 const Descriptor &to, const Descriptor &from); 520 RT_API_ATTRS void ShallowCopy(const Descriptor &to, const Descriptor &from, 521 bool toIsContiguous, bool fromIsContiguous); 522 RT_API_ATTRS void ShallowCopy(const Descriptor &to, const Descriptor &from); 523 524 // Ensures that a character string is null-terminated, allocating a /p length +1 525 // size memory for null-terminator if necessary. Returns the original or a newly 526 // allocated null-terminated string (responsibility for deallocation is on the 527 // caller). 528 RT_API_ATTRS char *EnsureNullTerminated( 529 char *str, std::size_t length, Terminator &terminator); 530 531 RT_API_ATTRS bool IsValidCharDescriptor(const Descriptor *value); 532 533 RT_API_ATTRS bool IsValidIntDescriptor(const Descriptor *intVal); 534 535 // Copy a null-terminated character array \p rawValue to descriptor \p value. 536 // The copy starts at the given \p offset, if not present then start at 0. 537 // If descriptor `errmsg` is provided, error messages will be stored to it. 538 // Returns stats specified in standard. 539 RT_API_ATTRS std::int32_t CopyCharsToDescriptor(const Descriptor &value, 540 const char *rawValue, std::size_t rawValueLength, 541 const Descriptor *errmsg = nullptr, std::size_t offset = 0); 542 543 RT_API_ATTRS void StoreIntToDescriptor( 544 const Descriptor *length, std::int64_t value, Terminator &terminator); 545 546 // Defines a utility function for copying and padding characters 547 template <typename TO, typename FROM> 548 RT_API_ATTRS void CopyAndPad( 549 TO *to, const FROM *from, std::size_t toChars, std::size_t fromChars) { 550 if constexpr (sizeof(TO) != sizeof(FROM)) { 551 std::size_t copyChars{std::min(toChars, fromChars)}; 552 for (std::size_t j{0}; j < copyChars; ++j) { 553 to[j] = from[j]; 554 } 555 for (std::size_t j{copyChars}; j < toChars; ++j) { 556 to[j] = static_cast<TO>(' '); 557 } 558 } else if (toChars <= fromChars) { 559 std::memcpy(to, from, toChars * sizeof(TO)); 560 } else { 561 std::memcpy(to, from, std::min(toChars, fromChars) * sizeof(TO)); 562 for (std::size_t j{fromChars}; j < toChars; ++j) { 563 to[j] = static_cast<TO>(' '); 564 } 565 } 566 } 567 568 RT_API_ATTRS void CreatePartialReductionResult(Descriptor &result, 569 const Descriptor &x, std::size_t resultElementSize, int dim, Terminator &, 570 const char *intrinsic, TypeCode); 571 572 } // namespace Fortran::runtime 573 #endif // FORTRAN_RUNTIME_TOOLS_H_ 574