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) (provide unboxed-let-opt-expr)
;; possibly replace bindings of complex numbers by bindings of their 2 components ;; possibly replace bindings of complex numbers by bindings of their 2
;; useful for intermediate results used more than once and for loop variables ;; components useful for intermediate results used more than once and for
;; 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 (pattern e:app-of-unboxed-let-opt-expr
@ -50,7 +51,8 @@
(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)
(pattern (letk:let-like-keyword ((~and clause (lhs rhs ...)) ...) (pattern
(letk:let-like-keyword ((~and clause (lhs rhs ...)) ...)
body:expr ...) body: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
@ -90,7 +92,8 @@
;; and can be unboxed ;; and can be unboxed
(syntax-parse (cadr p) (syntax-parse (cadr p)
[((~literal #%plain-lambda) params body ...) [((~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 '()) (let loop ((unboxed '())
(boxed '()) (boxed '())
(i 0) (i 0)
@ -136,14 +139,18 @@
this-syntax)) this-syntax))
;; add the unboxed bindings to the table, for them to be used by ;; add the unboxed bindings to the table, for them to be used by
;; further optimizations ;; further optimizations
(for ((v (in-list (syntax->list #'(opt-candidates.id ...)))) (for ((v (in-list (syntax->list
(r (in-list (syntax->list #'(opt-candidates.real-binding ...)))) #'(opt-candidates.id ...))))
(i (in-list (syntax->list #'(opt-candidates.imag-binding ...))))) (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))) (dict-set! unboxed-vars-table v (list r i v)))
;; in the case where no bindings are unboxed, we create a let ;; in the case where no bindings are unboxed, we create a let
;; that is equivalent to the original, but with all parts ;; that is equivalent to the original, but with all parts
;; optimized ;; optimized
(quasisyntax/loc/origin this-syntax #'letk.kw (quasisyntax/loc/origin
this-syntax #'letk.kw
(letk.key ... (letk.key ...
(opt-candidates.bindings ... ... (opt-candidates.bindings ... ...
opt-functions.res ... opt-functions.res ...
@ -213,8 +220,9 @@
(look-at #'(e ... ...))] (look-at #'(e ... ...))]
[(kw:identifier expr ...) [(kw:identifier expr ...)
#:when (ormap (lambda (k) (free-identifier=? k #'kw)) #:when (ormap (lambda (k) (free-identifier=? k #'kw))
(list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app
#'#%variable-reference #'with-continuation-mark)) #'#%expression #'#%variable-reference
#'with-continuation-mark))
(look-at #'(expr ...))] (look-at #'(expr ...))]
;; not used, not worth unboxing ;; not used, not worth unboxing
@ -224,12 +232,12 @@
(and (not (is-var-mutated? v)) (and (not (is-var-mutated? v))
(rec exp))) (rec exp)))
;; very simple escape analysis for functions ;; Very simple escape analysis for functions.
;; if a function is ever used in a non-operator position, we consider it escapes ;; 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 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 ;; 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 ;; 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 (escapes? v exp let-loop?)
(define (look-at exp) (define (look-at exp)
@ -259,8 +267,9 @@
(look-at #'(e-rhs ... e-body ...))] (look-at #'(e-rhs ... e-body ...))]
[(kw:identifier expr ...) [(kw:identifier expr ...)
#:when (ormap (lambda (k) (free-identifier=? k #'kw)) #:when (ormap (lambda (k) (free-identifier=? k #'kw))
(list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app
#'#%variable-reference #'with-continuation-mark)) #'#%expression #'#%variable-reference
#'with-continuation-mark))
(look-at #'(expr ...))] (look-at #'(expr ...))]
;; does not escape ;; does not escape
@ -288,7 +297,8 @@
;; 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
;; 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 (define-syntax-class unboxed-fun-clause
#:commit #:commit
(pattern ((v:id) (#%plain-lambda params body:expr ...)) (pattern ((v:id) (#%plain-lambda params body:expr ...))
@ -297,9 +307,11 @@
#: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 ...) (syntax-map (lambda (x) (unboxed-gensym "unboxed-real-")) #:with (real-params ...)
(syntax-map (lambda (x) (unboxed-gensym "unboxed-real-"))
#'(to-unbox ...)) #'(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 ...)) #'(to-unbox ...))
#:with res #:with res
(begin (begin
@ -312,16 +324,20 @@
(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 imag ;; real parts of unboxed parameters go first, then all
;; parts, then boxed occurrences of unboxed parameters will ;; imag parts, then boxed occurrences of unboxed
;; be inserted when optimizing the body ;; parameters will be inserted when optimizing the body
#`((v) (#%plain-lambda #`((v) (#%plain-lambda
(real-params ... imag-params ... #,@(reverse boxed)) (real-params ... imag-params ...
#,@(reverse boxed))
#,@(syntax-map (optimize) #'(body ...))))] #,@(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) (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) (loop (cdr params) (add1 i)
(cdr real-parts) (cdr imag-parts) (cdr real-parts) (cdr imag-parts)
boxed)] boxed)]