I have attached my current implementation for RANDOM_INIT.
For programs compiled without -fcoarry= or with -fcoarray=single,
the one gets,
% cat random_init_2.f90
program foo
real x(2)
call random_init(.false., .false.)
call random_number(x)
print *, x
call random_init(.false., .false.)
call random_number(x)
print *, x
call random_init(.true., .false.)
call random_number(x)
print *, x
call random_init(.true., .false.)
call random_number(x)
print *, x
end program foo
% gfcx -o z random_init_2.f90 && ./z
0.817726076 0.318128884
0.598739505 2.99510360E-02
0.336736381 0.870776474
0.336736381 0.870776474
Now, with -fcoarray=lib, one gets
% gfcx -fcoarray=lib -c random_init_2.f90
f951: Fatal Error: RANDOM_INIT with co-arrays is broken!
compilation terminated.
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.
2018-01-07 Steven G. Kargl <ka...@gcc.gnu.org>
* check.c (gfc_check_random_init): New function.
* gfortran.h: Define GFC_ISYM_RANDOM_INIT.
* intrinsic.c (add_subroutines): Add random_init to list of subroutines.
(gfc_check_intrinsic_standard): Update error message for Fortran 2018.
* intrinsic.h: Add prototypes for gfc_check_random_init and
gfc_resolve_random_init.
* iresolve.c (gfc_resolve_random_init): Implementation.
2018-01-07 Steven G. Kargl <ka...@gcc.gnu.org>
* libgfortran/gfortran.map: Add _gfortran_random_init.
* libgfortran/intrinsics/random.c: Add implemention of
_gfortran_random_init
--
Steve
Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c (revision 256045)
+++ gcc/fortran/check.c (working copy)
@@ -5671,6 +5671,19 @@ gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, g
bool
+gfc_check_random_init (gfc_expr *repeatable, gfc_expr *image_distinct)
+{
+ if (!type_check (repeatable, 0, BT_LOGICAL))
+ return false;
+
+ if (!type_check (image_distinct, 1, BT_LOGICAL))
+ return false;
+
+ return true;
+}
+
+
+bool
gfc_check_random_number (gfc_expr *harvest)
{
if (!type_check (harvest, 0, BT_REAL))
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 256045)
+++ gcc/fortran/expr.c (working copy)
@@ -3853,7 +3853,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *
/* Error for assignments of contiguous pointers to targets which is not
contiguous. Be lenient in the definition of what counts as
- congiguous. */
+ contiguous. */
if (lhs_attr.contiguous && !gfc_is_simply_contiguous (rvalue, false, true))
gfc_error ("Assignment to contiguous pointer from non-contiguous "
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 256045)
+++ 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 256045)
+++ 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 256045)
+++ 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 *);
@@ -643,6 +644,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 256045)
+++ gcc/fortran/iresolve.c (working copy)
@@ -35,7 +35,9 @@ along with GCC; see the file COPYING3. If not see
#include "intrinsic.h"
#include "constructor.h"
#include "arith.h"
+#include "tm.h" /* For flag_coarray. */
+
/* Given printf-like arguments, return a stable version of the result string.
We already have a working, optimized string hashing table in the form of
@@ -3118,6 +3120,8 @@ gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
{
f->ts.type = BT_CHARACTER;
f->ts.kind = string->ts.kind;
+ f->ts.u.cl = NULL;
+ f->ts.u.pad = 0;
f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
}
@@ -3368,6 +3372,61 @@ gfc_resolve_mvbits (gfc_code *c)
/* Create a dummy formal arglist so the INTENTs are known later for purpose
of creating temporaries. */
c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
+}
+
+
+/* Set up the call to RANDOM_INIT. To deal with image_distinct, we need to
+ send a hidden argument into the library function. For program that don't
+ use co-arrays or uses -fcoarray=single, the hidden argument is set to 0.
+ For -fcoarray=lib, the hidden argument should be set to the value
+ returned by this_image(). Using R for REPEATABLE and I for
+ IMAGE_DISTINCT. So, RANDOM_INIT(R, I) is mapped to the library routine
+ _gfortran_random_init(R, I, 0) for a single image, and it should be
+ mapped to _gfortran_random_init(R, I, this_image()). */
+
+void
+gfc_resolve_random_init (gfc_code *c)
+{
+ gfc_actual_arglist *a;
+ const char *name;
+
+ name = gfc_get_string (PREFIX ("random_init"));
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+
+ /* Pass a hidden integer to deal with seeding images for coarrays. */
+ a = gfc_get_actual_arglist ();
+ if (flag_coarray != GFC_FCOARRAY_LIB)
+ {
+ a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &c->ext.actual->next->expr->where);
+ mpz_set_si (a->expr->value.integer, 0);
+ }
+ else
+ {
+ gfc_fatal_error ("RANDOM_INIT with co-arrays is broken!");
+#if 0
+/* Well, this didn't work. :( */
+ static const char name[] = "this_image";
+ a->expr = gfc_get_expr ();
+ a->expr->expr_type = EXPR_FUNCTION;
+ a->expr->ts.type = BT_INTEGER;
+ a->expr->ts.kind = gfc_default_integer_kind;
+ a->expr->where = gfc_current_locus;
+ a->expr->value.function.isym = gfc_find_function (name);
+ a->expr->value.function.name = a->expr->value.function.isym->name;
+
+ a->expr->value.function.actual = gfc_get_actual_arglist ();
+ a->expr->value.function.actual->next = gfc_get_actual_arglist ();
+ a->expr->value.function.actual->next->next = gfc_get_actual_arglist ();
+ a->expr->value.function.isym->formal->actual = gfc_get_actual_arglist ();
+ a->expr->value.function.isym->formal->actual->next = gfc_get_actual_arglist ();
+ a->expr->value.function.isym->formal->actual->next->next = gfc_get_actual_arglist ();
+
+ gfc_simplify_expr (a->expr, 0);
+ c->resolved_isym->formal->actual->next->next = a;
+#endif
+ }
+ c->ext.actual->next->next = a;
}
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map (revision 256045)
+++ 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 256045)
+++ 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);
@@ -205,7 +208,6 @@ static uint64_t master_state[] = {
0x625288bc262faf33ULL
};
-
static __gthread_key_t rand_state_key;
static xorshift1024star_state*
@@ -927,6 +929,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))
