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

Make subtyping checks on objects faster

Browse Source
This commit is contained in:
Asumu Takikawa 2013-08-22 12:12:36 -04:00
parent e80c4d72fb
commit c8e5423e55
2 changed files with 62 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt
View File

@ -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 ()

66
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/subtype.rkt
View File

@ -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