From be2c246d1f66bbc7267eb5efa563b2a3f7ebce64 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Tue, 17 Dec 2013 08:50:31 -0800 Subject: [PATCH] Make many more static contract optimizer tests and add some more optimizations. original commit: 6961c0ecc812ac0653c71e0acf55a66c6300ba82 --- .../static-contracts/combinators/derived.rkt | 22 ++- .../static-contracts/combinators/none.rkt | 37 +++++ .../combinators/structural.rkt | 15 +- .../static-contracts/optimize.rkt | 74 +++++++-- .../static-contract-optimizer-tests.rkt | 143 +++++++++++++++++- 5 files changed, 274 insertions(+), 17 deletions(-) create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/none.rkt diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/derived.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/derived.rkt index 99723bb2..309eff67 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/derived.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/derived.rkt @@ -4,16 +4,28 @@ ;; These are used during optimizations as simplifications. ;; Ex: (listof/sc any/sc) => list?/sc -(require "simple.rkt" +(require "simple.rkt" "structural.rkt" (for-template racket/base racket/set racket/promise)) (provide (all-defined-out)) (define identifier?/sc (flat/sc #'identifier?)) -(define list?/sc (flat/sc #'list?)) -(define set?/sc (flat/sc #'set?)) (define box?/sc (flat/sc #'box?)) -(define vector?/sc (flat/sc #'box?)) (define syntax?/sc (flat/sc #'syntax?)) (define promise?/sc (flat/sc #'promise?)) -(define hash?/sc (flat/sc #'hash?)) +(define list?/sc (flat/sc #'list?)) +(define empty-list/sc (flat/sc #'null?)) +(define (list-length/sc n) + (if (equal? 0 n) + empty-list/sc + (and/sc list?/sc (flat/sc #`(λ (l) (= #,n (length l))))))) + +(define set?/sc (flat/sc #'set?)) +(define empty-set/sc (and/sc set?/sc (flat/sc #'set-empty?))) + +(define vector?/sc (flat/sc #'vector?)) +(define (vector-length/sc n) (and/sc vector?/sc (flat/sc #`(λ (v) (= #,n (vector-length v)))))) +(define empty-vector/sc (vector-length/sc 0)) + +(define hash?/sc (flat/sc #'hash?)) +(define empty-hash/sc (and/sc hash?/sc (flat/sc #'(λ (h) (zero? (hash-count h)))))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/none.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/none.rkt new file mode 100644 index 00000000..5e9cc1bb --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/none.rkt @@ -0,0 +1,37 @@ +#lang racket/base + +;; Static contract for none/c. +;; Allows optimizations as many combinators can be simplified if their arguments are none/sc +;; Ex: (listof/sc none/sc) => null?/sc + +(require "../structures.rkt" "../constraints.rkt" + racket/match + (except-in racket/contract recursive-contract) + (for-template racket/base racket/contract/base) + (for-syntax racket/base racket/syntax syntax/parse)) + +(provide + (contract-out + [none/sc static-contract?]) + none/sc:) + + +;;Printing +(define (none-write-proc v port mode) + (if (equal? mode 0) + (display "none/sc" port) + (display "#" port))) + +(struct none-combinator combinator () + #:methods gen:sc + [(define (sc-map v f) v) + (define (sc->contract v f) #'none/c) + (define (sc->constraints v f) (simple-contract-restrict 'flat))] + #:methods gen:custom-write [(define write-proc none-write-proc)]) + +(define-match-expander none/sc: + (syntax-parser + [(_) #'(? none-combinator?)])) + +(define none/sc (none-combinator null)) + diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt index 40382452..a38524b7 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt @@ -78,7 +78,7 @@ #'(define-match-expander matcher-name (syntax-parser [(_ ctc (... ...)) - #'(struct-name _ (list ctc (... ...)))])) + #'(struct-name (list ctc (... ...)))])) #:with map #'(lambda (v f) (struct-name @@ -103,6 +103,19 @@ (map recur (combinator-args v)))) (define (sc->constraints v recur) (merge-restricts* 'kind.category-stx (sc.->restricts v recur)))] + #:methods gen:equal+hash + [(define (equal-proc a b recur) + (for/and ([sub-a (in-list (combinator-args a))] + [sub-b (in-list (combinator-args b))]) + (recur sub-a sub-b))) + (define (hash-proc v recur) + (+ (recur 'sc.name) + (for/sum ((sub (in-list (combinator-args v)))) + (recur sub)))) + (define (hash2-proc v recur) + (+ (recur 'sc.name) + (for/sum ((sub (in-list (combinator-args v)))) + (recur sub))))] #:property prop:combinator-name (symbol->string 'sc.name)) sc.matcher sc.definition 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 c2b8488e..3afd0a85 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 @@ -16,17 +16,32 @@ (contract-out [optimize (static-contract? (or/c 'covariant 'contravariant 'invariant ) . -> . static-contract?)])) +(define (none/sc-reduce sc) + (match sc + [(listof/sc: (none/sc:)) empty-list/sc] + [(list/sc: sc1 ... (none/sc:) sc2 ...) none/sc] + [(vectorof/sc: (none/sc:)) empty-vector/sc] + [(vector/sc: sc1 ... (none/sc:) sc2 ...) none/sc] + [(set/sc: (none/sc:)) empty-set/sc] + [(box/sc: (none/sc:)) none/sc] + [(syntax/sc: (none/sc:)) none/sc] + [(promise/sc: (none/sc:)) none/sc] + [(hash/sc: (none/sc:) value/sc) empty-hash/sc] + [(hash/sc: key/sc (none/sc:)) empty-hash/sc] + [else sc])) + (define (any/sc-reduce sc) (match sc [(listof/sc: (any/sc:)) list?/sc] + [(list/sc: (and scs (any/sc:)) ...) (list-length/sc (length scs))] [(vectorof/sc: (any/sc:)) vector?/sc] + [(vector/sc: (and scs (any/sc:)) ...) (vector-length/sc (length scs))] [(set/sc: (any/sc:)) set?/sc] [(box/sc: (any/sc:)) box?/sc] [(syntax/sc: (any/sc:)) syntax?/sc] [(promise/sc: (any/sc:)) promise?/sc] [(hash/sc: (any/sc:) (any/sc:)) hash?/sc] - [(any/sc:) sc] [else sc])) @@ -38,10 +53,37 @@ (arr/sc args rest #f)] [else sc])) -(define (flat-reduce sc) +(define (covariant-none/sc-reduce sc) (match sc - [(? flat/sc?) + [(none/sc:) any/sc] + [else sc])) + +(define (or/sc-reduce sc) + (match sc + [(or/sc:) none/sc] + [(or/sc: sc) sc] + [(or/sc: sc1 ... (any/sc:) sc2 ...) any/sc] + [(or/sc: sc1 ... (none/sc:) sc2 ...) + (or/sc-reduce (apply or/sc (append sc1 sc2)))] + [else sc])) + +(define (and/sc-reduce sc) + (match sc + [(and/sc:) any/sc] + [(and/sc: sc) sc] + [(and/sc: sc1 ... (none/sc:) sc2 ...) + none/sc] + [(and/sc: sc1 ... (any/sc:) sc2 ...) + (and/sc-reduce (apply and/sc (append sc1 sc2)))] + [else sc])) + + + +(define (covariant-flat-reduce sc) + (match sc + [(? flat/sc?) any/sc] + [(none/sc:) any/sc] [sc sc])) (define (invert-variance v) @@ -67,11 +109,23 @@ [(contravariant invariant) sc] [else (error 'maybe/co "Bad variance ~a" variance)])) - ((maybe/co flat-reduce) ((maybe/co covariant-any/sc-reduce) (any/sc-reduce sc)))) - - (define ((recur current-variance) sc variance) - (define new-variance (combine-variance current-variance variance)) - (single-step (sc-map sc (recur new-variance)) new-variance)) - ((recur variance) sc 'covariant)) - + ((compose + (maybe/co covariant-flat-reduce) + (maybe/co covariant-any/sc-reduce) + (maybe/co covariant-none/sc-reduce) + and/sc-reduce + or/sc-reduce + none/sc-reduce + any/sc-reduce) + sc)) + (define (full-pass sc) + (define ((recur current-variance) sc variance) + (define new-variance (combine-variance current-variance variance)) + (single-step (sc-map sc (recur new-variance)) new-variance)) + ((recur variance) sc 'covariant)) + (let loop ((sc sc)) + (define new-sc (full-pass sc)) + (if (equal? sc new-sc) + new-sc + (loop new-sc)))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-optimizer-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-optimizer-tests.rkt index 3d6c6bfa..deb5342c 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-optimizer-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-optimizer-tests.rkt @@ -16,7 +16,7 @@ (list (make-check-info 'original argument) (make-check-expected expected)) (lambda () - (let ([opt (optimize argument variance)]) + (let ([opt (optimize argument variance)]) (with-check-info* (list (make-check-actual opt)) (lambda () (unless (equal? opt expected) @@ -25,18 +25,159 @@ (define tests (test-suite "Static Contract Optimizer Tests" + ;; Lists (check-optimize 'covariant (listof/sc any/sc) any/sc) (check-optimize 'contravariant (listof/sc any/sc) list?/sc) + (check-optimize 'covariant + (listof/sc none/sc) + any/sc) + (check-optimize 'contravariant + (listof/sc none/sc) + empty-list/sc) + + ;; Heterogeneous Lists + (check-optimize 'covariant + (list/sc any/sc) + any/sc) + ;; TODO fix ability to test equality here + #; + (check-optimize 'contravariant + (list/sc any/sc) + (list-length/sc 1)) + (check-optimize 'covariant + (list/sc none/sc) + any/sc) + (check-optimize 'contravariant + (list/sc none/sc) + none/sc) + (check-optimize 'covariant + (list/sc) + any/sc) + (check-optimize 'contravariant + (list/sc) + empty-list/sc) + + + ;; Sets (check-optimize 'covariant (set/sc any/sc) any/sc) (check-optimize 'contravariant (set/sc any/sc) set?/sc) + (check-optimize 'covariant + (set/sc none/sc) + any/sc) + (check-optimize 'contravariant + (set/sc none/sc) + empty-set/sc) + + ;; Vectors + (check-optimize 'covariant + (vectorof/sc any/sc) + any/sc) + (check-optimize 'contravariant + (vectorof/sc any/sc) + vector?/sc) + (check-optimize 'covariant + (vectorof/sc none/sc) + any/sc) + (check-optimize 'contravariant + (vectorof/sc none/sc) + empty-vector/sc) + + ;; Heterogeneous Vectors + (check-optimize 'covariant + (vector/sc any/sc) + any/sc) + ;; TODO fix ability to test equality here + #; + (check-optimize 'contravariant + (vector/sc any/sc) + (vector-length/sc 1)) + (check-optimize 'covariant + (vector/sc none/sc) + any/sc) + (check-optimize 'contravariant + (vector/sc none/sc) + none/sc) + (check-optimize 'covariant + (vector/sc set?/sc) + (vector/sc set?/sc)) + (check-optimize 'contravariant + (vector/sc set?/sc) + (vector/sc set?/sc)) + + ;; HashTables + (check-optimize 'covariant + (hash/sc any/sc any/sc) + any/sc) + (check-optimize 'contravariant + (hash/sc any/sc any/sc) + hash?/sc) + (check-optimize 'covariant + (hash/sc none/sc any/sc) + any/sc) + (check-optimize 'covariant + (hash/sc any/sc none/sc) + any/sc) + (check-optimize 'contravariant + (hash/sc none/sc any/sc) + empty-hash/sc) + (check-optimize 'contravariant + (hash/sc any/sc none/sc) + empty-hash/sc) + + ;; And + (check-optimize 'contravariant + (and/sc set?/sc) + set?/sc) + (check-optimize 'contravariant + (and/sc set?/sc any/sc) + set?/sc) + (check-optimize 'contravariant + (and/sc set?/sc none/sc) + none/sc) + (check-optimize 'contravariant + (and/sc) + any/sc) + (check-optimize 'contravariant + (and/sc any/sc any/sc) + any/sc) + + ;; Or + (check-optimize 'contravariant + (or/sc set?/sc) + set?/sc) + (check-optimize 'contravariant + (or/sc set?/sc none/sc) + set?/sc) + (check-optimize 'contravariant + (or/sc set?/sc any/sc) + any/sc) + (check-optimize 'covariant + (or/sc) + any/sc) + (check-optimize 'contravariant + (or/sc) + none/sc) + (check-optimize 'contravariant + (or/sc any/sc any/sc) + any/sc) + + ;; None + (check-optimize 'covariant none/sc any/sc) + (check-optimize 'contravariant none/sc none/sc) + + ;; TODO add these test cases + ;; Boxes + ;; Syntax + ;; Promise + (check-optimize 'covariant (function/sc (list (listof/sc any/sc)) (list)