diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt index 08501d80..ce5b4ea8 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt @@ -3,12 +3,16 @@ ;; Functionality to optimize a static contract to provide faster checking. ;; Also supports droping checks on either side. -(require "combinators.rkt" - "structures.rkt" - racket/set - racket/list - (except-in racket/contract recursive-contract) - racket/match) +(require + "combinators.rkt" + "structures.rkt" + racket/set + racket/syntax + racket/dict + syntax/id-table + racket/list + (except-in racket/contract recursive-contract) + racket/match) @@ -25,7 +29,7 @@ [(list/sc: sc1 ... (none/sc:) sc2 ...) none/sc] [(set/sc: (none/sc:)) empty-set/sc] [(syntax/sc: (none/sc:)) none/sc] - ;; The following are unsound because chaperones allow operations on these data structures to + ;; The following are unsound because chaperones allow operations on these data structures to ;; can call continuations and thus be useful even if they cannot return values. ;[(vectorof/sc: (none/sc:)) empty-vector/sc] ;[(vector/sc: sc1 ... (none/sc:) sc2 ...) none/sc] @@ -95,6 +99,58 @@ [(contravariant) (invert-side side)] [(invariant) 'both])) +(define (remove-unused-recursive-contracts sc) + (define root (generate-temporary)) + (define main-table (make-free-id-table)) + (define (search) + (define table (make-free-id-table)) + (define (recur sc variance) + (match sc + [(recursive-contract-use id) + (dict-set! table id #t)] + [(recursive-contract names values body) + (recur body 'covariant) + (for ([name (in-list names)] + [value (in-list values)]) + (dict-set! main-table name ((search) value)))] + [else + (sc-traverse sc recur)])) + (lambda (sc) + (recur sc 'covariant) + table)) + (define reachable ((search) sc)) + (define seen (make-free-id-table reachable)) + (let loop ((to-look-at reachable)) + (unless (zero? (dict-count to-look-at)) + (define new-table (make-free-id-table)) + (for ([(id _) (in-dict to-look-at)]) + (for ([(id _) (in-dict (dict-ref main-table id))]) + (unless (dict-has-key? seen id) + (dict-set! seen id #t) + (dict-set! new-table id #t)))) + (loop new-table))) + + (define (trim sc variance) + (match sc + [(recursive-contract names values body) + (define new-body (trim body 'covariant)) + + (define new-name-values + (for/list ([name (in-list names)] + [value (in-list values)] + #:when (dict-ref seen name #f)) + (list name value))) + (define new-names (map first new-name-values)) + (define new-values (map (λ (v) (trim v 'covariant)) + (map second new-name-values))) + (if (empty? new-names) + new-body + (recursive-contract new-names new-values new-body))] + [else + (sc-map sc trim)])) + (trim sc 'covariant)) + + ;; If we trust a specific side then we drop all contracts protecting that side. (define (optimize sc #:trusted-positive [trusted-positive #f] #:trusted-negative [trusted-negative #f]) ;; single-step: reduce and trusted-side-reduce if appropriate @@ -117,9 +173,9 @@ (single-step (sc-map sc (recur new-side)) new-side)) ((recur 'positive) sc 'covariant)) - ;; Do full passes until we reach a fix point + ;; Do full passes until we reach a fix point, and then remove all unneccessary recursive parts (let loop ((sc sc)) (define new-sc (full-pass sc)) (if (equal? sc new-sc) - new-sc + (remove-unused-recursive-contracts new-sc) (loop new-sc)))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/structures.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/structures.rkt index 84ad2f34..6bcf8fe8 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/structures.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/structures.rkt @@ -47,11 +47,12 @@ (fprintf port "(~a " (syntax->datum name)) (recur val port) (display ")" port)) - (recur-pair (first names) (first vals)) - (for ((name (rest names)) - (val (rest vals))) - (display " " port) - (recur-pair name val)) + (when (cons? names) + (recur-pair (first names) (first vals)) + (for ((name (rest names)) + (val (rest vals))) + (display " " port) + (recur-pair name val))) (display ") " port) (recur body port) (display close port))