460 lines · cpp
1//===-- lib/runtime/extensions.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-exception6//7//===----------------------------------------------------------------------===//8 9// These C-coded entry points with Fortran-mangled names implement legacy10// extensions that will eventually be implemented in Fortran.11 12#include "flang/Runtime/extensions.h"13#include "unit.h"14#include "flang-rt/runtime/descriptor.h"15#include "flang-rt/runtime/terminator.h"16#include "flang-rt/runtime/tools.h"17#include "flang/Runtime/command.h"18#include "flang/Runtime/entry-names.h"19#include "flang/Runtime/io-api.h"20#include "flang/Runtime/iostat-consts.h"21#include <atomic>22#include <chrono>23#include <cstdio>24#include <cstring>25#include <ctime>26#include <signal.h>27#include <stdlib.h>28#include <thread>29 30#ifdef _WIN3231#include "flang/Common/windows-include.h"32#include <synchapi.h>33 34inline void CtimeBuffer(char *buffer, size_t bufsize, const time_t cur_time,35 Fortran::runtime::Terminator terminator) {36 int error{ctime_s(buffer, bufsize, &cur_time)};37 RUNTIME_CHECK(terminator, error == 0);38}39#elif _POSIX_C_SOURCE >= 1 || _XOPEN_SOURCE || _BSD_SOURCE || _SVID_SOURCE || \40 defined(_POSIX_SOURCE)41inline void CtimeBuffer(char *buffer, size_t bufsize, const time_t cur_time,42 Fortran::runtime::Terminator terminator) {43 const char *res{ctime_r(&cur_time, buffer)};44 RUNTIME_CHECK(terminator, res != nullptr);45}46#else47inline void CtimeBuffer(char *buffer, size_t bufsize, const time_t cur_time,48 Fortran::runtime::Terminator terminator) {49 buffer[0] = '\0';50 terminator.Crash("fdate is not supported.");51}52#endif53 54#ifndef _WIN3255// posix-compliant and has getlogin_r and F_OK56#include <unistd.h>57#else58#include <direct.h>59#endif60 61namespace Fortran::runtime {62 63// Common implementation that could be used for either SECNDS() or DSECNDS(),64// which are defined for float or double.65template <typename T> T SecndsImpl(T *refTime) {66 static_assert(std::is_same<T, float>::value || std::is_same<T, double>::value,67 "T must be float or double");68 constexpr T FAIL_SECNDS{T{-1.0}}; // Failure code for this function69 // Failure code for time functions that return std::time_t70 constexpr std::time_t FAIL_TIME{std::time_t{-1}};71 constexpr std::time_t TIME_UNINITIALIZED{std::time_t{0}};72 if (!refTime) {73 return FAIL_SECNDS;74 }75 std::time_t now{std::time(nullptr)};76 if (now == FAIL_TIME) {77 return FAIL_SECNDS;78 }79 // In case we are using a float result, we can only precisely store80 // 2^24 seconds, which comes out to about 194 days. Thus, need to pick81 // a starting point, which will allow us to keep the time diffs as precise82 // as possible. Given the description of this function, midnight of the83 // current day is the best starting point.84 static std::atomic<std::time_t> startingPoint{TIME_UNINITIALIZED};85 // "Acquire" will give us writes from other threads.86 std::time_t localStartingPoint{startingPoint.load(std::memory_order_acquire)};87 // Initialize startingPoint if we haven't initialized it yet or88 // if we were passed 0.0, which indicates to compute seconds from89 // current day's midnight.90 if (localStartingPoint == TIME_UNINITIALIZED || *refTime == 0.0) {91 // Compute midnight in the current timezone and try to initialize92 // startingPoint with it. If there are any errors during computation,93 // exit with error and hope that the other threads have better luck94 // (or the user retries the call).95 struct tm timeInfo;96#ifdef _WIN3297 if (localtime_s(&timeInfo, &now)) {98#else99 if (!localtime_r(&now, &timeInfo)) {100#endif101 return FAIL_SECNDS;102 }103 // Back to midnight104 timeInfo.tm_hour = 0;105 timeInfo.tm_min = 0;106 timeInfo.tm_sec = 0;107 localStartingPoint = std::mktime(&timeInfo);108 if (localStartingPoint == FAIL_TIME) {109 return FAIL_SECNDS;110 }111 INTERNAL_CHECK(localStartingPoint > TIME_UNINITIALIZED);112 // Attempt to atomically set startingPoint to localStartingPoint113 std::time_t expected{TIME_UNINITIALIZED};114 if (startingPoint.compare_exchange_strong(expected, localStartingPoint,115 std::memory_order_acq_rel, // "Acquire and release" on success116 std::memory_order_acquire)) { // "Acquire" on failure117 // startingPoint was set to localStartingPoint118 } else {119 // startingPoint was already initialized and its value was loaded120 // into `expected`. Discard our precomputed midnight value in favor121 // of the one from startingPoint.122 localStartingPoint = expected;123 }124 }125 double diffStartingPoint{std::difftime(now, localStartingPoint)};126 return static_cast<T>(diffStartingPoint) - *refTime;127}128 129extern "C" {130 131gid_t RTNAME(GetGID)() {132#ifdef _WIN32133 // Group IDs don't exist on Windows, return 1 to avoid errors134 return 1;135#else136 return getgid();137#endif138}139 140uid_t RTNAME(GetUID)() {141#ifdef _WIN32142 // User IDs don't exist on Windows, return 1 to avoid errors143 return 1;144#else145 return getuid();146#endif147}148 149void GetUsernameEnvVar(const char *envName, char *arg, std::int64_t length) {150 Descriptor name{*Descriptor::Create(151 1, runtime::strlen(envName) + 1, const_cast<char *>(envName), 0)};152 Descriptor value{*Descriptor::Create(1, length, arg, 0)};153 154 RTNAME(GetEnvVariable)155 (name, &value, nullptr, false, nullptr, __FILE__, __LINE__);156}157 158namespace io {159// SUBROUTINE FLUSH(N)160// FLUSH N161// END162void FORTRAN_PROCEDURE_NAME(flush)(const int &unit) {163 Cookie cookie{IONAME(BeginFlush)(unit, __FILE__, __LINE__)};164 IONAME(EndIoStatement)(cookie);165}166 167void RTNAME(Flush)(int unit) {168 // We set the `unit == -1` on the `flush()` case, so flush all units.169 if (unit < 0) {170 Terminator terminator{__FILE__, __LINE__};171 IoErrorHandler handler{terminator};172 ExternalFileUnit::FlushAll(handler);173 return;174 }175 FORTRAN_PROCEDURE_NAME(flush)(unit);176}177} // namespace io178 179// CALL FDATE(DATE)180void FORTRAN_PROCEDURE_NAME(fdate)(char *arg, std::int64_t length) {181 // Day Mon dd hh:mm:ss yyyy\n\0 is 26 characters, e.g.182 // Tue May 26 21:51:03 2015\n\0183 char str[26];184 // Insufficient space, fill with spaces and return.185 if (length < 24) {186 runtime::memset(arg, ' ', length);187 return;188 }189 190 Terminator terminator{__FILE__, __LINE__};191 std::time_t current_time;192 std::time(¤t_time);193 CtimeBuffer(str, sizeof(str), current_time, terminator);194 195 // Pad space on the last two byte `\n\0`, start at index 24 included.196 CopyAndPad(arg, str, length, 24);197}198 199std::intptr_t RTNAME(Malloc)(std::size_t size) {200 return reinterpret_cast<std::intptr_t>(std::malloc(size));201}202 203// RESULT = IARGC()204std::int32_t FORTRAN_PROCEDURE_NAME(iargc)() { return RTNAME(ArgumentCount)(); }205 206// CALL GETARG(N, ARG)207void FORTRAN_PROCEDURE_NAME(getarg)(208 std::int32_t &n, char *arg, std::int64_t length) {209 Descriptor value{*Descriptor::Create(1, length, arg, 0)};210 (void)RTNAME(GetCommandArgument)(211 n, &value, nullptr, nullptr, __FILE__, __LINE__);212}213 214// CALL GETLOG(USRNAME)215void FORTRAN_PROCEDURE_NAME(getlog)(char *arg, std::int64_t length) {216#if _REENTRANT || _POSIX_C_SOURCE >= 199506L217 if (length >= 1 && getlogin_r(arg, length) == 0) {218 auto loginLen{runtime::strlen(arg)};219 runtime::memset(220 arg + loginLen, ' ', static_cast<std::size_t>(length) - loginLen);221 return;222 }223#endif224#if _WIN32225 GetUsernameEnvVar("USERNAME", arg, length);226#else227 GetUsernameEnvVar("LOGNAME", arg, length);228#endif229}230 231void RTNAME(Free)(std::intptr_t ptr) {232 std::free(reinterpret_cast<void *>(ptr));233}234 235std::int64_t RTNAME(Signal)(std::int64_t number, void (*handler)(int)) {236 // using auto for portability:237 // on Windows, this is a void *238 // on POSIX, this has the same type as handler239 auto result = signal(number, handler);240 241 // GNU defines the intrinsic as returning an integer, not a pointer. So we242 // have to reinterpret_cast243 return static_cast<int64_t>(reinterpret_cast<std::uintptr_t>(result));244}245 246// CALL SLEEP(SECONDS)247void RTNAME(Sleep)(std::int64_t seconds) {248 // ensure that conversion to unsigned makes sense,249 // sleep(0) is an immidiate return anyway250 if (seconds < 1) {251 return;252 }253#if _WIN32254 Sleep(seconds * 1000);255#else256 sleep(seconds);257#endif258}259 260// TODO: not supported on Windows261#ifndef _WIN32262std::int64_t FORTRAN_PROCEDURE_NAME(access)(const char *name,263 std::int64_t nameLength, const char *mode, std::int64_t modeLength) {264 std::int64_t ret{-1};265 if (nameLength <= 0 || modeLength <= 0 || !name || !mode) {266 return ret;267 }268 269 // ensure name is null terminated270 char *newName{nullptr};271 if (name[nameLength - 1] != '\0') {272 newName = static_cast<char *>(std::malloc(nameLength + 1));273 runtime::memcpy(newName, name, nameLength);274 newName[nameLength] = '\0';275 name = newName;276 }277 278 // calculate mode279 bool read{false};280 bool write{false};281 bool execute{false};282 bool exists{false};283 int imode{0};284 285 for (std::int64_t i = 0; i < modeLength; ++i) {286 switch (mode[i]) {287 case 'r':288 read = true;289 break;290 case 'w':291 write = true;292 break;293 case 'x':294 execute = true;295 break;296 case ' ':297 exists = true;298 break;299 default:300 // invalid mode301 goto cleanup;302 }303 }304 if (!read && !write && !execute && !exists) {305 // invalid mode306 goto cleanup;307 }308 309 if (!read && !write && !execute) {310 imode = F_OK;311 } else {312 if (read) {313 imode |= R_OK;314 }315 if (write) {316 imode |= W_OK;317 }318 if (execute) {319 imode |= X_OK;320 }321 }322 ret = access(name, imode);323 324cleanup:325 if (newName) {326 free(newName);327 }328 return ret;329}330#endif331 332// CHDIR(DIR)333int RTNAME(Chdir)(const char *name) {334// chdir alias seems to be deprecated on Windows.335#ifndef _WIN32336 return chdir(name);337#else338 return _chdir(name);339#endif340}341 342int FORTRAN_PROCEDURE_NAME(hostnm)(char *hn, int length) {343 std::int32_t status{0};344 345 if (!hn || length < 0) {346 return EINVAL;347 }348 349#ifdef _WIN32350 DWORD dwSize{static_cast<DWORD>(length)};351 352 // Note: Winsock has gethostname(), but use Win32 API GetComputerNameEx(),353 // in order to avoid adding dependency on Winsock.354 if (!GetComputerNameExA(ComputerNameDnsHostname, hn, &dwSize)) {355 status = GetLastError();356 }357#else358 if (gethostname(hn, length) < 0) {359 status = errno;360 }361#endif362 363 if (status == 0) {364 // Find zero terminator and fill the string from the365 // zero terminator to the end with spaces366 char *str_end{hn + length};367 char *str_zero{std::find(hn, str_end, '\0')};368 std::fill(str_zero, str_end, ' ');369 }370 371 return status;372}373 374int FORTRAN_PROCEDURE_NAME(ierrno)() { return errno; }375 376void FORTRAN_PROCEDURE_NAME(qsort)(int *array, int *len, int *isize,377 int (*compar)(const void *, const void *)) {378 qsort(array, *len, *isize, compar);379}380 381// PERROR(STRING)382void RTNAME(Perror)(const char *str) { perror(str); }383 384// GNU extension function SECNDS(refTime)385float FORTRAN_PROCEDURE_NAME(secnds)(float *refTime) {386 return SecndsImpl(refTime);387}388 389float RTNAME(Secnds)(float *refTime, const char *sourceFile, int line) {390 Terminator terminator{sourceFile, line};391 RUNTIME_CHECK(terminator, refTime != nullptr);392 return FORTRAN_PROCEDURE_NAME(secnds)(refTime);393}394 395// PGI extension function DSECNDS(refTime)396double FORTRAN_PROCEDURE_NAME(dsecnds)(double *refTime) {397 return SecndsImpl(refTime);398}399 400double RTNAME(Dsecnds)(double *refTime, const char *sourceFile, int line) {401 Terminator terminator{sourceFile, line};402 RUNTIME_CHECK(terminator, refTime != nullptr);403 return FORTRAN_PROCEDURE_NAME(dsecnds)(refTime);404}405 406// GNU extension function TIME()407std::int64_t RTNAME(time)() { return time(nullptr); }408 409// MCLOCK: returns accumulated CPU time in ticks410std::int32_t FORTRAN_PROCEDURE_NAME(mclock)() { return std::clock(); }411 412void RTNAME(ShowDescriptor)(const Fortran::runtime::Descriptor *descr) {413 if (descr) {414 descr->Dump(stderr, /*dumpRawType=*/false);415 } else {416 std::fprintf(stderr, "NULL\n");417 }418}419 420// Extension procedures related to I/O421 422namespace io {423std::int32_t RTNAME(Fseek)(int unitNumber, std::int64_t zeroBasedPos,424 int whence, const char *sourceFileName, int lineNumber) {425 if (ExternalFileUnit * unit{ExternalFileUnit::LookUp(unitNumber)}) {426 Terminator terminator{sourceFileName, lineNumber};427 IoErrorHandler handler{terminator};428 if (unit->Fseek(429 zeroBasedPos, static_cast<enum FseekWhence>(whence), handler)) {430 return IostatOk;431 } else {432 return IostatCannotReposition;433 }434 } else {435 return IostatBadUnitNumber;436 }437}438 439std::int64_t RTNAME(Ftell)(int unitNumber) {440 if (ExternalFileUnit * unit{ExternalFileUnit::LookUp(unitNumber)}) {441 return unit->InquirePos() - 1; // zero-based result442 } else {443 return -1;444 }445}446 447std::int32_t FORTRAN_PROCEDURE_NAME(fnum)(const int &unitNumber) {448 if (ExternalFileUnit * unit{ExternalFileUnit::LookUp(unitNumber)}) {449 return unit->fd();450 } else {451 return -1;452 }453}454 455} // namespace io456 457} // extern "C"458 459} // namespace Fortran::runtime460