cs: rumble layer tweaks inspired by investigations of random
The main (slightly) effective change here is to avoid disturbing loop patterns within the Rumble layer's implementation. Most of the commit is a commented out, updated version of the Scheme implementation of MRG32k3a `random`. With the latest improvements for unboxed floating-point arithmetic, performance is relatively good, but it doesn't catch up to the C compiler's output. On an x86_64 MacBook (i7 4870HQ) using LLVM or a Raspberry Pi 3 using GCC, it's about 50% slower compared to C (in contrast to 300% slower before unboxing). It's almost the same speed on a older x86_64 Linux machine (i7 2600) using GCC. Where the C compiler wins, maybe it's due to the use of SIMD instructions in the C output for x86_64 and Arm32. Switching to the Scheme implementation of `random` would probably be fine, but aisde from the satisfaction of being in Scheme, there's no reason to pay the sometimes 50% penalty for now.
This commit is contained in:
Matthew Flatt
parent
e7f2331663
commit
f3dd113e9d
|
|
@ -84,19 +84,23 @@
|
|||
#'((begin e ...) ...))])
|
||||
(list #'(case-lambda [args body] ...)
|
||||
(append-all #'(lifts ...))))]
|
||||
[(let loop ([arg val] ...) e ...)
|
||||
[(let loop ([arg val] ...) body-e ...)
|
||||
(symbol? (syntax->datum #'loop))
|
||||
(cond
|
||||
[(true-loop? (syntax->datum #'loop) #t #'(begin body-e ...))
|
||||
(lift-local-functions-in-named-let e env binds mutated)]
|
||||
[else
|
||||
(generate-lifted env binds mutated
|
||||
#'loop ; name
|
||||
#'(arg ...) ; argument names
|
||||
#'(begin e ...) ; body
|
||||
#'(begin body-e ...) ; body
|
||||
#t ; recursive
|
||||
(lambda (defn-to-lift new-loop-name free-vars wrap-bind-of-lifted)
|
||||
(with-syntax ([(free-var ...) free-vars]
|
||||
[new-loop-name new-loop-name]
|
||||
[defn-to-lift defn-to-lift])
|
||||
#`((new-loop-name val ... free-var ...)
|
||||
(defn-to-lift)))))]
|
||||
(defn-to-lift)))))])]
|
||||
[(let* () e ...)
|
||||
(lift-local-functions #`(begin e ...) env binds mutated)]
|
||||
[(let* ([id rhs] . more-binds) e ...)
|
||||
|
|
@ -206,6 +210,20 @@
|
|||
(wrap-bind-of-lifted e)
|
||||
(cons defn-to-lift lifts)))))]))])))]))]
|
||||
|
||||
[lift-local-functions-in-named-let
|
||||
(lambda (e env binds mutated)
|
||||
(syntax-case e ()
|
||||
[(form loop ([id rhs] ...) e ...)
|
||||
(let ([body-env (add-args env #'(id ...))])
|
||||
(with-syntax ([((new-rhs lifts) ...)
|
||||
(map (lambda (rhs)
|
||||
(lift-local-functions rhs env binds mutated))
|
||||
#'(rhs ...))])
|
||||
(with-syntax ([(new-body body-lifts)
|
||||
(lift-local-functions #'(begin e ...) body-env binds mutated)])
|
||||
(list #'(form loop ([id new-rhs] ...) new-body)
|
||||
(append #'body-lifts (append-all #'(lifts ...)))))))]))]
|
||||
|
||||
[split-proc-binds
|
||||
;; Helper to split `lambda` from non-`lambda`
|
||||
(lambda (form-binds)
|
||||
|
|
@ -341,6 +359,79 @@
|
|||
(extract-free-vars #'(begin rator rand ...) env)]
|
||||
[_ '()]))]
|
||||
|
||||
[true-loop?
|
||||
(lambda (name tail? e)
|
||||
(syntax-case e (quote begin begin0 if cond lambda case-lambda
|
||||
let* let letrec let-values
|
||||
fluid-let-syntax let-syntax
|
||||
set!)
|
||||
[id
|
||||
(symbol? (syntax->datum #'id))
|
||||
(not (eq? (syntax->datum #'id) name))]
|
||||
[(set! id rhs)
|
||||
(and (not (eq? (syntax->datum #'id) name))
|
||||
(true-loop? name #f e))]
|
||||
[(quote _) '()]
|
||||
[(begin e ... e0)
|
||||
(and (#%andmap (lambda (e) (true-loop? name #f e))
|
||||
#'(e ...))
|
||||
(true-loop? name tail? #'e0))]
|
||||
[(begin0 e ...)
|
||||
(#%andmap (lambda (e) (true-loop? name #f e))
|
||||
#'(e ...))]
|
||||
[(if e0 e1 e2)
|
||||
(and (true-loop? name #f #'e0)
|
||||
(true-loop? name tail? #'e1)
|
||||
(true-loop? name tail? #'e2))]
|
||||
[(cond [test expr ...] ...)
|
||||
(#%andmap (lambda (b) (true-loop? name #f b))
|
||||
#'((begin test expr ...) ...))]
|
||||
[(lambda args e ...) #f]
|
||||
[(case-lambda [args e ...] ...) #f]
|
||||
[(let loop ([arg val] ...) e ...)
|
||||
(or (eq? name (syntax->datum #'loop))
|
||||
(and
|
||||
(#%andmap (lambda (val) (true-loop? name #f val))
|
||||
#'(val ...))
|
||||
(true-loop? name tail? #'(begin e ...))))]
|
||||
[(let* () e ...)
|
||||
(true-loop? name tail? #'(begin e ...))]
|
||||
[(let* ([id rhs] . binds) e ...)
|
||||
(true-loop? name tail? #`(let ([id rhs]) (let* binds e ...)))]
|
||||
[(let ([id rhs] ...) e ...)
|
||||
(and (#%andmap (lambda (rhs) (true-loop? name #f #'rhs))
|
||||
#'(rhs ...))
|
||||
(or (#%ormap (lambda (id) (eq? (syntax->datum id) name))
|
||||
#'(id ...))
|
||||
(true-loop? name tail? #'(begin e ...))))]
|
||||
[(let-values ([(id ...) rhs] ...) e ...)
|
||||
(and (#%andmap (lambda (rhs) (true-loop? name #f #'rhs))
|
||||
#'(rhs ...))
|
||||
(or (#%ormap (lambda (id) (eq? (syntax->datum id) name))
|
||||
#'(id ... ...))
|
||||
(true-loop? name tail? #'(begin e ...))))]
|
||||
[(letrec ([id rhs] ...) e ...)
|
||||
(or (#%ormap (lambda (id) (eq? (syntax->datum id) name))
|
||||
#'(id ...))
|
||||
(and (#%andmap (lambda (rhs) (true-loop? name #f #'rhs))
|
||||
#'(rhs ...))
|
||||
(true-loop? name tail? #'(begin e ...))))]
|
||||
[(fluid-let-syntax ([id rhs] ...) e ...)
|
||||
(or (#%ormap (lambda (id) (eq? (syntax->datum id) name))
|
||||
#'(id ...))
|
||||
(true-loop? name tail? #'(begin e ...)))]
|
||||
[(let-syntax ([id rhs] ...) e ...)
|
||||
(or (#%ormap (lambda (id) (eq? (syntax->datum id) name))
|
||||
#'(id ...))
|
||||
(true-loop? name tail? #'(begin e ...)))]
|
||||
[(rator rand ...)
|
||||
(and (or (and tail?
|
||||
(eq? name (syntax->datum #'rator)))
|
||||
(true-loop? name #f #'rator))
|
||||
(#%andmap (lambda (rand) (true-loop? name #f rand))
|
||||
#'(rand ...)))]
|
||||
[_ #t]))]
|
||||
|
||||
[filter-shadowed-binds
|
||||
;; Simplify `binds` to drop bindings that are shadowned by
|
||||
;; `env` or by earlier bindings
|
||||
|
|
|
|||
|
|
@ -1,3 +1,300 @@
|
|||
#|
|
||||
|
||||
;; This Scheme implentation forms reasonably well, with suitable unboxing
|
||||
;; of floating-point calculations. But C compilers are still a little
|
||||
;; better at floating-point (e.g., using instructions that work on
|
||||
;; multiple values at once), so we still use a C implementation in
|
||||
;; the Chez Scheme kernel for now.
|
||||
|
||||
;; /*
|
||||
;; Based on
|
||||
;;
|
||||
;; Implementation of SRFI-27 core generator in C for Racket.
|
||||
;; dvanhorn@cs.uvm.edu
|
||||
;;
|
||||
;; and
|
||||
;;
|
||||
;; 54-BIT (double) IMPLEMENTATION IN C OF THE "MRG32K3A" GENERATOR
|
||||
;; ===============================================================
|
||||
;;
|
||||
;; Sebastian.Egner@philips.com, Mar-2002, in ANSI-C and Scheme 48 0.57
|
||||
;;
|
||||
;; This code is a C-implementation of Pierre L'Ecuyer's MRG32k3a generator.
|
||||
;; The code uses (double)-arithmetics, assuming that it covers the range
|
||||
;; {-2^53..2^53-1} exactly (!). The code of the generator is based on the
|
||||
;; L'Ecuyer's own implementation of the generator. Please refer to the
|
||||
;; file 'mrg32k3a.scm' for more information about the method.
|
||||
;; */
|
||||
|
||||
;; The Generator
|
||||
;; =============
|
||||
|
||||
;; moduli of the components
|
||||
(define Im1 #xffffff2f)
|
||||
(define Im2 #xffffa6bb)
|
||||
(define m1 4294967087.0)
|
||||
(define m2 4294944443.0)
|
||||
|
||||
;; recursion coefficients of the components
|
||||
(define a12 1403580.0)
|
||||
(define a13n 810728.0)
|
||||
(define a21 527612.0)
|
||||
(define a23n 1370589.0)
|
||||
|
||||
;; normalization factor 1/(m1 + 1)
|
||||
(define norm 2.328306549295728e-10)
|
||||
|
||||
(define-record pseudo-random-generator
|
||||
((mutable double x10) (mutable double x11) (mutable double x12)
|
||||
(mutable double x20) (mutable double x21) (mutable double x22))
|
||||
()
|
||||
((constructor new-pseudo-random-generator)))
|
||||
|
||||
;; We can use
|
||||
;; (fixnum->flonum (flonum->fixnum x))
|
||||
;; as a fast fltruncate below because x is always in fixnum range:
|
||||
;; each element of a random generator is between 0 and 4294967086, so
|
||||
;; (fl/ (fl- (fl* a12 x_i) (fl* a13n x_j)) m1) is between 0 and
|
||||
;; 1403580, where the upper bound is x_i = 4294967086 and x_j = 0.
|
||||
|
||||
(define-syntax-rule (mrg32k3a s-expr) ;; -> flonum in {0..m1-1}
|
||||
;; component 1
|
||||
(let* ([s s-expr]
|
||||
[x10 (fl- (fl* a12 (pseudo-random-generator-x11 s))
|
||||
(fl* a13n (pseudo-random-generator-x12 s)))]
|
||||
[k10 (fixnum->flonum (flonum->fixnum (fl/ x10 m1)))] ; fast fltruncate (see above)
|
||||
[x10 (fl- x10 (fl* k10 m1))]
|
||||
[x10 (if (fl< x10 0.0)
|
||||
(fl+ x10 m1)
|
||||
x10)])
|
||||
(set-pseudo-random-generator-x12! s (pseudo-random-generator-x11 s))
|
||||
(set-pseudo-random-generator-x11! s (pseudo-random-generator-x10 s))
|
||||
(set-pseudo-random-generator-x10! s x10)
|
||||
|
||||
;; component 2
|
||||
(let* ([x20 (fl- (fl* a21 (pseudo-random-generator-x20 s))
|
||||
(fl* a23n (pseudo-random-generator-x22 s)))]
|
||||
[k20 (fixnum->flonum (flonum->fixnum (fl/ x20 m2)))]
|
||||
[x20 (fl- x20 (fl* k20 m2))]
|
||||
[x20 (if (fl< x20 0.0)
|
||||
(fl+ x20 m2)
|
||||
x20)])
|
||||
(set-pseudo-random-generator-x22! s (pseudo-random-generator-x21 s))
|
||||
(set-pseudo-random-generator-x21! s (pseudo-random-generator-x20 s))
|
||||
(set-pseudo-random-generator-x20! s x20)
|
||||
|
||||
;; combination of components
|
||||
(let* ([y (fl- x10 x20)])
|
||||
(if (fl< y 0.0)
|
||||
(fl+ y m1)
|
||||
y)))))
|
||||
|
||||
(define (make-pseudo-random-generator)
|
||||
(let ([s (new-pseudo-random-generator 1.0 1.0 1.0 1.0 1.0 1.0)])
|
||||
(pseudo-random-generator-seed! s (current-milliseconds))
|
||||
s))
|
||||
|
||||
(define (pseudo-random-generator-seed! s x)
|
||||
;; Initial values are from Sebastian Egner's implementation:
|
||||
(set-pseudo-random-generator-x10! s 1062452522.0)
|
||||
(set-pseudo-random-generator-x11! s 2961816100.0)
|
||||
(set-pseudo-random-generator-x12! s 342112271.0)
|
||||
(set-pseudo-random-generator-x20! s 2854655037.0)
|
||||
(set-pseudo-random-generator-x21! s 3321940838.0)
|
||||
(set-pseudo-random-generator-x22! s 3542344109.0)
|
||||
(srand-half! s (bitwise-and x #xFFFF))
|
||||
(srand-half! s (bitwise-and (bitwise-arithmetic-shift-right x 16) #xFFFF)))
|
||||
|
||||
(define (srand-half! s x)
|
||||
(let* ([u32+ (lambda (a b)
|
||||
(bitwise-and (+ a b) #xFFFFFFFF))]
|
||||
[x (random-n! x
|
||||
(- Im1 1)
|
||||
(lambda (z)
|
||||
(set-pseudo-random-generator-x10!
|
||||
s
|
||||
(exact->inexact
|
||||
(+ 1 (modulo
|
||||
(u32+ (inexact->exact (pseudo-random-generator-x10 s))
|
||||
z)
|
||||
(- Im1 1)))))))]
|
||||
[x (random-n! x
|
||||
Im1
|
||||
(lambda (z)
|
||||
(set-pseudo-random-generator-x11!
|
||||
s
|
||||
(exact->inexact
|
||||
(modulo
|
||||
(u32+ (inexact->exact (pseudo-random-generator-x11 s))
|
||||
z)
|
||||
Im1)))))]
|
||||
[x (random-n! x
|
||||
Im1
|
||||
(lambda (z)
|
||||
(set-pseudo-random-generator-x12!
|
||||
s
|
||||
(exact->inexact
|
||||
(modulo
|
||||
(u32+ (inexact->exact (pseudo-random-generator-x12 s))
|
||||
z)
|
||||
Im1)))))]
|
||||
[x (random-n! x
|
||||
(- Im2 1)
|
||||
(lambda (z)
|
||||
(set-pseudo-random-generator-x20!
|
||||
s
|
||||
(exact->inexact
|
||||
(+ 1 (modulo
|
||||
(u32+ (inexact->exact (pseudo-random-generator-x20 s))
|
||||
z)
|
||||
(- Im2 1)))))))]
|
||||
[x (random-n! x
|
||||
Im2
|
||||
(lambda (z)
|
||||
(set-pseudo-random-generator-x21!
|
||||
s
|
||||
(exact->inexact
|
||||
(modulo
|
||||
(u32+ (inexact->exact (pseudo-random-generator-x21 s))
|
||||
z)
|
||||
Im2)))))]
|
||||
[x (random-n! x
|
||||
Im2
|
||||
(lambda (z)
|
||||
(set-pseudo-random-generator-x22!
|
||||
s
|
||||
(exact->inexact
|
||||
(modulo
|
||||
(u32+ (inexact->exact (pseudo-random-generator-x22 s))
|
||||
z)
|
||||
Im2)))))])
|
||||
(void)))
|
||||
|
||||
(define (random-n! x Im k)
|
||||
(let* ([y1 (bitwise-and x #xFFFF)]
|
||||
[x (+ (* 30903 y1) (bitwise-arithmetic-shift-right x 16))]
|
||||
[y2 (bitwise-and x #xFFFF)]
|
||||
[x (+ (* 30903 y2) (bitwise-arithmetic-shift-right x 16))])
|
||||
(k (modulo (+ (arithmetic-shift y1 16) y2) Im))
|
||||
x))
|
||||
|
||||
(define/who (pseudo-random-generator->vector s)
|
||||
(check who pseudo-random-generator? s)
|
||||
(vector (inexact->exact (pseudo-random-generator-x10 s))
|
||||
(inexact->exact (pseudo-random-generator-x11 s))
|
||||
(inexact->exact (pseudo-random-generator-x12 s))
|
||||
(inexact->exact (pseudo-random-generator-x20 s))
|
||||
(inexact->exact (pseudo-random-generator-x21 s))
|
||||
(inexact->exact (pseudo-random-generator-x22 s))))
|
||||
|
||||
(define (pseudo-random-generator-vector? v)
|
||||
(let ([in-range?
|
||||
(lambda (i mx)
|
||||
(let ([x (vector-ref v i)])
|
||||
(and (exact-nonnegative-integer? x)
|
||||
(<= x mx))))]
|
||||
[nonzero?
|
||||
(lambda (i)
|
||||
(not (zero? (vector-ref v i))))])
|
||||
(and (vector? v)
|
||||
(= 6 (vector-length v))
|
||||
(in-range? 0 4294967086)
|
||||
(in-range? 1 4294967086)
|
||||
(in-range? 2 4294967086)
|
||||
(in-range? 3 4294944442)
|
||||
(in-range? 4 4294944442)
|
||||
(in-range? 5 4294944442)
|
||||
(or (nonzero? 0) (nonzero? 1) (nonzero? 2))
|
||||
(or (nonzero? 3) (nonzero? 4) (nonzero? 5)))))
|
||||
|
||||
(define/who (vector->pseudo-random-generator orig-v)
|
||||
(let ([iv (and (vector? orig-v)
|
||||
(= 6 (vector-length orig-v))
|
||||
(vector->immutable-vector orig-v))])
|
||||
(check who pseudo-random-generator-vector? iv)
|
||||
(let ([r (lambda (i) (exact->inexact (vector-ref iv i)))])
|
||||
(new-pseudo-random-generator (r 0)
|
||||
(r 1)
|
||||
(r 2)
|
||||
(r 3)
|
||||
(r 4)
|
||||
(r 5)))))
|
||||
|
||||
(define/who (vector->pseudo-random-generator! s orig-v)
|
||||
(check who pseudo-random-generator? s)
|
||||
(let ([iv (and (vector? orig-v)
|
||||
(= 6 (vector-length orig-v))
|
||||
(vector->immutable-vector orig-v))])
|
||||
(unless (pseudo-random-generator-vector? iv)
|
||||
(raise-argument-error 'vector->pseudo-random-generator! "pseudo-random-generator-vector?" orig-v))
|
||||
(let ([r (lambda (i) (exact->inexact (vector-ref iv i)))])
|
||||
(set-pseudo-random-generator-x10! s (r 0))
|
||||
(set-pseudo-random-generator-x11! s (r 1))
|
||||
(set-pseudo-random-generator-x12! s (r 2))
|
||||
(set-pseudo-random-generator-x20! s (r 3))
|
||||
(set-pseudo-random-generator-x21! s (r 4))
|
||||
(set-pseudo-random-generator-x22! s (r 5)))))
|
||||
|
||||
(define (pseudo-random-generator-integer! s k)
|
||||
;; generate result in {0..n-1} using the rejection method
|
||||
(let* ([n (real->flonum k)]
|
||||
[q (fltruncate (fl/ m1 n))]
|
||||
[qn (fl* q n)])
|
||||
(let loop ()
|
||||
(let ([x (mrg32k3a s)])
|
||||
(if (fl>= x qn)
|
||||
(loop)
|
||||
(let ([xq (fl/ x q)])
|
||||
(if (fixnum? k) ; => result is fixnum
|
||||
(flonum->fixnum xq)
|
||||
(inexact->exact (flfloor xq)))))))))
|
||||
|
||||
(define (pseudo-random-generator-real! s)
|
||||
(fl* (fl+ (mrg32k3a s) 1.0) norm))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define/who current-pseudo-random-generator
|
||||
(make-parameter (make-pseudo-random-generator)
|
||||
(lambda (v)
|
||||
(check who pseudo-random-generator? v)
|
||||
v)
|
||||
'current-pseudo-random-generator))
|
||||
|
||||
(define/who random
|
||||
(case-lambda
|
||||
[() (pseudo-random-generator-real! (current-pseudo-random-generator))]
|
||||
[(n)
|
||||
(cond
|
||||
[(pseudo-random-generator? n)
|
||||
(pseudo-random-generator-real! n)]
|
||||
[else
|
||||
(check who
|
||||
:test (and (integer? n)
|
||||
(exact? n)
|
||||
(<= 1 n 4294967087))
|
||||
:contract "(or/c (integer-in 1 4294967087) pseudo-random-generator?)"
|
||||
n)
|
||||
(pseudo-random-generator-integer! (current-pseudo-random-generator) n)])]
|
||||
[(n prg)
|
||||
(check who
|
||||
:test (and (integer? n)
|
||||
(exact? n)
|
||||
(<= 1 n 4294967087))
|
||||
:contract "(or/c (integer-in 1 4294967087) pseudo-random-generator?)"
|
||||
n)
|
||||
(check who pseudo-random-generator? prg)
|
||||
(pseudo-random-generator-integer! prg n)]))
|
||||
|
||||
(define/who (random-seed k)
|
||||
(check who
|
||||
:test (and (exact-nonnegative-integer? k)
|
||||
(<= k (sub1 (expt 2 31))))
|
||||
:contract "(integer-in 0 (sub1 (expt 2 31)))"
|
||||
k)
|
||||
(pseudo-random-generator-seed! (current-pseudo-random-generator) k))
|
||||
|
||||
|#
|
||||
|
||||
(define/who current-pseudo-random-generator
|
||||
(make-parameter (make-pseudo-random-generator)
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@
|
|||
(define unsafe-flsqrt (unsafe-primitive flsqrt))
|
||||
(define unsafe-flexpt (unsafe-primitive flexpt))
|
||||
|
||||
(define (unsafe-flrandom gen) (random gen))
|
||||
(define (unsafe-flrandom gen) (pseudo-random-generator-next! gen))
|
||||
|
||||
(define unsafe-vector*-length (unsafe-primitive vector-length))
|
||||
(define unsafe-vector*-ref (unsafe-primitive vector-ref))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user