[PATCH] thread-safe libgfortran (follow-up)
Jakub Jelinek
jakub@redhat.com
Fri Oct 7 14:29:00 GMT 2005
On Thu, Oct 06, 2005 at 05:39:35PM -0700, Steve Kargl wrote:
> > 1) prev_nl
I still haven't studied in detail, but determined the variable's life time
must be bounded by the life of the namelist_read routine. The reason for
that is all the routines that touch prev_nl are called from namelist_read
and there is just one namelist_read per data transfer. At the end
of the data transfer all namelist objects are freed. Which also
means the previous prev_nl handling was buggy - testing if prev_nl is
non-NULL, but never resetting it to NULL. So if one namelist_read call
resulted in prev_nl being set, then in a different data transfer statement
it would be called again, but not set prev_nl at all, it would just
dereference already freed object.
> Many months ago, I looked at the 2 * saved_length and also
> thought that it was weird. I tried changing the buffering
> to not waste as much memory, but my attempts led to memory
> corruption. I moved on to changing gfortran to use GMP/MPFR
> and forgot about this wart.
>
> > 3) it is not clear to me whether rand/irand/srand/random/arandom/random_seed
> > must be thread-safe or not. OpenMP 2.5 is not very clear on what exactly
> > needs to be thread-safe and what doesn't. If yes, rand.c/random.c will
> > need either locking, or __sync_compare_and_swap.
>
> If multiple threads are updating the internal state of the
> PRNG, I suspect you'll still get random numbers. I don't
> know if this will effect the quality of the randomness. The
> only problem I can see is the possibility of repeated runs
> of a Monte Carlo simulation may not be able to regenerate the
> same set of random numbers if there are race conditions.
I think it is desirable not to get the same pseudo random numbers
in different threads, so I have added locking. If -lpthread is not
linked in, the additional cost is just two non-taken conditional branches,
and ~ 2 memory loads.
> > 4) similarly system_clock. tp0 is not accessed in a thread-safe way there,
> > but I'd like to hear rationale why it has to be subtracted, why can't
> > system_clock simply start with the current time.
>
> Technically, we can remove the tp0. The Standard does not
> require system_clock to start from zero. It says
>
> COUNT (optional) shall be scalar and of type default integer.
> It is an INTENT (OUT) argument. It is assigned a processor-dependent
> value based on the current value of the processor clock or HUGE(0)
> if there is no clock. The processor-dependent value is incremented
> by one for each clock count until the value COUNT_MAX is reached and
> is reset to zero at the next count. It lies in the range 0 to COUNT_MAX
> if there is a clock.
Yeah. Changed not to use tp0 and avoid floating point calculations.
> BTW, I noticed the Copyright year in system_clock.c is 2004.
Well, in the previous version of the patch I haven't touched that file.
But there were a few that I missed, so correcting below.
In addition to this, I have changed trans-io.c, so that set_parameter_ref
handles variables of kinds other than 4 (aka PR fortran/21647).
Jerry's patch is still not in CVS, so I haven't adjusted that part.
Posting as interdiff from my last patch to avoid vasting bandwidth
(and make it easier to spot the changes since last patch).
I haven't created a ChangeLog yet, since it will take a long time
to write it given the number of changes :(. Anyway, I wonder about
the future of the patch, because of its size it will be a nightmare to
maintain it in the long term. I'd certainly appreciate a thorough
review and if people could test it on something other than just
check-gfortran testsuite. If it could make it into 4.1, it would
save me a lot of work, but I would very well understand if it can't
- it is an ABI breaker and just too huge for this late stage.
Depends if we want an ABI break between 4.0 and 4.1 or between
4.1 and 4.2. The other alternative is after approval (if any)
commit it to the gomp branch and merge as one of the first things
into 4.2 once 4.1 branches, but in that case I'd appreciate help
from those making bigger changes to libgfortran in the mean time
to also adapt their patches on gomp.
Comments?
Jakub
-------------- next part --------------
--- libgfortran/runtime/stop.c 2005-10-04 19:53:55.000000000 +0200
+++ libgfortran/runtime/stop.c 2005-10-07 10:06:14.000000000 +0200
@@ -1,5 +1,5 @@
/* Implementation of the STOP statement.
- Copyright 2002 Free Software Foundation, Inc.
+ Copyright 2002, 2005 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
--- libgfortran/runtime/pause.c 2005-10-04 19:53:55.000000000 +0200
+++ libgfortran/runtime/pause.c 2005-10-07 10:06:21.000000000 +0200
@@ -1,5 +1,5 @@
/* Implementation of the STOP statement.
- Copyright 2002 Free Software Foundation, Inc.
+ Copyright 2002, 2005 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
--- libgfortran/io/list_read.c 2005-10-05 19:11:53.000000000 +0200
+++ libgfortran/io/list_read.c 2005-10-07 14:09:28.000000000 +0200
@@ -1448,7 +1448,8 @@
calls:
static void nml_match_name (char *name, int len)
static int nml_query (st_parameter_dt *dtp)
- static int nml_get_obj_data (st_parameter_dt *dtp, char *)
+ static int nml_get_obj_data (st_parameter_dt *dtp,
+ namelist_info **prev_nl, char *)
calls:
static void nml_untouch_nodes (st_parameter_dt *dtp)
static namelist_info * find_nml_node (st_parameter_dt *dtp,
@@ -1456,17 +1457,12 @@
static int nml_parse_qualifier(descriptor_dimension * ad,
nml_loop_spec * ls, int rank, char *)
static void nml_touch_nodes (namelist_info * nl)
- static int nml_read_obj (namelist_info * nl, index_type offset,
- char *, index_type clow, index_type chigh)
+ static int nml_read_obj (namelist_info *nl, index_type offset,
+ namelist_info **prev_nl, char *,
+ index_type clow, index_type chigh)
calls:
-itself- */
-/* Pointer to the previously read object, in case attempt is made to read
- new object name. Should this fail, error message can give previous
- name. */
-
-static namelist_info * prev_nl;
-
/* Inputs a rank-dimensional qualifier, which can contain
singlets, doublets, triplets or ':' with the standard meanings. */
@@ -1809,7 +1805,8 @@
static try
nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
- char *nml_err_msg, index_type clow, index_type chigh)
+ namelist_info **pprev_nl, char *nml_err_msg,
+ index_type clow, index_type chigh)
{
namelist_info * cmp;
@@ -1923,7 +1920,8 @@
{
if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
- nml_err_msg, clow, chigh) == FAILURE)
+ pprev_nl, nml_err_msg, clow, chigh)
+ == FAILURE)
{
free_mem (obj_name);
return FAILURE;
@@ -1952,7 +1950,7 @@
should be here with dtp->u.p.nml_read_error != 0. Control returns to
nml_get_obj_data and an attempt is made to read object name. */
- prev_nl = nl;
+ *pprev_nl = nl;
if (dtp->u.p.nml_read_error)
return SUCCESS;
@@ -2030,7 +2028,8 @@
the manner specified by the object name. */
static try
-nml_get_obj_data (st_parameter_dt *dtp, char *nml_err_msg)
+nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
+ char *nml_err_msg)
{
char c;
namelist_info * nl;
@@ -2133,9 +2132,9 @@
if (nl == NULL)
{
- if (dtp->u.p.nml_read_error && prev_nl)
+ if (dtp->u.p.nml_read_error && *pprev_nl)
st_sprintf (nml_err_msg, "Bad data for namelist object %s",
- prev_nl->var_name);
+ (*pprev_nl)->var_name);
else
st_sprintf (nml_err_msg, "Cannot match namelist object name %s",
@@ -2269,7 +2268,7 @@
goto nml_err_ret;
}
- if (nml_read_obj (dtp, nl, 0, nml_err_msg, clow, chigh) == FAILURE)
+ if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, clow, chigh) == FAILURE)
goto nml_err_ret;
return SUCCESS;
@@ -2289,6 +2288,10 @@
char c;
jmp_buf eof_jump;
char nml_err_msg[100];
+ /* Pointer to the previously read object, in case attempt is made to read
+ new object name. Should this fail, error message can give previous
+ name. */
+ namelist_info *prev_nl = NULL;
dtp->u.p.namelist_mode = 1;
dtp->u.p.input_complete = 0;
@@ -2339,7 +2342,7 @@
while (!dtp->u.p.input_complete)
{
- if (nml_get_obj_data (dtp, nml_err_msg) == FAILURE)
+ if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg) == FAILURE)
{
gfc_unit *u;
--- gcc/fortran/trans-io.c 2005-10-04 22:07:51.000000000 +0200
+++ gcc/fortran/trans-io.c 2005-10-07 13:34:49.000000000 +0200
@@ -145,6 +145,7 @@
/* The data transfer parameter block that should be shared by all
data transfer calls belonging to the same read/write/iolength. */
static GTY(()) tree dt_parm;
+static stmtblock_t *dt_post_end_block;
static void
gfc_build_st_parameter (enum ioparam_type ptype, tree *types)
@@ -394,25 +395,42 @@
st_parameter_XXX structure. This is pass by reference. */
static unsigned int
-set_parameter_ref (stmtblock_t * block, tree var, enum iofield type,
- gfc_expr * e)
+set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
+ tree var, enum iofield type, gfc_expr *e)
{
gfc_se se;
- tree tmp;
+ tree tmp, addr;
gfc_st_parameter_field *p = &st_parameter_field[type];
+ gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL);
gfc_init_se (&se, NULL);
- se.want_pointer = 1;
+ gfc_conv_expr_lhs (&se, e);
- gfc_conv_expr_type (&se, e, TREE_TYPE (p->field));
gfc_add_block_to_block (block, &se.pre);
+ if (TYPE_MODE (TREE_TYPE (se.expr))
+ == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field))))
+ addr = convert (TREE_TYPE (p->field),
+ gfc_build_addr_expr (NULL, se.expr));
+ else
+ {
+ /* The type used by the library has different size
+ from the type of the variable supplied by the user.
+ Need to use a temporary. */
+ tree tmpvar
+ = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)),
+ st_parameter_field[type].name);
+ addr = gfc_build_addr_expr (NULL, tmpvar);
+ tmp = convert (TREE_TYPE (se.expr), tmpvar);
+ gfc_add_modify_expr (postblock, se.expr, tmp);
+ }
+
if (p->param_type == IOPARM_ptype_common)
var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
NULL_TREE);
- gfc_add_modify_expr (block, tmp, se.expr);
+ gfc_add_modify_expr (block, tmp, addr);
return p->mask;
}
@@ -764,7 +782,8 @@
p->iomsg);
if (p->iostat)
- mask |= set_parameter_ref (&block, var, IOPARM_common_iostat, p->iostat);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+ p->iostat);
if (p->err)
mask |= IOPARM_common_err;
@@ -816,7 +835,8 @@
p->iomsg);
if (p->iostat)
- mask |= set_parameter_ref (&block, var, IOPARM_common_iostat, p->iostat);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+ p->iostat);
if (p->err)
mask |= IOPARM_common_err;
@@ -866,7 +886,8 @@
p->iomsg);
if (p->iostat)
- mask |= set_parameter_ref (&block, var, IOPARM_common_iostat, p->iostat);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+ p->iostat);
if (p->err)
mask |= IOPARM_common_err;
@@ -959,19 +980,24 @@
p->iomsg);
if (p->iostat)
- mask |= set_parameter_ref (&block, var, IOPARM_common_iostat, p->iostat);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+ p->iostat);
if (p->exist)
- mask |= set_parameter_ref (&block, var, IOPARM_inquire_exist, p->exist);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
+ p->exist);
if (p->opened)
- mask |= set_parameter_ref (&block, var, IOPARM_inquire_opened, p->opened);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
+ p->opened);
if (p->number)
- mask |= set_parameter_ref (&block, var, IOPARM_inquire_number, p->number);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
+ p->number);
if (p->named)
- mask |= set_parameter_ref (&block, var, IOPARM_inquire_named, p->named);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
+ p->named);
if (p->name)
mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
@@ -1002,11 +1028,12 @@
p->unformatted);
if (p->recl)
- mask |= set_parameter_ref (&block, var, IOPARM_inquire_recl_out, p->recl);
+ mask |= set_parameter_ref (&block, &post_block, var,
+ IOPARM_inquire_recl_out, p->recl);
if (p->nextrec)
- mask |= set_parameter_ref (&block, var, IOPARM_inquire_nextrec,
- p->nextrec);
+ mask |= set_parameter_ref (&block, &post_block, var,
+ IOPARM_inquire_nextrec, p->nextrec);
if (p->blank)
mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
@@ -1308,7 +1335,7 @@
static tree
build_dt (tree function, gfc_code * code)
{
- stmtblock_t block, post_block;
+ stmtblock_t block, post_block, post_end_block;
gfc_dt *dt;
tree tmp, var;
gfc_expr *nmlname;
@@ -1317,6 +1344,7 @@
gfc_start_block (&block);
gfc_init_block (&post_block);
+ gfc_init_block (&post_end_block);
var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
@@ -1333,8 +1361,8 @@
gcc_assert (inq->iolength != NULL);
/* Connect to the iolength variable. */
- mask |= set_parameter_ref (&block, var, IOPARM_dt_iolength,
- inq->iolength);
+ mask |= set_parameter_ref (&block, &post_end_block, var,
+ IOPARM_dt_iolength, inq->iolength);
dt = NULL;
}
else
@@ -1383,11 +1411,12 @@
dt->iomsg);
if (dt->iostat)
- mask |= set_parameter_ref (&block, var, IOPARM_common_iostat,
- dt->iostat);
+ mask |= set_parameter_ref (&block, &post_end_block, var,
+ IOPARM_common_iostat, dt->iostat);
if (dt->size)
- mask |= set_parameter_ref (&block, var, IOPARM_dt_size, dt->size);
+ mask |= set_parameter_ref (&block, &post_end_block, var,
+ IOPARM_dt_size, dt->size);
if (dt->err)
mask |= IOPARM_common_err;
@@ -1433,10 +1462,12 @@
gfc_add_block_to_block (&block, &post_block);
dt_parm = var;
+ dt_post_end_block = &post_end_block;
gfc_add_expr_to_block (&block, gfc_trans_code (code->block->next));
dt_parm = NULL;
+ dt_post_end_block = NULL;
return gfc_finish_block (&block);
}
@@ -1506,6 +1537,8 @@
tmp = gfc_chainon_list (NULL_TREE, tmp);
tmp = gfc_build_function_call (function, tmp);
gfc_add_expr_to_block (&block, tmp);
+ gfc_add_block_to_block (&block, dt_post_end_block);
+ gfc_init_block (dt_post_end_block);
if (last_dt != IOLENGTH)
{
--- libgfortran/intrinsics/random.c.jj 2005-08-27 10:13:09.000000000 +0200
+++ libgfortran/intrinsics/random.c 2005-10-07 10:49:03.000000000 +0200
@@ -30,6 +30,7 @@ write to the Free Software Foundation, I
Boston, MA 02110-1301, USA. */
#include "libgfortran.h"
+#include "../io/io.h"
extern void random_r4 (GFC_REAL_4 *);
iexport_proto(random_r4);
@@ -43,6 +44,12 @@ export_proto(arandom_r4);
extern void arandom_r8 (gfc_array_r8 *);
export_proto(arandom_r8);
+#ifdef __GTHREAD_MUTEX_INIT
+static __gthread_mutex_t random_lock = __GTHREAD_MUTEX_INIT;
+#else
+static __gthread_mutex_t random_lock;
+#endif
+
#if 0
/* The Mersenne Twister code is currently commented out due to
@@ -111,12 +118,14 @@ static unsigned int seed[N];
void
random_seed (GFC_INTEGER_4 *size, gfc_array_i4 *put, gfc_array_i4 *get)
{
+ __gthread_mutex_lock (&random_lock);
+
/* Initialize the seed in system dependent manner. */
if (get == NULL && put == NULL && size == NULL)
{
int fd;
fd = open ("/dev/urandom", O_RDONLY);
- if (fd == 0)
+ if (fd < 0)
{
/* We dont have urandom. */
GFC_UINTEGER_4 s = (GFC_UINTEGER_4) seed;
@@ -131,15 +140,16 @@ random_seed (GFC_INTEGER_4 *size, gfc_ar
/* Using urandom, might have a length issue. */
read (fd, &seed[0], sizeof (GFC_UINTEGER_4) * N);
close (fd);
+ i = N;
}
- return;
+ goto return_unlock;
}
/* Return the size of the seed */
if (size != NULL)
{
*size = N;
- return;
+ goto return_unlock;
}
/* if we have gotten to this pount we have a get or put
@@ -159,7 +169,7 @@ random_seed (GFC_INTEGER_4 *size, gfc_ar
/* If this is the case the array is a temporary */
if (put->dim[0].stride == 0)
- return;
+ goto return_unlock;
/* This code now should do correct strides. */
for (i = 0; i < N; i++)
@@ -179,12 +189,15 @@ random_seed (GFC_INTEGER_4 *size, gfc_ar
/* If this is the case the array is a temporary */
if (get->dim[0].stride == 0)
- return;
+ goto return_unlock;
/* This code now should do correct strides. */
for (i = 0; i < N; i++)
get->data[i * get->dim[0].stride] = seed[i];
}
+
+ random_unlock:
+ __gthread_mutex_unlock (&random_lock);
}
iexport(random_seed);
@@ -220,6 +233,8 @@ random_generate (void)
void
random_r4 (GFC_REAL_4 * harv)
{
+ __gthread_mutex_lock (&random_lock);
+
/* Regenerate if we need to. */
if (i >= N)
random_generate ();
@@ -227,6 +242,7 @@ random_r4 (GFC_REAL_4 * harv)
/* Convert uint32 to REAL(KIND=4). */
*harv = (GFC_REAL_4) ((GFC_REAL_4) (GFC_UINTEGER_4) seed[i++] /
(GFC_REAL_4) (~(GFC_UINTEGER_4) 0));
+ __gthread_mutex_unlock (&random_lock);
}
iexport(random_r4);
@@ -235,6 +251,8 @@ iexport(random_r4);
void
random_r8 (GFC_REAL_8 * harv)
{
+ __gthread_mutex_lock (&random_lock);
+
/* Regenerate if we need to, may waste one 32-bit value. */
if ((i + 1) >= N)
random_generate ();
@@ -243,6 +261,7 @@ random_r8 (GFC_REAL_8 * harv)
*harv = ((GFC_REAL_8) ((((GFC_UINTEGER_8) seed[i+1]) << 32) + seed[i])) /
(GFC_REAL_8) (~(GFC_UINTEGER_8) 0);
i += 2;
+ __gthread_mutex_unlock (&random_lock);
}
iexport(random_r8);
@@ -279,6 +298,8 @@ arandom_r4 (gfc_array_r4 * harv)
stride0 = stride[0];
+ __gthread_mutex_lock (&random_lock);
+
while (dest)
{
/* Set the elements. */
@@ -319,6 +340,8 @@ arandom_r4 (gfc_array_r4 * harv)
}
}
}
+
+ __gthread_mutex_unlock (&random_lock);
}
/* REAL(KIND=8) array. */
@@ -352,6 +375,8 @@ arandom_r8 (gfc_array_r8 * harv)
stride0 = stride[0];
+ __gthread_mutex_lock (&random_lock);
+
while (dest)
{
/* Set the elements. */
@@ -393,6 +418,8 @@ arandom_r8 (gfc_array_r8 * harv)
}
}
}
+
+ __gthread_mutex_unlock (&random_lock);
}
#else
@@ -470,11 +497,13 @@ random_r4 (GFC_REAL_4 *x)
{
GFC_UINTEGER_4 kiss;
+ __gthread_mutex_lock (&random_lock);
kiss = kiss_random_kernel ();
/* Burn a random number, so the REAL*4 and REAL*8 functions
produce similar sequences of random numbers. */
kiss_random_kernel ();
*x = normalize_r4_i4 (kiss, ~(GFC_UINTEGER_4) 0);
+ __gthread_mutex_unlock (&random_lock);
}
iexport(random_r4);
@@ -486,9 +515,11 @@ random_r8 (GFC_REAL_8 *x)
{
GFC_UINTEGER_8 kiss;
+ __gthread_mutex_lock (&random_lock);
kiss = ((GFC_UINTEGER_8)kiss_random_kernel ()) << 32;
kiss += kiss_random_kernel ();
*x = normalize_r8_i8 (kiss, ~(GFC_UINTEGER_8) 0);
+ __gthread_mutex_unlock (&random_lock);
}
iexport(random_r8);
@@ -504,6 +535,7 @@ arandom_r4 (gfc_array_r4 *x)
index_type stride0;
index_type dim;
GFC_REAL_4 *dest;
+ GFC_UINTEGER_4 kiss;
int n;
dest = x->data;
@@ -524,9 +556,16 @@ arandom_r4 (gfc_array_r4 *x)
stride0 = stride[0];
+ __gthread_mutex_lock (&random_lock);
+
while (dest)
{
- random_r4 (dest);
+ /* random_r4 (dest); */
+ kiss = kiss_random_kernel ();
+ /* Burn a random number, so the REAL*4 and REAL*8 functions
+ produce similar sequences of random numbers. */
+ kiss_random_kernel ();
+ *dest = normalize_r4_i4 (kiss, ~(GFC_UINTEGER_4) 0);
/* Advance to the next element. */
dest += stride0;
@@ -554,6 +593,7 @@ arandom_r4 (gfc_array_r4 *x)
}
}
}
+ __gthread_mutex_unlock (&random_lock);
}
/* This function fills a REAL(8) array with values from the uniform
@@ -568,6 +608,7 @@ arandom_r8 (gfc_array_r8 *x)
index_type stride0;
index_type dim;
GFC_REAL_8 *dest;
+ GFC_UINTEGER_8 kiss;
int n;
dest = x->data;
@@ -588,9 +629,14 @@ arandom_r8 (gfc_array_r8 *x)
stride0 = stride[0];
+ __gthread_mutex_lock (&random_lock);
+
while (dest)
{
- random_r8 (dest);
+ /* random_r8 (dest); */
+ kiss = ((GFC_UINTEGER_8)kiss_random_kernel ()) << 32;
+ kiss += kiss_random_kernel ();
+ *dest = normalize_r8_i8 (kiss, ~(GFC_UINTEGER_8) 0);
/* Advance to the next element. */
dest += stride0;
@@ -618,6 +664,7 @@ arandom_r8 (gfc_array_r8 *x)
}
}
}
+ __gthread_mutex_unlock (&random_lock);
}
/* random_seed is used to seed the PRNG with either a default
@@ -629,6 +676,8 @@ random_seed (GFC_INTEGER_4 *size, gfc_ar
{
int i;
+ __gthread_mutex_lock (&random_lock);
+
if (size == NULL && put == NULL && get == NULL)
{
/* From the standard: "If no argument is present, the processor assigns
@@ -678,7 +727,17 @@ random_seed (GFC_INTEGER_4 *size, gfc_ar
for (i = 0; i < kiss_size; i++)
get->data[i * get->dim[0].stride] = (GFC_INTEGER_4) kiss_seed[i];
}
+
+ __gthread_mutex_unlock (&random_lock);
}
iexport(random_seed);
#endif /* mersenne twister */
+
+#ifndef __GTHREAD_MUTEX_INIT
+static void __attribute__((constructor))
+init (void)
+{
+ __GTHREAD_MUTEX_INIT_FUNCTION (&random_lock);
+}
+#endif
--- libgfortran/intrinsics/system_clock.c.jj 2005-08-27 10:13:09.000000000 +0200
+++ libgfortran/intrinsics/system_clock.c 2005-10-07 13:11:19.000000000 +0200
@@ -44,13 +44,6 @@ Boston, MA 02110-1301, USA. */
#endif
-#if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
-static struct timeval tp0 = {-1, 0};
-#elif defined(HAVE_TIME_H)
-static time_t t0 = (time_t) -2;
-#endif
-
-
extern void system_clock_4 (GFC_INTEGER_4 *, GFC_INTEGER_4 *, GFC_INTEGER_4 *);
export_proto(system_clock_4);
@@ -74,31 +67,18 @@ system_clock_4(GFC_INTEGER_4 *count, GFC
#if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
struct timeval tp1;
struct timezone tzp;
- double t;
+
+ if (sizeof (tp1.tv_sec) < sizeof (GFC_INTEGER_4))
+ internal_error (NULL, "tv_sec too small");
if (gettimeofday(&tp1, &tzp) == 0)
{
- if (tp0.tv_sec < 0)
- {
- tp0 = tp1;
- cnt = 0;
- }
+ GFC_UINTEGER_4 ucnt = (GFC_UINTEGER_4) tp1.tv_sec * TCK;
+ ucnt += (tp1.tv_usec + 500000 / TCK) / (1000000 / TCK);
+ if (ucnt > GFC_INTEGER_4_HUGE)
+ cnt = ucnt - GFC_INTEGER_4_HUGE - 1;
else
- {
- /* TODO: Convert this to integer arithmetic. */
- t = (double) (tp1.tv_sec - tp0.tv_sec);
- t += (double) (tp1.tv_usec - tp0.tv_usec) * 1.e-6;
- t *= TCK;
-
- if (t > (double) GFC_INTEGER_4_HUGE)
- {
- /* Time has wrapped. */
- while (t > (double) GFC_INTEGER_4_HUGE)
- t -= (double) GFC_INTEGER_4_HUGE;
- tp0 = tp1;
- }
- cnt = (GFC_INTEGER_4) t;
- }
+ cnt = ucnt;
rate = TCK;
mx = GFC_INTEGER_4_HUGE;
}
@@ -113,24 +93,17 @@ system_clock_4(GFC_INTEGER_4 *count, GFC
return;
}
#elif defined(HAVE_TIME_H)
- time_t t, t1;
+ GFC_UINTEGER_4 ucnt;
- t1 = time(NULL);
+ if (sizeof (time_t) < sizeof (GFC_INTEGER_4))
+ internal_error (NULL, "time_t too small");
- if (t1 == (time_t) -1)
- {
- cnt = - GFC_INTEGER_4_HUGE;
- mx = 0;
- }
- else if (t0 == (time_t) -2)
- t0 = t1;
+ ucnt = time (NULL);
+ if (ucnt > GFC_INTEGER_4_HUGE)
+ cnt = ucnt - GFC_INTEGER_4_HUGE - 1;
else
- {
- /* The timer counts in seconts, so for simplicity assume it never wraps.
- Even with 32-bit counters this only happens once every 68 years. */
- cnt = t1 - t0;
- mx = GFC_INTEGER_4_HUGE;
- }
+ cnt = ucnt;
+ mx = GFC_INTEGER_4_HUGE;
#else
cnt = - GFC_INTEGER_4_HUGE;
mx = 0;
@@ -148,7 +121,7 @@ system_clock_4(GFC_INTEGER_4 *count, GFC
void
system_clock_8 (GFC_INTEGER_8 *count, GFC_INTEGER_8 *count_rate,
- GFC_INTEGER_8 *count_max)
+ GFC_INTEGER_8 *count_max)
{
GFC_INTEGER_8 cnt;
GFC_INTEGER_8 rate;
@@ -157,33 +130,33 @@ system_clock_8 (GFC_INTEGER_8 *count, GF
#if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
struct timeval tp1;
struct timezone tzp;
- double t;
+
+ if (sizeof (tp1.tv_sec) < sizeof (GFC_INTEGER_4))
+ internal_error (NULL, "tv_sec too small");
if (gettimeofday(&tp1, &tzp) == 0)
{
- if (tp0.tv_sec < 0)
- {
- tp0 = tp1;
- cnt = 0;
- }
+ if (sizeof (tp1.tv_sec) < sizeof (GFC_INTEGER_8))
+ {
+ GFC_UINTEGER_4 ucnt = (GFC_UINTEGER_4) tp1.tv_sec * TCK;
+ ucnt += (tp1.tv_usec + 500000 / TCK) / (1000000 / TCK);
+ if (ucnt > GFC_INTEGER_4_HUGE)
+ cnt = ucnt - GFC_INTEGER_4_HUGE - 1;
+ else
+ cnt = ucnt;
+ mx = GFC_INTEGER_4_HUGE;
+ }
else
- {
- /* TODO: Convert this to integer arithmetic. */
- t = (double) (tp1.tv_sec - tp0.tv_sec);
- t += (double) (tp1.tv_usec - tp0.tv_usec) * 1.e-6;
- t *= TCK;
-
- if (t > (double) GFC_INTEGER_8_HUGE)
- {
- /* Time has wrapped. */
- while (t > (double) GFC_INTEGER_8_HUGE)
- t -= (double) GFC_INTEGER_8_HUGE;
- tp0 = tp1;
- }
- cnt = (GFC_INTEGER_8) t;
- }
+ {
+ GFC_UINTEGER_8 ucnt = (GFC_UINTEGER_8) tp1.tv_sec * TCK;
+ ucnt += (tp1.tv_usec + 500000 / TCK) / (1000000 / TCK);
+ if (ucnt > GFC_INTEGER_8_HUGE)
+ cnt = ucnt - GFC_INTEGER_8_HUGE - 1;
+ else
+ cnt = ucnt;
+ mx = GFC_INTEGER_8_HUGE;
+ }
rate = TCK;
- mx = GFC_INTEGER_8_HUGE;
}
else
{
@@ -197,22 +170,24 @@ system_clock_8 (GFC_INTEGER_8 *count, GF
return;
}
#elif defined(HAVE_TIME_H)
- time_t t, t1;
-
- t1 = time(NULL);
-
- if (t1 == (time_t) -1)
- {
- cnt = - GFC_INTEGER_8_HUGE;
- mx = 0;
+ if (sizeof (time_t) < sizeof (GFC_INTEGER_4))
+ internal_error (NULL, "time_t too small");
+ else if (sizeof (time_t) == sizeof (GFC_INTEGER_4))
+ {
+ GFC_UINTEGER_4 ucnt = time (NULL);
+ if (ucnt > GFC_INTEGER_4_HUGE)
+ cnt = ucnt - GFC_INTEGER_4_HUGE - 1;
+ else
+ cnt = ucnt;
+ mx = GFC_INTEGER_4_HUGE;
}
- else if (t0 == (time_t) -2)
- t0 = t1;
else
{
- /* The timer counts in seconts, so for simplicity assume it never wraps.
- Even with 32-bit counters this only happens once every 68 years. */
- cnt = t1 - t0;
+ GFC_UINTEGER_8 ucnt = time (NULL);
+ if (ucnt > GFC_INTEGER_8_HUGE)
+ cnt = ucnt - GFC_INTEGER_8_HUGE - 1;
+ else
+ cnt = ucnt;
mx = GFC_INTEGER_8_HUGE;
}
#else
--- libgfortran/intrinsics/rand.c.jj 2005-08-27 10:13:09.000000000 +0200
+++ libgfortran/intrinsics/rand.c 2005-10-07 10:26:43.000000000 +0200
@@ -1,5 +1,5 @@
/* Implementation of the IRAND, RAND, and SRAND intrinsics.
- Copyright (C) 2004 Free Software Foundation, Inc.
+ Copyright (C) 2004, 2005 Free Software Foundation, Inc.
Contributed by Steven G. Kargl <kargls@comcast.net>.
This file is part of the GNU Fortran 95 runtime library (libgfortran).
@@ -37,12 +37,18 @@ Boston, MA 02110-1301, USA. */
#include "config.h"
#include "libgfortran.h"
+#include "../io/io.h"
#define GFC_RAND_A 16807
#define GFC_RAND_M 2147483647
#define GFC_RAND_M1 (GFC_RAND_M - 1)
static GFC_UINTEGER_8 rand_seed = 1;
+#ifdef __GTHREAD_MUTEX_INIT
+static __gthread_mutex_t rand_seed_lock = __GTHREAD_MUTEX_INIT;
+#else
+static __gthread_mutex_t rand_seed_lock;
+#endif
/* Set the seed of the irand generator. Note 0 is a bad seed. */
@@ -59,7 +65,9 @@ export_proto_np(PREFIX(srand));
void
PREFIX(srand) (GFC_INTEGER_4 *i)
{
+ __gthread_mutex_lock (&rand_seed_lock);
srand_internal (*i);
+ __gthread_mutex_unlock (&rand_seed_lock);
}
/* Return an INTEGER in the range [1,GFC_RAND_M-1]. */
@@ -76,6 +84,8 @@ irand (GFC_INTEGER_4 *i)
else
j = 0;
+ __gthread_mutex_lock (&rand_seed_lock);
+
switch (j)
{
/* Return the next RN. */
@@ -95,8 +105,11 @@ irand (GFC_INTEGER_4 *i)
}
rand_seed = GFC_RAND_A * rand_seed % GFC_RAND_M;
+ j = (GFC_INTEGER_4) rand_seed;
+
+ __gthread_mutex_unlock (&rand_seed_lock);
- return (GFC_INTEGER_4) rand_seed;
+ return j;
}
iexport(irand);
@@ -111,3 +124,11 @@ PREFIX(rand) (GFC_INTEGER_4 *i)
{
return normalize_r4_i4 (irand (i) - 1, GFC_RAND_M1 - 1);
}
+
+#ifndef __GTHREAD_MUTEX_INIT
+static void __attribute__((constructor))
+init (void)
+{
+ __GTHREAD_MUTEX_INIT_FUNCTION (&rand_seed_lock);
+}
+#endif
--- gcc/fortran/trans-expr.c.jj 2005-10-04 19:23:14.000000000 +0200
+++ gcc/fortran/trans-expr.c 2005-10-07 12:04:27.000000000 +0200
@@ -2351,7 +2351,7 @@ gfc_conv_expr_lhs (gfc_se * se, gfc_expr
}
/* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
- numeric expressions. Used for scalar values whee inserting cleanup code
+ numeric expressions. Used for scalar values where inserting cleanup code
is inconvenient. */
void
gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
only in patch2:
unchanged:
--- gcc/testsuite/gfortran.fortran-torture/execute/inquire_5.f90.jj 2005-10-07 13:34:20.000000000 +0200
+++ gcc/testsuite/gfortran.fortran-torture/execute/inquire_5.f90 2005-10-07 13:36:46.000000000 +0200
@@ -0,0 +1,32 @@
+! PR fortran/21647
+program inquire_5
+ integer (kind = 8) :: unit8
+ logical (kind = 8) :: exist8
+ integer (kind = 4) :: unit4
+ logical (kind = 4) :: exist4
+ integer (kind = 2) :: unit2
+ logical (kind = 2) :: exist2
+ integer (kind = 1) :: unit1
+ logical (kind = 1) :: exist1
+ character (len = 6) :: del
+ unit8 = 78
+ open (file = 'inquire_5.txt', unit = unit8)
+ unit8 = -1
+ exist8 = .false.
+ unit4 = -1
+ exist4 = .false.
+ unit2 = -1
+ exist2 = .false.
+ unit1 = -1
+ exist1 = .false.
+ inquire (file = 'inquire_5.txt', number = unit8, exist = exist8)
+ if (unit8 .ne. 78 .or. .not. exist8) call abort
+ inquire (file = 'inquire_5.txt', number = unit4, exist = exist4)
+ if (unit4 .ne. 78 .or. .not. exist4) call abort
+ inquire (file = 'inquire_5.txt', number = unit2, exist = exist2)
+ if (unit2 .ne. 78 .or. .not. exist2) call abort
+ inquire (file = 'inquire_5.txt', number = unit1, exist = exist1)
+ if (unit1 .ne. 78 .or. .not. exist1) call abort
+ del = 'delete'
+ close (unit = 78, status = del)
+end
More information about the Fortran
mailing list