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

The optimizer now ignores code that is inside a with-handlers form,

Browse Source 
since it would be typechecked in an unusual manner.
This commit is contained in:
Vincent St-Amour 2010-07-23 18:35:36 -04:00
parent 5d86813267
commit 80b6ef7dd1
1 changed files with 30 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
collects/typed-scheme/optimizer/optimizer.rkt
View File

@ -37,27 +37,42 @@
;; boring cases, just recur down ;; boring cases, just recur down
(pattern ((~and op (~or (~literal #%plain-lambda) (~literal define-values))) (pattern ((~and op (~or (~literal #%plain-lambda) (~literal define-values)))
formals e:opt-expr ...) formals e:expr ...)
#:with opt #'(op formals e.opt ...)) #:with opt #`(op formals #,@(map (optimize) (syntax->list #'(e ...)))))
(pattern (case-lambda [formals e:opt-expr ...] ...) (pattern (case-lambda [formals e:expr ...] ...)
#:with opt #'(case-lambda [formals e.opt ...] ...)) ;; optimize all the bodies
#:with (opt-parts ...)
(map (lambda (part)
(let ((l (syntax->list part)))
(cons (car l)
(map (optimize) (cdr l)))))
(syntax->list #'([formals e ...] ...)))
#:with opt #'(case-lambda opt-parts ...))
(pattern ((~and op (~or (~literal let-values) (~literal letrec-values))) (pattern ((~and op (~or (~literal let-values) (~literal letrec-values)))
([ids e-rhs:opt-expr] ...) e-body:opt-expr ...) ([ids e-rhs:expr] ...) e-body:expr ...)
#:with opt #'(op ([ids e-rhs.opt] ...) e-body.opt ...)) #:with (opt-rhs ...) (map (optimize) (syntax->list #'(e-rhs ...)))
#:with opt #`(op ([ids opt-rhs] ...)
#,@(map (optimize) (syntax->list #'(e-body ...)))))
(pattern (letrec-syntaxes+values stx-bindings (pattern (letrec-syntaxes+values stx-bindings
([(ids ...) e-rhs:opt-expr] ...) ([(ids ...) e-rhs:expr] ...)
e-body:opt-expr ...) e-body:expr ...)
#:with opt #'(letrec-syntaxes+values stx-bindings ;; optimize all the rhss
([(ids ...) e-rhs.opt] ...) #:with (opt-clauses ...)
e-body.opt ...)) (map (lambda (clause)
(let ((l (syntax->list clause)))
(list (car l) ((optimize) (cadr l)))))
(syntax->list #'([(ids ...) e-rhs] ...)))
#:with opt #`(letrec-syntaxes+values
stx-bindings
(opt-clauses ...)
#,@(map (optimize) (syntax->list #'(e-body ...)))))
(pattern (kw:identifier expr ...) (pattern (kw:identifier expr ...)
#:when #:when
(for/or ([k (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression (for/or ([k (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
#'#%variable-reference #'with-continuation-mark)]) #'#%variable-reference #'with-continuation-mark)])
(free-identifier=? k #'kw)) (free-identifier=? k #'kw))
;; we don't want to optimize in the cases that don't match the #:when clause ;; we don't want to optimize in the cases that don't match the #:when clause
#:with (expr*:opt-expr ...) #'(expr ...) #:with opt #`(kw #,@(map (optimize) (syntax->list #'(expr ...)))))
#:with opt #'(kw expr*.opt ...))
(pattern other:expr (pattern other:expr
#:with opt #'other)) #:with opt #'other))
@ -71,7 +86,8 @@
(parameterize ([current-output-port port] (parameterize ([current-output-port port]
[optimize (syntax-parser [optimize (syntax-parser
[e:expr [e:expr
#:when (not (syntax-property #'e 'typechecker:ignore)) #:when (and (not (syntax-property #'e 'typechecker:ignore))
(not (syntax-property #'e 'typechecker:with-handlers)))
#:with e*:opt-expr #'e #:with e*:opt-expr #'e
#'e*.opt] #'e*.opt]
[e:expr #'e])]) [e:expr #'e])])