Merge remote-tracking branch 'upstream/master'

typed-racket-lib/typed-racket/optimizer/sequence.rkt

@@ -1,16 +1,18 @@
 #lang racket/base
 
-(require syntax/parse
-         racket/match
+(require (for-template racket/base
+                       racket/unsafe/ops)
          racket/function
+         racket/match
+         syntax/parse
          syntax/parse/experimental/specialize
-         (for-template racket/base racket/unsafe/ops)
-         "../utils/utils.rkt" "../utils/tc-utils.rkt"
          "../rep/type-rep.rkt"
          "../types/abbrev.rkt"
-         "utils.rkt"
+         "../utils/tc-utils.rkt"
+         "../utils/utils.rkt"
+         "float.rkt"
          "logging.rkt"
-         "float.rkt")
+         "utils.rkt")
 
 (provide sequence-opt-expr)
 

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

@@ -4,9 +4,16 @@
 ;; These are used during optimizations as simplifications.
 ;; Ex: (listof/sc any/sc) => list?/sc
 
-(require "simple.rkt" "structural.rkt"
-         (for-template racket/base racket/list racket/set racket/promise
-                       racket/class racket/unit racket/async-channel racket/future))
+(require (for-template racket/async-channel
+                       racket/base
+                       racket/class
+                       racket/future
+                       racket/list
+                       racket/promise
+                       racket/set
+                       racket/unit)
+         "simple.rkt"
+         "structural.rkt")
 (provide (all-defined-out))
 
 (define identifier?/sc (flat/sc #'identifier?))

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

@@ -27,16 +27,14 @@
      (f rngs 'invariant)
      (void))
    (define (sc->contract v f)
-     (match v
-       [(exist-combinator (list names doms rngs))
-        (parameterize ([static-contract-may-contain-free-ids? #t])
-          (let ([a (with-syntax ([doms-stx (f doms)]
-                                 [rngs-stx (f rngs)]
-                                 [n (car names)])
-                     #'(->i ([n doms-stx])
-                            (_ (n)
-                               rngs-stx)))])
-            a))]))
+     (match-define (exist-combinator (list names doms rngs)) v)
+     (parameterize ([static-contract-may-contain-free-ids? #t])
+       (define a
+         (with-syntax ([doms-stx (f doms)]
+                       [rngs-stx (f rngs)]
+                       [n (car names)])
+           #'(->i ([n doms-stx]) (_ (n) rngs-stx))))
+       a))
    (define (sc->constraints v f)
      (simple-contract-restrict 'flat))])
 

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

@@ -76,10 +76,9 @@
          [else (raise-argument-error 'lookup-name-sc "side?" typed-side)])))
 
 (define (register-name-sc type typed-thunk untyped-thunk both-thunk)
-  (define-values (typed-name untyped-name both-name)
-    (values (generate-temporary)
-            (generate-temporary)
-            (generate-temporary)))
+  (define typed-name (generate-temporary))
+  (define untyped-name (generate-temporary))
+  (define both-name (generate-temporary))
   (hash-set! (name-sc-table)
              type
              (list (name-combinator null typed-name)

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

@@ -35,22 +35,18 @@
   #:property prop:combinator-name "parametric->/sc"
   #:methods gen:sc
     [(define (sc-map v f)
-       (match v
-        [(parametric-combinator (list arg) vars)
-         (parametric-combinator (list (f arg 'covariant)) vars)]))
+       (match-define (parametric-combinator (list arg) vars) v)
+       (parametric-combinator (list (f arg 'covariant)) vars))
      (define (sc-traverse v f)
-       (match v
-        [(parametric-combinator (list arg) vars)
-         (f arg 'covariant)
-         (void)]))
+       (match-define (parametric-combinator (list arg) vars) v)
+       (f arg 'covariant)
+       (void))
      (define (sc->contract v f)
-       (match v
-        [(parametric-combinator (list arg) vars)
-         #`(parametric->/c #,vars #,(f arg))]))
+       (match-define (parametric-combinator (list arg) vars) v)
+       #`(parametric->/c #,vars #,(f arg)))
      (define (sc->constraints v f)
-       (match v
-        [(parametric-combinator (list arg) vars)
-         (merge-restricts* 'impersonator  (list (f arg)))]))])
+       (match-define (parametric-combinator (list arg) vars) v)
+       (merge-restricts* 'impersonator (list (f arg))))])
 
 (define (parametric->/sc vars body)
   (parametric-combinator (list body) vars))
@@ -70,22 +66,18 @@
   #:property prop:combinator-name "sealing->/sc"
   #:methods gen:sc
     [(define (sc-map v f)
-       (match v
-        [(sealing-combinator (list arg) vars members)
-         (sealing-combinator (list (f arg 'covariant)) vars members)]))
+       (match-define (sealing-combinator (list arg) vars members) v)
+       (sealing-combinator (list (f arg 'covariant)) vars members))
      (define (sc-traverse v f)
-       (match v
-        [(sealing-combinator (list arg) vars members)
-         (f arg 'covariant)
-         (void)]))
+       (match-define (sealing-combinator (list arg) vars members) v)
+       (f arg 'covariant)
+       (void))
      (define (sc->contract v f)
-       (match v
-        [(sealing-combinator (list arg) vars members)
-         #`(sealing->/c #,(car vars) #,members #,(f arg))]))
+       (match-define (sealing-combinator (list arg) vars members) v)
+       #`(sealing->/c #,(car vars) #,members #,(f arg)))
      (define (sc->constraints v f)
-       (match v
-        [(sealing-combinator (list arg) vars members)
-         (merge-restricts* 'impersonator  (list (f arg)))]))])
+       (match-define (sealing-combinator (list arg) vars members) v)
+       (merge-restricts* 'impersonator (list (f arg))))])
 
 (define (sealing->/sc vars members body)
   (sealing-combinator (list body) vars members))

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

@@ -182,32 +182,28 @@
 
 
 (define (add-constraint cr max)
-  (match cr
-    [(contract-restrict v rec constraints)
-     (define con (constraint v max))
-     (if (trivial-constraint? con)
-         cr
-         (contract-restrict v rec (set-add constraints con)))]))
+  (match-define (contract-restrict v rec constraints) cr)
+  (define con (constraint v max))
+  (if (trivial-constraint? con)
+      cr
+      (contract-restrict v rec (set-add constraints con))))
 
-(define (add-recursive-values cr dict) 
-  (match cr
-    [(contract-restrict v rec constraints)
-     (contract-restrict v (free-id-table-union (list rec dict)) constraints)]))
+(define (add-recursive-values cr dict)
+  (match-define (contract-restrict v rec constraints) cr)
+  (contract-restrict v (free-id-table-union (list rec dict)) constraints))
 
 (define (merge-restricts* min crs)
   (apply merge-restricts min crs))
 
 (define (merge-restricts min . crs)
-  (match crs
-    [(list (contract-restrict vs rec constraints) ...)
-     (contract-restrict (merge-kind-maxes min vs)
-                        (free-id-table-union rec)
-                        (apply set-union (set) constraints))]))
+  (match-define (list (contract-restrict vs rec constraints) ...) crs)
+  (contract-restrict (merge-kind-maxes min vs)
+                     (free-id-table-union rec)
+                     (apply set-union (set) constraints)))
 
 (define (merge-kind-maxes min-kind vs)
-  (match vs
-    [(list (kind-max variables maxes) ...)
-     (kind-max (free-id-set-union variables) (apply combine-kinds min-kind maxes))]))
+  (match-define (list (kind-max variables maxes) ...) vs)
+  (kind-max (free-id-set-union variables) (apply combine-kinds min-kind maxes)))
 
 (define (close-loop names crs body)
   (define eqs (make-equation-set))
@@ -222,38 +218,36 @@
 
   (define (instantiate-cr cr lookup-id)
     (define (instantiate-kind-max km)
-      (match km
-        [(kind-max ids actual)
-         (define-values (bvals unbound-ids)
-           (for/fold ([bvals '()] [ubids (make-immutable-free-id-table)])
-                     ([(id _) (in-free-id-table ids)])
-             (if (member id names)
-                 (values (cons (contract-restrict-value (lookup-id id)) bvals) ubids)
-                 (values bvals (free-id-table-set ubids id #t)))))
-         (merge-kind-maxes 'flat (cons (kind-max unbound-ids actual) bvals))]))
+      (match-define (kind-max ids actual) km)
+      (define-values (bvals unbound-ids)
+        (for/fold ([bvals '()]
+                   [ubids (make-immutable-free-id-table)])
+                  ([(id _) (in-free-id-table ids)])
+          (if (member id names)
+              (values (cons (contract-restrict-value (lookup-id id)) bvals) ubids)
+              (values bvals (free-id-table-set ubids id #t)))))
+      (merge-kind-maxes 'flat (cons (kind-max unbound-ids actual) bvals)))
 
     (define (instantiate-constraint con)
-      (match con
-        [(constraint km bound)
-         (constraint (instantiate-kind-max km) bound)]))
-
-    (match cr
-      [(contract-restrict (kind-max ids max) rec constraints)
-       (define-values (bound-vals unbound-ids)
-         (for/fold ([bvs '()] [ubids (make-immutable-free-id-table)])
-                   ([(id _) (in-free-id-table ids)])
-           (if (member id names)
-               (values (cons (lookup-id id) bvs) ubids)
-               (values bvs (free-id-table-set ubids id #t)))))
-       (merge-restricts* 'flat (cons
-                                (contract-restrict
-                                 (kind-max unbound-ids max) 
-                                 rec
-                                 (for*/set ([c (in-immutable-set constraints)]
-                                            [ic (in-value (instantiate-constraint c))]
-                                            #:when (not (trivial-constraint? ic)))
-                                   ic))
-                                bound-vals))]))
+      (match-define (constraint km bound) con)
+      (constraint (instantiate-kind-max km) bound))
+
+    (match-define (contract-restrict (kind-max ids max) rec constraints) cr)
+    (define-values (bound-vals unbound-ids)
+      (for/fold ([bvs '()]
+                 [ubids (make-immutable-free-id-table)])
+                ([(id _) (in-free-id-table ids)])
+        (if (member id names)
+            (values (cons (lookup-id id) bvs) ubids)
+            (values bvs (free-id-table-set ubids id #t)))))
+    (merge-restricts* 'flat
+                      (cons (contract-restrict (kind-max unbound-ids max)
+                                               rec
+                                               (for*/set ([c (in-immutable-set constraints)]
+                                                          [ic (in-value (instantiate-constraint c))]
+                                                          #:when (not (trivial-constraint? ic)))
+                                                 ic))
+                            bound-vals)))
 
   (for ([name (in-list names)]
         [cr (in-list crs)])

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

@@ -2,24 +2,24 @@
 
 ;; Provides functionality to take a static contract and turn it into a regular contract.
 
-(require
-  "../utils/utils.rkt"
-  racket/match
-  racket/list
-  racket/contract
-  racket/syntax
-  syntax/private/id-table
-  (for-template racket/base racket/contract)
-  "combinators.rkt"
-  "combinators/name.rkt"
-  "combinators/case-lambda.rkt"
-  "combinators/parametric.rkt"
-  "kinds.rkt"
-  "optimize.rkt"
-  "parametric-check.rkt"
-  "structures.rkt"
-  "constraints.rkt"
-  "equations.rkt")
+(require (for-template racket/base
+                       racket/contract)
+         racket/contract
+         racket/list
+         racket/match
+         racket/syntax
+         syntax/private/id-table
+         "../utils/utils.rkt"
+         "combinators.rkt"
+         "combinators/case-lambda.rkt"
+         "combinators/name.rkt"
+         "combinators/parametric.rkt"
+         "constraints.rkt"
+         "equations.rkt"
+         "kinds.rkt"
+         "optimize.rkt"
+         "parametric-check.rkt"
+         "structures.rkt")
 
 (provide static-contract-may-contain-free-ids?)
 
@@ -145,12 +145,14 @@
     (variable-ref (hash-ref vars id)))
 
   (for ([(name v) (in-free-id-table recursives)])
-    (match v
-      [(kind-max others max)
-       (add-equation! eqs
-          (hash-ref vars name)
-          (λ () (apply combine-kinds max (for/list ([(id _) (in-free-id-table others)])
-                                           (lookup id)))))]))
+    (match-define (kind-max others max) v)
+    (add-equation! eqs
+                   (hash-ref vars name)
+                   (λ ()
+                     (apply combine-kinds
+                            max
+                            (for/list ([(id _) (in-free-id-table others)])
+                              (lookup id))))))
   (define var-values (resolve-equations eqs))
   (for/hash ([(name var) (in-hash vars)])
     (values name (hash-ref var-values var))))

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

@@ -111,7 +111,7 @@
         ;; All results must have the same range
         (unless (equal? (set-count (list->set ranges)) 1)
           (fail))
-        (define sorted-args (sort args (λ (l1 l2) (< (length l1) (length l2)))))
+        (define sorted-args (sort args < #:key length))
         (define shortest-args (first sorted-args))
         (define longest-args (last sorted-args))
         ;; The number of arguments must increase by 1 with no gaps
@@ -341,11 +341,11 @@
   (let loop ((to-look-at reachable))
     (unless (zero? (free-id-table-count to-look-at))
       (define new-table (make-free-id-table))
-      (for ([(id _) (in-free-id-table to-look-at)])
-        (for ([(id _) (in-free-id-table (free-id-table-ref main-table id))])
-          (unless (free-id-table-ref seen id #f)
-            (free-id-table-set! seen id #t)
-            (free-id-table-set! new-table id #t))))
+      (for* ([(id _) (in-free-id-table to-look-at)]
+             [(id _) (in-free-id-table (free-id-table-ref main-table id))]
+             #:unless (free-id-table-ref seen id #f))
+        (free-id-table-set! seen id #t)
+        (free-id-table-set! new-table id #t))
       (loop new-table)))
 
   ;; Determine if the recursive name is referenced in the static contract
@@ -403,9 +403,9 @@
 
 ;; 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 ([sc->kind (make-sc->kind recursive-kinds)])
-      (λ (sc) (eq? 'flat (sc->kind sc)))))
+  (define sc->kind (make-sc->kind recursive-kinds))
+  (define (flat-sc? sc)
+    (eq? 'flat (sc->kind sc)))
   (define trusted-side-reduce (make-trusted-side-reduce flat-sc?))
   (define update-side (make-update-side flat-sc?))
 

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

@@ -124,15 +124,13 @@
         #:transparent
         #:methods gen:sc
           [(define (sc-map v f)
-             (match v
-               [(recursive-sc names values body)
-                (recursive-sc names (map (λ (v) (f v 'covariant)) values) (f body 'covariant))]))
+             (match-define (recursive-sc names values body) v)
+             (recursive-sc names (map (λ (v) (f v 'covariant)) values) (f body 'covariant)))
            (define (sc-traverse v f)
-             (match v
-               [(recursive-sc names values body)
-                (for-each (λ (v) (f v 'covariant)) values)
-                (f body 'covariant)
-                (void)]))
+             (match-define (recursive-sc names values body) v)
+             (for-each (λ (v) (f v 'covariant)) values)
+             (f body 'covariant)
+             (void))
            (define (sc->constraints v f)
              (simple-contract-restrict 'impersonator))]
         #:methods gen:custom-write [(define write-proc recursive-sc-write-proc)])