test: pass recursive kinds to optimizer

Author: bennn

typed-racket-lib/typed-racket/static-contracts/combinators/name.rkt

@@ -17,18 +17,13 @@
          racket/match
          racket/syntax
          syntax/private/id-table
-         (only-in syntax/private/id-set
-           mutable-free-id-set
-           free-id-set-add!
-           free-id-set-member?)
          (for-syntax racket/base
                      syntax/parse))
 
 (provide with-new-name-tables
          name/sc:
          lookup-name-defined
-         set-name-defined
-         set-flat-names!)
+         set-name-defined)
 
 (provide/cond-contract
  [get-all-name-defs
@@ -45,12 +40,6 @@
 
 (define name-sc-table (make-parameter (make-hash)))
 (define name-defs-table (make-parameter (make-hash)))
-(define current-flat-names (make-parameter (mutable-free-id-set)))
-
-(define (set-flat-names! gen-names)
-  (define cfn (current-flat-names))
-  (for ((stx (in-list gen-names)))
-    (free-id-set-add! cfn stx)))
 
 ;; Use this table to track whether a contract has already been
 ;; generated for this name type yet. Stores booleans.
@@ -67,8 +56,7 @@
 (define-syntax-rule (with-new-name-tables e)
   (parameterize ([name-sc-table (make-hash)]
                  [name-defs-table (make-hash)]
-                 [name-defined-table (make-free-id-table)]
-                 [current-flat-names (mutable-free-id-set)])
+                 [name-defined-table (make-free-id-table)])
     e))
 
 (define (get-all-name-defs)
@@ -113,13 +101,8 @@
    (define (sc->contract v f)
      (name-combinator-gen-name v))
    (define (sc->constraints v f)
-     (variable-contract-restrict (name-combinator-gen-name v)))
-   (define (sc-terminal-kind v)
-     (if (free-id-set-member? (current-flat-names) (name-combinator-gen-name v))
-       'flat
-       #false))])
+     (variable-contract-restrict (name-combinator-gen-name v)))])
 
 (define-match-expander name/sc:
   (syntax-parser
     [(_ var) #'(name-combinator _ var)]))
-

typed-racket-lib/typed-racket/static-contracts/instantiate.rkt

@@ -24,12 +24,15 @@
 (provide static-contract-may-contain-free-ids?)
 
 (provide/cond-contract
+ [instantiate/optimize
+     (parametric->/c (a) ((static-contract? (-> reason (or/c #f string?) a))
+                          (contract-kind? #:cache hash? #:trusted-positive boolean? #:trusted-negative boolean?)
+                          . ->* . (or/c a (list/c (listof syntax?) syntax?))))]
  [instantiate
      (parametric->/c (a) ((static-contract? (-> #:reason (or/c #f string?) a))
                           (contract-kind? #:cache hash?)
                           . ->* . (or/c a (list/c (listof syntax?) syntax?))))]
  [should-inline-contract? (-> syntax? boolean?)])
-(provide instantiate/optimize)
 
 ;; Providing these so that tests can work directly with them.
 (module* internals #f
@@ -43,11 +46,7 @@
                       (lambda (exn) (fail #:reason (exn:fail:constraint-failure-reason exn))))]
       (compute-recursive-kinds
         (contract-restrict-recursive-values (compute-constraints sc kind)))))
-  (set-flat-names!
-    (for/list ([(k v) (in-hash recursive-kinds)]
-               #:when (eq? 'flat v))
-      k))
-  (define sc/opt (optimize sc #:trusted-positive trusted-positive #:trusted-negative trusted-negative))
+  (define sc/opt (optimize sc #:trusted-positive trusted-positive #:trusted-negative trusted-negative #:recursive-kinds recursive-kinds))
   (instantiate sc/opt fail kind #:cache cache #:recursive-kinds recursive-kinds))
 
 ;; kind is the greatest kind of contract that is supported, if a greater kind would be produced the

typed-racket-lib/typed-racket/static-contracts/optimize.rkt

@@ -17,7 +17,7 @@
 
 
 (provide/cond-contract
- [optimize ((static-contract?) (#:trusted-positive boolean? #:trusted-negative boolean?)
+ [optimize ((static-contract?) (#:trusted-positive boolean? #:trusted-negative boolean? #:recursive-kinds (or/c #f hash?))
                                . ->* . static-contract?)])
 
 ;; Reduce a static contract to a smaller simpler one that protects in the same way
@@ -110,25 +110,22 @@
 
 
 ;; Reduce a static contract assuming that we trusted the current side
-(define (trusted-side-reduce sc)
+(define (trusted-side-reduce sc flat-sc?)
   (match sc
     [(->/sc: mand-args opt-args mand-kw-args opt-kw-args rest-arg (list (any/sc:) ...))
      (function/sc #t mand-args opt-args mand-kw-args opt-kw-args rest-arg #f)]
     [(arr/sc: args rest (list (any/sc:) ...))
      (arr/sc args rest #f)]
     [(none/sc:) any/sc]
-    [(or/sc: (? flat-terminal-kind?) ...) any/sc]
-    [(? flat-terminal-kind?) any/sc]
+    [(or/sc: (? flat-sc?) ...) any/sc]
+    [(? flat-sc?) any/sc]
     [(syntax/sc: (? recursive-sc?))
      ;;bg; _temporary_ case to allow contracts from the `Syntax` type.
      ;;    This is temporary until TR has types for immutable-vector
      ;;    and box-immutable & changes the definition of the `Syntax` type.
      any/sc]
     [else sc]))
 
-(define (flat-terminal-kind? sc)
-  (eq? 'flat (sc-terminal-kind sc)))
-
 ;; The side of a static contract describes the source of the values that
 ;;  the contract needs to check.
 ;; - 'positive : values exported by the server module
@@ -176,10 +173,10 @@
 ;; update-side : sc? weak-side? -> weak-side?
 ;; Change the current side to something safe & strong-as-possible
 ;;  for optimizing the sub-contracts of the given `sc`.
-(define (update-side sc side)
+(define (update-side sc side flat-sc?)
   (match sc
    [(or/sc: scs ...)
-    #:when (not (andmap flat-terminal-kind? scs))
+    #:when (not (andmap flat-sc? scs))
     (weaken-side side)]
    [_
     #:when (guarded-sc? sc)
@@ -195,8 +192,7 @@
 ;;  type constructor. E.g. list/sc is "real" and or/sc is not.
 (define (guarded-sc? sc)
   (match sc
-   [(or (? flat-terminal-kind?)
-        (->/sc: _ _ _ _ _ _)
+   [(or (->/sc: _ _ _ _ _ _)
         (arr/sc: _ _ _)
         (async-channel/sc: _)
         (box/sc: _)
@@ -295,7 +291,23 @@
 
 
 ;; 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])
+(define (optimize sc #:trusted-positive [trusted-positive #f] #:trusted-negative [trusted-negative #f] #:recursive-kinds [recursive-kinds #f])
+  (define sc->kind
+    (if (not recursive-kinds)
+      sc-terminal-kind
+      (λ (sc)
+        (let loop ([sc sc])
+          (match sc
+           [(recursive-sc _ _ body)
+            (loop body)]
+           [(or (recursive-sc-use id)
+                (name/sc: id))
+            (hash-ref recursive-kinds id #f)]
+           [_
+            (sc-terminal-kind sc)])))))
+  (define (flat-sc? sc)
+    (eq? 'flat (sc->kind sc)))
+
   ;; single-step: reduce and trusted-side-reduce if appropriate
   (define (single-step sc maybe-weak-side)
     (define trusted
@@ -308,14 +320,14 @@
 
     (reduce
       (if trusted
-          (trusted-side-reduce sc)
+          (trusted-side-reduce sc flat-sc?)
           sc)))
 
   ;; full-pass: single-step at every static contract subpart
   (define (full-pass sc)
     (define ((recur side) sc variance)
       (define curr-side (combine-variance side variance))
-      (define next-side (update-side sc curr-side))
+      (define next-side (update-side sc curr-side flat-sc?))
       (single-step (sc-map sc (recur next-side)) curr-side))
     ((recur 'positive) sc 'covariant))