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

Optimize away recursive contracts in more cases.

Browse Source 
original commit: 74d79a50512835441709f6b61ddac246cb58ef6d
This commit is contained in:
Eric Dobson 2014-01-14 23:41:53 -08:00
parent 9522355e0b
commit f296f54acd
2 changed files with 46 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -130,6 +130,18 @@
(dict-set! new-table id #t))))
(loop new-table)))
;; Determine if the recursive name is referenced in the static contract
(define (unused? new-name sc)
(let/ec exit
(define (recur sc variance)
(match sc
[(recursive-sc-use (== new-name free-identifier=?))
(exit #f)]
[else
(sc-traverse sc recur)]))
(recur sc 'covariant)
#t))
(define (trim sc variance)
(match sc
[(recursive-sc names values body)
@ -143,9 +155,16 @@
(define new-names (map first new-name-values))
(define new-values (map (λ (v) (trim v 'covariant))
(map second new-name-values)))
(if (empty? new-names)
new-body
(recursive-sc new-names new-values new-body))]
(cond
[(empty? new-names) new-body]
[(and
(equal? (length new-names) 1)
(recursive-sc-use? new-body)
(free-identifier=? (first new-names) (recursive-sc-use-name new-body))
(unused? (first new-names) (first new-values)))
(first new-values)]
[else
(recursive-sc new-names new-values new-body)])]
[else
(sc-map sc trim)]))
(trim sc 'covariant))

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

@ -2,7 +2,7 @@
(require "test-utils.rkt"
racket/list racket/format rackunit
(static-contracts instantiate optimize combinators)
(static-contracts instantiate optimize combinators structures)
(for-syntax racket/base syntax/parse))
(provide tests)
@ -37,6 +37,10 @@
(unless (equal? opt expected)
(fail-check))))))))
;; Ids with unique identity so that equals works
(define foo-id #'foo)
(define bar-id #'bar)
(define tests
(test-suite "Static Contract Optimizer Tests"
;; Lists
@ -247,5 +251,24 @@
#:pos (class/sc (list (member-spec 'field 'x list?/sc)) #f empty empty)
#:neg (class/sc (list (member-spec 'field 'x list?/sc)) #f empty empty))
(check-optimize
(recursive-sc (list foo-id bar-id)
(list (listof/sc (recursive-sc-use foo-id))
(listof/sc (recursive-sc-use bar-id)))
(recursive-sc-use foo-id))
#:pos (recursive-sc (list foo-id)
(list (listof/sc (recursive-sc-use foo-id)))
(recursive-sc-use foo-id))
#:neg (recursive-sc (list foo-id)
(list (listof/sc (recursive-sc-use foo-id)))
(recursive-sc-use foo-id)))
(check-optimize
(recursive-sc (list foo-id bar-id)
(list (listof/sc any/sc )
(listof/sc any/sc))
(recursive-sc-use foo-id))
#:pos any/sc
#:neg list?/sc)
))