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

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

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