suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: change representation of parameters

Browse Source 
Implement a parameter as a Chez Scheme wrapper procedure,
instead of an applicable record. A wrapper procedure can be
applied more directly, saving 10-20% of the time for some
parameter lookups.
This commit is contained in:
Matthew Flatt 2019-09-04 20:35:34 -06:00
parent 8c049d914e
commit cccaf4e46e
11 changed files with 161 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi) (define collection 'multi)
(define version "7.4.0.5") (define version "7.4.0.6")
(define deps `("racket-lib" (define deps `("racket-lib"
["racket" #:version ,version])) ["racket" #:version ,version]))

40
racket/src/cs/main.sps
View File

@ -76,7 +76,7 @@
[else (string->path s)])) [else (string->path s)]))
(define (getenv-bytes str) (define (getenv-bytes str)
(environment-variables-ref (|#%app| current-environment-variables) (string->utf8 str))) (environment-variables-ref (current-environment-variables) (string->utf8 str)))
(define builtin-argc 9) (define builtin-argc 9)
(seq (seq
@ -381,7 +381,7 @@
(abort-current-continuation (default-continuation-prompt-tag) proc)))) (abort-current-continuation (default-continuation-prompt-tag) proc))))
(lambda vals (lambda vals
(for-each (lambda (v) (for-each (lambda (v)
(|#%app| (|#%app| current-print) v) (|#%app| (current-print) v)
(flush-output)) (flush-output))
vals)))) vals))))
loads)) loads))
@ -582,7 +582,7 @@
(call-with-values (lambda () (eval (datum->kernel-syntax (call-with-values (lambda () (eval (datum->kernel-syntax
(cons m (vector->list remaining-command-line-arguments))))) (cons m (vector->list remaining-command-line-arguments)))))
(lambda results (lambda results
(let ([p (|#%app| current-print)]) (let ([p (current-print)])
(for-each (lambda (v) (|#%app| p v)) results)))))) (for-each (lambda (v) (|#%app| p v)) results))))))
;; Set up GC logging ;; Set up GC logging
@ -624,7 +624,7 @@
(define peak-mem 0) (define peak-mem 0)
(seq (seq
(set-garbage-collect-notify! (set-garbage-collect-notify!
(let ([root-logger (|#%app| current-logger)]) (let ([root-logger (current-logger)])
;; This function can be called in any Chez Scheme thread ;; This function can be called in any Chez Scheme thread
(lambda (gen pre-allocated pre-allocated+overhead pre-time pre-cpu-time (lambda (gen pre-allocated pre-allocated+overhead pre-time pre-cpu-time
post-allocated post-allocated+overhead post-time post-cpu-time) post-allocated post-allocated+overhead post-time post-cpu-time)
@ -653,9 +653,9 @@
;; in interrupt: ;; in interrupt:
#t))))))))) #t)))))))))
(seq (seq
(|#%app| exit-handler (exit-handler
(let ([orig (|#%app| exit-handler)] (let ([orig (exit-handler)]
[root-logger (|#%app| current-logger)]) [root-logger (current-logger)])
(lambda (v) (lambda (v)
(when (log-level? root-logger 'info 'GC) (when (log-level? root-logger 'info 'GC)
(log-message root-logger 'info 'GC (log-message root-logger 'info 'GC
@ -693,40 +693,40 @@
'())))) '()))))
(define (initialize-place!) (define (initialize-place!)
(|#%app| current-command-line-arguments remaining-command-line-arguments) (current-command-line-arguments remaining-command-line-arguments)
(|#%app| use-compiled-file-paths compiled-file-paths) (use-compiled-file-paths compiled-file-paths)
(|#%app| use-user-specific-search-paths user-specific-search-paths?) (use-user-specific-search-paths user-specific-search-paths?)
(|#%app| load-on-demand-enabled load-on-demand?) (load-on-demand-enabled load-on-demand?)
(unless (eq? compile-target-machine (machine-type)) (unless (eq? compile-target-machine (machine-type))
(|#%app| current-compile-target-machine compile-target-machine)) (current-compile-target-machine compile-target-machine))
(boot) (boot)
(when (and stderr-logging (when (and stderr-logging
(not (null? stderr-logging))) (not (null? stderr-logging)))
(apply add-stderr-log-receiver! (|#%app| current-logger) stderr-logging)) (apply add-stderr-log-receiver! (current-logger) stderr-logging))
(when (and stdout-logging (when (and stdout-logging
(not (null? stdout-logging))) (not (null? stdout-logging)))
(apply add-stdout-log-receiver! (|#%app| current-logger) stdout-logging)) (apply add-stdout-log-receiver! (current-logger) stdout-logging))
(when (and syslog-logging (when (and syslog-logging
(not (null? syslog-logging))) (not (null? syslog-logging)))
(apply add-syslog-log-receiver! (|#%app| current-logger) syslog-logging)) (apply add-syslog-log-receiver! (current-logger) syslog-logging))
(when host-collects-dir (when host-collects-dir
(set-host-collects-dir! host-collects-dir)) (set-host-collects-dir! host-collects-dir))
(when host-config-dir (when host-config-dir
(set-host-config-dir! host-config-dir)) (set-host-config-dir! host-config-dir))
(cond (cond
[(eq? init-collects-dir 'disable) [(eq? init-collects-dir 'disable)
(|#%app| use-collection-link-paths #f) (use-collection-link-paths #f)
(set-collects-dir! (build-path 'same))] (set-collects-dir! (build-path 'same))]
[else [else
(set-collects-dir! init-collects-dir)]) (set-collects-dir! init-collects-dir)])
(set-config-dir! init-config-dir) (set-config-dir! init-config-dir)
(unless (eq? init-collects-dir 'disable) (unless (eq? init-collects-dir 'disable)
(|#%app| current-library-collection-links (current-library-collection-links
(find-library-collection-links)) (find-library-collection-links))
(|#%app| current-library-collection-paths (current-library-collection-paths
(find-library-collection-paths collects-pre-extra (reverse rev-collects-post-extra)))) (find-library-collection-paths collects-pre-extra (reverse rev-collects-post-extra))))
(when compiled-roots-path-list-string (when compiled-roots-path-list-string
(|#%app| current-compiled-file-roots (current-compiled-file-roots
(let ([s (regexp-replace* "@[(]version[)]" (let ([s (regexp-replace* "@[(]version[)]"
compiled-roots-path-list-string compiled-roots-path-list-string
(version))]) (version))])
@ -797,7 +797,7 @@
(newline))) (newline)))
(when yield? (when yield?
(|#%app| (|#%app| executable-yield-handler) exit-value)) (|#%app| (executable-yield-handler) exit-value))
(exit exit-value)))) (exit exit-value))))

114
racket/src/cs/primitive/kernel.ss
View File

@ -197,44 +197,44 @@
[continuation? (known-procedure/pure/folding 2)] [continuation? (known-procedure/pure/folding 2)]
[copy-file (known-procedure/no-prompt 12)] [copy-file (known-procedure/no-prompt 12)]
[cos (known-procedure/folding 2)] [cos (known-procedure/folding 2)]
[current-code-inspector (known-constant)] [current-code-inspector (known-procedure 3)]
[current-command-line-arguments (known-constant)] [current-command-line-arguments (known-procedure 3)]
[current-compile-target-machine (known-constant)] [current-compile-target-machine (known-procedure 3)]
[current-continuation-marks (known-procedure 3)] [current-continuation-marks (known-procedure 3)]
[current-custodian (known-constant)] [current-custodian (known-procedure 3)]
[current-directory (known-constant)] [current-directory (known-procedure 3)]
[current-directory-for-user (known-constant)] [current-directory-for-user (known-procedure 3)]
[current-drive (known-procedure/no-prompt 1)] [current-drive (known-procedure/no-prompt 1)]
[current-environment-variables (known-constant)] [current-environment-variables (known-procedure 3)]
[current-error-port (known-constant)] [current-error-port (known-procedure 3)]
[current-evt-pseudo-random-generator (known-constant)] [current-evt-pseudo-random-generator (known-procedure 3)]
[current-force-delete-permissions (known-constant)] [current-force-delete-permissions (known-procedure 3)]
[current-gc-milliseconds (known-procedure/no-prompt 1)] [current-gc-milliseconds (known-procedure/no-prompt 1)]
[current-get-interaction-input-port (known-constant)] [current-get-interaction-input-port (known-procedure 3)]
[current-inexact-milliseconds (known-procedure/no-prompt 1)] [current-inexact-milliseconds (known-procedure/no-prompt 1)]
[current-input-port (known-constant)] [current-input-port (known-procedure 3)]
[current-inspector (known-constant)] [current-inspector (known-procedure 3)]
[current-load-extension (known-constant)] [current-load-extension (known-procedure 3)]
[current-load-relative-directory (known-constant)] [current-load-relative-directory (known-procedure 3)]
[current-locale (known-constant)] [current-locale (known-procedure 3)]
[current-logger (known-constant)] [current-logger (known-procedure 3)]
[current-memory-use (known-procedure/no-prompt 3)] [current-memory-use (known-procedure/no-prompt 3)]
[current-milliseconds (known-procedure/no-prompt 1)] [current-milliseconds (known-procedure/no-prompt 1)]
[current-output-port (known-constant)] [current-output-port (known-procedure 3)]
[current-plumber (known-constant)] [current-plumber (known-procedure 3)]
[current-preserved-thread-cell-values (known-procedure/no-prompt 3)] [current-preserved-thread-cell-values (known-procedure/no-prompt 3)]
[current-print (known-constant)] [current-print (known-procedure 3)]
[current-process-milliseconds (known-procedure/no-prompt 3)] [current-process-milliseconds (known-procedure/no-prompt 3)]
[current-prompt-read (known-constant)] [current-prompt-read (known-procedure 3)]
[current-pseudo-random-generator (known-constant)] [current-pseudo-random-generator (known-procedure 3)]
[current-read-interaction (known-constant)] [current-read-interaction (known-procedure 3)]
[current-seconds (known-procedure/no-prompt 1)] [current-seconds (known-procedure/no-prompt 1)]
[current-security-guard (known-constant)] [current-security-guard (known-procedure 3)]
[current-subprocess-custodian-mode (known-constant)] [current-subprocess-custodian-mode (known-procedure 3)]
[current-thread (known-procedure/no-prompt 1)] [current-thread (known-procedure/no-prompt 1)]
[current-thread-group (known-constant)] [current-thread-group (known-procedure 3)]
[current-thread-initial-stack-size (known-constant)] [current-thread-initial-stack-size (known-procedure 3)]
[current-write-relative-directory (known-constant)] [current-write-relative-directory (known-procedure 3)]
[custodian-box-value (known-procedure/no-prompt 2)] [custodian-box-value (known-procedure/no-prompt 2)]
[custodian-box? (known-procedure/pure/folding 2)] [custodian-box? (known-procedure/pure/folding 2)]
[custodian-limit-memory (known-procedure/no-prompt 12)] [custodian-limit-memory (known-procedure/no-prompt 12)]
@ -294,13 +294,13 @@
[eqv-hash-code (known-procedure/no-prompt 2)] [eqv-hash-code (known-procedure/no-prompt 2)]
[eqv? (known-procedure/pure/folding 4)] [eqv? (known-procedure/pure/folding 4)]
[error (known-procedure -2)] [error (known-procedure -2)]
[error-display-handler (known-constant)] [error-display-handler (known-procedure 3)]
[error-escape-handler (known-constant)] [error-escape-handler (known-procedure 3)]
[error-print-context-length (known-constant)] [error-print-context-length (known-procedure 3)]
[error-print-source-location (known-constant)] [error-print-source-location (known-procedure 3)]
[error-print-width (known-constant)] [error-print-width (known-procedure 3)]
[error-value->string-handler (known-constant)] [error-value->string-handler (known-procedure 3)]
[eval-jit-enabled (known-constant)] [eval-jit-enabled (known-procedure 3)]
[even? (known-procedure/folding 2)] [even? (known-procedure/folding 2)]
[evt? (known-procedure/pure/folding 2)] [evt? (known-procedure/pure/folding 2)]
[exact->inexact (known-procedure/folding 2)] [exact->inexact (known-procedure/folding 2)]
@ -308,9 +308,9 @@
[exact-nonnegative-integer? (known-procedure/pure/folding 2)] [exact-nonnegative-integer? (known-procedure/pure/folding 2)]
[exact-positive-integer? (known-procedure/pure/folding 2)] [exact-positive-integer? (known-procedure/pure/folding 2)]
[exact? (known-procedure/folding 2)] [exact? (known-procedure/folding 2)]
[executable-yield-handler (known-constant)] [executable-yield-handler (known-procedure 3)]
[exit (known-procedure 3)] [exit (known-procedure 3)]
[exit-handler (known-constant)] [exit-handler (known-procedure 3)]
[exn (known-constant)] [exn (known-constant)]
[exn-continuation-marks (known-procedure 2)] [exn-continuation-marks (known-procedure 2)]
[exn-message (known-procedure 2)] [exn-message (known-procedure 2)]
@ -397,7 +397,7 @@
[gensym (known-procedure 3)] [gensym (known-procedure 3)]
[get-output-bytes (known-procedure/no-prompt 30)] [get-output-bytes (known-procedure/no-prompt 30)]
[get-output-string (known-procedure/no-prompt 2)] [get-output-string (known-procedure/no-prompt 2)]
[global-port-print-handler (known-constant)] [global-port-print-handler (known-procedure 3)]
[handle-evt (known-procedure/no-prompt 4)] [handle-evt (known-procedure/no-prompt 4)]
[handle-evt? (known-procedure/pure/folding 2)] [handle-evt? (known-procedure/pure/folding 2)]
[hash (known-procedure -1)] [hash (known-procedure -1)]
@ -476,7 +476,7 @@
[list-ref (known-procedure/no-prompt 4)] [list-ref (known-procedure/no-prompt 4)]
[list-tail (known-procedure/no-prompt 4)] [list-tail (known-procedure/no-prompt 4)]
[list? (known-procedure/pure/folding 2)] [list? (known-procedure/pure/folding 2)]
[load-on-demand-enabled (known-constant)] [load-on-demand-enabled (known-procedure 3)]
[locale-string-encoding (known-procedure/no-prompt 1)] [locale-string-encoding (known-procedure/no-prompt 1)]
[log (known-procedure/folding 6)] [log (known-procedure/folding 6)]
[log-all-levels (known-procedure/no-prompt 2)] [log-all-levels (known-procedure/no-prompt 2)]
@ -611,7 +611,7 @@
[port-closed? (known-procedure 2)] [port-closed? (known-procedure 2)]
[port-commit-peeked (known-procedure 24)] [port-commit-peeked (known-procedure 24)]
[port-count-lines! (known-procedure 2)] [port-count-lines! (known-procedure 2)]
[port-count-lines-enabled (known-constant)] [port-count-lines-enabled (known-procedure 3)]
[port-counts-lines? (known-procedure 2)] [port-counts-lines? (known-procedure 2)]
[port-display-handler (known-procedure 6)] [port-display-handler (known-procedure 6)]
[port-file-identity (known-procedure 2)] [port-file-identity (known-procedure 2)]
@ -636,18 +636,18 @@
[primitive-result-arity (known-procedure 2)] [primitive-result-arity (known-procedure 2)]
[primitive? (known-procedure/pure 2)] [primitive? (known-procedure/pure 2)]
[print (known-procedure 14)] [print (known-procedure 14)]
[print-as-expression (known-constant)] [print-as-expression (known-procedure 3)]
[print-boolean-long-form (known-constant)] [print-boolean-long-form (known-procedure 3)]
[print-box (known-constant)] [print-box (known-procedure 3)]
[print-graph (known-constant)] [print-graph (known-procedure 3)]
[print-hash-table (known-constant)] [print-hash-table (known-procedure 3)]
[print-mpair-curly-braces (known-constant)] [print-mpair-curly-braces (known-procedure 3)]
[print-pair-curly-braces (known-constant)] [print-pair-curly-braces (known-procedure 3)]
[print-reader-abbreviations (known-constant)] [print-reader-abbreviations (known-procedure 3)]
[print-struct (known-constant)] [print-struct (known-procedure 3)]
[print-syntax-width (known-constant)] [print-syntax-width (known-procedure 3)]
[print-unreadable (known-constant)] [print-unreadable (known-procedure 3)]
[print-vector-length (known-constant)] [print-vector-length (known-procedure 3)]
[printf (known-procedure -2)] [printf (known-procedure -2)]
[procedure->method (known-procedure/no-prompt 2)] [procedure->method (known-procedure/no-prompt 2)]
[procedure-arity (known-procedure 2)] [procedure-arity (known-procedure 2)]
@ -699,7 +699,7 @@
[random (known-procedure/no-prompt 7)] [random (known-procedure/no-prompt 7)]
[random-seed (known-procedure/no-prompt 2)] [random-seed (known-procedure/no-prompt 2)]
[rational? (known-procedure/pure/folding 2)] [rational? (known-procedure/pure/folding 2)]
[read-accept-bar-quote (known-constant)] [read-accept-bar-quote (known-procedure 3)]
[read-byte (known-procedure 3)] [read-byte (known-procedure 3)]
[read-byte-or-special (known-procedure 15)] [read-byte-or-special (known-procedure 15)]
[read-bytes (known-procedure 6)] [read-bytes (known-procedure 6)]
@ -708,11 +708,11 @@
[read-bytes-avail!* (known-procedure 30)] [read-bytes-avail!* (known-procedure 30)]
[read-bytes-avail!/enable-break (known-procedure 30)] [read-bytes-avail!/enable-break (known-procedure 30)]
[read-bytes-line (known-procedure 7)] [read-bytes-line (known-procedure 7)]
[read-case-sensitive (known-constant)] [read-case-sensitive (known-procedure 3)]
[read-char (known-procedure 3)] [read-char (known-procedure 3)]
[read-char-or-special (known-procedure 15)] [read-char-or-special (known-procedure 15)]
[read-line (known-procedure 7)] [read-line (known-procedure 7)]
[read-on-demand-source (known-constant)] [read-on-demand-source (known-procedure 3)]
[read-string (known-procedure 6)] [read-string (known-procedure 6)]
[read-string! (known-procedure 30)] [read-string! (known-procedure 30)]
[real->double-flonum (known-procedure/folding 2)] [real->double-flonum (known-procedure/folding 2)]
@ -870,7 +870,7 @@
[sub1 (known-procedure/folding 2)] [sub1 (known-procedure/folding 2)]
[subbytes (known-procedure/no-prompt 12)] [subbytes (known-procedure/no-prompt 12)]
[subprocess (known-procedure -16)] [subprocess (known-procedure -16)]
[subprocess-group-enabled (known-constant)] [subprocess-group-enabled (known-procedure 3)]
[subprocess-kill (known-procedure 4)] [subprocess-kill (known-procedure 4)]
[subprocess-pid (known-procedure 2)] [subprocess-pid (known-procedure 2)]
[subprocess-status (known-procedure 2)] [subprocess-status (known-procedure 2)]
@ -930,7 +930,7 @@
[truncate (known-procedure/folding 2)] [truncate (known-procedure/folding 2)]
[unbox (known-procedure 2)] [unbox (known-procedure 2)]
[unbox* (known-procedure/has-unsafe 2 'unsafe-unbox*)] [unbox* (known-procedure/has-unsafe 2 'unsafe-unbox*)]
[uncaught-exception-handler (known-constant)] [uncaught-exception-handler (known-procedure 3)]
[unquoted-printing-string (known-procedure/no-prompt 2)] [unquoted-printing-string (known-procedure/no-prompt 2)]
[unquoted-printing-string-value (known-procedure 2)] [unquoted-printing-string-value (known-procedure 2)]
[unquoted-printing-string? (known-procedure/no-prompt 2)] [unquoted-printing-string? (known-procedure/no-prompt 2)]

67
racket/src/cs/rumble/parameter.ss
View File

@ -52,16 +52,30 @@
key key
#f)) #f))
(define-record-type (parameter create-parameter authentic-parameter?) (define-record-type parameter-data
(fields proc guard)) (fields guard))
(define-record-type (derived-parameter create-derived-parameter derived-parameter?) (define-record-type derived-parameter-data
(parent parameter) (parent parameter-data)
(fields next)) (fields next))
(define (parameter? v) (define (parameter? v)
(authentic-parameter? (strip-impersonator v))) (authentic-parameter? (strip-impersonator v)))
(define (authentic-parameter? v)
(and (wrapper-procedure? v)
(parameter-data? (wrapper-procedure-data v))))
(define (parameter-guard p)
(parameter-data-guard (wrapper-procedure-data p)))
(define (derived-parameter? v)
(and (wrapper-procedure? v)
(derived-parameter-data? (wrapper-procedure-data v))))
(define (derived-parameter-next p)
(derived-parameter-data-next (wrapper-procedure-data p)))
(define/who make-parameter (define/who make-parameter
(case-lambda (case-lambda
[(v) (make-parameter v #f)] [(v) (make-parameter v #f)]
@ -69,19 +83,22 @@
(check who (procedure-arity-includes/c 1) :or-false guard) (check who (procedure-arity-includes/c 1) :or-false guard)
(let ([default-c (make-thread-cell v #t)]) (let ([default-c (make-thread-cell v #t)])
(letrec ([self (letrec ([self
(create-parameter (make-wrapper-procedure
(case-lambda (|#%name|
[() parameter-procedure
(let ([c (or (parameter-cell self) (case-lambda
default-c)]) [()
(thread-cell-ref c))] (let ([c (or (parameter-cell self)
[(v) default-c)])
(let ([c (or (parameter-cell self) (thread-cell-ref c))]
default-c)]) [(v)
(thread-cell-set! c (if guard (let ([c (or (parameter-cell self)
(guard v) default-c)])
v)))]) (thread-cell-set! c (if guard
guard)]) (guard v)
v)))]))
3
(make-parameter-data guard))])
self))])) self))]))
(define/who (make-derived-parameter p guard wrap) (define/who (make-derived-parameter p guard wrap)
@ -90,12 +107,16 @@
p) p)
(check who (procedure-arity-includes/c 1) guard) (check who (procedure-arity-includes/c 1) guard)
(check who (procedure-arity-includes/c 1) wrap) (check who (procedure-arity-includes/c 1) wrap)
(create-derived-parameter (let ([self (parameter-proc p)]) (make-wrapper-procedure (let ([self p])
(case-lambda (|#%name|
[(v) (self (guard v))] parameter-procedure
[() (wrap (self))])) (case-lambda
guard [(v) (self (guard v))]
p)) [() (wrap (self))])))
3
(make-derived-parameter-data
guard
p)))
(define/who (parameter-procedure=? a b) (define/who (parameter-procedure=? a b)
(check who parameter? a) (check who parameter? a)

9
racket/src/cs/rumble/procedure.ss
View File

@ -311,6 +311,7 @@
;; <symbol-or-#f> or name of <proc> ;; <symbol-or-#f> or name of <proc>
;; - (vector <symbol-or-#f> <proc> 'method) => is a method ;; - (vector <symbol-or-#f> <proc> 'method) => is a method
;; - (box <symbol>) => JIT function generated, name is <symbol>, not a method ;; - (box <symbol>) => JIT function generated, name is <symbol>, not a method
;; - <parameter-data> => parameter
;; ---------------------------------------- ;; ----------------------------------------
@ -501,6 +502,7 @@
[(#%box? name) (#%unbox name)] [(#%box? name) (#%unbox name)]
[(#%vector? name) (or (#%vector-ref name 0) [(#%vector? name) (or (#%vector-ref name 0)
(object-name (#%vector-ref name 1)))] (object-name (#%vector-ref name 1)))]
[(parameter-data? name) 'parameter-procedure]
[else name]))) [else name])))
;; ---------------------------------------- ;; ----------------------------------------
@ -866,13 +868,6 @@
;; ---------------------------------------- ;; ----------------------------------------
(define (set-primitive-applicables!) (define (set-primitive-applicables!)
(struct-property-set! prop:procedure
(record-type-descriptor parameter)
0)
(struct-property-set! prop:procedure
(record-type-descriptor derived-parameter)
0)
(struct-property-set! prop:procedure (struct-property-set! prop:procedure
(record-type-descriptor position-based-accessor) (record-type-descriptor position-based-accessor)
(lambda (pba s p) (lambda (pba s p)

6
racket/src/cs/rumble/random.ss
View File

@ -245,7 +245,7 @@
(define/who random (define/who random
(case-lambda (case-lambda
[() (pseudo-random-generator-real! (|#%app| current-pseudo-random-generator))] [() (pseudo-random-generator-real! (current-pseudo-random-generator))]
[(n) [(n)
(cond (cond
[(pseudo-random-generator? n) [(pseudo-random-generator? n)
@ -257,7 +257,7 @@
(<= 1 n 4294967087)) (<= 1 n 4294967087))
:contract "(or/c (integer-in 1 4294967087) pseudo-random-generator?)" :contract "(or/c (integer-in 1 4294967087) pseudo-random-generator?)"
n) n)
(pseudo-random-generator-integer! (|#%app| current-pseudo-random-generator) n)])] (pseudo-random-generator-integer! (current-pseudo-random-generator) n)])]
[(n prg) [(n prg)
(check who (check who
:test (and (integer? n) :test (and (integer? n)
@ -274,4 +274,4 @@
(<= k (sub1 (expt 2 31)))) (<= k (sub1 (expt 2 31))))
:contract "(integer-in 0 (sub1 (expt 2 31)))" :contract "(integer-in 0 (sub1 (expt 2 31)))"
k) k)
(pseudo-random-generator-seed! (|#%app| current-pseudo-random-generator) k)) (pseudo-random-generator-seed! (current-pseudo-random-generator) k))

16
racket/src/cs/rumble/struct.ss
View File

@ -126,14 +126,14 @@
(define/who make-inspector (define/who make-inspector
(case-lambda (case-lambda
[() (new-inspector (|#%app| current-inspector))] [() (new-inspector (current-inspector))]
[(i) [(i)
(check who inspector? i) (check who inspector? i)
(new-inspector i)])) (new-inspector i)]))
(define/who make-sibling-inspector (define/who make-sibling-inspector
(case-lambda (case-lambda
[() (make-sibling-inspector (|#%app| current-inspector))] [() (make-sibling-inspector (current-inspector))]
[(i) [(i)
(check who inspector? i) (check who inspector? i)
(new-inspector (inspector-parent i))])) (new-inspector (inspector-parent i))]))
@ -427,11 +427,11 @@
(define make-struct-type (define make-struct-type
(case-lambda (case-lambda
[(name parent-rtd init-count auto-count) [(name parent-rtd init-count auto-count)
(make-struct-type name parent-rtd init-count auto-count #f '() (|#%app| current-inspector) #f '() #f name)] (make-struct-type name parent-rtd init-count auto-count #f '() (current-inspector) #f '() #f name)]
[(name parent-rtd init-count auto-count auto-val) [(name parent-rtd init-count auto-count auto-val)
(make-struct-type name parent-rtd init-count auto-count auto-val '() (|#%app| current-inspector) #f '() #f name)] (make-struct-type name parent-rtd init-count auto-count auto-val '() (current-inspector) #f '() #f name)]
[(name parent-rtd init-count auto-count auto-val props) [(name parent-rtd init-count auto-count auto-val props)
(make-struct-type name parent-rtd init-count auto-count auto-val props (|#%app| current-inspector) #f '() #f name)] (make-struct-type name parent-rtd init-count auto-count auto-val props (current-inspector) #f '() #f name)]
[(name parent-rtd init-count auto-count auto-val props insp) [(name parent-rtd init-count auto-count auto-val props insp)
(make-struct-type name parent-rtd init-count auto-count auto-val props insp #f '() #f name)] (make-struct-type name parent-rtd init-count auto-count auto-val props insp #f '() #f name)]
[(name parent-rtd init-count auto-count auto-val props insp proc-spec) [(name parent-rtd init-count auto-count auto-val props insp proc-spec)
@ -499,9 +499,9 @@
(define struct-type-install-properties! (define struct-type-install-properties!
(case-lambda (case-lambda
[(rtd name init-count auto-count parent-rtd) [(rtd name init-count auto-count parent-rtd)
(struct-type-install-properties! rtd name init-count auto-count parent-rtd '() (|#%app| current-inspector) #f '() #f name #f)] (struct-type-install-properties! rtd name init-count auto-count parent-rtd '() (current-inspector) #f '() #f name #f)]
[(rtd name init-count auto-count parent-rtd props) [(rtd name init-count auto-count parent-rtd props)
(struct-type-install-properties! rtd name init-count auto-count parent-rtd props (|#%app| current-inspector) #f '() #f name #f)] (struct-type-install-properties! rtd name init-count auto-count parent-rtd props (current-inspector) #f '() #f name #f)]
[(rtd name init-count auto-count parent-rtd props insp) [(rtd name init-count auto-count parent-rtd props insp)
(struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp #f '() #f name #f)] (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp #f '() #f name #f)]
[(rtd name init-count auto-count parent-rtd props insp proc-spec) [(rtd name init-count auto-count parent-rtd props insp proc-spec)
@ -1041,7 +1041,7 @@
(and (not (eq? insp none)) (and (not (eq? insp none))
(or (not insp) (or (not insp)
(eq? insp 'prefab) (eq? insp 'prefab)
(inspector-superior? (|#%app| current-inspector) insp))))) (inspector-superior? (current-inspector) insp)))))
;; Check whether a structure type is fully transparent ;; Check whether a structure type is fully transparent
(define (struct-type-transparent? rtd) (define (struct-type-transparent? rtd)

2
racket/src/racket/src/schvers.h
View File

@ -16,7 +16,7 @@
#define MZSCHEME_VERSION_X 7 #define MZSCHEME_VERSION_X 7
#define MZSCHEME_VERSION_Y 4 #define MZSCHEME_VERSION_Y 4
#define MZSCHEME_VERSION_Z 0 #define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 5 #define MZSCHEME_VERSION_W 6
/* A level of indirection makes `#` work as needed: */ /* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x #define AS_a_STR_HELPER(x) #x

4
racket/src/schemify/infer-known.rkt
View File

@ -4,7 +4,7 @@
"known.rkt" "known.rkt"
"import.rkt" "import.rkt"
"simple.rkt" "simple.rkt"
"pthread-parameter.rkt" "parameter-result.rkt"
"constructed-procedure.rkt" "constructed-procedure.rkt"
"literal.rkt" "literal.rkt"
"inline.rkt" "inline.rkt"
@ -67,7 +67,7 @@
[else known]))] [else known]))]
[defn a-known-constant] [defn a-known-constant]
[else (known-copy rhs)])] [else (known-copy rhs)])]
[(pthread-parameter? rhs prim-knowns knowns mutated) [(parameter-result? rhs prim-knowns knowns mutated)
(known-procedure 3)] (known-procedure 3)]
[(constructed-procedure-arity-mask rhs) [(constructed-procedure-arity-mask rhs)
=> (lambda (m) (known-procedure m))] => (lambda (m) (known-procedure m))]

23
racket/src/schemify/parameter-result.rkt Normal file
View File

@ -0,0 +1,23 @@
#lang racket/base
(require "wrap.rkt"
"known.rkt")
(provide parameter-result?)
(define (parameter-result? v prim-knowns knowns mutated)
(and (wrap-pair? v)
(let ([v (wrap-cdr v)])
(and (wrap-pair? v)
(let ([v (wrap-cdr v)])
(or (wrap-null? v)
(and (wrap-pair? v)
(wrap-null? (wrap-cdr v)))))))
(let ([u-rator (unwrap (wrap-car v))])
(or (eq? u-rator 'make-parameter)
(eq? u-rator 'make-pthread-parameter)
(and (symbol? u-rator)
(let ([k (hash-ref knowns u-rator #f)])
(and (known-copy? k)
(let ([id (known-copy-id k)])
(or (eq? 'make-parameter id)
(eq? 'make-pthread-parameter id))))))))))

16
racket/src/schemify/pthread-parameter.rkt
View File

@ -1,16 +0,0 @@
#lang racket/base
(require "wrap.rkt"
"known.rkt")
(provide pthread-parameter?)
(define (pthread-parameter? v prim-knowns knowns mutated)
(and (wrap-pair? v)
(wrap-pair? (wrap-cdr v))
(wrap-null? (wrap-cdr (wrap-cdr v)))
(let ([u-rator (unwrap (wrap-car v))])
(or (eq? u-rator 'make-pthread-parameter)
(and (symbol? u-rator)
(let ([k (hash-ref knowns u-rator #f)])
(and (known-copy? k)
(eq? 'make-pthread-parameter (known-copy-id k)))))))))