suzanne.soy/typed-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.

original commit: 54bc1732da258f4d1f979fde24c793790b8c50ba
This commit is contained in:
Asumu Takikawa 2013-08-15 16:21:03 -04:00
parent 02f61dbd05
commit 5b6fcb01dc
1 changed files with 34 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
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)
(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 (numeric? t) (match t [(Base: _ _ _ b) b] [(Value: (? number?)) #t] [_ #f]))
(define (split-union ts)
@ -92,17 +94,27 @@
[(PolyRow-names: ns c b) `(make-PolyRow (list ,@(map sub ns))
(quote ,c) ,(sub b))]
[(Class: row inits fields methods augments)
;; FIXME: there's probably a better way to do this
(define (convert members [inits? #f])
(for/list ([m members])
`(list (quote ,(car m))
,(sub (cadr m))
,@(if inits? (cddr m) '()))))
`(make-Class ,(sub row)
(list ,@(convert inits #t))
(list ,@(convert fields))
(list ,@(convert methods))
(list ,@(convert 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
(define (convert members [inits? #f])
(for/list ([m members])
`(list (quote ,(car m))
,(sub (cadr m))
,@(if inits? (cddr m) '()))))
(define class-type
`(make-Class ,(sub row)
(list ,@(convert inits #t))
(list ,@(convert fields))
(list ,@(convert methods))
(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)
`(make-arr ,(sub dom) ,(sub rng) ,(sub rest) ,(sub drest) ,(sub kws))]
[(TypeFilter: t p i)
@ -131,12 +143,21 @@
#f)))
(define (make-init-code map f)
(define class-type-cache (box '()))
(define (bound-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)
(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)
(datum->syntax #'here (print-convert ty)))