Make random-mt19937 function only when :random-mt19937 is set

;;; transformed to a call to this routine allowing its use in byte

;;; compiled code.

;;;

#+random-mt19937

(defun random-mt19937 (state)

  (declare (type (simple-array (unsigned-byte 32) (627)) state))

  (random-mt19937 state))

  (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)))))