1//===-- lib/runtime/time-intrinsic.cpp --------------------------*- 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// Implements time-related intrinsic subroutines.
10
11#include "flang/Runtime/time-intrinsic.h"
12#include "flang-rt/runtime/descriptor.h"
13#include "flang-rt/runtime/terminator.h"
14#include "flang-rt/runtime/tools.h"
15#include "flang/Runtime/cpp-type.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.
46namespace {
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.
50using fallback_implementation = double;
51using preferred_implementation = int;
52
53// This is the fallback implementation, which should work everywhere.
54template <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 libflang_rt 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.
92template <typename T = int, typename U = struct timespec>
93double 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, tp: &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
106using count_t = std::int64_t;
107using 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
114constexpr unsigned_count_t DS_PER_SEC{10u};
115constexpr unsigned_count_t MS_PER_SEC{1'000u};
116constexpr unsigned_count_t NS_PER_SEC{1'000'000'000u};
117
118// Computes HUGE(INT(0,kind)) as an unsigned integer value.
119static 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.
129count_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.
144template <typename Unused = void>
145count_t GetSystemClockCount(int kind, fallback_implementation) {
146 struct timespec tspec;
147
148 if (timespec_get(ts: &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
159template <typename Unused = void>
160count_t GetSystemClockCountRate(int kind, fallback_implementation) {
161 return kind >= 8 ? NS_PER_SEC : kind >= 2 ? MS_PER_SEC : DS_PER_SEC;
162}
163
164template <typename Unused = void>
165count_t GetSystemClockCountMax(int kind, fallback_implementation) {
166 unsigned_count_t maxCount{GetHUGE(kind)};
167 return maxCount;
168}
169
170#ifdef CLOCKID_ELAPSED_TIME
171template <typename T = int, typename U = struct timespec>
172count_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, tp: &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
188template <typename T = int, typename U = struct timespec>
189count_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
196template <typename T = int, typename U = struct timespec>
197count_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
207template <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).
219static 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(s: date, c: static_cast<int>(' '), n: dateChars);
225 }
226 if (time) {
227 std::memset(s: time, c: static_cast<int>(' '), n: timeChars);
228 }
229 if (zone) {
230 std::memset(s: zone, c: static_cast<int>(' '), n: 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.
256static 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
291static 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(s: buffer, maxsize: buffSize, format: "%z", tp: localTime);
303#endif
304}
305
306// SFINAE helper to return the struct tm.tm_gmtoff which is not a POSIX standard
307// field.
308template <int KIND, typename TM = struct tm>
309Fortran::runtime::CppTypeFor<Fortran::common::TypeCategory::Integer, KIND>
310GetGmtOffset(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}
315template <int KIND, typename TM = struct tm>
316Fortran::runtime::CppTypeFor<Fortran::common::TypeCategory::Integer, KIND>
317GetGmtOffset(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}
335template <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.
348static 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(tv: &t, tz: 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: &timer, tp: &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(a: len, b: destChars)};
368 std::memcpy(dest: dest, src: buffer, n: copyLen);
369 for (auto i{copyLen}; i < destChars; ++i) {
370 dest[i] = ' ';
371 }
372 }};
373 if (date) {
374 auto len = std::strftime(s: buffer, maxsize: buffSize, format: "%Y%m%d", tp: &localTime);
375 copyBufferAndPad(date, dateChars, len);
376 }
377 if (time) {
378 auto len{std::snprintf(s: buffer, maxlen: buffSize, format: "%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: &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).
419static 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
431namespace Fortran::runtime {
432extern "C" {
433
434double RTNAME(CpuTime)() { return GetCpuTime(0); }
435
436std::int64_t RTNAME(SystemClockCount)(int kind) {
437 return GetSystemClockCount(kind, 0);
438}
439
440std::int64_t RTNAME(SystemClockCountRate)(int kind) {
441 return GetSystemClockCountRate(kind, 0);
442}
443
444std::int64_t RTNAME(SystemClockCountMax)(int kind) {
445 return GetSystemClockCountMax(kind, 0);
446}
447
448void 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
456void 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(buffer: &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
526

source code of flang-rt/lib/runtime/time-intrinsic.cpp