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

cs: use anonymous-field record types

Browse Source 
Record types with unnamed fields can be significantly more compact,
excdeption in combination with the constrain the the fields all
contain Scheme objects. Saves 2% for DrRacket's initial footprint.
This commit is contained in:
Matthew Flatt 2020-02-10 15:07:45 -07:00
parent fb63f399ef
commit 5e45dd2e1c
12 changed files with 102 additions and 42 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.6.0.11")
(define version "7.6.0.12")
(define deps `("racket-lib"
["racket" #:version ,version]))

7
racket/src/cs/bootstrap/r6rs-lang.rkt
View File

@ -79,6 +79,7 @@
define-record-type
record-type-descriptor
make-record-type-descriptor
make-record-type-descriptor*
make-record-constructor-descriptor
(rename-out [s:struct-type? record-type-descriptor?])
record-constructor-descriptor
@ -595,6 +596,12 @@
(define (make-record-type-descriptor name parent uid s? o? fields)
(do-$make-record-type base-rtd parent name fields s? o? null #:uid uid))
(define (make-record-type-descriptor* name parent uid s? o? num-fields mutability-mask)
(define fields (for ([i (in-range num-fields)])
(list (if (bitwise-bit-set? mutability-mask i) 'mutable 'immutable)
(string->symbol (format "f~a" i)))))
(do-$make-record-type base-rtd parent name fields s? o? null #:uid uid))
(define (make-record-constructor-descriptor rtd parent-rcd protocol)
(rec-cons-desc rtd parent-rcd protocol))

25
racket/src/cs/bootstrap/record.rkt
View File

@ -36,7 +36,9 @@
record-type-opaque?
record-type-parent
record-type-field-names
record-type-field-indices
csv7:record-type-field-names
csv7:record-type-field-indices
csv7:record-type-field-decls
record-writer
$object-ref)
@ -484,6 +486,18 @@
[else
(map fld-name (hash-ref rtd-fields rtd))]))
;; all fields, including from parent
(define (csv7:record-type-field-indices rtd)
(cond
[(base-rtd? rtd)
(for/list ([f (in-list base-rtd-fields)]
[i (in-naturals)])
i)]
[else
(for/list ([f (in-list (hash-ref rtd-fields rtd))]
[i (in-naturals)])
i)]))
;; does not include parent fields
(define (record-type-field-names rtd)
(cond
@ -496,6 +510,17 @@
(define fields (reverse (take (reverse all-fields) init-cnt)))
(list->vector (map fld-name fields))]))
;; does not include parent fields
(define (record-type-field-indices rtd)
(cond
[(base-rtd? rtd)
(list->vector (csv7:record-type-field-indices rtd))]
[else
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
(struct-type-info rtd))
(for/vector ([i (in-range init-cnt)])
i)]))
(define (csv7:record-type-field-decls rtd)
(map (lambda (v) (list (if (fld-mutable? v) 'mutable 'immutable) (fld-type v) (fld-name v)))
(hash-ref rtd-fields rtd)))

9
racket/src/cs/bootstrap/scheme-lang.rkt
View File

@ -49,6 +49,7 @@
enumerate
$make-record-type
$make-record-type-descriptor
$make-record-type-descriptor*
$make-record-constructor-descriptor
$record
$record?
@ -78,7 +79,9 @@
record-type-opaque?
record-type-parent
record-type-field-names
record-type-field-indices
csv7:record-type-field-names
csv7:record-type-field-indices
csv7:record-type-field-decls
(rename-out [record-rtd $record-type-descriptor])
record?
@ -649,6 +652,12 @@
(define ($make-record-constructor-descriptor rtd prcd protocol who)
(make-record-constructor-descriptor rtd prcd protocol))
(define ($make-record-type-descriptor* base-rtd name parent uid sealed? opaque? num-fields mutability-mask who . extras)
(define fields (for ([i (in-range num-fields)])
(list (if (bitwise-bit-set? mutability-mask i) 'mutable 'immutable)
(string->symbol (format "f~a" i)))))
(apply $make-record-type-descriptor base-rtd name parent uid sealed? opaque? fields who extras))
(define-syntax-rule (s:module (id ...) body ...)
(begin
body ...))

9
racket/src/cs/compile-file.ss
View File

@ -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 19))
(values 9 5 3 20))
(unless (guard (x [else #f]) (eval 'scheme-fork-version-number))
(error 'compile-file
@ -79,6 +79,13 @@
=> (lambda (args)
(set! xpatch-path (car args))
(loop (cdr args)))]
[(get-opt args "--show-cp0" 0)
=> (lambda (args)
(run-cp0 (lambda (cp0 x)
(let ([r (cp0 (cp0 x))])
(pretty-print (#%$uncprep r))
r)))
(loop (cdr args)))]
[(null? args)
(error 'compile-file "missing source file")]
[else

1
racket/src/cs/primitive/internal.ss
View File

@ -20,6 +20,7 @@
[set-box!/check-undefined (known-constant)]
[make-record-type-descriptor (known-constant)]
[make-record-type-descriptor* (known-constant)]
[make-record-constructor-descriptor (known-constant)]
[record-constructor (known-constant)]
[record-predicate (known-constant)]

2
racket/src/cs/rumble/check.ss
View File

@ -73,4 +73,4 @@
(unless (and (integer? v)
(exact? v)
(<= lo v hi))
(raise-argument-error who v (format "(integer-in ~a ~a)" lo hi))))
(raise-argument-error who (format "(integer-in ~a ~a)" lo hi) v)))

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

@ -504,10 +504,12 @@
[parent-fi (if parent-rtd*
(struct-type-field-info parent-rtd*)
empty-field-info)]
[rtd (make-record-type-descriptor name
parent-rtd*
prefab-uid #f #f
(make-fields (+ init-count auto-count)))]
[rtd (make-record-type-descriptor* name
parent-rtd*
prefab-uid #f #f
(+ init-count auto-count)
;; Reporting all as mutable, for now:
(sub1 (bitwise-arithmetic-shift-left 1 (+ init-count auto-count))))]
[parent-auto*-count (get-field-info-auto*-count parent-fi)]
[parent-init*-count (get-field-info-init*-count parent-fi)]
[parent-total*-count (get-field-info-total*-count parent-fi)]
@ -608,7 +610,7 @@
;; Register guard
(register-guards! rtd parent-rtd guard 'at-start))))]))
;; Field count (init + auto) not including paren fields
;; Field count (init + auto) not including parent fields
(define (record-type-field-count rtd)
(fx- (#%$record-type-field-count rtd)
(let ([parent-rtd (record-type-parent rtd)])
@ -668,10 +670,13 @@
(cdr parent-prefab-key+count)
0))]
[uid (encode-prefab-key+count-as-symbol prefab-key+count)]
[rtd (make-record-type-descriptor name
parent-rtd
uid #f #f
(make-fields total-count))]
[rtd (make-record-type-descriptor* name
parent-rtd
uid #f #f
total-count
;; All fields must be reported as mutable, because
;; we might need to mutate to create cyclic data:
(sub1 (bitwise-arithmetic-shift-left 1 total-count)))]
[mutables (prefab-key-mutables prefab-key)])
(with-global-lock
(cond
@ -1220,16 +1225,6 @@
(vector (string->symbol (format "struct:~a" ((inspect/object s*) 'type))) dots)))]
[(s) (struct->vector s '...)]))
;; ----------------------------------------
(define (make-fields field-count)
(list->vector
(let loop ([i 0])
(if (= i field-count)
'()
(cons `(mutable ,(string->symbol (format "f~a" i)))
(loop (fx1+ i)))))))
;; ----------------------------------------
;; Convenience for Rumble implementation:
@ -1257,6 +1252,7 @@
(cond
[(null? fields) (reverse accum)]
[else (loop (cdr fields) (cons pos accum) (add1 pos))]))]
[field-count (length #'(field ...))]
[struct:parent (if (syntax->datum #'parent)
(make-id #'parent "struct:~a" (syntax->datum #'parent))
#f)])
@ -1266,7 +1262,7 @@
#'mk))]
[uid (datum->syntax #'name ((current-generate-id) (syntax->datum #'name)))])
#'(begin
(define struct:name (make-record-type-descriptor 'name struct:parent 'uid #f #f '#((immutable field) ...)))
(define struct:name (make-record-type-descriptor* 'name struct:parent 'uid #f #f field-count 0))
(define unsafe-make-name (record-constructor (make-record-constructor-descriptor struct:name #f #f)))
(define name ctr-expr)
(define authentic-name? (record-predicate struct:name))

1
racket/src/expander/compile/built-in-symbol.rkt
View File

@ -77,6 +77,7 @@
engine-block
force-unfasl
make-record-type-descriptor
make-record-type-descriptor*
make-record-constructor-descriptor
record-constructor
record-accessor

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

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

20
racket/src/racket/src/startup.inc
View File

@ -12445,10 +12445,15 @@ static const char *startup_source =
" 'loop"
"(let-values(((v_0)(unbox lock-box_0)))"
"(if(let-values(((or-part_0)(not v_0)))"
"(if or-part_0 or-part_0(sync/timeout 0(car v_0)(cdr v_0))))"
"(if or-part_0"
" or-part_0"
"(sync/timeout 0(car v_0)(weak-box-value(cdr v_0) never-evt))))"
"(let-values()"
"(let-values(((sema_0)(make-semaphore)))"
"(let-values(((lock_0)(cons(semaphore-peek-evt sema_0)(current-thread))))"
"(let-values(((lock_0)"
"(cons"
"(semaphore-peek-evt sema_0)"
"(make-weak-box(current-thread)))))"
"((dynamic-wind"
" void"
"(lambda()"
@ -12456,9 +12461,15 @@ static const char *startup_source =
"(let-values()(begin(proc_0) void))"
"(let-values()(lambda()(loop_0)))))"
"(lambda()(semaphore-post sema_0)))))))"
"(if(eq?(current-thread)(cdr v_0))"
"(if(eq?(current-thread)(weak-box-value(cdr v_0)))"
"(let-values()(proc_0))"
"(let-values()(begin(sync(car v_0)(cdr v_0))(loop_0))))))))))"
"(let-values()"
"(begin"
"(sync"
"(car v_0)"
"(let-values(((or-part_0)(weak-box-value(cdr v_0))))"
"(if or-part_0 or-part_0 never-evt)))"
"(loop_0))))))))))"
" loop_0))))))"
"(define-values"
"(struct:namespace"
@ -20248,6 +20259,7 @@ static const char *startup_source =
" engine-block"
" force-unfasl"
" make-record-type-descriptor"
" make-record-type-descriptor*"
" make-record-constructor-descriptor"
" record-constructor"
" record-accessor"

30
racket/src/schemify/struct-convert.rkt
View File

@ -56,20 +56,22 @@
(define can-impersonate? (not (struct-type-info-authentic? sti)))
(define raw-s? (if can-impersonate? (deterministic-gensym (unwrap s?)) s?))
`(begin
(define ,struct:s (make-record-type-descriptor ',(struct-type-info-name sti)
,(schemify (struct-type-info-parent sti) knowns)
,(if (not (struct-type-info-prefab-immutables sti))
#f
`(structure-type-lookup-prefab-uid
',(struct-type-info-name sti)
,(schemify (struct-type-info-parent sti) knowns)
,(struct-type-info-immediate-field-count sti)
0 #f
',(struct-type-info-prefab-immutables sti)))
#f
#f
',(for/vector ([i (in-range (struct-type-info-immediate-field-count sti))])
`(mutable ,(string->symbol (format "f~a" i))))))
(define ,struct:s (make-record-type-descriptor* ',(struct-type-info-name sti)
,(schemify (struct-type-info-parent sti) knowns)
,(if (not (struct-type-info-prefab-immutables sti))
#f
`(structure-type-lookup-prefab-uid
',(struct-type-info-name sti)
,(schemify (struct-type-info-parent sti) knowns)
,(struct-type-info-immediate-field-count sti)
0 #f
',(struct-type-info-prefab-immutables sti)))
#f
#f
,(struct-type-info-immediate-field-count sti)
;; Reporting all as mutable, for now:
,(let ([n (struct-type-info-immediate-field-count sti)])
(sub1 (arithmetic-shift 1 n)))))
,@(if (null? (struct-type-info-rest sti))
null
`((define ,(deterministic-gensym "effect")