(def!method print-object ((state random-state) stream)
(if (and *print-readably* (not *read-eval*))
- (restart-case
- (error 'print-not-readable :object state)
- (print-unreadably ()
- :report "Print unreadably."
- (write state :stream stream :readably nil))
- (use-value (object)
- :report "Supply an object to be printed instead."
- :interactive read-unreadable-replacement
- (write object :stream stream)))
+ (print-not-readable-error state stream)
(format stream "#S(~S ~S #.~S)"
'random-state
':state
(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).
- See SB-EXT:SEED-RANDOM-STATE for a SBCL extension to this functionality."
+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.
+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
+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 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 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.
+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 also accepts an argument of the following type:
- - (SIMPLE-ARRAY (UNSIGNED-BYTE 32) (*))
+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
+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
"
(etypecase state
;; Easy standard cases
;; Standard case, less easy: try to randomly initialize a state.
((eql t)
(/show0 "getting randomness from the operating system")
- (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.
- ;; 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.
#!-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)))
\f
;;; 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
(* 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)))
(* 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))
(* 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))
1d0))))
\f
-;;;; 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))
#!+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
projects / sbcl.git / blobdiff