From 72a11f2d561344a8cdc3b8fcff110427383d6254 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 8 Sep 2010 11:38:28 -0400 Subject: [PATCH] Load typechecker dynamically to reduce footprint. original commit: 120a1d0d87824f90b153047cc3a5408a60753b65 --- collects/typed-scheme/core.rkt | 69 +++++++ collects/typed-scheme/private/with-types.rkt | 188 +++++++++--------- .../typed-scheme/typecheck/def-export.rkt | 12 +- collects/typed-scheme/typecheck/renamer.rkt | 9 + collects/typed-scheme/typed-scheme.rkt | 71 +------ 5 files changed, 185 insertions(+), 164 deletions(-) create mode 100644 collects/typed-scheme/core.rkt create mode 100644 collects/typed-scheme/typecheck/renamer.rkt diff --git a/collects/typed-scheme/core.rkt b/collects/typed-scheme/core.rkt new file mode 100644 index 00000000..04ac1879 --- /dev/null +++ b/collects/typed-scheme/core.rkt @@ -0,0 +1,69 @@ +#lang racket/base + +(require (rename-in "utils/utils.rkt" [infer r:infer]) + (for-syntax racket/base) + (for-template racket/base) + (private with-types type-contract) + (except-in syntax/parse id) + racket/match unstable/syntax unstable/match + (optimizer optimizer) + (types utils convenience) + (typecheck typechecker provide-handling tc-toplevel) + (env type-name-env type-alias-env) + (r:infer infer) + (rep type-rep) + (except-in (utils utils tc-utils) infer) + (only-in (r:infer infer-dummy) infer-param) + "tc-setup.rkt") + +(provide mb-core ti-core wt-core) + +(define (mb-core stx) + (syntax-parse stx + [(mb (~optional (~and #:optimize (~bind [opt? #'#t]))) forms ...) + (let ([pmb-form (syntax/loc stx (#%plain-module-begin forms ...))]) + (parameterize ([optimize? (or (optimize?) (attribute opt?))]) + (tc-setup + stx pmb-form 'module-begin new-mod tc-module after-code + (with-syntax* + (;; pmb = #%plain-module-begin + [(pmb . body2) new-mod] + ;; add in syntax property on useless expression to draw check-syntax arrows + [check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))] + ;; perform the provide transformation from [Culpepper 07] + [transformed-body (remove-provides #'body2)] + ;; add the real definitions of contracts on requires + [transformed-body (change-contract-fixups #'transformed-body)] + ;; potentially optimize the code based on the type information + [(optimized-body ...) + ;; do we optimize? + (if (optimize?) + (begin0 (map optimize-top (syntax->list #'transformed-body)) + (do-time "Optimized")) + #'transformed-body)]) + ;; reconstruct the module with the extra code + ;; use the regular %#module-begin from `racket/base' for top-level printing + #`(#%module-begin optimized-body ... #,after-code check-syntax-help)))))])) + +(define (ti-core stx) + (syntax-parse stx + [(_ . ((~datum module) . rest)) + #'(module . rest)] + [(_ . form) + (tc-setup + stx #'form 'top-level body2 tc-toplevel-form type + (syntax-parse body2 + ;; any of these do not produce an expression to be printed + [(head:invis-kw . _) body2] + [_ (let ([ty-str (match type + ;; don't print results of type void + [(tc-result1: (== -Void type-equal?)) #f] + [(tc-result1: t f o) + (format "- : ~a\n" t)] + [(tc-results: t) + (format "- : ~a\n" (cons 'Values t))] + [x (int-err "bad type result: ~a" x)])]) + (if ty-str + #`(let ([type '#,ty-str]) + (begin0 #,body2 (display type))) + body2))]))])) \ No newline at end of file diff --git a/collects/typed-scheme/private/with-types.rkt b/collects/typed-scheme/private/with-types.rkt index 601bdb38..a3eb62dc 100644 --- a/collects/typed-scheme/private/with-types.rkt +++ b/collects/typed-scheme/private/with-types.rkt @@ -1,11 +1,14 @@ #lang racket/base -(require racket/require racket/contract/regions racket/contract/base +(require racket/require + (for-template + (except-in racket/base for for*) + "prims.rkt" + (prefix-in c: (combine-in racket/contract/regions racket/contract/base))) "base-env.rkt" "base-special-env.rkt" "base-env-numeric.rkt" "base-env-indexing.rkt" "extra-procs.rkt" "prims.rkt" - (for-syntax - scheme/base syntax/parse racket/block racket/match - unstable/sequence unstable/debug "base-types-extra.rkt" + syntax/parse racket/block racket/match + unstable/sequence unstable/debug "base-types-extra.rkt" (except-in (path-up "env/type-name-env.rkt" "env/type-alias-env.rkt" "infer/infer-dummy.rkt" @@ -21,98 +24,97 @@ "types/convenience.rkt" "types/abbrev.rkt") ->) - (except-in (path-up "utils/utils.rkt") infer))) + (except-in (path-up "utils/utils.rkt") infer)) -(provide with-type) +(provide wt-core) -(define-for-syntax (with-type-helper stx body fvids fvtys exids extys resty expr? ctx) - (block - (define old-context (unbox typed-context?)) - (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) - (define fv-types (for/list ([t (in-list (syntax->list fvtys))]) - (parse-type t))) - (define fv-cnts (for/list ([t (in-list fv-types)] - [stx (in-list (syntax->list fvtys))]) - (type->contract t #:typed-side #f (no-contract t)))) - (define ex-types (for/list ([t (syntax->list extys)]) - (parse-type t))) - (define ex-cnts (for/list ([t (in-list ex-types)] - [stx (in-list (syntax->list extys))]) - (type->contract t #:typed-side #t (no-contract t)))) - (define region-tc-result - (and expr? (parse-tc-results resty))) - (define region-cnts - (if region-tc-result - (match region-tc-result - [(tc-result1: t) - (list (type->contract t #:typed-side #t (no-contract t #'region-ty-stx)))] - [(tc-results: ts) - (for/list ([t (in-list ts)]) - (type->contract - t #:typed-side #t - (no-contract t #'region-ty-stx)))]) - null)) - (for ([i (in-list (syntax->list fvids))] - [ty (in-list fv-types)]) - (register-type i ty)) - (define expanded-body - (if expr? - (with-syntax ([body body]) - (local-expand #'(let () . body) ctx null)) - (with-syntax ([(body ...) body] - [(id ...) exids] - [(ty ...) extys]) - (local-expand #'(let () (begin (: id ty) ... body ... (values id ...))) ctx null)))) - (parameterize (;; disable fancy printing? - [custom-printer #t] - ;; a cheat to avoid units - [infer-param infer] - ;; do we report multiple errors - [delay-errors? #t] - ;; this parameter is just for printing types - ;; this is a parameter to avoid dependency issues - [current-type-names - (lambda () - (append - (type-name-env-map (lambda (id ty) - (cons (syntax-e id) ty))) - (type-alias-env-map (lambda (id ty) - (cons (syntax-e id) ty)))))] - ;; reinitialize seen type variables - [type-name-references null] - ;; for error reporting - [orig-module-stx stx] - [expanded-module-stx expanded-body]) - (tc-expr/check expanded-body (if expr? region-tc-result (ret ex-types)))) - (report-all-errors) - (set-box! typed-context? old-context) - ;; then clear the new entries from the env ht - (for ([i (in-list (syntax->list fvids))]) - (unregister-type i)) - (with-syntax ([(fv.id ...) fvids] - [(cnt ...) fv-cnts] - [(ex-id ...) exids] - [(ex-cnt ...) ex-cnts] - [(region-cnt ...) region-cnts] - [body expanded-body] - [check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))]) - (if expr? - (quasisyntax/loc stx - (begin check-syntax-help - (with-contract typed-region - #:results (region-cnt ...) - #:freevars ([fv.id cnt] ...) - body))) - (syntax/loc stx - (begin - (define-values () (begin check-syntax-help (values))) - (with-contract typed-region - ([ex-id ex-cnt] ...) - (define-values (ex-id ...) body)))))))) +(define (with-type-helper stx body fvids fvtys exids extys resty expr? ctx) + (define old-context (unbox typed-context?)) + (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) + (define fv-types (for/list ([t (in-list (syntax->list fvtys))]) + (parse-type t))) + (define fv-cnts (for/list ([t (in-list fv-types)] + [stx (in-list (syntax->list fvtys))]) + (type->contract t #:typed-side #f (no-contract t)))) + (define ex-types (for/list ([t (syntax->list extys)]) + (parse-type t))) + (define ex-cnts (for/list ([t (in-list ex-types)] + [stx (in-list (syntax->list extys))]) + (type->contract t #:typed-side #t (no-contract t)))) + (define region-tc-result + (and expr? (parse-tc-results resty))) + (define region-cnts + (if region-tc-result + (match region-tc-result + [(tc-result1: t) + (list (type->contract t #:typed-side #t (no-contract t #'region-ty-stx)))] + [(tc-results: ts) + (for/list ([t (in-list ts)]) + (type->contract + t #:typed-side #t + (no-contract t #'region-ty-stx)))]) + null)) + (for ([i (in-list (syntax->list fvids))] + [ty (in-list fv-types)]) + (register-type i ty)) + (define expanded-body + (if expr? + (with-syntax ([body body]) + (local-expand #'(let () . body) ctx null)) + (with-syntax ([(body ...) body] + [(id ...) exids] + [(ty ...) extys]) + (local-expand #'(let () (begin (: id ty) ... body ... (values id ...))) ctx null)))) + (parameterize (;; disable fancy printing? + [custom-printer #t] + ;; a cheat to avoid units + [infer-param infer] + ;; do we report multiple errors + [delay-errors? #t] + ;; this parameter is just for printing types + ;; this is a parameter to avoid dependency issues + [current-type-names + (lambda () + (append + (type-name-env-map (lambda (id ty) + (cons (syntax-e id) ty))) + (type-alias-env-map (lambda (id ty) + (cons (syntax-e id) ty)))))] + ;; reinitialize seen type variables + [type-name-references null] + ;; for error reporting + [orig-module-stx stx] + [expanded-module-stx expanded-body]) + (tc-expr/check expanded-body (if expr? region-tc-result (ret ex-types)))) + (report-all-errors) + (set-box! typed-context? old-context) + ;; then clear the new entries from the env ht + (for ([i (in-list (syntax->list fvids))]) + (unregister-type i)) + (with-syntax ([(fv.id ...) fvids] + [(cnt ...) fv-cnts] + [(ex-id ...) exids] + [(ex-cnt ...) ex-cnts] + [(region-cnt ...) region-cnts] + [body expanded-body] + [check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))]) + (if expr? + (quasisyntax/loc stx + (begin check-syntax-help + (c:with-contract typed-region + #:results (region-cnt ...) + #:freevars ([fv.id cnt] ...) + body))) + (syntax/loc stx + (begin + (define-values () (begin check-syntax-help (values))) + (c:with-contract typed-region + ([ex-id ex-cnt] ...) + (define-values (ex-id ...) body))))))) -(define-syntax (with-type stx) +(define (wt-core stx) (define-syntax-class typed-id #:description "[id type]" [pattern (id ty)]) diff --git a/collects/typed-scheme/typecheck/def-export.rkt b/collects/typed-scheme/typecheck/def-export.rkt index acf624d6..16b70823 100644 --- a/collects/typed-scheme/typecheck/def-export.rkt +++ b/collects/typed-scheme/typecheck/def-export.rkt @@ -1,16 +1,10 @@ #lang racket/base -(require racket/require - (for-syntax syntax/parse racket/base - (path-up "utils/tc-utils.rkt" "private/typed-renaming.rkt" "env/type-name-env.rkt"))) +(require racket/require (for-template "renamer.rkt") "renamer.rkt" + (for-syntax syntax/parse racket/base "renamer.rkt" + (path-up "utils/tc-utils.rkt" "env/type-name-env.rkt"))) (provide def-export) - -(define-for-syntax (renamer id #:alt [alt #f]) - (if alt - (make-typed-renaming (syntax-property id 'not-free-identifier=? #t) alt) - (make-rename-transformer (syntax-property id 'not-free-identifier=? #t)))) - (define-syntax (def-export stx) (syntax-parse stx [(def-export export-id:identifier id:identifier cnt-id:identifier) diff --git a/collects/typed-scheme/typecheck/renamer.rkt b/collects/typed-scheme/typecheck/renamer.rkt new file mode 100644 index 00000000..a1f19cff --- /dev/null +++ b/collects/typed-scheme/typecheck/renamer.rkt @@ -0,0 +1,9 @@ +#lang racket/base + +(require "../private/typed-renaming.rkt") +(provide renamer) + +(define (renamer id #:alt [alt #f]) + (if alt + (make-typed-renaming (syntax-property id 'not-free-identifier=? #t) alt) + (make-rename-transformer (syntax-property id 'not-free-identifier=? #t)))) \ No newline at end of file diff --git a/collects/typed-scheme/typed-scheme.rkt b/collects/typed-scheme/typed-scheme.rkt index 6063fdfa..88f1e416 100644 --- a/collects/typed-scheme/typed-scheme.rkt +++ b/collects/typed-scheme/typed-scheme.rkt @@ -1,21 +1,6 @@ #lang racket/base -(require (rename-in "utils/utils.rkt" [infer r:infer]) - (private with-types) - (for-syntax - (except-in syntax/parse id) - racket/match unstable/syntax racket/base unstable/match - (private type-contract) - (optimizer optimizer) - (types utils convenience) - (typecheck typechecker provide-handling tc-toplevel) - (env type-name-env type-alias-env) - (r:infer infer) - (utils tc-utils) - (rep type-rep) - (except-in (utils utils) infer) - (only-in (r:infer infer-dummy) infer-param) - "tc-setup.rkt")) +(require (for-syntax racket/base "typecheck/renamer.rkt")) (provide (rename-out [module-begin #%module-begin] [top-interaction #%top-interaction] @@ -25,54 +10,16 @@ with-type) (define-syntax (module-begin stx) - (syntax-parse stx - [(mb (~optional (~and #:optimize (~bind [opt? #'#t]))) forms ...) - (let ([pmb-form (syntax/loc stx (#%plain-module-begin forms ...))]) - (parameterize ([optimize? (or (optimize?) (attribute opt?))]) - (tc-setup - stx pmb-form 'module-begin new-mod tc-module after-code - (with-syntax* - (;; pmb = #%plain-module-begin - [(pmb . body2) new-mod] - ;; add in syntax property on useless expression to draw check-syntax arrows - [check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))] - ;; perform the provide transformation from [Culpepper 07] - [transformed-body (remove-provides #'body2)] - ;; add the real definitions of contracts on requires - [transformed-body (change-contract-fixups #'transformed-body)] - ;; potentially optimize the code based on the type information - [(optimized-body ...) - ;; do we optimize? - (if (optimize?) - (begin0 (map optimize-top (syntax->list #'transformed-body)) - (do-time "Optimized")) - #'transformed-body)]) - ;; reconstruct the module with the extra code - ;; use the regular %#module-begin from `racket/base' for top-level printing - #`(#%module-begin optimized-body ... #,after-code check-syntax-help)))))])) + (dynamic-require 'typed-scheme/private/base-env #f) + (dynamic-require 'typed-scheme/private/base-env-numeric #f) + (dynamic-require 'typed-scheme/private/base-env-indexing #f) + ((dynamic-require 'typed-scheme/core 'mb-core) stx)) (define-syntax (top-interaction stx) - (syntax-parse stx - [(_ . ((~datum module) . rest)) - #'(module . rest)] - [(_ . form) - (tc-setup - stx #'form 'top-level body2 tc-toplevel-form type - (syntax-parse body2 - ;; any of these do not produce an expression to be printed - [(head:invis-kw . _) body2] - [_ (let ([ty-str (match type - ;; don't print results of type void - [(tc-result1: (== -Void type-equal?)) #f] - [(tc-result1: t f o) - (format "- : ~a\n" t)] - [(tc-results: t) - (format "- : ~a\n" (cons 'Values t))] - [x (int-err "bad type result: ~a" x)])]) - (if ty-str - #`(let ([type '#,ty-str]) - (begin0 #,body2 (display type))) - body2))]))])) + ((dynamic-require 'typed-scheme/core 'ti-core) stx)) + +(define-syntax (with-type stx) + ((dynamic-require 'typed-scheme/core 'wt-core) stx))