~ chicken-core (chicken-5) 4f9ff45ea7f17878dbb01cbd4f9760f2148547ce
commit 4f9ff45ea7f17878dbb01cbd4f9760f2148547ce
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Nov 3 13:58:54 2017 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Nov 3 13:58:54 2017 +0100
initial attempt at new random numbers API
diff --git a/chicken.h b/chicken.h
index 400c80e2..357928b9 100644
--- a/chicken.h
+++ b/chicken.h
@@ -735,6 +735,8 @@ void *alloca ();
# define C_MAX_PATH 1024
#endif
+#define C_RANDOM_STATE_SIZE (16 * sizeof(C_u32))
+
/* Types: */
typedef struct C_block_struct
@@ -1232,8 +1234,7 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
C_unfix(end1) - C_unfix(start1) ), C_SCHEME_UNDEFINED)
#define C_words(n) C_fix(C_bytestowords(C_unfix(n)))
#define C_bytes(n) C_fix(C_wordstobytes(C_unfix(n)))
-#define C_random_fixnum(n) C_fix((C_word)(((double)rand())/(RAND_MAX + 1.0) * C_unfix(n)))
-#define C_randomize(n) (srand(C_unfix(n)), C_SCHEME_UNDEFINED)
+#define C_rand(n) C_fix((C_word)(((double)rand())/(RAND_MAX + 1.0) * C_unfix(n)))
#define C_block_size(x) C_fix(C_header_size(x))
#define C_u_i_bignum_size(b) C_fix(C_bignum_size(b))
#define C_a_u_i_big_to_flo(p, n, b) C_flonum(p, C_bignum_to_double(b))
@@ -2092,6 +2093,11 @@ C_fctexport C_word C_fcall C_i_foreign_unsigned_ranged_integer_argumentp(C_word
C_fctexport C_char *C_lookup_procedure_id(void *ptr);
C_fctexport void *C_lookup_procedure_ptr(C_char *id);
+C_fctexport C_word C_random_fixnum(C_word n) C_regparm;
+C_fctexport C_word C_fcall C_s_a_u_i_random_int(C_word **ptr, C_word n, C_word rn) C_regparm;
+C_fctexport C_word C_random_bytes(C_word buf, C_word size);
+C_fctexport C_word C_set_random_seed(C_word buf, C_word n);
+
#ifdef C_SIXTY_FOUR
C_fctexport C_cpsproc(C_peek_signed_integer_32);
C_fctexport C_cpsproc(C_peek_unsigned_integer_32);
diff --git a/extras.scm b/extras.scm
index 5c998600..63f49ed6 100644
--- a/extras.scm
+++ b/extras.scm
@@ -644,19 +644,64 @@
;;; Random numbers:
(module chicken.random
- (randomize random)
-
-(import scheme chicken chicken.time)
-
-(define (randomize . n)
- (let ((nn (if (null? n)
- (quotient (current-seconds) 1000) ; wall clock time
- (car n))))
- (##sys#check-fixnum nn 'randomize)
- (##core#inline "C_randomize" nn)))
-
-(define (random n)
- (##sys#check-fixnum n 'random)
- (if (eq? n 0)
- 0
- (##core#inline "C_random_fixnum" n))))
+ (set-pseudo-random-seed! pseudo-random-integer random-bytes)
+
+(import scheme chicken chicken.time chicken.io foreign)
+
+(define (set-pseudo-random-seed! buf #!optional n)
+ (if n
+ (##sys#check-fixnum n 'set-pseudo-random-seed!)
+ (set! n (##sys#size buf)))
+ (unless (##core#inline "C_byteblockp" buf)
+ (##sys#error 'set-pseudo-random-seed!
+ "invalid buffer type" buf))
+ (##core#inline "C_set_random_seed" buf
+ (##core#inline "C_i_fixnum_min"
+ n
+ (##sys#size buf))))
+
+(define (pseudo-random-integer n)
+ (define (badrange)
+ (##sys#error 'pseudo-random-integer "invalid range" n))
+ (cond ((##core#inline "C_fixnump" n)
+ (if (##core#inline "C_fixnum_lessp" n 0)
+ (badrange)
+ (##core#inline "C_random_fixnum" n)))
+ ((not (##core#inline "C_i_bignump" n))
+ (##sys#error 'pseudo-random-integer "bad argument type" n))
+ (else
+ (if (##core#inline "C_i_lessp" n 0)
+ (badrange)
+ (##core#inline_allocate ("C_s_a_u_i_random_int" 2)
+ n)))))
+
+(define random-bytes
+ (let ((in #f)
+ (nstate (foreign-value "C_RANDOM_STATE_SIZE" unsigned-int)))
+ (lambda (#!optional buf size)
+ (when size
+ (##sys#check-fixnum size 'random-bytes)
+ (when (or (< size 0)
+ (> size 256))
+ (##sys#error 'random-bytes "size out of range" size)))
+ (let* ((dest (cond (buf
+ (unless (##core#inline "C_byteblockp" buf)
+ (##sys#error 'random-bytes
+ "invalid buffer type" buf))
+ buf)
+ (else (make-string (or size nstate)))))
+ (r (##core#inline "C_random_bytes" dest
+ (or size (##sys#size dest)))))
+ (cond ((eq? -1 r)
+ (##sys#error 'random-bytes "error while obtaining random bytes"))
+ ((not r) ; no syscall or API function, read from /dev/urandom...
+ (unless in
+ (if (file-exists? "/dev/urandom")
+ (set! in (open-input-file "/dev/urandom" #:binary))
+ (##sys#error 'random-bytes "no entropy source available")))
+ (read-string! nstate dest in)
+ (unless (eq? buf dest)
+ (##core#inline "C_string_to_bytevector" dest))))
+ dest))))
+
+)
diff --git a/runtime.c b/runtime.c
index 9423993a..60803e01 100644
--- a/runtime.c
+++ b/runtime.c
@@ -479,6 +479,8 @@ static C_TLS int
pending_interrupts[ MAX_PENDING_INTERRUPTS ],
pending_interrupts_count,
handling_interrupts;
+static C_TLS C_u32 random_state[ C_RANDOM_STATE_SIZE / sizeof(C_u32) ];
+static C_TLS int random_state_index = 0;
/* Prototypes: */
@@ -816,7 +818,11 @@ int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel)
current_module_handle = NULL;
callback_continuation_level = 0;
gc_ms = 0;
- (void)C_randomize(C_fix(time(NULL)));
+ srand(C_fix(time(NULL)));
+
+ for(i = 0; i < C_RANDOM_STATE_SIZE / sizeof(C_u32); ++i)
+ random_state[ i ] = rand();
+
initialize_symbol_table();
if (profiling) {
@@ -12516,3 +12522,112 @@ C_i_pending_interrupt(C_word dummy)
return C_SCHEME_FALSE;
}
}
+
+
+/* random numbers, mostly lifted from
+ https://github.com/jedisct1/libsodium/blob/master/src/libsodium/randombytes/sysrandom/randombytes_sysrandom.c
+*/
+
+#ifdef __linux__
+# include <sys/syscall.h>
+#elif defined(__OpenBSD__)
+# include <sys/systm.h>
+#endif
+
+#ifdef _WIN32
+# define RtlGenRandom SystemFunction036
+# if defined(__cplusplus)
+extern "C"
+# endif
+BOOLEAN WINAPI RtlGenRandom(PVOID RandomBuffer, ULONG RandomBufferLength);
+#endif
+
+
+C_word C_random_bytes(C_word buf, C_word size)
+{
+ int count = C_unfix(size);
+ int r = 0;
+
+#ifdef __OpenBSD__
+ arc4random_buf(C_data_pointer(buf), count);
+#elif defined(SYS_getrandom) && defined(__NR_getrandom)
+ do {
+ r = getrandom(C_data_pointer(buf), count, 0);
+ } while(r < 0 && (errno == EINTR));
+#elif defined(_WIN32)
+ if(!RtlGenRandom((PVOID)C_data_pointer(buf), (LONG)count))
+ r = -1;
+#else
+ return C_SCHEME_FALSE;
+#endif
+ return C_fix(r);
+}
+
+
+/* WELL512 pseudo random number generator, see also:
+ https://en.wikipedia.org/wiki/Well_equidistributed_long-period_linear
+ http://lomont.org/Math/Papers/2008/Lomont_PRNG_2008.pdf
+*/
+
+static C_u32 random_word(void)
+{
+ C_u32 a, b, c, d, r;
+ a = random_state[random_state_index];
+ c = random_state[(random_state_index+13)&15];
+ b = a^c^(a<<16)^(c<<15);
+ c = random_state[(random_state_index+9)&15];
+ c ^= (c>>11);
+ a = random_state[random_state_index] = b^c;
+ d = a^((a<<5)&0xDA442D24UL);
+ random_state_index = (random_state_index + 15)&15;
+ a = random_state[random_state_index];
+ random_state[random_state_index] = a^b^d^(a<<2)^(b<<18)^(c<<28);
+ r = random_state[random_state_index];
+ return r;
+}
+
+
+C_regparm C_word C_random_fixnum(C_word n)
+{
+ C_u32 r = random_word();
+ return C_fix(((double)r / 0xffffffffUL) * C_unfix(n));
+}
+
+
+C_regparm C_word C_fcall
+C_s_a_u_i_random_int(C_word **ptr, C_word n, C_word rn)
+{
+ C_uword *start, *end;
+ int len = integer_length_abs(rn);
+ C_word size = C_fix(C_BIGNUM_BITS_TO_DIGITS(len));
+ C_word result = C_allocate_scratch_bignum(ptr, size, C_SCHEME_FALSE, C_SCHEME_FALSE);
+ C_u32 *p, mask;
+
+ start = C_bignum_digits(result);
+ end = start + C_bignum_size(result);
+
+ for(p = (C_u32 *)start; p < ((C_u32*)end - 1); ++p) {
+ *p = random_word();
+ len -= sizeof(C_u32);
+ }
+
+ *end = random_word() >> len;
+ return C_bignum_simplify(result);
+}
+
+
+C_word C_set_random_seed(C_word buf, C_word n)
+{
+ int i, nsu = C_unfix(n) / sizeof(C_u32);
+ int off = 0;
+
+ for(i = 0; i < C_RANDOM_STATE_SIZE; ++i) {
+ if(off >= nsu) off = 0;
+
+ random_state[ i ] = *((C_u32 *)C_data_pointer(buf) + off);
+ ++off;
+ }
+
+ random_state_index = 0;
+ return C_SCHEME_FALSE;
+}
Trap