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

50
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])
(private with-types)
(for-syntax
(except-in syntax/parse id)
unstable/syntax racket/base unstable/match
racket/match unstable/syntax racket/base unstable/match
(private type-contract optimize)
(types utils convenience)
(typecheck typechecker provide-handling tc-toplevel)
@ -14,7 +14,6 @@
(rep type-rep)
(except-in (utils utils) infer)
(only-in (r:infer infer-dummy) infer-param)
scheme/match
"tc-setup.rkt"))
(provide (rename-out [module-begin #%module-begin]
@ -28,28 +27,29 @@
(syntax-parse stx
[(mb (~optional (~and #:optimize (~bind [opt? #'#t]))) forms ...)
(let ([pmb-form (syntax/loc stx (#%plain-module-begin forms ...))])
(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 (or (attribute opt?) (optimize?))
(begin (printf "optimizing ...\n")
(begin0 (map optimize (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))))]))
(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?)
(begin (printf "optimizing ...\n")
(begin0 (map optimize (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-syntax (top-interaction stx)
(syntax-parse stx