flang/runtime/time-intrinsic.cpp

   1 //===-- runtime/time-intrinsic.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 time-related intrinsic subroutines.
  10
  11 #include "flang/Runtime/time-intrinsic.h"
  12 #include "terminator.h"
  13 #include "tools.h"
  14 #include "flang/Runtime/cpp-type.h"
  15 #include "flang/Runtime/descriptor.h"
  16 #include <algorithm>
  17 #include <cstdint>
  18 #include <cstdio>
  19 #include <cstdlib>
  20 #include <cstring>
  21 #include <ctime>
  22 #ifdef _WIN32
  23 #include "flang/Common/windows-include.h"
  24 #else
  25 #include <sys/time.h> // gettimeofday
  26 #include <sys/times.h>
  27 #include <unistd.h>
  28 #endif
  29
  30 // CPU_TIME (Fortran 2018 16.9.57)
  31 // SYSTEM_CLOCK (Fortran 2018 16.9.168)
  32 //
  33 // We can use std::clock() from the <ctime> header as a fallback implementation
  34 // that should be available everywhere. This may not provide the best resolution
  35 // and is particularly troublesome on (some?) POSIX systems where CLOCKS_PER_SEC
  36 // is defined as 10^6 regardless of the actual precision of std::clock().
  37 // Therefore, we will usually prefer platform-specific alternatives when they
  38 // are available.
  39 //
  40 // We can use SFINAE to choose a platform-specific alternative. To do so, we
  41 // introduce a helper function template, whose overload set will contain only
  42 // implementations relying on interfaces which are actually available. Each
  43 // overload will have a dummy parameter whose type indicates whether or not it
  44 // should be preferred. Any other parameters required for SFINAE should have
  45 // default values provided.
  46 namespace {
  47 // Types for the dummy parameter indicating the priority of a given overload.
  48 // We will invoke our helper with an integer literal argument, so the overload
  49 // with the highest priority should have the type int.
  50 using fallback_implementation = double;
  51 using preferred_implementation = int;
  52
  53 // This is the fallback implementation, which should work everywhere.
  54 template <typename Unused = void> double GetCpuTime(fallback_implementation) {
  55   std::clock_t timestamp{std::clock()};
  56   if (timestamp != static_cast<std::clock_t>(-1)) {
  57     return static_cast<double>(timestamp) / CLOCKS_PER_SEC;
  58   }
  59   // Return some negative value to represent failure.
  60   return -1.0;
  61 }
  62
  63 #if defined __MINGW32__
  64 // clock_gettime is implemented in the pthread library for MinGW.
  65 // Using it here would mean that all programs that link libFortranRuntime are
  66 // required to also link to pthread. Instead, don't use the function.
  67 #undef CLOCKID_CPU_TIME
  68 #undef CLOCKID_ELAPSED_TIME
  69 #else
  70 // Determine what clock to use for CPU time.
  71 #if defined CLOCK_PROCESS_CPUTIME_ID
  72 #define CLOCKID_CPU_TIME CLOCK_PROCESS_CPUTIME_ID
  73 #elif defined CLOCK_THREAD_CPUTIME_ID
  74 #define CLOCKID_CPU_TIME CLOCK_THREAD_CPUTIME_ID
  75 #else
  76 #undef CLOCKID_CPU_TIME
  77 #endif
  78
  79 // Determine what clock to use for elapsed time.
  80 #if defined CLOCK_MONOTONIC
  81 #define CLOCKID_ELAPSED_TIME CLOCK_MONOTONIC
  82 #elif defined CLOCK_REALTIME
  83 #define CLOCKID_ELAPSED_TIME CLOCK_REALTIME
  84 #else
  85 #undef CLOCKID_ELAPSED_TIME
  86 #endif
  87 #endif
  88
  89 #ifdef CLOCKID_CPU_TIME
  90 // POSIX implementation using clock_gettime. This is only enabled where
  91 // clock_gettime is available.
  92 template <typename T = int, typename U = struct timespec>
  93 double GetCpuTime(preferred_implementation,
  94     // We need some dummy parameters to pass to decltype(clock_gettime).
  95     T ClockId = 0, U *Timespec = nullptr,
  96     decltype(clock_gettime(ClockId, Timespec)) *Enabled = nullptr) {
  97   struct timespec tspec;
  98   if (clock_gettime(CLOCKID_CPU_TIME, &tspec) == 0) {
  99     return tspec.tv_nsec * 1.0e-9 + tspec.tv_sec;
 100   }
 101   // Return some negative value to represent failure.
 102   return -1.0;
 103 }
 104 #endif // CLOCKID_CPU_TIME
 105
 106 using count_t = std::int64_t;
 107 using unsigned_count_t = std::uint64_t;
 108
 109 // POSIX implementation using clock_gettime where available.  The clock_gettime
 110 // result is in nanoseconds, which is converted as necessary to
 111 //  - deciseconds for kind 1
 112 //  - milliseconds for kinds 2, 4
 113 //  - nanoseconds for kinds 8, 16
 114 constexpr unsigned_count_t DS_PER_SEC{10u};
 115 constexpr unsigned_count_t MS_PER_SEC{1'000u};
 116 constexpr unsigned_count_t NS_PER_SEC{1'000'000'000u};
 117
 118 // Computes HUGE(INT(0,kind)) as an unsigned integer value.
 119 static constexpr inline unsigned_count_t GetHUGE(int kind) {
 120   if (kind > 8) {
 121     kind = 8;
 122   }
 123   return (unsigned_count_t{1} << ((8 * kind) - 1)) - 1;
 124 }
 125
 126 // Function converts a std::timespec_t into the desired count to
 127 // be returned by the timing functions in accordance with the requested
 128 // kind at the call site.
 129 count_t ConvertTimeSpecToCount(int kind, const struct timespec &tspec) {
 130   const unsigned_count_t huge{GetHUGE(kind)};
 131   unsigned_count_t sec{static_cast<unsigned_count_t>(tspec.tv_sec)};
 132   unsigned_count_t nsec{static_cast<unsigned_count_t>(tspec.tv_nsec)};
 133   if (kind >= 8) {
 134     return (sec * NS_PER_SEC + nsec) % (huge + 1);
 135   } else if (kind >= 2) {
 136     return (sec * MS_PER_SEC + (nsec / (NS_PER_SEC / MS_PER_SEC))) % (huge + 1);
 137   } else { // kind == 1
 138     return (sec * DS_PER_SEC + (nsec / (NS_PER_SEC / DS_PER_SEC))) % (huge + 1);
 139   }
 140 }
 141
 142 #ifndef _AIX
 143 // This is the fallback implementation, which should work everywhere.
 144 template <typename Unused = void>
 145 count_t GetSystemClockCount(int kind, fallback_implementation) {
 146   struct timespec tspec;
 147
 148   if (timespec_get(&tspec, TIME_UTC) < 0) {
 149     // Return -HUGE(COUNT) to represent failure.
 150     return -static_cast<count_t>(GetHUGE(kind));
 151   }
 152
 153   // Compute the timestamp as seconds plus nanoseconds in accordance
 154   // with the requested kind at the call site.
 155   return ConvertTimeSpecToCount(kind, tspec);
 156 }
 157 #endif
 158
 159 template <typename Unused = void>
 160 count_t GetSystemClockCountRate(int kind, fallback_implementation) {
 161   return kind >= 8 ? NS_PER_SEC : kind >= 2 ? MS_PER_SEC : DS_PER_SEC;
 162 }
 163
 164 template <typename Unused = void>
 165 count_t GetSystemClockCountMax(int kind, fallback_implementation) {
 166   unsigned_count_t maxCount{GetHUGE(kind)};
 167   return maxCount;
 168 }
 169
 170 #ifdef CLOCKID_ELAPSED_TIME
 171 template <typename T = int, typename U = struct timespec>
 172 count_t GetSystemClockCount(int kind, preferred_implementation,
 173     // We need some dummy parameters to pass to decltype(clock_gettime).
 174     T ClockId = 0, U *Timespec = nullptr,
 175     decltype(clock_gettime(ClockId, Timespec)) *Enabled = nullptr) {
 176   struct timespec tspec;
 177   const unsigned_count_t huge{GetHUGE(kind)};
 178   if (clock_gettime(CLOCKID_ELAPSED_TIME, &tspec) != 0) {
 179     return -huge; // failure
 180   }
 181
 182   // Compute the timestamp as seconds plus nanoseconds in accordance
 183   // with the requested kind at the call site.
 184   return ConvertTimeSpecToCount(kind, tspec);
 185 }
 186 #endif // CLOCKID_ELAPSED_TIME
 187
 188 template <typename T = int, typename U = struct timespec>
 189 count_t GetSystemClockCountRate(int kind, preferred_implementation,
 190     // We need some dummy parameters to pass to decltype(clock_gettime).
 191     T ClockId = 0, U *Timespec = nullptr,
 192     decltype(clock_gettime(ClockId, Timespec)) *Enabled = nullptr) {
 193   return kind >= 8 ? NS_PER_SEC : kind >= 2 ? MS_PER_SEC : DS_PER_SEC;
 194 }
 195
 196 template <typename T = int, typename U = struct timespec>
 197 count_t GetSystemClockCountMax(int kind, preferred_implementation,
 198     // We need some dummy parameters to pass to decltype(clock_gettime).
 199     T ClockId = 0, U *Timespec = nullptr,
 200     decltype(clock_gettime(ClockId, Timespec)) *Enabled = nullptr) {
 201   return GetHUGE(kind);
 202 }
 203
 204 // DATE_AND_TIME (Fortran 2018 16.9.59)
 205
 206 // Helper to set an integer value to -HUGE
 207 template <int KIND> struct StoreNegativeHugeAt {
 208   void operator()(
 209       const Fortran::runtime::Descriptor &result, std::size_t at) const {
 210     *result.ZeroBasedIndexedElement<Fortran::runtime::CppTypeFor<
 211         Fortran::common::TypeCategory::Integer, KIND>>(at) =
 212         -std::numeric_limits<Fortran::runtime::CppTypeFor<
 213             Fortran::common::TypeCategory::Integer, KIND>>::max();
 214   }
 215 };
 216
 217 // Default implementation when date and time information is not available (set
 218 // strings to blanks and values to -HUGE as defined by the standard).
 219 static void DateAndTimeUnavailable(Fortran::runtime::Terminator &terminator,
 220     char *date, std::size_t dateChars, char *time, std::size_t timeChars,
 221     char *zone, std::size_t zoneChars,
 222     const Fortran::runtime::Descriptor *values) {
 223   if (date) {
 224     std::memset(date, static_cast<int>(' '), dateChars);
 225   }
 226   if (time) {
 227     std::memset(time, static_cast<int>(' '), timeChars);
 228   }
 229   if (zone) {
 230     std::memset(zone, static_cast<int>(' '), zoneChars);
 231   }
 232   if (values) {
 233     auto typeCode{values->type().GetCategoryAndKind()};
 234     RUNTIME_CHECK(terminator,
 235         values->rank() == 1 && values->GetDimension(0).Extent() >= 8 &&
 236             typeCode &&
 237             typeCode->first == Fortran::common::TypeCategory::Integer);
 238     // DATE_AND_TIME values argument must have decimal range > 4. Do not accept
 239     // KIND 1 here.
 240     int kind{typeCode->second};
 241     RUNTIME_CHECK(terminator, kind != 1);
 242     for (std::size_t i = 0; i < 8; ++i) {
 243       Fortran::runtime::ApplyIntegerKind<StoreNegativeHugeAt, void>(
 244           kind, terminator, *values, i);
 245     }
 246   }
 247 }
 248
 249 #ifndef _WIN32
 250 #ifdef _AIX
 251 // Compute the time difference from GMT/UTC to get around the behavior of
 252 // strfname on AIX that requires setting an environment variable for numeric
 253 // value for ZONE.
 254 // The ZONE and the VALUES(4) arguments of the DATE_AND_TIME intrinsic has
 255 // the resolution to the minute.
 256 static int computeUTCDiff(const tm &localTime, bool *err) {
 257   tm utcTime;
 258   const time_t timer{mktime(const_cast<tm *>(&localTime))};
 259   if (timer < 0) {
 260     *err = true;
 261     return 0;
 262   }
 263
 264   // Get the GMT/UTC time
 265   if (gmtime_r(&timer, &utcTime) == nullptr) {
 266     *err = true;
 267     return 0;
 268   }
 269
 270   // Adjust for day difference
 271   auto dayDiff{localTime.tm_mday - utcTime.tm_mday};
 272   auto localHr{localTime.tm_hour};
 273   if (dayDiff > 0) {
 274     if (dayDiff == 1) {
 275       localHr += 24;
 276     } else {
 277       utcTime.tm_hour += 24;
 278     }
 279   } else if (dayDiff < 0) {
 280     if (dayDiff == -1) {
 281       utcTime.tm_hour += 24;
 282     } else {
 283       localHr += 24;
 284     }
 285   }
 286   return (localHr * 60 + localTime.tm_min) -
 287       (utcTime.tm_hour * 60 + utcTime.tm_min);
 288 }
 289 #endif
 290
 291 static std::size_t getUTCOffsetToBuffer(
 292     char *buffer, const std::size_t &buffSize, tm *localTime) {
 293 #ifdef _AIX
 294   // format: +HHMM or -HHMM
 295   bool err{false};
 296   auto utcOffset{computeUTCDiff(*localTime, &err)};
 297   auto hour{utcOffset / 60};
 298   auto hrMin{hour * 100 + (utcOffset - hour * 60)};
 299   auto n{sprintf(buffer, "%+05d", hrMin)};
 300   return err ? 0 : n + 1;
 301 #else
 302   return std::strftime(buffer, buffSize, "%z", localTime);
 303 #endif
 304 }
 305
 306 // SFINAE helper to return the struct tm.tm_gmtoff which is not a POSIX standard
 307 // field.
 308 template <int KIND, typename TM = struct tm>
 309 Fortran::runtime::CppTypeFor<Fortran::common::TypeCategory::Integer, KIND>
 310 GetGmtOffset(const TM &tm, preferred_implementation,
 311     decltype(tm.tm_gmtoff) *Enabled = nullptr) {
 312   // Returns the GMT offset in minutes.
 313   return tm.tm_gmtoff / 60;
 314 }
 315 template <int KIND, typename TM = struct tm>
 316 Fortran::runtime::CppTypeFor<Fortran::common::TypeCategory::Integer, KIND>
 317 GetGmtOffset(const TM &tm, fallback_implementation) {
 318   // tm.tm_gmtoff is not available, there may be platform dependent alternatives
 319   // (such as using timezone from <time.h> when available), but so far just
 320   // return -HUGE to report that this information is not available.
 321   const auto negHuge{-std::numeric_limits<Fortran::runtime::CppTypeFor<
 322       Fortran::common::TypeCategory::Integer, KIND>>::max()};
 323 #ifdef _AIX
 324   bool err{false};
 325   auto diff{computeUTCDiff(tm, &err)};
 326   if (err) {
 327     return negHuge;
 328   } else {
 329     return diff;
 330   }
 331 #else
 332   return negHuge;
 333 #endif
 334 }
 335 template <typename TM = struct tm> struct GmtOffsetHelper {
 336   template <int KIND> struct StoreGmtOffset {
 337     void operator()(const Fortran::runtime::Descriptor &result, std::size_t at,
 338         TM &tm) const {
 339       *result.ZeroBasedIndexedElement<Fortran::runtime::CppTypeFor<
 340           Fortran::common::TypeCategory::Integer, KIND>>(at) =
 341           GetGmtOffset<KIND>(tm, 0);
 342     }
 343   };
 344 };
 345
 346 // Dispatch to posix implementation where gettimeofday and localtime_r are
 347 // available.
 348 static void GetDateAndTime(Fortran::runtime::Terminator &terminator, char *date,
 349     std::size_t dateChars, char *time, std::size_t timeChars, char *zone,
 350     std::size_t zoneChars, const Fortran::runtime::Descriptor *values) {
 351
 352   timeval t;
 353   if (gettimeofday(&t, nullptr) != 0) {
 354     DateAndTimeUnavailable(
 355         terminator, date, dateChars, time, timeChars, zone, zoneChars, values);
 356     return;
 357   }
 358   time_t timer{t.tv_sec};
 359   tm localTime;
 360   localtime_r(&timer, &localTime);
 361   std::intmax_t ms{t.tv_usec / 1000};
 362
 363   static constexpr std::size_t buffSize{16};
 364   char buffer[buffSize];
 365   auto copyBufferAndPad{
 366       [&](char *dest, std::size_t destChars, std::size_t len) {
 367         auto copyLen{std::min(len, destChars)};
 368         std::memcpy(dest, buffer, copyLen);
 369         for (auto i{copyLen}; i < destChars; ++i) {
 370           dest[i] = ' ';
 371         }
 372       }};
 373   if (date) {
 374     auto len = std::strftime(buffer, buffSize, "%Y%m%d", &localTime);
 375     copyBufferAndPad(date, dateChars, len);
 376   }
 377   if (time) {
 378     auto len{std::snprintf(buffer, buffSize, "%02d%02d%02d.%03jd",
 379         localTime.tm_hour, localTime.tm_min, localTime.tm_sec, ms)};
 380     copyBufferAndPad(time, timeChars, len);
 381   }
 382   if (zone) {
 383     // Note: this may leave the buffer empty on many platforms. Classic flang
 384     // has a much more complex way of doing this (see __io_timezone in classic
 385     // flang).
 386     auto len{getUTCOffsetToBuffer(buffer, buffSize, &localTime)};
 387     copyBufferAndPad(zone, zoneChars, len);
 388   }
 389   if (values) {
 390     auto typeCode{values->type().GetCategoryAndKind()};
 391     RUNTIME_CHECK(terminator,
 392         values->rank() == 1 && values->GetDimension(0).Extent() >= 8 &&
 393             typeCode &&
 394             typeCode->first == Fortran::common::TypeCategory::Integer);
 395     // DATE_AND_TIME values argument must have decimal range > 4. Do not accept
 396     // KIND 1 here.
 397     int kind{typeCode->second};
 398     RUNTIME_CHECK(terminator, kind != 1);
 399     auto storeIntegerAt = [&](std::size_t atIndex, std::int64_t value) {
 400       Fortran::runtime::ApplyIntegerKind<Fortran::runtime::StoreIntegerAt,
 401           void>(kind, terminator, *values, atIndex, value);
 402     };
 403     storeIntegerAt(0, localTime.tm_year + 1900);
 404     storeIntegerAt(1, localTime.tm_mon + 1);
 405     storeIntegerAt(2, localTime.tm_mday);
 406     Fortran::runtime::ApplyIntegerKind<
 407         GmtOffsetHelper<struct tm>::StoreGmtOffset, void>(
 408         kind, terminator, *values, 3, localTime);
 409     storeIntegerAt(4, localTime.tm_hour);
 410     storeIntegerAt(5, localTime.tm_min);
 411     storeIntegerAt(6, localTime.tm_sec);
 412     storeIntegerAt(7, ms);
 413   }
 414 }
 415
 416 #else
 417 // Fallback implementation where gettimeofday or localtime_r are not both
 418 // available (e.g. windows).
 419 static void GetDateAndTime(Fortran::runtime::Terminator &terminator, char *date,
 420     std::size_t dateChars, char *time, std::size_t timeChars, char *zone,
 421     std::size_t zoneChars, const Fortran::runtime::Descriptor *values) {
 422   // TODO: An actual implementation for non Posix system should be added.
 423   // So far, implement as if the date and time is not available on those
 424   // platforms.
 425   DateAndTimeUnavailable(
 426       terminator, date, dateChars, time, timeChars, zone, zoneChars, values);
 427 }
 428 #endif
 429 } // namespace
 430
 431 namespace Fortran::runtime {
 432 extern "C" {
 433
 434 double RTNAME(CpuTime)() { return GetCpuTime(0); }
 435
 436 std::int64_t RTNAME(SystemClockCount)(int kind) {
 437   return GetSystemClockCount(kind, 0);
 438 }
 439
 440 std::int64_t RTNAME(SystemClockCountRate)(int kind) {
 441   return GetSystemClockCountRate(kind, 0);
 442 }
 443
 444 std::int64_t RTNAME(SystemClockCountMax)(int kind) {
 445   return GetSystemClockCountMax(kind, 0);
 446 }
 447
 448 void RTNAME(DateAndTime)(char *date, std::size_t dateChars, char *time,
 449     std::size_t timeChars, char *zone, std::size_t zoneChars,
 450     const char *source, int line, const Descriptor *values) {
 451   Fortran::runtime::Terminator terminator{source, line};
 452   return GetDateAndTime(
 453       terminator, date, dateChars, time, timeChars, zone, zoneChars, values);
 454 }
 455
 456 void RTNAME(Etime)(const Descriptor *values, const Descriptor *time,
 457     const char *sourceFile, int line) {
 458   Fortran::runtime::Terminator terminator{sourceFile, line};
 459
 460   double usrTime = -1.0, sysTime = -1.0, realTime = -1.0;
 461
 462 #ifdef _WIN32
 463   FILETIME creationTime;
 464   FILETIME exitTime;
 465   FILETIME kernelTime;
 466   FILETIME userTime;
 467
 468   if (GetProcessTimes(GetCurrentProcess(), &creationTime, &exitTime,
 469           &kernelTime, &userTime) == 0) {
 470     ULARGE_INTEGER userSystemTime;
 471     ULARGE_INTEGER kernelSystemTime;
 472
 473     memcpy(&userSystemTime, &userTime, sizeof(FILETIME));
 474     memcpy(&kernelSystemTime, &kernelTime, sizeof(FILETIME));
 475
 476     usrTime = ((double)(userSystemTime.QuadPart)) / 10000000.0;
 477     sysTime = ((double)(kernelSystemTime.QuadPart)) / 10000000.0;
 478     realTime = usrTime + sysTime;
 479   }
 480 #else
 481   struct tms tms;
 482   if (times(&tms) != (clock_t)-1) {
 483     usrTime = ((double)(tms.tms_utime)) / sysconf(_SC_CLK_TCK);
 484     sysTime = ((double)(tms.tms_stime)) / sysconf(_SC_CLK_TCK);
 485     realTime = usrTime + sysTime;
 486   }
 487 #endif
 488
 489   if (values) {
 490     auto typeCode{values->type().GetCategoryAndKind()};
 491     // ETIME values argument must have decimal range == 2.
 492     RUNTIME_CHECK(terminator,
 493         values->rank() == 1 && typeCode &&
 494             typeCode->first == Fortran::common::TypeCategory::Real);
 495     // Only accept KIND=4 here.
 496     int kind{typeCode->second};
 497     RUNTIME_CHECK(terminator, kind == 4);
 498     auto extent{values->GetDimension(0).Extent()};
 499     if (extent >= 1) {
 500       ApplyFloatingPointKind<StoreFloatingPointAt, void>(
 501           kind, terminator, *values, /* atIndex = */ 0, usrTime);
 502     }
 503     if (extent >= 2) {
 504       ApplyFloatingPointKind<StoreFloatingPointAt, void>(
 505           kind, terminator, *values, /* atIndex = */ 1, sysTime);
 506     }
 507   }
 508
 509   if (time) {
 510     auto typeCode{time->type().GetCategoryAndKind()};
 511     // ETIME time argument must have decimal range == 0.
 512     RUNTIME_CHECK(terminator,
 513         time->rank() == 0 && typeCode &&
 514             typeCode->first == Fortran::common::TypeCategory::Real);
 515     // Only accept KIND=4 here.
 516     int kind{typeCode->second};
 517     RUNTIME_CHECK(terminator, kind == 4);
 518
 519     ApplyFloatingPointKind<StoreFloatingPointAt, void>(
 520         kind, terminator, *time, /* atIndex = */ 0, realTime);
 521   }
 522 }
 523
 524 } // extern "C"
 525 } // namespace Fortran::runtime