December 2017 - cmucl-cvs - mailman3.common-lisp.net

[Git][cmucl/cmucl][rtoy-xoro] Print and set state as 64-bit integers
by Raymond Toy 19 Dec '17

19 Dec '17

Raymond Toy pushed to branch rtoy-xoro at cmucl / cmucl Commits: f9203f85 by Raymond Toy at 2017-12-19T10:04:50-08:00 Print and set state as 64-bit integers The xoroshiro128+ algorithm is defined using uint64_t types, but we hack it to store the state as double-float's. This is a bit confusing, so add a printer to print the state as an array of two uint64_t's. Adjust init-xoro-state to allow initializing the state using an array of 2 64-bit ints. - - - - - 1 changed file: - src/code/rand-xoroshiro.lisp Changes: ===================================== src/code/rand-xoroshiro.lisp ===================================== --- a/src/code/rand-xoroshiro.lisp +++ b/src/code/rand-xoroshiro.lisp @@ -22,6 +22,28 @@ (sys:register-lisp-feature :random-xoroshiro) +(defun generate-seed (&optional (nwords 1)) + ;; On some systems (as reported by Ole Rohne on cmucl-imp), + ;; /dev/urandom isn't what we think it is, so if it doesn't work, + ;; silently generate the seed from the current time. + (or (ignore-errors + (let ((words (make-array nwords :element-type '(unsigned-byte 32)))) + (with-open-file (rand "/dev/urandom" + :direction :input + :element-type '(unsigned-byte 32)) + (read-sequence words rand)) + (if (= nwords 1) + (aref words 0) + (let ((vec (make-array (floor nwords 2) :element-type '(unsigned-byte 64)))) + (do ((k 0 (+ k 1)) + (j 0 (+ j 2))) + ((>= k (length vec)) + vec) + (setf (aref vec k) + (logior (ash (aref words j) 32) + (aref words (+ j 1))))))))) + (logand (get-universal-time) #xffffffff))) + (defun int-init-xoro-state (&optional (seed 5772156649015328606) state) (let ((state (or state (make-array 2 :element-type 'double-float))) (splitmix-state (ldb (byte 64 0) seed))) @@ -51,16 +73,18 @@ state)))) (defun vec-init-xoro-state (key &optional state) - (declare (type (array (unsigned-byte 32) (4)) key) + (declare (type (array (unsigned-byte 64) (2)) key) (type (simple-array double-float (2)) state)) - (flet ((make-double (hi lo) - (kernel:make-double-float - (if (< hi #x80000000) - hi - (- hi #x100000000)) - lo))) - (setf (aref state 0) (make-double (aref key 0) (aref key 1)) - (aref state 1) (make-double (aref key 2) (aref key 3))) + (flet ((make-double (x) + (let ((hi (ldb (byte 32 32) x)) + (lo (ldb (byte 32 0) x))) + (kernel:make-double-float + (if (< hi #x80000000) + hi + (- hi #x100000000)) + lo)))) + (setf (aref state 0) (make-double (aref key 0)) + (aref state 1) (make-double (aref key 1))) state)) @@ -68,13 +92,13 @@ "Generate an random state vector from the given SEED. The seed can be either an integer or a vector of (unsigned-byte 32)" (declare (type (or null integer - (array (unsigned-byte 32) (*))) + (array (unsigned-byte 64) (*))) seed)) (let ((state (or state (make-array 2 :element-type 'double-float)))) (etypecase seed (integer (int-init-xoro-state (ldb (byte 64 0) seed) state)) - ((array (unsigned-byte 32) (4)) + ((array (unsigned-byte 64) (2)) (vec-init-xoro-state seed state))))) (defstruct (xoro-random-state @@ -113,14 +137,15 @@ (pprint-logical-block (stream nil :prefix "#.(" :suffix ")") (prin1 'init-xoro-state stream) (write-char #\space stream) - (prin1 (make-array 4 :element-type '(unsigned-byte 32) - :initial-contents (list (ldb (byte 32 0) - (double-float-high-bits (aref state 0))) - (double-float-low-bits (aref state 0)) - (ldb (byte 32 0) - (double-float-high-bits (aref state 1))) - (double-float-low-bits (aref state 1)))) - stream)) + (flet ((c (x) + (multiple-value-bind (hi lo) + (double-float-bits x) + (logior (ash (ldb (byte 32 0) hi) 32) + lo)))) + (prin1 (make-array 2 :element-type '(unsigned-byte 64) + :initial-contents (list (c (aref state 0)) + (c (aref state 1)))) + stream))) (write-char #\space stream) (pprint-newline :linear stream) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/f9203f85f2f65dd8b277f2910… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/f9203f85f2f65dd8b277f2910… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-xoro] Add custom xoro-random-state printer
by Raymond Toy 19 Dec '17

19 Dec '17

Raymond Toy pushed to branch rtoy-xoro at cmucl / cmucl Commits: 0b94ee3d by Raymond Toy at 2017-12-19T09:02:25-08:00 Add custom xoro-random-state printer Custom printer to print the state as array of integers instead of doubles. Makes it easier to see and match what the C code does. - - - - - 1 changed file: - src/code/rand-xoroshiro.lisp Changes: ===================================== src/code/rand-xoroshiro.lisp ===================================== --- a/src/code/rand-xoroshiro.lisp +++ b/src/code/rand-xoroshiro.lisp @@ -79,6 +79,7 @@ (defstruct (xoro-random-state (:constructor make-xoroshiro-object) + (:print-function %print-xoro-state) (:make-load-form-fun :just-dump-it-normally)) ;; The state of the RNG. The actual algorithm uses 2 64-bit words ;; of state. To reduce consing, we use an array of double-float's @@ -95,6 +96,46 @@ ;; generate a new 64-bit result. (cached-p nil :type (member t nil))) +(defun %print-xoro-state (rng-state stream depth) + (declare (ignore depth)) + ;; Basically the same as the default structure printer, but we want + ;; to print the state as an array of integers instead of doubles, + ;; because it's a bit confusing to see the state as doubles. + (let ((state (xoro-random-state-state rng-state))) + (pprint-logical-block (stream nil :prefix "#S(" :suffix ")") + (prin1 'xoro-random-state stream) + (write-char #\space stream) + (pprint-indent :block 2 stream) + (pprint-newline :linear stream) + (prin1 :state stream) + (write-char #\space stream) + (pprint-newline :miser stream) + (pprint-logical-block (stream nil :prefix "#.(" :suffix ")") + (prin1 'init-xoro-state stream) + (write-char #\space stream) + (prin1 (make-array 4 :element-type '(unsigned-byte 32) + :initial-contents (list (ldb (byte 32 0) + (double-float-high-bits (aref state 0))) + (double-float-low-bits (aref state 0)) + (ldb (byte 32 0) + (double-float-high-bits (aref state 1))) + (double-float-low-bits (aref state 1)))) + stream)) + (write-char #\space stream) + (pprint-newline :linear stream) + + (prin1 :rand stream) + (write-char #\space stream) + (pprint-newline :miser stream) + (prin1 (xoro-random-state-rand rng-state) stream) + (write-char #\space stream) + (pprint-newline :linear stream) + + (prin1 :cached-p stream) + (write-char #\space stream) + (pprint-newline :miser stream) + (prin1 (xoro-random-state-cached-p rng-state) stream)))) + (defvar *xoro-random-state* (make-xoroshiro-object)) @@ -396,11 +437,3 @@ (setf (aref state 1) (convert s1-1 s1-0))) rng-state)) -(defun print-xoro-state (rng-state) - (let ((state (xoro-random-state-state rng-state))) - (flet ((v (x) - (multiple-value-bind (hi lo) - (kernel:double-float-bits x) - (logior (ash (ldb (byte 32 0) hi) 32) - lo)))) - (format t "~16,'0x ~16,'0x" (v (aref state 0)) (v (aref state 1)))))) \ No newline at end of file View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/0b94ee3d6f6bdf7c2575678ef… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/0b94ee3d6f6bdf7c2575678ef… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-xoro] Fix typos add jump function
by Raymond Toy 18 Dec '17

18 Dec '17

Raymond Toy pushed to branch rtoy-xoro at cmucl / cmucl Commits: dbc0518d by Raymond Toy at 2017-12-18T21:02:39-08:00 Fix typos add jump function * Fix typos in names so we can call the functions. * Add jump function to allow generating new distinct sequences. * Add simple function to print the state using integers instead of doubles. (Untested.) - - - - - 1 changed file: - src/code/rand-xoroshiro.lisp Changes: ===================================== src/code/rand-xoroshiro.lisp ===================================== --- a/src/code/rand-xoroshiro.lisp +++ b/src/code/rand-xoroshiro.lisp @@ -18,7 +18,7 @@ make-xoro-random-state)) (in-package "KERNEL") -(export '(%xorohiro-single-float %xorohiro-double-float xoroshiro-chunk init-xoro-state)) +(export '(%xoroshiro-single-float %xoroshiro-double-float xoroshiro-chunk init-xoro-state)) (sys:register-lisp-feature :random-xoroshiro) @@ -95,7 +95,8 @@ ;; generate a new 64-bit result. (cached-p nil :type (member t nil))) -(defvar *xoro-random-state*) +(defvar *xoro-random-state* + (make-xoroshiro-object)) (defun make-xoro-random-state (&optional state) (flet ((copy-random-state (state) @@ -120,16 +121,23 @@ ;;;; Random entries: +(declaim (ext:start-block xoroshiro-gen xoroshiro-chunk + %xoroshiro-single-float %xoroshiro-double-float + %xoroshiro-integer + #+double-double + %xoroshiro-double-double-float)) +;;#+x86 +;;(declaim (inline xoroshiro-next)) #+x86 -(declaim (inline xoroshiro-next)) -#+x86 -(defun xoroshiro-next (state) - (declare (type (simple-array double-float (2)) state)) +(defun xoroshiro-gen (state) + (declare (type (simple-array double-float (2)) state) + (optimize (speed 3) (safety 0))) (vm::xoroshiro-next state)) #-x86 -(defun xoroshiro-next (state) - (declare (type (simple-array double-float (2)) state)) +(defun xoroshiro-gen (state) + (declare (type (simple-array double-float (2)) state) + (optimize (speed 3) (safety 0))) (flet ((rotl-55 (x1 x0) (declare (type (unsigned-byte 32) x0 x1) (optimize (speed 3) (safety 0))) @@ -228,7 +236,7 @@ (let ((s (xoro-random-state-state rng-state))) (declare (type (simple-array double-float (2)) s)) (multiple-value-bind (r1 r0) - (xoroshiro-next s) + (xoroshiro-gen s) (setf (xoro-random-state-rand rng-state) r0) (setf (xoro-random-state-cached-p rng-state) t) r1)))))) @@ -240,14 +248,14 @@ ;;; between 0.0 and 1.0 by clobbering the significand of 1.0 with random bits, ;;; then subtracting 1.0. This hides the fact that we have a hidden bit. ;;; -(declaim (inline %xorohiro-single-float %xorohiro-double-float)) -(declaim (ftype (function ((single-float (0f0)) random-state) +(declaim (inline %xoroshiro-single-float %xoroshiro-double-float)) +(declaim (ftype (function ((single-float (0f0)) xoro-random-state) (single-float 0f0)) - %xorohiro-single-float)) + %xoroshiro-single-float)) ;;; -(defun %xorohiro-single-float (arg state) +(defun %xoroshiro-single-float (arg state) (declare (type (single-float (0f0)) arg) - (type random-state state)) + (type xoro-random-state state)) (* arg (- (make-single-float (dpb (ash (xoroshiro-chunk state) @@ -256,15 +264,15 @@ (single-float-bits 1.0))) 1.0))) ;;; -(declaim (ftype (function ((double-float (0d0)) random-state) +(declaim (ftype (function ((double-float (0d0)) xoro-random-state) (double-float 0d0)) - %xorohiro-double-float)) + %xoroshiro-double-float)) ;;; ;;; 53bit version. ;;; -(defun %xorohiro-double-float (arg state) +(defun %xoroshiro-double-float (arg state) (declare (type (double-float (0d0)) arg) - (type random-state state)) + (type xoro-random-state state)) (* arg (- (lisp::make-double-float (dpb (ash (xoroshiro-chunk state) @@ -311,11 +319,12 @@ ;;; %RANDOM-INTEGER -- Internal ;;; -(defun %xorohiro-integer (arg state) - (declare (type (integer 1) arg) (type random-state state)) +(defun %xoroshiro-integer (arg state) + (declare (type (integer 1) arg) + (type xoro-random-state state)) (let ((shift (- random-chunk-length random-integer-overlap))) - (do ((bits (random-chunk state) - (logxor (ash bits shift) (random-chunk state))) + (do ((bits (xoroshiro-chunk state) + (logxor (ash bits shift) (xoroshiro-chunk state))) (count (+ (integer-length arg) (- random-integer-extra-bits shift)) (- count shift))) @@ -323,30 +332,75 @@ (rem bits arg)) (declare (fixnum count))))) -(defun xoro-random (arg &optional (state *random-state*)) +(declaim (ext:end-block)) + +(defun xoro-random (arg &optional (state *xoro-random-state*)) "Generate a uniformly distributed pseudo-random number between zero and Arg. State, if supplied, is the random state to use." - (declare (inline %xorohiro-single-float %xorohiro-double-float + (declare (inline %xoroshiro-single-float %xoroshiro-double-float #+long-float %long-float)) (cond ((typep arg '(integer 1 #x100000000)) ;; Let the compiler deftransform take care of this case. - (random arg state)) + (%xoroshiro-integer arg state)) ((and (typep arg 'single-float) (> arg 0.0F0)) - (%xorohiro-single-float arg state)) + (%xoroshiro-single-float arg state)) ((and (typep arg 'double-float) (> arg 0.0D0)) - (%xorohiro-double-float arg state)) + (%xoroshiro-double-float arg state)) #+long-float ((and (typep arg 'long-float) (> arg 0.0L0)) - (%xorohiro-long-float arg state)) + (%xoroshiro-long-float arg state)) #+double-double ((and (typep arg 'double-double-float) (> arg 0.0w0)) - (%xorohiro-double-double-float arg state)) + (%xoroshiro-double-double-float arg state)) ((and (integerp arg) (> arg 0)) - (%xorohiro-integer arg state)) + (%xoroshiro-integer arg state)) (t (error 'simple-type-error :expected-type '(or (integer 1) (float (0.0))) :datum arg :format-control (intl:gettext "Argument is not a positive integer or a positive float: ~S") :format-arguments (list arg))))) +(defun xoroshiro-jump (rng-state) + (declare (type xoro-random-state rng-state)) + (let ((state (xoro-random-state-state rng-state)) + (s0-0 0) + (s0-1 0) + (s1-0 0) + (s1-1 0)) + (declare (type (unsigned-byte 32) s0-0 s0-1 s1-0 s1-1) + (optimize (speed 3) (safety 0))) + (dolist (jump '(#xbeac0467eba5facb #xd86b048b86aa9922)) + (declare (type (unsigned-byte 64) jump)) + (dotimes (b 64) + (declare (fixnum b)) + (when (logbitp b jump) + (multiple-value-bind (x1 x0) + (kernel:double-float-bits (aref state 0)) + (setf s0-1 (logxor s0-1 (ldb (byte 32 0) x1)) + s0-0 (logxor s0-0 x0))) + + (multiple-value-bind (x1 x0) + (kernel:double-float-bits (aref state 1)) + (setf s1-1 (logxor s1-1 (ldb (byte 32 0) x1)) + s1-0 (logxor s1-0 x0)))) + (format t "jump: ~D s0, s1 = ~X~8,'0X ~X~8,'0X~%" b s0-1 s0-0 s1-1 s1-0) + (xoroshiro-next state))) + + (flet ((convert (x1 x0) + (declare (type (unsigned-byte 32) x1 x0)) + (kernel:make-double-float + (if (< x1 #x80000000) x1 (- x1 #x100000000)) + x0))) + (setf (aref state 0) (convert s0-1 s0-0)) + (setf (aref state 1) (convert s1-1 s1-0))) + rng-state)) + +(defun print-xoro-state (rng-state) + (let ((state (xoro-random-state-state rng-state))) + (flet ((v (x) + (multiple-value-bind (hi lo) + (kernel:double-float-bits x) + (logior (ash (ldb (byte 32 0) hi) 32) + lo)))) + (format t "~16,'0x ~16,'0x" (v (aref state 0)) (v (aref state 1)))))) \ No newline at end of file View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/dbc0518d7d280599ce5185ace… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/dbc0518d7d280599ce5185ace… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-xoro] Define xoroshiro-next before xoroshiro-chunk.
by Raymond Toy 17 Dec '17

17 Dec '17

Raymond Toy pushed to branch rtoy-xoro at cmucl / cmucl Commits: d539b6a0 by Raymond Toy at 2017-12-17T13:04:59-08:00 Define xoroshiro-next before xoroshiro-chunk. - - - - - 1 changed file: - src/code/rand-xoroshiro.lisp Changes: ===================================== src/code/rand-xoroshiro.lisp ===================================== --- a/src/code/rand-xoroshiro.lisp +++ b/src/code/rand-xoroshiro.lisp @@ -120,32 +120,12 @@ ;;;; Random entries: -;;; Size of the chunks returned by xoroshiro-chunk. -;;; -;;(defconstant random-chunk-length 32) - -;;; xoroshiro-chunk -- Internal -;;; -;;; This function generaters a 32bit integer between 0 and #xffffffff -;;; inclusive. -;;; -(declaim (inline xoroshiro-chunk)) - -(defun xoroshiro-chunk (rng-state) - (declare (type xoro-random-state rng-state) - (optimize (speed 3) (safety 0))) - (let ((cached (xoro-random-state-cached-p rng-state))) - (cond (cached - (setf (xoro-random-state-cached-p rng-state) nil) - (xoro-random-state-rand rng-state)) - (t - (let ((s (xoro-random-state-state rng-state))) - (declare (type (simple-array double-float (2)) s)) - (multiple-value-bind (r1 r0) - (xoroshiro-next s) - (setf (xoro-random-state-rand rng-state) r0) - (setf (xoro-random-state-cached-p rng-state) t) - r1)))))) +#+x86 +(declaim (inline xoroshiro-next)) +#+x86 +(defun xoroshiro-next (state) + (declare (type (simple-array double-float (2)) state)) + (vm::xoroshiro-next state)) #-x86 (defun xoroshiro-next (state) @@ -225,6 +205,34 @@ (rotl-36 s1-1 s1-0) (setf (aref state 0) (make-double s0-1 s0-0) (aref state 1) (make-double r1 r0))))))) + +;;; Size of the chunks returned by xoroshiro-chunk. +;;; +;;(defconstant random-chunk-length 32) + +;;; xoroshiro-chunk -- Internal +;;; +;;; This function generaters a 32bit integer between 0 and #xffffffff +;;; inclusive. +;;; +(declaim (inline xoroshiro-chunk)) + +(defun xoroshiro-chunk (rng-state) + (declare (type xoro-random-state rng-state) + (optimize (speed 3) (safety 0))) + (let ((cached (xoro-random-state-cached-p rng-state))) + (cond (cached + (setf (xoro-random-state-cached-p rng-state) nil) + (xoro-random-state-rand rng-state)) + (t + (let ((s (xoro-random-state-state rng-state))) + (declare (type (simple-array double-float (2)) s)) + (multiple-value-bind (r1 r0) + (xoroshiro-next s) + (setf (xoro-random-state-rand rng-state) r0) + (setf (xoro-random-state-cached-p rng-state) t) + r1)))))) + ;;; %RANDOM-SINGLE-FLOAT, %RANDOM-DOUBLE-FLOAT -- Interface ;;; View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/d539b6a06bf8d209c2678e3d2… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/d539b6a06bf8d209c2678e3d2… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-xoro] Put back the original version, optimized for x86.
by Raymond Toy 16 Dec '17

16 Dec '17

Raymond Toy pushed to branch rtoy-xoro at cmucl / cmucl Commits: 95a01145 by Raymond Toy at 2017-12-16T21:05:41-08:00 Put back the original version, optimized for x86. - - - - - 1 changed file: - src/code/rand-xoroshiro.lisp Changes: ===================================== src/code/rand-xoroshiro.lisp ===================================== --- a/src/code/rand-xoroshiro.lisp +++ b/src/code/rand-xoroshiro.lisp @@ -142,12 +142,13 @@ (let ((s (xoro-random-state-state rng-state))) (declare (type (simple-array double-float (2)) s)) (multiple-value-bind (r1 r0) - (xoroshiro-next-portable s) + (xoroshiro-next s) (setf (xoro-random-state-rand rng-state) r0) (setf (xoro-random-state-cached-p rng-state) t) r1)))))) -(defun xoroshiro-next-portable (state) +#-x86 +(defun xoroshiro-next (state) (declare (type (simple-array double-float (2)) state)) (flet ((rotl-55 (x1 x0) (declare (type (unsigned-byte 32) x0 x1) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/95a011458bb9f2bad346b92e9… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/95a011458bb9f2bad346b92e9… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-xoro] Test portable version of xoroshiro-next
by Raymond Toy 16 Dec '17

16 Dec '17

Raymond Toy pushed to branch rtoy-xoro at cmucl / cmucl Commits: edcbb7d3 by Raymond Toy at 2017-12-16T20:53:21-08:00 Test portable version of xoroshiro-next - - - - - 1 changed file: - src/code/rand-xoroshiro.lisp Changes: ===================================== src/code/rand-xoroshiro.lisp ===================================== --- a/src/code/rand-xoroshiro.lisp +++ b/src/code/rand-xoroshiro.lisp @@ -142,13 +142,12 @@ (let ((s (xoro-random-state-state rng-state))) (declare (type (simple-array double-float (2)) s)) (multiple-value-bind (r1 r0) - (vm::xoroshiro-next s) + (xoroshiro-next-portable s) (setf (xoro-random-state-rand rng-state) r0) (setf (xoro-random-state-cached-p rng-state) t) r1)))))) -#-x86 -(defun xoroshiro-next (state) +(defun xoroshiro-next-portable (state) (declare (type (simple-array double-float (2)) state)) (flet ((rotl-55 (x1 x0) (declare (type (unsigned-byte 32) x0 x1) @@ -192,10 +191,8 @@ (let ((s0-1 0) (s0-0 0) (s1-1 0) - (s1-0 0) - (r1 0) - (r0 0)) - (declare (type (unsigned-byte 32)) s0-1 s0-0 s1-1 s1-0 r1 r0) + (s1-0 0)) + (declare (type (unsigned-byte 32) s0-1 s0-0 s1-1 s1-0)) (multiple-value-bind (x1 x0) (kernel:double-float-bits (aref state 0)) (setf s0-1 (ldb (byte 32 0) x1) @@ -210,27 +207,23 @@ (bignum::%add-with-carry s0-0 s1-0 0) (values (bignum::%add-with-carry s0-1 s1-1 c) sum-0)) - ;; s1 ^= s0 - (setf s1-1 (logxor s1-1 s0-1) - s1-0 (logxor s1-0 s0-0)) - ;; s[0] = rotl(s0,55) ^ s1 ^ (s1 << 14) - (multiple-value-setq (s0-1 s0-0) - (rotl-55 s0-1 s0-0)) - (setf s0-1 (logxor s0-1 s1-1) - s0-0 (logxor s0-0 s1-0)) - (multiple-value-bind (s14-1 s14-0) - (shl-14 s1-1 s1-0) - (setf s0-1 (logxor s0-1 s14-1) - s0-0 (logxor s0-0 s14-0))) - (setf (aref s 0) s0-0) - (setf (aref s 1) s0-1) + ;; s1 ^= s0 + (setf s1-1 (logxor s1-1 s0-1) + s1-0 (logxor s1-0 s0-0)) + ;; s[0] = rotl(s0,55) ^ s1 ^ (s1 << 14) + (multiple-value-setq (s0-1 s0-0) + (rotl-55 s0-1 s0-0)) + (setf s0-1 (logxor s0-1 s1-1) + s0-0 (logxor s0-0 s1-0)) + (multiple-value-bind (s14-1 s14-0) + (shl-14 s1-1 s1-0) + (setf s0-1 (logxor s0-1 s14-1) + s0-0 (logxor s0-0 s14-0))) - (multiple-value-bind (r1 r0) - (rotl-36 s1-1 s1-0) - (setf (aref s 2) r0 - (aref s 3) r1)) - (setf (aref state 0) (make-double s0-1 s0-0) - (aref state 1) (make-double s1-1 s1-0)))))) + (multiple-value-bind (r1 r0) + (rotl-36 s1-1 s1-0) + (setf (aref state 0) (make-double s0-1 s0-0) + (aref state 1) (make-double r1 r0))))))) ;;; %RANDOM-SINGLE-FLOAT, %RANDOM-DOUBLE-FLOAT -- Interface ;;; View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/edcbb7d34826926edc18b487c… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/edcbb7d34826926edc18b487c… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-xoro] 2 commits: Simplify state
by Raymond Toy 16 Dec '17

16 Dec '17

Raymond Toy pushed to branch rtoy-xoro at cmucl / cmucl Commits: 192fe3b6 by Raymond Toy at 2017-12-16T08:16:46-08:00 Simplify state Don't need an array for the cached value; (unsigned-byte 32) is a specialized structure slot, so no consing. Some random cleanups and comments. - - - - - c62e3467 by Raymond Toy at 2017-12-16T08:17:24-08:00 Add tests for xoroshiro generator - - - - - 2 changed files: - src/code/rand-xoroshiro.lisp - + tests/rng.lisp Changes: ===================================== src/code/rand-xoroshiro.lisp ===================================== --- a/src/code/rand-xoroshiro.lisp +++ b/src/code/rand-xoroshiro.lisp @@ -18,7 +18,7 @@ make-xoro-random-state)) (in-package "KERNEL") -(export '(%xorohiro-single-float %xorohiro-double-float xoroshiro-chunk init-random-state)) +(export '(%xorohiro-single-float %xorohiro-double-float xoroshiro-chunk init-xoro-state)) (sys:register-lisp-feature :random-xoroshiro) @@ -80,10 +80,19 @@ (defstruct (xoro-random-state (:constructor make-xoroshiro-object) (:make-load-form-fun :just-dump-it-normally)) + ;; The state of the RNG. The actual algorithm uses 2 64-bit words + ;; of state. To reduce consing, we use an array of double-float's + ;; since a double-float is 64 bits long. At no point do we operate + ;; on these as floats; they're just convenient objects to hold the + ;; state we need. (state (init-xoro-state) :type (simple-array double-float (2))) - (rand (make-array 1 :element-type '(unsigned-byte 32) :initial-element 0) - :type (simple-array (unsigned-byte 32) (1))) + ;; The generator produces 64-bit results. We separate the 64-bit + ;; result into two parts. One is returned and the other is cached + ;; here for later use. + (rand 0 :type (unsigned-byte 32)) + ;; Indicates if RAND holds a valid value. If NIL, we need to + ;; generate a new 64-bit result. (cached-p nil :type (member t nil))) (defvar *xoro-random-state*) @@ -92,13 +101,11 @@ (flet ((copy-random-state (state) (let ((old-state (xoro-random-state-state state)) (new-state - (make-array 2 :element-type 'double-float)) - (new-rand (make-array 1 :element-type '(unsigned-byte 32)))) + (make-array 2 :element-type 'double-float))) (setf (aref new-state 0) (aref old-state 0)) (setf (aref new-state 1) (aref old-state 1)) - (setf (aref new-rand 0) (aref (xoro-random-state-rand state) 0)) (make-xoroshiro-object :state new-state - :rand new-rand + :rand (xoro-random-state-rand state) :cached-p (xoro-random-state-cached-p state))))) (cond ((not state) (copy-random-state *xoro-random-state*)) @@ -106,7 +113,7 @@ (copy-random-state state)) ((eq state t) (make-xoroshiro-object :state (init-xoro-state (generate-seed 4)) - :rand (make-array 1 :element-type '(unsigned-byte 32) :initial-element 0) + :rand 0 :cached-p nil)) (t (error "Argument is not a RANDOM-STATE, T, or NIL: ~S" state))))) @@ -130,15 +137,15 @@ (let ((cached (xoro-random-state-cached-p rng-state))) (cond (cached (setf (xoro-random-state-cached-p rng-state) nil) - (aref (xoro-random-state-rand rng-state) 0)) + (xoro-random-state-rand rng-state)) (t (let ((s (xoro-random-state-state rng-state))) (declare (type (simple-array double-float (2)) s)) (multiple-value-bind (r1 r0) (vm::xoroshiro-next s) - (setf (aref (xoro-random-state-rand rng-state) 0) r1) + (setf (xoro-random-state-rand rng-state) r0) (setf (xoro-random-state-cached-p rng-state) t) - r0)))))) + r1)))))) #-x86 (defun xoroshiro-next (state) @@ -267,7 +274,7 @@ 1d0))) #+double-double -(defun %random-double-double-float (arg state) +(defun %xoroshiro-double-double-float (arg state) (declare (type (double-double-float (0w0)) arg) (type xoro-random-state state)) ;; Generate a 31-bit integer, scale it and sum them up ===================================== tests/rng.lisp ===================================== --- /dev/null +++ b/tests/rng.lisp @@ -0,0 +1,55 @@ +;; Tests for RNG + +(defpackage :rng-tests + (:use :cl :lisp-unit)) + +(in-package "RNG-TESTS") + +(defun 64-bit-rng-state (rng) + (let ((state (kernel::xoro-random-state-state rng))) + (flet ((convert (x) + (multiple-value-bind (hi lo) + (kernel:double-float-bits x) + (logior (ash (ldb (byte 32 0) hi) 32) + lo)))) + (values (convert (aref state 0)) (convert (aref state 1)))))) + +(defun 64-bit-value (rng) + (logior (ash (kernel::xoroshiro-chunk rng) 32) + (kernel::xoroshiro-chunk rng))) + +(defvar *test-state*) + +(define-test rng.initial-state + (setf *test-state* + (kernel::make-xoroshiro-object :state (kernel::init-xoro-state #x12345678) + :rand 0 + :cached-p nil)) + (multiple-value-bind (s0 s1) + (64-bit-rng-state *test-state*) + (assert-equal #x38f1dc39d1906b6f s0) + (assert-equal #xdfe4142236dd9517 s1) + (assert-equal 0 (kernel::xoro-random-state-rand *test-state*)) + (assert-equal nil (kernel::xoro-random-state-cached-p *test-state*)))) + + +(define-test rng.values-test + (assert-equal (list #x38f1dc39d1906b6f #xdfe4142236dd9517) + (multiple-value-list (64-bit-rng-state *test-state*))) + (assert-equal 0 (kernel::xoro-random-state-rand *test-state*)) + (assert-equal nil (kernel::xoro-random-state-cached-p *test-state*)) + + (dolist (item '((#x18d5f05c086e0086 (#x228f4926843b364d #x74dfe78e715c81be)) + (#x976f30b4f597b80b (#x5b6bd4558bd96a68 #x567b7f35650aea8f)) + (#xb1e7538af0e454f7 (#x13e5253e242fac52 #xed380e70d10ab60e)) + (#x011d33aef53a6260 (#x9d0764952ca00d8a #x5251a5cfedd2b4ef)) + (#xef590a651a72c279 (#xba4ef2b425bda963 #x172b965cf56c15ac)) + (#xd17a89111b29bf0f (#x458277a5e5f0a21b #xd1bccfad6564e8d)) + (#x529e44a0bc46f0a8 (#x2becb68d5a7194c7 #x3a6ec964899bb5f3)) + (#x665b7ff1e40d4aba (#xededfd481d0a19fe #x3ea213411827fe9d)) + (#x2c9010893532189b (#xd7bb59bcd8fba26f #x52de763d34fee090)) + (#x2a99cffa0dfa82ff (#xf96e892c62d6ff2e #xc0542ff85652f81e)))) + (destructuring-bind (value state) + item + (assert-equal value (64-bit-value *test-state*)) + (assert-equal state (multiple-value-list (64-bit-rng-state *test-state*)))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/eea11e0772aee7480a290045… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/eea11e0772aee7480a290045… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-xoro] 2 commits: Random cleanups and updates
by Raymond Toy 15 Dec '17

15 Dec '17

Raymond Toy pushed to branch rtoy-xoro at cmucl / cmucl Commits: 8707116f by Raymond Toy at 2017-12-15T15:40:08-08:00 Random cleanups and updates Make some things work on x86: * Can create a random state and initialize it to the desired state * xoroshiro-chunk produces the correct values for the first few calls - - - - - eea11e07 by Raymond Toy at 2017-12-15T15:41:13-08:00 Compile and load xoroshiro rng Make xoroshiro rng available in the core. Basic things work on x86 but not yet integrated in anyway. - - - - - 4 changed files: - src/code/rand-xoroshiro.lisp - src/tools/worldbuild.lisp - src/tools/worldcom.lisp - src/tools/worldload.lisp Changes: ===================================== src/code/rand-xoroshiro.lisp ===================================== --- a/src/code/rand-xoroshiro.lisp +++ b/src/code/rand-xoroshiro.lisp @@ -13,15 +13,16 @@ (in-package "LISP") (intl:textdomain "cmucl") -(export '(random-state random-state-p random *random-state* - make-random-state)) +#+nil +(export '(xoro-random-state xoro-random-state-p xoro-random *xoro-random-state* + make-xoro-random-state)) (in-package "KERNEL") -(export '(%random-single-float %random-double-float random-chunk init-random-state)) +(export '(%xorohiro-single-float %xorohiro-double-float xoroshiro-chunk init-random-state)) (sys:register-lisp-feature :random-xoroshiro) -(defun int-init-random-state (&optional (seed 5772156649015328606) state) +(defun int-init-xoro-state (&optional (seed 5772156649015328606) state) (let ((state (or state (make-array 2 :element-type 'double-float))) (splitmix-state (ldb (byte 64 0) seed))) (flet ((splitmix64 () @@ -46,9 +47,10 @@ (let* ((s0 (splitmix64)) (s1 (splitmix64))) (setf (aref state 0) (make-double s0) - (aref state 1) (make-double s1)))))) + (aref state 1) (make-double s1)) + state)))) -(defun vec-init-random-state (key &optional state) +(defun vec-init-xoro-state (key &optional state) (declare (type (array (unsigned-byte 32) (4)) key) (type (simple-array double-float (2)) state)) (flet ((make-double (hi lo) @@ -58,59 +60,84 @@ (- hi #x100000000)) lo))) (setf (aref state 0) (make-double (aref key 0) (aref key 1)) - (aref state 1) (make-double (aref key 2) (aref key 3))))) + (aref state 1) (make-double (aref key 2) (aref key 3))) + state)) -(defun init-random-state (&optional (seed 5772156649015328606) state) +(defun init-xoro-state (&optional (seed 5772156649015328606) state) "Generate an random state vector from the given SEED. The seed can be either an integer or a vector of (unsigned-byte 32)" (declare (type (or null integer (array (unsigned-byte 32) (*))) seed)) - (etypecase seed - (integer - (int-init-random-state (ldb (byte 64 0) seed) state)) - ((array (unsigned-byte 32) (4)) - (vec-init-random-state seed state)))) + (let ((state (or state (make-array 2 :element-type 'double-float)))) + (etypecase seed + (integer + (int-init-xoro-state (ldb (byte 64 0) seed) state)) + ((array (unsigned-byte 32) (4)) + (vec-init-xoro-state seed state))))) (defstruct (xoro-random-state (:constructor make-xoroshiro-object) (:make-load-form-fun :just-dump-it-normally)) - (state (init-random-state) + (state (init-xoro-state) :type (simple-array double-float (2))) (rand (make-array 1 :element-type '(unsigned-byte 32) :initial-element 0) :type (simple-array (unsigned-byte 32) (1))) (cached-p nil :type (member t nil))) +(defvar *xoro-random-state*) +(defun make-xoro-random-state (&optional state) + (flet ((copy-random-state (state) + (let ((old-state (xoro-random-state-state state)) + (new-state + (make-array 2 :element-type 'double-float)) + (new-rand (make-array 1 :element-type '(unsigned-byte 32)))) + (setf (aref new-state 0) (aref old-state 0)) + (setf (aref new-state 1) (aref old-state 1)) + (setf (aref new-rand 0) (aref (xoro-random-state-rand state) 0)) + (make-xoroshiro-object :state new-state + :rand new-rand + :cached-p (xoro-random-state-cached-p state))))) + (cond ((not state) + (copy-random-state *xoro-random-state*)) + ((xoro-random-state-p state) + (copy-random-state state)) + ((eq state t) + (make-xoroshiro-object :state (init-xoro-state (generate-seed 4)) + :rand (make-array 1 :element-type '(unsigned-byte 32) :initial-element 0) + :cached-p nil)) + (t + (error "Argument is not a RANDOM-STATE, T, or NIL: ~S" state))))) ;;;; Random entries: -;;; Size of the chunks returned by random-chunk. +;;; Size of the chunks returned by xoroshiro-chunk. ;;; -(defconstant random-chunk-length 32) +;;(defconstant random-chunk-length 32) -;;; random-chunk -- Internal +;;; xoroshiro-chunk -- Internal ;;; ;;; This function generaters a 32bit integer between 0 and #xffffffff ;;; inclusive. ;;; -(declaim (inline random-chunk)) +(declaim (inline xoroshiro-chunk)) -(defun random-chunk (rng-state) - (declare (type xoro-state rng-state) +(defun xoroshiro-chunk (rng-state) + (declare (type xoro-random-state rng-state) (optimize (speed 3) (safety 0))) - (let ((cached (xoro-state-cached-p rng-state))) + (let ((cached (xoro-random-state-cached-p rng-state))) (cond (cached - (setf (xoro-state-cached-p rng-state) nil) - (aref (xoro-state-rand rng-state) 0)) + (setf (xoro-random-state-cached-p rng-state) nil) + (aref (xoro-random-state-rand rng-state) 0)) (t - (let ((s (xoro-state-state rng-state))) + (let ((s (xoro-random-state-state rng-state))) (declare (type (simple-array double-float (2)) s)) (multiple-value-bind (r1 r0) (vm::xoroshiro-next s) - (setf (aref (xoro-state-rand rng-state) 0) r1) - (setf (xoro-state-cached-p rng-state) t) + (setf (aref (xoro-random-state-rand rng-state) 0) r1) + (setf (xoro-random-state-cached-p rng-state) t) r0)))))) #-x86 @@ -204,17 +231,17 @@ ;;; between 0.0 and 1.0 by clobbering the significand of 1.0 with random bits, ;;; then subtracting 1.0. This hides the fact that we have a hidden bit. ;;; -(declaim (inline %random-single-float %random-double-float)) +(declaim (inline %xorohiro-single-float %xorohiro-double-float)) (declaim (ftype (function ((single-float (0f0)) random-state) (single-float 0f0)) - %random-single-float)) + %xorohiro-single-float)) ;;; -(defun %random-single-float (arg state) +(defun %xorohiro-single-float (arg state) (declare (type (single-float (0f0)) arg) (type random-state state)) (* arg (- (make-single-float - (dpb (ash (random-chunk state) + (dpb (ash (xoroshiro-chunk state) (- vm:single-float-digits random-chunk-length)) vm:single-float-significand-byte (single-float-bits 1.0))) @@ -222,72 +249,27 @@ ;;; (declaim (ftype (function ((double-float (0d0)) random-state) (double-float 0d0)) - %random-double-float)) + %xorohiro-double-float)) ;;; ;;; 53bit version. ;;; -#-x86 -(defun %random-double-float (arg state) +(defun %xorohiro-double-float (arg state) (declare (type (double-float (0d0)) arg) (type random-state state)) (* arg (- (lisp::make-double-float - (dpb (ash (random-chunk state) + (dpb (ash (xoroshiro-chunk state) (- vm:double-float-digits random-chunk-length vm:word-bits)) vm:double-float-significand-byte (lisp::double-float-high-bits 1d0)) - (random-chunk state)) + (xoroshiro-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)) - (let ((state-vector (random-state-state state))) - (* arg - (- (lisp::make-double-float - (dpb (ash (vm::random-mt19937 state-vector) - (- vm:double-float-digits random-chunk-length - vm:word-bits)) - vm:double-float-significand-byte - (lisp::double-float-high-bits 1d0)) - (vm::random-mt19937 state-vector)) - 1d0)))) - -#+long-float -(declaim (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 - (- (lisp::make-long-float - (lisp::long-float-exp-bits 1l0) - (logior (vm::random-mt19937 state-vector) vm:long-float-hidden-bit) - (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 - (- (lisp::make-long-float - (lisp::long-float-exp-bits 1l0) ; X needs more work - (random-chunk state) (random-chunk state) (random-chunk state)) - 1l0))) #+double-double (defun %random-double-double-float (arg state) (declare (type (double-double-float (0w0)) arg) - (type random-state state)) + (type xoro-random-state state)) ;; Generate a 31-bit integer, scale it and sum them up (let* ((r 0w0) (scale (scale-float 1d0 -31)) @@ -296,10 +278,9 @@ (type double-double-float r) (optimize (speed 3) (inhibit-warnings 3))) (dotimes (k 4) - (setf r (+ r (* mult (ldb (byte 31 0) (random-chunk state))))) + (setf r (+ r (* mult (ldb (byte 31 0) (xoroshiro-chunk state))))) (setf mult (* mult scale))) (* arg r))) - ;;;; Random integers: @@ -321,7 +302,7 @@ ;;; %RANDOM-INTEGER -- Internal ;;; -(defun %random-integer (arg state) +(defun %xorohiro-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) @@ -333,27 +314,27 @@ (rem bits arg)) (declare (fixnum count))))) -(defun random (arg &optional (state *random-state*)) +(defun xoro-random (arg &optional (state *random-state*)) "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 + (declare (inline %xorohiro-single-float %xorohiro-double-float #+long-float %long-float)) (cond ((typep arg '(integer 1 #x100000000)) ;; Let the compiler deftransform take care of this case. (random arg state)) ((and (typep arg 'single-float) (> arg 0.0F0)) - (%random-single-float arg state)) + (%xorohiro-single-float arg state)) ((and (typep arg 'double-float) (> arg 0.0D0)) - (%random-double-float arg state)) + (%xorohiro-double-float arg state)) #+long-float ((and (typep arg 'long-float) (> arg 0.0L0)) - (%random-long-float arg state)) + (%xorohiro-long-float arg state)) #+double-double ((and (typep arg 'double-double-float) (> arg 0.0w0)) - (%random-double-double-float arg state)) + (%xorohiro-double-double-float arg state)) ((and (integerp arg) (> arg 0)) - (%random-integer arg state)) + (%xorohiro-integer arg state)) (t (error 'simple-type-error :expected-type '(or (integer 1) (float (0.0))) :datum arg ===================================== src/tools/worldbuild.lisp ===================================== --- a/src/tools/worldbuild.lisp +++ b/src/tools/worldbuild.lisp @@ -124,6 +124,7 @@ ,@(if (c:backend-featurep :random-mt19937) '("target:code/rand-mt19937") '("target:code/rand")) + "target:code/rand-xoroshiro" "target:code/alieneval" "target:code/c-call" "target:code/sap" ===================================== src/tools/worldcom.lisp ===================================== --- a/src/tools/worldcom.lisp +++ b/src/tools/worldcom.lisp @@ -271,6 +271,7 @@ (if (c:backend-featurep :random-mt19937) (comf "target:code/rand-mt19937") (comf "target:code/rand")) +(comf "target:code/rand-xoroshiro") (comf "target:code/ntrace" :byte-compile *byte-compile*) (comf "target:code/profile") (comf "target:code/sort") ===================================== src/tools/worldload.lisp ===================================== --- a/src/tools/worldload.lisp +++ b/src/tools/worldload.lisp @@ -98,6 +98,7 @@ (maybe-byte-load "code:describe") #+random-mt19937 (maybe-byte-load "code:rand-mt19937") #-random-mt19937 (maybe-byte-load "code:rand") +(maybe-byte-load "code:rand-xoroshiro") (maybe-byte-load "target:pcl/walk") (maybe-byte-load "code:fwrappers") (maybe-byte-load "code:ntrace") View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/b119b34f82807a862a763e93… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/b119b34f82807a862a763e93… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-xoro] Initial implementation of xoroshiro rng
by Raymond Toy 15 Dec '17

15 Dec '17

Raymond Toy pushed to branch rtoy-xoro at cmucl / cmucl Commits: b119b34f by Raymond Toy at 2017-12-15T09:00:38-08:00 Initial implementation of xoroshiro rng Not yet tested or integrated. - - - - - 1 changed file: - + src/code/rand-xoroshiro.lisp Changes: ===================================== src/code/rand-xoroshiro.lisp ===================================== --- /dev/null +++ b/src/code/rand-xoroshiro.lisp @@ -0,0 +1,362 @@ +;;; -*- Mode: Lisp; Package: Kernel -*- +;;; +;;; ********************************************************************** +(ext:file-comment + "$Header: src/code/rand-xoroshiro.lisp $") + +;;; +;;; ********************************************************************** +;;; +;;; Support for the xoroshiro128+ random number generator by David +;;; Blackman and Sebastiano Vigna (vigna(a)acm.org) + +(in-package "LISP") +(intl:textdomain "cmucl") + +(export '(random-state random-state-p random *random-state* + make-random-state)) + +(in-package "KERNEL") +(export '(%random-single-float %random-double-float random-chunk init-random-state)) + +(sys:register-lisp-feature :random-xoroshiro) + +(defun int-init-random-state (&optional (seed 5772156649015328606) state) + (let ((state (or state (make-array 2 :element-type 'double-float))) + (splitmix-state (ldb (byte 64 0) seed))) + (flet ((splitmix64 () + (let ((z (setf splitmix-state + (ldb (byte 64 0) (+ splitmix-state #x9e3779b97f4a7c15))))) + (declare (type (unsigned-byte 64) z)) + (setf z (ldb (byte 64 0) + (* (logxor z (ash z -30)) + #xbf58476d1ce4e5b9))) + (setf z (ldb (byte 64 0) + (* (logxor z (ash z -27)) + #x94d049bb133111eb))) + (logxor z (ash z -31)))) + (make-double (x) + (let ((lo (ldb (byte 32 0) x)) + (hi (ldb (byte 32 32) x))) + (kernel:make-double-float + (if (< hi #x80000000) + hi + (- hi #x100000000)) + lo)))) + (let* ((s0 (splitmix64)) + (s1 (splitmix64))) + (setf (aref state 0) (make-double s0) + (aref state 1) (make-double s1)))))) + +(defun vec-init-random-state (key &optional state) + (declare (type (array (unsigned-byte 32) (4)) key) + (type (simple-array double-float (2)) state)) + (flet ((make-double (hi lo) + (kernel:make-double-float + (if (< hi #x80000000) + hi + (- hi #x100000000)) + lo))) + (setf (aref state 0) (make-double (aref key 0) (aref key 1)) + (aref state 1) (make-double (aref key 2) (aref key 3))))) + + +(defun init-random-state (&optional (seed 5772156649015328606) state) + "Generate an random state vector from the given SEED. The seed can be + either an integer or a vector of (unsigned-byte 32)" + (declare (type (or null integer + (array (unsigned-byte 32) (*))) + seed)) + (etypecase seed + (integer + (int-init-random-state (ldb (byte 64 0) seed) state)) + ((array (unsigned-byte 32) (4)) + (vec-init-random-state seed state)))) + +(defstruct (xoro-random-state + (:constructor make-xoroshiro-object) + (:make-load-form-fun :just-dump-it-normally)) + (state (init-random-state) + :type (simple-array double-float (2))) + (rand (make-array 1 :element-type '(unsigned-byte 32) :initial-element 0) + :type (simple-array (unsigned-byte 32) (1))) + (cached-p nil :type (member t nil))) + + + +;;;; Random entries: + +;;; Size of the chunks returned by random-chunk. +;;; +(defconstant random-chunk-length 32) + +;;; random-chunk -- Internal +;;; +;;; This function generaters a 32bit integer between 0 and #xffffffff +;;; inclusive. +;;; +(declaim (inline random-chunk)) + +(defun random-chunk (rng-state) + (declare (type xoro-state rng-state) + (optimize (speed 3) (safety 0))) + (let ((cached (xoro-state-cached-p rng-state))) + (cond (cached + (setf (xoro-state-cached-p rng-state) nil) + (aref (xoro-state-rand rng-state) 0)) + (t + (let ((s (xoro-state-state rng-state))) + (declare (type (simple-array double-float (2)) s)) + (multiple-value-bind (r1 r0) + (vm::xoroshiro-next s) + (setf (aref (xoro-state-rand rng-state) 0) r1) + (setf (xoro-state-cached-p rng-state) t) + r0)))))) + +#-x86 +(defun xoroshiro-next (state) + (declare (type (simple-array double-float (2)) state)) + (flet ((rotl-55 (x1 x0) + (declare (type (unsigned-byte 32) x0 x1) + (optimize (speed 3) (safety 0))) + ;; x << 55 + (let ((sl55-h (ldb (byte 32 0) (ash x0 (- 55 32)))) + (sl55-l 0)) + ;; x >> 9 + (let ((sr9-h (ash x1 -9)) + (sr9-l (ldb (byte 32 0) + (logior (ash x0 -9) + (ash x1 23))))) + (values (logior sl55-h sr9-h) + (logior sl55-l sr9-l))))) + (rotl-36 (x1 x0) + (declare (type (unsigned-byte 32) x0 x1) + (optimize (speed 3) (safety 0))) + ;; x << 36 + (let ((sl36-h (ldb (byte 32 0) (ash x0 4)))) + ;; x >> 28 + (let ((sr28-l (ldb (byte 32 0) + (logior (ash x0 -28) + (ash x1 4)))) + (sr28-h (ash x1 -28))) + (values (logior sl36-h sr28-h) + sr28-l)))) + (shl-14 (x1 x0) + (declare (type (unsigned-byte 32) x1 x0) + (optimize (speed 3) (safety 0))) + (values (ldb (byte 32 0) + (logior (ash x1 14) + (ash x0 (- 14 32)))) + (ldb (byte 32 0) + (ash x0 14)))) + (make-double (hi lo) + (kernel:make-double-float + (if (< hi #x80000000) + hi + (- hi #x100000000)) + lo))) + (let ((s0-1 0) + (s0-0 0) + (s1-1 0) + (s1-0 0) + (r1 0) + (r0 0)) + (declare (type (unsigned-byte 32)) s0-1 s0-0 s1-1 s1-0 r1 r0) + (multiple-value-bind (x1 x0) + (kernel:double-float-bits (aref state 0)) + (setf s0-1 (ldb (byte 32 0) x1) + s0-0 x0)) + (multiple-value-bind (x1 x0) + (kernel:double-float-bits (aref state 1)) + (setf s1-1 (ldb (byte 32 0) x1) + s1-0 x0)) + + (multiple-value-prog1 + (multiple-value-bind (sum-0 c) + (bignum::%add-with-carry s0-0 s1-0 0) + (values (bignum::%add-with-carry s0-1 s1-1 c) + sum-0)) + ;; s1 ^= s0 + (setf s1-1 (logxor s1-1 s0-1) + s1-0 (logxor s1-0 s0-0)) + ;; s[0] = rotl(s0,55) ^ s1 ^ (s1 << 14) + (multiple-value-setq (s0-1 s0-0) + (rotl-55 s0-1 s0-0)) + (setf s0-1 (logxor s0-1 s1-1) + s0-0 (logxor s0-0 s1-0)) + (multiple-value-bind (s14-1 s14-0) + (shl-14 s1-1 s1-0) + (setf s0-1 (logxor s0-1 s14-1) + s0-0 (logxor s0-0 s14-0))) + (setf (aref s 0) s0-0) + (setf (aref s 1) s0-1) + + (multiple-value-bind (r1 r0) + (rotl-36 s1-1 s1-0) + (setf (aref s 2) r0 + (aref s 3) r1)) + (setf (aref state 0) (make-double s0-1 s0-0) + (aref state 1) (make-double s1-1 s1-0)))))) + +;;; %RANDOM-SINGLE-FLOAT, %RANDOM-DOUBLE-FLOAT -- Interface +;;; +;;; 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 with random bits, +;;; then subtracting 1.0. This hides the fact that we have a hidden bit. +;;; +(declaim (inline %random-single-float %random-double-float)) +(declaim (ftype (function ((single-float (0f0)) random-state) + (single-float 0f0)) + %random-single-float)) +;;; +(defun %random-single-float (arg state) + (declare (type (single-float (0f0)) arg) + (type random-state state)) + (* arg + (- (make-single-float + (dpb (ash (random-chunk state) + (- vm:single-float-digits random-chunk-length)) + 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)) +;;; +;;; 53bit version. +;;; +#-x86 +(defun %random-double-float (arg state) + (declare (type (double-float (0d0)) arg) + (type random-state state)) + (* arg + (- (lisp::make-double-float + (dpb (ash (random-chunk state) + (- vm:double-float-digits random-chunk-length + vm:word-bits)) + vm:double-float-significand-byte + (lisp::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)) + (let ((state-vector (random-state-state state))) + (* arg + (- (lisp::make-double-float + (dpb (ash (vm::random-mt19937 state-vector) + (- vm:double-float-digits random-chunk-length + vm:word-bits)) + vm:double-float-significand-byte + (lisp::double-float-high-bits 1d0)) + (vm::random-mt19937 state-vector)) + 1d0)))) + +#+long-float +(declaim (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 + (- (lisp::make-long-float + (lisp::long-float-exp-bits 1l0) + (logior (vm::random-mt19937 state-vector) vm:long-float-hidden-bit) + (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 + (- (lisp::make-long-float + (lisp::long-float-exp-bits 1l0) ; X needs more work + (random-chunk state) (random-chunk state) (random-chunk state)) + 1l0))) +#+double-double +(defun %random-double-double-float (arg state) + (declare (type (double-double-float (0w0)) arg) + (type random-state state)) + ;; Generate a 31-bit integer, scale it and sum them up + (let* ((r 0w0) + (scale (scale-float 1d0 -31)) + (mult scale)) + (declare (double-float mult) + (type double-double-float r) + (optimize (speed 3) (inhibit-warnings 3))) + (dotimes (k 4) + (setf r (+ r (* mult (ldb (byte 31 0) (random-chunk state))))) + (setf mult (* mult scale))) + (* arg r))) + + +;;;; Random integers: + +;;; Amount we overlap chunks by when building a large integer to make up for +;;; the loss of randomness in the low bits. +;;; +(defconstant random-integer-overlap 3) + +;;; Extra bits of randomness that we generate before taking the value MOD the +;;; limit, to avoid loss of randomness near the limit. +;;; +(defconstant random-integer-extra-bits 10) + +;;; Largest fixnum we can compute from one chunk of bits. +;;; +(defconstant random-fixnum-max + (1- (ash 1 (- random-chunk-length random-integer-extra-bits)))) + + +;;; %RANDOM-INTEGER -- Internal +;;; +(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))))) + +(defun random (arg &optional (state *random-state*)) + "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)) + (cond + ((typep arg '(integer 1 #x100000000)) + ;; Let the compiler deftransform take care of this case. + (random arg state)) + ((and (typep arg 'single-float) (> arg 0.0F0)) + (%random-single-float arg state)) + ((and (typep arg 'double-float) (> arg 0.0D0)) + (%random-double-float arg state)) + #+long-float + ((and (typep arg 'long-float) (> arg 0.0L0)) + (%random-long-float arg state)) + #+double-double + ((and (typep arg 'double-double-float) (> arg 0.0w0)) + (%random-double-double-float arg state)) + ((and (integerp arg) (> arg 0)) + (%random-integer arg state)) + (t + (error 'simple-type-error + :expected-type '(or (integer 1) (float (0.0))) :datum arg + :format-control (intl:gettext "Argument is not a positive integer or a positive float: ~S") + :format-arguments (list arg))))) + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/b119b34f82807a862a763e93e… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/b119b34f82807a862a763e93e… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch rtoy-xoro
by Raymond Toy 14 Dec '17

14 Dec '17

Raymond Toy pushed new branch rtoy-xoro at cmucl / cmucl --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/tree/rtoy-xoro You're receiving this email because of your account on gitlab.common-lisp.net.

1 0