1//===-- runtime/random.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 the intrinsic subroutines RANDOM_INIT, RANDOM_NUMBER, and
10// RANDOM_SEED.
11
12#include "flang/Runtime/random.h"
13#include "lock.h"
14#include "random-templates.h"
15#include "terminator.h"
16#include "flang/Common/float128.h"
17#include "flang/Common/leading-zero-bit-count.h"
18#include "flang/Common/uint128.h"
19#include "flang/Runtime/cpp-type.h"
20#include "flang/Runtime/descriptor.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(s: 0);
41 } else {
42#ifdef CLOCK_REALTIME
43 timespec ts;
44 clock_gettime(CLOCK_REALTIME, tp: &ts);
45 generator.seed(s: 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, typeCode && typeCode->first == TypeCategory::Real);
58 int kind{typeCode->second};
59 switch (kind) {
60 // TODO: REAL (2 & 3)
61 case 4:
62 Generate<CppTypeFor<TypeCategory::Real, 4>, 24>(harvest);
63 return;
64 case 8:
65 Generate<CppTypeFor<TypeCategory::Real, 8>, 53>(harvest);
66 return;
67 case 10:
68 if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) {
69#if LDBL_MANT_DIG == 64
70 Generate<CppTypeFor<TypeCategory::Real, 10>, 64>(harvest);
71 return;
72#endif
73 }
74 break;
75 }
76 terminator.Crash(
77 "not yet implemented: intrinsic: REAL(KIND=%d) in RANDOM_NUMBER", kind);
78}
79
80void RTNAME(RandomSeedSize)(
81 const Descriptor *size, const char *source, int line) {
82 if (!size || !size->raw().base_addr) {
83 RTNAME(RandomSeedDefaultPut)();
84 return;
85 }
86 Terminator terminator{source, line};
87 auto typeCode{size->type().GetCategoryAndKind()};
88 RUNTIME_CHECK(terminator,
89 size->rank() == 0 && typeCode &&
90 typeCode->first == TypeCategory::Integer);
91 int sizeArg{typeCode->second};
92 switch (sizeArg) {
93 case 4:
94 *size->OffsetElement<CppTypeFor<TypeCategory::Integer, 4>>() = 1;
95 break;
96 case 8:
97 *size->OffsetElement<CppTypeFor<TypeCategory::Integer, 8>>() = 1;
98 break;
99 default:
100 terminator.Crash(
101 "not yet implemented: intrinsic: RANDOM_SEED(SIZE=): size %d\n",
102 sizeArg);
103 }
104}
105
106void RTNAME(RandomSeedPut)(
107 const Descriptor *put, const char *source, int line) {
108 if (!put || !put->raw().base_addr) {
109 RTNAME(RandomSeedDefaultPut)();
110 return;
111 }
112 Terminator terminator{source, line};
113 auto typeCode{put->type().GetCategoryAndKind()};
114 RUNTIME_CHECK(terminator,
115 put->rank() == 1 && typeCode &&
116 typeCode->first == TypeCategory::Integer &&
117 put->GetDimension(0).Extent() >= 1);
118 int putArg{typeCode->second};
119 GeneratedWord seed;
120 switch (putArg) {
121 case 4:
122 seed = *put->OffsetElement<CppTypeFor<TypeCategory::Integer, 4>>();
123 break;
124 case 8:
125 seed = *put->OffsetElement<CppTypeFor<TypeCategory::Integer, 8>>();
126 break;
127 default:
128 terminator.Crash(
129 "not yet implemented: intrinsic: RANDOM_SEED(PUT=): put %d\n", putArg);
130 }
131 {
132 CriticalSection critical{lock};
133 generator.seed(s: seed);
134 nextValue = seed;
135 }
136}
137
138void RTNAME(RandomSeedDefaultPut)() {
139 // TODO: should this be time &/or image dependent?
140 {
141 CriticalSection critical{lock};
142 generator.seed(s: 0);
143 }
144}
145
146void RTNAME(RandomSeedGet)(
147 const Descriptor *get, const char *source, int line) {
148 if (!get || !get->raw().base_addr) {
149 RTNAME(RandomSeedDefaultPut)();
150 return;
151 }
152 Terminator terminator{source, line};
153 auto typeCode{get->type().GetCategoryAndKind()};
154 RUNTIME_CHECK(terminator,
155 get->rank() == 1 && typeCode &&
156 typeCode->first == TypeCategory::Integer &&
157 get->GetDimension(0).Extent() >= 1);
158 int getArg{typeCode->second};
159 GeneratedWord seed;
160 {
161 CriticalSection critical{lock};
162 seed = GetNextValue();
163 nextValue = seed;
164 }
165 switch (getArg) {
166 case 4:
167 *get->OffsetElement<CppTypeFor<TypeCategory::Integer, 4>>() = seed;
168 break;
169 case 8:
170 *get->OffsetElement<CppTypeFor<TypeCategory::Integer, 8>>() = seed;
171 break;
172 default:
173 terminator.Crash(
174 "not yet implemented: intrinsic: RANDOM_SEED(GET=): get %d\n", getArg);
175 }
176}
177
178void RTNAME(RandomSeed)(const Descriptor *size, const Descriptor *put,
179 const Descriptor *get, const char *source, int line) {
180 bool sizePresent = size && size->raw().base_addr;
181 bool putPresent = put && put->raw().base_addr;
182 bool getPresent = get && get->raw().base_addr;
183 if (sizePresent + putPresent + getPresent > 1)
184 Terminator{source, line}.Crash(
185 "RANDOM_SEED must have either 1 or no arguments");
186 if (sizePresent)
187 RTNAME(RandomSeedSize)(size, source, line);
188 else if (putPresent)
189 RTNAME(RandomSeedPut)(put, source, line);
190 else if (getPresent)
191 RTNAME(RandomSeedGet)(get, source, line);
192 else
193 RTNAME(RandomSeedDefaultPut)();
194}
195
196} // extern "C"
197} // namespace Fortran::runtime::random
198

source code of flang/runtime/random.cpp