Simplify recursive contracts when optimizing.

original commit: 738efdc263c347321879e73405425cff2558c14b

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

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