From 9bba906a8af6a14ab0e1588b2b00342ac21732ee Mon Sep 17 00:00:00 2001 From: Raymond Toy <toy.raymond@gmail.com> Date: Thu, 14 Dec 2017 19:31:56 -0800 Subject: [PATCH] Initial support for xoroshiro128+ RNG Not yet integrated but the basic vop and other methods do work and produce the same output as the reference C code (not included). --- src/code/x86-vm.lisp | 126 ++++++++++++++++++++++++++++++++++++ src/compiler/x86/arith.lisp | 118 +++++++++++++++++++++++++++++++++ src/compiler/x86/insts.lisp | 7 +- 3 files changed, 249 insertions(+), 2 deletions(-) diff --git a/src/code/x86-vm.lisp b/src/code/x86-vm.lisp index 987d1a345..6996a3c0d 100644 --- a/src/code/x86-vm.lisp +++ b/src/code/x86-vm.lisp @@ -698,3 +698,129 @@ (multiple-value-bind (fop dst src) (get-fp-operation scp) (values fop (list dst src)))) + +(defstruct (xoro-state (:constructor %make-xoro-state)) + (state (make-array 2 :element-type 'double-float) + :type (simple-array double-float (2))) + (rand (make-array 1 :element-type '(unsigned-byte 32)) + :type (simple-array (unsigned-byte 32) (1))) + (cached-p nil :type (member t nil))) + +(defun make-xoro-state (&optional init) + (let* ((s (%make-xoro-state)) + (state (xoro-state-state s))) + (flet ((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)))) + (etypecase init + (null + s) + ((vector integer 2) + (setf (aref state 0) (make-double (ldb (byte 64 0) (aref init 0))) + (aref state 1) (make-double (ldb (byte 64 0) (aref init 1))))) + (integer + (set-state (ldb (byte 64 0) init)) + (let* ((s0 (splitmix64)) + (s1 (splitmix64))) + (setf (aref state 0) (make-double s0) + (aref state 1) (make-double s1))) + ))) + s)) + +#|| +(defun xoroshiro (rng-state) + (declare (type xoro-state rng-state) + (optimize (speed 3) (safety 0))) + (let ((s (xoro-state- rng-state))) + (declare (type (simple-array double-float (2)) s)) + (multiple-value-bind (r1 r0 new-s1 new-s0) + (vm::xoroshiro-next (aref s 1) (aref s 0)) + (setf (aref s 1) new-s1 + (aref s 0) new-s0) + (values r1 r0)))) + + +||# + +(defun xoroshiro (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)))))) + +(defun xoroshiro-jump (rng-state) + (declare (type xoro-state rng-state)) + (let ((state (xoro-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 (vm::xoro-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)))))) + +(let ((state 0)) + (declare (type (unsigned-byte 64) state)) + (defun set-state (x) + (setf state (ldb (byte 64 0) x))) + (defun get-state () + state) + (defun splitmix64 () + (let ((z (setf state + (ldb (byte 64 0) (+ 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))))) diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp index c1868d432..16defb23f 100644 --- a/src/compiler/x86/arith.lisp +++ b/src/compiler/x86/arith.lisp @@ -1833,3 +1833,121 @@ (vm::ash-right-unsigned num (- shift))))) (t (give-up))))) + +(in-package "VM") +#+nil +(progn +(defknown xoroshiro-next (double-float double-float) + (values (unsigned-byte 32) (unsigned-byte 32) double-float double-float) + (movable)) + +(define-vop (xoroshiro-next) + (:policy :fast-safe) + (:translate xoroshiro-next) + (:args (old-s1 :scs (double-reg) :to (:result 3)) + (old-s0 :scs (double-reg) :to (:result 3))) + (:arg-types double-float double-float) + (:results (r1 :scs (unsigned-reg)) + (r0 :scs (unsigned-reg)) + (s1 :scs (double-reg)) + (s0 :scs (double-reg))) + (:result-types unsigned-num unsigned-num double-float double-float) + (:temporary (:sc double-reg) t0) + (:generator 10 + (inst movapd t0 old-s0) + (inst paddq t0 old-s1) ; t0 = old-s0 + old-s1 + (inst movd r0 t0) ; r0 = low 32-bits of t0 + (inst psrlq t0 32) + (inst movd r1 t0) ; r1 = high 32-bits of t0 + ;; s1 ^= s0 + (inst movapd s1 old-s1) ; s1 = old-s1 + (inst xorpd s1 old-s0) ; s1 = old-s0 ^ old-s1 + ;; rotl(s0, 55) = s0 << 55 | (s0 >> 9) + (inst movapd s0 old-s0) ; s0 = old-s0 + (inst movapd t0 old-s0) ; t0 = old-s0 + (inst psllq s0 55) ; s0 = s0 << 55 + (inst psrlq t0 9) ; t0 = s0 >> 9 + (inst orpd s0 t0) ; s0 = rotl(s0,55) = s0 << 55 | s0 >> 9 + (inst xorpd s0 s1) ; s0 = rotl(s0,55) ^ s1 + (inst movapd t0 s1) ; t0 = s1 + (inst psllq t0 14) ; t0 = s1 << 14 + (inst xorpd s0 t0) ; s0 = rotl(s0,55) ^ s1 ^ (s1 << 14) + (inst movapd t0 s1) ; t0 = s1 + (inst psllq t0 36) ; t0 = s1 << 36 + (inst psrlq s1 28) ; s1 = s1 >> 28 + (inst orpd s1 t0) ; s1 = rotl(new-s1, 36) + + )) +) + +(progn +(defknown xoroshiro-next ((simple-array double-float (2))) + (values (unsigned-byte 32) (unsigned-byte 32)) + (movable)) + +(define-vop (xoroshiro-next) + (:policy :fast-safe) + (:translate xoroshiro-next) + (:args (state :scs (descriptor-reg) :to (:result 3))) + (:arg-types simple-array-double-float) + (:results (r1 :scs (unsigned-reg)) + (r0 :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:temporary (:sc double-reg) s0) + (:temporary (:sc double-reg) s1) + (:temporary (:sc double-reg) t0) + (:generator 10 + ;; s0 = state[0] + (inst movsd s0 (make-ea :dword :base state + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 8 0)) + vm:other-pointer-type))) + ;; s1 = state[1] + (inst movsd s1 (make-ea :dword :base state + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 8 1)) + vm:other-pointer-type))) + ;; Compute result = s0 + s1 + (inst movapd t0 s0) + (inst paddq t0 s1) + ;; Save the 64-bit result as two 32-bit results + (inst movd r0 t0) + (inst psrlq t0 32) + (inst movd r1 t0) + + ;; s1 = s1 ^ s0 + (inst xorpd s1 s0) + + ;; s0 = rotl(s0,55) = s0 << 55 | s0 >> 9 + (inst movapd t0 s0) + (inst psllq s0 55) ; s0 = s0 << 55 + (inst psrlq t0 9) ; t0 = s0 >> 9 + (inst orpd s0 t0) ; s0 = rotl(s0, 55) + + (inst movapd t0 s1) + (inst xorpd s0 s1) ; s0 = s0 ^ s1 + (inst psllq t0 14) ; t0 = s1 << 14 + (inst xorpd s0 t0) ; s0 = s0 ^ t0 + (inst movsd (make-ea :dword :base state + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 8 0)) + vm:other-pointer-type)) + s0) + + ;; s1 = rotl(s1, 36) = s1 << 36 | s1 >> 28, using t0 as temp + (inst movapd t0 s1) + (inst psllq s1 36) + (inst psrlq t0 28) + (inst orpd s1 t0) + + (inst movsd (make-ea :dword :base state + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 8 1)) + vm:other-pointer-type)) + s1))) +) + \ No newline at end of file diff --git a/src/compiler/x86/insts.lisp b/src/compiler/x86/insts.lisp index 0a63c0bf8..0964ea05c 100644 --- a/src/compiler/x86/insts.lisp +++ b/src/compiler/x86/insts.lisp @@ -3195,7 +3195,11 @@ ;; dst[63:0] = dst[63:0] ;; dst[127:64] = src[63:0] (define-regular-sse-inst unpcklpd #x66 #x14 t) - (define-regular-sse-inst unpcklps nil #x14 t)) + (define-regular-sse-inst unpcklps nil #x14 t) + + ;; PADDQ 64-bit integer add + (define-regular-sse-inst paddq #x66 #xd4) + ) (define-instruction popcnt (segment dst src) (:printer ext-reg-reg/mem @@ -3539,4 +3543,3 @@ (packed-shift psllw #x71 #xf1 6) (packed-shift psrad #x72 #xe2 4) (packed-shift psraw #x71 #xe1 4)) - -- GitLab