[Git][cmucl/cmucl][master] 38 commits: Initial support for xoroshiro128+ RNG
Raymond Toy
rtoy at common-lisp.net
Fri Dec 29 18:32:14 UTC 2017
Raymond Toy pushed to branch master at cmucl / cmucl
Commits:
9bba906a by Raymond Toy 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).
- - - - -
b119b34f by Raymond Toy at 2017-12-15T09:00:38-08:00
Initial implementation of xoroshiro rng
Not yet tested or integrated.
- - - - -
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.
- - - - -
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
- - - - -
edcbb7d3 by Raymond Toy at 2017-12-16T20:53:21-08:00
Test portable version of xoroshiro-next
- - - - -
95a01145 by Raymond Toy at 2017-12-16T21:05:41-08:00
Put back the original version, optimized for x86.
- - - - -
d539b6a0 by Raymond Toy at 2017-12-17T13:04:59-08:00
Define xoroshiro-next before xoroshiro-chunk.
- - - - -
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.)
- - - - -
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.
- - - - -
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.
- - - - -
09bbc248 by Raymond Toy at 2017-12-19T17:32:05-08:00
Add cross-compile scripts for building xoroshiro128+.
- - - - -
38db18cb by Raymond Toy at 2017-12-19T17:33:27-08:00
Set version 21c now.
Bootstrap files are from 21c directory instead of 21b.
- - - - -
cba9bad7 by Raymond Toy at 2017-12-19T17:34:28-08:00
Update xoroshiro methods to standard names
- - - - -
8d363473 by Raymond Toy at 2017-12-19T17:35:19-08:00
Make random-mt19937 function only when :random-mt19937 is set
- - - - -
7362e561 by Raymond Toy at 2017-12-19T17:35:41-08:00
Disable some deftransforms for now
- - - - -
68596489 by Raymond Toy at 2017-12-19T17:36:27-08:00
Add rand-xoroshiro to the build files
Compile/load rand-xoroshiro if :random-xoroshiro is a feature.
- - - - -
b8d326cc by Raymond Toy at 2017-12-19T17:46:39-08:00
Update CI to do the required cross-compile
- - - - -
f5df8745 by Raymond Toy at 2017-12-19T18:18:23-08:00
Update tests to match xoroshiro implementation.
- - - - -
be17d9f4 by Raymond Toy at 2017-12-19T19:01:35-08:00
Conditionalize on random-xoroshiro.
These tests test the actual implementation details of the
xoroshiro128+ generator, so conditionalize it for this generator.
- - - - -
0c2284a7 by Raymond Toy at 2017-12-19T19:03:21-08:00
Add cross script for sparc
This changes the RNG to xoroshiro128+ for sparc.
- - - - -
4720c794 by Raymond Toy at 2017-12-19T19:03:27-08:00
Add comment
- - - - -
5ca98fb1 by Raymond Toy at 2017-12-20T13:59:20-08:00
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.
- - - - -
96c90caf by Raymond Toy at 2017-12-20T14:00:25-08:00
Remove old stuff; conditionalize on :random-xoroshiro
- - - - -
9cd66071 by Raymond Toy at 2017-12-20T16:30:41-08:00
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.
- - - - -
96c58393 by Raymond Toy at 2017-12-27T09:46:59-08:00
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.
- - - - -
ab6d2c6a by Raymond Toy at 2017-12-27T10:29:26-08:00
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.
- - - - -
164cf685 by Raymond Toy at 2017-12-27T12:17:25-08:00
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.
- - - - -
6fbd959e by Raymond Toy at 2017-12-28T09:04:13-08:00
Fix logic mistakes in sparc xoroshiro impl
Also compute the array offsets just once so we're consistent between
loading and storing.
- - - - -
11a14537 by Raymond Toy at 2017-12-28T09:04:27-08:00
Export random-state-jump
- - - - -
448e9970 by Raymond Toy at 2017-12-28T09:53:39-08:00
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.
- - - - -
58f107b1 by Raymond Toy at 2017-12-28T12:26:31-08:00
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.
- - - - -
86599903 by Raymond Toy at 2017-12-28T19:53:42-08:00
Add comments.
- - - - -
562752c0 by Raymond Toy at 2017-12-28T19:54:11-08:00
Regenerated from sources
- - - - -
e5bd7ef7 by Raymond Toy at 2017-12-29T08:57:34-08:00
Fix typo in reader conditional.
Don't use the portable xoroshiro-gen on x86 and sparc!
- - - - -
d8ef7876 by Raymond Toy at 2017-12-29T10:20:13-08:00
Update release notes
- - - - -
fb3f58ea by Raymond Toy at 2017-12-29T18:32:07+00:00
Merge branch 'rtoy-xoro-default' into 'master'
Change random number generator from MT19937 to xoroshiro128+
Closes #48
See merge request cmucl/cmucl!29
- - - - -
18 changed files:
- .gitlab-ci.yml
- bin/build.sh
- + src/bootfiles/21c/boot-21c-cross-sparc.lisp
- + src/bootfiles/21c/boot-21c-cross-x86.lisp
- + src/bootfiles/21c/boot-21c-cross.lisp
- src/code/exports.lisp
- + src/code/rand-xoroshiro.lisp
- src/code/x86-vm.lisp
- src/compiler/float-tran.lisp
- src/compiler/sparc/arith.lisp
- src/compiler/x86/arith.lisp
- src/compiler/x86/insts.lisp
- src/general-info/release-21d.md
- src/i18n/locale/cmucl.pot
- src/tools/worldbuild.lisp
- src/tools/worldcom.lisp
- src/tools/worldload.lisp
- + tests/rng.lisp
Changes:
=====================================
.gitlab-ci.yml
=====================================
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -8,7 +8,10 @@ linux-runner:
- 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
@@ -20,6 +23,9 @@ osx-runner:
- 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
=====================================
bin/build.sh
=====================================
--- a/bin/build.sh
+++ b/bin/build.sh
@@ -39,7 +39,7 @@ ENABLE2="yes"
ENABLE3="yes"
ENABLE4="yes"
-version=21b
+version=21c
SRCDIR=src
BINDIR=bin
TOOLDIR=$BINDIR
=====================================
src/bootfiles/21c/boot-21c-cross-sparc.lisp
=====================================
--- /dev/null
+++ b/src/bootfiles/21c/boot-21c-cross-sparc.lisp
@@ -0,0 +1,237 @@
+(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)))
=====================================
src/bootfiles/21c/boot-21c-cross-x86.lisp
=====================================
--- /dev/null
+++ b/src/bootfiles/21c/boot-21c-cross-x86.lisp
@@ -0,0 +1,225 @@
+;; 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)))
=====================================
src/bootfiles/21c/boot-21c-cross.lisp
=====================================
--- /dev/null
+++ b/src/bootfiles/21c/boot-21c-cross.lisp
@@ -0,0 +1,13 @@
+;; 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")
+
=====================================
src/code/exports.lisp
=====================================
--- a/src/code/exports.lisp
+++ b/src/code/exports.lisp
@@ -2550,7 +2550,9 @@
"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
=====================================
src/code/rand-xoroshiro.lisp
=====================================
--- /dev/null
+++ b/src/code/rand-xoroshiro.lisp
@@ -0,0 +1,534 @@
+;;; -*- 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 at 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))
=====================================
src/code/x86-vm.lisp
=====================================
--- a/src/code/x86-vm.lisp
+++ b/src/code/x86-vm.lisp
@@ -413,6 +413,7 @@
;;; 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))
=====================================
src/compiler/float-tran.lisp
=====================================
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -236,7 +236,7 @@
(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"
@@ -259,7 +259,7 @@
'(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"
=====================================
src/compiler/sparc/arith.lisp
=====================================
--- a/src/compiler/sparc/arith.lisp
+++ b/src/compiler/sparc/arith.lisp
@@ -2588,3 +2588,60 @@
(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))))
+)
=====================================
src/compiler/x86/arith.lisp
=====================================
--- a/src/compiler/x86/arith.lisp
+++ b/src/compiler/x86/arith.lisp
@@ -1833,3 +1833,78 @@
(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)))
+)
+
\ No newline at end of file
=====================================
src/compiler/x86/insts.lisp
=====================================
--- 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))
-
=====================================
src/general-info/release-21d.md
=====================================
--- a/src/general-info/release-21d.md
+++ b/src/general-info/release-21d.md
@@ -21,6 +21,11 @@ public domain.
* 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/i18n/locale/cmucl.pot
=====================================
--- a/src/i18n/locale/cmucl.pot
+++ b/src/i18n/locale/cmucl.pot
@@ -33,7 +33,7 @@ msgstr ""
#: 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
@@ -12105,13 +12105,13 @@ msgstr ""
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"
@@ -12119,20 +12119,27 @@ msgid ""
" 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"
@@ -18869,10 +18876,6 @@ msgid "use inline (unsigned-byte 32) operations"
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 ""
=====================================
src/tools/worldbuild.lisp
=====================================
--- a/src/tools/worldbuild.lisp
+++ b/src/tools/worldbuild.lisp
@@ -121,9 +121,13 @@
"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"
=====================================
src/tools/worldcom.lisp
=====================================
--- a/src/tools/worldcom.lisp
+++ b/src/tools/worldcom.lisp
@@ -268,9 +268,12 @@
(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")
=====================================
src/tools/worldload.lisp
=====================================
--- a/src/tools/worldload.lisp
+++ b/src/tools/worldload.lisp
@@ -96,8 +96,13 @@
(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/rng.lisp
=====================================
--- /dev/null
+++ b/tests/rng.lisp
@@ -0,0 +1,70 @@
+;; 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*)))))
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/757fb170ee958123f0d44e7f0731e22668993a18...fb3f58eaecd9a8dd57105f94fd96ad95b94fb7f3
---
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/757fb170ee958123f0d44e7f0731e22668993a18...fb3f58eaecd9a8dd57105f94fd96ad95b94fb7f3
You're receiving this email because of your account on gitlab.common-lisp.net.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20171229/216fbb38/attachment-0001.html>
More information about the cmucl-cvs
mailing list