X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-random.lisp;h=f0b740fd3afb4e501ec1058ce011d286d11ff042;hb=c07dbfb642a88f20a1dd0d163308ba4a28b67ef3;hp=e82f7a0137ba18afcce0103fa205f2f92ecb453f;hpb=95a6db7329b91dd90d165dd4057b9b5098d34aa2;p=sbcl.git

diff --git a/src/code/target-random.lisp b/src/code/target-random.lisp
index e82f7a0..f0b740f 100644
--- a/src/code/target-random.lisp
+++ b/src/code/target-random.lisp
@@ -18,9 +18,21 @@
 
 ;;;; 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:
 ;;;
@@ -43,10 +55,10 @@
     (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*)
@@ -61,21 +73,30 @@
   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)))))))
 
 ;;;; random entries
 
@@ -92,35 +113,35 @@
 #!-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)
@@ -143,6 +164,13 @@
 (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))))
 
 ;;; 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
@@ -150,89 +178,59 @@
 ;;; 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))))
-
-#!+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))))
+           (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))))
 
-#!+(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)))
 
 ;;;; random integers
 
@@ -240,34 +238,32 @@
   (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*))
-  #!+sb-doc
-  "Generate a uniformly distributed pseudo-random number between zero
-  and Arg. State, if supplied, is the random state to use."
   (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) #!+high-security (> arg 0))
+    ((and (fixnump arg) (<= arg random-fixnum-max) (> arg 0))
      (rem (random-chunk state) arg))
-    ((and (typep arg 'single-float) #!+high-security (> arg 0.0S0))
+    ((and (typep arg 'single-float) (> arg 0.0f0))
      (%random-single-float arg state))
-    ((and (typep arg 'double-float) #!+high-security (> arg 0.0D0))
+    ((and (typep arg 'double-float) (> arg 0.0d0))
      (%random-double-float arg state))
     #!+long-float
-    ((and (typep arg 'long-float) #!+high-security (> arg 0.0L0))
+    ((and (typep arg 'long-float) (> arg 0.0l0))
      (%random-long-float arg state))
-    ((and (integerp arg) #!+high-security (> arg 0))
+    ((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 not a positive integer or a positive float: ~S"
-	    :format-arguments (list arg)))))
+            :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)))))