Make subtyping checks on objects faster

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)
+               ;; FIXME: instead of sorting here every time
-               (append fields row-fields)
+               ;;        the match expander is called, the row
-               (append methods row-methods)
+               ;;        fields should be merged on substitution
-               (append augments row-augments))]
+               (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 ()

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)
+            ;; invariant: map and map* are sorted by key
-            (match-define (list (and s* (list names* types*)) ...) map*)
+            (let loop ([A A0] [map map] [map* map*])
-            (for/fold ([A A0])
+              (cond [(or (empty? map) (empty? map*)) #t]
-                      ([n names*] [m types*] #:break (not A))
+                    [else
-              (and A (cond [(assq n s) =>
+                     (match-define (list name type) (car map))
-                            (lambda (spec) (subtype* A (cadr spec) m))]
+                     (match-define (list name* type*) (car map*))
-                           [else #f]))))
+                     (cond [;; quit if 2nd obj lacks a name in 1st obj
-          (and ;; Note that augment/public doesn't matter for object
+                            (symbol<? name* name)
-               ;; subtyping, so these mappings can be merged
+                            #f]
-               (subtype-clause? (append method-map augment-map)
+                           [;; if 1st obj lacks a name in 2nd obj, try
-                                (append method-map* augment-map*))
+                            ;; 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,10 +606,6 @@
           ;; 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)
@@ -618,7 +621,7 @@
               (and (= (length names) (length names*))
                    (andmap equal? names names*)
                    (andmap sub types types*)
-                     (andmap equal? opt? opt?*))])))
+                   (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