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 version "7.4.0.5")
(define version "7.4.0.6")
(define deps `("racket-lib"
["racket" #:version ,version]))

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

@ -76,7 +76,7 @@
[else (string->path s)]))
(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)
(seq
@ -381,7 +381,7 @@
(abort-current-continuation (default-continuation-prompt-tag) proc))))
(lambda vals
(for-each (lambda (v)
(|#%app| (|#%app| current-print) v)
(|#%app| (current-print) v)
(flush-output))
vals))))
loads))
@ -582,7 +582,7 @@
(call-with-values (lambda () (eval (datum->kernel-syntax
(cons m (vector->list remaining-command-line-arguments)))))
(lambda results
(let ([p (|#%app| current-print)])
(let ([p (current-print)])
(for-each (lambda (v) (|#%app| p v)) results))))))
;; Set up GC logging
@ -624,7 +624,7 @@
(define peak-mem 0)
(seq
(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
(lambda (gen pre-allocated pre-allocated+overhead pre-time pre-cpu-time
post-allocated post-allocated+overhead post-time post-cpu-time)
@ -653,9 +653,9 @@
;; in interrupt:
#t)))))))))
(seq
(|#%app| exit-handler
(let ([orig (|#%app| exit-handler)]
[root-logger (|#%app| current-logger)])
(exit-handler
(let ([orig (exit-handler)]
[root-logger (current-logger)])
(lambda (v)
(when (log-level? root-logger 'info 'GC)
(log-message root-logger 'info 'GC
@ -693,40 +693,40 @@
'()))))
(define (initialize-place!)
(|#%app| current-command-line-arguments remaining-command-line-arguments)
(|#%app| use-compiled-file-paths compiled-file-paths)
(|#%app| use-user-specific-search-paths user-specific-search-paths?)
(|#%app| load-on-demand-enabled load-on-demand?)
(current-command-line-arguments remaining-command-line-arguments)
(use-compiled-file-paths compiled-file-paths)
(use-user-specific-search-paths user-specific-search-paths?)
(load-on-demand-enabled load-on-demand?)
(unless (eq? compile-target-machine (machine-type))
(|#%app| current-compile-target-machine compile-target-machine))
(current-compile-target-machine compile-target-machine))
(boot)
(when (and 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
(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
(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
(set-host-collects-dir! host-collects-dir))
(when host-config-dir
(set-host-config-dir! host-config-dir))
(cond
[(eq? init-collects-dir 'disable)
(|#%app| use-collection-link-paths #f)
(use-collection-link-paths #f)
(set-collects-dir! (build-path 'same))]
[else
(set-collects-dir! init-collects-dir)])
(set-config-dir! init-config-dir)
(unless (eq? init-collects-dir 'disable)
(|#%app| current-library-collection-links
(current-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))))
(when compiled-roots-path-list-string
(|#%app| current-compiled-file-roots
(current-compiled-file-roots
(let ([s (regexp-replace* "@[(]version[)]"
compiled-roots-path-list-string
(version))])
@ -797,7 +797,7 @@
(newline)))
(when yield?
(|#%app| (|#%app| executable-yield-handler) exit-value))
(|#%app| (executable-yield-handler) exit-value))
(exit exit-value))))

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

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

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

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

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

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

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

@ -245,7 +245,7 @@
(define/who random
(case-lambda
[() (pseudo-random-generator-real! (|#%app| current-pseudo-random-generator))]
[() (pseudo-random-generator-real! (current-pseudo-random-generator))]
[(n)
(cond
[(pseudo-random-generator? n)
@ -257,7 +257,7 @@
(<= 1 n 4294967087))
:contract "(or/c (integer-in 1 4294967087) pseudo-random-generator?)"
n)
(pseudo-random-generator-integer! (|#%app| current-pseudo-random-generator) n)])]
(pseudo-random-generator-integer! (current-pseudo-random-generator) n)])]
[(n prg)
(check who
:test (and (integer? n)
@ -274,4 +274,4 @@
(<= k (sub1 (expt 2 31))))
:contract "(integer-in 0 (sub1 (expt 2 31)))"
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
(case-lambda
[() (new-inspector (|#%app| current-inspector))]
[() (new-inspector (current-inspector))]
[(i)
(check who inspector? i)
(new-inspector i)]))
(define/who make-sibling-inspector
(case-lambda
[() (make-sibling-inspector (|#%app| current-inspector))]
[() (make-sibling-inspector (current-inspector))]
[(i)
(check who inspector? i)
(new-inspector (inspector-parent i))]))
@ -427,11 +427,11 @@
(define make-struct-type
(case-lambda
[(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)
(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)
(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)
(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)
@ -499,9 +499,9 @@
(define struct-type-install-properties!
(case-lambda
[(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)
(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)
(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)
@ -1041,7 +1041,7 @@
(and (not (eq? insp none))
(or (not insp)
(eq? insp 'prefab)
(inspector-superior? (|#%app| current-inspector) insp)))))
(inspector-superior? (current-inspector) insp)))))
;; Check whether a structure type is fully transparent
(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_Y 4
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 5
#define MZSCHEME_VERSION_W 6
/* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x

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

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