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

Added dead code elimination.

Browse Source 
original commit: 1e550139aa67631ffc965027584284b61453b634
This commit is contained in:
Vincent St-Amour 2010-07-12 12:31:21 -04:00
parent 52559ccd98
commit 70cfe1b953
6 changed files with 74 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/tests/typed-scheme/optimizer/generic/dead-else.rkt Normal file
View File

@ -0,0 +1,8 @@
#lang typed/scheme #:optimize
(require racket/unsafe/ops)
(if (number? 3)
(+ 2.0 3.0)
(+ 4.0 5.0))
(if #t
(+ 2.0 3.0)
(+ 4.0 5.0))

8
collects/tests/typed-scheme/optimizer/generic/dead-then.rkt Normal file
View File

@ -0,0 +1,8 @@
#lang typed/scheme #:optimize
(require racket/unsafe/ops)
(if (number? "eh")
(+ 2.0 3.0)
(+ 4.0 5.0))
(if #f
(+ 2.0 3.0)
(+ 4.0 5.0))

25
collects/typed-scheme/optimizer/dead-code.rkt Normal file
View File

@ -0,0 +1,25 @@
#lang scheme/base
(require syntax/parse
(for-template scheme/base)
"../utils/utils.rkt" "../utils/tc-utils.rkt"
(types type-table)
(optimizer utils))
(provide dead-code-opt-expr)
(define-syntax-class dead-code-opt-expr
;; if one of the brances of an if is unreachable, we can eliminate it
;; we have to keep the test, in case it has side effects
(pattern (if tst:expr thn:expr els:expr)
#:when (tautology? #'tst)
#:with opt
(begin (log-optimization "dead else branch" #'op)
#`(begin #,((optimize) #'tst)
#,((optimize) #'thn))))
(pattern (if tst:expr thn:expr els:expr)
#:when (contradiction? #'tst)
#:with opt
(begin (log-optimization "dead then branch" #'op)
#`(begin #,((optimize) #'tst)
#,((optimize) #'els)))))

3
collects/typed-scheme/optimizer/optimizer.rkt
View File

@ -5,7 +5,7 @@
(for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops racket/private/for)
"../utils/utils.rkt"
(types abbrev type-table utils subtype)
(optimizer utils fixnum float inexact-complex vector pair list struct))
(optimizer utils fixnum float inexact-complex vector pair list struct dead-code))
(provide optimize-top)
@ -25,6 +25,7 @@
(pattern e:pair-opt-expr #:with opt #'e.opt)
(pattern e:list-opt-expr #:with opt #'e.opt)
(pattern e:struct-opt-expr #:with opt #'e.opt)
(pattern e:dead-code-opt-expr #:with opt #'e.opt)
;; boring cases, just recur down
(pattern (#%plain-lambda formals e:opt-expr ...)

8
collects/typed-scheme/typecheck/tc-if.rkt
View File

@ -8,6 +8,7 @@
(r:infer infer)
(utils tc-utils)
(typecheck tc-envops tc-metafunctions)
(types type-table)
syntax/kerncase
racket/trace unstable/debug
racket/match)
@ -55,6 +56,13 @@
;(printf "els-props: ~a~n" (env-props env-els))
;(printf "new-thn-props: ~a~n" new-thn-props)
;(printf "new-els-props: ~a~n" new-els-props)
;; record reachability
(when (not (unbox flag+))
(add-contradiction tst))
(when (not (unbox flag-))
(add-tautology tst))
;; if we have the same number of values in both cases
(cond [(= (length ts) (length us))
(let ([r (combine-results

24
collects/typed-scheme/types/type-table.rkt
View File

@ -20,6 +20,7 @@
(syntax-line e)
(syntax-column e))))))
(define struct-fn-table (make-free-id-table))
(define (add-struct-fn! id pe mut?) (dict-set! struct-fn-table id (list pe mut?)))
@ -48,6 +49,23 @@
#,(print-convert pe)
#,mut?)])))))
;; keeps track of expressions that always evaluate to true or always evaluate
;; to false, so that the optimizer can eliminate dead code
(define tautology-contradiction-table (make-hasheq))
(define-values (add-tautology add-contradiction)
(let ()
(define ((mk t?) e)
(when (optimize?)
(hash-set! tautology-contradiction-table e t?)))
(values (mk #t) (mk #f))))
(define-values (tautology? contradiction?)
(let ()
(define ((mk t?) e)
(eq? t? (hash-ref tautology-contradiction-table e 'not-there)))
(values (mk #t) (mk #f))))
(p/c [add-typeof-expr (syntax? tc-results? . -> . any/c)]
[type-of (syntax? . -> . tc-results?)]
[reset-type-table (-> any/c)]
@ -55,4 +73,8 @@
[struct-accessor? (identifier? . -> . (or/c #f StructPE?))]
[struct-mutator? (identifier? . -> . (or/c #f StructPE?))]
[struct-fn-idx (identifier? . -> . exact-integer?)]
[make-struct-table-code (-> syntax?)])
[make-struct-table-code (-> syntax?)]
[add-tautology (syntax? . -> . any/c)]
[add-contradiction (syntax? . -> . any/c)]
[tautology? (syntax? . -> . boolean?)]
[contradiction? (syntax? . -> . boolean?)])