src/code/target-random.lisp

   1 ;;;; This implementation of RANDOM is based on the Mersenne Twister random
   2 ;;;; number generator "MT19937" due to Matsumoto and Nishimura. See:
   3 ;;;;   Makoto Matsumoto and T. Nishimura, "Mersenne twister: A
   4 ;;;;   623-dimensionally equidistributed uniform pseudorandom number
   5 ;;;;   generator.", ACM Transactions on Modeling and Computer Simulation,
   6 ;;;;   1997, to appear.
   7
   8 ;;;; This software is part of the SBCL system. See the README file for
   9 ;;;; more information.
  10 ;;;;
  11 ;;;; This software is derived from the CMU CL system, which was
  12 ;;;; written at Carnegie Mellon University and released into the
  13 ;;;; public domain. The software is in the public domain and is
  14 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  15 ;;;; files for more information.
  16
  17 (in-package "SB!KERNEL")
  18
  19 (file-comment
  20   "$Header$")
  21 \f
  22 ;;;; RANDOM-STATEs
  23
  24 (def!method make-load-form ((random-state random-state) &optional environment)
  25   (make-load-form-saving-slots random-state :environment environment))
  26
  27 ;;; The state is stored in a (simple-array (unsigned-byte 32) (627))
  28 ;;; wrapped in a random-state structure:
  29 ;;;
  30 ;;;  0-1:   Constant matrix A. [0, #x9908b0df]
  31 ;;;  2:     Index k.
  32 ;;;  3-626: State.
  33
  34 ;;; Generate and initialize a new random-state array. Index is
  35 ;;; initialized to 1 and the states to 32bit integers excluding zero.
  36 ;;;
  37 ;;; Seed - A 32bit number, not zero.
  38 ;;;
  39 ;;; Apparently uses the generator Line 25 of Table 1 in
  40 ;;; [KNUTH 1981, The Art of Computer Programming, Vol. 2 (2nd Ed.), pp102]
  41 (defun init-random-state (&optional (seed 4357) state)
  42   (declare (type (integer 1 #xffffffff) seed))
  43   (let ((state (or state (make-array 627 :element-type '(unsigned-byte 32)))))
  44     (declare (type (simple-array (unsigned-byte 32) (627)) state))
  45     (setf (aref state 1) #x9908b0df)
  46     (setf (aref state 2) 1)
  47     (setf (aref state 3) seed)
  48     (do ((k 1 (1+ k)))
  49         ((>= k 624))
  50       (declare (type (mod 625) k))
  51       (setf (aref state (+ 3 k))
  52             (logand (* 69069 (aref state (+ 3 (1- k)))) #xffffffff)))
  53     state))
  54
  55 (defvar *random-state*)
  56 (defun !random-cold-init ()
  57   (setf *random-state* (%make-random-state)))
  58
  59 (defun make-random-state (&optional state)
  60   #!+sb-doc
  61   "Make a random state object. If State is not supplied, return a copy
  62   of the default random state. If State is a random state, then return a
  63   copy of it. If state is T then return a random state generated from
  64   the universal time."
  65   (flet ((copy-random-state (state)
  66            (let ((state (random-state-state state))
  67                  (new-state
  68                   (make-array 627 :element-type '(unsigned-byte 32))))
  69              (dotimes (i 627)
  70                (setf (aref new-state i) (aref state i)))
  71              (%make-random-state :state new-state))))
  72     (cond ((not state) (copy-random-state *random-state*))
  73           ((random-state-p state) (copy-random-state state))
  74           ((eq state t)
  75            (%make-random-state :state (init-random-state
  76                                        (logand (get-universal-time)
  77                                                #xffffffff))))
  78           ;; FIXME: should be TYPE-ERROR?
  79           (t (error "Argument is not a RANDOM-STATE, T or NIL: ~S" state)))))
  80 \f
  81 ;;;; random entries
  82
  83 ;;; This function generates a 32bit integer between 0 and #xffffffff
  84 ;;; inclusive.
  85 #!-sb-fluid (declaim (inline random-chunk))
  86 ;;; portable implementation
  87 (defconstant mt19937-n 624)
  88 (defconstant mt19937-m 397)
  89 (defconstant mt19937-upper-mask #x80000000)
  90 (defconstant mt19937-lower-mask #x7fffffff)
  91 (defconstant mt19937-b #x9D2C5680)
  92 (defconstant mt19937-c #xEFC60000)
  93 #!-x86
  94 (defun random-mt19937-update (state)
  95   (declare (type (simple-array (unsigned-byte 32) (627)) state)
  96            (optimize (speed 3) (safety 0)))
  97   (let ((y 0))
  98     (declare (type (unsigned-byte 32) y))
  99     (do ((kk 3 (1+ kk)))
 100         ((>= kk (+ 3 (- mt19937-n mt19937-m))))
 101       (declare (type (mod 628) kk))
 102       (setf y (logior (logand (aref state kk) mt19937-upper-mask)
 103                       (logand (aref state (1+ kk)) mt19937-lower-mask)))
 104       (setf (aref state kk) (logxor (aref state (+ kk mt19937-m))
 105                                     (ash y -1) (aref state (logand y 1)))))
 106     (do ((kk (+ (- mt19937-n mt19937-m) 3) (1+ kk)))
 107         ((>= kk (+ (1- mt19937-n) 3)))
 108       (declare (type (mod 628) kk))
 109       (setf y (logior (logand (aref state kk) mt19937-upper-mask)
 110                       (logand (aref state (1+ kk)) mt19937-lower-mask)))
 111       (setf (aref state kk) (logxor (aref state (+ kk (- mt19937-m mt19937-n)))
 112                                     (ash y -1) (aref state (logand y 1)))))
 113     (setf y (logior (logand (aref state (+ 3 (1- mt19937-n)))
 114                             mt19937-upper-mask)
 115                     (logand (aref state 3) mt19937-lower-mask)))
 116     (setf (aref state (+ 3 (1- mt19937-n)))
 117           (logxor (aref state (+ 3 (1- mt19937-m)))
 118                   (ash y -1) (aref state (logand y 1)))))
 119   (values))
 120 #!-x86
 121 (defun random-chunk (state)
 122   (declare (type random-state state))
 123   (let* ((state (random-state-state state))
 124          (k (aref state 2)))
 125     (declare (type (mod 628) k))
 126     (when (= k mt19937-n)
 127       (random-mt19937-update state)
 128       (setf k 0))
 129     (setf (aref state 2) (1+ k))
 130     (let ((y (aref state (+ 3 k))))
 131       (declare (type (unsigned-byte 32) y))
 132       (setf y (logxor y (ash y -11)))
 133       (setf y (logxor y (ash (logand y (ash mt19937-b -7)) 7)))
 134       (setf y (logxor y (ash (logand y (ash mt19937-c -15)) 15)))
 135       (setf y (logxor y (ash y -18)))
 136       y)))
 137
 138 ;;; Using inline VOP support, only available on the x86 so far.
 139 ;;;
 140 ;;; FIXME: It would be nice to have some benchmark numbers on this.
 141 ;;; My inclination is to get rid of the nonportable implementation
 142 ;;; unless the performance difference is just enormous.
 143 #!+x86
 144 (defun random-chunk (state)
 145   (declare (type random-state state))
 146   (sb!vm::random-mt19937 (random-state-state state)))
 147 \f
 148 ;;; Handle the single or double float case of RANDOM. We generate a
 149 ;;; float between 0.0 and 1.0 by clobbering the significand of 1.0
 150 ;;; with random bits, then subtracting 1.0. This hides the fact that
 151 ;;; we have a hidden bit.
 152 #!-sb-fluid (declaim (inline %random-single-float %random-double-float))
 153 (declaim (ftype (function ((single-float (0f0)) random-state)
 154                           (single-float 0f0))
 155                 %random-single-float))
 156 (defun %random-single-float (arg state)
 157   (declare (type (single-float (0f0)) arg)
 158            (type random-state state))
 159   (* arg
 160      (- (make-single-float
 161          (dpb (ash (random-chunk state)
 162                    (- sb!vm:single-float-digits random-chunk-length))
 163               sb!vm:single-float-significand-byte
 164               (single-float-bits 1.0)))
 165         1.0)))
 166 (declaim (ftype (function ((double-float (0d0)) random-state)
 167                           (double-float 0d0))
 168                 %random-double-float))
 169
 170 ;;; 32-bit version
 171 #!+nil
 172 (defun %random-double-float (arg state)
 173   (declare (type (double-float (0d0)) arg)
 174            (type random-state state))
 175   (* (float (random-chunk state) 1d0) (/ 1d0 (expt 2 32))))
 176
 177 ;;; 53-bit version
 178 #!-x86
 179 (defun %random-double-float (arg state)
 180   (declare (type (double-float (0d0)) arg)
 181            (type random-state state))
 182   (* arg
 183      (- (sb!impl::make-double-float
 184          (dpb (ash (random-chunk state)
 185                    (- sb!vm:double-float-digits random-chunk-length
 186                       sb!vm:word-bits))
 187               sb!vm:double-float-significand-byte
 188               (sb!impl::double-float-high-bits 1d0))
 189          (random-chunk state))
 190         1d0)))
 191
 192 ;;; using a faster inline VOP
 193 #!+x86
 194 (defun %random-double-float (arg state)
 195   (declare (type (double-float (0d0)) arg)
 196            (type random-state state))
 197   (let ((state-vector (random-state-state state)))
 198     (* arg
 199        (- (sb!impl::make-double-float
 200            (dpb (ash (sb!vm::random-mt19937 state-vector)
 201                      (- sb!vm:double-float-digits random-chunk-length
 202                         sb!vm:word-bits))
 203                 sb!vm:double-float-significand-byte
 204                 (sb!impl::double-float-high-bits 1d0))
 205            (sb!vm::random-mt19937 state-vector))
 206           1d0))))
 207
 208 #!+long-float
 209 (declaim #!-sb-fluid (inline %random-long-float))
 210 #!+long-float
 211 (declaim (ftype (function ((long-float (0l0)) random-state) (long-float 0l0))
 212                 %random-long-float))
 213
 214 ;;; using a faster inline VOP
 215 #!+(and long-float x86)
 216 (defun %random-long-float (arg state)
 217   (declare (type (long-float (0l0)) arg)
 218            (type random-state state))
 219   (let ((state-vector (random-state-state state)))
 220     (* arg
 221        (- (sb!impl::make-long-float
 222            (sb!impl::long-float-exp-bits 1l0)
 223            (logior (sb!vm::random-mt19937 state-vector)
 224                    sb!vm:long-float-hidden-bit)
 225            (sb!vm::random-mt19937 state-vector))
 226           1l0))))
 227
 228 #!+(and long-float sparc)
 229 (defun %random-long-float (arg state)
 230   (declare (type (long-float (0l0)) arg)
 231            (type random-state state))
 232   (* arg
 233      (- (sb!impl::make-long-float
 234          (sb!impl::long-float-exp-bits 1l0)     ; X needs more work
 235          (random-chunk state) (random-chunk state) (random-chunk state))
 236         1l0)))
 237 \f
 238 ;;;; random integers
 239
 240 (defun %random-integer (arg state)
 241   (declare (type (integer 1) arg) (type random-state state))
 242   (let ((shift (- random-chunk-length random-integer-overlap)))
 243     (do ((bits (random-chunk state)
 244                (logxor (ash bits shift) (random-chunk state)))
 245          (count (+ (integer-length arg)
 246                    (- random-integer-extra-bits shift))
 247                 (- count shift)))
 248         ((minusp count)
 249          (rem bits arg))
 250       (declare (fixnum count)))))
 251
 252 (defun random (arg &optional (state *random-state*))
 253   #!+sb-doc
 254   "Generate a uniformly distributed pseudo-random number between zero
 255   and Arg. State, if supplied, is the random state to use."
 256   (declare (inline %random-single-float %random-double-float
 257                    #!+long-float %long-float))
 258   (cond
 259     ((and (fixnump arg) (<= arg random-fixnum-max) #!+high-security (> arg 0))
 260      (rem (random-chunk state) arg))
 261     ((and (typep arg 'single-float) #!+high-security (> arg 0.0S0))
 262      (%random-single-float arg state))
 263     ((and (typep arg 'double-float) #!+high-security (> arg 0.0D0))
 264      (%random-double-float arg state))
 265     #!+long-float
 266     ((and (typep arg 'long-float) #!+high-security (> arg 0.0L0))
 267      (%random-long-float arg state))
 268     ((and (integerp arg) #!+high-security (> arg 0))
 269      (%random-integer arg state))
 270     (t
 271      (error 'simple-type-error
 272             :expected-type '(or (integer 1) (float (0))) :datum arg
 273             :format-control "Argument is not a positive integer or a positive float: ~S"
 274             :format-arguments (list arg)))))