1 /* Implementation of the RANDOM intrinsics
2 Copyright (C) 2002-2016 Free Software Foundation, Inc.
3 Contributed by Lars Segerlund <seger@linuxmail.org>,
4 Steve Kargl and Janne Blomqvist.
6 This file is part of the GNU Fortran runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or
9 modify it under the terms of the GNU General Public
10 License as published by the Free Software Foundation; either
11 version 3 of the License, or (at your option) any later version.
13 Ligbfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
27 #include "libgfortran.h"
32 /* For getosrandom. */
33 #ifdef HAVE_SYS_TYPES_H
34 #include <sys/types.h>
48 extern void random_r4 (GFC_REAL_4
*);
49 iexport_proto(random_r4
);
51 extern void random_r8 (GFC_REAL_8
*);
52 iexport_proto(random_r8
);
54 extern void arandom_r4 (gfc_array_r4
*);
55 export_proto(arandom_r4
);
57 extern void arandom_r8 (gfc_array_r8
*);
58 export_proto(arandom_r8
);
60 #ifdef HAVE_GFC_REAL_10
62 extern void random_r10 (GFC_REAL_10
*);
63 iexport_proto(random_r10
);
65 extern void arandom_r10 (gfc_array_r10
*);
66 export_proto(arandom_r10
);
70 #ifdef HAVE_GFC_REAL_16
72 extern void random_r16 (GFC_REAL_16
*);
73 iexport_proto(random_r16
);
75 extern void arandom_r16 (gfc_array_r16
*);
76 export_proto(arandom_r16
);
80 #ifdef __GTHREAD_MUTEX_INIT
81 static __gthread_mutex_t random_lock
= __GTHREAD_MUTEX_INIT
;
83 static __gthread_mutex_t random_lock
;
86 /* Helper routines to map a GFC_UINTEGER_* to the corresponding
87 GFC_REAL_* types in the range of [0,1). If GFC_REAL_*_RADIX are 2
88 or 16, respectively, we mask off the bits that don't fit into the
89 correct GFC_REAL_*, convert to the real type, then multiply by the
94 rnumber_4 (GFC_REAL_4
*f
, GFC_UINTEGER_4 v
)
97 #if GFC_REAL_4_RADIX == 2
98 mask
= ~ (GFC_UINTEGER_4
) 0u << (32 - GFC_REAL_4_DIGITS
);
99 #elif GFC_REAL_4_RADIX == 16
100 mask
= ~ (GFC_UINTEGER_4
) 0u << ((8 - GFC_REAL_4_DIGITS
) * 4);
102 #error "GFC_REAL_4_RADIX has unknown value"
105 *f
= (GFC_REAL_4
) v
* GFC_REAL_4_LITERAL(0x1.p
-32);
109 rnumber_8 (GFC_REAL_8
*f
, GFC_UINTEGER_8 v
)
112 #if GFC_REAL_8_RADIX == 2
113 mask
= ~ (GFC_UINTEGER_8
) 0u << (64 - GFC_REAL_8_DIGITS
);
114 #elif GFC_REAL_8_RADIX == 16
115 mask
= ~ (GFC_UINTEGER_8
) 0u << (16 - GFC_REAL_8_DIGITS
) * 4);
117 #error "GFC_REAL_8_RADIX has unknown value"
120 *f
= (GFC_REAL_8
) v
* GFC_REAL_8_LITERAL(0x1.p
-64);
123 #ifdef HAVE_GFC_REAL_10
126 rnumber_10 (GFC_REAL_10
*f
, GFC_UINTEGER_8 v
)
129 #if GFC_REAL_10_RADIX == 2
130 mask
= ~ (GFC_UINTEGER_8
) 0u << (64 - GFC_REAL_10_DIGITS
);
131 #elif GFC_REAL_10_RADIX == 16
132 mask
= ~ (GFC_UINTEGER_10
) 0u << ((16 - GFC_REAL_10_DIGITS
) * 4);
134 #error "GFC_REAL_10_RADIX has unknown value"
137 *f
= (GFC_REAL_10
) v
* GFC_REAL_10_LITERAL(0x1.p
-64);
141 #ifdef HAVE_GFC_REAL_16
143 /* For REAL(KIND=16), we only need to mask off the lower bits. */
146 rnumber_16 (GFC_REAL_16
*f
, GFC_UINTEGER_8 v1
, GFC_UINTEGER_8 v2
)
149 #if GFC_REAL_16_RADIX == 2
150 mask
= ~ (GFC_UINTEGER_8
) 0u << (128 - GFC_REAL_16_DIGITS
);
151 #elif GFC_REAL_16_RADIX == 16
152 mask
= ~ (GFC_UINTEGER_8
) 0u << ((32 - GFC_REAL_16_DIGITS
) * 4);
154 #error "GFC_REAL_16_RADIX has unknown value"
157 *f
= (GFC_REAL_16
) v1
* GFC_REAL_16_LITERAL(0x1.p
-64)
158 + (GFC_REAL_16
) v2
* GFC_REAL_16_LITERAL(0x1.p
-128);
165 We use the xorshift1024* generator, a fast high-quality generator
168 - passes TestU1 without any failures
170 - provides a "jump" function making it easy to provide many
171 independent parallel streams.
173 - Long period of 2**1024 - 1
175 A description can be found at
177 http://vigna.di.unimi.it/ftp/papers/xorshift.pdf
181 http://arxiv.org/abs/1402.6246
183 The paper includes public domain source code which is the basis for
184 the implementation below.
193 xorshift1024star_state
;
196 /* master_init, njumps, and master_state are the only variables
197 protected by random_lock. */
198 static bool master_init
;
199 static unsigned njumps
; /* How many times we have jumped. */
200 static uint64_t master_state
[] = {
201 0xad63fa1ed3b55f36ULL
, 0xd94473e78978b497ULL
, 0xbc60592a98172477ULL
,
202 0xa3de7c6e81265301ULL
, 0x586640c5e785af27ULL
, 0x7a2a3f63b67ce5eaULL
,
203 0x9fde969f922d9b82ULL
, 0xe6fe34379b3f3822ULL
, 0x6c277eac3e99b6c2ULL
,
204 0x9197290ab0d3f069ULL
, 0xdb227302f6c25576ULL
, 0xee0209aee527fae9ULL
,
205 0x675666a793cd05b9ULL
, 0xd048c99fbc70c20fULL
, 0x775f8c3dba385ef5ULL
,
206 0x625288bc262faf33ULL
210 static __gthread_key_t rand_state_key
;
212 static xorshift1024star_state
*
213 get_rand_state (void)
215 /* For single threaded apps. */
216 static xorshift1024star_state rand_state
;
218 if (__gthread_active_p ())
220 void* p
= __gthread_getspecific (rand_state_key
);
223 p
= xcalloc (1, sizeof (xorshift1024star_state
));
224 __gthread_setspecific (rand_state_key
, p
);
234 xorshift1024star (xorshift1024star_state
* rs
)
237 const uint64_t s0
= rs
->s
[p
];
238 uint64_t s1
= rs
->s
[p
= (p
+ 1) & 15];
240 rs
->s
[p
] = s1
^ s0
^ (s1
>> 11) ^ (s0
>> 30);
242 return rs
->s
[p
] * UINT64_C(1181783497276652981);
246 /* This is the jump function for the generator. It is equivalent to
247 2^512 calls to xorshift1024star(); it can be used to generate 2^512
248 non-overlapping subsequences for parallel computations. */
251 jump (xorshift1024star_state
* rs
)
253 static const uint64_t JUMP
[] = {
254 0x84242f96eca9c41dULL
, 0xa3c65b8776f96855ULL
, 0x5b34a39f070b5837ULL
,
255 0x4489affce4f31a1eULL
, 0x2ffeeb0a48316f40ULL
, 0xdc2d9891fe68c022ULL
,
256 0x3659132bb12fea70ULL
, 0xaac17d8efa43cab8ULL
, 0xc4cb815590989b13ULL
,
257 0x5ee975283d71c93bULL
, 0x691548c86c1bd540ULL
, 0x7910c41d10a1e6a5ULL
,
258 0x0b5fc64563b3e2a8ULL
, 0x047f7684e9fc949dULL
, 0xb99181f2d8f685caULL
,
259 0x284600e3f30e38c3ULL
262 uint64_t t
[16] = { 0 };
263 for(unsigned int i
= 0; i
< sizeof JUMP
/ sizeof *JUMP
; i
++)
264 for(int b
= 0; b
< 64; b
++)
266 if (JUMP
[i
] & 1ULL << b
)
267 for(int j
= 0; j
< 16; j
++)
268 t
[j
] ^= rs
->s
[(j
+ rs
->p
) & 15];
269 xorshift1024star (rs
);
271 for(int j
= 0; j
< 16; j
++)
272 rs
->s
[(j
+ rs
->p
) & 15] = t
[j
];
276 /* Super-simple LCG generator used in getosrandom () if /dev/urandom
279 #define M 2147483647 /* 2^31 - 1 (A large prime number) */
280 #define A 16807 /* Prime root of M, passes statistical tests and produces a full cycle */
281 #define Q 127773 /* M / A (To avoid overflow on A * seed) */
282 #define R 2836 /* M % A (To avoid overflow on A * seed) */
285 lcg_parkmiller(uint32_t seed
)
287 uint32_t hi
= seed
/ Q
;
288 uint32_t lo
= seed
% Q
;
289 int32_t test
= A
* lo
- R
* hi
;
300 /* Get some random bytes from the operating system in order to seed
304 getosrandom (void *buf
, size_t buflen
)
306 /* TODO: On Windows one could use CryptGenRandom
308 TODO: When glibc adds a wrapper for the getrandom() system call
309 on Linux, one could use that.
311 TODO: One could use getentropy() on OpenBSD. */
312 int flags
= O_RDONLY
;
316 int fd
= open("/dev/urandom", flags
);
319 int res
= read(fd
, buf
, buflen
);
323 uint32_t seed
= 1234567890;
326 if (gf_gettime (&secs
, &usecs
) == 0)
332 pid_t pid
= getpid();
336 for (size_t i
= 0; i
< buflen
; i
++)
339 seed
= lcg_parkmiller (seed
);
345 /* Initialize the random number generator for the current thread,
346 using the master state and the number of times we must jump. */
349 init_rand_state (xorshift1024star_state
* rs
, const bool locked
)
352 __gthread_mutex_lock (&random_lock
);
355 getosrandom (master_state
, sizeof (master_state
));
359 memcpy (&rs
->s
, master_state
, sizeof (master_state
));
360 unsigned n
= njumps
++;
362 __gthread_mutex_unlock (&random_lock
);
363 for (unsigned i
= 0; i
< n
; i
++)
369 /* This function produces a REAL(4) value from the uniform distribution
373 random_r4 (GFC_REAL_4
*x
)
375 xorshift1024star_state
* rs
= get_rand_state();
377 if (unlikely (!rs
->init
))
378 init_rand_state (rs
, false);
379 uint64_t r
= xorshift1024star (rs
);
380 /* Take the higher bits, ensuring that a stream of real(4), real(8),
381 and real(10) will be identical (except for precision). */
382 uint32_t high
= (uint32_t) (r
>> 32);
387 /* This function produces a REAL(8) value from the uniform distribution
391 random_r8 (GFC_REAL_8
*x
)
394 xorshift1024star_state
* rs
= get_rand_state();
396 if (unlikely (!rs
->init
))
397 init_rand_state (rs
, false);
398 r
= xorshift1024star (rs
);
403 #ifdef HAVE_GFC_REAL_10
405 /* This function produces a REAL(10) value from the uniform distribution
409 random_r10 (GFC_REAL_10
*x
)
412 xorshift1024star_state
* rs
= get_rand_state();
414 if (unlikely (!rs
->init
))
415 init_rand_state (rs
, false);
416 r
= xorshift1024star (rs
);
423 /* This function produces a REAL(16) value from the uniform distribution
426 #ifdef HAVE_GFC_REAL_16
429 random_r16 (GFC_REAL_16
*x
)
431 GFC_UINTEGER_8 r1
, r2
;
432 xorshift1024star_state
* rs
= get_rand_state();
434 if (unlikely (!rs
->init
))
435 init_rand_state (rs
, false);
436 r1
= xorshift1024star (rs
);
437 r2
= xorshift1024star (rs
);
438 rnumber_16 (x
, r1
, r2
);
445 /* This function fills a REAL(4) array with values from the uniform
446 distribution with range [0,1). */
449 arandom_r4 (gfc_array_r4
*x
)
451 index_type count
[GFC_MAX_DIMENSIONS
];
452 index_type extent
[GFC_MAX_DIMENSIONS
];
453 index_type stride
[GFC_MAX_DIMENSIONS
];
457 xorshift1024star_state
* rs
= get_rand_state();
463 dim
= GFC_DESCRIPTOR_RANK (x
);
465 for (n
= 0; n
< dim
; n
++)
468 stride
[n
] = GFC_DESCRIPTOR_STRIDE(x
,n
);
469 extent
[n
] = GFC_DESCRIPTOR_EXTENT(x
,n
);
476 if (unlikely (!rs
->init
))
477 init_rand_state (rs
, false);
481 /* random_r4 (dest); */
482 uint64_t r
= xorshift1024star (rs
);
483 uint32_t high
= (uint32_t) (r
>> 32);
484 rnumber_4 (dest
, high
);
486 /* Advance to the next element. */
489 /* Advance to the next source element. */
491 while (count
[n
] == extent
[n
])
493 /* When we get to the end of a dimension, reset it and increment
494 the next dimension. */
496 /* We could precalculate these products, but this is a less
497 frequently used path so probably not worth it. */
498 dest
-= stride
[n
] * extent
[n
];
514 /* This function fills a REAL(8) array with values from the uniform
515 distribution with range [0,1). */
518 arandom_r8 (gfc_array_r8
*x
)
520 index_type count
[GFC_MAX_DIMENSIONS
];
521 index_type extent
[GFC_MAX_DIMENSIONS
];
522 index_type stride
[GFC_MAX_DIMENSIONS
];
526 xorshift1024star_state
* rs
= get_rand_state();
531 dim
= GFC_DESCRIPTOR_RANK (x
);
533 for (n
= 0; n
< dim
; n
++)
536 stride
[n
] = GFC_DESCRIPTOR_STRIDE(x
,n
);
537 extent
[n
] = GFC_DESCRIPTOR_EXTENT(x
,n
);
544 if (unlikely (!rs
->init
))
545 init_rand_state (rs
, false);
549 /* random_r8 (dest); */
550 uint64_t r
= xorshift1024star (rs
);
553 /* Advance to the next element. */
556 /* Advance to the next source element. */
558 while (count
[n
] == extent
[n
])
560 /* When we get to the end of a dimension, reset it and increment
561 the next dimension. */
563 /* We could precalculate these products, but this is a less
564 frequently used path so probably not worth it. */
565 dest
-= stride
[n
] * extent
[n
];
581 #ifdef HAVE_GFC_REAL_10
583 /* This function fills a REAL(10) array with values from the uniform
584 distribution with range [0,1). */
587 arandom_r10 (gfc_array_r10
*x
)
589 index_type count
[GFC_MAX_DIMENSIONS
];
590 index_type extent
[GFC_MAX_DIMENSIONS
];
591 index_type stride
[GFC_MAX_DIMENSIONS
];
595 xorshift1024star_state
* rs
= get_rand_state();
600 dim
= GFC_DESCRIPTOR_RANK (x
);
602 for (n
= 0; n
< dim
; n
++)
605 stride
[n
] = GFC_DESCRIPTOR_STRIDE(x
,n
);
606 extent
[n
] = GFC_DESCRIPTOR_EXTENT(x
,n
);
613 if (unlikely (!rs
->init
))
614 init_rand_state (rs
, false);
618 /* random_r10 (dest); */
619 uint64_t r
= xorshift1024star (rs
);
620 rnumber_10 (dest
, r
);
622 /* Advance to the next element. */
625 /* Advance to the next source element. */
627 while (count
[n
] == extent
[n
])
629 /* When we get to the end of a dimension, reset it and increment
630 the next dimension. */
632 /* We could precalculate these products, but this is a less
633 frequently used path so probably not worth it. */
634 dest
-= stride
[n
] * extent
[n
];
652 #ifdef HAVE_GFC_REAL_16
654 /* This function fills a REAL(16) array with values from the uniform
655 distribution with range [0,1). */
658 arandom_r16 (gfc_array_r16
*x
)
660 index_type count
[GFC_MAX_DIMENSIONS
];
661 index_type extent
[GFC_MAX_DIMENSIONS
];
662 index_type stride
[GFC_MAX_DIMENSIONS
];
666 xorshift1024star_state
* rs
= get_rand_state();
671 dim
= GFC_DESCRIPTOR_RANK (x
);
673 for (n
= 0; n
< dim
; n
++)
676 stride
[n
] = GFC_DESCRIPTOR_STRIDE(x
,n
);
677 extent
[n
] = GFC_DESCRIPTOR_EXTENT(x
,n
);
684 if (unlikely (!rs
->init
))
685 init_rand_state (rs
, false);
689 /* random_r16 (dest); */
690 uint64_t r1
= xorshift1024star (rs
);
691 uint64_t r2
= xorshift1024star (rs
);
692 rnumber_16 (dest
, r1
, r2
);
694 /* Advance to the next element. */
697 /* Advance to the next source element. */
699 while (count
[n
] == extent
[n
])
701 /* When we get to the end of a dimension, reset it and increment
702 the next dimension. */
704 /* We could precalculate these products, but this is a less
705 frequently used path so probably not worth it. */
706 dest
-= stride
[n
] * extent
[n
];
725 /* Number of elements in master_state array. */
726 #define SZU64 (sizeof (master_state) / sizeof (uint64_t))
729 /* Keys for scrambling the seed in order to avoid poor seeds. */
731 static const uint64_t xor_keys
[] = {
732 0xbd0c5b6e50c2df49ULL
, 0xd46061cd46e1df38ULL
, 0xbb4f4d4ed6103544ULL
,
733 0x114a583d0756ad39ULL
, 0x4b5ad8623d0aaab6ULL
, 0x3f2ed7afbe0c0f21ULL
,
734 0xdec83fd65f113445ULL
, 0x3824f8fbc4f10d24ULL
, 0x5d9025af05878911ULL
,
735 0x500bc46b540340e9ULL
, 0x8bd53298e0d00530ULL
, 0x57886e40a952e06aULL
,
736 0x926e76c88e31cdb6ULL
, 0xbd0724dac0a3a5f9ULL
, 0xc5c8981b858ab796ULL
,
737 0xbb12ab2694c2b32cULL
741 /* Since a XOR cipher is symmetric, we need only one routine, and we
742 can use it both for encryption and decryption. */
745 scramble_seed (uint64_t *dest
, const uint64_t *src
)
747 for (int i
= 0; i
< (int) SZU64
; i
++)
748 dest
[i
] = src
[i
] ^ xor_keys
[i
];
752 /* random_seed is used to seed the PRNG with either a default
753 set of seeds or user specified set of seeds. random_seed
754 must be called with no argument or exactly one argument. */
757 random_seed_i4 (GFC_INTEGER_4
*size
, gfc_array_i4
*put
, gfc_array_i4
*get
)
759 uint64_t seed
[SZU64
];
760 #define SZ (sizeof (master_state) / sizeof (GFC_INTEGER_4))
762 /* Check that we only have one argument present. */
763 if ((size
? 1 : 0) + (put
? 1 : 0) + (get
? 1 : 0) > 1)
764 runtime_error ("RANDOM_SEED should have at most one argument present.");
769 xorshift1024star_state
* rs
= get_rand_state();
771 /* Return the seed to GET data. */
774 /* If the rank of the array is not 1, abort. */
775 if (GFC_DESCRIPTOR_RANK (get
) != 1)
776 runtime_error ("Array rank of GET is not 1.");
778 /* If the array is too small, abort. */
779 if (GFC_DESCRIPTOR_EXTENT(get
,0) < (index_type
) SZ
+ 1)
780 runtime_error ("Array size of GET is too small.");
783 init_rand_state (rs
, false);
785 /* Unscramble the seed. */
786 scramble_seed (seed
, rs
->s
);
788 /* Then copy it back to the user variable. */
789 for (size_t i
= 0; i
< SZ
; i
++)
790 memcpy (&(get
->base_addr
[(SZ
- 1 - i
) * GFC_DESCRIPTOR_STRIDE(get
,0)]),
791 (unsigned char*) seed
+ i
* sizeof(GFC_UINTEGER_4
),
792 sizeof(GFC_UINTEGER_4
));
794 /* Finally copy the value of p after the seed. */
795 get
->base_addr
[SZ
* GFC_DESCRIPTOR_STRIDE(get
, 0)] = rs
->p
;
800 __gthread_mutex_lock (&random_lock
);
802 /* From the standard: "If no argument is present, the processor assigns
803 a processor-dependent value to the seed." */
804 if (size
== NULL
&& put
== NULL
&& get
== NULL
)
807 init_rand_state (rs
, true);
812 /* If the rank of the array is not 1, abort. */
813 if (GFC_DESCRIPTOR_RANK (put
) != 1)
814 runtime_error ("Array rank of PUT is not 1.");
816 /* If the array is too small, abort. */
817 if (GFC_DESCRIPTOR_EXTENT(put
,0) < (index_type
) SZ
+ 1)
818 runtime_error ("Array size of PUT is too small.");
820 /* We copy the seed given by the user. */
821 for (size_t i
= 0; i
< SZ
; i
++)
822 memcpy ((unsigned char*) seed
+ i
* sizeof(GFC_UINTEGER_4
),
823 &(put
->base_addr
[(SZ
- 1 - i
) * GFC_DESCRIPTOR_STRIDE(put
,0)]),
824 sizeof(GFC_UINTEGER_4
));
826 /* We put it after scrambling the bytes, to paper around users who
827 provide seeds with quality only in the lower or upper part. */
828 scramble_seed (master_state
, seed
);
831 init_rand_state (rs
, true);
833 rs
->p
= put
->base_addr
[SZ
* GFC_DESCRIPTOR_STRIDE(put
, 0)] & 15;
836 __gthread_mutex_unlock (&random_lock
);
840 iexport(random_seed_i4
);
844 random_seed_i8 (GFC_INTEGER_8
*size
, gfc_array_i8
*put
, gfc_array_i8
*get
)
846 uint64_t seed
[SZU64
];
848 /* Check that we only have one argument present. */
849 if ((size
? 1 : 0) + (put
? 1 : 0) + (get
? 1 : 0) > 1)
850 runtime_error ("RANDOM_SEED should have at most one argument present.");
852 #define SZ (sizeof (master_state) / sizeof (GFC_INTEGER_8))
856 xorshift1024star_state
* rs
= get_rand_state();
858 /* Return the seed to GET data. */
861 /* If the rank of the array is not 1, abort. */
862 if (GFC_DESCRIPTOR_RANK (get
) != 1)
863 runtime_error ("Array rank of GET is not 1.");
865 /* If the array is too small, abort. */
866 if (GFC_DESCRIPTOR_EXTENT(get
,0) < (index_type
) SZ
+ 1)
867 runtime_error ("Array size of GET is too small.");
870 init_rand_state (rs
, false);
872 /* Unscramble the seed. */
873 scramble_seed (seed
, rs
->s
);
875 /* This code now should do correct strides. */
876 for (size_t i
= 0; i
< SZ
; i
++)
877 memcpy (&(get
->base_addr
[i
* GFC_DESCRIPTOR_STRIDE(get
,0)]), &seed
[i
],
878 sizeof (GFC_UINTEGER_8
));
880 get
->base_addr
[SZ
* GFC_DESCRIPTOR_STRIDE(get
, 0)] = rs
->p
;
885 __gthread_mutex_lock (&random_lock
);
887 /* From the standard: "If no argument is present, the processor assigns
888 a processor-dependent value to the seed." */
889 if (size
== NULL
&& put
== NULL
&& get
== NULL
)
892 init_rand_state (rs
, true);
897 /* If the rank of the array is not 1, abort. */
898 if (GFC_DESCRIPTOR_RANK (put
) != 1)
899 runtime_error ("Array rank of PUT is not 1.");
901 /* If the array is too small, abort. */
902 if (GFC_DESCRIPTOR_EXTENT(put
,0) < (index_type
) SZ
+ 1)
903 runtime_error ("Array size of PUT is too small.");
905 /* This code now should do correct strides. */
906 for (size_t i
= 0; i
< SZ
; i
++)
907 memcpy (&seed
[i
], &(put
->base_addr
[i
* GFC_DESCRIPTOR_STRIDE(put
,0)]),
908 sizeof (GFC_UINTEGER_8
));
910 scramble_seed (master_state
, seed
);
913 init_rand_state (rs
, true);
914 rs
->p
= put
->base_addr
[SZ
* GFC_DESCRIPTOR_STRIDE(put
, 0)] & 15;
918 __gthread_mutex_unlock (&random_lock
);
921 iexport(random_seed_i8
);
924 #if !defined __GTHREAD_MUTEX_INIT || defined __GTHREADS
925 static void __attribute__((constructor
))
926 constructor_random (void)
928 #ifndef __GTHREAD_MUTEX_INIT
929 __GTHREAD_MUTEX_INIT_FUNCTION (&random_lock
);
931 if (__gthread_active_p ())
932 __gthread_key_create (&rand_state_key
, &free
);
937 static void __attribute__((destructor
))
938 destructor_random (void)
940 if (__gthread_active_p ())
941 __gthread_key_delete (rand_state_key
);