Re: [PATCH] Implementation of RANDOM_INIT from F2018

[Steve Kargl <sgk@troutmask.apl.washington.edu>]

[-- Attachment #1: Type: text/plain, Size: 2094 bytes --]

On Sun, Jan 07, 2018 at 06:52:22PM -0800, Steve Kargl wrote:
> 
> I have zero knowledge about co-arrays and especially zero
> knowledge about gfortran internals for co-arrays.  I'm
> disinclined to waste another 12 hours trying to get gfortran
> to emit essentially a call to this_image().  See iresolve.c
> for details.
> 

An epiphany came to me last night, which has led to the attach
patch.  This patch should be a complete implementation of
RANDOM_INIT.

RANDOM_INIT takes two LOGICAL, INTENT(IN) arguments.  To 
avoid library bloat, these arguments are converted/casted to
LOGICAL(4) in trans-intrinsic.c (conv_intrinsic_random_init).
It is also in this function, that I set up the hidden argument
that is needed to hopefully give standard conforming behavior
when co-arrays are involved.  I, however, cannot test -fcoarray=lib
situation.  I would appreciate feedback from a co-array user.

Boostrapped and regression tested on x86_64-*-freebsd.
OK to commit?

2018-01-08  Steven G. Kargl  <kargl@gcc.gnu.org>

	* check.c (gfc_check_random_init): New function.  Check arguments of
	random_init().
	* gfortran.h (gfc_isym_id): Add GFC_ISYM_RANDOM_INIT.
	* intrinsic.c (add_subroutines): Make random_init() an intrinsic
	subroutine.
	(gfc_check_intrinsic_standard): Check for Fortran 2018.
	* intrinsic.h: Add prototypes for gfc_check_random_init and
	gfc_resolve_random_init.
	* iresolve.c (gfc_resolve_random_init): New function.  Add
	_gfortran_random_init to list of subroutines.
	* trans-decl.c: Describe gfor_fndecl_random_init.
	* trans-intrinsic.c (conv_intrinsic_random_init): New function.
	Translate random_init and added hidden argument.
	(gfc_conv_intrinsic_subroutine): Call conv_intrinsic_random_init.
	* trans.h: Declare gfor_fndecl_random_init.

2018-01-08  Steven G. Kargl  <kargl@gcc.gnu.org>

	* gfortran.dg/random_init_1.f90: New test.
	* gfortran.dg/random_init_2.f90: New test.

2018-01-08  Steven G. Kargl  <kargl@gcc.gnu.org>

	* gfortran.map: Add _gfortran_random_init to library map.
	* intrinsics/random.c (random_init): Implemenation of random_init.

-- 
steve

[-- Attachment #2: random_init.diff --]
[-- Type: text/x-diff, Size: 11135 bytes --]

Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c	(revision 256351)
+++ gcc/fortran/check.c	(working copy)
@@ -5723,6 +5723,27 @@ gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, g
 }
 
 
+/* Check the arguments for RANDOM_INIT.  */
+
+bool
+gfc_check_random_init (gfc_expr *repeatable, gfc_expr *image_distinct)
+{
+  if (!type_check (repeatable, 0, BT_LOGICAL))
+    return false;
+
+  if (!scalar_check (repeatable, 0))
+    return false;
+
+  if (!type_check (image_distinct, 1, BT_LOGICAL))
+    return false;
+
+  if (!scalar_check (image_distinct, 1))
+    return false;
+
+  return true;
+}
+
+
 bool
 gfc_check_random_number (gfc_expr *harvest)
 {
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 256351)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -551,6 +551,7 @@ enum gfc_isym_id
   GFC_ISYM_PRODUCT,
   GFC_ISYM_RADIX,
   GFC_ISYM_RAND,
+  GFC_ISYM_RANDOM_INIT,
   GFC_ISYM_RANDOM_NUMBER,
   GFC_ISYM_RANDOM_SEED,
   GFC_ISYM_RANGE,
Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c	(revision 256351)
+++ gcc/fortran/intrinsic.c	(working copy)
@@ -3549,6 +3549,12 @@ add_subroutines (void)
       make_alias ("kmvbits", GFC_STD_GNU);
     }
 
+  add_sym_2s ("random_init", GFC_ISYM_RANDOM_INIT, CLASS_IMPURE,
+	      BT_UNKNOWN, 0, GFC_STD_F2018,
+	      gfc_check_random_init, NULL, gfc_resolve_random_init,
+	      "repeatable",     BT_LOGICAL, dl, REQUIRED, INTENT_IN,
+	      "image_distinct", BT_LOGICAL, dl, REQUIRED, INTENT_IN);
+
   add_sym_1s ("random_number", GFC_ISYM_RANDOM_NUMBER, CLASS_IMPURE,
 	      BT_UNKNOWN, 0, GFC_STD_F95,
 	      gfc_check_random_number, NULL, gfc_resolve_random_number,
@@ -4601,6 +4607,10 @@ gfc_check_intrinsic_standard (const gfc_intrinsic_sym*
 
     case GFC_STD_F2008_TS:
       symstd_msg = "new in TS 29113/TS 18508";
+      break;
+
+    case GFC_STD_F2018:
+      symstd_msg = "new in Fortran 2018";
       break;
 
     case GFC_STD_GNU:
Index: gcc/fortran/intrinsic.h
===================================================================
--- gcc/fortran/intrinsic.h	(revision 256351)
+++ gcc/fortran/intrinsic.h	(working copy)
@@ -203,6 +203,7 @@ bool gfc_check_getlog (gfc_expr *);
 bool gfc_check_move_alloc (gfc_expr *, gfc_expr *);
 bool gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
 		      gfc_expr *);
+bool gfc_check_random_init (gfc_expr *, gfc_expr *);
 bool gfc_check_random_number (gfc_expr *);
 bool gfc_check_random_seed (gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_dtime_etime_sub (gfc_expr *, gfc_expr *);
@@ -646,6 +647,7 @@ void gfc_resolve_lstat_sub (gfc_code *);
 void gfc_resolve_ltime (gfc_code *);
 void gfc_resolve_mvbits (gfc_code *);
 void gfc_resolve_perror (gfc_code *);
+void gfc_resolve_random_init (gfc_code *);
 void gfc_resolve_random_number (gfc_code *);
 void gfc_resolve_random_seed (gfc_code *);
 void gfc_resolve_rename_sub (gfc_code *);
Index: gcc/fortran/iresolve.c
===================================================================
--- gcc/fortran/iresolve.c	(revision 256351)
+++ gcc/fortran/iresolve.c	(working copy)
@@ -3370,6 +3370,17 @@ gfc_resolve_mvbits (gfc_code *c)
 }
 
 
+/* Set up the call to RANDOM_INIT.  */ 
+
+void
+gfc_resolve_random_init (gfc_code *c)
+{
+  const char *name;
+  name = gfc_get_string (PREFIX ("random_init"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
 void
 gfc_resolve_random_number (gfc_code *c)
 {
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 256351)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -221,6 +221,8 @@ tree gfor_fndecl_dgemm;
 tree gfor_fndecl_cgemm;
 tree gfor_fndecl_zgemm;
 
+/* RANDOM_INIT function.  */
+tree gfor_fndecl_random_init;
 
 static void
 gfc_add_decl_to_parent_function (tree decl)
@@ -3314,6 +3316,11 @@ gfc_build_intrinsic_function_decls (void)
 	get_identifier (PREFIX("ctime")), ".W",
 	void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
 	gfc_int8_type_node);
+
+  gfor_fndecl_random_init = gfc_build_library_function_decl (
+	get_identifier (PREFIX("random_init")),
+	void_type_node, 3, gfc_logical4_type_node, gfc_logical4_type_node,
+	gfc_int4_type_node);
 
   gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec (
 	get_identifier (PREFIX("selected_char_kind")), "..R",
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c	(revision 256351)
+++ gcc/fortran/trans-intrinsic.c	(working copy)
@@ -3484,6 +3484,52 @@ conv_intrinsic_free (gfc_code *code)
 }
 
 
+/* Call the RANDOM_INIT library subrotuine with a hidden argument for
+   handling seeding on coarray images.  */
+
+static tree
+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);
+
+  /* Make the function call.  */
+  gfc_init_block (&block);
+  gfc_init_se (&se, NULL);
+
+  /* Convert REPEATABLE to a LOGICAL(4) 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));
+  gfc_add_block_to_block (&block, &se.post);
+
+  /* Convert IMAGE_DISTINCT to a LOGICAL(4) 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));
+  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_random_init, 3,
+			     arg1, arg2, arg3);
+  gfc_add_expr_to_block (&block, tmp);
+ 
+  return gfc_finish_block (&block);
+}
+
+
 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
    conversions.  */
 
@@ -10711,6 +10757,10 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
 
     case GFC_ISYM_FREE:
       res = conv_intrinsic_free (code);
+      break;
+
+    case GFC_ISYM_RANDOM_INIT:
+      res = conv_intrinsic_random_init (code);
       break;
 
     case GFC_ISYM_SYSTEM_CLOCK:
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h	(revision 256351)
+++ gcc/fortran/trans.h	(working copy)
@@ -907,6 +907,8 @@ extern GTY(()) tree gfor_fndecl_sr_kind;
 extern GTY(()) tree gfor_fndecl_ieee_procedure_entry;
 extern GTY(()) tree gfor_fndecl_ieee_procedure_exit;
 
+/* RANDOM_INIT.  */
+extern GTY(()) tree gfor_fndecl_random_init;
 
 /* True if node is an integer constant.  */
 #define INTEGER_CST_P(node) (TREE_CODE(node) == INTEGER_CST)
Index: gcc/testsuite/gfortran.dg/random_init_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/random_init_1.f90	(nonexistent)
+++ gcc/testsuite/gfortran.dg/random_init_1.f90	(working copy)
@@ -0,0 +1,12 @@
+! { dg-do compile } 
+program foo
+   logical a(2)
+   real x
+   call random_init(1., .false.) ! { dg-error "must be LOGICAL" }
+   call random_init(.true., 1)   ! { dg-error "must be LOGICAL" }
+   call random_number(x)
+   a = .true.
+   call random_init(a, .false.) ! { dg-error "must be a scalar" }
+   call random_init(.false., a) ! { dg-error "must be a scalar" }
+   print *, x
+end program foo
Index: gcc/testsuite/gfortran.dg/random_init_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/random_init_2.f90	(nonexistent)
+++ gcc/testsuite/gfortran.dg/random_init_2.f90	(working copy)
@@ -0,0 +1,30 @@
+! { dg-do run } 
+program foo
+
+   real x(2), y(2)
+
+   call random_init(.false., .false.)
+   call random_number(x)
+   print *, x
+!   x = int(1e6*x)
+
+   call random_init(.false., .false.)
+   call random_number(y)
+   print *, y
+!   y = int(1e6*y)
+
+   if (any(x == y)) call abort
+
+   call random_init(.true., .false.)
+   call random_number(x)
+!   print *, x
+   x = int(1e6*x)
+
+   call random_init(.true., .false.)
+   call random_number(y)
+!   print *, y
+   y = int(1e6*y)
+
+   if (any(x /= y)) call abort   
+
+end program foo
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map	(revision 256346)
+++ libgfortran/gfortran.map	(working copy)
@@ -801,6 +801,7 @@ GFORTRAN_8 {
     _gfortran_product_r4;
     _gfortran_product_r8;
     _gfortran_rand;
+    _gfortran_random_init;
     _gfortran_random_r10;
     _gfortran_random_r16;
     _gfortran_random_r4;
Index: libgfortran/intrinsics/random.c
===================================================================
--- libgfortran/intrinsics/random.c	(revision 256346)
+++ libgfortran/intrinsics/random.c	(working copy)
@@ -44,6 +44,9 @@ see the files COPYING3 and COPYING.RUNTIME respectivel
 #include <_mingw.h> /* For __MINGW64_VERSION_MAJOR  */
 #endif
 
+extern void random_init (GFC_LOGICAL_4, GFC_LOGICAL_4, GFC_INTEGER_4);
+iexport_proto(random_init);
+
 extern void random_r4 (GFC_REAL_4 *);
 iexport_proto(random_r4);
 
@@ -927,6 +930,46 @@ random_seed_i8 (GFC_INTEGER_8 *size, gfc_array_i8 *put
 }
 iexport(random_seed_i8);
 
+
+/* random_init is used to seed the PRNG with either a default
+   set of seeds or a random set of seeds.  */
+
+void
+random_init (GFC_LOGICAL_4 repeatable, GFC_LOGICAL_4 image_distinct,
+	     GFC_INTEGER_4 hidden)
+{
+  static const uint64_t repeat_state[] = {
+    0x25b946ebc0b36173ULL, 0x31fffb768dfde2d1ULL, 0xb08dbf28a70a6b08ULL,
+    0x60b1fc7fbcc04151ULL, 0xb4018862d654635dULL, 0x5c2fc35553bb5470ULL,
+    0xd588f951b8984a2bULL, 0x060c05384e97789dULL, 0x2b992ddfa23249d6ULL,
+    0x4034650f1c98bd69ULL, 0x79267e9c00e018afULL, 0x449eb881a2869d0eULL,
+    0xe2fee08d1e670313ULL, 0x17afc3eef0f0c640ULL, 0x2002db4f8acb8a0eULL,
+    0x50cd06b1b61a6804ULL
+  };
+
+  xorshift1024star_state* rs = get_rand_state();
+
+  __gthread_mutex_lock (&random_lock);
+
+  if (repeatable)
+    {
+      /* Copy the repeat seeds.   */
+      memcpy (&rs->s, repeat_state, sizeof (repeat_state));
+      njumps = 0;
+      if (image_distinct) njumps = hidden;
+      master_init = true;
+      init_rand_state (rs, true);
+	  rs->p = 0;
+    }
+  else
+    {
+      master_init = false;
+      init_rand_state (rs, true);
+    }
+
+  __gthread_mutex_unlock (&random_lock);
+}
+iexport(random_init);
 
 #if !defined __GTHREAD_MUTEX_INIT || defined __GTHREADS
 static void __attribute__((constructor))