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

Cleanup unboxed-let optimizations.

Browse Source
This commit is contained in:
Eric Dobson 2013-09-04 22:45:45 -07:00
parent 2ddcfbc1e4
commit fc5369ecea
3 changed files with 122 additions and 146 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/float-complex.rkt
View File

@ -647,6 +647,7 @@
;; to benefit from local information ;; to benefit from local information
(define-syntax-class (float-complex-call-site-opt-expr unboxed-info opt-operator) (define-syntax-class (float-complex-call-site-opt-expr unboxed-info opt-operator)
#:commit #:commit
#:attributes (opt)
;; call site of a function with unboxed parameters ;; call site of a function with unboxed parameters
;; the calling convention is: real parts of unboxed, imag parts, boxed ;; the calling convention is: real parts of unboxed, imag parts, boxed
(pattern (#%plain-app op:expr args:expr ...) (pattern (#%plain-app op:expr args:expr ...)

244
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/unboxed-let.rkt
View File

@ -15,10 +15,9 @@
;; loop variables ;; loop variables
(define-syntax-class unboxed-let-opt-expr (define-syntax-class unboxed-let-opt-expr
#:commit #:commit
(pattern e:app-of-unboxed-let-opt-expr #:attributes (opt)
#:with opt #'e.opt) (pattern :app-of-unboxed-let-opt-expr)
(pattern (~var e (unboxed-let-opt-expr-internal #f)) (pattern (~var || (unboxed-let-opt-expr-internal #f))))
#:with opt #'e.opt))
;; let loops expand to an application of a letrec-values ;; let loops expand to an application of a letrec-values
;; thus, the loop function technically escapes from the letrec, but it ;; thus, the loop function technically escapes from the letrec, but it
@ -27,22 +26,17 @@
(define-syntax-class app-of-unboxed-let-opt-expr (define-syntax-class app-of-unboxed-let-opt-expr
#:commit #:commit
#:literal-sets (kernel-literals) #:literal-sets (kernel-literals)
#:attributes (opt)
(pattern (#%plain-app (pattern (#%plain-app
(~and let-e ((~literal letrec-values) (~and let-e (letrec-values
bindings bindings
loop-fun:id)) ; sole element of the body loop-fun:id)) ; sole element of the body
args:expr ...) args:expr ...)
#:with (~var operator (unboxed-let-opt-expr-internal #t)) #'let-e #:with (~var operator (unboxed-let-opt-expr-internal #t)) #'let-e
#:with unboxed-info (dict-ref unboxed-funs-table #'loop-fun #f) #:with unboxed-info (dict-ref unboxed-funs-table #'loop-fun #f)
#:when (syntax->datum #'unboxed-info) #:when (syntax->datum #'unboxed-info)
#:with (~var e* (float-complex-call-site-opt-expr #:do [(log-optimization "unboxed let loop" arity-raising-opt-msg #'loop-fun)]
#'unboxed-info #'operator.opt)) #:with (~var || (float-complex-call-site-opt-expr #'unboxed-info #'operator.opt)) this-syntax))
this-syntax
#:with opt
(begin (log-optimization "unboxed let loop"
arity-raising-opt-msg
#'loop-fun)
#'e*.opt)))
;; does the bulk of the work ;; does the bulk of the work
;; detects which let bindings can be unboxed, same for arguments of let-bound ;; detects which let bindings can be unboxed, same for arguments of let-bound
@ -50,9 +44,10 @@
(define-syntax-class (unboxed-let-opt-expr-internal let-loop?) (define-syntax-class (unboxed-let-opt-expr-internal let-loop?)
#:commit #:commit
#:literal-sets (kernel-literals) #:literal-sets (kernel-literals)
#:attributes (opt)
(pattern (pattern
(letk:let-like-keyword ((~and clause (lhs rhs ...)) ...) (letk:let-like-keyword ((~and clause (lhs rhs ...)) ...)
body:expr ...) body:opt-expr ...)
;; we look for bindings of complexes that are not mutated and only ;; we look for bindings of complexes that are not mutated and only
;; used in positions where we would unbox them ;; used in positions where we would unbox them
;; these are candidates for unboxing ;; these are candidates for unboxing
@ -90,7 +85,8 @@
;; at least 1 argument has to be of type float-complex ;; at least 1 argument has to be of type float-complex
;; and can be unboxed ;; and can be unboxed
(syntax-parse (cadr p) (syntax-parse (cadr p)
[((~literal #%plain-lambda) params body ...) #:literal-sets (kernel-literals)
[(#%plain-lambda params body ...)
;; keep track of the param # of each param that can be ;; keep track of the param # of each param that can be
;; unboxed ;; unboxed
(let loop ((unboxed '()) (let loop ((unboxed '())
@ -126,46 +122,43 @@
#:with (opt-candidates:unboxed-let-clause ...) #'(candidates ...) #:with (opt-candidates:unboxed-let-clause ...) #'(candidates ...)
#:with (opt-functions:unboxed-fun-clause ...) #'(function-candidates ...) #:with (opt-functions:unboxed-fun-clause ...) #'(function-candidates ...)
#:with (opt-others:opt-let-clause ...) #'(others ...) #:with (opt-others:opt-let-clause ...) #'(others ...)
#:with opt #:do [(unless (zero? (syntax-length #'(opt-candidates.id ...)))
(begin (unless (zero? (syntax-length #'(opt-candidates.id ...))) ;; only log when we actually optimize
;; only log when we actually optimize (log-opt "unboxed let bindings" arity-raising-opt-msg))
(log-optimization "unboxed let bindings" ;; add the unboxed bindings to the table, for them to be used by
arity-raising-opt-msg ;; further optimizations
this-syntax)) (for ((v (in-syntax #'(opt-candidates.id ...)))
;; add the unboxed bindings to the table, for them to be used by (r (in-syntax #'(opt-candidates.real-binding ...)))
;; further optimizations (i (in-syntax #'(opt-candidates.imag-binding ...))))
(for ((v (in-syntax #'(opt-candidates.id ...))) (dict-set! unboxed-vars-table v (list r i v)))]
(r (in-syntax #'(opt-candidates.real-binding ...))) ;; in the case where no bindings are unboxed, we create a let
(i (in-syntax #'(opt-candidates.imag-binding ...)))) ;; that is equivalent to the original, but with all parts optimized
(dict-set! unboxed-vars-table v (list r i v))) #:with opt (quasisyntax/loc/origin
;; in the case where no bindings are unboxed, we create a let this-syntax #'letk.kw
;; that is equivalent to the original, but with all parts (letk.key ...
;; optimized (opt-functions.res ...
(quasisyntax/loc/origin opt-others.res ...
this-syntax #'letk.kw opt-candidates.bindings ... ...)
(letk.key ... body.opt ...))))
(opt-functions.res ...
opt-others.res ...
opt-candidates.bindings ... ...)
#,@(stx-map (optimize) #'(body ...)))))))
(define-splicing-syntax-class let-like-keyword (define-splicing-syntax-class let-like-keyword
#:commit #:commit
#:literal-sets (kernel-literals) #:literal-sets (kernel-literals)
#:attributes ([key 1] kw) #:attributes ([key 1] kw)
(pattern (~and kw (~literal let-values)) (pattern (~and kw let-values)
;; we need let*-values because we bind intermediate unboxed results, ;; we need let*-values because we bind intermediate unboxed results,
;; and the bindings for the final results refer to them ;; and the bindings for the final results refer to them
#:with (key ...) #'(let*-values)) #:with (key ...) #'(let*-values))
(pattern (~and kw (~literal letrec-values)) (pattern (~and kw letrec-values)
#:with (key ...) #'(kw)) #:with (key ...) #'(kw))
(pattern (~seq (~and kw (~literal letrec-syntaxes+values)) stx-bindings) (pattern (~seq (~and kw letrec-syntaxes+values) stx-bindings)
#:with (key ...) #'(kw stx-bindings))) #:with (key ...) #'(kw stx-bindings)))
(define (direct-child-of? v exp) (define (direct-child-of? v exp)
(ormap (lambda (x) (and (identifier? x) (free-identifier=? x v))) (for/or ((x (in-syntax exp)))
(syntax->list exp))) (and (identifier? x)
(free-identifier=? x v))))
;; if a variable is used at least once in complex arithmetic operations, ;; if a variable is used at least once in complex arithmetic operations,
;; it's worth unboxing ;; it's worth unboxing
@ -179,8 +172,6 @@
(define (rec exp) (define (rec exp)
(syntax-parse exp (syntax-parse exp
#:literal-sets (kernel-literals)
;; can be used in a complex arithmetic expr, can be a direct child ;; can be used in a complex arithmetic expr, can be a direct child
[exp:float-complex-arith-opt-expr [exp:float-complex-arith-opt-expr
#:when (not (identifier? #'exp)) #:when (not (identifier? #'exp))
@ -189,36 +180,22 @@
;; if the variable gets rebound to something else, we look for unboxing ;; if the variable gets rebound to something else, we look for unboxing
;; opportunities for the new variable too ;; opportunities for the new variable too
;; this case happens in the expansion of the for macros, so we care ;; this case happens in the expansion of the for macros, so we care
[(l:let-like-keyword [(l:let-like-keyword ([ids e-rhs:expr] ...) e-body:expr ...)
([ids e-rhs:expr] ...) e-body:expr ...) (define rebindings
#:with rebindings (filter (lambda (x) x)
(filter (lambda (x) x) (stx-map (syntax-parser
(stx-map (syntax-parser [((id) rhs:identifier)
[((id) rhs) #:when (free-identifier=? v #'rhs)
#:when (and (identifier? #'rhs) #'id]
(free-identifier=? v #'rhs)) [_ #f])
#'id] #'((ids e-rhs) ...))))
[_ #f])
#'((ids e-rhs) ...)))
(or (look-at #'(e-rhs ... e-body ...)) (or (look-at #'(e-rhs ... e-body ...))
(ormap (lambda (x) (could-be-unboxed-in? x exp)) (for/or ((x (in-list rebindings)))
(syntax->list #'rebindings)))] (could-be-unboxed-in? x exp)))]
;; recur down ;; recur down
[((~and op (~or (~literal #%plain-lambda) (~literal define-values))) [e:kernel-expression
formals e:expr ...) (look-at #'(e.sub-exprs ...))]))
(look-at #'(e ...))]
[(case-lambda [formals e:expr ...] ...)
(look-at #'(e ... ...))]
[(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))
(look-at #'(expr ...))]
;; not used, not worth unboxing
[_ #f]))
;; of course, if the var is mutated, we can't do anything ;; of course, if the var is mutated, we can't do anything
(and (not (is-var-mutated? v)) (and (not (is-var-mutated? v))
@ -240,32 +217,12 @@
(syntax-parse exp (syntax-parse exp
#:literal-sets (kernel-literals) #:literal-sets (kernel-literals)
[((~or (~literal #%plain-app) (~literal #%app)) [(#%plain-app rator:expr rands:expr ...)
rator:expr rands:expr ...)
(or (direct-child-of? v #'(rands ...)) ; used as an argument, escapes (or (direct-child-of? v #'(rands ...)) ; used as an argument, escapes
(ormap rec (syntax->list #'(rator rands ...))))] (ormap rec (syntax->list #'(rator rands ...))))]
[e:kernel-expression
(look-at #'(e.sub-exprs ...))]))
[((~and op (~or (~literal #%plain-lambda) (~literal define-values)))
formals e:expr ...)
(look-at #'(e ...))]
[(case-lambda [formals e:expr ...] ...)
(look-at #'(e ... ...))]
[((~or (~literal let-values) (~literal letrec-values))
([ids e-rhs:expr] ...) e-body:expr ...)
(look-at #'(e-rhs ... e-body ...))]
[(letrec-syntaxes+values stx-bindings
([(ids ...) e-rhs:expr] ...)
e-body:expr ...)
(look-at #'(e-rhs ... e-body ...))]
[(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))
(look-at #'(expr ...))]
;; does not escape
[_ #f]))
;; if the given var is the _only_ element of the body and we're in a ;; if the given var is the _only_ element of the body and we're in a
;; let loop, we let it slide ;; let loop, we let it slide
@ -281,11 +238,8 @@
;; let clause whose rhs is going to be unboxed (turned into multiple bindings) ;; let clause whose rhs is going to be unboxed (turned into multiple bindings)
(define-syntax-class unboxed-let-clause (define-syntax-class unboxed-let-clause
#:commit #:commit
(pattern ((v:id) rhs:unboxed-float-complex-opt-expr) #:attributes (id real-binding imag-binding (bindings 1))
#:with id #'v (pattern ((id:id) :unboxed-float-complex-opt-expr)))
#:with real-binding #'rhs.real-binding
#:with imag-binding #'rhs.imag-binding
#:with (bindings ...) #'(rhs.bindings ...)))
;; let clause whose rhs is a function with some float complex arguments ;; let clause whose rhs is a function with some float complex arguments
;; these arguments may be unboxed ;; these arguments may be unboxed
@ -293,50 +247,48 @@
;; boxed ;; boxed
(define-syntax-class unboxed-fun-clause (define-syntax-class unboxed-fun-clause
#:commit #:commit
(pattern ((v:id) (#%plain-lambda params body:expr ...)) #:attributes (res)
#:with id #'v (pattern ((id:id) (#%plain-lambda params body:opt-expr ...))
#:with unboxed-info (dict-ref unboxed-funs-table #'v #f) #:with unboxed-info (dict-ref unboxed-funs-table #'id #f)
#:when (syntax->datum #'unboxed-info) #:when (syntax->datum #'unboxed-info)
;; partition of the arguments ;; partition of the arguments
#:with ((to-unbox ...) (boxed ...)) #'unboxed-info #:with ((to-unbox ...) (boxed ...)) #'unboxed-info
#:with (real-params ...) #:with (real-params ...)
(stx-map (lambda (x) (generate-temporary "unboxed-real-")) #'(to-unbox ...)) (stx-map (lambda (x) (generate-temporary "unboxed-real-")) #'(to-unbox ...))
#:with (imag-params ...) #:with (imag-params ...)
(stx-map (lambda (x) (generate-temporary "unboxed-imag-")) #'(to-unbox ...)) (stx-map (lambda (x) (generate-temporary "unboxed-imag-")) #'(to-unbox ...))
#:with res #:do [(log-optimization "fun -> unboxed fun" arity-raising-opt-msg #'id)]
(begin #:with res
(log-optimization "fun -> unboxed fun" arity-raising-opt-msg #'v) ;; add unboxed parameters to the unboxed vars table
;; add unboxed parameters to the unboxed vars table (let ((to-unbox (syntax->datum #'(to-unbox ...))))
(let ((to-unbox (syntax->datum #'(to-unbox ...)))) (let loop ((params (syntax->list #'params))
(let loop ((params (syntax->list #'params)) (i 0)
(i 0) (real-parts (syntax->list #'(real-params ...)))
(real-parts (syntax->list #'(real-params ...))) (imag-parts (syntax->list #'(imag-params ...)))
(imag-parts (syntax->list #'(imag-params ...))) (boxed '()))
(boxed '())) (cond [(null? params) ; done, create the new clause
(cond [(null? params) ; done, create the new clause ;; real parts of unboxed parameters go first, then all
;; real parts of unboxed parameters go first, then all ;; imag parts, then boxed occurrences of unboxed
;; imag parts, then boxed occurrences of unboxed ;; parameters will be inserted when optimizing the body
;; parameters will be inserted when optimizing the body #`((id) (#%plain-lambda
#`((v) (#%plain-lambda (real-params ... imag-params ... #,@(reverse boxed))
(real-params ... imag-params ... body.opt ...))]
#,@(reverse boxed)) [(memq i to-unbox)
#,@(stx-map (optimize) #'(body ...))))] ;; we unbox the current param, add to the table
(dict-set! unboxed-vars-table (car params)
[(memq i to-unbox) (list (car real-parts)
;; we unbox the current param, add to the table (car imag-parts)
(dict-set! unboxed-vars-table (car params) (car params)))
(list (car real-parts) (loop (cdr params) (add1 i)
(car imag-parts) (cdr real-parts) (cdr imag-parts)
(car params))) boxed)]
(loop (cdr params) (add1 i) [else ; that param stays boxed, keep going
(cdr real-parts) (cdr imag-parts) (loop (cdr params) (add1 i)
boxed)] real-parts imag-parts
[else ; that param stays boxed, keep going (cons (car params) boxed))])))))
(loop (cdr params) (add1 i)
real-parts imag-parts
(cons (car params) boxed))]))))))
(define-syntax-class opt-let-clause (define-syntax-class opt-let-clause
#:commit #:commit
(pattern (vs rhs:expr) #:attributes (res)
#:with res #`(vs #,((optimize) #'rhs)))) (pattern (vs rhs:opt-expr)
#:with res #'(vs rhs.opt)))

23
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt
View File

@ -18,6 +18,7 @@
n-ary->binary n-ary-comp->binary n-ary->binary n-ary-comp->binary
opt-expr optimize opt-expr optimize
value-expr typed-expr subtyped-expr value-expr typed-expr subtyped-expr
kernel-expression
define-unsafe-syntax-class define-unsafe-syntax-class
define-literal-syntax-class define-literal-syntax-class
define-merged-syntax-class define-merged-syntax-class
@ -143,3 +144,25 @@
#:attr val (match (type-of #'e) #:attr val (match (type-of #'e)
[(tc-result1: (Value: v)) v] [(tc-result1: (Value: v)) v]
[_ #f]))) [_ #f])))
(define-syntax-class kernel-expression
#:commit
#:literal-sets (kernel-literals)
#:attributes [(sub-exprs 1)]
[pattern (begin sub-exprs:expr ...)]
[pattern ((~or begin0 #%plain-app) sub-exprs:expr ...+)]
[pattern (#%plain-lambda formals sub-exprs:expr ...)]
[pattern ((~or if with-continuation-mark) e1:expr e2:expr e3:expr)
#:with (sub-exprs ...) #'(e1 e2 e3)]
[pattern (~or (#%top . _) (#%variable-reference . _) (quote _) (quote-syntax _) :id)
#:with (sub-exprs ...) #'()]
[pattern (case-lambda [formals e*:expr ...] ...)
#:with (sub-exprs ...) #'(e* ... ...)]
[pattern ((~or let-values letrec-values) ([ids e-rhs:expr] ...) e-body:expr ...)
#:with (sub-exprs ...) #'(e-rhs ... e-body ...)]
[pattern (letrec-syntaxes+values stx-bindings ([(ids ...) e-rhs:expr] ...) e-body:expr ...)
#:with (sub-exprs ...) #'(e-rhs ... e-body ...)]
[pattern (#%expression e:expr)
#:with (sub-exprs ...) #'(e)]
[pattern (set! _ e:expr)
#:with (sub-exprs ...) #'(e)])