test: name/sc remembers if flat or not

This is slower than previous commit, 31s

Author: bennn

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

@@ -23,7 +23,8 @@
 (provide with-new-name-tables
          name/sc:
          lookup-name-defined
-         set-name-defined)
+         set-name-defined
+         set-flat-names!)
 
 (provide/cond-contract
  [get-all-name-defs
@@ -41,6 +42,12 @@
 (define name-sc-table (make-parameter (make-hash)))
 (define name-defs-table (make-parameter (make-hash)))
 
+(define (set-flat-names! gen-names)
+  (for* ([ns (in-hash-values (name-sc-table))]
+         [n (in-list ns)]
+         #:when (member (name-combinator-gen-name n) gen-names))
+    (set-name-combinator-flat! n #true)))
+
 ;; Use this table to track whether a contract has already been
 ;; generated for this name type yet. Stores booleans.
 (define name-defined-table (make-parameter (make-free-id-table)))
@@ -91,7 +98,7 @@
              type
              (list typed-sc untyped-sc both-sc)))
 
-(struct name-combinator combinator (gen-name)
+(struct name-combinator combinator (gen-name [flat #:auto #:mutable])
   #:transparent
   #:property prop:combinator-name "name/sc"
   #:methods gen:sc
@@ -101,8 +108,13 @@
    (define (sc->contract v f)
      (name-combinator-gen-name v))
    (define (sc->constraints v f)
-     (variable-contract-restrict (name-combinator-gen-name v)))])
+     (variable-contract-restrict (name-combinator-gen-name v)))
+   (define (sc-terminal-kind v)
+     (if (name-combinator-flat v)
+       'flat
+       #f))])
 
 (define-match-expander name/sc:
   (syntax-parser
-    [(_ var) #'(name-combinator _ var)]))
+    [(_ var) #'(name-combinator _ var _)]))
+

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

@@ -37,13 +37,23 @@
            compute-recursive-kinds
            instantiate/inner))
 
+(define (name/sc? v)
+  (printf "nmae? ~a~n" v)
+  (match v
+   [(name/sc: _) #true]
+   [_ #false]))
+
 (define (instantiate/optimize sc fail kind #:cache cache #:trusted-positive trusted-positive #:trusted-negative trusted-negative)
   (define recursive-kinds
     (with-handlers [(exn:fail:constraint-failure?
                       (lambda (exn) (fail #:reason (exn:fail:constraint-failure-reason exn))))]
       (compute-recursive-kinds
         (contract-restrict-recursive-values (compute-constraints sc kind)))))
-  (define sc/opt (optimize sc #:trusted-positive trusted-positive #:trusted-negative trusted-negative #:recursive-kinds recursive-kinds))
+  (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))
   (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

@@ -110,15 +110,15 @@
 
 
 ;; Reduce a static contract assuming that we trusted the current side
-(define (trusted-side-reduce sc flat?)
+(define (trusted-side-reduce 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?) ...) any/sc]
-    [(? flat?) any/sc]
+    [(or/sc: (? flat-terminal-kind?) ...) any/sc]
+    [(? flat-terminal-kind?) 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
@@ -176,13 +176,13 @@
 ;; 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 flat?)
+(define (update-side sc side)
   (match sc
    [(or/sc: scs ...)
-    #:when (not (andmap flat? scs))
+    #:when (not (andmap flat-terminal-kind? scs))
     (weaken-side side)]
    [_
-    #:when (guarded-sc? sc flat?)
+    #:when (guarded-sc? sc)
     (strengthen-side side)]
    [_
     ;; Keep same side by default.
@@ -193,9 +193,9 @@
 ;; guarded-sc? : sc? -> boolean?
 ;; Returns #true if the given static contract represents a type with a "real"
 ;;  type constructor. E.g. list/sc is "real" and or/sc is not.
-(define (guarded-sc? sc flat?)
+(define (guarded-sc? sc)
   (match sc
-   [(or (? flat?)
+   [(or (? flat-terminal-kind?)
         (->/sc: _ _ _ _ _ _)
         (arr/sc: _ _ _)
         (async-channel/sc: _)
@@ -295,22 +295,7 @@
 
 
 ;; 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] #:recursive-kinds [recursive-kinds #f])
-  (define flat?/sc
-    (let* ([flat-names
-            (and recursive-kinds
-                 (for/set ([(k v) (in-hash recursive-kinds)]
-                           #:when (eq? 'flat v))
-                   k))])
-      (if flat-names
-        (λ (sc)
-          (match sc
-           [(name/sc: name)
-            (set-member? flat-names name)]
-           [_
-            (flat-terminal-kind? sc)]))
-        flat-terminal-kind?)))
-
+(define (optimize sc #:trusted-positive [trusted-positive #f] #:trusted-negative [trusted-negative #f])
   ;; single-step: reduce and trusted-side-reduce if appropriate
   (define (single-step sc maybe-weak-side)
     (define trusted
@@ -323,14 +308,14 @@
 
     (reduce
       (if trusted
-          (trusted-side-reduce sc flat?/sc)
+          (trusted-side-reduce 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 flat?/sc))
+      (define next-side (update-side sc curr-side))
       (single-step (sc-map sc (recur next-side)) curr-side))
     ((recur 'positive) sc 'covariant))