Steve Kargl <kargl@gcc.gnu.org>

PR fortran/98301 - random_init() is broken

Correct implementation of random_init() when -fcoarray=lib is given.

gcc/fortran/ChangeLog:

	PR fortran/98301
	* trans-decl.c (gfc_build_builtin_function_decls): Move decl.
	* trans-intrinsic.c (conv_intrinsic_random_init): Use bool for
	lib-call of caf_random_init instead of logical (4-byte).
	* trans.h: Add tree var for random_init.

libgfortran/ChangeLog:

	PR fortran/98301
	* caf/libcaf.h (_gfortran_caf_random_init): New function.
	* caf/single.c (_gfortran_caf_random_init): New function.
	* gfortran.map: Added fndecl.
	* intrinsics/random_init.f90: Implement random_init.

7 files changed, 106 insertions, 70 deletions

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 406b4ae..c32bd05 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -170,6 +170,7 @@ tree gfor_fndecl_co_min;
 tree gfor_fndecl_co_reduce;
 tree gfor_fndecl_co_sum;
 tree gfor_fndecl_caf_is_present;
+tree gfor_fndecl_caf_random_init;
 
 
 /* Math functions.  Many other math functions are handled in
@@ -233,7 +234,7 @@ tree gfor_fndecl_cgemm;
 tree gfor_fndecl_zgemm;
 
 /* RANDOM_INIT function.  */
-tree gfor_fndecl_random_init;
+tree gfor_fndecl_random_init;      /* libgfortran, 1 image only.  */
 
 static void
 gfc_add_decl_to_parent_function (tree decl)
@@ -3516,6 +3517,8 @@ gfc_build_intrinsic_function_decls (void)
 	void_type_node, 3, gfc_logical4_type_node, gfc_logical4_type_node,
 	gfc_int4_type_node);
 
+ // gfor_fndecl_caf_rand_init is defined in the lib-coarray section below.
+
   gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec (
 	get_identifier (PREFIX("selected_char_kind")), ". . R ",
 	gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node);
@@ -4081,6 +4084,10 @@ gfc_build_builtin_function_decls (void)
 	get_identifier (PREFIX("caf_is_present")), ". r . r ",
 	integer_type_node, 3, pvoid_type_node, integer_type_node,
 	pvoid_type_node);
+
+      gfor_fndecl_caf_random_init = gfc_build_library_function_decl (
+	    get_identifier (PREFIX("caf_random_init")),
+	    void_type_node, 2, logical_type_node, logical_type_node);
     }
 
   gfc_build_intrinsic_function_decls ();
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 4d74514..db9248c 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -3827,38 +3827,43 @@ conv_intrinsic_random_init (gfc_code *code)
 {
   stmtblock_t block;
   gfc_se se;
-  tree arg1, arg2, arg3, tmp;
-  tree logical4_type_node = gfc_get_logical_type (4);
+  tree arg1, arg2, tmp;
+  /* On none coarray == lib compiles use LOGICAL(4) else regular LOGICAL.  */
+  tree used_bool_type_node = flag_coarray == GFC_FCOARRAY_LIB
+			     ? logical_type_node
+			     : gfc_get_logical_type (4);
 
   /* Make the function call.  */
   gfc_init_block (&block);
   gfc_init_se (&se, NULL);
 
-  /* Convert REPEATABLE to a LOGICAL(4) entity.  */
+  /* Convert REPEATABLE to the desired LOGICAL entity.  */
   gfc_conv_expr (&se, code->ext.actual->expr);
   gfc_add_block_to_block (&block, &se.pre);
-  arg1 = fold_convert (logical4_type_node, gfc_evaluate_now (se.expr, &block));
+  arg1 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
   gfc_add_block_to_block (&block, &se.post);
 
-  /* Convert IMAGE_DISTINCT to a LOGICAL(4) entity.  */
+  /* Convert IMAGE_DISTINCT to the desired LOGICAL entity.  */
   gfc_conv_expr (&se, code->ext.actual->next->expr);
   gfc_add_block_to_block (&block, &se.pre);
-  arg2 = fold_convert (logical4_type_node, gfc_evaluate_now (se.expr, &block));
+  arg2 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
   gfc_add_block_to_block (&block, &se.post);
 
-  /* Create the hidden argument.  For non-coarray codes and -fcoarray=single,
-     simply set this to 0.  For -fcoarray=lib, generate a call to
-     THIS_IMAGE() without arguments.  */
-  arg3 = build_int_cst (gfc_get_int_type (4), 0);
   if (flag_coarray == GFC_FCOARRAY_LIB)
     {
-      arg3 = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image,
-				  1, arg3);
-      se.expr = fold_convert (gfc_get_int_type (4), arg3);
+      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_random_init,
+				 2, arg1, arg2);
+    }
+  else
+    {
+      /* The ABI for libgfortran needs to be maintained, so a hidden
+	 argument must be include if code is compiled with -fcoarray=single
+	 or without the option.  Set to 0.  */
+      tree arg3 = build_int_cst (gfc_get_int_type (4), 0);
+      tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init,
+				 3, arg1, arg2, arg3);
     }
 
-  tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init, 3,
-			     arg1, arg2, arg3);
   gfc_add_expr_to_block (&block, tmp);
 
   return gfc_finish_block (&block);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 8c6f82f..69d3fdc 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -969,6 +969,7 @@ extern GTY(()) tree gfor_fndecl_ieee_procedure_exit;
 
 /* RANDOM_INIT.  */
 extern GTY(()) tree gfor_fndecl_random_init;
+extern GTY(()) tree gfor_fndecl_caf_random_init;
 
 /* True if node is an integer constant.  */
 #define INTEGER_CST_P(node) (TREE_CODE(node) == INTEGER_CST)
diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h
index 5abb753..c66d037 100644
--- a/libgfortran/caf/libcaf.h
+++ b/libgfortran/caf/libcaf.h
@@ -261,4 +261,6 @@ void _gfortran_caf_stopped_images (gfc_descriptor_t *,
 
 int _gfortran_caf_is_present (caf_token_t, int, caf_reference_t *);
 
+void _gfortran_caf_random_init (bool, bool);
+
 #endif  /* LIBCAF_H  */
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index a291c44..fc8e3b3 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -3135,3 +3135,13 @@ _gfortran_caf_is_present (caf_token_t token,
     }
   return memptr != NULL;
 }
+
+/* Reference the libraries implementation.  */
+extern void _gfortran_random_init (int32_t, int32_t, int32_t);
+
+void _gfortran_caf_random_init (bool repeatable, bool image_distinct)
+{
+  /* In a single image implementation always forward to the gfortran
+     routine.  */
+  _gfortran_random_init (repeatable, image_distinct, 1);
+}
diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map
index f74436f..3257983 100644
--- a/libgfortran/gfortran.map
+++ b/libgfortran/gfortran.map
@@ -1629,3 +1629,8 @@ GFORTRAN_10.2 {
   _gfortran_mfindloc1_c10;
   _gfortran_sfindloc1_c10;
 } GFORTRAN_10;
+
+GFORTRAN_12 {
+  global:
+  _gfortran_caf_random_init;
+} GFORTRAN_10.2;
diff --git a/libgfortran/intrinsics/random_init.f90 b/libgfortran/intrinsics/random_init.f90
index e5b4087..1200225 100644
--- a/libgfortran/intrinsics/random_init.f90
+++ b/libgfortran/intrinsics/random_init.f90
@@ -1,94 +1,100 @@
 ! Copyright (C) 2018-2021 Free Software Foundation, Inc.
 ! Contributed by Steven G. Kargl <kargl@gcc.gnu.org>
-! 
+!
 ! This file is part of the GNU Fortran runtime library (libgfortran).
-! 
+!
 ! Libgfortran is free software; you can redistribute it and/or
 ! modify it under the terms of the GNU General Public
 ! License as published by the Free Software Foundation; either
 ! version 3 of the License, or (at your option) any later version.
-! 
+!
 ! Libgfortran is distributed in the hope that it will be useful,
 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ! GNU General Public License for more details.
-! 
+!
 ! Under Section 7 of GPL version 3, you are granted additional
 ! permissions described in the GCC Runtime Library Exception, version
 ! 3.1, as published by the Free Software Foundation.
-! 
+!
 ! You should have received a copy of the GNU General Public License and
 ! a copy of the GCC Runtime Library Exception along with this program;
 ! see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 ! <http://www.gnu.org/licenses/>.
 !
-!
 ! WARNING:  This file should never be compiled with an option that changes
 ! default logical kind from 4 to some other value or changes default integer
-! kind from from 4 to some other value.
-!
-!
-! There are four combinations of repeatable and image_distinct.  If a program
-! is compiled without the -fcoarray= option or with -fcoarray=single, then
-! execution of the compiled executable does not use image_distinct as it is
-! irrelevant (although required).  The behavior is as follows:
-!
-! call random_init(.true., .true.)
+! kind from 4 to some other value.
 !
-! The sequence of random numbers is repeatable within an instance of program
-! execution.  That is, calls to random_init(.true., .true.) during the
-! execution will reset the sequence of RN to the same sequence.  If the
-! program is compiled with -fcoarray=lib and multiple images are instantiated,
-! then each image accesses a repeatable distinct sequence of random numbers.
-! There are no guarantees that multiple execution of the program will access
-! the same sequence.
+! There are four combinations of repeatable and image_distinct.  The
+! language below is from the F2018 standard (actually, J3/18-007r1).
 !
-! call random_init(.false., .false.)
-! call random_init(.false., .true.)
+! This routine is only used for non-coarray programs or with programs
+! compiled with -fcoarray=single.  Use of -fcoarray=lib or -fcoarray=shared
+! requires different routines due to the need for communication between
+! images under case(iv).
 !
-! The sequence of random numbers is determined from process-dependent seeds.
-! On each execution of the executable, different seeds will be used.  For
-! -fcoarray=lib and multiple instantiated images, each image will use
-! process-dependent seeds.  In other words, the two calls have identical
-! behavior.
+! Technically, neither image_distinct nor image_num are now needed.  The
+! interface to _gfortran_random_init() is maintained for libgfortran ABI.
+! Note, the Fortran standard requires the image_distinct argument, so
+! it will always have a valid value, and the frontend generates an value
+! of 0 for image_num.
 !
-! call random_init(.true., .false.)
-! 
-! For a program compiled without the -fcoarray= option or with
-! -fcoarray=single, a single image is instantiated when the executable is
-! run.  If the executable causes multiple images to be instantiated, then
-! image_distinct=.false. in one image cannot affect the sequence of random
-! numbers in another image.  As gfortran gives each image its own independent
-! PRNG, this condition is automatically satisfied.
-!
-impure subroutine _gfortran_random_init(repeatable, image_distinct, hidden) 
+impure subroutine _gfortran_random_init(repeatable, image_distinct, image_num) 
 
    implicit none
 
    logical, value, intent(in) :: repeatable
    logical, value, intent(in) :: image_distinct
-   integer, value, intent(in) :: hidden
+   integer, value, intent(in) :: image_num
 
    logical, save :: once = .true.
-   integer :: nseed
+   integer :: nseed, lcg_seed
    integer, save, allocatable :: seed(:)
 
-   if (once) then
-      once = .false.
-      call random_seed(size=nseed)
-      allocate(seed(nseed))
-      call random_seed(get=seed)
+   if (repeatable) then
+      if (once) then
+         once = .false.
+         call random_seed(size=nseed)
+         allocate(seed(nseed))
+         lcg_seed = 57911963
+         call _gfortran_lcg(seed)
+      end if
+      call random_seed(put=seed)
+   else
+      call random_seed()
       !
-      ! To guarantee that seed is distinct on multiple images, add the hidden
-      ! argument (which is the image index).
+      ! This cannot happen; but, prevent gfortran complaining about
+      ! unused variables.
       !
-      if (image_distinct) seed = seed + hidden
+      if (image_num > 2) then
+         block
+            use iso_fortran_env, only : error_unit
+            write(error_unit, '(A)') 'whoops: random_init(.false., .false.)'
+            if (image_distinct) error stop image_num + 1
+            error stop image_num
+         end block
+      end if
    end if
 
-   if (repeatable) then
-      call random_seed(put=seed);
-   else
-      call random_seed();
-   end if
+   contains
+      !
+      ! SK Park and KW Miller, ``Random number generators: good ones are hard
+      ! to find,'' Comm. ACM, 31(10), 1192--1201, (1988).
+      !
+      ! Implementation of a prime modulus multiplicative linear congruential
+      ! generator, which avoids overflow and provides the full period.
+      !
+      impure elemental subroutine _gfortran_lcg(i)
+         implicit none
+         integer, intent(out) :: i
+         integer, parameter :: a = 16807     ! Multiplier
+         integer, parameter :: m = huge(a)   ! Modulus
+         integer, parameter :: q = 127773    ! Quotient to avoid overflow
+         integer, parameter :: r = 2836      ! Remainder to avoid overflow
+         lcg_seed = a * mod(lcg_seed, q) - r * (lcg_seed / q)
+         if (lcg_seed <= 0) lcg_seed = lcg_seed + m
+         i = lcg_seed
+      end subroutine _gfortran_lcg
 
 end subroutine _gfortran_random_init