From af26c11c83a11fbe4b219b5473c3b688e14e66ff Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 12 Sep 2011 11:49:07 -0400 Subject: [PATCH] Move environment initialization after local expansion in Typed Racket. This means that syntax errors caught by `local-expand' are reported sooner, but shouldn't change other timing results. original commit: f9b0f0ce7320b09eb2203580a7d04d909dc2f430 --- collects/typed-racket/core.rkt | 12 +++---- collects/typed-racket/private/with-types.rkt | 11 ++++--- collects/typed-racket/tc-setup.rkt | 34 ++++++++++---------- collects/typed-racket/typed-racket.rkt | 5 ++- 4 files changed, 31 insertions(+), 31 deletions(-) diff --git a/collects/typed-racket/core.rkt b/collects/typed-racket/core.rkt index 97ba6669..313f1dc4 100644 --- a/collects/typed-racket/core.rkt +++ b/collects/typed-racket/core.rkt @@ -15,7 +15,7 @@ (provide mb-core ti-core wt-core) -(define (mb-core stx) +(define (mb-core stx init) (syntax-parse stx [(mb (~optional (~or (~and #:optimize (~bind [opt? #'#t])) ; kept for backward compatibility (~and #:no-optimize (~bind [opt? #'#f])))) @@ -24,7 +24,7 @@ (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 + stx pmb-form 'module-begin new-mod init tc-module after-code (with-syntax* (;; pmb = #%plain-module-begin [(pmb . body2) new-mod] @@ -46,7 +46,7 @@ (define did-I-suggest-:print-type-already? #f) (define :print-type-message " ... [Use (:print-type ) to see more.]") -(define (ti-core stx) +(define (ti-core stx init) (syntax-parse stx [(_ . ((~datum module) . rest)) #'(module . rest)] @@ -55,14 +55,14 @@ ;; Prints the _entire_ type. May be quite large. [(_ . ((~literal :print-type) e:expr)) #`(display #,(format "~a\n" - (tc-setup #'stx #'e 'top-level expanded tc-toplevel-form type + (tc-setup #'stx #'e 'top-level expanded init tc-toplevel-form type (match type [(tc-result1: t f o) t] [(tc-results: t) (cons 'Values t)]))))] ;; given a function and a desired return type, fill in the blanks [(_ . ((~literal :query-result-type) op:expr desired-type:expr)) (let ([expected (parse-type #'desired-type)]) - (tc-setup #'stx #'op 'top-level expanded tc-toplevel-form type + (tc-setup #'stx #'op 'top-level expanded init tc-toplevel-form type (match type [(tc-result1: (and t (Function: _)) f o) (let ([cleaned (cleanup-type t expected)]) @@ -75,7 +75,7 @@ [_ (error (format "~a: not a function" (syntax->datum #'op) ))])))] [(_ . form) (tc-setup - stx #'form 'top-level body2 tc-toplevel-form type + stx #'form 'top-level body2 init tc-toplevel-form type (with-syntax* ([optimized-body (car (maybe-optimize #`(#,body2)))]) (syntax-parse body2 diff --git a/collects/typed-racket/private/with-types.rkt b/collects/typed-racket/private/with-types.rkt index ee35295f..8a9af72e 100644 --- a/collects/typed-racket/private/with-types.rkt +++ b/collects/typed-racket/private/with-types.rkt @@ -7,7 +7,7 @@ (prefix-in c: (combine-in racket/contract/region racket/contract/base))) "../base-env/extra-procs.rkt" (except-in "../base-env/prims.rkt" with-handlers) "../tc-setup.rkt" - syntax/parse racket/block racket/match + syntax/parse racket/match unstable/sequence "../base-env/base-types-extra.rkt" (except-in (path-up "env/type-name-env.rkt" "env/type-alias-env.rkt" @@ -28,13 +28,14 @@ (provide wt-core) -(define (with-type-helper stx body fvids fvtys exids extys resty expr? ctx) +(define (with-type-helper stx init body fvids fvtys exids extys resty expr? ctx) (define old-context (unbox typed-context?)) (unless (not old-context) (tc-error/stx stx "with-type cannot be used in a typed module.")) (define ((no-contract t [stx stx])) (tc-error/stx stx "Type ~a could not be converted to a contract." t)) (set-box! typed-context? #t) + (init) (define fv-types (for/list ([t (in-list (syntax->list fvtys))]) (parse-type t))) (define fv-cnts (for/list ([t (in-list fv-types)] @@ -121,7 +122,7 @@ ([ex-id ex-cnt] ...) (define-values (ex-id ...) body))))))) -(define (wt-core stx) +(define (wt-core stx init) (define-syntax-class typed-id #:description "[id type]" [pattern (id ty)]) @@ -143,7 +144,7 @@ [pattern (~seq #:result ty:expr)]) (syntax-parse stx [(_ :typed-ids fv:free-vars . body) - (with-type-helper stx #'body #'(fv.id ...) #'(fv.ty ...) #'(id ...) #'(ty ...) #f #f (syntax-local-context))] + (with-type-helper stx init #'body #'(fv.id ...) #'(fv.ty ...) #'(id ...) #'(ty ...) #f #f (syntax-local-context))] [(_ :result-ty fv:free-vars . body) - (with-type-helper stx #'body #'(fv.id ...) #'(fv.ty ...) #'() #'() #'ty #t (syntax-local-context))])) + (with-type-helper stx init #'body #'(fv.id ...) #'(fv.ty ...) #'() #'() #'ty #t (syntax-local-context))])) diff --git a/collects/typed-racket/tc-setup.rkt b/collects/typed-racket/tc-setup.rkt index 5d67fa22..3e32e9e8 100644 --- a/collects/typed-racket/tc-setup.rkt +++ b/collects/typed-racket/tc-setup.rkt @@ -13,7 +13,6 @@ (rep type-rep) (except-in (utils utils) infer) (only-in (r:infer infer-dummy) infer-param) - racket/match (for-syntax racket/base) (for-template racket/base)) @@ -34,13 +33,13 @@ (do-time "Optimized"))) body)) -(define-syntax-rule (tc-setup orig-stx stx expand-ctxt fully-expanded-stx checker result . body) +(define-syntax-rule (tc-setup orig-stx stx expand-ctxt fully-expanded-stx init checker result . body) (let () (set-box! typed-context? #t) ;(start-timing (syntax-property stx 'enclosing-module-name)) (with-handlers - ([(lambda (e) (and #f (exn:fail? e) (not (exn:fail:syntax? e)))) - (lambda (e) (tc-error "Internal Typed Racket Error : ~a" e))]) + ([(λ (e) (and (exn:fail? e) (not (exn:fail:syntax? e)))) + (λ (e) (tc-error "Internal Typed Racket Error : ~a" e))]) (parameterize (;; enable fancy printing? [custom-printer #t] ;; a cheat to avoid units @@ -60,17 +59,18 @@ (cons (syntax-e id) ty)))))] ;; reinitialize disappeared uses [disappeared-use-todo null] - [disappeared-bindings-todo null]) + [disappeared-bindings-todo null]) + (define fully-expanded-stx (disarm* (local-expand stx expand-ctxt null))) + (when (show-input?) + (pretty-print (syntax->datum fully-expanded-stx))) + (do-time "Local Expand Done") + (init) (do-time "Initialized Envs") - (let ([fully-expanded-stx (disarm* (local-expand stx expand-ctxt null))]) - (when (show-input?) - (pretty-print (syntax->datum fully-expanded-stx))) - (do-time "Local Expand Done") - (parameterize ([mutated-vars (find-mutated-vars fully-expanded-stx)] - [orig-module-stx (or (orig-module-stx) orig-stx)] - [expanded-module-stx fully-expanded-stx] - [debugging? #f]) - (do-time "Starting `checker'") - (let ([result (checker fully-expanded-stx)]) - (do-time "Typechecking Done") - (let () . body)))))))) + (parameterize ([mutated-vars (find-mutated-vars fully-expanded-stx)] + [orig-module-stx (or (orig-module-stx) orig-stx)] + [expanded-module-stx fully-expanded-stx] + [debugging? #f]) + (do-time "Starting `checker'") + (define result (checker fully-expanded-stx)) + (do-time "Typechecking Done") + (let () . body)))))) diff --git a/collects/typed-racket/typed-racket.rkt b/collects/typed-racket/typed-racket.rkt index 0724da95..0ace76fb 100644 --- a/collects/typed-racket/typed-racket.rkt +++ b/collects/typed-racket/typed-racket.rkt @@ -34,11 +34,10 @@ (define-syntax-rule (drivers [name sym] ...) (begin (define-syntax (name stx) - (do-time (format "Calling ~a driver" 'name)) - (do-standard-inits) + (do-time (format "Calling ~a driver" 'name)) (define f (dynamic-require 'typed-racket/core 'sym)) (do-time (format "Loaded core ~a" 'sym)) - (begin0 (f stx) + (begin0 (f stx do-standard-inits) (do-time "Finished, returning to Racket"))) ...))