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

Extended the typed Scheme optimizer to handle all the core forms.

Browse Source
This commit is contained in:
Vincent St-Amour 2010-05-13 16:46:20 -04:00
parent b543177868
commit 7adedacf2b
1 changed files with 25 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
collects/typed-scheme/private/optimize.rkt
View File

@ -40,13 +40,12 @@
(define-syntax-class opt-expr* (define-syntax-class opt-expr*
#:literal-sets (kernel-literals) #:literal-sets (kernel-literals)
#:local-conventions ([#rx"^e" opt-expr] #:local-conventions ([#px"^e" opt-expr]
[#rx"^f" float-opt-expr] [#px"^f\\d*s?$" float-opt-expr]
[#rx"^p" pair-opt-expr]) [#px"^p\\d*s?$" pair-opt-expr])
(pattern (let-values ([ids e-rhs] ...) e-body ...)
#:with opt #'(let-values ([ids e-rhs.opt] ...) e-body.opt ...))
(pattern (#%plain-app op:float-unary-op f) (pattern (#%plain-app op:float-unary-op f)
#:with opt #'(op.unsafe f.opt)) #:with opt #'(op.unsafe f.opt))
;; unlike their safe counterparts, unsafe binary operators can only take 2 arguments
(pattern (#%plain-app op:float-binary-op f fs ...) (pattern (#%plain-app op:float-binary-op f fs ...)
#:with opt #:with opt
(for/fold ([o #'f.opt]) (for/fold ([o #'f.opt])
@ -54,17 +53,29 @@
#`(op.unsafe #,o #,e))) #`(op.unsafe #,o #,e)))
(pattern (#%plain-app op:pair-unary-op p) (pattern (#%plain-app op:pair-unary-op p)
#:with opt #'(op.unsafe p.opt)) #:with opt #'(op.unsafe p.opt))
(pattern (#%plain-app e ...)
#:with opt #'(#%plain-app e.opt ...)) ;; boring cases, just recur down
(pattern (lambda (x ...) e ...) (pattern (#%plain-lambda formals e ...)
#:with opt #'(lambda (x ...) e.opt ...)) #:with opt #'(#%plain-lambda formals e.opt ...))
(pattern (define-values formals e ...)
#:with opt #'(define-values formals e.opt ...))
(pattern (case-lambda [formals e ...] ...)
#:with opt #'(case-lambda [formals e.opt ...] ...))
(pattern (let-values ([ids e-rhs] ...) e-body ...)
#:with opt #'(let-values ([ids e-rhs.opt] ...) e-body.opt ...))
(pattern (letrec-values ([ids e-rhs] ...) e-body ...)
#:with opt #'(letrec-values ([ids e-rhs.opt] ...) e-body.opt ...))
(pattern (letrec-syntaxes+values stx-bindings ([(ids ...) e-rhs] ...) e-body ...)
#:with opt #'(letrec-syntaxes+values stx-bindings ([(ids ...) e-rhs.opt] ...) e-body.opt ...))
(pattern (kw:identifier expr ...)
#:when (ormap (lambda (k) (free-identifier=? k #'kw))
(list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
#'#%variable-reference #'with-continuation-mark))
#:with opt #'(kw expr.opt ...))
(pattern other:expr (pattern other:expr
#:with opt #'other)) #:with opt #'other))
(define (optimize stx) (define (optimize stx)
(syntax-parse stx #:literal-sets (kernel-literals) (syntax-parse stx #:literal-sets (kernel-literals)
[(define-values ~! ids e:opt-expr) [e:opt-expr
(syntax/loc stx (define-values ids e.opt))] (syntax/loc stx e.opt)]))
[(#%app e:opt-expr ...) (syntax/loc stx (#%app e.opt ...))]
[(#%plain-app e:opt-expr ...) (syntax/loc stx (#%plain-app e.opt ...))]
[_ stx]))