flang/runtime/tools.h

   1 //===-- runtime/tools.h -----------------------------------------*- C++ -*-===//
   2 //
   3 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
   4 // See https://llvm.org/LICENSE.txt for license information.
   5 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
   6 //
   7 //===----------------------------------------------------------------------===//
   8
   9 #ifndef FORTRAN_RUNTIME_TOOLS_H_
  10 #define FORTRAN_RUNTIME_TOOLS_H_
  11
  12 #include "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::Real:
 210     switch (kind) {
 211 #if 0 // TODO: REAL(2 & 3)
 212     case 2:
 213       return FUNC<TypeCategory::Real, 2>{}(std::forward<A>(x)...);
 214     case 3:
 215       return FUNC<TypeCategory::Real, 3>{}(std::forward<A>(x)...);
 216 #endif
 217     case 4:
 218       return FUNC<TypeCategory::Real, 4>{}(std::forward<A>(x)...);
 219     case 8:
 220       return FUNC<TypeCategory::Real, 8>{}(std::forward<A>(x)...);
 221     case 10:
 222       if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) {
 223         return FUNC<TypeCategory::Real, 10>{}(std::forward<A>(x)...);
 224       }
 225       break;
 226     case 16:
 227       if constexpr (HasCppTypeFor<TypeCategory::Real, 16>) {
 228         return FUNC<TypeCategory::Real, 16>{}(std::forward<A>(x)...);
 229       }
 230       break;
 231     }
 232     terminator.Crash("not yet implemented: REAL(KIND=%d)", kind);
 233   case TypeCategory::Complex:
 234     switch (kind) {
 235 #if 0 // TODO: COMPLEX(2 & 3)
 236     case 2:
 237       return FUNC<TypeCategory::Complex, 2>{}(std::forward<A>(x)...);
 238     case 3:
 239       return FUNC<TypeCategory::Complex, 3>{}(std::forward<A>(x)...);
 240 #endif
 241     case 4:
 242       return FUNC<TypeCategory::Complex, 4>{}(std::forward<A>(x)...);
 243     case 8:
 244       return FUNC<TypeCategory::Complex, 8>{}(std::forward<A>(x)...);
 245     case 10:
 246       if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) {
 247         return FUNC<TypeCategory::Complex, 10>{}(std::forward<A>(x)...);
 248       }
 249       break;
 250     case 16:
 251       if constexpr (HasCppTypeFor<TypeCategory::Real, 16>) {
 252         return FUNC<TypeCategory::Complex, 16>{}(std::forward<A>(x)...);
 253       }
 254       break;
 255     }
 256     terminator.Crash("not yet implemented: COMPLEX(KIND=%d)", kind);
 257   case TypeCategory::Character:
 258     switch (kind) {
 259     case 1:
 260       return FUNC<TypeCategory::Character, 1>{}(std::forward<A>(x)...);
 261     case 2:
 262       return FUNC<TypeCategory::Character, 2>{}(std::forward<A>(x)...);
 263     case 4:
 264       return FUNC<TypeCategory::Character, 4>{}(std::forward<A>(x)...);
 265     default:
 266       terminator.Crash("not yet implemented: CHARACTER(KIND=%d)", kind);
 267     }
 268   case TypeCategory::Logical:
 269     switch (kind) {
 270     case 1:
 271       return FUNC<TypeCategory::Logical, 1>{}(std::forward<A>(x)...);
 272     case 2:
 273       return FUNC<TypeCategory::Logical, 2>{}(std::forward<A>(x)...);
 274     case 4:
 275       return FUNC<TypeCategory::Logical, 4>{}(std::forward<A>(x)...);
 276     case 8:
 277       return FUNC<TypeCategory::Logical, 8>{}(std::forward<A>(x)...);
 278     default:
 279       terminator.Crash("not yet implemented: LOGICAL(KIND=%d)", kind);
 280     }
 281   default:
 282     terminator.Crash(
 283         "not yet implemented: type category(%d)", static_cast<int>(cat));
 284   }
 285 }
 286
 287 // Maps a runtime INTEGER kind value to the appropriate instantiation of
 288 // a function object template and calls it with the supplied arguments.
 289 template <template <int KIND> class FUNC, typename RESULT, typename... A>
 290 inline RT_API_ATTRS RESULT ApplyIntegerKind(
 291     int kind, Terminator &terminator, A &&...x) {
 292   switch (kind) {
 293   case 1:
 294     return FUNC<1>{}(std::forward<A>(x)...);
 295   case 2:
 296     return FUNC<2>{}(std::forward<A>(x)...);
 297   case 4:
 298     return FUNC<4>{}(std::forward<A>(x)...);
 299   case 8:
 300     return FUNC<8>{}(std::forward<A>(x)...);
 301 #if defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T
 302   case 16:
 303     return FUNC<16>{}(std::forward<A>(x)...);
 304 #endif
 305   default:
 306     terminator.Crash("not yet implemented: INTEGER(KIND=%d)", kind);
 307   }
 308 }
 309
 310 template <template <int KIND> class FUNC, typename RESULT,
 311     bool NEEDSMATH = false, typename... A>
 312 inline RT_API_ATTRS RESULT ApplyFloatingPointKind(
 313     int kind, Terminator &terminator, A &&...x) {
 314   switch (kind) {
 315 #if 0 // TODO: REAL/COMPLEX (2 & 3)
 316   case 2:
 317     return FUNC<2>{}(std::forward<A>(x)...);
 318   case 3:
 319     return FUNC<3>{}(std::forward<A>(x)...);
 320 #endif
 321   case 4:
 322     return FUNC<4>{}(std::forward<A>(x)...);
 323   case 8:
 324     return FUNC<8>{}(std::forward<A>(x)...);
 325   case 10:
 326     if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) {
 327       return FUNC<10>{}(std::forward<A>(x)...);
 328     }
 329     break;
 330   case 16:
 331     if constexpr (HasCppTypeFor<TypeCategory::Real, 16>) {
 332       // If FUNC implemenation relies on FP math functions,
 333       // then we should not be here. The compiler should have
 334       // generated a call to an entry in FortranFloat128Math
 335       // library.
 336       if constexpr (!NEEDSMATH) {
 337         return FUNC<16>{}(std::forward<A>(x)...);
 338       }
 339     }
 340     break;
 341   }
 342   terminator.Crash("not yet implemented: REAL/COMPLEX(KIND=%d)", kind);
 343 }
 344
 345 template <template <int KIND> class FUNC, typename RESULT, typename... A>
 346 inline RT_API_ATTRS RESULT ApplyCharacterKind(
 347     int kind, Terminator &terminator, A &&...x) {
 348   switch (kind) {
 349   case 1:
 350     return FUNC<1>{}(std::forward<A>(x)...);
 351   case 2:
 352     return FUNC<2>{}(std::forward<A>(x)...);
 353   case 4:
 354     return FUNC<4>{}(std::forward<A>(x)...);
 355   default:
 356     terminator.Crash("not yet implemented: CHARACTER(KIND=%d)", kind);
 357   }
 358 }
 359
 360 template <template <int KIND> class FUNC, typename RESULT, typename... A>
 361 inline RT_API_ATTRS RESULT ApplyLogicalKind(
 362     int kind, Terminator &terminator, A &&...x) {
 363   switch (kind) {
 364   case 1:
 365     return FUNC<1>{}(std::forward<A>(x)...);
 366   case 2:
 367     return FUNC<2>{}(std::forward<A>(x)...);
 368   case 4:
 369     return FUNC<4>{}(std::forward<A>(x)...);
 370   case 8:
 371     return FUNC<8>{}(std::forward<A>(x)...);
 372   default:
 373     terminator.Crash("not yet implemented: LOGICAL(KIND=%d)", kind);
 374   }
 375 }
 376
 377 // Calculate result type of (X op Y) for *, //, DOT_PRODUCT, &c.
 378 Fortran::common::optional<
 379     std::pair<TypeCategory, int>> inline constexpr RT_API_ATTRS
 380 GetResultType(TypeCategory xCat, int xKind, TypeCategory yCat, int yKind) {
 381   int maxKind{std::max(xKind, yKind)};
 382   switch (xCat) {
 383   case TypeCategory::Integer:
 384     switch (yCat) {
 385     case TypeCategory::Integer:
 386       return std::make_pair(TypeCategory::Integer, maxKind);
 387     case TypeCategory::Real:
 388     case TypeCategory::Complex:
 389 #if !(defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T)
 390       if (xKind == 16) {
 391         break;
 392       }
 393 #endif
 394       return std::make_pair(yCat, yKind);
 395     default:
 396       break;
 397     }
 398     break;
 399   case TypeCategory::Real:
 400     switch (yCat) {
 401     case TypeCategory::Integer:
 402 #if !(defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T)
 403       if (yKind == 16) {
 404         break;
 405       }
 406 #endif
 407       return std::make_pair(TypeCategory::Real, xKind);
 408     case TypeCategory::Real:
 409     case TypeCategory::Complex:
 410       return std::make_pair(yCat, maxKind);
 411     default:
 412       break;
 413     }
 414     break;
 415   case TypeCategory::Complex:
 416     switch (yCat) {
 417     case TypeCategory::Integer:
 418 #if !(defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T)
 419       if (yKind == 16) {
 420         break;
 421       }
 422 #endif
 423       return std::make_pair(TypeCategory::Complex, xKind);
 424     case TypeCategory::Real:
 425     case TypeCategory::Complex:
 426       return std::make_pair(TypeCategory::Complex, maxKind);
 427     default:
 428       break;
 429     }
 430     break;
 431   case TypeCategory::Character:
 432     if (yCat == TypeCategory::Character) {
 433       return std::make_pair(TypeCategory::Character, maxKind);
 434     } else {
 435       return Fortran::common::nullopt;
 436     }
 437   case TypeCategory::Logical:
 438     if (yCat == TypeCategory::Logical) {
 439       return std::make_pair(TypeCategory::Logical, maxKind);
 440     } else {
 441       return Fortran::common::nullopt;
 442     }
 443   default:
 444     break;
 445   }
 446   return Fortran::common::nullopt;
 447 }
 448
 449 // Accumulate floating-point results in (at least) double precision
 450 template <TypeCategory CAT, int KIND>
 451 using AccumulationType = CppTypeFor<CAT,
 452     CAT == TypeCategory::Real || CAT == TypeCategory::Complex
 453         ? std::max(KIND, static_cast<int>(sizeof(double)))
 454         : KIND>;
 455
 456 // memchr() for any character type
 457 template <typename CHAR>
 458 static inline RT_API_ATTRS const CHAR *FindCharacter(
 459     const CHAR *data, CHAR ch, std::size_t chars) {
 460   const CHAR *end{data + chars};
 461   for (const CHAR *p{data}; p < end; ++p) {
 462     if (*p == ch) {
 463       return p;
 464     }
 465   }
 466   return nullptr;
 467 }
 468
 469 template <>
 470 inline RT_API_ATTRS const char *FindCharacter(
 471     const char *data, char ch, std::size_t chars) {
 472   return reinterpret_cast<const char *>(
 473       runtime::memchr(data, static_cast<int>(ch), chars));
 474 }
 475
 476 // Copy payload data from one allocated descriptor to another.
 477 // Assumes element counts and element sizes match, and that both
 478 // descriptors are allocated.
 479 RT_API_ATTRS void ShallowCopyDiscontiguousToDiscontiguous(
 480     const Descriptor &to, const Descriptor &from);
 481 RT_API_ATTRS void ShallowCopyDiscontiguousToContiguous(
 482     const Descriptor &to, const Descriptor &from);
 483 RT_API_ATTRS void ShallowCopyContiguousToDiscontiguous(
 484     const Descriptor &to, const Descriptor &from);
 485 RT_API_ATTRS void ShallowCopy(const Descriptor &to, const Descriptor &from,
 486     bool toIsContiguous, bool fromIsContiguous);
 487 RT_API_ATTRS void ShallowCopy(const Descriptor &to, const Descriptor &from);
 488
 489 // Ensures that a character string is null-terminated, allocating a /p length +1
 490 // size memory for null-terminator if necessary. Returns the original or a newly
 491 // allocated null-terminated string (responsibility for deallocation is on the
 492 // caller).
 493 RT_API_ATTRS char *EnsureNullTerminated(
 494     char *str, std::size_t length, Terminator &terminator);
 495
 496 RT_API_ATTRS bool IsValidCharDescriptor(const Descriptor *value);
 497
 498 RT_API_ATTRS bool IsValidIntDescriptor(const Descriptor *intVal);
 499
 500 // Copy a null-terminated character array \p rawValue to descriptor \p value.
 501 // The copy starts at the given \p offset, if not present then start at 0.
 502 // If descriptor `errmsg` is provided, error messages will be stored to it.
 503 // Returns stats specified in standard.
 504 RT_API_ATTRS std::int32_t CopyCharsToDescriptor(const Descriptor &value,
 505     const char *rawValue, std::size_t rawValueLength,
 506     const Descriptor *errmsg = nullptr, std::size_t offset = 0);
 507
 508 RT_API_ATTRS void StoreIntToDescriptor(
 509     const Descriptor *length, std::int64_t value, Terminator &terminator);
 510
 511 // Defines a utility function for copying and padding characters
 512 template <typename TO, typename FROM>
 513 RT_API_ATTRS void CopyAndPad(
 514     TO *to, const FROM *from, std::size_t toChars, std::size_t fromChars) {
 515   if constexpr (sizeof(TO) != sizeof(FROM)) {
 516     std::size_t copyChars{std::min(toChars, fromChars)};
 517     for (std::size_t j{0}; j < copyChars; ++j) {
 518       to[j] = from[j];
 519     }
 520     for (std::size_t j{copyChars}; j < toChars; ++j) {
 521       to[j] = static_cast<TO>(' ');
 522     }
 523   } else if (toChars <= fromChars) {
 524     std::memcpy(to, from, toChars * sizeof(TO));
 525   } else {
 526     std::memcpy(to, from, std::min(toChars, fromChars) * sizeof(TO));
 527     for (std::size_t j{fromChars}; j < toChars; ++j) {
 528       to[j] = static_cast<TO>(' ');
 529     }
 530   }
 531 }
 532
 533 RT_API_ATTRS void CreatePartialReductionResult(Descriptor &result,
 534     const Descriptor &x, std::size_t resultElementSize, int dim, Terminator &,
 535     const char *intrinsic, TypeCode);
 536
 537 } // namespace Fortran::runtime
 538 #endif // FORTRAN_RUNTIME_TOOLS_H_