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, 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 111 void 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 137 void 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 169 void RTNAME(RandomSeedDefaultPut)() { 170 // TODO: should this be time &/or image dependent? 171 { 172 CriticalSection critical{lock}; 173 generator.seed(0); 174 } 175 } 176 177 void 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 209 void 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