Implementation of RANDOM_INIT from F2018

Message ID	20180108025140.GA14526@troutmask.apl.washington.edu
State	New
Headers	show Return-Path: <gcc-patches-return-470367-incoming=patchwork.ozlabs.org@gcc.gnu.org> DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:subject:message-id:reply-to:mime-version:content-type; q=dns; s=default; b=GQrsdqUZT8Zvx/EQasWv5nvGAxFIxgcyLP5hSQfAvX3 1APxq9O3HFKX+FSRDgqW9zwUCeuPZJDVSHM6bKr0PJ5PtJwvwcWGpSJ+kvMggju8 0Xj0Rc97gfurDI7gfM0Iz6l9Zn8stn/QkWPpfbF4ku2dltx/URpXBVk1yHt6c0oQ = Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk Sender: gcc-patches-owner@gcc.gnu.org Date: Sun, 7 Jan 2018 18:51:40 -0800 From: Steve Kargl <sgk@troutmask.apl.washington.edu> To: fortan@troutmask.apl.washington.edu, gcc-patches@gcc.gnu.org Subject: [PATCH] Implementation of RANDOM_INIT from F2018 Message-ID: <20180108025140.GA14526@troutmask.apl.washington.edu> Reply-To: sgk@troutmask.apl.washington.edu MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="vtzGhvizbBRQ85DL" Content-Disposition: inline User-Agent: Mutt/1.9.2 (2017-12-15)
Series	Implementation of RANDOM_INIT from F2018 \| expand Implementation of RANDOM_INIT from F2018

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))

Implementation of RANDOM_INIT from F2018

Commit Message

Comments

Patch