[flang/flang-rt] Adding support of RAND, IRAND and SRAND intrinsics (llvm#166780)

This PR adds support of
[RAND](https://gcc.gnu.org/onlinedocs/gcc-9.2.0/gfortran/RAND.html),
[IRAND](https://gcc.gnu.org/onlinedocs/gcc-9.2.0/gfortran/IRAND.html)
and
[SRAND](https://gcc.gnu.org/onlinedocs/gcc-9.2.0/gfortran/SRAND.html)
intrinsics in Flang, which are part of the GNU extension.
These intrinsics are used in the following benchmark:
[floatingspeed](https://github.com/ahbarnett/floatingspeed/)

Author: JDPailleux

flang-rt/lib/runtime/extensions.cpp

@@ -12,6 +12,7 @@
 #include "flang/Runtime/extensions.h"
 #include "unit.h"
 #include "flang-rt/runtime/descriptor.h"
+#include "flang-rt/runtime/lock.h"
 #include "flang-rt/runtime/terminator.h"
 #include "flang-rt/runtime/tools.h"
 #include "flang/Runtime/command.h"
@@ -23,6 +24,7 @@
 #include <cstdio>
 #include <cstring>
 #include <ctime>
+#include <limits>
 #include <signal.h>
 #include <stdlib.h>
 #include <thread>
@@ -60,6 +62,11 @@ inline void CtimeBuffer(char *buffer, size_t bufsize, const time_t cur_time,
 
 namespace Fortran::runtime {
 
+#define GFC_RAND_A 16807
+#define GFC_RAND_M 2147483647
+static unsigned rand_seed = 1;
+static Lock rand_seed_lock;
+
 // Common implementation that could be used for either SECNDS() or DSECNDS(),
 // which are defined for float or double.
 template <typename T> T SecndsImpl(T *refTime) {
@@ -417,6 +424,57 @@ void RTNAME(ShowDescriptor)(const Fortran::runtime::Descriptor *descr) {
   }
 }
 
+static void _internal_srand(int seed) { rand_seed = seed ? seed : 123459876; }
+
+// IRAND(I)
+int RTNAME(Irand)(int *i) {
+  int j;
+  if (i)
+    j = *i;
+  else
+    j = 0;
+
+  rand_seed_lock.Take();
+  switch (j) {
+  case 0:
+    break;
+  case 1:
+    _internal_srand(0);
+    break;
+  default:
+    _internal_srand(j);
+    break;
+  }
+
+  rand_seed = GFC_RAND_A * rand_seed % GFC_RAND_M;
+  j = (int)rand_seed;
+  rand_seed_lock.Drop();
+  return j;
+}
+
+// RAND(I)
+float RTNAME(Rand)(int *i, const char *sourceFile, int line) {
+  unsigned mask = 0;
+  constexpr int radix = std::numeric_limits<float>::radix;
+  constexpr int digits = std::numeric_limits<float>::digits;
+  if (radix == 2) {
+    mask = ~(unsigned)0u << (32 - digits + 1);
+  } else if (radix == 16) {
+    mask = ~(unsigned)0u << ((8 - digits) * 4 + 1);
+  } else {
+    Terminator terminator{sourceFile, line};
+    terminator.Crash("Radix unknown value.");
+  }
+  return ((unsigned)(RTNAME(Irand)(i) - 1) & mask) * (float)0x1.p-31f;
+}
+
+// SRAND(SEED)
+void FORTRAN_PROCEDURE_NAME(srand)(int *seed) {
+  rand_seed_lock.Take();
+  _internal_srand(*seed);
+  rand_seed_lock.Drop();
+}
+
 // Extension procedures related to I/O
 
 namespace io {

flang/docs/Intrinsics.md

@@ -1455,3 +1455,45 @@ subroutine test
   call show_descriptor(a)
 end subroutine test
 ```
+
+### Non-Standard Intrinsics: SRAND
+
+#### Description
+`SRAND` reinitializes the pseudo-random number generator called by `RAND` and `IRAND`.
+The new seed used by the generator is specified by the required argument `SEED`.
+
+#### Usage and Info
+
+- **Standard:** GNU extension
+- **Class:** Subroutine
+- **Syntax:** `CALL SRAND(SEED)`
+
+### Non-Standard Intrinsics: IRAND
+
+#### Description
+`IRAND(FLAG)` returns a pseudo-random number from a uniform distribution between 0 and a system-dependent limit.
+If `FLAG` is 0, the next number in the current sequence is returned;
+If `FLAG` is 1, the generator is restarted by `CALL SRAND(0)`;
+If `FLAG` has any other value, it is used as a new seed with `SRAND`.
+The return value is of `INTEGER` type of kind 4.
+
+#### Usage and Info
+
+- **Standard:** GNU extension
+- **Class:** function
+- **Syntax:** `RESULT = IRAND(I)`
+
+### Non-Standard Intrinsics: RAND
+
+#### Description
+`RAND(FLAG)` returns a pseudo-random number from a uniform distribution between 0 and 1.
+If `FLAG` is 0, the next number in the current sequence is returned;
+If `FLAG` is 1, the generator is restarted by `CALL SRAND(0)`;
+If `FLAG` has any other value, it is used as a new seed with `SRAND`.
+The return value is of `REAL` type with the default kind.
+
+#### Usage and Info
+
+- **Standard:** GNU extension
+- **Class:** function
+- **Syntax:** `RESULT = RAND(I)`

flang/include/flang/Optimizer/Builder/IntrinsicCall.h

@@ -330,6 +330,8 @@ struct IntrinsicLibrary {
   fir::ExtendedValue genIndex(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   mlir::Value genIor(mlir::Type, llvm::ArrayRef<mlir::Value>);
   fir::ExtendedValue genIparity(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
+  fir::ExtendedValue genIrand(mlir::Type resultType,
+                              llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genIsContiguous(mlir::Type,
                                      llvm::ArrayRef<fir::ExtendedValue>);
   template <Fortran::runtime::io::Iostat value>
@@ -377,6 +379,8 @@ struct IntrinsicLibrary {
   fir::ExtendedValue genProduct(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genPutenv(std::optional<mlir::Type>,
                                llvm::ArrayRef<fir::ExtendedValue>);
+  fir::ExtendedValue genRand(mlir::Type resultType,
+                             llvm::ArrayRef<fir::ExtendedValue>);
   void genRandomInit(llvm::ArrayRef<fir::ExtendedValue>);
   void genRandomNumber(llvm::ArrayRef<fir::ExtendedValue>);
   void genRandomSeed(llvm::ArrayRef<fir::ExtendedValue>);

flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h

@@ -114,6 +114,12 @@ mlir::Value genChdir(fir::FirOpBuilder &builder, mlir::Location loc,
 /// generate dump of a descriptor
 void genShowDescriptor(fir::FirOpBuilder &builder, mlir::Location loc,
                        mlir::Value descriptor);
+
+mlir::Value genIrand(fir::FirOpBuilder &builder, mlir::Location loc,
+                     mlir::Value i);
+mlir::Value genRand(fir::FirOpBuilder &builder, mlir::Location loc,
+                    mlir::Value i);
+
 } // namespace runtime
 } // namespace fir
 

flang/include/flang/Runtime/extensions.h

@@ -110,5 +110,14 @@ float RTNAME(Secnds)(float *refTime, const char *sourceFile, int line);
 // Extension subroutine SHOW_DESCRIPTOR(D)
 void RTNAME(ShowDescriptor)(const Fortran::runtime::Descriptor *descr);
 
+// GNU extension function IRAND(I)
+int RTNAME(Irand)(int *i);
+
+// GNU extension function RAND(I)
+float RTNAME(Rand)(int *i, const char *sourceFile, int line);
+
+// GNU extension subroutine SRAND(SEED)
+void FORTRAN_PROCEDURE_NAME(srand)(int *seed);
+
 } // extern "C"
 #endif // FORTRAN_RUNTIME_EXTENSIONS_H_

flang/lib/Evaluate/intrinsics.cpp

@@ -654,6 +654,10 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
         {{"i", OperandUnsigned}, {"j", OperandUnsigned, Rank::elementalOrBOZ}},
         OperandUnsigned},
     {"ior", {{"i", BOZ}, {"j", SameIntOrUnsigned}}, SameIntOrUnsigned},
+    {"irand",
+        {{"i", TypePattern{IntType, KindCode::exactKind, 4}, Rank::scalar,
+            Optionality::optional}},
+        TypePattern{IntType, KindCode::exactKind, 4}, Rank::scalar},
     {"ishft", {{"i", SameIntOrUnsigned}, {"shift", AnyInt}}, SameIntOrUnsigned},
     {"ishftc",
         {{"i", SameIntOrUnsigned}, {"shift", AnyInt},
@@ -872,6 +876,10 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
             common::Intent::In,
             {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
         DefaultInt, Rank::scalar, IntrinsicClass::inquiryFunction},
+    {"rand",
+        {{"i", TypePattern{IntType, KindCode::exactKind, 4}, Rank::scalar,
+            Optionality::optional}},
+        TypePattern{RealType, KindCode::exactKind, 4}, Rank::scalar},
     {"range",
         {{"x", AnyNumeric, Rank::anyOrAssumedRank, Optionality::required,
             common::Intent::In,

flang/lib/Optimizer/Builder/IntrinsicCall.cpp

@@ -499,6 +499,10 @@ static constexpr IntrinsicHandler handlers[]{
        {"dim", asValue},
        {"mask", asBox, handleDynamicOptional}}},
      /*isElemental=*/false},
+    {"irand",
+     &I::genIrand,
+     {{{"i", asAddr, handleDynamicOptional}}},
+     /*isElemental=*/false},
     {"is_contiguous",
      &I::genIsContiguous,
      {{{"array", asBox}}},
@@ -625,6 +629,10 @@ static constexpr IntrinsicHandler handlers[]{
      &I::genPutenv,
      {{{"str", asAddr}, {"status", asAddr, handleDynamicOptional}}},
      /*isElemental=*/false},
+    {"rand",
+     &I::genRand,
+     {{{"i", asAddr, handleDynamicOptional}}},
+     /*isElemental=*/false},
     {"random_init",
      &I::genRandomInit,
      {{{"repeatable", asValue}, {"image_distinct", asValue}}},
@@ -6162,6 +6170,20 @@ IntrinsicLibrary::genIparity(mlir::Type resultType,
                       "IPARITY", resultType, args);
 }
 
+// IRAND
+fir::ExtendedValue
+IntrinsicLibrary::genIrand(mlir::Type resultType,
+                           llvm::ArrayRef<fir::ExtendedValue> args) {
+  assert(args.size() == 1);
+  mlir::Value i =
+      isStaticallyPresent(args[0])
+          ? fir::getBase(args[0])
+          : fir::AbsentOp::create(builder, loc,
+                                  builder.getRefType(builder.getI32Type()))
+                .getResult();
+  return fir::runtime::genIrand(builder, loc, i);
+}
+
 // IS_CONTIGUOUS
 fir::ExtendedValue
 IntrinsicLibrary::genIsContiguous(mlir::Type resultType,
@@ -7188,6 +7210,19 @@ IntrinsicLibrary::genPutenv(std::optional<mlir::Type> resultType,
   return {};
 }
 
+// RAND
+fir::ExtendedValue
+IntrinsicLibrary::genRand(mlir::Type, llvm::ArrayRef<fir::ExtendedValue> args) {
+  assert(args.size() == 1);
+  mlir::Value i =
+      isStaticallyPresent(args[0])
+          ? fir::getBase(args[0])
+          : fir::AbsentOp::create(builder, loc,
+                                  builder.getRefType(builder.getI32Type()))
+                .getResult();
+  return fir::runtime::genRand(builder, loc, i);
+}
+
 // RANDOM_INIT
 void IntrinsicLibrary::genRandomInit(llvm::ArrayRef<fir::ExtendedValue> args) {
   assert(args.size() == 2);

flang/lib/Optimizer/Builder/Runtime/Intrinsics.cpp

@@ -477,3 +477,27 @@ void fir::runtime::genShowDescriptor(fir::FirOpBuilder &builder,
       fir::runtime::getRuntimeFunc<mkRTKey(ShowDescriptor)>(loc, builder)};
   fir::CallOp::create(builder, loc, func, descAddr);
 }
+
+mlir::Value fir::runtime::genIrand(fir::FirOpBuilder &builder,
+                                   mlir::Location loc, mlir::Value i) {
+  auto runtimeFunc = fir::runtime::getRuntimeFunc<mkRTKey(Irand)>(loc, builder);
+  mlir::FunctionType runtimeFuncTy = runtimeFunc.getFunctionType();
+
+  llvm::SmallVector<mlir::Value> args =
+      fir::runtime::createArguments(builder, loc, runtimeFuncTy, i);
+  return fir::CallOp::create(builder, loc, runtimeFunc, args).getResult(0);
+}
+
+mlir::Value fir::runtime::genRand(fir::FirOpBuilder &builder,
+                                  mlir::Location loc, mlir::Value i) {
+  auto runtimeFunc = fir::runtime::getRuntimeFunc<mkRTKey(Rand)>(loc, builder);
+  mlir::FunctionType runtimeFuncTy = runtimeFunc.getFunctionType();
+
+  mlir::Value sourceFile = fir::factory::locationToFilename(builder, loc);
+  mlir::Value sourceLine =
+      fir::factory::locationToLineNo(builder, loc, runtimeFuncTy.getInput(2));
+
+  llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
+      builder, loc, runtimeFuncTy, i, sourceFile, sourceLine);
+  return fir::CallOp::create(builder, loc, runtimeFunc, args).getResult(0);
+}

flang/test/Lower/Intrinsics/rand.f90

@@ -0,0 +1,41 @@
+! RUN: bbc -emit-hlfir %s -o - | FileCheck --check-prefixes=CHECK %s
+! RUN: %flang_fc1 -emit-hlfir %s -o - | FileCheck --check-prefixes=CHECK %s
+
+! CHECK-LABEL: func @_QPtest_srand(
+subroutine test_srand()
+  integer :: seed = 0
+  call srand(seed)
+  ! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QFtest_srandEseed) : !fir.ref<i32> 
+  ! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFtest_srandEseed"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+  ! CHECK: fir.call @_QPsrand(%[[VAL_1]]#0) fastmath<contract> : (!fir.ref<i32>) -> () 
+  ! CHECK: return
+end subroutine test_srand
+
+! CHECK-LABEL: func @_QPtest_irand(
+subroutine test_irand()
+  integer :: seed = 0
+  integer :: result
+  result = irand(seed)
+  ! CHECK: %[[VAL_0:.*]] = fir.alloca i32 {bindc_name = "result", uniq_name = "_QFtest_irandEresult"} 
+  ! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFtest_irandEresult"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+  ! CHECK: %[[VAL_2:.*]] = fir.address_of(@_QFtest_irandEseed) : !fir.ref<i32> 
+  ! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_2]] {uniq_name = "_QFtest_irandEseed"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+  ! CHECK: %[[VAL_4:.*]] = fir.call @_FortranAIrand(%[[VAL_3]]#0) fastmath<contract> : (!fir.ref<i32>) -> i32
+  ! CHECK: hlfir.assign %[[VAL_4]] to %[[VAL_1]]#0 : i32, !fir.ref<i32>
+  ! CHECK: return
+end subroutine test_irand
+
+! CHECK-LABEL: func @_QPtest_rand(
+subroutine test_rand()
+  integer :: seed = 0
+  real :: result
+  result = rand(seed)
+  ! CHECK: %[[VAL_0:.*]] = fir.alloca f32 {bindc_name = "result", uniq_name = "_QFtest_randEresult"} 
+  ! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFtest_randEresult"} : (!fir.ref<f32>) -> (!fir.ref<f32>, !fir.ref<f32>)
+  ! CHECK: %[[VAL_2:.*]] = fir.address_of(@_QFtest_randEseed) : !fir.ref<i32> 
+  ! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_2]] {uniq_name = "_QFtest_randEseed"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+  ! CHECK: %[[VAL_4:.*]] = fir.call @_FortranARand(%[[VAL_3]]#0, %[[SOURCE:.*]], %[[LINE:.*]]) fastmath<contract> : (!fir.ref<i32>, !fir.ref<i8>, i32) -> f32
+  ! CHECK: hlfir.assign %[[VAL_4]] to %[[VAL_1]]#0 : f32, !fir.ref<f32>
+  ! CHECK: return
+end subroutine test_rand
+