229 lines · cpp
1//===-- lib/runtime/random.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// Implements the intrinsic subroutines RANDOM_INIT, RANDOM_NUMBER, and10// RANDOM_SEED.11 12#include "flang/Runtime/random.h"13#include "flang-rt/runtime/descriptor.h"14#include "flang-rt/runtime/lock.h"15#include "flang-rt/runtime/random-templates.h"16#include "flang-rt/runtime/terminator.h"17#include "flang/Common/float128.h"18#include "flang/Common/leading-zero-bit-count.h"19#include "flang/Common/uint128.h"20#include "flang/Runtime/cpp-type.h"21#include <cmath>22#include <cstdint>23#include <limits>24#include <memory>25#include <time.h>26 27namespace Fortran::runtime::random {28 29Lock lock;30Generator generator;31common::optional<GeneratedWord> nextValue;32 33extern "C" {34 35void RTNAME(RandomInit)(bool repeatable, bool /*image_distinct*/) {36 // TODO: multiple images and image_distinct: add image number37 {38 CriticalSection critical{lock};39 if (repeatable) {40 generator.seed(0);41 } else {42#ifdef CLOCK_REALTIME43 timespec ts;44 clock_gettime(CLOCK_REALTIME, &ts);45 generator.seed(ts.tv_sec ^ ts.tv_nsec);46#else47 generator.seed(time(nullptr));48#endif49 }50 }51}52 53void RTNAME(RandomNumber)(54 const Descriptor &harvest, const char *source, int line) {55 Terminator terminator{source, line};56 auto typeCode{harvest.type().GetCategoryAndKind()};57 RUNTIME_CHECK(terminator,58 typeCode &&59 (typeCode->first == TypeCategory::Real ||60 typeCode->first == TypeCategory::Unsigned));61 int kind{typeCode->second};62 if (typeCode->first == TypeCategory::Real) {63 switch (kind) {64 // TODO: REAL (2 & 3)65 case 4:66 GenerateReal<CppTypeFor<TypeCategory::Real, 4>, 24>(harvest);67 return;68 case 8:69 GenerateReal<CppTypeFor<TypeCategory::Real, 8>, 53>(harvest);70 return;71 case 10:72 if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) {73#if HAS_FLOAT8074 GenerateReal<CppTypeFor<TypeCategory::Real, 10>, 64>(harvest);75 return;76#endif77 }78 break;79 }80 terminator.Crash(81 "not yet implemented: intrinsic: REAL(KIND=%d) in RANDOM_NUMBER", kind);82 } else if (typeCode->first == TypeCategory::Unsigned) {83 switch (kind) {84 case 1:85 GenerateUnsigned<CppTypeFor<TypeCategory::Unsigned, 1>>(harvest);86 return;87 case 2:88 GenerateUnsigned<CppTypeFor<TypeCategory::Unsigned, 2>>(harvest);89 return;90 case 4:91 GenerateUnsigned<CppTypeFor<TypeCategory::Unsigned, 4>>(harvest);92 return;93 case 8:94 GenerateUnsigned<CppTypeFor<TypeCategory::Unsigned, 8>>(harvest);95 return;96#ifdef __SIZEOF_INT128__97 case 16:98 if constexpr (HasCppTypeFor<TypeCategory::Unsigned, 16>) {99 GenerateUnsigned<CppTypeFor<TypeCategory::Unsigned, 16>>(harvest);100 return;101 }102 break;103#endif104 }105 terminator.Crash(106 "not yet implemented: intrinsic: UNSIGNED(KIND=%d) in RANDOM_NUMBER",107 kind);108 }109}110 111void RTNAME(RandomSeedSize)(112 const Descriptor *size, const char *source, int line) {113 if (!size || !size->raw().base_addr) {114 RTNAME(RandomSeedDefaultPut)();115 return;116 }117 Terminator terminator{source, line};118 auto typeCode{size->type().GetCategoryAndKind()};119 RUNTIME_CHECK(terminator,120 size->rank() == 0 && typeCode &&121 typeCode->first == TypeCategory::Integer);122 int sizeArg{typeCode->second};123 switch (sizeArg) {124 case 4:125 *size->OffsetElement<CppTypeFor<TypeCategory::Integer, 4>>() = 1;126 break;127 case 8:128 *size->OffsetElement<CppTypeFor<TypeCategory::Integer, 8>>() = 1;129 break;130 default:131 terminator.Crash(132 "not yet implemented: intrinsic: RANDOM_SEED(SIZE=): size %d\n",133 sizeArg);134 }135}136 137void RTNAME(RandomSeedPut)(138 const Descriptor *put, const char *source, int line) {139 if (!put || !put->raw().base_addr) {140 RTNAME(RandomSeedDefaultPut)();141 return;142 }143 Terminator terminator{source, line};144 auto typeCode{put->type().GetCategoryAndKind()};145 RUNTIME_CHECK(terminator,146 put->rank() == 1 && typeCode &&147 typeCode->first == TypeCategory::Integer &&148 put->GetDimension(0).Extent() >= 1);149 int putArg{typeCode->second};150 GeneratedWord seed;151 switch (putArg) {152 case 4:153 seed = *put->OffsetElement<CppTypeFor<TypeCategory::Integer, 4>>();154 break;155 case 8:156 seed = *put->OffsetElement<CppTypeFor<TypeCategory::Integer, 8>>();157 break;158 default:159 terminator.Crash(160 "not yet implemented: intrinsic: RANDOM_SEED(PUT=): put %d\n", putArg);161 }162 {163 CriticalSection critical{lock};164 generator.seed(seed);165 nextValue = seed;166 }167}168 169void RTNAME(RandomSeedDefaultPut)() {170 // TODO: should this be time &/or image dependent?171 {172 CriticalSection critical{lock};173 generator.seed(0);174 }175}176 177void RTNAME(RandomSeedGet)(178 const Descriptor *get, const char *source, int line) {179 if (!get || !get->raw().base_addr) {180 RTNAME(RandomSeedDefaultPut)();181 return;182 }183 Terminator terminator{source, line};184 auto typeCode{get->type().GetCategoryAndKind()};185 RUNTIME_CHECK(terminator,186 get->rank() == 1 && typeCode &&187 typeCode->first == TypeCategory::Integer &&188 get->GetDimension(0).Extent() >= 1);189 int getArg{typeCode->second};190 GeneratedWord seed;191 {192 CriticalSection critical{lock};193 seed = GetNextValue();194 nextValue = seed;195 }196 switch (getArg) {197 case 4:198 *get->OffsetElement<CppTypeFor<TypeCategory::Integer, 4>>() = seed;199 break;200 case 8:201 *get->OffsetElement<CppTypeFor<TypeCategory::Integer, 8>>() = seed;202 break;203 default:204 terminator.Crash(205 "not yet implemented: intrinsic: RANDOM_SEED(GET=): get %d\n", getArg);206 }207}208 209void RTNAME(RandomSeed)(const Descriptor *size, const Descriptor *put,210 const Descriptor *get, const char *source, int line) {211 bool sizePresent = size && size->raw().base_addr;212 bool putPresent = put && put->raw().base_addr;213 bool getPresent = get && get->raw().base_addr;214 if (sizePresent + putPresent + getPresent > 1)215 Terminator{source, line}.Crash(216 "RANDOM_SEED must have either 1 or no arguments");217 if (sizePresent)218 RTNAME(RandomSeedSize)(size, source, line);219 else if (putPresent)220 RTNAME(RandomSeedPut)(put, source, line);221 else if (getPresent)222 RTNAME(RandomSeedGet)(get, source, line);223 else224 RTNAME(RandomSeedDefaultPut)();225}226 227} // extern "C"228} // namespace Fortran::runtime::random229