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