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

Formatting.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-08-14 16:31:22 -04:00
parent becaac8c18
commit 63b5747018
1 changed files with 137 additions and 121 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
collects/typed-scheme/optimizer/unboxed-let.rkt
View File

@ -11,8 +11,9 @@
(provide unboxed-let-opt-expr)
;; possibly replace bindings of complex numbers by bindings of their 2 components
;; useful for intermediate results used more than once and for loop variables
;; possibly replace bindings of complex numbers by bindings of their 2
;; components useful for intermediate results used more than once and for
;; loop variables
(define-syntax-class unboxed-let-opt-expr
#:commit
(pattern e:app-of-unboxed-let-opt-expr
@ -50,7 +51,8 @@
(define-syntax-class (unboxed-let-opt-expr-internal let-loop?)
#:commit
#:literal-sets (kernel-literals)
(pattern (letk:let-like-keyword ((~and clause (lhs rhs ...)) ...)
(pattern
(letk:let-like-keyword ((~and clause (lhs rhs ...)) ...)
body:expr ...)
;; we look for bindings of complexes that are not mutated and only
;; used in positions where we would unbox them
@ -90,7 +92,8 @@
;; and can be unboxed
(syntax-parse (cadr p)
[((~literal #%plain-lambda) params body ...)
;; keep track of the param # of each param that can be unboxed
;; keep track of the param # of each param that can be
;; unboxed
(let loop ((unboxed '())
(boxed '())
(i 0)
@ -136,14 +139,18 @@
this-syntax))
;; add the unboxed bindings to the table, for them to be used by
;; further optimizations
(for ((v (in-list (syntax->list #'(opt-candidates.id ...))))
(r (in-list (syntax->list #'(opt-candidates.real-binding ...))))
(i (in-list (syntax->list #'(opt-candidates.imag-binding ...)))))
(for ((v (in-list (syntax->list
#'(opt-candidates.id ...))))
(r (in-list (syntax->list
#'(opt-candidates.real-binding ...))))
(i (in-list (syntax->list
#'(opt-candidates.imag-binding ...)))))
(dict-set! unboxed-vars-table v (list r i v)))
;; in the case where no bindings are unboxed, we create a let
;; that is equivalent to the original, but with all parts
;; optimized
(quasisyntax/loc/origin this-syntax #'letk.kw
(quasisyntax/loc/origin
this-syntax #'letk.kw
(letk.key ...
(opt-candidates.bindings ... ...
opt-functions.res ...
@ -213,8 +220,9 @@
(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))
(list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app
#'#%expression #'#%variable-reference
#'with-continuation-mark))
(look-at #'(expr ...))]
;; not used, not worth unboxing
@ -224,12 +232,12 @@
(and (not (is-var-mutated? v))
(rec exp)))
;; very simple escape analysis for functions
;; if a function is ever used in a non-operator position, we consider it escapes
;; if it doesn't escape, we may be able to pass its float complex args unboxed
;; if we are in a let loop, don't consider functions that escape by being the
;; Very simple escape analysis for functions.
;; If a function is used in a non-operator position, we consider it escapes.
;; If it doesn't escape, we may be able to pass its float complex args unboxed.
;; If we are in a let loop, don't consider functions that escape by being the
;; sole thing in the let's body as escaping, since they would only escape to
;; a call site that we control, which is fine
;; a call site that we control, which is fine.
(define (escapes? v exp let-loop?)
(define (look-at exp)
@ -259,8 +267,9 @@
(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))
(list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app
#'#%expression #'#%variable-reference
#'with-continuation-mark))
(look-at #'(expr ...))]
;; does not escape
@ -288,7 +297,8 @@
;; let clause whose rhs is a function with some float complex arguments
;; these arguments may be unboxed
;; the new function will have all the unboxed arguments first, then all the boxed
;; the new function will have all the unboxed arguments first, then all the
;; boxed
(define-syntax-class unboxed-fun-clause
#:commit
(pattern ((v:id) (#%plain-lambda params body:expr ...))
@ -297,9 +307,11 @@
#:when (syntax->datum #'unboxed-info)
;; partition of the arguments
#:with ((to-unbox ...) (boxed ...)) #'unboxed-info
#:with (real-params ...) (syntax-map (lambda (x) (unboxed-gensym "unboxed-real-"))
#:with (real-params ...)
(syntax-map (lambda (x) (unboxed-gensym "unboxed-real-"))
#'(to-unbox ...))
#:with (imag-params ...) (syntax-map (lambda (x) (unboxed-gensym "unboxed-imag-"))
#:with (imag-params ...)
(syntax-map (lambda (x) (unboxed-gensym "unboxed-imag-"))
#'(to-unbox ...))
#:with res
(begin
@ -312,16 +324,20 @@
(imag-parts (syntax->list #'(imag-params ...)))
(boxed '()))
(cond [(null? params) ; done, create the new clause
;; real parts of unboxed parameters go first, then all imag
;; parts, then boxed occurrences of unboxed parameters will
;; be inserted when optimizing the body
;; real parts of unboxed parameters go first, then all
;; imag parts, then boxed occurrences of unboxed
;; parameters will be inserted when optimizing the body
#`((v) (#%plain-lambda
(real-params ... imag-params ... #,@(reverse boxed))
(real-params ... imag-params ...
#,@(reverse boxed))
#,@(syntax-map (optimize) #'(body ...))))]
[(memq i to-unbox) ; we unbox the current param, add to the table
[(memq i to-unbox)
;; we unbox the current param, add to the table
(dict-set! unboxed-vars-table (car params)
(list (car real-parts) (car imag-parts) (car params)))
(list (car real-parts)
(car imag-parts)
(car params)))
(loop (cdr params) (add1 i)
(cdr real-parts) (cdr imag-parts)
boxed)]