From 5b6fcb01dc5d0b39b121b12b0a699d8a1de3b67f Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Thu, 15 Aug 2013 16:21:03 -0400
Subject: [PATCH] Increase named-based sharing of class types

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
---
 .../typed-racket/env/init-envs.rkt            | 47 ++++++++++++++-----
 1 file changed, 34 insertions(+), 13 deletions(-)

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/init-envs.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/init-envs.rkt
index 6bb93e48..b235084a 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/init-envs.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/init-envs.rkt
@@ -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)))