suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fix optimizer for refactoring.

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2010-06-11 14:21:15 -04:00
parent b649575afc
commit fd1b20c93d
3 changed files with 31 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/tests/typed-scheme/succeed/optimize-simple.rkt Normal file
View File

@ -0,0 +1,3 @@
#lang typed/racket #:optimize
(+ 3 4)

6
collects/typed-scheme/tc-setup.rkt
View File

@ -4,7 +4,7 @@
(except-in syntax/parse id) (except-in syntax/parse id)
unstable/mutated-vars unstable/mutated-vars
scheme/base scheme/base
(private type-contract optimize) (private type-contract)
(types utils convenience) (types utils convenience)
(typecheck typechecker provide-handling tc-toplevel) (typecheck typechecker provide-handling tc-toplevel)
(env type-environments type-name-env type-alias-env) (env type-environments type-name-env type-alias-env)
@ -13,9 +13,7 @@
(rep type-rep) (rep type-rep)
(except-in (utils utils) infer) (except-in (utils utils) infer)
(only-in (r:infer infer-dummy) infer-param) (only-in (r:infer infer-dummy) infer-param)
scheme/nest racket/match
syntax/kerncase
scheme/match
(for-syntax racket/base) (for-syntax racket/base)
(for-template racket/base)) (for-template racket/base))

52
collects/typed-scheme/typed-scheme.rkt
View File

@ -1,10 +1,10 @@
#lang scheme/base #lang racket/base
(require (rename-in "utils/utils.rkt" [infer r:infer]) (require (rename-in "utils/utils.rkt" [infer r:infer])
(private with-types) (private with-types)
(for-syntax (for-syntax
(except-in syntax/parse id) (except-in syntax/parse id)
unstable/syntax racket/base unstable/match racket/match unstable/syntax racket/base unstable/match
(private type-contract optimize) (private type-contract optimize)
(types utils convenience) (types utils convenience)
(typecheck typechecker provide-handling tc-toplevel) (typecheck typechecker provide-handling tc-toplevel)
@ -13,8 +13,7 @@
(utils tc-utils) (utils tc-utils)
(rep type-rep) (rep type-rep)
(except-in (utils utils) infer) (except-in (utils utils) infer)
(only-in (r:infer infer-dummy) infer-param) (only-in (r:infer infer-dummy) infer-param)
scheme/match
"tc-setup.rkt")) "tc-setup.rkt"))
(provide (rename-out [module-begin #%module-begin] (provide (rename-out [module-begin #%module-begin]
@ -28,28 +27,29 @@
(syntax-parse stx (syntax-parse stx
[(mb (~optional (~and #:optimize (~bind [opt? #'#t]))) forms ...) [(mb (~optional (~and #:optimize (~bind [opt? #'#t]))) forms ...)
(let ([pmb-form (syntax/loc stx (#%plain-module-begin forms ...))]) (let ([pmb-form (syntax/loc stx (#%plain-module-begin forms ...))])
(tc-setup (parameterize ([optimize? (or (optimize?) (attribute opt?))])
stx pmb-form 'module-begin new-mod tc-module after-code (tc-setup
(with-syntax* stx pmb-form 'module-begin new-mod tc-module after-code
(;; pmb = #%plain-module-begin (with-syntax*
[(pmb . body2) new-mod] (;; pmb = #%plain-module-begin
;; add in syntax property on useless expression to draw check-syntax arrows [(pmb . body2) new-mod]
[check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))] ;; add in syntax property on useless expression to draw check-syntax arrows
;; perform the provide transformation from [Culpepper 07] [check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))]
[transformed-body (remove-provides #'body2)] ;; perform the provide transformation from [Culpepper 07]
;; add the real definitions of contracts on requires [transformed-body (remove-provides #'body2)]
[transformed-body (change-contract-fixups #'transformed-body)] ;; add the real definitions of contracts on requires
;; potentially optimize the code based on the type information [transformed-body (change-contract-fixups #'transformed-body)]
[(optimized-body ...) ;; potentially optimize the code based on the type information
;; do we optimize? [(optimized-body ...)
(if (or (attribute opt?) (optimize?)) ;; do we optimize?
(begin (printf "optimizing ...\n") (if (optimize?)
(begin0 (map optimize (syntax->list #'transformed-body)) (begin (printf "optimizing ...\n")
(do-time "Optimized"))) (begin0 (map optimize (syntax->list #'transformed-body))
#'transformed-body)]) (do-time "Optimized")))
;; reconstruct the module with the extra code #'transformed-body)])
;; use the regular %#module-begin from `racket/base' for top-level printing ;; reconstruct the module with the extra code
#`(#%module-begin optimized-body ... #,after-code check-syntax-help))))])) ;; use the regular %#module-begin from `racket/base' for top-level printing
#`(#%module-begin optimized-body ... #,after-code check-syntax-help)))))]))
(define-syntax (top-interaction stx) (define-syntax (top-interaction stx)
(syntax-parse stx (syntax-parse stx