From c8e5423e557cf5976bdb0050b72979b9fb9c76a4 Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Thu, 22 Aug 2013 12:12:36 -0400
Subject: [PATCH] Make subtyping checks on objects faster

---
 .../typed-racket/rep/type-rep.rkt             | 35 ++++++++--
 .../typed-racket/types/subtype.rkt            | 66 ++++++++++---------
 2 files changed, 62 insertions(+), 39 deletions(-)

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt
index ab1584300f..95b24ae34e 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt
@@ -26,13 +26,14 @@
          Values/c SomeValues/c
          Poly-n
          PolyDots-n
-         Class?
+         Class? Row? Row:
          free-vars*
          type-compare type<?
          remove-dups
          sub-f sub-o sub-pe
          (rename-out [Class:* Class:]
                      [Class* make-Class]
+                     [Row* make-Row]
                      [Mu:* Mu:]
                      [Poly:* Poly:]
                      [PolyDots:* PolyDots:]
@@ -457,11 +458,15 @@
 
 ;; A Row used in type instantiation
 ;; For now, this should not appear in user code. It's used
-;; internally to perform row instantiations
+;; internally to perform row instantiations and to represent
+;; class types.
+;;
+;; invariant: all clauses are sorted by the key name
 (def-type Row ([inits (listof (list/c symbol? Type/c boolean?))]
                [fields (listof (list/c symbol? Type/c))]
                [methods (listof (list/c symbol? Function?))]
                [augments (listof (list/c symbol? Function?))])
+  #:no-provide
   [#:frees (λ (f) (combine-frees
                    (map f (append (map cadr inits)
                                   (map cadr fields)
@@ -904,6 +909,15 @@
                          (PolyRow-body* fresh-syms t)))
                  (list nps freshp constrp bp)))])))
 
+;; Row*
+;; This is a custom constructor for Row types
+;; Sorts all clauses by the key (the clause name)
+(define (Row* inits fields methods augments)
+  (*Row (sort-row-clauses inits)
+        (sort-row-clauses fields)
+        (sort-row-clauses methods)
+        (sort-row-clauses augments)))
+
 ;; Class*
 ;; This is a custom constructor for Class types that
 ;; doesn't require writing make-Row everywhere
@@ -914,7 +928,7 @@
       (listof (list/c symbol? Function?))
       (listof (list/c symbol? Function?))
       Class?)
-  (*Class row-var (*Row inits fields methods augments)))
+  (*Class row-var (Row* inits fields methods augments)))
 
 ;; Class:*
 ;; This match expander replaces the built-in matching with
@@ -936,12 +950,19 @@
          (define row-methods (Row-methods row))
          (define row-augments (Row-augments row))
          (list row
-               (append inits row-inits)
-               (append fields row-fields)
-               (append methods row-methods)
-               (append augments row-augments))]
+               ;; FIXME: instead of sorting here every time
+               ;;        the match expander is called, the row
+               ;;        fields should be merged on substitution
+               (sort-row-clauses (append inits row-inits))
+               (sort-row-clauses (append fields row-fields))
+               (sort-row-clauses (append methods row-methods))
+               (sort-row-clauses (append augments row-augments)))]
         [else (list row inits fields methods augments)]))
 
+;; sorts the given field of a Row by the member name
+(define (sort-row-clauses clauses)
+  (sort clauses symbol<? #:key car))
+
 (define-match-expander Class:*
   (λ (stx)
     (syntax-case stx ()
diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/subtype.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/subtype.rkt
index 07dc99144f..8b5156c968 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/subtype.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/subtype.rkt
@@ -580,17 +580,24 @@
          [((Instance: (Class: _ _ field-map method-map augment-map))
            (Instance: (Class: _ _ field-map* method-map* augment-map*)))
           (define (subtype-clause? map map*)
-            (match-define (list (and s (list names types)) ...) map)
-            (match-define (list (and s* (list names* types*)) ...) map*)
-            (for/fold ([A A0])
-                      ([n names*] [m types*] #:break (not A))
-              (and A (cond [(assq n s) =>
-                            (lambda (spec) (subtype* A (cadr spec) m))]
-                           [else #f]))))
-          (and ;; Note that augment/public doesn't matter for object
-               ;; subtyping, so these mappings can be merged
-               (subtype-clause? (append method-map augment-map)
-                                (append method-map* augment-map*))
+            ;; invariant: map and map* are sorted by key
+            (let loop ([A A0] [map map] [map* map*])
+              (cond [(or (empty? map) (empty? map*)) #t]
+                    [else
+                     (match-define (list name type) (car map))
+                     (match-define (list name* type*) (car map*))
+                     (cond [;; quit if 2nd obj lacks a name in 1st obj
+                            (symbol<? name* name)
+                            #f]
+                           [;; if 1st obj lacks a name in 2nd obj, try
+                            ;; the next one
+                            (symbol<? name name*)
+                            (loop A (cdr map) map*)]
+                           [else
+                            (define A* (subtype* A type type*))
+                            (and A* (loop A* (cdr map) (cdr map*)))])])))
+          (and ;; Note that init & augment clauses don't matter for objects
+               (subtype-clause? method-map method-map*)
                (subtype-clause? field-map field-map*))]
          [((Class: row inits fields methods augments)
            (Class: row* inits* fields* methods* augments*))
@@ -599,26 +606,22 @@
           ;; check that each of inits, fields, methods, etc. are
           ;; equal by sorting and checking type equality
           (define (equal-clause? clause clause* [inits? #f])
-            (define (sort-clause lst)
-              (sort lst string<? #:key (compose symbol->string car)))
-            (let ([clause (sort-clause clause)]
-                  [clause* (sort-clause clause*)])
-              (cond
-               [(not inits?)
-                (match-define (list (list names types) ...) clause)
-                (match-define (list (list names* types*) ...) clause*)
-                (and (= (length names) (length names*))
-                     (andmap equal? names names*)
-                     (andmap sub types types*))]
-               [else
-                (match-define (list (list names types opt?) ...)
-                              clause)
-                (match-define (list (list names* types* opt?*) ...)
-                              clause*)
-                (and (= (length names) (length names*))
-                     (andmap equal? names names*)
-                     (andmap sub types types*)
-                     (andmap equal? opt? opt?*))])))
+            (cond
+             [(not inits?)
+              (match-define (list (list names types) ...) clause)
+              (match-define (list (list names* types*) ...) clause*)
+              (and (= (length names) (length names*))
+                   (andmap equal? names names*)
+                   (andmap sub types types*))]
+             [else
+              (match-define (list (list names types opt?) ...)
+                            clause)
+              (match-define (list (list names* types* opt?*) ...)
+                            clause*)
+              (and (= (length names) (length names*))
+                   (andmap equal? names names*)
+                   (andmap sub types types*)
+                   (andmap equal? opt? opt?*))]))
           ;; There is no non-trivial width subtyping on class types, but it's
           ;; possible for two "equal" class types to look different
           ;; in the representation. We deal with that here.
@@ -627,7 +630,6 @@
                    (equal? row row*))
                (equal-clause? inits inits* #t)
                (equal-clause? fields fields*)
-               ;; augment/public distinction is important here
                (equal-clause? methods methods*)
                (equal-clause? augments augments*))]
          ;; otherwise, not a subtype