From 70cfe1b9532569af7fdaf317e222e6957cb8cab1 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 12 Jul 2010 12:31:21 -0400 Subject: [PATCH] Added dead code elimination. original commit: 1e550139aa67631ffc965027584284b61453b634 --- .../optimizer/generic/dead-else.rkt | 8 ++++++ .../optimizer/generic/dead-then.rkt | 8 ++++++ collects/typed-scheme/optimizer/dead-code.rkt | 25 +++++++++++++++++++ collects/typed-scheme/optimizer/optimizer.rkt | 3 ++- collects/typed-scheme/typecheck/tc-if.rkt | 8 ++++++ collects/typed-scheme/types/type-table.rkt | 24 +++++++++++++++++- 6 files changed, 74 insertions(+), 2 deletions(-) create mode 100644 collects/tests/typed-scheme/optimizer/generic/dead-else.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/dead-then.rkt create mode 100644 collects/typed-scheme/optimizer/dead-code.rkt diff --git a/collects/tests/typed-scheme/optimizer/generic/dead-else.rkt b/collects/tests/typed-scheme/optimizer/generic/dead-else.rkt new file mode 100644 index 00000000..40194c44 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/dead-else.rkt @@ -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)) diff --git a/collects/tests/typed-scheme/optimizer/generic/dead-then.rkt b/collects/tests/typed-scheme/optimizer/generic/dead-then.rkt new file mode 100644 index 00000000..719452b0 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/dead-then.rkt @@ -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)) diff --git a/collects/typed-scheme/optimizer/dead-code.rkt b/collects/typed-scheme/optimizer/dead-code.rkt new file mode 100644 index 00000000..f20019de --- /dev/null +++ b/collects/typed-scheme/optimizer/dead-code.rkt @@ -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))))) diff --git a/collects/typed-scheme/optimizer/optimizer.rkt b/collects/typed-scheme/optimizer/optimizer.rkt index 7e799542..6616ea6d 100644 --- a/collects/typed-scheme/optimizer/optimizer.rkt +++ b/collects/typed-scheme/optimizer/optimizer.rkt @@ -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 ...) diff --git a/collects/typed-scheme/typecheck/tc-if.rkt b/collects/typed-scheme/typecheck/tc-if.rkt index c415ef8b..ce1bca7b 100644 --- a/collects/typed-scheme/typecheck/tc-if.rkt +++ b/collects/typed-scheme/typecheck/tc-if.rkt @@ -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 diff --git a/collects/typed-scheme/types/type-table.rkt b/collects/typed-scheme/types/type-table.rkt index b9784dfa..a4bb8890 100644 --- a/collects/typed-scheme/types/type-table.rkt +++ b/collects/typed-scheme/types/type-table.rkt @@ -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?)]) \ No newline at end of file + [make-struct-table-code (-> syntax?)] + [add-tautology (syntax? . -> . any/c)] + [add-contradiction (syntax? . -> . any/c)] + [tautology? (syntax? . -> . boolean?)] + [contradiction? (syntax? . -> . boolean?)])