From 28b07e7a4518a43e390d815a2709123cfa7ca3b6 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Thu, 5 Sep 2013 08:25:05 -0700 Subject: [PATCH] Cleanup optimizer code. --- .../typed-racket/optimizer/optimizer.rkt | 120 ++++++++---------- .../typed-racket/private/with-types.rkt | 2 +- 2 files changed, 53 insertions(+), 69 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/optimizer.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/optimizer.rkt index 9d01965f59..b1a3c93e98 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/optimizer.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/optimizer.rkt @@ -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))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt index 62407ee938..248e7071cf 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt @@ -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)