Fix for random_seed when seeds have zeroes in LSB

This patch fixes setting random seeds when seeds are large and has zeroes in their least significant 23 bits. Fixes flang-compiler#691 Change-Id: If532da3159997a4ddbecd20f388a5e6280bc1012
kiranchandramohan · Apr 5, 2019 · 0dbe81d · 0dbe81d
1 parent 2800441
commit 0dbe81d
Show file tree

Hide file tree

Showing 7 changed files with 294 additions and 31 deletions.
diff --git a/runtime/flang/rnum.c b/runtime/flang/rnum.c
@@ -6332,9 +6332,10 @@ void ENTFTN(RSEED, rseed)(void *size, __INT_T *putb, __INT_T *getb,
 {
   int i, j, no_args_present, vhi, vlo;
   __INT_T *la;
-  int list[LONG_LAG][2];
+  __INT_T list[LONG_LAG][2];
   __INT_T extent, index;
   char *static_seed;
+  unsigned int shift_val=0;
 
 
   MP_P(sem);
@@ -6397,40 +6398,62 @@ void ENTFTN(RSEED, rseed)(void *size, __INT_T *putb, __INT_T *getb,
       }
 
       if (extent < (2 * LONG_LAG)) {
-        set_npb();
-        /*
-         * SEED_LO:
-         */
-        vlo = I8(__fort_fetch_int_element)(putb, putd, 1);
-        seed_lo = R46 * (vlo & MASK23);
-        /*
-         * SEED_HI:
-         */
-        vhi = I8(__fort_fetch_int_element)(putb, putd, 2);
-        seed_hi = R23 * (vhi & MASK23);
+        shift_val = 0;
+        do {
+          set_npb();
+          /*
+           * SEED_LO:
+           */
+          index = F90_DIM_LBOUND_G(putd, 0);
+          I8(__fort_get_scalar)(list[0] + 0, putb, putd, &index);
+          list[0][0] >>= shift_val;
+          list[0][0] &= MASK23;
+          vlo = list[0][0];
+          seed_lo = R46 * vlo;
+          /*
+           * SEED_HI:
+           */
+          index = F90_DIM_LBOUND_G(putd, 0) + 1;
+          I8(__fort_get_scalar)(list[0] + 1, putb, putd, &index);
+          list[0][1] >>= shift_val;
+          list[0][1] &= MASK23;
+          vhi = list[0][1];
+          seed_hi = R23 * vhi;
+          shift_val += 23;
+        } while(!(vlo | vhi) && shift_val < 64);
       } else {
-
-        set_fibonacci();
-        offset = LONG_LAG - 1;
-        for (i = 0; i < LONG_LAG; ++i)
-          for (j = 0; j < 2; ++j) {
-            index = F90_DIM_LBOUND_G(putd, 0) + (2 * i + j);
-            I8(__fort_get_scalar)(list[i] + j, putb, putd, &index);
-            list[i][j] &= 0x7fffff;
+        shift_val = 0;
+        do {
+          if (shift_val != 0)
+            vlo = vhi = 0;
+          set_fibonacci();
+          offset = LONG_LAG - 1;
+          for (i = 0; i < LONG_LAG; ++i)
+            for (j = 0; j < 2; ++j) {
+              index = F90_DIM_LBOUND_G(putd, 0) + (2 * i + j);
+              I8(__fort_get_scalar)(list[i] + j, putb, putd, &index);
+              list[i][j] >>= shift_val;
+              list[i][j] &= 0x7fffff;
+            }
+          for (i = 0; i < LONG_LAG; ++i) {
+            seed_lf[i] = R23 * (R23 * list[i][0] + list[i][1]);
+            vlo |= list[i][0];
+            vhi |= list[i][1];
           }
-        for (i = 0; i < LONG_LAG; ++i) {
-          seed_lf[i] = R23 * (R23 * list[i][0] + list[i][1]);
-          vlo |= list[i][0];
-          vhi |= list[i][1];
-        }
+          shift_val += 23;
+        } while(!(vlo | vhi) && shift_val < 64);
       }
-
     } else {
-      /*
-       * Mask seed value that was input.
-       */
-      vlo = *putb & MASK23;
-      vhi = *putb & MASK23;
+      shift_val = 0;
+      do {
+        /*
+         * Mask seed value that was input.
+         */
+        vlo = (*putb >> shift_val) & MASK23;
+        vhi = (*putb >> shift_val) & MASK23;
+        shift_val += 23;
+      } while(!(vlo | vhi) && shift_val < 64);
+
       if (fibonacci)
         for (i = 0; i < LONG_LAG; ++i)
           seed_lf[i] = R23 * (R23 * vlo + vhi);

diff --git a/test/f90_correct/inc/random_seed_fix.mk b/test/f90_correct/inc/random_seed_fix.mk
@@ -0,0 +1,32 @@
+#
+# Copyright (c) 2016, NVIDIA CORPORATION.  All rights reserved.
+#
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+#
+#     http://www.apache.org/licenses/LICENSE-2.0
+#
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+#
+
+EXE=random_seed_fix.$(EXESUFFIX)
+
+build:  $(SRC)/random_seed_fix.f90
+	-$(RM) random_seed_fix.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.*
+	-$(RM) $(OBJ)
+	-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX)
+	@echo ------------------------------------ building test $@
+	$(FC) $(FFLAGS) $(LDFLAGS) $(SRC)/random_seed_fix.f90 check.$(OBJX) -o random_seed_fix.$(EXESUFFIX)
+
+run:
+	@echo ------------------------------------ executing test random_seed_fix
+	random_seed_fix.$(EXESUFFIX)
+
+verify: ;
+
+random_seed_fix.run: run
diff --git a/test/f90_correct/inc/random_seed_i8_fix.mk b/test/f90_correct/inc/random_seed_i8_fix.mk
@@ -0,0 +1,32 @@
+#
+# Copyright (c) 2016, NVIDIA CORPORATION.  All rights reserved.
+#
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+#
+#     http://www.apache.org/licenses/LICENSE-2.0
+#
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+#
+
+EXE=random_seed_i8_fix.$(EXESUFFIX)
+
+build:  $(SRC)/random_seed_i8_fix.f90
+	-$(RM) random_seed_i8_fix.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.*
+	-$(RM) $(OBJ)
+	-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX)
+	@echo ------------------------------------ building test $@
+	$(FC) $(FFLAGS) -i8 $(LDFLAGS) $(SRC)/random_seed_i8_fix.f90 check.$(OBJX) -o random_seed_i8_fix.$(EXESUFFIX)
+
+run:
+	@echo ------------------------------------ executing test random_seed_i8_fix
+	random_seed_i8_fix.$(EXESUFFIX)
+
+verify: ;
+
+random_seed_i8_fix.run: run
diff --git a/test/f90_correct/lit/random_seed_fix.sh b/test/f90_correct/lit/random_seed_fix.sh
@@ -0,0 +1,20 @@
+#
+# Copyright (c) 2019, Arm Ltd.  All rights reserved.
+#
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+#
+#     http://www.apache.org/licenses/LICENSE-2.0
+#
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+# Shared lit script for each tests. Run bash commands that run tests with make.
+# This test is expected to fail till PGI switches the allocatable default to 03
+
+# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t
+# RUN: cat %t | FileCheck %S/runmake
diff --git a/test/f90_correct/lit/random_seed_i8_fix.sh b/test/f90_correct/lit/random_seed_i8_fix.sh
@@ -0,0 +1,20 @@
+#
+# Copyright (c) 2019, Arm Ltd.  All rights reserved.
+#
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+#
+#     http://www.apache.org/licenses/LICENSE-2.0
+#
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+# Shared lit script for each tests. Run bash commands that run tests with make.
+# This test is expected to fail till PGI switches the allocatable default to 03
+
+# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t
+# RUN: cat %t | FileCheck %S/runmake
diff --git a/test/f90_correct/src/random_seed_fix.f90 b/test/f90_correct/src/random_seed_fix.f90
@@ -0,0 +1,68 @@
+!** Copyright (c) 2019, Arm Ltd.  All rights reserved.
+
+!** Licensed under the Apache License, Version 2.0 (the "License");
+!** you may not use this file except in compliance with the License.
+!** You may obtain a copy of the License at
+!**
+!**     http://www.apache.org/licenses/LICENSE-2.0
+!**
+!** Unless required by applicable law or agreed to in writing, software
+!** distributed under the License is distributed on an "AS IS" BASIS,
+!** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+!** See the License for the specific language governing permissions and
+!** limitations under the License.
+
+!* Test random_seed fix
+program test
+  integer, parameter :: num = 1
+  integer rslts(num), expect(num)
+  data expect / 1 /
+
+  call test_with_sized_seed_array()
+  call test_with_large_seed_array()
+  call test_with_small_seed_array()
+
+  rslts(1) = 1
+  call check(rslts, expect, num)
+contains
+subroutine test_with_sized_seed_array()
+  integer :: my_seed_sz
+  integer, allocatable :: my_seed_arr(:)
+  real :: my_rand
+
+  call random_seed(size=my_seed_sz)
+
+  allocate(my_seed_arr(my_seed_sz))
+  my_seed_arr = 0
+  my_seed_arr(1) = Z'800000'
+
+  call random_seed(put=my_seed_arr)
+  call random_number(my_rand)
+
+  deallocate(my_seed_arr)
+end subroutine
+
+subroutine test_with_small_seed_array()
+  integer, parameter :: my_seed_sz=8
+  integer :: my_seed_arr(my_seed_sz)
+  real :: my_rand
+
+  my_seed_arr = 0
+  my_seed_arr(1) = Z'800000'
+
+  call random_seed(put=my_seed_arr)
+  call random_number(my_rand)
+end subroutine
+
+subroutine test_with_large_seed_array()
+  integer, parameter :: my_seed_sz=51
+  integer :: my_seed_arr(my_seed_sz)
+  real :: my_rand
+
+  my_seed_arr = 0
+  my_seed_arr(1) = Z'800000'
+
+  call random_seed(put=my_seed_arr)
+  call random_number(my_rand)
+end subroutine
+end program
diff --git a/test/f90_correct/src/random_seed_i8_fix.f90 b/test/f90_correct/src/random_seed_i8_fix.f90
@@ -0,0 +1,68 @@
+!** Copyright (c) 2019, Arm Ltd.  All rights reserved.
+
+!** Licensed under the Apache License, Version 2.0 (the "License");
+!** you may not use this file except in compliance with the License.
+!** You may obtain a copy of the License at
+!**
+!**     http://www.apache.org/licenses/LICENSE-2.0
+!**
+!** Unless required by applicable law or agreed to in writing, software
+!** distributed under the License is distributed on an "AS IS" BASIS,
+!** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+!** See the License for the specific language governing permissions and
+!** limitations under the License.
+
+!* Test random_seed fix
+program test
+  integer, parameter :: num = 1
+  integer rslts(num), expect(num)
+  data expect / 1 /
+
+  call test_with_sized_seed_array()
+  call test_with_large_seed_array()
+  call test_with_small_seed_array()
+
+  rslts(1) = 1
+  call check(rslts, expect, num)
+contains
+subroutine test_with_sized_seed_array()
+  integer :: my_seed_sz
+  integer, allocatable :: my_seed_arr(:)
+  real :: my_rand
+
+  call random_seed(size=my_seed_sz)
+
+  allocate(my_seed_arr(my_seed_sz))
+  my_seed_arr = 0
+  my_seed_arr(1) = Z'800000000000000'
+
+  call random_seed(put=my_seed_arr)
+  call random_number(my_rand)
+
+  deallocate(my_seed_arr)
+end subroutine
+
+subroutine test_with_small_seed_array()
+  integer, parameter :: my_seed_sz=8
+  integer :: my_seed_arr(my_seed_sz)
+  real :: my_rand
+
+  my_seed_arr = 0
+  my_seed_arr(1) = Z'800000000000000'
+
+  call random_seed(put=my_seed_arr)
+  call random_number(my_rand)
+end subroutine
+
+subroutine test_with_large_seed_array()
+  integer, parameter :: my_seed_sz=51
+  integer :: my_seed_arr(my_seed_sz)
+  real :: my_rand
+
+  my_seed_arr = 0
+  my_seed_arr(1) = Z'800000000000000'
+
+  call random_seed(put=my_seed_arr)
+  call random_number(my_rand)
+end subroutine
+end program