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))

10
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)
@ -14,7 +14,6 @@
(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,6 +27,7 @@
(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 ...))])
(parameterize ([optimize? (or (optimize?) (attribute opt?))])
(tc-setup (tc-setup
stx pmb-form 'module-begin new-mod tc-module after-code stx pmb-form 'module-begin new-mod tc-module after-code
(with-syntax* (with-syntax*
@ -42,14 +42,14 @@
;; potentially optimize the code based on the type information ;; potentially optimize the code based on the type information
[(optimized-body ...) [(optimized-body ...)
;; do we optimize? ;; do we optimize?
(if (or (attribute opt?) (optimize?)) (if (optimize?)
(begin (printf "optimizing ...\n") (begin (printf "optimizing ...\n")
(begin0 (map optimize (syntax->list #'transformed-body)) (begin0 (map optimize (syntax->list #'transformed-body))
(do-time "Optimized"))) (do-time "Optimized")))
#'transformed-body)]) #'transformed-body)])
;; reconstruct the module with the extra code ;; reconstruct the module with the extra code
;; use the regular %#module-begin from `racket/base' for top-level printing ;; use the regular %#module-begin from `racket/base' for top-level printing
#`(#%module-begin optimized-body ... #,after-code check-syntax-help))))])) #`(#%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