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

Cleanup optimizer code.

Browse Source
This commit is contained in:
Eric Dobson 2013-09-05 08:25:05 -07:00
parent 1f631a219f
commit 28b07e7a45
2 changed files with 53 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

120
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/optimizer.rkt
View File

@ -1,99 +1,83 @@
#lang racket/base
(require syntax/parse syntax/stx unstable/sequence
racket/pretty
(for-template racket/base)
(require syntax/parse racket/pretty
"../utils/utils.rkt"
(private syntax-properties)
(except-in
(optimizer utils
number fixnum float float-complex vector string list pair
sequence box struct dead-code apply unboxed-let
hidden-costs)
opt-expr))
(optimizer utils
number fixnum float float-complex vector string list pair
sequence box struct dead-code apply unboxed-let
hidden-costs))
(provide optimize-top)
(define-syntax-class opt-expr
(define-syntax-class opt-expr*
#:commit
#:literal-sets (kernel-literals)
#:attributes (opt)
;; Can't optimize this code because it isn't typechecked
(pattern opt:expr
#:when (or (ignore-property #'opt)
(ignore-some-property #'opt)
(with-handlers-property #'opt)))
;; can't optimize the body of this code because it isn't typechecked
(pattern ((~and op (~literal let-values))
([(i:id) e-rhs:expr]) e-body:expr ...)
;; Can't optimize the body of this code because it isn't typechecked
(pattern ((~and op let-values)
([(i:id) e-rhs:opt-expr]) e-body:expr ...)
#:when (kw-lambda-property this-syntax)
#:with opt-rhs ((optimize) #'e-rhs)
#:with opt (quasisyntax/loc/origin this-syntax #'op
(op ([(i) opt-rhs]) e-body ...)))
(op ([(i) e-rhs.opt]) e-body ...)))
;; interesting cases, where something is optimized
(pattern e:dead-code-opt-expr #:with opt #'e.opt)
(pattern e:unboxed-let-opt-expr #:with opt #'e.opt)
(pattern e:apply-opt-expr #:with opt #'e.opt)
(pattern e:number-opt-expr #:with opt #'e.opt)
(pattern e:fixnum-opt-expr #:with opt #'e.opt)
(pattern e:float-opt-expr #:with opt #'e.opt)
(pattern e:float-complex-opt-expr #:with opt #'e.opt)
(pattern e:vector-opt-expr #:with opt #'e.opt)
(pattern e:string-opt-expr #:with opt #'e.opt)
(pattern e:list-opt-expr #:with opt #'e.opt)
(pattern e:pair-opt-expr #:with opt #'e.opt)
(pattern e:sequence-opt-expr #:with opt #'e.opt)
(pattern e:box-opt-expr #:with opt #'e.opt)
(pattern e:struct-opt-expr #:with opt #'e.opt)
(pattern e:hidden-cost-log-expr #:with opt #'e.opt)
(pattern :dead-code-opt-expr)
(pattern :unboxed-let-opt-expr)
(pattern :apply-opt-expr)
(pattern :number-opt-expr)
(pattern :fixnum-opt-expr)
(pattern :float-opt-expr)
(pattern :float-complex-opt-expr)
(pattern :vector-opt-expr)
(pattern :string-opt-expr)
(pattern :list-opt-expr)
(pattern :pair-opt-expr)
(pattern :sequence-opt-expr)
(pattern :box-opt-expr)
(pattern :struct-opt-expr)
(pattern :hidden-cost-log-expr)
;; boring cases, just recur down
(pattern ((~and op (~or (~literal #%plain-lambda) (~literal define-values)))
formals e:expr ...)
#:with opt (quasisyntax/loc/origin this-syntax #'op (op formals #,@(stx-map (optimize) #'(e ...)))))
(pattern ((~and op case-lambda) [formals e:expr ...] ...)
(pattern ((~and op (~or #%plain-lambda define-values)) formals e:opt-expr ...)
#:with opt (quasisyntax/loc/origin this-syntax #'op (op formals e.opt ...)))
(pattern ((~and op case-lambda) [formals e:opt-expr ...] ...)
;; optimize all the bodies
#:with (opt-parts ...)
(for/list ([part (in-syntax #'([formals e ...] ...))])
(let ((l (syntax->list part)))
(cons (car l)
(map (optimize) (cdr l)))))
#:with opt (syntax/loc/origin this-syntax #'op (op opt-parts ...)))
(pattern ((~and op (~or (~literal let-values) (~literal letrec-values)))
([ids e-rhs:expr] ...) e-body:expr ...)
#:with (opt-rhs ...) (stx-map (optimize) #'(e-rhs ...))
#:with opt (quasisyntax/loc/origin this-syntax #'op
(op ([ids opt-rhs] ...)
#,@(stx-map (optimize) #'(e-body ...)))))
(pattern ((~and op letrec-syntaxes+values) stx-bindings
([(ids ...) e-rhs:expr] ...)
e-body:expr ...)
;; optimize all the rhss
#:with (opt-clauses ...)
(for/list ([clause (in-syntax #'([(ids ...) e-rhs] ...))])
(let ((l (syntax->list clause)))
(list (car l) ((optimize) (cadr l)))))
#:with opt (syntax/loc/origin this-syntax #'op (op [formals e.opt ...] ...)))
(pattern ((~and op (~or let-values letrec-values))
([ids e-rhs:opt-expr] ...) e-body:opt-expr ...)
#:with opt (syntax/loc/origin this-syntax #'op
(op ([ids e-rhs.opt] ...)
e-body.opt ...)))
(pattern ((~and op letrec-syntaxes+values)
stx-bindings
([(ids ...) e-rhs:opt-expr] ...)
e-body:opt-expr ...)
;; optimize all the rhss and bodies
#:with opt (quasisyntax/loc/origin this-syntax #'op
(letrec-syntaxes+values
stx-bindings
(opt-clauses ...)
#,@(stx-map (optimize) #'(e-body ...)))))
(pattern (kw:identifier expr ...)
#:when
(for/or ([k (in-list (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
#'#%variable-reference #'with-continuation-mark))])
(free-identifier=? k #'kw))
;; we don't want to optimize in the cases that don't match the #:when clause
stx-bindings
([(ids ...) e-rhs.opt] ...)
e-body.opt ...)))
(pattern ((~and kw (~or if begin begin0 set! #%plain-app #%expression
#%variable-reference with-continuation-mark))
e:opt-expr ...)
#:with opt (quasisyntax/loc/origin this-syntax #'kw
(kw #,@(stx-map (optimize) #'(expr ...)))))
(pattern other:expr
#:with opt #'other))
(kw e.opt ...)))
(pattern (~and ((~or #%provide %require begin-for-syntax module module*) . _) opt))
(pattern (~and (~or (quote _) (quote-syntax _) :id) opt)))
(define (optimize-top stx)
(parameterize ([optimize (syntax-parser [e:opt-expr #'e.opt])])
(parameterize ([optimize (syntax-parser [e:opt-expr* #'e.opt])])
(let ((result ((optimize) stx)))
(when *show-optimized-code*
(pretty-print (syntax->datum result)))

2
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt
View File

@ -93,7 +93,7 @@
[(ex-id ...) exids]
[(ex-cnt ...) ex-cnts]
[(region-cnt ...) region-cnts]
[body (maybe-optimize expanded-body)]
[(body) (maybe-optimize #`(#,expanded-body))]
[check-syntax-help (syntax-property
(syntax-property
#'(void)