Raymond Toy pushed to branch rtoy-xoro at cmucl / cmucl

Commits:

4 changed files:

Changes:

  • src/code/rand-xoroshiro.lisp
    ... ... @@ -13,15 +13,16 @@
    13 13 
     (in-package "LISP")
    14 14 
     (intl:textdomain "cmucl")
    15 15
    16 
    -(export '(random-state random-state-p random *random-state*
    17 
    -	  make-random-state))
    16 
    +#+nil
    17 
    +(export '(xoro-random-state xoro-random-state-p xoro-random *xoro-random-state*
    18 
    +	  make-xoro-random-state))
    18 19
    19 20 
     (in-package "KERNEL")
    20 
    -(export '(%random-single-float %random-double-float random-chunk init-random-state))
    21 
    +(export '(%xorohiro-single-float %xorohiro-double-float xoroshiro-chunk init-random-state))
    21 22
    22 23 
     (sys:register-lisp-feature :random-xoroshiro)
    23 24
    24 
    -(defun int-init-random-state (&optional (seed 5772156649015328606) state)
    25 
    +(defun int-init-xoro-state (&optional (seed 5772156649015328606) state)
    25 26 
       (let ((state (or state (make-array 2 :element-type 'double-float)))
    26 27 
     	(splitmix-state (ldb (byte 64 0) seed)))
    27 28 
         (flet ((splitmix64 ()
    ... ... @@ -46,9 +47,10 @@
    46 47 
           (let* ((s0 (splitmix64))
    47 48 
     	     (s1 (splitmix64)))
    48 49 
     	   (setf (aref state 0) (make-double s0)
    49 
    -		 (aref state 1) (make-double s1))))))
    50 
    +		 (aref state 1) (make-double s1))
    51 
    +	   state))))
    50 52
    51 
    -(defun vec-init-random-state (key &optional state)
    53 
    +(defun vec-init-xoro-state (key &optional state)
    52 54 
       (declare (type (array (unsigned-byte 32) (4)) key)
    53 55 
     	   (type (simple-array double-float (2)) state))
    54 56 
       (flet ((make-double (hi lo)
    ... ... @@ -58,59 +60,84 @@
    58 60 
     		    (- hi #x100000000))
    59 61 
     		lo)))
    60 62 
         (setf (aref state 0) (make-double (aref key 0) (aref key 1))
    61 
    -	  (aref state 1) (make-double (aref key 2) (aref key 3)))))
    63 
    +	  (aref state 1) (make-double (aref key 2) (aref key 3)))
    64 
    +    state))
    62 65
    63 66
    64 
    -(defun init-random-state (&optional (seed 5772156649015328606) state)
    67 
    +(defun init-xoro-state (&optional (seed 5772156649015328606) state)
    65 68 
       "Generate an random state vector from the given SEED.  The seed can be
    66 69 
       either an integer or a vector of (unsigned-byte 32)"
    67 70 
       (declare (type (or null integer
    68 71 
     		     (array (unsigned-byte 32) (*)))
    69 72 
     		 seed))
    70 
    -  (etypecase seed
    71 
    -    (integer
    72 
    -     (int-init-random-state (ldb (byte 64 0) seed) state))
    73 
    -    ((array (unsigned-byte 32) (4))
    74 
    -     (vec-init-random-state seed state))))
    73 
    +  (let ((state (or state (make-array 2 :element-type 'double-float))))
    74 
    +    (etypecase seed
    75 
    +      (integer
    76 
    +       (int-init-xoro-state (ldb (byte 64 0) seed) state))
    77 
    +      ((array (unsigned-byte 32) (4))
    78 
    +       (vec-init-xoro-state seed state)))))
    75 79
    76 80 
     (defstruct (xoro-random-state
    77 81 
     	     (:constructor make-xoroshiro-object)
    78 82 
     	     (:make-load-form-fun :just-dump-it-normally))
    79 
    -  (state (init-random-state)
    83 
    +  (state (init-xoro-state)
    80 84 
        :type (simple-array double-float (2)))
    81 85 
       (rand (make-array 1 :element-type '(unsigned-byte 32) :initial-element 0)
    82 86 
        :type (simple-array (unsigned-byte 32) (1)))
    83 87 
       (cached-p nil :type (member t nil)))
    84 88
    89 
    +(defvar *xoro-random-state*)
    85 90
    91 
    +(defun make-xoro-random-state (&optional state)
    92 
    +  (flet ((copy-random-state (state)
    93 
    +	   (let ((old-state (xoro-random-state-state state))
    94 
    +		 (new-state
    95 
    +		  (make-array 2 :element-type 'double-float))
    96 
    +		 (new-rand (make-array 1 :element-type '(unsigned-byte 32))))
    97 
    +	     (setf (aref new-state 0) (aref old-state 0))
    98 
    +	     (setf (aref new-state 1) (aref old-state 1))
    99 
    +	     (setf (aref new-rand 0) (aref (xoro-random-state-rand state) 0))
    100 
    +	     (make-xoroshiro-object :state new-state
    101 
    +				    :rand new-rand
    102 
    +				    :cached-p (xoro-random-state-cached-p state)))))
    103 
    +    (cond ((not state)
    104 
    +	   (copy-random-state *xoro-random-state*))
    105 
    +	  ((xoro-random-state-p state)
    106 
    +	   (copy-random-state state))
    107 
    +	  ((eq state t)
    108 
    +	   (make-xoroshiro-object :state (init-xoro-state (generate-seed 4))
    109 
    +				  :rand (make-array 1 :element-type '(unsigned-byte 32) :initial-element 0)
    110 
    +				  :cached-p nil))
    111 
    +	  (t
    112 
    +	   (error "Argument is not a RANDOM-STATE, T, or NIL: ~S" state)))))
    86 113
    87 114 
     ;;;; Random entries:
    88 115
    89 
    -;;; Size of the chunks returned by random-chunk.
    116 
    +;;; Size of the chunks returned by xoroshiro-chunk.
    90 117 
     ;;;
    91 
    -(defconstant random-chunk-length 32)
    118 
    +;;(defconstant random-chunk-length 32)
    92 119
    93 
    -;;; random-chunk -- Internal
    120 
    +;;; xoroshiro-chunk -- Internal
    94 121 
     ;;;
    95 122 
     ;;; This function generaters a 32bit integer between 0 and #xffffffff
    96 123 
     ;;; inclusive.
    97 124 
     ;;;
    98 
    -(declaim (inline random-chunk))
    125 
    +(declaim (inline xoroshiro-chunk))
    99 126
    100 
    -(defun random-chunk (rng-state)
    101 
    -  (declare (type xoro-state rng-state)
    127 
    +(defun xoroshiro-chunk (rng-state)
    128 
    +  (declare (type xoro-random-state rng-state)
    102 129 
     	   (optimize (speed 3) (safety 0)))
    103 
    -  (let ((cached (xoro-state-cached-p rng-state)))
    130 
    +  (let ((cached (xoro-random-state-cached-p rng-state)))
    104 131 
         (cond (cached
    105 
    -	   (setf (xoro-state-cached-p rng-state) nil)
    106 
    -	   (aref (xoro-state-rand rng-state) 0))
    132 
    +	   (setf (xoro-random-state-cached-p rng-state) nil)
    133 
    +	   (aref (xoro-random-state-rand rng-state) 0))
    107 134 
     	  (t
    108 
    -	   (let ((s (xoro-state-state rng-state)))
    135 
    +	   (let ((s (xoro-random-state-state rng-state)))
    109 136 
     	     (declare (type (simple-array double-float (2)) s))
    110 137 
     	     (multiple-value-bind (r1 r0)
    111 138 
     		 (vm::xoroshiro-next s)
    112 
    -	       (setf (aref (xoro-state-rand rng-state) 0) r1)
    113 
    -	       (setf (xoro-state-cached-p rng-state) t)
    139 
    +	       (setf (aref (xoro-random-state-rand rng-state) 0) r1)
    140 
    +	       (setf (xoro-random-state-cached-p rng-state) t)
    114 141 
     	       r0))))))
    115 142
    116 143 
     #-x86
    ... ... @@ -204,17 +231,17 @@
    204 231 
     ;;; between 0.0 and 1.0 by clobbering the significand of 1.0 with random bits,
    205 232 
     ;;; then subtracting 1.0.  This hides the fact that we have a hidden bit.
    206 233 
     ;;;
    207 
    -(declaim (inline %random-single-float %random-double-float))
    234 
    +(declaim (inline %xorohiro-single-float %xorohiro-double-float))
    208 235 
     (declaim (ftype (function ((single-float (0f0)) random-state)
    209 236 
     			  (single-float 0f0))
    210 
    -		%random-single-float))
    237 
    +		%xorohiro-single-float))
    211 238 
     ;;;
    212 
    -(defun %random-single-float (arg state)
    239 
    +(defun %xorohiro-single-float (arg state)
    213 240 
       (declare (type (single-float (0f0)) arg)
    214 241 
     	   (type random-state state))
    215 242 
       (* arg
    216 243 
          (- (make-single-float
    217 
    -	 (dpb (ash (random-chunk state)
    244 
    +	 (dpb (ash (xoroshiro-chunk state)
    218 245 
     		   (- vm:single-float-digits random-chunk-length))
    219 246 
     	      vm:single-float-significand-byte
    220 247 
     	      (single-float-bits 1.0)))
    ... ... @@ -222,72 +249,27 @@
    222 249 
     ;;;
    223 250 
     (declaim (ftype (function ((double-float (0d0)) random-state)
    224 251 
     			  (double-float 0d0))
    225 
    -		%random-double-float))
    252 
    +		%xorohiro-double-float))
    226 253 
     ;;;
    227 254 
     ;;; 53bit version.
    228 255 
     ;;;
    229 
    -#-x86
    230 
    -(defun %random-double-float (arg state)
    256 
    +(defun %xorohiro-double-float (arg state)
    231 257 
       (declare (type (double-float (0d0)) arg)
    232 258 
     	   (type random-state state))
    233 259 
       (* arg
    234 260 
          (- (lisp::make-double-float
    235 
    -	 (dpb (ash (random-chunk state)
    261 
    +	 (dpb (ash (xoroshiro-chunk state)
    236 262 
     		   (- vm:double-float-digits random-chunk-length
    237 263 
     		      vm:word-bits))
    238 264 
     	      vm:double-float-significand-byte
    239 265 
     	      (lisp::double-float-high-bits 1d0))
    240 
    -	 (random-chunk state))
    266 
    +	 (xoroshiro-chunk state))
    241 267 
     	1d0)))
    242 268
    243 
    -;;; Using a faster inline VOP.
    244 
    -#+x86
    245 
    -(defun %random-double-float (arg state)
    246 
    -  (declare (type (double-float (0d0)) arg)
    247 
    -	   (type random-state state))
    248 
    -  (let ((state-vector (random-state-state state)))
    249 
    -    (* arg
    250 
    -       (- (lisp::make-double-float
    251 
    -	   (dpb (ash (vm::random-mt19937 state-vector)
    252 
    -		     (- vm:double-float-digits random-chunk-length
    253 
    -			vm:word-bits))
    254 
    -		vm:double-float-significand-byte
    255 
    -		(lisp::double-float-high-bits 1d0))
    256 
    -	   (vm::random-mt19937 state-vector))
    257 
    -	  1d0))))
    258 
    -
    259 
    -#+long-float
    260 
    -(declaim (inline %random-long-float))
    261 
    -#+long-float
    262 
    -(declaim (ftype (function ((long-float (0l0)) random-state) (long-float 0l0))
    263 
    -		%random-long-float))
    264 
    -
    265 
    -;;; Using a faster inline VOP.
    266 
    -#+(and long-float x86)
    267 
    -(defun %random-long-float (arg state)
    268 
    -  (declare (type (long-float (0l0)) arg)
    269 
    -	   (type random-state state))
    270 
    -  (let ((state-vector (random-state-state state)))
    271 
    -    (* arg
    272 
    -       (- (lisp::make-long-float
    273 
    -	   (lisp::long-float-exp-bits 1l0)
    274 
    -	   (logior (vm::random-mt19937 state-vector) vm:long-float-hidden-bit)
    275 
    -	   (vm::random-mt19937 state-vector))
    276 
    -	  1l0))))
    277 
    -
    278 
    -#+(and long-float sparc)
    279 
    -(defun %random-long-float (arg state)
    280 
    -  (declare (type (long-float (0l0)) arg)
    281 
    -	   (type random-state state))
    282 
    -  (* arg
    283 
    -     (- (lisp::make-long-float
    284 
    -	 (lisp::long-float-exp-bits 1l0)	; X needs more work
    285 
    -	 (random-chunk state) (random-chunk state) (random-chunk state))
    286 
    -	1l0)))
    287 269 
     #+double-double
    288 270 
     (defun %random-double-double-float (arg state)
    289 271 
       (declare (type (double-double-float (0w0)) arg)
    290 
    -	   (type random-state state))
    272 
    +	   (type xoro-random-state state))
    291 273 
       ;; Generate a 31-bit integer, scale it and sum them up
    292 274 
       (let* ((r 0w0)
    293 275 
     	 (scale (scale-float 1d0 -31))
    ... ... @@ -296,10 +278,9 @@
    296 278 
     	     (type double-double-float r)
    297 279 
     	     (optimize (speed 3) (inhibit-warnings 3)))
    298 280 
         (dotimes (k 4)
    299 
    -      (setf r (+ r (* mult (ldb (byte 31 0) (random-chunk state)))))
    281 
    +      (setf r (+ r (* mult (ldb (byte 31 0) (xoroshiro-chunk state)))))
    300 282 
           (setf mult (* mult scale)))
    301 283 
         (* arg r)))
    302 
    -
    303 284
    304 285 
     ;;;; Random integers:
    305 286
    ... ... @@ -321,7 +302,7 @@
    321 302
    322 303 
     ;;; %RANDOM-INTEGER  --  Internal
    323 304 
     ;;;
    324 
    -(defun %random-integer (arg state)
    305 
    +(defun %xorohiro-integer (arg state)
    325 306 
       (declare (type (integer 1) arg) (type random-state state))
    326 307 
       (let ((shift (- random-chunk-length random-integer-overlap)))
    327 308 
         (do ((bits (random-chunk state)
    ... ... @@ -333,27 +314,27 @@
    333 314 
     	 (rem bits arg))
    334 315 
           (declare (fixnum count)))))
    335 316
    336 
    -(defun random (arg &optional (state *random-state*))
    317 
    +(defun xoro-random (arg &optional (state *random-state*))
    337 318 
       "Generate a uniformly distributed pseudo-random number between zero
    338 319 
       and Arg.  State, if supplied, is the random state to use."
    339 
    -  (declare (inline %random-single-float %random-double-float
    320 
    +  (declare (inline %xorohiro-single-float %xorohiro-double-float
    340 321 
     		   #+long-float %long-float))
    341 322 
       (cond
    342 323 
         ((typep arg '(integer 1 #x100000000))
    343 324 
          ;; Let the compiler deftransform take care of this case.
    344 325 
          (random arg state))
    345 326 
         ((and (typep arg 'single-float) (> arg 0.0F0))
    346 
    -     (%random-single-float arg state))
    327 
    +     (%xorohiro-single-float arg state))
    347 328 
         ((and (typep arg 'double-float) (> arg 0.0D0))
    348 
    -     (%random-double-float arg state))
    329 
    +     (%xorohiro-double-float arg state))
    349 330 
         #+long-float
    350 331 
         ((and (typep arg 'long-float) (> arg 0.0L0))
    351 
    -     (%random-long-float arg state))
    332 
    +     (%xorohiro-long-float arg state))
    352 333 
         #+double-double
    353 334 
         ((and (typep arg 'double-double-float) (> arg 0.0w0))
    354 
    -     (%random-double-double-float arg state))
    335 
    +     (%xorohiro-double-double-float arg state))
    355 336 
         ((and (integerp arg) (> arg 0))
    356 
    -     (%random-integer arg state))
    337 
    +     (%xorohiro-integer arg state))
    357 338 
         (t
    358 339 
          (error 'simple-type-error
    359 340 
     	    :expected-type '(or (integer 1) (float (0.0))) :datum arg

  • src/tools/worldbuild.lisp
    ... ... @@ -124,6 +124,7 @@
    124 124 
         ,@(if (c:backend-featurep :random-mt19937)
    125 125 
     	  '("target:code/rand-mt19937")
    126 126 
     	  '("target:code/rand"))
    127 
    +    "target:code/rand-xoroshiro"
    127 128 
         "target:code/alieneval"
    128 129 
         "target:code/c-call"
    129 130 
         "target:code/sap"

  • src/tools/worldcom.lisp
    ... ... @@ -271,6 +271,7 @@
    271 271 
     (if (c:backend-featurep :random-mt19937)
    272 272 
         (comf "target:code/rand-mt19937")
    273 273 
         (comf "target:code/rand"))
    274 
    +(comf "target:code/rand-xoroshiro")
    274 275 
     (comf "target:code/ntrace" :byte-compile *byte-compile*)
    275 276 
     (comf "target:code/profile")
    276 277 
     (comf "target:code/sort")

  • src/tools/worldload.lisp
    ... ... @@ -98,6 +98,7 @@
    98 98 
     (maybe-byte-load "code:describe")
    99 99 
     #+random-mt19937 (maybe-byte-load "code:rand-mt19937")
    100 100 
     #-random-mt19937 (maybe-byte-load "code:rand")
    101 
    +(maybe-byte-load "code:rand-xoroshiro")
    101 102 
     (maybe-byte-load "target:pcl/walk")
    102 103 
     (maybe-byte-load "code:fwrappers")
    103 104 
     (maybe-byte-load "code:ntrace")

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.common-lisp.net. If you'd like to receive fewer emails, you can adjust your notification settings.