[racket-dev] Typed Racket's optimizer is now on by default (Re: [plt] Push #21190: master branch updated)
Typed Racket's type-driven optimizer is now turned on by default.
The #:optimize switch that was previously used to turn the optimizer
on has been kept around for backward compatibility, but is now a
no-op. A #:no-optimize switch has been added, in case you want to turn
the optimizer off (e.g. for debugging). The documentation has been
updated to explain the new behavior.
While this change has been tested extensively, I recommend that you
test any Typed Racket code you have with the new version, to make sure
nothing slipped through the cracks. Please report any bugs you find.
Vincent
At Wed, 6 Oct 2010 17:33:32 -0400,
stamourv at racket-lang.org wrote:
>
> stamourv has updated `master' from 7871487b12 to 3ec9503da9.
> http://git.racket-lang.org/plt/7871487b12..3ec9503da9
>
> =====[ 7 Commits ]======================================================
>
> Directory summary:
> 6.4% collects/tests/racket/benchmarks/common/
> 16.3% collects/tests/racket/benchmarks/shootout/
> 11.8% collects/typed-scheme/scribblings/
> 48.4% collects/typed-scheme/typecheck/
> 7.6% collects/typed-scheme/types/
> 7.2% collects/typed-scheme/
>
> ~~~~~~~~~~
>
> 2172328 Vincent St-Amour <stamourv at racket-lang.org> 2010-10-04 11:41
> :
> | Register types for send exprs in the type table.
> :
> M collects/typed-scheme/typecheck/tc-expr-unit.rkt | 64 ++++++++++---------
>
> ~~~~~~~~~~
>
> f281abe Vincent St-Amour <stamourv at racket-lang.org> 2010-10-06 13:05
> :
> | Added quote-syntax to kernel-literals.
> :
> M collects/syntax/parse/private/litconv.rkt | 1 +
>
> ~~~~~~~~~~
>
> 5395dbc Vincent St-Amour <stamourv at racket-lang.org> 2010-10-06 16:20
> :
> | Fixed tautology/contradiction recording to work with case-lambda.
> :
> M collects/typed-scheme/typecheck/tc-if.rkt | 20 ++++++++++++++++----
> M collects/typed-scheme/types/type-table.rkt | 13 ++++++++-----
>
> ~~~~~~~~~~
>
> 8baa168 Vincent St-Amour <stamourv at racket-lang.org> 2010-10-05 15:56
> :
> | Turned the optimizer on by default.
> :
> M collects/typed-scheme/core.rkt | 7 +++++--
> M collects/typed-scheme/utils/utils.rkt | 2 +-
>
> ~~~~~~~~~~
>
> abcbce1 Vincent St-Amour <stamourv at racket-lang.org> 2010-10-06 11:11
> :
> | Changed the optimizer's test harness for optimization on by default.
> :
> M collects/tests/typed-scheme/optimizer/run.rkt | 2 +-
>
> ~~~~~~~~~~
>
> d39cb53 Vincent St-Amour <stamourv at racket-lang.org> 2010-10-06 16:40
> :
> | Updated the documentation of TR's optimizer.
> :
> M collects/typed-scheme/scribblings/optimization.scrbl | 11 ++++++-----
> M collects/typed-scheme/scribblings/ts-reference.scrbl | 9 +++++----
>
> ~~~~~~~~~~
>
> 3ec9503 Vincent St-Amour <stamourv at racket-lang.org> 2010-10-06 16:46
> :
> | Changed the typed benchmark harness to reflect optimization on by default.
> :
> M collects/tests/racket/benchmarks/common/auto.rkt | 12 +++---
> M collects/tests/racket/benchmarks/common/typed/wrapper.rkt | 2 +-
> M collects/tests/racket/benchmarks/shootout/auto.rkt | 16 ++++----
> M collects/tests/racket/benchmarks/shootout/run.rkt | 6 +-
> M collects/tests/racket/benchmarks/shootout/typed/wrapper.rkt | 2 +-
>
> =====[ Overall Diff ]===================================================
>
> collects/syntax/parse/private/litconv.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/syntax/parse/private/litconv.rkt
> +++ NEW/collects/syntax/parse/private/litconv.rkt
> @@ -126,6 +126,7 @@ Use cases, explained:
> case-lambda
> if
> quote
> + quote-syntax
> letrec-syntaxes+values
> with-continuation-mark
> #%expression
>
> collects/tests/racket/benchmarks/common/auto.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/tests/racket/benchmarks/common/auto.rkt
> +++ NEW/collects/tests/racket/benchmarks/common/auto.rkt
> @@ -50,7 +50,7 @@ exec racket -qu "$0" ${1+"$@"}
> (when (directory-exists? "compiled")
> (delete-directory/files "compiled")))
>
> - (define (mk-typed-scheme bm)
> + (define (mk-typed-racket-non-optimizing bm)
> (unless (directory-exists? "typed/compiled")
> (make-directory "typed/compiled"))
> (parameterize ([current-namespace (make-base-namespace)]
> @@ -58,7 +58,7 @@ exec racket -qu "$0" ${1+"$@"}
> (let ([name (format "~a-non-optimizing.rkt" bm)])
> (compile-file (format "typed/~a" name)
> (build-path "typed/compiled" (path-add-suffix name #".zo"))))))
> - (define (mk-typed-scheme-optimizing bm)
> + (define (mk-typed-racket bm)
> (unless (directory-exists? "typed/compiled")
> (make-directory "typed/compiled"))
> (parameterize ([current-namespace (make-base-namespace)]
> @@ -417,18 +417,18 @@ exec racket -qu "$0" ${1+"$@"}
> clean-up-zo
> (append '(nucleic2)
> mutable-pair-progs))
> - (make-impl 'typed-scheme
> + (make-impl 'typed-racket-non-optimizing
> void
> - mk-typed-scheme
> + mk-typed-racket-non-optimizing
> (lambda (bm)
> (system (format "racket -u typed/~a-non-optimizing.rkt" bm)))
> extract-racket-times
> clean-up-typed
> (append mutable-pair-progs
> '(dynamic2 earley nboyer nucleic2 sboyer scheme2)))
> - (make-impl 'typed-scheme-optimizing
> + (make-impl 'typed-racket
> void
> - mk-typed-scheme-optimizing
> + mk-typed-racket
> (lambda (bm)
> (system (format "racket -u typed/~a-optimizing.rkt" bm)))
> extract-racket-times
>
> collects/tests/racket/benchmarks/common/typed/wrapper.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/tests/racket/benchmarks/common/typed/wrapper.rkt
> +++ NEW/collects/tests/racket/benchmarks/common/typed/wrapper.rkt
> @@ -13,7 +13,7 @@
> (caar (regexp-match-positions
> (if opt? opt-re non-opt-re)
> name)))]
> - [option (if opt? (list #'#:optimize) '())]
> + [option (if opt? '() (list #'#:no-optimize))]
> [fname (format "~a.rktl" base-name)])
> #`(ts:#%module-begin
> #, at option
>
> collects/tests/racket/benchmarks/shootout/auto.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/tests/racket/benchmarks/shootout/auto.rkt
> +++ NEW/collects/tests/racket/benchmarks/shootout/auto.rkt
> @@ -45,7 +45,7 @@ exec racket -qu "$0" ${1+"$@"}
> (when (directory-exists? "compiled")
> (delete-directory/files "compiled")))
>
> - (define (mk-typed-scheme bm)
> + (define (mk-typed-racket-non-optimizing bm)
> (unless (directory-exists? "typed/compiled")
> (make-directory "typed/compiled"))
> (parameterize ([current-namespace (make-base-namespace)]
> @@ -53,7 +53,7 @@ exec racket -qu "$0" ${1+"$@"}
> (let ([name (format "~a-non-optimizing.rkt" bm)])
> (compile-file (format "typed/~a" name)
> (build-path "typed/compiled" (path-add-suffix name #".zo"))))))
> - (define (mk-typed-scheme-optimizing bm)
> + (define (mk-typed-racket bm)
> (unless (directory-exists? "typed/compiled")
> (make-directory "typed/compiled"))
> (parameterize ([current-namespace (make-base-namespace)]
> @@ -84,19 +84,19 @@ exec racket -qu "$0" ${1+"$@"}
> extract-racket-times
> clean-up-zo
> '())
> - (make-impl 'typed-scheme
> + (make-impl 'typed-racket-non-optimizing
> void
> - mk-typed-scheme
> + mk-typed-racket-non-optimizing
> (lambda (bm)
> - (system (format "racket run.rkt ~a typed-scheme" bm)))
> + (system (format "racket run.rkt ~a typed-racket-non-optimizing" bm)))
> extract-racket-times
> clean-up-typed
> '())
> - (make-impl 'typed-scheme-optimizing
> + (make-impl 'typed-racket
> void
> - mk-typed-scheme-optimizing
> + mk-typed-racket
> (lambda (bm)
> - (system (format "racket run.rkt ~a typed-scheme-optimizing" bm)))
> + (system (format "racket run.rkt ~a typed-racket" bm)))
> extract-racket-times
> clean-up-typed
> '())
>
> collects/tests/racket/benchmarks/shootout/run.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/tests/racket/benchmarks/shootout/run.rkt
> +++ NEW/collects/tests/racket/benchmarks/shootout/run.rkt
> @@ -138,9 +138,9 @@
> (vector-ref (current-command-line-arguments) 1))]
> [bench (vector-ref (current-command-line-arguments) 0)]
> [prog (cond
> - ((string=? version "racket") (format "~a.rkt" bench))
> - ((string=? version "typed-scheme") (format "typed/~a-non-optimizing.rkt" bench))
> - ((string=? version "typed-scheme-optimizing") (format "typed/~a-optimizing.rkt" bench))
> + ((string=? version "racket") (format "~a.rkt" bench))
> + ((string=? version "typed-racket-non-optimizing") (format "typed/~a-non-optimizing.rkt" bench))
> + ((string=? version "typed-racket") (format "typed/~a-optimizing.rkt" bench))
> (else (error 'run "unknown version ~a" version)))])
> (let ([m (assoc bench input-map)])
> (unless m
>
> collects/tests/racket/benchmarks/shootout/typed/wrapper.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/tests/racket/benchmarks/shootout/typed/wrapper.rkt
> +++ NEW/collects/tests/racket/benchmarks/shootout/typed/wrapper.rkt
> @@ -13,7 +13,7 @@
> (caar (regexp-match-positions
> (if opt? opt-re non-opt-re)
> name)))]
> - [option (if opt? (list #'#:optimize) '())]
> + [option (if opt? '() (list #'#:no-optimize))]
> [fname (format "~a.rktl" base-name)])
> #`(ts:#%module-begin #, at option
> (define OPTIMIZED? #,opt?)
>
> collects/tests/typed-scheme/optimizer/run.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/tests/typed-scheme/optimizer/run.rkt
> +++ NEW/collects/tests/typed-scheme/optimizer/run.rkt
> @@ -29,7 +29,7 @@
> [m (or (regexp-match-positions prog-rx prog)
> (error 'evaluator "bad program contents in ~e" file))]
> [prog (string-append (substring prog (caadr m) (cdadr m))
> - (if optimize? "\n#:optimize\n" "\n")
> + (if (not optimize?) "\n#:no-optimize\n" "\n")
> (substring prog (cdar m)))]
> [evaluator (make-module-evaluator prog)]
> [out (get-output evaluator)])
>
> collects/typed-scheme/core.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/typed-scheme/core.rkt
> +++ NEW/collects/typed-scheme/core.rkt
> @@ -20,9 +20,12 @@
>
> (define (mb-core stx)
> (syntax-parse stx
> - [(mb (~optional (~and #:optimize (~bind [opt? #'#t]))) forms ...)
> + [(mb (~optional (~or (~and #:optimize (~bind [opt? #'#t])) ; kept for backward compatibility
> + (~and #:no-optimize (~bind [opt? #'#f]))))
> + forms ...)
> (let ([pmb-form (syntax/loc stx (#%plain-module-begin forms ...))])
> - (parameterize ([optimize? (or (optimize?) (attribute opt?))])
> + (parameterize ([optimize? (or (and (not (attribute opt?)) (optimize?))
> + (and (attribute opt?) (syntax-e (attribute opt?))))])
> (tc-setup
> stx pmb-form 'module-begin new-mod tc-module after-code
> (with-syntax*
>
> collects/typed-scheme/scribblings/optimization.scrbl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/typed-scheme/scribblings/optimization.scrbl
> +++ NEW/collects/typed-scheme/scribblings/optimization.scrbl
> @@ -12,13 +12,14 @@ Typed Racket provides a type-driven optimizer that rewrites well-typed
> programs to potentially make them faster. It should in no way make
> your programs slower or unsafe.
>
> - at section{Using the optimizer}
> + at section{Turning the optimizer off}
>
> -Typed Racket's optimizer is not currently turned on by default. If you
> -want to activate it, you must add the @racket[#:optimize] keyword when
> -specifying the language of your program:
> +Typed Racket's optimizer is turned on by default. If you want to
> +deactivate it (for debugging, for instance), you must add the
> + at racket[#:no-optimize] keyword when specifying the language of your
> +program:
>
> - at racketmod[typed/racket #:optimize]
> + at racketmod[typed/racket #:no-optimize]
>
> @section{Getting the most out of the optimizer}
> Typed Racket's optimizer can improve the performance of various common
>
> collects/typed-scheme/scribblings/ts-reference.scrbl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/typed-scheme/scribblings/ts-reference.scrbl
> +++ NEW/collects/typed-scheme/scribblings/ts-reference.scrbl
> @@ -624,11 +624,12 @@ Typed Racket provides a type-driven optimizer that rewrites well-typed
> programs to potentially make them faster. It should in no way make
> your programs slower or unsafe.
>
> -Typed Racket's optimizer is not currently turned on by default. If you
> -want to activate it, you must add the @racket[#:optimize] keyword when
> -specifying the language of your program:
> +Typed Racket's optimizer is turned on by default. If you want to
> +deactivate it (for debugging, for instance), you must add the
> + at racket[#:no-optimize] keyword when specifying the language of your
> +program:
>
> - at racketmod[typed/racket #:optimize]
> + at racketmod[typed/racket #:no-optimize]
>
> @section{Legacy Forms}
>
>
> collects/typed-scheme/typecheck/tc-expr-unit.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/typed-scheme/typecheck/tc-expr-unit.rkt
> +++ NEW/collects/typed-scheme/typecheck/tc-expr-unit.rkt
> @@ -2,7 +2,6 @@
>
>
> (require (rename-in "../utils/utils.rkt" [private private-in])
> - syntax/kerncase mzlib/trace
> racket/match (prefix-in - scheme/contract)
> "signatures.rkt" "tc-envops.rkt" "tc-metafunctions.rkt" "tc-subst.rkt"
> "check-below.rkt" "tc-funapp.rkt"
> @@ -149,8 +148,9 @@
>
> ;; typecheck an identifier
> ;; the identifier has variable effect
> -;; tc-id : identifier -> tc-result
> -(define (tc-id id)
> +;; tc-id : identifier -> tc-results
> +(d/c (tc-id id)
> + (--> identifier? tc-results?)
> (let* ([ty (lookup-type/lexical id)])
> (ret ty
> (make-FilterSet (-not-filter (-val #f) id)
> @@ -208,7 +208,8 @@
> t)]))))
>
> ;; tc-expr/check : syntax tc-results -> tc-results
> -(define (tc-expr/check/internal form expected)
> +(d/c (tc-expr/check/internal form expected)
> + (--> syntax? tc-results? tc-results?)
> (parameterize ([current-orig-stx form])
> ;(printf "form: ~a\n" (syntax-object->datum form))
> ;; the argument must be syntax
> @@ -219,13 +220,14 @@
> (lambda args
> (define te (apply ret args))
> (check-below te expected))])
> - (kernel-syntax-case* form #f
> - (letrec-syntaxes+values find-method/who) ;; letrec-syntaxes+values is not in kernel-syntax-case literals
> + (syntax-parse form
> + #:literal-sets (kernel-literals)
> + #:literals (find-method/who)
> [stx
> - (syntax-property form 'typechecker:with-handlers)
> + #:when (syntax-property form 'typechecker:with-handlers)
> (check-subforms/with-handlers/check form expected)]
> [stx
> - (syntax-property form 'typechecker:ignore-some)
> + #:when (syntax-property form 'typechecker:ignore-some)
> (let ([ty (check-subforms/ignore form)])
> (unless ty
> (int-err "internal error: ignore-some"))
> @@ -251,7 +253,7 @@
> [(#%variable-reference . _)
> (tc-error/expr #:return (ret expected) "#%variable-reference is not supported by Typed Scheme")]
> ;; identifiers
> - [x (identifier? #'x)
> + [x:identifier
> (check-below (tc-id #'x) expected)]
> ;; w-c-m
> [(with-continuation-mark e1 e2 e3)
> @@ -270,31 +272,31 @@
> [(begin e . es) (tc-exprs/check (syntax->list #'(e . es)) expected)]
> [(begin0 e . es)
> (begin (tc-exprs/check (syntax->list #'es) Univ)
> - (tc-expr/check #'e expected))]
> + (tc-expr/check #'e expected))]
> ;; if
> [(if tst thn els) (tc/if-twoarm #'tst #'thn #'els expected)]
> ;; lambda
> [(#%plain-lambda formals . body)
> - (tc/lambda/check form #'(formals) #'(body) expected)]
> + (tc/lambda/check form #'(formals) #'(body) expected)]
> [(case-lambda [formals . body] ...)
> - (tc/lambda/check form #'(formals ...) #'(body ...) expected)]
> + (tc/lambda/check form #'(formals ...) #'(body ...) expected)]
> ;; send
> [(let-values (((_) meth))
> - (let-values (((_ _) (#%plain-app find-method/who _ rcvr _)))
> + (let-values (((_ _) (~and find-app (#%plain-app find-method/who _ rcvr _))))
> (#%plain-app _ _ args ...)))
> - (tc/send #'rcvr #'meth #'(args ...) expected)]
> + (tc/send #'find-app #'rcvr #'meth #'(args ...) expected)]
> ;; let
> [(let-values ([(name ...) expr] ...) . body)
> (tc/let-values #'((name ...) ...) #'(expr ...) #'body form expected)]
> [(letrec-values ([(name) expr]) name*)
> - (and (identifier? #'name*) (free-identifier=? #'name #'name*))
> + #:when (and (identifier? #'name*) (free-identifier=? #'name #'name*))
> (match expected
> [(tc-result1: t)
> (with-lexical-env/extend (list #'name) (list t) (tc-expr/check #'expr expected))]
> - [(tc-results: ts)
> + [(tc-results: ts)
> (tc-error/expr #:return (ret (Un)) "Expected ~a values, but got only 1" (length ts))])]
> [(letrec-values ([(name ...) expr] ...) . body)
> - (tc/letrec-values #'((name ...) ...) #'(expr ...) #'body form expected)]
> + (tc/letrec-values #'((name ...) ...) #'(expr ...) #'body form expected)]
> ;; other
> [_ (tc-error/expr #:return (ret expected) "cannot typecheck unknown form : ~a\n" (syntax->datum form))]
> ))))
> @@ -307,17 +309,18 @@
> ;; do the actual typechecking of form
> ;; internal-tc-expr : syntax -> Type
> (define (internal-tc-expr form)
> - (kernel-syntax-case* form #f
> - (letrec-syntaxes+values #%datum #%app lambda find-method/who) ;; letrec-syntaxes+values is not in kernel-syntax-case literals
> + (syntax-parse form
> + #:literal-sets (kernel-literals)
> + #:literals (#%app lambda find-method/who)
> ;;
> [stx
> - (syntax-property form 'typechecker:with-handlers)
> + #:when (syntax-property form 'typechecker:with-handlers)
> (let ([ty (check-subforms/with-handlers form)])
> (unless ty
> (int-err "internal error: with-handlers"))
> ty)]
> [stx
> - (syntax-property form 'typechecker:ignore-some)
> + #:when (syntax-property form 'typechecker:ignore-some)
> (let ([ty (check-subforms/ignore form)])
> (unless ty
> (int-err "internal error: ignore-some"))
> @@ -342,9 +345,9 @@
> (tc/lambda form #'(formals ...) #'(body ...))]
> ;; send
> [(let-values (((_) meth))
> - (let-values (((_ _) (#%plain-app find-method/who _ rcvr _)))
> + (let-values (((_ _) (~and find-app (#%plain-app find-method/who _ rcvr _))))
> (#%plain-app _ _ args ...)))
> - (tc/send #'rcvr #'meth #'(args ...))]
> + (tc/send #'find-app #'rcvr #'meth #'(args ...))]
> ;; let
> [(let-values ([(name ...) expr] ...) . body)
> (tc/let-values #'((name ...) ...) #'(expr ...) #'body form)]
> @@ -365,7 +368,7 @@
> [(#%variable-reference . _)
> (tc-error/expr #:return (ret (Un)) "#%variable-reference is not supported by Typed Scheme")]
> ;; identifiers
> - [x (identifier? #'x) (tc-id #'x)]
> + [x:identifier (tc-id #'x)]
> ;; application
> [(#%plain-app . _) (tc/app form)]
> ;; if
> @@ -402,17 +405,20 @@
> (add-typeof-expr form r)
> r)]))))
>
> -(define (tc/send rcvr method args [expected #f])
> +(d/c (tc/send form rcvr method args [expected #f])
> + (-->* (syntax? syntax? syntax? syntax?) ((-or/c tc-results? #f)) tc-results?)
> (match (tc-expr rcvr)
> [(tc-result1: (Instance: (and c (Class: _ _ methods))))
> (match (tc-expr method)
> [(tc-result1: (Value: (? symbol? s)))
> (let* ([ftype (cond [(assq s methods) => cadr]
> [else (tc-error/expr "send: method ~a not understood by class ~a" s c)])]
> - [ret-ty (tc/funapp rcvr args (ret ftype) (map tc-expr (syntax->list args)) expected)])
> - (if expected
> - (begin (check-below ret-ty expected) expected)
> - ret-ty))]
> + [ret-ty (tc/funapp rcvr args (ret ftype) (map tc-expr (syntax->list args)) expected)]
> + [retval (if expected
> + (begin (check-below ret-ty expected) expected)
> + ret-ty)])
> + (add-typeof-expr form retval)
> + retval)]
> [(tc-result1: t) (int-err "non-symbol methods not supported by Typed Scheme: ~a" t)])]
> [(tc-result1: t) (tc-error/expr #:return (or expected (ret (Un))) "send: expected a class instance, got ~a" t)]))
>
>
> collects/typed-scheme/typecheck/tc-if.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/typed-scheme/typecheck/tc-if.rkt
> +++ NEW/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))
>
> collects/typed-scheme/types/type-table.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/typed-scheme/types/type-table.rkt
> +++ NEW/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?)])
>
> collects/typed-scheme/utils/utils.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/typed-scheme/utils/utils.rkt
> +++ NEW/collects/typed-scheme/utils/utils.rkt
> @@ -25,7 +25,7 @@ at least theoretically.
> ;; provide macros
> rep utils typecheck infer env private types)
>
> -(define optimize? (make-parameter #f))
> +(define optimize? (make-parameter #t))
> (define-for-syntax enable-contracts? #f)
> (define show-input? (make-parameter #f))
>
![[logo]](/logo.png){kind=logo}