\f
;;;; RANDOM-STATEs
-(def!method make-load-form ((random-state random-state) &optional environment)
+(def!method make-load-form ((random-state random-state) &optional environment)
(make-load-form-saving-slots random-state :environment environment))
+(def!method print-object ((state random-state) stream)
+ (if (and *print-readably* (not *read-eval*))
+ (error 'print-not-readable :object state)
+ (format stream "#S(~S ~S #.~S)"
+ 'random-state
+ ':state
+ `(make-array 627
+ :element-type
+ '(unsigned-byte 32)
+ :initial-contents
+ ',(coerce (random-state-state state) 'list)))))
+
;;; The state is stored in a (simple-array (unsigned-byte 32) (627))
;;; wrapped in a random-state structure:
;;;
(setf (aref state 2) 1)
(setf (aref state 3) seed)
(do ((k 1 (1+ k)))
- ((>= k 624))
+ ((>= k 624))
(declare (type (mod 625) k))
(setf (aref state (+ 3 k))
- (logand (* 69069 (aref state (+ 3 (1- k)))) #xffffffff)))
+ (logand (* 69069 (aref state (+ 3 (1- k)))) #xffffffff)))
state))
(defvar *random-state*)
of the default random state. If STATE is a random state, then return a
copy of it. If STATE is T then return a random state generated from
the universal time."
+ (/show0 "entering MAKE-RANDOM-STATE")
(flet ((copy-random-state (state)
- (let ((state (random-state-state state))
- (new-state
- (make-array 627 :element-type '(unsigned-byte 32))))
- (dotimes (i 627)
- (setf (aref new-state i) (aref state i)))
- (%make-random-state :state new-state))))
- (cond ((not state) (copy-random-state *random-state*))
- ((random-state-p state) (copy-random-state state))
- ((eq state t)
- (%make-random-state :state (init-random-state
- (logand (get-universal-time)
- #xffffffff))))
- ;; FIXME: should be TYPE-ERROR?
- (t (error "Argument is not a RANDOM-STATE, T or NIL: ~S" state)))))
+ (/show0 "entering COPY-RANDOM-STATE")
+ (let ((state (random-state-state state))
+ (new-state
+ (make-array 627 :element-type '(unsigned-byte 32))))
+ (/show0 "made NEW-STATE, about to DOTIMES")
+ (dotimes (i 627)
+ (setf (aref new-state i) (aref state i)))
+ (/show0 "falling through to %MAKE-RANDOM-STATE")
+ (%make-random-state :state new-state))))
+ (/show0 "at head of ETYPECASE in MAKE-RANDOM-STATE")
+ (etypecase state
+ (null
+ (/show0 "NULL case")
+ (copy-random-state *random-state*))
+ (random-state
+ (/show0 "RANDOM-STATE-P clause")
+ (copy-random-state state))
+ ((member t)
+ (/show0 "T clause")
+ (%make-random-state :state (init-random-state
+ (logand (get-universal-time)
+ #xffffffff)))))))
\f
;;;; random entries
#!-x86
(defun random-mt19937-update (state)
(declare (type (simple-array (unsigned-byte 32) (627)) state)
- (optimize (speed 3) (safety 0)))
+ (optimize (speed 3) (safety 0)))
(let ((y 0))
(declare (type (unsigned-byte 32) y))
(do ((kk 3 (1+ kk)))
- ((>= kk (+ 3 (- mt19937-n mt19937-m))))
+ ((>= kk (+ 3 (- mt19937-n mt19937-m))))
(declare (type (mod 628) kk))
(setf y (logior (logand (aref state kk) mt19937-upper-mask)
- (logand (aref state (1+ kk)) mt19937-lower-mask)))
+ (logand (aref state (1+ kk)) mt19937-lower-mask)))
(setf (aref state kk) (logxor (aref state (+ kk mt19937-m))
- (ash y -1) (aref state (logand y 1)))))
+ (ash y -1) (aref state (logand y 1)))))
(do ((kk (+ (- mt19937-n mt19937-m) 3) (1+ kk)))
- ((>= kk (+ (1- mt19937-n) 3)))
+ ((>= kk (+ (1- mt19937-n) 3)))
(declare (type (mod 628) kk))
(setf y (logior (logand (aref state kk) mt19937-upper-mask)
- (logand (aref state (1+ kk)) mt19937-lower-mask)))
+ (logand (aref state (1+ kk)) mt19937-lower-mask)))
(setf (aref state kk) (logxor (aref state (+ kk (- mt19937-m mt19937-n)))
- (ash y -1) (aref state (logand y 1)))))
+ (ash y -1) (aref state (logand y 1)))))
(setf y (logior (logand (aref state (+ 3 (1- mt19937-n)))
- mt19937-upper-mask)
- (logand (aref state 3) mt19937-lower-mask)))
+ mt19937-upper-mask)
+ (logand (aref state 3) mt19937-lower-mask)))
(setf (aref state (+ 3 (1- mt19937-n)))
- (logxor (aref state (+ 3 (1- mt19937-m)))
- (ash y -1) (aref state (logand y 1)))))
+ (logxor (aref state (+ 3 (1- mt19937-m)))
+ (ash y -1) (aref state (logand y 1)))))
(values))
#!-x86
(defun random-chunk (state)
(declare (type random-state state))
(let* ((state (random-state-state state))
- (k (aref state 2)))
+ (k (aref state 2)))
(declare (type (mod 628) k))
(when (= k mt19937-n)
(random-mt19937-update state)
(defun random-chunk (state)
(declare (type random-state state))
(sb!vm::random-mt19937 (random-state-state state)))
+
+#!-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))))
\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
;;; we have a hidden bit.
#!-sb-fluid (declaim (inline %random-single-float %random-double-float))
(declaim (ftype (function ((single-float (0f0)) random-state)
- (single-float 0f0))
- %random-single-float))
+ (single-float 0f0))
+ %random-single-float))
(defun %random-single-float (arg state)
(declare (type (single-float (0f0)) arg)
- (type random-state state))
+ (type random-state state))
(* arg
(- (make-single-float
- (dpb (ash (random-chunk state)
- (- sb!vm:single-float-digits random-chunk-length))
- sb!vm:single-float-significand-byte
- (single-float-bits 1.0)))
- 1.0)))
+ (dpb (ash (random-chunk state)
+ (- sb!vm:single-float-digits random-chunk-length))
+ sb!vm:single-float-significand-byte
+ (single-float-bits 1.0)))
+ 1.0)))
(declaim (ftype (function ((double-float (0d0)) random-state)
- (double-float 0d0))
- %random-double-float))
+ (double-float 0d0))
+ %random-double-float))
;;; 32-bit version
#!+nil
(defun %random-double-float (arg state)
(declare (type (double-float (0d0)) arg)
- (type random-state state))
+ (type random-state state))
(* (float (random-chunk state) 1d0) (/ 1d0 (expt 2 32))))
;;; 53-bit version
#!-x86
(defun %random-double-float (arg state)
(declare (type (double-float (0d0)) arg)
- (type random-state state))
+ (type random-state state))
(* arg
(- (sb!impl::make-double-float
- (dpb (ash (random-chunk state)
- (- sb!vm:double-float-digits random-chunk-length
- sb!vm:word-bits))
- sb!vm:double-float-significand-byte
- (sb!impl::double-float-high-bits 1d0))
- (random-chunk state))
- 1d0)))
+ (dpb (ash (random-chunk state)
+ (- sb!vm:double-float-digits random-chunk-length 32))
+ sb!vm:double-float-significand-byte
+ (sb!impl::double-float-high-bits 1d0))
+ (random-chunk state))
+ 1d0)))
;;; using a faster inline VOP
#!+x86
(defun %random-double-float (arg state)
(declare (type (double-float (0d0)) arg)
- (type random-state state))
+ (type random-state state))
(let ((state-vector (random-state-state 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:word-bits))
- sb!vm:double-float-significand-byte
- (sb!impl::double-float-high-bits 1d0))
- (sb!vm::random-mt19937 state-vector))
- 1d0))))
+ (dpb (ash (sb!vm::random-mt19937 state-vector)
+ (- sb!vm:double-float-digits random-chunk-length
+ sb!vm:n-word-bits))
+ sb!vm:double-float-significand-byte
+ (sb!impl::double-float-high-bits 1d0))
+ (sb!vm::random-mt19937 state-vector))
+ 1d0))))
-#!+long-float
-(declaim #!-sb-fluid (inline %random-long-float))
-#!+long-float
-(declaim (ftype (function ((long-float (0l0)) random-state) (long-float 0l0))
- %random-long-float))
-
-;;; using a faster inline VOP
-#!+(and long-float x86)
-(defun %random-long-float (arg state)
- (declare (type (long-float (0l0)) arg)
- (type random-state state))
- (let ((state-vector (random-state-state state)))
- (* arg
- (- (sb!impl::make-long-float
- (sb!impl::long-float-exp-bits 1l0)
- (logior (sb!vm::random-mt19937 state-vector)
- sb!vm:long-float-hidden-bit)
- (sb!vm::random-mt19937 state-vector))
- 1l0))))
-
-#!+(and long-float sparc)
-(defun %random-long-float (arg state)
- (declare (type (long-float (0l0)) arg)
- (type random-state state))
- (* arg
- (- (sb!impl::make-long-float
- (sb!impl::long-float-exp-bits 1l0) ; X needs more work
- (random-chunk state) (random-chunk state) (random-chunk state))
- 1l0)))
\f
;;;; random integers
(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))
+ (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)))))
(defun random (arg &optional (state *random-state*))
(declare (inline %random-single-float %random-double-float
- #!+long-float %long-float))
+ #!+long-float %random-long-float))
(cond
((and (fixnump arg) (<= arg random-fixnum-max) (> arg 0))
(rem (random-chunk state) arg))
- ((and (typep arg 'single-float) (> arg 0.0S0))
+ ((and (typep arg 'single-float) (> arg 0.0f0))
(%random-single-float arg state))
- ((and (typep arg 'double-float) (> arg 0.0D0))
+ ((and (typep arg 'double-float) (> arg 0.0d0))
(%random-double-float arg state))
#!+long-float
- ((and (typep arg 'long-float) (> arg 0.0L0))
+ ((and (typep arg 'long-float) (> arg 0.0l0))
(%random-long-float arg state))
((and (integerp arg) (> arg 0))
(%random-integer arg state))
(t
(error 'simple-type-error
- :expected-type '(or (integer 1) (float (0))) :datum arg
- :format-control "~@<Argument is neither a positive integer nor a ~
+ :expected-type '(or (integer 1) (float (0))) :datum arg
+ :format-control "~@<Argument is neither a positive integer nor a ~
positive float: ~2I~_~S~:>"
- :format-arguments (list arg)))))
+ :format-arguments (list arg)))))
projects / sbcl.git / blobdiff