X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-random.lisp;h=f886832ca57591472fc8e2ddfbce1be94c6f5f66;hb=54da325f13fb41669869aea688ae195426c0e231;hp=5ecbd141dbe817144789cc6bdf003f917c595c7d;hpb=c1a334ce597cc041447fe92f2e9adf2a5e295483;p=sbcl.git diff --git a/src/code/target-random.lisp b/src/code/target-random.lisp index 5ecbd14..f886832 100644 --- a/src/code/target-random.lisp +++ b/src/code/target-random.lisp @@ -42,11 +42,11 @@ (def!method print-object ((state random-state) stream) (if (and *print-readably* (not *read-eval*)) - (error 'print-not-readable :object state) + (print-not-readable-error state stream) (format stream "#S(~S ~S #.~S)" 'random-state ':state - `(make-array (,(+ 3 mt19937-n)) + `(make-array ,(+ 3 mt19937-n) :element-type '(unsigned-byte 32) :initial-contents @@ -85,32 +85,78 @@ (defun make-random-state (&optional state) #!+sb-doc "Make a random state object. The optional STATE argument specifies a seed - for deterministic pseudo-random number generation. +for deterministic pseudo-random number generation. - As per the Common Lisp standard, - - If STATE is NIL or not supplied or is NIL, return a copy of the default +As per the Common Lisp standard, +- If STATE is NIL or not supplied, return a copy of the default *RANDOM-STATE*. - - If STATE is a random state, return a copy of it. - - If STATE is T, return a randomly initialized state (using operating-system - provided randomness source where available, otherwise a poor substitute - based on internal time and pid) +- If STATE is a random state, return a copy of it. +- If STATE is T, return a randomly initialized state (using operating-system + provided randomness where available, otherwise a poor substitute based on + internal time and PID). - As an SBCL extension (starting with SBCL 1.0.33), we also support receiving - as a seed an object of the following types: - - (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)) - - UNSIGNED-BYTE - While we support arguments of any size and will mix the provided bits into - the random state, it is probably overkill to provide more than 256 bits worth - of actual information. +See SB-EXT:SEED-RANDOM-STATE for a SBCL extension to this functionality." + (/show0 "entering MAKE-RANDOM-STATE") + (check-type state (or boolean random-state)) + (seed-random-state state)) + +(defun fallback-random-seed () + ;; When /dev/urandom is not available, we make do with time and pid + ;; Thread ID and/or address of a CONS cell would be even better, but... + (/show0 "No /dev/urandom, using randomness from time and pid") + (+ (get-internal-real-time) + (ash (sb!unix:unix-getpid) 32))) + +#!-win32 +(defun os-random-seed () + (or + ;; On unices, we try to read from /dev/urandom and pass the results + ;; to our (simple-array (unsigned-byte 32) (*)) processor below. + ;; More than 256 bits would provide a false sense of security. + ;; If you need more bits than that, you probably also need + ;; a better algorithm too. + (ignore-errors + (with-open-file (r "/dev/urandom" :element-type '(unsigned-byte 32) + :direction :input :if-does-not-exist :error) + (let ((a (make-array '(8) :element-type '(unsigned-byte 32)))) + (assert (= 8 (read-sequence a r))) + a))) + (fallback-random-seed))) + +#!+win32 +(defun os-random-seed () + (/show0 "Getting randomness from CryptGenRandom") + (or (sb!win32:crypt-gen-random 32) + (fallback-random-seed))) + +(defun seed-random-state (&optional state) + #!+sb-doc + "Make a random state object. The optional STATE argument specifies a seed +for deterministic pseudo-random number generation. + +As per the Common Lisp standard for MAKE-RANDOM-STATE, +- If STATE is NIL or not supplied, return a copy of the default + *RANDOM-STATE*. +- If STATE is a random state, return a copy of it. +- If STATE is T, return a randomly initialized state (using operating-system + provided randomness where available, otherwise a poor substitute based on + internal time and pid). - This particular SBCL version also accepts an argument of the following type: - - (SIMPLE-ARRAY (UNSIGNED-BYTE 32) (*)) +As a supported SBCL extension, we also support receiving as a seed an object +of the following types: +- (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)) +- UNSIGNED-BYTE +While we support arguments of any size and will mix the provided bits into +the random state, it is probably overkill to provide more than 256 bits worth +of actual information. - This particular SBCL version uses the popular MT19937 PRNG algorithm, and its - internal state only effectively contains about 19937 bits of information. - http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html +This particular SBCL version also accepts an argument of the following type: +(SIMPLE-ARRAY (UNSIGNED-BYTE 32) (*)) + +This particular SBCL version uses the popular MT19937 PRNG algorithm, and its +internal state only effectively contains about 19937 bits of information. +http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html " - (/show0 "entering MAKE-RANDOM-STATE") (etypecase state ;; Easy standard cases (null @@ -122,26 +168,7 @@ ;; Standard case, less easy: try to randomly initialize a state. ((eql t) (/show0 "getting randomness from the operating system") - (make-random-state - (or - ;; On unices, we try to read from /dev/urandom and pass the results - ;; to our (simple-array (unsigned-byte 32) (*)) processor below. - ;; More than 256 bits would provide a false sense of security. - ;; If you need more bits than that, you probably also need - ;; a better algorithm too. - #!-win32 - (ignore-errors - (with-open-file (r "/dev/urandom" :element-type '(unsigned-byte 32) - :direction :input :if-does-not-exist :error) - (let ((a (make-array '(8) :element-type '(unsigned-byte 32)))) - (assert (= 8 (read-sequence a r))) - a))) - ;; When /dev/urandom is not available, we make do with time and pid - ;; Thread ID and/or address of a CONS cell would be even better, but... - (progn - (/show0 "No /dev/urandom, using randomness from time and pid") - (+ (get-internal-real-time) - #!+unix (ash (sb!unix:unix-getpid) 32)))))) + (seed-random-state (os-random-seed))) ;; For convenience to users, we accept (simple-array (unsigned-byte 8) (*)) ;; We just convert it to (simple-array (unsigned-byte 32) (*)) in a ;; completely straightforward way. @@ -165,7 +192,7 @@ (+ (aref state q) (if (< 1 r) (ash (aref state (+ q 1)) 8) 0) (if (= 3 r) (ash (aref state (+ q 2)) 16) 0))))) - (make-random-state y))) + (seed-random-state y))) ;; Also for convenience, we accept non-negative integers as seeds. ;; Small ones get passed to init-random-state, as before. ((unsigned-byte 32) @@ -179,7 +206,7 @@ for i below l for p from 0 by 32 do (setf (aref s i) (ldb (byte 32 p) state)) - finally (return (make-random-state s)))) + finally (return (seed-random-state s)))) ;; Last but not least, when provided an array of 32-bit words, we truncate ;; it to 19968 bits and mix these into an initial state. We reuse the same ;; method as the authors of the original algorithm. See @@ -275,9 +302,8 @@ #!-sb-fluid (declaim (inline big-random-chunk)) (defun big-random-chunk (state) (declare (type random-state state)) - (logand (1- (expt 2 64)) - (logior (ash (random-chunk state) 32) - (random-chunk state)))) + (logior (ash (random-chunk state) 32) + (random-chunk state))) ;;; Handle the single or double float case of RANDOM. We generate a ;;; float between 0.0 and 1.0 by clobbering the significand of 1.0 @@ -293,7 +319,7 @@ (* arg (- (make-single-float (dpb (ash (random-chunk state) - (- sb!vm:single-float-digits random-chunk-length)) + (- sb!vm:single-float-digits n-random-chunk-bits)) sb!vm:single-float-significand-byte (single-float-bits 1.0))) 1.0))) @@ -316,7 +342,7 @@ (* arg (- (sb!impl::make-double-float (dpb (ash (random-chunk state) - (- sb!vm:double-float-digits random-chunk-length 32)) + (- sb!vm:double-float-digits n-random-chunk-bits 32)) sb!vm:double-float-significand-byte (sb!impl::double-float-high-bits 1d0)) (random-chunk state)) @@ -331,7 +357,7 @@ (* arg (- (sb!impl::make-double-float (dpb (ash (sb!vm::random-mt19937 state-vector) - (- sb!vm:double-float-digits random-chunk-length + (- sb!vm:double-float-digits n-random-chunk-bits sb!vm:n-word-bits)) sb!vm:double-float-significand-byte (sb!impl::double-float-high-bits 1d0)) @@ -339,26 +365,46 @@ 1d0)))) -;;;; random integers +;;;; random fixnums -(defun %random-integer (arg state) - (declare (type (integer 1) arg) (type random-state state)) - (let ((shift (- random-chunk-length random-integer-overlap))) - (do ((bits (random-chunk state) - (logxor (ash bits shift) (random-chunk state))) - (count (+ (integer-length arg) - (- random-integer-extra-bits shift)) - (- count shift))) - ((minusp count) - (rem bits arg)) - (declare (fixnum count))))) +;;; Generate and return a pseudo random fixnum less than ARG. To achieve +;;; equidistribution an accept-reject loop is used. +;;; No extra effort is made to detect the case of ARG being a power of +;;; two where rejection is not possible, as the cost of checking for +;;; this case is the same as doing the rejection test. When ARG is +;;; larger than (expt 2 N-RANDOM-CHUNK-BITS), which can only happen if +;;; the random chunk size is half the word size, two random chunks are +;;; used in each loop iteration, otherwise only one. Finally, the +;;; rejection probability could often be reduced by not masking the +;;; chunk but rejecting only values as least as large as the largest +;;; multiple of ARG that fits in a chunk (or two), but this is not done +;;; as the speed gains due to needing fewer loop iterations are by far +;;; outweighted by the cost of the two divisions required (one to find +;;; the multiplier and one to bring the result into the correct range). +#!-sb-fluid (declaim (inline %random-fixnum)) +(defun %random-fixnum (arg state) + (declare (type (integer 1 #.sb!xc:most-positive-fixnum) arg) + (type random-state state)) + (if (= arg 1) + 0 + (let* ((n-bits (integer-length (1- arg))) + (mask (1- (ash 1 n-bits)))) + (macrolet ((accept-reject-loop (generator) + `(loop + (let ((bits (logand mask (,generator state)))) + (when (< bits arg) + (return bits)))))) + (assert (<= n-bits (* 2 n-random-chunk-bits))) + (if (<= n-bits n-random-chunk-bits) + (accept-reject-loop random-chunk) + (accept-reject-loop big-random-chunk)))))) (defun random (arg &optional (state *random-state*)) - (declare (inline %random-single-float %random-double-float + (declare (inline %random-fixnum %random-single-float %random-double-float #!+long-float %random-long-float)) (cond - ((and (fixnump arg) (<= arg random-fixnum-max) (> arg 0)) - (rem (random-chunk state) arg)) + ((and (fixnump arg) (> arg 0)) + (%random-fixnum arg state)) ((and (typep arg 'single-float) (> arg 0.0f0)) (%random-single-float arg state)) ((and (typep arg 'double-float) (> arg 0.0d0)) @@ -366,8 +412,8 @@ #!+long-float ((and (typep arg 'long-float) (> arg 0.0l0)) (%random-long-float arg state)) - ((and (integerp arg) (> arg 0)) - (%random-integer arg state)) + ((and (bignump arg) (> arg 0)) + (%random-bignum arg state)) (t (error 'simple-type-error :expected-type '(or (integer 1) (float (0))) :datum arg