From 4c8168cc9dd57fdfae9183aedcdb8ec1b36e08b0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 7 Oct 2019 11:35:18 -0600 Subject: [PATCH] cs: use pseudo-random generator from Chez Scheme Use the pseudo-random generator API that is now available from Chez Scheme. While the generator can be written in Scheme, the lack of unboxed floating-point arithmetic unfortunately makes it about 6 times as slow as a built-in implementation. That difference is significant when `sync` uses `random` for fair scheduling. --- pkgs/base/info.rkt | 2 +- .../tests/racket/benchmarks/control/sync.rkt | 38 +++ .../racket/benchmarks/control/thread.rkt | 1 - racket/src/cs/bootstrap/record.rkt | 4 +- racket/src/cs/compile-file.ss | 4 +- racket/src/cs/rumble.sls | 5 - racket/src/cs/rumble/random.ss | 290 +++--------------- racket/src/racket/src/schvers.h | 2 +- racket/src/thread/sync.rkt | 9 +- 9 files changed, 83 insertions(+), 272 deletions(-) create mode 100644 pkgs/racket-benchmarks/tests/racket/benchmarks/control/sync.rkt diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index b77aafed39..b9d0f4e193 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "7.4.0.12") +(define version "7.4.0.13") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/racket-benchmarks/tests/racket/benchmarks/control/sync.rkt b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/sync.rkt new file mode 100644 index 0000000000..0f4e26ba6c --- /dev/null +++ b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/sync.rkt @@ -0,0 +1,38 @@ +#lang racket/base + +(require racket/include) + +(include "config.rktl") + +'---------------------------------------- + +'semaphore-wait +(times + (let ([s (make-semaphore M)]) + (for ([i (in-range M)]) + (semaphore-wait s)))) + +'semaphore-post+wait +(times + (let ([s (make-semaphore)]) + (for ([i (in-range M)]) + (semaphore-post s) + (semaphore-wait s)))) + +'semaphore-peek-evt +(times + (let ([e (semaphore-peek-evt (make-semaphore 1))]) + (for ([i (in-range M)]) + (sync e)))) + +'sync-two +(times + (let ([s (make-semaphore M)]) + (for ([i (in-range M)]) + (sync s never-evt)))) + +'sync-three +(times + (let ([s (make-semaphore M)]) + (for ([i (in-range M)]) + (sync s always-evt never-evt)))) diff --git a/pkgs/racket-benchmarks/tests/racket/benchmarks/control/thread.rkt b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/thread.rkt index 4ebcb824ea..63bda36808 100644 --- a/pkgs/racket-benchmarks/tests/racket/benchmarks/control/thread.rkt +++ b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/thread.rkt @@ -106,4 +106,3 @@ (define t2 (make s2 s1)) (thread-wait t1) (thread-wait t2))) - diff --git a/racket/src/cs/bootstrap/record.rkt b/racket/src/cs/bootstrap/record.rkt index c138cf1f48..f2a64f2adb 100644 --- a/racket/src/cs/bootstrap/record.rkt +++ b/racket/src/cs/bootstrap/record.rkt @@ -151,7 +151,7 @@ (error 'normalize-fields "not a list: ~s" fields)) (define (check-type t) (case t - [(scheme-object uptr ptr) t] + [(scheme-object uptr ptr double) t] [else (error 'make-struct-type "unsupported type ~s" t)])) (define (is-mut? m) @@ -298,7 +298,7 @@ (define (ptr-type? t) (case t [(scheme-object ptr) #t] - [(uptr) #f] + [(uptr double) #f] [else (error "unrecognized type")])) (define (assert-accessor) (when mut? (error 'csv7:record-field-mutator "immutable base-rtd field"))) diff --git a/racket/src/cs/compile-file.ss b/racket/src/cs/compile-file.ss index 9b270608ed..03b85ea632 100644 --- a/racket/src/cs/compile-file.ss +++ b/racket/src/cs/compile-file.ss @@ -2,7 +2,7 @@ ;; Check to make we're using a build of Chez Scheme ;; that has all the features we need. (define-values (need-maj need-min need-sub need-dev) - (values 9 5 3 2)) + (values 9 5 3 3)) (unless (guard (x [else #f]) (eval 'scheme-fork-version-number)) (error 'compile-file @@ -13,7 +13,7 @@ (and (= maj need-maj) (or (> min need-min) (and (= min need-min) - (or (>= sub need-sub) + (or (> sub need-sub) (and (= sub need-sub) (>= dev need-dev))))))) (error 'compile-file "need a newer Chez Scheme"))) diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index 064a8b921f..60163302dc 100644 --- a/racket/src/cs/rumble.sls +++ b/racket/src/cs/rumble.sls @@ -406,12 +406,7 @@ random random-seed - pseudo-random-generator? - make-pseudo-random-generator current-pseudo-random-generator - vector->pseudo-random-generator - vector->pseudo-random-generator! - pseudo-random-generator->vector pseudo-random-generator-vector? mpair? diff --git a/racket/src/cs/rumble/random.ss b/racket/src/cs/rumble/random.ss index 90c7a0e1a2..8a84513331 100644 --- a/racket/src/cs/rumble/random.ss +++ b/racket/src/cs/rumble/random.ss @@ -1,175 +1,41 @@ -;; /* -;; 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 -;; ============= +(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)) -;; moduli of the components -(define Im1 #xffffff2f) -(define Im2 #xffffa6bb) -(define m1 4294967087.0) -(define m2 4294944443.0) +(define/who random + (case-lambda + [() (pseudo-random-generator-next! (current-pseudo-random-generator))] + [(n) + (cond + [(pseudo-random-generator? n) + (pseudo-random-generator-next! n)] + [else + (check who + :test (and (exact-integer? n) + (<= 1 n 4294967087)) + :contract "(or/c (integer-in 1 4294967087) pseudo-random-generator?)" + n) + (pseudo-random-generator-next! (current-pseudo-random-generator) n)])] + [(n prg) + (check who + :test (and (exact-integer? n) + (<= 1 n 4294967087)) + :contract "(or/c (integer-in 1 4294967087) pseudo-random-generator?)" + n) + (check who pseudo-random-generator? prg) + (pseudo-random-generator-next! prg n)])) -;; 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) - -;; the actual generator - -(define-record-type (pseudo-random-generator new-pseudo-random-generator pseudo-random-generator?) - (fields (mutable x10) (mutable x11) (mutable x12) (mutable x20) (mutable x21) (mutable x22)) - (nongenerative)) - -(define (mrg32k3a s) ;; -> flonum in {0..m1-1} - ;; component 1 - (let* ([x10 (fl- (fl* a12 (pseudo-random-generator-x11 s)) - (fl* a13n (pseudo-random-generator-x12 s)))] - [k10 (fltruncate (fl/ x10 m1))] - [x10 (fl- x10 (fl* k10 m1))] - [x10 (if (fl< x10 0.0) - (fl+ x10 m1) - x10)]) - (pseudo-random-generator-x12-set! s (pseudo-random-generator-x11 s)) - (pseudo-random-generator-x11-set! s (pseudo-random-generator-x10 s)) - (pseudo-random-generator-x10-set! s x10) - - ;; component 2 - (let* ([x20 (fl- (fl* a21 (pseudo-random-generator-x20 s)) - (fl* a23n (pseudo-random-generator-x22 s)))] - [k20 (fltruncate (fl/ x20 m2))] - [x20 (fl- x20 (fl* k20 m2))] - [x20 (if (fl< x20 0.0) - (fl+ x20 m2) - x20)]) - (pseudo-random-generator-x22-set! s (pseudo-random-generator-x21 s)) - (pseudo-random-generator-x21-set! s (pseudo-random-generator-x20 s)) - (pseudo-random-generator-x20-set! 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: - (pseudo-random-generator-x10-set! s 1062452522.0) - (pseudo-random-generator-x11-set! s 2961816100.0) - (pseudo-random-generator-x12-set! s 342112271.0) - (pseudo-random-generator-x20-set! s 2854655037.0) - (pseudo-random-generator-x21-set! s 3321940838.0) - (pseudo-random-generator-x22-set! 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) - (pseudo-random-generator-x10-set! - s - (exact->inexact - (+ 1 (modulo - (u32+ (inexact->exact (pseudo-random-generator-x10 s)) - z) - (- Im1 1)))))))] - [x (random-n! x - Im1 - (lambda (z) - (pseudo-random-generator-x11-set! - s - (exact->inexact - (modulo - (u32+ (inexact->exact (pseudo-random-generator-x11 s)) - z) - Im1)))))] - [x (random-n! x - Im1 - (lambda (z) - (pseudo-random-generator-x12-set! - s - (exact->inexact - (modulo - (u32+ (inexact->exact (pseudo-random-generator-x12 s)) - z) - Im1)))))] - [x (random-n! x - (- Im2 1) - (lambda (z) - (pseudo-random-generator-x20-set! - s - (exact->inexact - (+ 1 (modulo - (u32+ (inexact->exact (pseudo-random-generator-x20 s)) - z) - (- Im2 1)))))))] - [x (random-n! x - Im2 - (lambda (z) - (pseudo-random-generator-x21-set! - s - (exact->inexact - (modulo - (u32+ (inexact->exact (pseudo-random-generator-x21 s)) - z) - Im2)))))] - [x (random-n! x - Im2 - (lambda (z) - (pseudo-random-generator-x22-set! - 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/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 (pseudo-random-generator-vector? v) (let ([in-range? @@ -190,89 +56,3 @@ (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)))]) - (pseudo-random-generator-x10-set! s (r 0)) - (pseudo-random-generator-x11-set! s (r 1)) - (pseudo-random-generator-x12-set! s (r 2)) - (pseudo-random-generator-x20-set! s (r 3)) - (pseudo-random-generator-x21-set! s (r 4)) - (pseudo-random-generator-x22-set! s (r 5))))) - -(define (pseudo-random-generator-integer! s n) - ;; generate result in {0..n-1} using the rejection method - (let* ([n (exact->inexact n)] - [q (fltruncate (fl/ m1 n))] - [qn (fl* q n)] - [x (let loop () - (let ([x (mrg32k3a s)]) - (if (fl>= x qn) - (loop) - x)))] - [xq (fl/ x q)]) - (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)) diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index df75723c76..98830be682 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -16,7 +16,7 @@ #define MZSCHEME_VERSION_X 7 #define MZSCHEME_VERSION_Y 4 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 12 +#define MZSCHEME_VERSION_W 13 /* A level of indirection makes `#` work as needed: */ #define AS_a_STR_HELPER(x) #x diff --git a/racket/src/thread/sync.rkt b/racket/src/thread/sync.rkt index 10383cc75d..f3eeb2bf66 100644 --- a/racket/src/thread/sync.rkt +++ b/racket/src/thread/sync.rkt @@ -40,10 +40,10 @@ #:transparent #:mutable) -(define (make-syncer evt wraps) - (syncer evt wraps null #f null null null #f #f)) +(define (make-syncer evt wraps prev) + (syncer evt wraps null #f null null null prev #f)) -(define none-syncer (make-syncer #f null)) +(define none-syncer (make-syncer #f null #f)) (define (make-syncing syncers #:disable-break [disable-break #f]) (syncing #f ; selected @@ -267,12 +267,11 @@ first last)] [else - (define sr (make-syncer arg wraps)) + (define sr (make-syncer arg wraps last)) (unless (and (null? extended-commits) (null? guarded-abandons)) (set-syncer-commits! sr extended-commits) (set-syncer-abandons! sr guarded-abandons)) - (set-syncer-prev! sr last) (when last (set-syncer-next! last sr)) (loop (cdr evts)