X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-random.lisp;h=b4cb2780c4fc3208422d99e45618b475b1070e07;hb=d720bc359f03734ccb9baf66cb45dc01d623f369;hp=5ecbd141dbe817144789cc6bdf003f917c595c7d;hpb=c1a334ce597cc041447fe92f2e9adf2a5e295483;p=sbcl.git diff --git a/src/code/target-random.lisp b/src/code/target-random.lisp index 5ecbd14..b4cb278 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 @@ -95,8 +95,26 @@ provided randomness source 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: + 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 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 or is NIL, 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) + + 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 @@ -110,7 +128,6 @@ 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,7 +139,7 @@ ;; Standard case, less easy: try to randomly initialize a state. ((eql t) (/show0 "getting randomness from the operating system") - (make-random-state + (seed-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. @@ -165,7 +182,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 +196,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 +292,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 +309,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 +332,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 +347,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 +355,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 +402,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