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-exception
6//
7//===----------------------------------------------------------------------===//
8
9// Implements the intrinsic subroutines RANDOM_INIT, RANDOM_NUMBER, and
10// 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;
31Fortran::common::optional<GeneratedWord> nextValue;
32
33extern "C" {
34
35void RTNAME(RandomInit)(bool repeatable, bool /*image_distinct*/) {
36 // TODO: multiple images and image_distinct: add image number
37 {
38 CriticalSection critical{lock};
39 if (repeatable) {
40 generator.seed(0);
41 } else {
42#ifdef CLOCK_REALTIME
43 timespec ts;
44 clock_gettime(CLOCK_REALTIME, tp: &ts);
45 generator.seed(ts.tv_sec ^ ts.tv_nsec);
46#else
47 generator.seed(time(nullptr));
48#endif
49 }
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_FLOAT80
74 GenerateReal<CppTypeFor<TypeCategory::Real, 10>, 64>(harvest);
75 return;
76#endif
77 }
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#endif
104 }
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 else
224 RTNAME(RandomSeedDefaultPut)();
225}
226
227} // extern "C"
228} // namespace Fortran::runtime::random
229

source code of flang-rt/lib/runtime/random.cpp