From e5695309151b123d8c7d98bafb71b7d317daa76e Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Sun, 6 Jul 2014 18:33:30 -0700 Subject: [PATCH] Add code to handle when the test expression is neither true nor false. Closes PR 14564. --- .../typed-racket/optimizer/dead-code.rkt | 47 ++++++++++--------- .../typed-racket/types/type-table.rkt | 31 ++++-------- .../optimizer/tests/both-if-branches-dead.rkt | 13 +++++ 3 files changed, 48 insertions(+), 43 deletions(-) create mode 100644 pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/tests/both-if-branches-dead.rkt diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/dead-code.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/dead-code.rkt index 210cbab9c7..7ed55ae631 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/dead-code.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/dead-code.rkt @@ -1,6 +1,7 @@ #lang racket/base (require syntax/parse racket/promise syntax/stx unstable/sequence + racket/syntax (for-template racket/base) "../utils/utils.rkt" (types type-table) @@ -12,31 +13,33 @@ ;; The type based 'dead code elimination' done by this file just makes the dead code obvious. ;; The actual elimination step is left to the compiler. - -;; if the conditional has a known truth value, we can reveal this -;; we have to keep the test, in case it has side effects -(define-syntax-class tautology - #:attributes (opt) - (pattern e:opt-expr - #:when (tautology? #'e) - #:attr opt (delay #'(begin e.opt #t)))) - -(define-syntax-class contradiction - #:attributes (opt) - (pattern e:opt-expr - #:when (contradiction? #'e) - #:attr opt (delay #'(begin e.opt #f)))) - - (define-syntax-class dead-code-opt-expr #:commit #:literal-sets (kernel-literals) - (pattern ((~and kw if) tst:tautology thn:opt-expr els:expr) - #:do [(log-optimization "dead else branch" "Unreachable else branch elimination." #'els)] - #:with opt (syntax/loc/origin this-syntax #'kw (if tst.opt thn.opt els))) - (pattern ((~and kw if) tst:contradiction thn:expr els:opt-expr) - #:do [(log-optimization "dead then branch" "Unreachable then branch elimination." #'thn)] - #:with opt (syntax/loc/origin this-syntax #'kw (if tst.opt thn els.opt))) + (pattern ((~and kw if) tst:opt-expr thn:opt-expr els:opt-expr) + #:do [(define takes-true (test-position-takes-true-branch #'tst)) + (define takes-false (test-position-takes-false-branch #'tst)) + (unless takes-true + (log-optimization "dead then branch" "Unreachable then branch elimination." #'thn)) + (unless takes-false + (log-optimization "dead else branch" "Unreachable else branch elimination." #'els))] + #:with thn-opt (if takes-true #'thn.opt #'thn) + #:with els-opt (if takes-false #'els.opt #'els) + ;; if the conditional has a known truth value, we can reveal this + ;; we have to keep the test, in case it has side effects + #:with opt + (cond + [(and (not takes-true) (not takes-false)) + (quasisyntax/loc/origin this-syntax #'kw + (if #t tst.opt (begin thn-opt els-opt)))] + [else + (define/with-syntax tst-opt + (cond + [(and takes-true takes-false) #'tst.opt] + [takes-true #'(begin tst.opt #t)] + [takes-false #'(begin tst.opt #f)])) + (quasisyntax/loc/origin this-syntax #'kw + (if tst-opt thn-opt els-opt))])) (pattern ((~and kw lambda) formals . bodies) #:when (dead-lambda-branch? #'formals) #:with opt this-syntax) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/type-table.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/type-table.rkt index 455e9b1fc4..77e37320ad 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/type-table.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/type-table.rkt @@ -18,8 +18,8 @@ [reset-type-table (-> any/c)] [test-position-add-true (syntax? . -> . any)] [test-position-add-false (syntax? . -> . any)] - [tautology? (syntax? . -> . boolean?)] - [contradiction? (syntax? . -> . boolean?)] + [test-position-takes-true-branch (syntax? . -> . boolean?)] + [test-position-takes-false-branch (syntax? . -> . boolean?)] [add-dead-lambda-branch (syntax? . -> . any)] [dead-lambda-branch? (syntax? . -> . boolean?)] [;; Register that the given expression should be ignored @@ -63,29 +63,18 @@ (syntax-column e)))))) ;; For expressions in test position keep track of if it evaluates to true/false -;; values: can be 'true, 'false, 'both. -(define test-position-table (make-hasheq)) +(define test-position-table/true (make-hasheq)) +(define test-position-table/false (make-hasheq)) (define (test-position-add-true expr) - (hash-update! test-position-table expr - (lambda (v) - (case v - [(true) 'true] - [(false both) 'both])) - 'true)) + (hash-set! test-position-table/true expr #t)) (define (test-position-add-false expr) - (hash-update! test-position-table expr - (lambda (v) - (case v - [(false) 'false] - [(true both) 'both])) - 'false)) + (hash-set! test-position-table/false expr #t)) -(define-values (tautology? contradiction?) - (let () - (define ((mk t?) e) - (eq? t? (hash-ref test-position-table e 'not-there))) - (values (mk 'true) (mk 'false)))) +(define (test-position-takes-true-branch expr) + (hash-ref test-position-table/true expr #f)) +(define (test-position-takes-false-branch expr) + (hash-ref test-position-table/false expr #f)) ;; keeps track of lambda branches that never get evaluated, so that the ;; optimizer can eliminate dead code. The key is the formals syntax object. diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/tests/both-if-branches-dead.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/tests/both-if-branches-dead.rkt new file mode 100644 index 0000000000..b8ce769baf --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/tests/both-if-branches-dead.rkt @@ -0,0 +1,13 @@ +#;#; +#<