llvm-project

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
// This is the fallback implementation, which should work everywhere.
143
template <typename Unused = void>
144
count_t GetSystemClockCount(int kind, fallback_implementation) {
145
  struct timespec tspec;
146

147
  if (timespec_get(&tspec, TIME_UTC) < 0) {
148
    // Return -HUGE(COUNT) to represent failure.
149
    return -static_cast<count_t>(GetHUGE(kind));
150
  }
151

152
  // Compute the timestamp as seconds plus nanoseconds in accordance
153
  // with the requested kind at the call site.
154
  return ConvertTimeSpecToCount(kind, tspec);
155
}
156

157
template <typename Unused = void>
158
count_t GetSystemClockCountRate(int kind, fallback_implementation) {
159
  return kind >= 8 ? NS_PER_SEC : kind >= 2 ? MS_PER_SEC : DS_PER_SEC;
160
}
161

162
template <typename Unused = void>
163
count_t GetSystemClockCountMax(int kind, fallback_implementation) {
164
  unsigned_count_t maxCount{GetHUGE(kind)};
165
  return maxCount;
166
}
167

168
#ifdef CLOCKID_ELAPSED_TIME
169
template <typename T = int, typename U = struct timespec>
170
count_t GetSystemClockCount(int kind, preferred_implementation,
171
    // We need some dummy parameters to pass to decltype(clock_gettime).
172
    T ClockId = 0, U *Timespec = nullptr,
173
    decltype(clock_gettime(ClockId, Timespec)) *Enabled = nullptr) {
174
  struct timespec tspec;
175
  const unsigned_count_t huge{GetHUGE(kind)};
176
  if (clock_gettime(CLOCKID_ELAPSED_TIME, &tspec) != 0) {
177
    return -huge; // failure
178
  }
179

180
  // Compute the timestamp as seconds plus nanoseconds in accordance
181
  // with the requested kind at the call site.
182
  return ConvertTimeSpecToCount(kind, tspec);
183
}
184
#endif // CLOCKID_ELAPSED_TIME
185

186
template <typename T = int, typename U = struct timespec>
187
count_t GetSystemClockCountRate(int kind, preferred_implementation,
188
    // We need some dummy parameters to pass to decltype(clock_gettime).
189
    T ClockId = 0, U *Timespec = nullptr,
190
    decltype(clock_gettime(ClockId, Timespec)) *Enabled = nullptr) {
191
  return kind >= 8 ? NS_PER_SEC : kind >= 2 ? MS_PER_SEC : DS_PER_SEC;
192
}
193

194
template <typename T = int, typename U = struct timespec>
195
count_t GetSystemClockCountMax(int kind, preferred_implementation,
196
    // We need some dummy parameters to pass to decltype(clock_gettime).
197
    T ClockId = 0, U *Timespec = nullptr,
198
    decltype(clock_gettime(ClockId, Timespec)) *Enabled = nullptr) {
199
  return GetHUGE(kind);
200
}
201

202
// DATE_AND_TIME (Fortran 2018 16.9.59)
203

204
// Helper to set an integer value to -HUGE
205
template <int KIND> struct StoreNegativeHugeAt {
206
  void operator()(
207
      const Fortran::runtime::Descriptor &result, std::size_t at) const {
208
    *result.ZeroBasedIndexedElement<Fortran::runtime::CppTypeFor<
209
        Fortran::common::TypeCategory::Integer, KIND>>(at) =
210
        -std::numeric_limits<Fortran::runtime::CppTypeFor<
211
            Fortran::common::TypeCategory::Integer, KIND>>::max();
212
  }
213
};
214

215
// Default implementation when date and time information is not available (set
216
// strings to blanks and values to -HUGE as defined by the standard).
217
static void DateAndTimeUnavailable(Fortran::runtime::Terminator &terminator,
218
    char *date, std::size_t dateChars, char *time, std::size_t timeChars,
219
    char *zone, std::size_t zoneChars,
220
    const Fortran::runtime::Descriptor *values) {
221
  if (date) {
222
    std::memset(date, static_cast<int>(' '), dateChars);
223
  }
224
  if (time) {
225
    std::memset(time, static_cast<int>(' '), timeChars);
226
  }
227
  if (zone) {
228
    std::memset(zone, static_cast<int>(' '), zoneChars);
229
  }
230
  if (values) {
231
    auto typeCode{values->type().GetCategoryAndKind()};
232
    RUNTIME_CHECK(terminator,
233
        values->rank() == 1 && values->GetDimension(0).Extent() >= 8 &&
234
            typeCode &&
235
            typeCode->first == Fortran::common::TypeCategory::Integer);
236
    // DATE_AND_TIME values argument must have decimal range > 4. Do not accept
237
    // KIND 1 here.
238
    int kind{typeCode->second};
239
    RUNTIME_CHECK(terminator, kind != 1);
240
    for (std::size_t i = 0; i < 8; ++i) {
241
      Fortran::runtime::ApplyIntegerKind<StoreNegativeHugeAt, void>(
242
          kind, terminator, *values, i);
243
    }
244
  }
245
}
246

247
#ifndef _WIN32
248

249
// SFINAE helper to return the struct tm.tm_gmtoff which is not a POSIX standard
250
// field.
251
template <int KIND, typename TM = struct tm>
252
Fortran::runtime::CppTypeFor<Fortran::common::TypeCategory::Integer, KIND>
253
GetGmtOffset(const TM &tm, preferred_implementation,
254
    decltype(tm.tm_gmtoff) *Enabled = nullptr) {
255
  // Returns the GMT offset in minutes.
256
  return tm.tm_gmtoff / 60;
257
}
258
template <int KIND, typename TM = struct tm>
259
Fortran::runtime::CppTypeFor<Fortran::common::TypeCategory::Integer, KIND>
260
GetGmtOffset(const TM &tm, fallback_implementation) {
261
  // tm.tm_gmtoff is not available, there may be platform dependent alternatives
262
  // (such as using timezone from <time.h> when available), but so far just
263
  // return -HUGE to report that this information is not available.
264
  return -std::numeric_limits<Fortran::runtime::CppTypeFor<
265
      Fortran::common::TypeCategory::Integer, KIND>>::max();
266
}
267
template <typename TM = struct tm> struct GmtOffsetHelper {
268
  template <int KIND> struct StoreGmtOffset {
269
    void operator()(const Fortran::runtime::Descriptor &result, std::size_t at,
270
        TM &tm) const {
271
      *result.ZeroBasedIndexedElement<Fortran::runtime::CppTypeFor<
272
          Fortran::common::TypeCategory::Integer, KIND>>(at) =
273
          GetGmtOffset<KIND>(tm, 0);
274
    }
275
  };
276
};
277

278
// Dispatch to posix implementation where gettimeofday and localtime_r are
279
// available.
280
static void GetDateAndTime(Fortran::runtime::Terminator &terminator, char *date,
281
    std::size_t dateChars, char *time, std::size_t timeChars, char *zone,
282
    std::size_t zoneChars, const Fortran::runtime::Descriptor *values) {
283

284
  timeval t;
285
  if (gettimeofday(&t, nullptr) != 0) {
286
    DateAndTimeUnavailable(
287
        terminator, date, dateChars, time, timeChars, zone, zoneChars, values);
288
    return;
289
  }
290
  time_t timer{t.tv_sec};
291
  tm localTime;
292
  localtime_r(&timer, &localTime);
293
  std::intmax_t ms{t.tv_usec / 1000};
294

295
  static constexpr std::size_t buffSize{16};
296
  char buffer[buffSize];
297
  auto copyBufferAndPad{
298
      [&](char *dest, std::size_t destChars, std::size_t len) {
299
        auto copyLen{std::min(len, destChars)};
300
        std::memcpy(dest, buffer, copyLen);
301
        for (auto i{copyLen}; i < destChars; ++i) {
302
          dest[i] = ' ';
303
        }
304
      }};
305
  if (date) {
306
    auto len = std::strftime(buffer, buffSize, "%Y%m%d", &localTime);
307
    copyBufferAndPad(date, dateChars, len);
308
  }
309
  if (time) {
310
    auto len{std::snprintf(buffer, buffSize, "%02d%02d%02d.%03jd",
311
        localTime.tm_hour, localTime.tm_min, localTime.tm_sec, ms)};
312
    copyBufferAndPad(time, timeChars, len);
313
  }
314
  if (zone) {
315
    // Note: this may leave the buffer empty on many platforms. Classic flang
316
    // has a much more complex way of doing this (see __io_timezone in classic
317
    // flang).
318
    auto len{std::strftime(buffer, buffSize, "%z", &localTime)};
319
    copyBufferAndPad(zone, zoneChars, len);
320
  }
321
  if (values) {
322
    auto typeCode{values->type().GetCategoryAndKind()};
323
    RUNTIME_CHECK(terminator,
324
        values->rank() == 1 && values->GetDimension(0).Extent() >= 8 &&
325
            typeCode &&
326
            typeCode->first == Fortran::common::TypeCategory::Integer);
327
    // DATE_AND_TIME values argument must have decimal range > 4. Do not accept
328
    // KIND 1 here.
329
    int kind{typeCode->second};
330
    RUNTIME_CHECK(terminator, kind != 1);
331
    auto storeIntegerAt = [&](std::size_t atIndex, std::int64_t value) {
332
      Fortran::runtime::ApplyIntegerKind<Fortran::runtime::StoreIntegerAt,
333
          void>(kind, terminator, *values, atIndex, value);
334
    };
335
    storeIntegerAt(0, localTime.tm_year + 1900);
336
    storeIntegerAt(1, localTime.tm_mon + 1);
337
    storeIntegerAt(2, localTime.tm_mday);
338
    Fortran::runtime::ApplyIntegerKind<
339
        GmtOffsetHelper<struct tm>::StoreGmtOffset, void>(
340
        kind, terminator, *values, 3, localTime);
341
    storeIntegerAt(4, localTime.tm_hour);
342
    storeIntegerAt(5, localTime.tm_min);
343
    storeIntegerAt(6, localTime.tm_sec);
344
    storeIntegerAt(7, ms);
345
  }
346
}
347

348
#else
349
// Fallback implementation where gettimeofday or localtime_r are not both
350
// available (e.g. windows).
351
static void GetDateAndTime(Fortran::runtime::Terminator &terminator, char *date,
352
    std::size_t dateChars, char *time, std::size_t timeChars, char *zone,
353
    std::size_t zoneChars, const Fortran::runtime::Descriptor *values) {
354
  // TODO: An actual implementation for non Posix system should be added.
355
  // So far, implement as if the date and time is not available on those
356
  // platforms.
357
  DateAndTimeUnavailable(
358
      terminator, date, dateChars, time, timeChars, zone, zoneChars, values);
359
}
360
#endif
361
} // namespace
362

363
namespace Fortran::runtime {
364
extern "C" {
365

366
double RTNAME(CpuTime)() { return GetCpuTime(0); }
367

368
std::int64_t RTNAME(SystemClockCount)(int kind) {
369
  return GetSystemClockCount(kind, 0);
370
}
371

372
std::int64_t RTNAME(SystemClockCountRate)(int kind) {
373
  return GetSystemClockCountRate(kind, 0);
374
}
375

376
std::int64_t RTNAME(SystemClockCountMax)(int kind) {
377
  return GetSystemClockCountMax(kind, 0);
378
}
379

380
void RTNAME(DateAndTime)(char *date, std::size_t dateChars, char *time,
381
    std::size_t timeChars, char *zone, std::size_t zoneChars,
382
    const char *source, int line, const Descriptor *values) {
383
  Fortran::runtime::Terminator terminator{source, line};
384
  return GetDateAndTime(
385
      terminator, date, dateChars, time, timeChars, zone, zoneChars, values);
386
}
387

388
void RTNAME(Etime)(const Descriptor *values, const Descriptor *time,
389
    const char *sourceFile, int line) {
390
  Fortran::runtime::Terminator terminator{sourceFile, line};
391

392
  double usrTime = -1.0, sysTime = -1.0, realTime = -1.0;
393

394
#ifdef _WIN32
395
  FILETIME creationTime;
396
  FILETIME exitTime;
397
  FILETIME kernelTime;
398
  FILETIME userTime;
399

400
  if (GetProcessTimes(GetCurrentProcess(), &creationTime, &exitTime,
401
          &kernelTime, &userTime) == 0) {
402
    ULARGE_INTEGER userSystemTime;
403
    ULARGE_INTEGER kernelSystemTime;
404

405
    memcpy(&userSystemTime, &userTime, sizeof(FILETIME));
406
    memcpy(&kernelSystemTime, &kernelTime, sizeof(FILETIME));
407

408
    usrTime = ((double)(userSystemTime.QuadPart)) / 10000000.0;
409
    sysTime = ((double)(kernelSystemTime.QuadPart)) / 10000000.0;
410
    realTime = usrTime + sysTime;
411
  }
412
#else
413
  struct tms tms;
414
  if (times(&tms) != (clock_t)-1) {
415
    usrTime = ((double)(tms.tms_utime)) / sysconf(_SC_CLK_TCK);
416
    sysTime = ((double)(tms.tms_stime)) / sysconf(_SC_CLK_TCK);
417
    realTime = usrTime + sysTime;
418
  }
419
#endif
420

421
  if (values) {
422
    auto typeCode{values->type().GetCategoryAndKind()};
423
    // ETIME values argument must have decimal range == 2.
424
    RUNTIME_CHECK(terminator,
425
        values->rank() == 1 && values->GetDimension(0).Extent() == 2 &&
426
            typeCode && typeCode->first == Fortran::common::TypeCategory::Real);
427
    // Only accept KIND=4 here.
428
    int kind{typeCode->second};
429
    RUNTIME_CHECK(terminator, kind == 4);
430

431
    ApplyFloatingPointKind<StoreFloatingPointAt, void>(
432
        kind, terminator, *values, /* atIndex = */ 0, usrTime);
433
    ApplyFloatingPointKind<StoreFloatingPointAt, void>(
434
        kind, terminator, *values, /* atIndex = */ 1, sysTime);
435
  }
436

437
  if (time) {
438
    auto typeCode{time->type().GetCategoryAndKind()};
439
    // ETIME time argument must have decimal range == 0.
440
    RUNTIME_CHECK(terminator,
441
        time->rank() == 0 && typeCode &&
442
            typeCode->first == Fortran::common::TypeCategory::Real);
443
    // Only accept KIND=4 here.
444
    int kind{typeCode->second};
445
    RUNTIME_CHECK(terminator, kind == 4);
446

447
    ApplyFloatingPointKind<StoreFloatingPointAt, void>(
448
        kind, terminator, *time, /* atIndex = */ 0, realTime);
449
  }
450
}
451

452
} // extern "C"
453
} // namespace Fortran::runtime
454