GitLab

at 2017-12-14T19:31:56-08:00

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

Initial implementation of xoroshiro rng

Not yet tested or integrated.

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

Compile and load xoroshiro rng

Make xoroshiro rng available in the core.  Basic things work on x86
but not yet integrated in anyway.

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.

Add tests for xoroshiro generator

Test portable version of xoroshiro-next

Put back the original version, optimized for x86.

Define xoroshiro-next before xoroshiro-chunk.

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

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.

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.

Add cross-compile scripts for building xoroshiro128+.

Set version 21c now.

Bootstrap files are from 21c directory instead of 21b.

Update xoroshiro methods to standard names

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

Disable some deftransforms for now

Add rand-xoroshiro to the build files

Compile/load rand-xoroshiro if :random-xoroshiro is a feature.

Update CI to do the required cross-compile

Update tests to match xoroshiro implementation.

Conditionalize on random-xoroshiro.

These tests test the actual implementation details of the
xoroshiro128+ generator, so conditionalize it for this generator.

Add cross script for sparc

This changes the RNG to xoroshiro128+ for sparc.

Add comment

Add documentation and inline xoroshiro-gen

Not sure about inlining that; it makes random-chunk bigger and all
callers of random-chunk bigger too.

Nice speed win, however.  A test of generating 50000000 single-float
values shows xoroshiro128+ takes 0.58 sec vs 0.98 using MT19937 on my
machine.

Remove old stuff; conditionalize on :random-xoroshiro

Document the jump function and add test.

* rand-xoroshiro.lisp:
  * Rename xoroshiro-jump to random-state-jump
  * Add documentation/comments.
* tests/rng.lisp
  * Add tests for the RNG jump function.

Modify random-state-jump to use 32-bit ints

Break the constants in the jump function into 32-bit chunks so we
operate on 32-bit integers instead of 64-bit integers.

This is a minor optimization.

Fix compiler warning in VEC-INIT-XORO-STATE

Set default value for state in VEC-INIT-XORO-STATE.  If not given,
initialize it to the correct array.

Implement vop for xoroshiro-next

Not yet working.  Cross-compile works and generates appropriate code,
but can't rebuild lisp using the cross-compiled lisp.

Fix logic mistakes in sparc xoroshiro impl

Also compute the array offsets just once so we're consistent between
loading and storing.

Export random-state-jump

Use the xoroshiro vop on sparc

The vop greatly speeds up the generator on sparc.  The time to
generate 10,000,000 single-floats (on a 1 GHz Ultrasparc 3i) is:

mt19937:   1.32 sec
xoroshiro: 1.03 sec

So xoroshiro is 22% faster than mt19937.

Print random state in hex

Add comment for %random-double-float to use xoroshiro-gen directly
instead of random-chunk twice.  A minor micro optimization.

Add comments.

Regenerated from sources

Fix typo in reader conditional.

Don't use the portable xoroshiro-gen on x86 and sparc!

Update release notes

Merge branch 'rtoy-xoro-default' into 'master'

Change random number generator from MT19937 to xoroshiro128+

Closes #48

See merge request cmucl/cmucl!29
     - mkdir snapshot

     - (cd snapshot; tar xjf ../cmucl-21c-x86-linux.tar.bz2; tar xjf ../cmucl-21c-x86-linux.extra.tar.bz2)

   script:

-    - bin/build.sh -C "" -o ./snapshot/bin/lisp

+    - bin/create-target.sh xtarget x86_linux x86

+    - bin/create-target.sh xcross x86_linux x86

+    - bin/cross-build-world.sh -crl xtarget xcross src/bootfiles/21c/boot-21c-cross.lisp ./snapshot/bin/lisp

+    - bin/build.sh -C "" -o xtarget/lisp/lisp

     - bin/make-dist.sh -I dist linux-4

     - bin/run-tests.sh -l dist/bin/lisp 2>&1 | tee test.log

     - mkdir snapshot

     - (cd snapshot; tar xjf ../cmucl-21c-x86-darwin.tar.bz2)

   script:

-    - bin/build.sh -C "" -o ./snapshot/bin/lisp

+    - bin/create-target.sh xtarget x86_darwin

+    - bin/create-target.sh xcross x86_darwin

+    - bin/cross-build-world.sh -crl xtarget xcross src/bootfiles/21c/boot-21c-cross.lisp ./snapshot/bin/lisp

+    - bin/build.sh -C "" -o xtarget/lisp/lisp

     - bin/make-dist.sh -I dist darwin-4

     - bin/run-tests.sh -l dist/bin/lisp 2>&1 | tee test.log
 ENABLE3="yes"

 ENABLE4="yes"

-version=21b

+version=21c

 SRCDIR=src

 BINDIR=bin

 TOOLDIR=$BINDIR

+(in-package :cl-user)

+

+;;; Rename the SPARC package and backend so that new-backend does the

+;;; right thing.

+(rename-package "SPARC" "OLD-SPARC" '("OLD-VM"))

+(setf (c:backend-name c:*native-backend*) "OLD-SPARC")

+

+(c::new-backend "SPARC"

+   ;; Features to add here

+   '(:sparc

+     :sparc-v9				; For Ultrasparc processors

+     :complex-fp-vops			; Some slightly faster FP vops on complex numbers

+     :linkage-table

+     :stack-checking			; Throw error if we run out of stack

+     :heap-overflow-check		; Throw error if we run out of

+					; heap (This requires gencgc!)

+     :gencgc				; Generational GC

+     :relative-package-names		; Relative package names from Allegro

+     :conservative-float-type

+     :hash-new

+     :random-xoroshiro			; xoroshiro128+ RNG

+     :cmu				; Announce this is CMUCL

+     :cmu20 :cmu20a			; Current version identifier

+     :modular-arith			; Modular arithmetic

+     :double-double			; Double-double float support

+     )

+   ;; Features to remove from current *features* here

+   '(:sparc-v8 :sparc-v7		; Choose only one of :sparc-v7, :sparc-v8, :sparc-v9

+     ;; Other architectures we aren't using.

+     :x86 :x86-bootstrap

+     :alpha :osf1 :mips

+     ;; Really old stuff that should have been removed long ago.

+     :propagate-fun-type :propagate-float-type :constrain-float-type

+     ;; Other OSes were not using

+     :openbsd :freebsd :glibc2 :linux

+     :pentium

+     :long-float

+     :new-random

+     :random-mt19937			; MT-19937 generator

+     :small))

+

+;;; May need to add some symbols to *features* and

+;;; sys::*runtime-features* as well.  This might be needed even if we

+;;; have those listed above, because of the code checks for things in

+;;; *features* and not in the backend-features..  So do that here.

+

+

+;;; Extern-alien-name for the new backend.

+(in-package :vm)

+(defun extern-alien-name (name)

+  (declare (type simple-string name))

+  #+(and bsd (not elf))

+  (concatenate 'string "_" name)

+  #-(and bsd (not elf))

+  name)

+;; When compiling the compiler, vm:fixup-code-object and

+;; vm:sanctify-for-execution are undefined.  Import these to get rid

+;; of that error.

+(import 'old-vm::fixup-code-object)

+(import 'old-vm::sanctify-for-execution)

+(export 'extern-alien-name)

+(export 'fixup-code-object)

+(export 'sanctify-for-execution)

+

+(in-package :cl-user)

+

+;;; Compile the new backend.

+(pushnew :bootstrap *features*)

+(pushnew :building-cross-compiler *features*)

+(load "target:tools/comcom")

+

+;;; Load the new backend.

+(setf (search-list "c:")

+      '("target:compiler/"))

+(setf (search-list "vm:")

+      '("c:sparc/" "c:generic/"))

+(setf (search-list "assem:")

+      '("target:assembly/" "target:assembly/sparc/"))

+

+;; Load the backend of the compiler.

+

+(in-package "C")

+

+(load "vm:vm-macs")

+(load "vm:parms")

+(load "vm:objdef")

+(load "vm:interr")

+(load "assem:support")

+

+(load "target:compiler/srctran")

+(load "vm:vm-typetran")

+(load "target:compiler/float-tran")

+(load "target:compiler/saptran")

+

+(load "vm:macros")

+(load "vm:utils")

+

+(load "vm:vm")

+(load "vm:insts")

+(load "vm:primtype")

+(load "vm:move")

+(load "vm:sap")

+(load "vm:system")

+(load "vm:char")

+(load "vm:float")

+

+(load "vm:memory")

+(load "vm:static-fn")

+(load "vm:arith")

+(load "vm:cell")

+(load "vm:subprim")

+(load "vm:debug")

+(load "vm:c-call")

+(load "vm:print")

+(load "vm:alloc")

+(load "vm:call")

+(load "vm:nlx")

+(load "vm:values")

+(load "vm:array")

+(load "vm:pred")

+(load "vm:type-vops")

+

+(load "assem:assem-rtns")

+

+(load "assem:array")

+(load "assem:arith")

+(load "assem:alloc")

+

+(load "c:pseudo-vops")

+

+(check-move-function-consistency)

+

+(load "vm:new-genesis")

+

+;;; OK, the cross compiler backend is loaded.

+

+(setf *features* (remove :building-cross-compiler *features*))

+

+;;; Info environment hacks.

+(macrolet ((frob (&rest syms)

+	     `(progn ,@(mapcar #'(lambda (sym)

+				   `(defconstant ,sym

+				      (symbol-value

+				       (find-symbol ,(symbol-name sym)

+						    :vm))))

+			       syms))))

+  (frob OLD-VM:BYTE-BITS OLD-VM:WORD-BITS

+	OLD-VM:CHAR-BITS

+	OLD-VM:CHAR-BYTES

+	OLD-VM:LOWTAG-BITS

+	#+long-float OLD-VM:SIMPLE-ARRAY-LONG-FLOAT-TYPE 

+	OLD-VM:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE 

+	OLD-VM:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE

+	#+long-float OLD-VM:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE 

+	OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE 

+	OLD-VM:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE

+	OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE 

+	OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE

+	OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE 

+	OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE 

+	OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE 

+	OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE 

+	OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE

+	OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE 

+	OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE

+	OLD-VM:SIMPLE-BIT-VECTOR-TYPE

+	OLD-VM:SIMPLE-STRING-TYPE OLD-VM:SIMPLE-VECTOR-TYPE 

+	OLD-VM:SIMPLE-ARRAY-TYPE OLD-VM:VECTOR-DATA-OFFSET

+	OLD-VM:DOUBLE-FLOAT-DIGITS

+	old-vm:single-float-digits

+	OLD-VM:DOUBLE-FLOAT-EXPONENT-BYTE

+	OLD-VM:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX

+	OLD-VM:DOUBLE-FLOAT-SIGNIFICAND-BYTE

+	OLD-VM:SINGLE-FLOAT-EXPONENT-BYTE

+	OLD-VM:SINGLE-FLOAT-NORMAL-EXPONENT-MAX

+	OLD-VM:SINGLE-FLOAT-SIGNIFICAND-BYTE

+	)

+  #+double-double

+  (frob OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE

+	OLD-VM:SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE)

+  )

+

+;; Modular arith hacks.  When cross-compiling, the compiler wants to

+;; constant-fold some stuff, and it needs the following functions to

+;; do so.  This just gets rid of the hundreds of errors that happen.

+(setf (fdefinition 'vm::ash-left-mod32) #'old-vm::ash-left-mod32)

+(setf (fdefinition 'vm::lognot-mod32) #'old-vm::lognot-mod32)

+;; End modular arith hacks

+

+(let ((function (symbol-function 'kernel:error-number-or-lose)))

+  (let ((*info-environment* (c:backend-info-environment c:*target-backend*)))

+    (setf (symbol-function 'kernel:error-number-or-lose) function)

+    (setf (info function kind 'kernel:error-number-or-lose) :function)

+    (setf (info function where-from 'kernel:error-number-or-lose) :defined)))

+

+(defun fix-class (name)

+  (let* ((new-value (find-class name))

+	 (new-layout (kernel::%class-layout new-value))

+	 (new-cell (kernel::find-class-cell name))

+	 (*info-environment* (c:backend-info-environment c:*target-backend*)))

+    (remhash name kernel::*forward-referenced-layouts*)

+    (kernel::%note-type-defined name)

+    (setf (info type kind name) :instance)

+    (setf (info type class name) new-cell)

+    (setf (info type compiler-layout name) new-layout)

+    new-value))

+(fix-class 'c::vop-parse)

+(fix-class 'c::operand-parse)

+

+#+random-mt19937

+(declaim (notinline kernel:random-chunk))

+

+(setf c:*backend* c:*target-backend*)

+

+;;; Extern-alien-name for the new backend.

+(in-package :vm)

+(defun extern-alien-name (name)

+  (declare (type simple-string name))

+  name)

+(export 'extern-alien-name)

+(export 'fixup-code-object)

+(export 'sanctify-for-execution)

+(in-package :cl-user)

+

+;;; Don't load compiler parts from the target compilation

+

+(defparameter *load-stuff* nil)

+

+;; Sometimes during cross-compile sparc::any-reg isn't defined during

+;; cross-compile.

+;;

+;; hack, hack, hack: Make old-vm::any-reg the same as

+;; sparc::any-reg as an SC.  Do this by adding old-vm::any-reg

+;; to the hash table with the same value as sparc::any-reg.

+(let ((ht (c::backend-sc-names c::*target-backend*)))

+  (setf (gethash 'old-vm::any-reg ht)

+	(gethash 'vm::any-reg ht)))
+;; Basic cross-compile script for cross-compiling from x86 to x86.

+;; May require tweaking for more difficult cross-compiles.

+

+(in-package :cl-user)

+

+;;; Rename the X86 package and backend so that new-backend does the

+;;; right thing.

+(rename-package "X86" "OLD-X86" '("OLD-VM"))

+(setf (c:backend-name c:*native-backend*) "OLD-X86")

+

+(c::new-backend "X86"

+   ;; Features to add here.  These are just examples.  You may not

+   ;; need to list anything here.  We list them here anyway as a

+   ;; record of typical features for all x86 ports.

+   '(:x86 :i486 :pentium

+     :stack-checking			; Catches stack overflow

+     :heap-overflow-check		; Catches heap overflows

+     :relative-package-names		; relative package names

+     :mp				; multiprocessing

+     :gencgc				; Generational GC

+     :conservative-float-type

+     :hash-new

+     :random-xoroshiro			; xoroshiro128+ RNG

+     :cmu :cmu20 :cmu20a		; Version features

+     :double-double			; double-double float support

+     )

+   ;; Features to remove from current *features* here.  Normally don't

+   ;; need to list anything here unless you are trying to remove a

+   ;; feature.

+   '(:x86-bootstrap

+     ;; :alpha :osf1 :mips

+     :propagate-fun-type :propagate-float-type :constrain-float-type

+     ;; :openbsd :freebsd :glibc2 :linux

+     :long-float :new-random :small

+     :random-mt19937))

+

+;;; Compile the new backend.

+(pushnew :bootstrap *features*)

+(pushnew :building-cross-compiler *features*)

+

+;; Make fixup-code-object and sanctify-for-execution in the VM package

+;; be the same as the original.  Needed to get rid of a compiler error

+;; in generic/core.lisp.  (This halts cross-compilations if the

+;; compiling lisp uses the -batch flag.

+(import 'old-vm::fixup-code-object "VM")

+(import 'old-vm::sanctify-for-execution "VM")

+(export 'vm::fixup-code-object "VM")

+(export 'vm::sanctify-for-execution "VM")

+

+(do-external-symbols (sym "OLD-VM")

+  (export (intern (symbol-name sym) "VM") "VM"))

+

+(load "target:tools/comcom")

+

+;;; Load the new backend.

+(setf (search-list "c:")

+      '("target:compiler/"))

+(setf (search-list "vm:")

+      '("c:x86/" "c:generic/"))

+(setf (search-list "assem:")

+      '("target:assembly/" "target:assembly/x86/"))

+

+;; Load the backend of the compiler.

+

+(in-package "C")

+

+(load "vm:vm-macs")

+(load "vm:parms")

+(load "vm:objdef")

+(load "vm:interr")

+(load "assem:support")

+

+(load "target:compiler/srctran")

+(load "vm:vm-typetran")

+(load "target:compiler/float-tran")

+(load "target:compiler/saptran")

+

+(load "vm:macros")

+(load "vm:utils")

+

+(load "vm:vm")

+(load "vm:insts")

+(load "vm:primtype")

+(load "vm:move")

+(load "vm:sap")

+(when (target-featurep :sse2)

+  (load "vm:sse2-sap"))

+(load "vm:system")

+(load "vm:char")

+(if (target-featurep :sse2)

+    (load "vm:float-sse2")

+    (load "vm:float"))

+

+(load "vm:memory")

+(load "vm:static-fn")

+(load "vm:arith")

+(load "vm:cell")

+(load "vm:subprim")

+(load "vm:debug")

+(load "vm:c-call")

+(if (target-featurep :sse2)

+    (load "vm:sse2-c-call")

+    (load "vm:x87-c-call"))

+

+(load "vm:print")

+(load "vm:alloc")

+(load "vm:call")

+(load "vm:nlx")

+(load "vm:values")

+;; These need to be loaded before array because array wants to use

+;; some vops as templates.

+(load (if (target-featurep :sse2)

+	  "vm:sse2-array"

+	  "vm:x87-array"))

+(load "vm:array")

+(load "vm:pred")

+(load "vm:type-vops")

+

+(load "assem:assem-rtns")

+

+(load "assem:array")

+(load "assem:arith")

+(load "assem:alloc")

+

+(load "c:pseudo-vops")

+

+(check-move-function-consistency)

+

+(load "vm:new-genesis")

+

+;;; OK, the cross compiler backend is loaded.

+

+(setf *features* (remove :building-cross-compiler *features*))

+

+;;; Info environment hacks.

+(macrolet ((frob (&rest syms)

+	     `(progn ,@(mapcar #'(lambda (sym)

+				   `(defconstant ,sym

+				      (symbol-value

+				       (find-symbol ,(symbol-name sym)

+						    :vm))))

+			       syms))))

+  (frob OLD-VM:BYTE-BITS OLD-VM:WORD-BITS

+	OLD-VM:CHAR-BITS

+	OLD-VM:CHAR-BYTES

+	#+long-float OLD-VM:SIMPLE-ARRAY-LONG-FLOAT-TYPE 

+	OLD-VM:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE 

+	OLD-VM:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE

+	#+long-float OLD-VM:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE 

+	OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE 

+	OLD-VM:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE

+	OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE 

+	OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE

+	OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE 

+	OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE 

+	OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE 

+	OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE 

+	OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE

+	OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE 

+	OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE

+	OLD-VM:SIMPLE-BIT-VECTOR-TYPE

+	OLD-VM:SIMPLE-STRING-TYPE OLD-VM:SIMPLE-VECTOR-TYPE 

+	OLD-VM:SIMPLE-ARRAY-TYPE OLD-VM:VECTOR-DATA-OFFSET

+	OLD-VM:DOUBLE-FLOAT-EXPONENT-BYTE

+	OLD-VM:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX 

+	OLD-VM:DOUBLE-FLOAT-SIGNIFICAND-BYTE

+	OLD-VM:SINGLE-FLOAT-EXPONENT-BYTE

+	OLD-VM:SINGLE-FLOAT-NORMAL-EXPONENT-MAX

+	OLD-VM:SINGLE-FLOAT-SIGNIFICAND-BYTE

+	)

+  #+double-double

+  (frob OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE

+	OLD-VM:SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE))

+

+;; Modular arith hacks

+(setf (fdefinition 'vm::ash-left-mod32) #'old-vm::ash-left-mod32)

+(setf (fdefinition 'vm::lognot-mod32) #'old-vm::lognot-mod32)

+;; End arith hacks

+

+(let ((function (symbol-function 'kernel:error-number-or-lose)))

+  (let ((*info-environment* (c:backend-info-environment c:*target-backend*)))

+    (setf (symbol-function 'kernel:error-number-or-lose) function)

+    (setf (info function kind 'kernel:error-number-or-lose) :function)

+    (setf (info function where-from 'kernel:error-number-or-lose) :defined)))

+

+(defun fix-class (name)

+  (let* ((new-value (find-class name))

+	 (new-layout (kernel::%class-layout new-value))

+	 (new-cell (kernel::find-class-cell name))

+	 (*info-environment* (c:backend-info-environment c:*target-backend*)))

+    (remhash name kernel::*forward-referenced-layouts*)

+    (kernel::%note-type-defined name)

+    (setf (info type kind name) :instance)

+    (setf (info type class name) new-cell)

+    (setf (info type compiler-layout name) new-layout)

+    new-value))

+(fix-class 'c::vop-parse)

+(fix-class 'c::operand-parse)

+

+#+random-mt19937

+(declaim (notinline kernel:random-chunk))

+

+(setf c:*backend* c:*target-backend*)

+

+;;; Extern-alien-name for the new backend.

+(in-package :vm)

+(defun extern-alien-name (name)

+  (declare (type simple-string name))

+  #-elf

+  (concatenate 'simple-string "_" name)

+  #+elf

+  name)

+(export 'extern-alien-name)

+(in-package :cl-user)

+

+;;; Don't load compiler parts from the target compilation

+

+(defparameter *load-stuff* nil)

+

+;; hack, hack, hack: Make old-vm::any-reg the same as

+;; x86::any-reg as an SC.  Do this by adding old-vm::any-reg

+;; to the hash table with the same value as x86::any-reg.

+(let ((ht (c::backend-sc-names c::*target-backend*)))

+  (setf (gethash 'old-vm::any-reg ht)

+	(gethash 'vm::any-reg ht)))
+;; Cross-compile script to change the default random number generator

+;; from MT19937 to xoroshiro128+.

+

+;; The cross-script is basically the default platform script, but we

+;; remove :random-mt19937 and add :random-xoroshiro to the backend

+;; features.

+

+#+x86

+(load "src/bootfiles/21c/boot-21c-cross-x86.lisp")

+

+#+sparc

+(load "src/bootfiles/21c/boot-21c-cross-sparc.lisp")

+
 	   "SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-P"

 	   "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-ERROR"

 	   "DD-PI"

-	   "INVALID-CASE"))

+	   "INVALID-CASE")

+  #+random-xoroshiro

+  (:export "RANDOM-STATE-JUMP"))

 (dolist

     (name

+;;; -*- Mode: Lisp; Package: Kernel -*-

+;;;

+;;; **********************************************************************

+;;; This code was written as part of CMU Common Lisp and has been

+;;; placed in the public domain, and is provided 'as is'.

+;;;

+(ext:file-comment

+  "$Header: src/code/rand-xoroshiro.lisp $")

+

+;;;

+;;; **********************************************************************

+;;;

+;;; Support for the xoroshiro128+ random number generator by David

+;;; Blackman and Sebastiano Vigna (vigna@acm.org). See

+;;; http://xoroshiro.di.unimi.it/.

+

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

+	  random-state-jump))

+

+(sys:register-lisp-feature :random-xoroshiro)

+

+

+;;;; Random state hackery:

+

+;; Generate a random seed that can be used for seeding the generator.

+;; If /dev/urandom is available, it is used to generate random data as

+;; the seed.  Otherwise, the current time is used as the seed.

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

+    (flet ((splitmix64 ()

+	     ;; See http://xoroshiro.di.unimi.it/splitmix64.c for the

+	     ;; definitive reference.  The basic algorithm, where x is

+	     ;; the 64-bit state of the generator, is:

+	     ;;

+	     ;;   uint64_t z = (x += 0x9e3779b97f4a7c15);

+	     ;;   z = (z ^ (z >> 30)) * 0xbf58476d1ce4e5b9;

+	     ;;   z = (z ^ (z >> 27)) * 0x94d049bb133111eb;

+	     ;;   return z ^ (z >> 31);

+	     ;;

+	     ;; This is only used occasionally for initializing the

+	     ;; RNG, so this is a very straight-forward

+	     ;; implementation.

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

+	   state))))

+

+;; Initialize from an array.  The KEY is a 2-element array of unsigned

+;; 64-bit integers.  The state is set to the given 64-bit integer

+;; values.

+(defun vec-init-xoro-state (key &optional (state (make-array 2 :element-type 'double-float)))

+  (declare (type (array (unsigned-byte 64) (2)) key)

+	   (type (simple-array double-float (2)) state))

+  (flet ((make-double (x)

+	   (declare (type (unsigned-byte 64) 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))

+

+;; The default seed is the digits of Euler's constant, 0.5772....

+(defun init-random-state (&optional (seed 5772156649015328606) state)

+  _N"Generate an random state vector from the given SEED.  The seed can be

+  either an integer or a vector of (unsigned-byte 64)"

+  (declare (type (or null integer

+		     (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 64) (2))

+       (vec-init-xoro-state seed state)))))

+

+(defstruct (random-state

+	     (:constructor make-random-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

+  ;; 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-random-state)

+   :type (simple-array double-float (2)))

+  ;; 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)))

+

+(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 (random-state-state rng-state)))

+    (pprint-logical-block (stream nil :prefix "#S(" :suffix ")")

+      (prin1 '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-random-state stream)

+	(write-char #\space stream)

+	(flet ((c (x)

+		 (multiple-value-bind (hi lo)

+		     (double-float-bits x)

+		   (logior (ash (ldb (byte 32 0) hi) 32)

+			   lo))))

+	  (write (make-array 2 :element-type '(unsigned-byte 64)

+			     :initial-contents (list (c (aref state 0))

+						     (c (aref state 1))))

+		 :stream stream

+		 :base 16

+		 :radix t)))

+      (write-char #\space stream)

+      (pprint-newline :linear stream)

+

+      (prin1 :rand stream)

+      (write-char #\space stream)

+      (pprint-newline :miser stream)

+      (prin1 (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 (random-state-cached-p rng-state) stream))))

+

+(defvar *random-state*

+  (make-random-object))

+

+(defun make-random-state (&optional state)

+  _N"Make a random state object.  If STATE is not supplied, return a copy

+  of the default random state.  If STATE is a random state, then return a

+  copy of it.  If STATE is T then return a random state generated from

+  the universal time or /dev/urandom if available."

+  (flet ((copy-random-state (state)

+	   (let ((old-state (random-state-state state))

+		 (new-state

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

+	     (make-random-object :state new-state

+				 :rand (random-state-rand state)

+				 :cached-p (random-state-cached-p state)))))

+    (cond ((not state)

+	   (copy-random-state *random-state*))

+	  ((random-state-p state)

+	   (copy-random-state state))

+	  ((eq state t)

+	   (make-random-object :state (init-random-state (generate-seed 4))

+			       :rand 0

+			       :cached-p nil))

+	  (t

+	   (error _"Argument is not a RANDOM-STATE, T, or NIL: ~S" state)))))

+

+(defun rand-initializer ()

+  (init-random-state (generate-seed)

+                     (random-state-state *random-state*)))

+

+(pushnew 'rand-initializer ext:*after-save-initializations*)

+

+;;;; Random entries:

+

+;; Sparc and x86 have vops to implement xoroshiro-gen that are much

+;; faster than the portable lisp version.  Use them.

+#+(or x86 sparc)

+(declaim (inline xoroshiro-gen))

+#+(or x86 sparc)

+(defun xoroshiro-gen (state)

+  (declare (type (simple-array double-float (2)) state)

+	   (optimize (speed 3) (safety 0)))

+  (vm::xoroshiro-next state))

+

+#-(or x86 sparc)

+(defun xoroshiro-gen (state)

+  (declare (type (simple-array double-float (2)) state)

+	   (optimize (speed 3) (safety 0)))

+  ;; Portable implementation of the xoroshiro128+ generator. See

+  ;; http://xoroshiro.di.unimi.it/xoroshiro128plus.c for the

+  ;; definitive definition.

+  ;;

+  ;; uint64_t s[2];

+  ;;

+  ;; static inline uint64_t rotl(const uint64_t x, int k) {

+  ;; 	return (x << k) | (x >> (64 - k));

+  ;; }

+  ;;

+  ;; uint64_t next(void) {

+  ;; 	const uint64_t s0 = s[0];

+  ;; 	uint64_t s1 = s[1];

+  ;; 	const uint64_t result = s0 + s1;

+  ;;

+  ;; 	s1 ^= s0;

+  ;; 	s[0] = rotl(s0, 55) ^ s1 ^ (s1 << 14); // a, b

+  ;; 	s[1] = rotl(s1, 36); // c

+  ;;

+  ;; 	return result;

+  ;; }

+  ;;

+  (flet ((rotl-55 (x1 x0)

+	   ;; Rotate [x1|x0] left 55 bits, returning the result as two

+	   ;; values.

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

+	   ;; Rotate [x1|x0] left 36 bits, returning the result as two

+	   ;; values.

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

+	   ;; Shift [x1|x0] left by 14 bits, returning the result as

+	   ;; two values.

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

+      (declare (type (unsigned-byte 32) s0-1 s0-0 s1-1 s1-0))

+      ;; Load the state to s0 and s1. s0-1 is the high 32-bit part and

+      ;; s0-0 is the low 32-bit part of the 64-bit value.  Similarly

+      ;; for s1.

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

+

+      ;; Compute the 64-bit random value: s0 + s1

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

+

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

+

+;;; 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 random-state rng-state)

+	   (optimize (speed 3) (safety 0)))

+  (let ((cached (random-state-cached-p rng-state)))

+    (cond (cached

+	   (setf (random-state-cached-p rng-state) nil)

+	   (random-state-rand rng-state))

+	  (t

+	   (let ((s (random-state-state rng-state)))

+	     (declare (type (simple-array double-float (2)) s))

+	     (multiple-value-bind (r1 r0)

+		 (xoroshiro-gen s)

+	       (setf (random-state-rand rng-state) r0)

+	       (setf (random-state-cached-p rng-state) t)

+	       r1))))))

+

+

+;;; %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))

+;;;

+;;; 53-bit version.

+;;;

+(defun %random-double-float (arg state)

+  (declare (type (double-float (0d0)) arg)

+	   (type random-state state))

+  ;; xoroshiro-gen produces 64-bit values.  Should we use that

+  ;; directly to get the random bits instead of two calls to

+  ;; RANDOM-CHUNK?

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

+

+#+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*))

+  _N"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))

+  (cond

+    ((typep arg '(integer 1 #x100000000))

+     ;; Let the compiler deftransform take care of this case.

+     (%random-integer 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))

+    #+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 _"Argument is not a positive integer or a positive float: ~S")

+	    :format-arguments (list arg)))))

+

+;; Jump function for the generator.  See the jump function in

+;; http://xoroshiro.di.unimi.it/xoroshiro128plus.c

+(defun random-state-jump (&optional (rng-state *random-state*))

+  _N"Jump the RNG-STATE.  This is equivalent to 2^64 calls to the

+  xoroshiro128+ generator.  It can be used to generate 2^64

+  non-overlapping subsequences for parallel computations."

+  (declare (type random-state rng-state))

+  (let ((state (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)))

+    ;; The constants are #xbeac0467eba5facb and #xd86b048b86aa9922,

+    ;; and we process these numbers starting from the LSB.  We want ot

+    ;; process these in 32-bit chunks, so word-reverse the constants.

+    (dolist (jump '(#xeba5facb #xbeac0467 #x86aa9922 #xd86b048b))

+      (declare (type (unsigned-byte 32) jump))

+      (dotimes (b 32)

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

+	(xoroshiro-gen 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))
 ;;; 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))

   (frob %random-single-float single-float)

   (frob %random-double-float double-float))

-#-(or new-random random-mt19937)

+#-(or new-random random-mt19937 rand-xoroshiro)

 (deftransform random ((num &optional state)

 		      ((integer 1 #.random-fixnum-max) &optional *))

   _N"use inline fixnum operations"

   '(values (truncate (%random-double-float (coerce num 'double-float)

 		      (or state *random-state*)))))

-#+random-mt19937

+#+(or random-mt19937)

 (deftransform random ((num &optional state)

 		      ((integer 1 #.(expt 2 32)) &optional *))

   _N"use inline (unsigned-byte 32) operations"

 		 (unsigned-byte 32))

   "recode as shifts and adds"

   (*-transformer y))

+

+(in-package "VM")

+

+#+random-xoroshiro

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

+  ;; Must be sure to use %o registers for temps because we want to use

+  ;; 64-bit registers that will get preserved.

+  (:temporary (:sc unsigned-reg :offset nl5-offset) s0)

+  (:temporary (:sc unsigned-reg :offset nl4-offset) s1)

+  (:temporary (:sc unsigned-reg :offset nl3-offset) t0)

+  (:generator 10

+    (let ((s0-offset (+ (* 0 double-float-bytes)

+			(- (* vm:vector-data-offset vm:word-bytes)

+			   vm:other-pointer-type)))

+	  (s1-offset (+ (* 1 double-float-bytes)

+			(- (* vm:vector-data-offset vm:word-bytes)

+			   vm:other-pointer-type))))

+      (inst ldx s0 state s0-offset)

+      (inst ldx s1 state s1-offset)

+      ;; result = s0 + s1, split into low 32-bits in r0 and high 32-bits

+      ;; in r1

+      (inst add r0 s0 s1)

+      (inst srlx r1 r0 32)

+

+      ;; s1 = s1 ^ s0

+      (inst xor s1 s0)

+

+      ;; s0 = rotl(s0,55) = s0 << 55 | s0 >> 9

+      (inst sllx t0 s0 55)

+      (inst srlx s0 s0 9)

+      (inst or s0 t0)

+

+      (inst xor s0 s1)			; s0 = s0 ^ s1

+      (inst sllx t0 s1 14)		; t0 = s1 << 14

+      (inst xor s0 t0)			; s0 = s0 ^ t0

+

+      (inst stx s0 state s0-offset)

+

+      ;; s1 = rotl(s1, 36) = s1 << 36 | s1 >> 28, using t0 as temp

+      (inst sllx t0 s1 36)

+      (inst srlx s1 28)

+      (inst or s1 t0)

+

+      (inst stx s1 state s1-offset))))

+)
 		 (vm::ash-right-unsigned num (- shift)))))

 	  (t

 	   (give-up)))))

+

+(in-package "VM")

+

+#+random-xoroshiro

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

+)    

+    
   ;; 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

   (packed-shift psllw #x71 #xf1 6)

   (packed-shift psrad #x72 #xe2 4)

   (packed-shift psraw #x71 #xe1 4))
-
   * Feature enhancements

     * Update to ASDF 3.3.1, fixing issues introduced in 3.3.0

   * Changes

+    * x86 and sparc have replaced the MT19937 RNG with xoroshiro128+ RNG.

+      * The required state for this generator is just 4 32-bit words instead of the 600+ for MT19937.

+      * The generator is also faster than MT19937 (approximately 28% faster on x86 and 18% on sparc).

+      * The new function `KERNEL:RANDOM-STATE-JUMP` modifies the given state to jump 2^64 samples ahead, allowing 2^64 non-overlapping sequences.

+

   * ANSI compliance fixes:

   * Bug fixes:

   * Gitlab tickets:

 #: src/code/intl.lisp src/compiler/globaldb.lisp src/code/defstruct.lisp

 #: src/code/remote.lisp src/code/wire.lisp src/code/internet.lisp

 #: src/code/loop.lisp src/code/run-program.lisp src/code/parse-time.lisp

-#: src/code/profile.lisp src/code/ntrace.lisp src/code/rand-mt19937.lisp

+#: src/code/profile.lisp src/code/ntrace.lisp src/code/rand-xoroshiro.lisp

 #: src/code/debug.lisp src/code/debug-int.lisp src/code/debug-info.lisp

 #: src/code/eval.lisp src/code/filesys.lisp src/code/pathname.lisp

 #: src/code/fd-stream.lisp src/code/extfmts.lisp src/code/serve-event.lisp

 msgid "Type \"yes\" for yes or \"no\" for no. "

 msgstr ""

-#: src/code/rand-mt19937.lisp

+#: src/code/rand-xoroshiro.lisp

 msgid ""

 "Generate an random state vector from the given SEED.  The seed can be\n"

-"  either an integer or a vector of (unsigned-byte 32)"

+"  either an integer or a vector of (unsigned-byte 64)"

 msgstr ""

-#: src/code/rand-mt19937.lisp

+#: src/code/rand-xoroshiro.lisp

 msgid ""

 "Make a random state object.  If STATE is not supplied, return a copy\n"

 "  of the default random state.  If STATE is a random state, then return a\n"

 "  the universal time or /dev/urandom if available."

 msgstr ""

-#: src/code/rand-mt19937.lisp

-msgid "Argument is not a RANDOM-STATE, T or NIL: ~S"

+#: src/code/rand-xoroshiro.lisp

+msgid "Argument is not a RANDOM-STATE, T, or NIL: ~S"

 msgstr ""

-#: src/code/rand-mt19937.lisp

+#: src/code/rand-xoroshiro.lisp

 msgid ""

 "Generate a uniformly distributed pseudo-random number between zero\n"

 "  and Arg.  State, if supplied, is the random state to use."

 msgstr ""

-#: src/code/rand-mt19937.lisp

+#: src/code/rand-xoroshiro.lisp

 msgid "Argument is not a positive integer or a positive float: ~S"

 msgstr ""

+#: src/code/rand-xoroshiro.lisp

+msgid ""

+"Jump the RNG-STATE.  This is equivalent to 2^64 calls to the\n"

+"  xoroshiro128+ generator.  It can be used to generate 2^64\n"

+"  non-overlapping subsequences for parallel computations."

+msgstr ""

+

 #: src/code/ntrace.lisp

 msgid ""

 "This is bound to the returned values when evaluating :BREAK-AFTER and\n"

 msgstr ""

 #: src/compiler/float-tran.lisp

-msgid "Shouldn't happen"

-msgstr ""

-

-#: src/compiler/float-tran.lisp

 msgid "Can't open-code float to rational comparison."

 msgstr ""

     "target:code/scavhook"

     "target:code/save"

-    ,@(if (c:backend-featurep :random-mt19937)

-	  '("target:code/rand-mt19937")

-	  '("target:code/rand"))

+    ,@(cond ((c:backend-featurep :random-mt19937)

+	     '("target:code/rand-mt19937"))

+	    ((c:backend-featurep :random-xoroshiro)

+	     '("target:code/rand-xoroshiro"))

+	    (t

+	     '("target:code/rand")))

+    "target:code/rand-xoroshiro"

     "target:code/alieneval"

     "target:code/c-call"

     "target:code/sap"

 (comf "target:code/debug" :byte-compile t)

 (comf "target:code/query" :byte-compile *byte-compile*)

-(if (c:backend-featurep :random-mt19937)

-    (comf "target:code/rand-mt19937")

-    (comf "target:code/rand"))

+(cond ((c:backend-featurep :random-mt19937)

+       (comf "target:code/rand-mt19937"))

+      ((c:backend-featurep :random-xoroshiro)

+       (comf "target:code/rand-xoroshiro"))

+      (t

+       (comf "target:code/rand")))

 (comf "target:code/ntrace" :byte-compile *byte-compile*)

 (comf "target:code/profile")

 (comf "target:code/sort")

 (maybe-byte-load "code:time")

 (maybe-byte-load "code:tty-inspect")

 (maybe-byte-load "code:describe")

-#+random-mt19937 (maybe-byte-load "code:rand-mt19937")

-#-random-mt19937 (maybe-byte-load "code:rand")

+#+random-mt19937

+(maybe-byte-load "code:rand-mt19937")

+#+random-xoroshiro

+(maybe-byte-load "code:rand-xoroshiro")

+#-(or random-mt19937 random-xoroshiro)

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

+;; Tests for RNG

+

+(defpackage :rng-tests

+  (:use :cl :lisp-unit))

+

+(in-package "RNG-TESTS")

+

+(defun 64-bit-rng-state (rng)

+  (let ((state (kernel::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::random-chunk rng) 32)

+	  (kernel::random-chunk rng)))

+

+(defvar *test-state*)

+  

+#+random-xoroshiro

+(define-test rng.initial-state

+  (setf *test-state*

+	(kernel::make-random-object :state (kernel::init-random-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::random-state-rand *test-state*))

+    (assert-equal nil (kernel::random-state-cached-p *test-state*))))

+

+

+#+random-xoroshiro

+(define-test rng.values-test

+  (assert-equal (list #x38f1dc39d1906b6f #xdfe4142236dd9517)

+		(multiple-value-list (64-bit-rng-state *test-state*)))

+  (assert-equal 0 (kernel::random-state-rand *test-state*))

+  (assert-equal nil (kernel::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*))))))

+

+(define-test rng.jump

+  (setf *test-state*

+	(kernel::make-random-object :state (kernel::init-random-state #x12345678)

+				    :rand 0

+				    :cached-p nil))

+  (dolist (result '((#x291ddf8e6f6a7b67 #x1f9018a12f9e031f)

+		    (#x88a7aa12158558d0 #xe264d785ab1472d9)

+		    (#x207e16f73c51e7ba #x999c8a0a9a8d87c0)

+		    (#x28f8959d3bcf5ff1 #x38091e563ab6eb98)))

+    (kernel:random-state-jump *test-state*)

+    (assert-equal result (multiple-value-list

+			  (64-bit-rng-state *test-state*)))))

Raymond Toy pushed to branch master at cmucl / cmucl

Commits:

18 changed files:

Changes: