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.

racket/src/cs/rumble/define.ss

@@ -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))
-                 (generate-lifted env binds mutated
+                 (cond
-                                  #'loop          ; name
+                   [(true-loop? (syntax->datum #'loop) #t #'(begin body-e ...))
-                                  #'(arg ...)     ; argument names
+                    (lift-local-functions-in-named-let e env binds mutated)]
-                                  #'(begin e ...) ; body
+                   [else
-                                  #t              ; recursive
+                    (generate-lifted env binds mutated
-                                  (lambda (defn-to-lift new-loop-name free-vars wrap-bind-of-lifted)
+                                     #'loop          ; name
-                                    (with-syntax ([(free-var ...) free-vars]
+                                     #'(arg ...)     ; argument names
-                                                  [new-loop-name new-loop-name]
+                                     #'(begin body-e ...) ; body
-                                                  [defn-to-lift defn-to-lift])
+                                     #t              ; recursive
-                                      #`((new-loop-name val ... free-var ...)
+                                     (lambda (defn-to-lift new-loop-name free-vars wrap-bind-of-lifted)
-                                         (defn-to-lift)))))]
+                                       (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)))))])]
                 [(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

racket/src/cs/rumble/random.ss

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

racket/src/cs/rumble/unsafe.ss

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