llvm-project

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

27
namespace Fortran::runtime::random {
28

29
Lock lock;
30
Generator generator;
31
Fortran::common::optional<GeneratedWord> nextValue;
32

33
extern "C" {
34

35
void 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, &ts);
45
      generator.seed(ts.tv_sec & ts.tv_nsec);
46
#else
47
      generator.seed(time(nullptr));
48
#endif
49
    }
50
  }
51
}
52

53
void 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

80
void 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

106
void 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(seed);
134
    nextValue = seed;
135
  }
136
}
137

138
void RTNAME(RandomSeedDefaultPut)() {
139
  // TODO: should this be time &/or image dependent?
140
  {
141
    CriticalSection critical{lock};
142
    generator.seed(0);
143
  }
144
}
145

146
void 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

178
void 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