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

Increase named-based sharing of class types

Browse Source 
This change makes serialized types much smaller when large
class types are used for type aliases. This shrunk the zo file
for the gui-types module from 12MB to 220KB.

If large zo files are a problem elsewhere, this may be worth
doing for more types.
This commit is contained in:
Asumu Takikawa 2013-08-15 16:21:03 -04:00
parent 37c1730bb3
commit 54bc1732da
1 changed files with 34 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/init-envs.rkt vendored
View File

@ -42,6 +42,8 @@
(define (initialize-type-env initial-env) (define (initialize-type-env initial-env)
(for-each (lambda (nm/ty) (register-type-if-undefined (car nm/ty) (cadr nm/ty))) initial-env)) (for-each (lambda (nm/ty) (register-type-if-undefined (car nm/ty) (cadr nm/ty))) initial-env))
(define current-class-cache (make-parameter #f))
(define (converter v basic sub) (define (converter v basic sub)
(define (numeric? t) (match t [(Base: _ _ _ b) b] [(Value: (? number?)) #t] [_ #f])) (define (numeric? t) (match t [(Base: _ _ _ b) b] [(Value: (? number?)) #t] [_ #f]))
(define (split-union ts) (define (split-union ts)
@ -92,17 +94,27 @@
[(PolyRow-names: ns c b) `(make-PolyRow (list ,@(map sub ns)) [(PolyRow-names: ns c b) `(make-PolyRow (list ,@(map sub ns))
(quote ,c) ,(sub b))] (quote ,c) ,(sub b))]
[(Class: row inits fields methods augments) [(Class: row inits fields methods augments)
(cond [(and (current-class-cache)
(dict-ref (unbox (current-class-cache)) v #f)) => car]
[else
;; FIXME: there's probably a better way to do this ;; FIXME: there's probably a better way to do this
(define (convert members [inits? #f]) (define (convert members [inits? #f])
(for/list ([m members]) (for/list ([m members])
`(list (quote ,(car m)) `(list (quote ,(car m))
,(sub (cadr m)) ,(sub (cadr m))
,@(if inits? (cddr m) '())))) ,@(if inits? (cddr m) '()))))
(define class-type
`(make-Class ,(sub row) `(make-Class ,(sub row)
(list ,@(convert inits #t)) (list ,@(convert inits #t))
(list ,@(convert fields)) (list ,@(convert fields))
(list ,@(convert methods)) (list ,@(convert methods))
(list ,@(convert augments)))] (list ,@(convert augments))))
(define name (gensym))
(define cache-box (current-class-cache))
(when cache-box
(set-box! cache-box
(dict-set (unbox cache-box) v (list name class-type))))
(if cache-box name class-type)])]
[(arr: dom rng rest drest kws) [(arr: dom rng rest drest kws)
`(make-arr ,(sub dom) ,(sub rng) ,(sub rest) ,(sub drest) ,(sub kws))] `(make-arr ,(sub dom) ,(sub rng) ,(sub rest) ,(sub drest) ,(sub kws))]
[(TypeFilter: t p i) [(TypeFilter: t p i)
@ -131,12 +143,21 @@
#f))) #f)))
(define (make-init-code map f) (define (make-init-code map f)
(define class-type-cache (box '()))
(define (bound-f id v) (define (bound-f id v)
(and (bound-in-this-module id) (f id v))) (and (bound-in-this-module id) (f id v)))
(parameterize ((current-print-convert-hook converter) (parameterize ((current-class-cache class-type-cache)
(current-print-convert-hook converter)
;; ignore sharing in all cases
(current-build-share-hook (λ (v basic sub) 'atomic))
(show-sharing #f) (show-sharing #f)
(booleans-as-true/false #f)) (booleans-as-true/false #f))
#`(begin #,@(filter values (map bound-f))))) (define aliases (filter values (map bound-f)))
#`(begin
#,@(for/list ([name+type (dict-values (unbox class-type-cache))])
(match-define (list name type) name+type)
(datum->syntax #'here `(define ,name ,type)))
#,@aliases)))
(define (quote-type ty) (define (quote-type ty)
(datum->syntax #'here (print-convert ty))) (datum->syntax #'here (print-convert ty)))