suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Make many more static contract optimizer tests and add some more optimizations.

Browse Source 
original commit: 6961c0ecc812ac0653c71e0acf55a66c6300ba82
This commit is contained in:
Eric Dobson 2013-12-17 08:50:31 -08:00
parent 13d40d3616
commit be2c246d1f
5 changed files with 274 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/derived.rkt
View File

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

37
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/none.rkt Normal file
View File

@ -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 "#<none/sc>" 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))

15
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt
View File

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

74
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt
View File

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

143
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-optimizer-tests.rkt
View File

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