From 105b82fb7002e4fb8928d765e88c95cf8f0fe826 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 6 Oct 2010 16:20:57 -0400 Subject: [PATCH] Fixed tautology/contradiction recording to work with case-lambda. original commit: 5395dbca122c534db3d70139c871e0bc4b91515f --- collects/typed-scheme/typecheck/tc-if.rkt | 20 ++++++++++++++++---- collects/typed-scheme/types/type-table.rkt | 13 ++++++++----- 2 files changed, 24 insertions(+), 9 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-if.rkt b/collects/typed-scheme/typecheck/tc-if.rkt index 0c61c883..f897a9b0 100644 --- a/collects/typed-scheme/typecheck/tc-if.rkt +++ b/collects/typed-scheme/typecheck/tc-if.rkt @@ -58,10 +58,22 @@ ;(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)) + ;; since we may typecheck a given piece of code multiple times in different + ;; contexts, we need to take previous results into account + (cond [(and (not (unbox flag+)) ; maybe contradiction + ;; to be an actual contradiction, we must have either previously + ;; recorded this test as a contradiction, or have never seen it + ;; before + (not (tautology? tst)) + (not (neither? tst))) + (add-contradiction tst)] + [(and (not (unbox flag-)) ; maybe tautology + ;; mirror case + (not (contradiction? tst)) + (not (neither? tst))) + (add-tautology tst)] + [else + (add-neither tst)]) ;; if we have the same number of values in both cases (cond [(= (length ts) (length us)) diff --git a/collects/typed-scheme/types/type-table.rkt b/collects/typed-scheme/types/type-table.rkt index 2e1c7896..43b1221a 100644 --- a/collects/typed-scheme/types/type-table.rkt +++ b/collects/typed-scheme/types/type-table.rkt @@ -55,19 +55,20 @@ ;; keeps track of expressions that always evaluate to true or always evaluate ;; to false, so that the optimizer can eliminate dead code +;; 3 possible values: 'tautology 'contradiction 'neither (define tautology-contradiction-table (make-hasheq)) -(define-values (add-tautology add-contradiction) +(define-values (add-tautology add-contradiction add-neither) (let () (define ((mk t?) e) (when (optimize?) (hash-set! tautology-contradiction-table e t?))) - (values (mk #t) (mk #f)))) -(define-values (tautology? contradiction?) + (values (mk 'tautology) (mk 'contradiction) (mk 'neither)))) +(define-values (tautology? contradiction? neither?) (let () (define ((mk t?) e) (eq? t? (hash-ref tautology-contradiction-table e 'not-there))) - (values (mk #t) (mk #f)))) + (values (mk 'tautology) (mk 'contradiction) (mk 'neither)))) (p/c [add-typeof-expr (syntax? tc-results? . -> . any/c)] [type-of (syntax? . -> . tc-results?)] @@ -79,5 +80,7 @@ [make-struct-table-code (-> syntax?)] [add-tautology (syntax? . -> . any/c)] [add-contradiction (syntax? . -> . any/c)] + [add-neither (syntax? . -> . any/c)] [tautology? (syntax? . -> . boolean?)] - [contradiction? (syntax? . -> . boolean?)]) + [contradiction? (syntax? . -> . boolean?)] + [neither? (syntax? . -> . boolean?)])