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 "freestanding-tools.h"
  13 #include "terminator.h"
  14 #include "flang/Runtime/cpp-type.h"
  15 #include "flang/Runtime/descriptor.h"
  16 #include "flang/Runtime/memory.h"
  17 #include <cstring>
  18 #include <functional>
  19 #include <map>
  20 #include <type_traits>
  21
  22 namespace Fortran::runtime {
  23
  24 class Terminator;
  25
  26 RT_API_ATTRS std::size_t TrimTrailingSpaces(const char *, std::size_t);
  27
  28 RT_API_ATTRS OwningPtr<char> SaveDefaultCharacter(
  29     const char *, std::size_t, const Terminator &);
  30
  31 // For validating and recognizing default CHARACTER values in a
  32 // case-insensitive manner.  Returns the zero-based index into the
  33 // null-terminated array of upper-case possibilities when the value is valid,
  34 // or -1 when it has no match.
  35 RT_API_ATTRS int IdentifyValue(
  36     const char *value, std::size_t length, const char *possibilities[]);
  37
  38 // Truncates or pads as necessary
  39 RT_API_ATTRS void ToFortranDefaultCharacter(
  40     char *to, std::size_t toLength, const char *from);
  41
  42 // Utility for dealing with elemental LOGICAL arguments
  43 inline RT_API_ATTRS bool IsLogicalElementTrue(
  44     const Descriptor &logical, const SubscriptValue at[]) {
  45   // A LOGICAL value is false if and only if all of its bytes are zero.
  46   const char *p{logical.Element<char>(at)};
  47   for (std::size_t j{logical.ElementBytes()}; j-- > 0; ++p) {
  48     if (*p) {
  49       return true;
  50     }
  51   }
  52   return false;
  53 }
  54
  55 // Check array conformability; a scalar 'x' conforms.  Crashes on error.
  56 RT_API_ATTRS void CheckConformability(const Descriptor &to, const Descriptor &x,
  57     Terminator &, const char *funcName, const char *toName,
  58     const char *fromName);
  59
  60 // Helper to store integer value in result[at].
  61 template <int KIND> struct StoreIntegerAt {
  62   RT_API_ATTRS void operator()(const Fortran::runtime::Descriptor &result,
  63       std::size_t at, std::int64_t value) const {
  64     *result.ZeroBasedIndexedElement<Fortran::runtime::CppTypeFor<
  65         Fortran::common::TypeCategory::Integer, KIND>>(at) = value;
  66   }
  67 };
  68
  69 // Validate a KIND= argument
  70 RT_API_ATTRS void CheckIntegerKind(
  71     Terminator &, int kind, const char *intrinsic);
  72
  73 template <typename TO, typename FROM>
  74 inline RT_API_ATTRS void PutContiguousConverted(
  75     TO *to, FROM *from, std::size_t count) {
  76   while (count-- > 0) {
  77     *to++ = *from++;
  78   }
  79 }
  80
  81 static inline RT_API_ATTRS std::int64_t GetInt64(
  82     const char *p, std::size_t bytes, Terminator &terminator) {
  83   switch (bytes) {
  84   case 1:
  85     return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 1> *>(p);
  86   case 2:
  87     return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 2> *>(p);
  88   case 4:
  89     return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 4> *>(p);
  90   case 8:
  91     return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 8> *>(p);
  92   default:
  93     terminator.Crash("GetInt64: no case for %zd bytes", bytes);
  94   }
  95 }
  96
  97 static inline RT_API_ATTRS std::optional<std::int64_t> GetInt64Safe(
  98     const char *p, std::size_t bytes, Terminator &terminator) {
  99   switch (bytes) {
 100   case 1:
 101     return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 1> *>(p);
 102   case 2:
 103     return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 2> *>(p);
 104   case 4:
 105     return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 4> *>(p);
 106   case 8:
 107     return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 8> *>(p);
 108   case 16: {
 109     using Int128 = CppTypeFor<TypeCategory::Integer, 16>;
 110     auto n{*reinterpret_cast<const Int128 *>(p)};
 111     std::int64_t result{static_cast<std::int64_t>(n)};
 112     if (static_cast<Int128>(result) == n) {
 113       return result;
 114     }
 115     return std::nullopt;
 116   }
 117   default:
 118     terminator.Crash("GetInt64Safe: no case for %zd bytes", bytes);
 119   }
 120 }
 121
 122 template <typename INT>
 123 inline RT_API_ATTRS bool SetInteger(INT &x, int kind, std::int64_t value) {
 124   switch (kind) {
 125   case 1:
 126     reinterpret_cast<CppTypeFor<TypeCategory::Integer, 1> &>(x) = value;
 127     return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 1> &>(x);
 128   case 2:
 129     reinterpret_cast<CppTypeFor<TypeCategory::Integer, 2> &>(x) = value;
 130     return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 2> &>(x);
 131   case 4:
 132     reinterpret_cast<CppTypeFor<TypeCategory::Integer, 4> &>(x) = value;
 133     return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 4> &>(x);
 134   case 8:
 135     reinterpret_cast<CppTypeFor<TypeCategory::Integer, 8> &>(x) = value;
 136     return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 8> &>(x);
 137   default:
 138     return false;
 139   }
 140 }
 141
 142 // Maps intrinsic runtime type category and kind values to the appropriate
 143 // instantiation of a function object template and calls it with the supplied
 144 // arguments.
 145 template <template <TypeCategory, int> class FUNC, typename RESULT,
 146     typename... A>
 147 inline RT_API_ATTRS RESULT ApplyType(
 148     TypeCategory cat, int kind, Terminator &terminator, A &&...x) {
 149   switch (cat) {
 150   case TypeCategory::Integer:
 151     switch (kind) {
 152     case 1:
 153       return FUNC<TypeCategory::Integer, 1>{}(std::forward<A>(x)...);
 154     case 2:
 155       return FUNC<TypeCategory::Integer, 2>{}(std::forward<A>(x)...);
 156     case 4:
 157       return FUNC<TypeCategory::Integer, 4>{}(std::forward<A>(x)...);
 158     case 8:
 159       return FUNC<TypeCategory::Integer, 8>{}(std::forward<A>(x)...);
 160 #if defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T
 161     case 16:
 162       return FUNC<TypeCategory::Integer, 16>{}(std::forward<A>(x)...);
 163 #endif
 164     default:
 165       terminator.Crash("not yet implemented: INTEGER(KIND=%d)", kind);
 166     }
 167   case TypeCategory::Real:
 168     switch (kind) {
 169 #if 0 // TODO: REAL(2 & 3)
 170     case 2:
 171       return FUNC<TypeCategory::Real, 2>{}(std::forward<A>(x)...);
 172     case 3:
 173       return FUNC<TypeCategory::Real, 3>{}(std::forward<A>(x)...);
 174 #endif
 175     case 4:
 176       return FUNC<TypeCategory::Real, 4>{}(std::forward<A>(x)...);
 177     case 8:
 178       return FUNC<TypeCategory::Real, 8>{}(std::forward<A>(x)...);
 179     case 10:
 180       if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) {
 181         return FUNC<TypeCategory::Real, 10>{}(std::forward<A>(x)...);
 182       }
 183       break;
 184     case 16:
 185       if constexpr (HasCppTypeFor<TypeCategory::Real, 16>) {
 186         return FUNC<TypeCategory::Real, 16>{}(std::forward<A>(x)...);
 187       }
 188       break;
 189     }
 190     terminator.Crash("not yet implemented: REAL(KIND=%d)", kind);
 191   case TypeCategory::Complex:
 192     switch (kind) {
 193 #if 0 // TODO: COMPLEX(2 & 3)
 194     case 2:
 195       return FUNC<TypeCategory::Complex, 2>{}(std::forward<A>(x)...);
 196     case 3:
 197       return FUNC<TypeCategory::Complex, 3>{}(std::forward<A>(x)...);
 198 #endif
 199     case 4:
 200       return FUNC<TypeCategory::Complex, 4>{}(std::forward<A>(x)...);
 201     case 8:
 202       return FUNC<TypeCategory::Complex, 8>{}(std::forward<A>(x)...);
 203     case 10:
 204       if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) {
 205         return FUNC<TypeCategory::Complex, 10>{}(std::forward<A>(x)...);
 206       }
 207       break;
 208     case 16:
 209       if constexpr (HasCppTypeFor<TypeCategory::Real, 16>) {
 210         return FUNC<TypeCategory::Complex, 16>{}(std::forward<A>(x)...);
 211       }
 212       break;
 213     }
 214     terminator.Crash("not yet implemented: COMPLEX(KIND=%d)", kind);
 215   case TypeCategory::Character:
 216     switch (kind) {
 217     case 1:
 218       return FUNC<TypeCategory::Character, 1>{}(std::forward<A>(x)...);
 219     case 2:
 220       return FUNC<TypeCategory::Character, 2>{}(std::forward<A>(x)...);
 221     case 4:
 222       return FUNC<TypeCategory::Character, 4>{}(std::forward<A>(x)...);
 223     default:
 224       terminator.Crash("not yet implemented: CHARACTER(KIND=%d)", kind);
 225     }
 226   case TypeCategory::Logical:
 227     switch (kind) {
 228     case 1:
 229       return FUNC<TypeCategory::Logical, 1>{}(std::forward<A>(x)...);
 230     case 2:
 231       return FUNC<TypeCategory::Logical, 2>{}(std::forward<A>(x)...);
 232     case 4:
 233       return FUNC<TypeCategory::Logical, 4>{}(std::forward<A>(x)...);
 234     case 8:
 235       return FUNC<TypeCategory::Logical, 8>{}(std::forward<A>(x)...);
 236     default:
 237       terminator.Crash("not yet implemented: LOGICAL(KIND=%d)", kind);
 238     }
 239   default:
 240     terminator.Crash(
 241         "not yet implemented: type category(%d)", static_cast<int>(cat));
 242   }
 243 }
 244
 245 // Maps a runtime INTEGER kind value to the appropriate instantiation of
 246 // a function object template and calls it with the supplied arguments.
 247 template <template <int KIND> class FUNC, typename RESULT, typename... A>
 248 inline RT_API_ATTRS RESULT ApplyIntegerKind(
 249     int kind, Terminator &terminator, A &&...x) {
 250   switch (kind) {
 251   case 1:
 252     return FUNC<1>{}(std::forward<A>(x)...);
 253   case 2:
 254     return FUNC<2>{}(std::forward<A>(x)...);
 255   case 4:
 256     return FUNC<4>{}(std::forward<A>(x)...);
 257   case 8:
 258     return FUNC<8>{}(std::forward<A>(x)...);
 259 #if defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T
 260   case 16:
 261     return FUNC<16>{}(std::forward<A>(x)...);
 262 #endif
 263   default:
 264     terminator.Crash("not yet implemented: INTEGER(KIND=%d)", kind);
 265   }
 266 }
 267
 268 template <template <int KIND> class FUNC, typename RESULT, typename... A>
 269 inline RT_API_ATTRS RESULT ApplyFloatingPointKind(
 270     int kind, Terminator &terminator, A &&...x) {
 271   switch (kind) {
 272 #if 0 // TODO: REAL/COMPLEX (2 & 3)
 273   case 2:
 274     return FUNC<2>{}(std::forward<A>(x)...);
 275   case 3:
 276     return FUNC<3>{}(std::forward<A>(x)...);
 277 #endif
 278   case 4:
 279     return FUNC<4>{}(std::forward<A>(x)...);
 280   case 8:
 281     return FUNC<8>{}(std::forward<A>(x)...);
 282   case 10:
 283     if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) {
 284       return FUNC<10>{}(std::forward<A>(x)...);
 285     }
 286     break;
 287   case 16:
 288     if constexpr (HasCppTypeFor<TypeCategory::Real, 16>) {
 289       return FUNC<16>{}(std::forward<A>(x)...);
 290     }
 291     break;
 292   }
 293   terminator.Crash("not yet implemented: REAL/COMPLEX(KIND=%d)", kind);
 294 }
 295
 296 template <template <int KIND> class FUNC, typename RESULT, typename... A>
 297 inline RT_API_ATTRS RESULT ApplyCharacterKind(
 298     int kind, Terminator &terminator, A &&...x) {
 299   switch (kind) {
 300   case 1:
 301     return FUNC<1>{}(std::forward<A>(x)...);
 302   case 2:
 303     return FUNC<2>{}(std::forward<A>(x)...);
 304   case 4:
 305     return FUNC<4>{}(std::forward<A>(x)...);
 306   default:
 307     terminator.Crash("not yet implemented: CHARACTER(KIND=%d)", kind);
 308   }
 309 }
 310
 311 template <template <int KIND> class FUNC, typename RESULT, typename... A>
 312 inline RT_API_ATTRS RESULT ApplyLogicalKind(
 313     int kind, Terminator &terminator, A &&...x) {
 314   switch (kind) {
 315   case 1:
 316     return FUNC<1>{}(std::forward<A>(x)...);
 317   case 2:
 318     return FUNC<2>{}(std::forward<A>(x)...);
 319   case 4:
 320     return FUNC<4>{}(std::forward<A>(x)...);
 321   case 8:
 322     return FUNC<8>{}(std::forward<A>(x)...);
 323   default:
 324     terminator.Crash("not yet implemented: LOGICAL(KIND=%d)", kind);
 325   }
 326 }
 327
 328 // Calculate result type of (X op Y) for *, //, DOT_PRODUCT, &c.
 329 std::optional<std::pair<TypeCategory, int>> inline constexpr RT_API_ATTRS
 330 GetResultType(TypeCategory xCat, int xKind, TypeCategory yCat, int yKind) {
 331   int maxKind{std::max(xKind, yKind)};
 332   switch (xCat) {
 333   case TypeCategory::Integer:
 334     switch (yCat) {
 335     case TypeCategory::Integer:
 336       return std::make_pair(TypeCategory::Integer, maxKind);
 337     case TypeCategory::Real:
 338     case TypeCategory::Complex:
 339 #if !(defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T)
 340       if (xKind == 16) {
 341         break;
 342       }
 343 #endif
 344       return std::make_pair(yCat, yKind);
 345     default:
 346       break;
 347     }
 348     break;
 349   case TypeCategory::Real:
 350     switch (yCat) {
 351     case TypeCategory::Integer:
 352 #if !(defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T)
 353       if (yKind == 16) {
 354         break;
 355       }
 356 #endif
 357       return std::make_pair(TypeCategory::Real, xKind);
 358     case TypeCategory::Real:
 359     case TypeCategory::Complex:
 360       return std::make_pair(yCat, maxKind);
 361     default:
 362       break;
 363     }
 364     break;
 365   case TypeCategory::Complex:
 366     switch (yCat) {
 367     case TypeCategory::Integer:
 368 #if !(defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T)
 369       if (yKind == 16) {
 370         break;
 371       }
 372 #endif
 373       return std::make_pair(TypeCategory::Complex, xKind);
 374     case TypeCategory::Real:
 375     case TypeCategory::Complex:
 376       return std::make_pair(TypeCategory::Complex, maxKind);
 377     default:
 378       break;
 379     }
 380     break;
 381   case TypeCategory::Character:
 382     if (yCat == TypeCategory::Character) {
 383       return std::make_pair(TypeCategory::Character, maxKind);
 384     } else {
 385       return std::nullopt;
 386     }
 387   case TypeCategory::Logical:
 388     if (yCat == TypeCategory::Logical) {
 389       return std::make_pair(TypeCategory::Logical, maxKind);
 390     } else {
 391       return std::nullopt;
 392     }
 393   default:
 394     break;
 395   }
 396   return std::nullopt;
 397 }
 398
 399 // Accumulate floating-point results in (at least) double precision
 400 template <TypeCategory CAT, int KIND>
 401 using AccumulationType = CppTypeFor<CAT,
 402     CAT == TypeCategory::Real || CAT == TypeCategory::Complex
 403         ? std::max(KIND, static_cast<int>(sizeof(double)))
 404         : KIND>;
 405
 406 // memchr() for any character type
 407 template <typename CHAR>
 408 static inline RT_API_ATTRS const CHAR *FindCharacter(
 409     const CHAR *data, CHAR ch, std::size_t chars) {
 410   const CHAR *end{data + chars};
 411   for (const CHAR *p{data}; p < end; ++p) {
 412     if (*p == ch) {
 413       return p;
 414     }
 415   }
 416   return nullptr;
 417 }
 418
 419 template <>
 420 inline RT_API_ATTRS const char *FindCharacter(
 421     const char *data, char ch, std::size_t chars) {
 422   return reinterpret_cast<const char *>(
 423       std::memchr(data, static_cast<int>(ch), chars));
 424 }
 425
 426 // Copy payload data from one allocated descriptor to another.
 427 // Assumes element counts and element sizes match, and that both
 428 // descriptors are allocated.
 429 RT_API_ATTRS void ShallowCopyDiscontiguousToDiscontiguous(
 430     const Descriptor &to, const Descriptor &from);
 431 RT_API_ATTRS void ShallowCopyDiscontiguousToContiguous(
 432     const Descriptor &to, const Descriptor &from);
 433 RT_API_ATTRS void ShallowCopyContiguousToDiscontiguous(
 434     const Descriptor &to, const Descriptor &from);
 435 RT_API_ATTRS void ShallowCopy(const Descriptor &to, const Descriptor &from,
 436     bool toIsContiguous, bool fromIsContiguous);
 437 RT_API_ATTRS void ShallowCopy(const Descriptor &to, const Descriptor &from);
 438
 439 // Defines a utility function for copying and padding characters
 440 template <typename TO, typename FROM>
 441 RT_API_ATTRS void CopyAndPad(
 442     TO *to, const FROM *from, std::size_t toChars, std::size_t fromChars) {
 443   if constexpr (sizeof(TO) != sizeof(FROM)) {
 444     std::size_t copyChars{std::min(toChars, fromChars)};
 445     for (std::size_t j{0}; j < copyChars; ++j) {
 446       to[j] = from[j];
 447     }
 448     for (std::size_t j{copyChars}; j < toChars; ++j) {
 449       to[j] = static_cast<TO>(' ');
 450     }
 451   } else if (toChars <= fromChars) {
 452     std::memcpy(to, from, toChars * sizeof(TO));
 453   } else {
 454     std::memcpy(to, from, std::min(toChars, fromChars) * sizeof(TO));
 455     for (std::size_t j{fromChars}; j < toChars; ++j) {
 456       to[j] = static_cast<TO>(' ');
 457     }
 458   }
 459 }
 460
 461 } // namespace Fortran::runtime
 462 #endif // FORTRAN_RUNTIME_TOOLS_H_