From 3842628342de111eb3533c21b31a1613a70aa5af Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 2 Feb 2010 20:42:22 -0500 Subject: [PATCH 1/3] new branch original commit: 536b94c3052559ae51a63807d8190b01d97f7326 --- collects/typed-scheme/typecheck/tc-expr-unit.ss | 16 +++++++++++----- collects/typed-scheme/typed-scheme.ss | 5 +++-- collects/typed-scheme/types/abbrev.ss | 2 +- collects/typed-scheme/utils/utils.ss | 2 +- 4 files changed, 16 insertions(+), 9 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 6121a49f..dcba9d75 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -5,7 +5,7 @@ (require syntax/kerncase mzlib/trace scheme/match (prefix-in - scheme/contract) "signatures.ss" "tc-envops.ss" "tc-metafunctions.ss" - (types utils convenience union subtype remove-intersect) + (types utils convenience union subtype remove-intersect type-table) (private-in parse-type type-annotation) (rep type-rep) (only-in (infer infer) restrict) @@ -231,6 +231,7 @@ (lambda (ann) (let* ([r (tc-expr/check/internal form ann)] [r* (check-below r expected)]) + (add-typeof-expr form expected) ;; around again in case there is an instantiation ;; remove the ascription so we don't loop infinitely (loop (remove-ascription form) r* #t)))] @@ -242,13 +243,16 @@ ;; do the instantiation on the old type (let* ([ts* (do-inst form ts)] [ts** (ret ts* fs os)]) + (add-typeof-expr form ts**) ;; make sure the new type is ok (check-below ts** expected))] ;; no annotations possible on dotted results - [ty ty])] + [ty (add-typeof-expr form ty) ty])] ;; nothing to see here [checked? expected] - [else (tc-expr/check/internal form expected)])))) + [else (let ([t (tc-expr/check/internal form expected)]) + (add-typeof-expr form t) + t)])))) (define (tc-or e1 e2 or-part [expected #f]) (match (single-value e1) @@ -469,8 +473,10 @@ [else (internal-tc-expr form)])]) (match ty [(tc-results: ts fs os) - (let ([ts* (do-inst form ts)]) - (ret ts* fs os))])))) + (let* ([ts* (do-inst form ts)] + [r (ret ts* fs os)]) + (add-typeof-expr form r) + r)])))) (define (tc/send rcvr method args [expected #f]) (match (tc-expr rcvr) diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index 0e1b5832..0f83019c 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -6,7 +6,7 @@ (for-syntax (except-in syntax/parse id) scheme/base - (private type-contract) + (private type-contract optimize) (types utils convenience) (typecheck typechecker provide-handling) (env type-environments type-name-env type-alias-env) @@ -79,7 +79,8 @@ (type-check #'(body2 ...)))] [check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))] [(transformed-body ...) (remove-provides #'(body2 ...))])] - [with-syntax ([(transformed-body ...) (change-contract-fixups #'(transformed-body ...))])]) + [with-syntax ([(transformed-body ...) (change-contract-fixups #'(transformed-body ...))])] + [with-syntax ([(transformed-body ...) (map optimize (syntax->list #'(transformed-body ...)))])]) (do-time "Typechecked") #;(printf "checked ~a~n" module-name) #;(printf "created ~a types~n" (count!)) diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss index ca5ca183..554488dd 100644 --- a/collects/typed-scheme/types/abbrev.ss +++ b/collects/typed-scheme/types/abbrev.ss @@ -2,7 +2,7 @@ (require "../utils/utils.ss") -(require (rep type-rep object-rep filter-rep) +(require (rep type-rep object-rep filter-rep rep-utils) "printer.ss" "utils.ss" (utils tc-utils) scheme/list diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index 8e3d6f73..766ba3c2 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -160,7 +160,7 @@ at least theoretically. ;; turn contracts on and off - off by default for performance. -(define-for-syntax enable-contracts? #f) +(define-for-syntax enable-contracts? #t) (provide (for-syntax enable-contracts?) p/c w/c cnt d-s/c d/c) ;; these are versions of the contract forms conditionalized by `enable-contracts?' From 3e18a985d7810021d6d53e78ad8fcb3b053899a8 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 2 Feb 2010 20:42:53 -0500 Subject: [PATCH 2/3] new files original commit: 1e6aaf5928d25a650e3642f84657c6cd78476672 --- collects/typed-scheme/private/optimize.ss | 51 +++++++++++++++++++++++ collects/typed-scheme/types/type-table.ss | 15 +++++++ 2 files changed, 66 insertions(+) create mode 100644 collects/typed-scheme/private/optimize.ss create mode 100644 collects/typed-scheme/types/type-table.ss diff --git a/collects/typed-scheme/private/optimize.ss b/collects/typed-scheme/private/optimize.ss new file mode 100644 index 00000000..ca7db62a --- /dev/null +++ b/collects/typed-scheme/private/optimize.ss @@ -0,0 +1,51 @@ +#lang scheme/base + +(require syntax/parse (for-template scheme/base scheme/unsafe/ops) + "../utils/utils.ss" unstable/match scheme/match unstable/syntax + (rep type-rep) + (types abbrev type-table utils)) +(provide optimize) + +(define-syntax-class float-opt-expr + (pattern e:opt-expr + #:when (match (type-of #'e) + [(tc-result1: (== -Flonum type-equal?)) #t] [_ #f]) + #:with opt #'e.opt)) + +(define-syntax-class float-binary-op + #:literals (+ - * / = <= < > >= min max) + (pattern (~and i:id (~or + - * / = <= < > >= min max)) + #:with unsafe (format-id #'here "unsafe-fl~a" #'i))) + +(define-syntax-class float-unary-op + #:literals (abs sin cos tan asin acos atan log exp) + (pattern (~and i:id (~or abs sin cos tan asin acos atan log exp)) + #:with unsafe (format-id #'here "unsafe-fl~a" #'i))) + +(define-syntax-class opt-expr + (pattern e:opt-expr* + #:with opt (syntax-recertify #'e.opt this-syntax (current-code-inspector) #f))) + +(define-syntax-class opt-expr* + #:literal-sets (kernel-literals) + #:local-conventions ([#rx"^e" opt-expr] + [#rx"^f" float-opt-expr]) + (pattern (let-values ([ids e-rhs] ...) e-body ...) + #:with opt #'(let-values ([ids e-rhs.opt] ...) e-body.opt ...)) + (pattern (#%plain-app op:float-unary-op f) + #:with opt #'(op.unsafe f.opt)) + (pattern (#%plain-app op:float-binary-op f fs ...) + #:with opt + (for/fold ([o #'f.opt]) + ([e (syntax->list #'(fs.opt ...))]) + #`(op.unsafe #,o #,e))) + (pattern (#%plain-app e ...) + #:with opt #'(#%plain-app e.opt ...)) + (pattern other:expr + #:with opt #'other)) + +(define (optimize stx) + (syntax-parse stx #:literal-sets (kernel-literals) + [(define-values ~! ids e:opt-expr) + (syntax/loc stx (define-values ids e.opt))] + [_ (printf "nothing happened") stx])) \ No newline at end of file diff --git a/collects/typed-scheme/types/type-table.ss b/collects/typed-scheme/types/type-table.ss new file mode 100644 index 00000000..0cae12dc --- /dev/null +++ b/collects/typed-scheme/types/type-table.ss @@ -0,0 +1,15 @@ +#lang scheme/base + +(require unstable/debug "../utils/utils.ss" (rep type-rep) (only-in (types abbrev utils) tc-results?) scheme/contract) + +(define table (make-hasheq)) + +(define (reset-type-table) (set! table (make-hasheq))) + +(define (add-typeof-expr e t) (hash-set! table e t)) + +(define (type-of e) (hash-ref table e)) + +(p/c [add-typeof-expr (syntax? tc-results? . -> . any/c)] + [type-of (syntax? . -> . tc-results?)] + [reset-type-table (-> any/c)]) \ No newline at end of file From 70118d8ebe816ccb7214bea30f4c029400614041 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 3 Feb 2010 11:44:10 -0500 Subject: [PATCH 3/3] fix some contract errors original commit: 492cab22cbebcdfeed9a4bc467d147b4722308e9 --- collects/typed-scheme/types/union.ss | 2 ++ collects/typed-scheme/utils/utils.ss | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/types/union.ss b/collects/typed-scheme/types/union.ss index 5019cada..a78cbae0 100644 --- a/collects/typed-scheme/types/union.ss +++ b/collects/typed-scheme/types/union.ss @@ -19,6 +19,8 @@ (define (flat t) (match t [(Union: es) es] + [(Values: (list (Result: (Union: es) _ _))) es] + [(Values: (list (Result: t _ _))) (list t)] [_ (list t)])) (define (remove-subtypes ts) diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index 766ba3c2..8e3d6f73 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -160,7 +160,7 @@ at least theoretically. ;; turn contracts on and off - off by default for performance. -(define-for-syntax enable-contracts? #t) +(define-for-syntax enable-contracts? #f) (provide (for-syntax enable-contracts?) p/c w/c cnt d-s/c d/c) ;; these are versions of the contract forms conditionalized by `enable-contracts?'