flang/runtime/random.cpp

   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 HAS_FLOAT80
  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