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

258
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,105 +51,111 @@
(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
body:expr ...) (letk:let-like-keyword ((~and clause (lhs rhs ...)) ...)
;; we look for bindings of complexes that are not mutated and only body:expr ...)
;; used in positions where we would unbox them ;; we look for bindings of complexes that are not mutated and only
;; these are candidates for unboxing ;; used in positions where we would unbox them
#:with ((candidates ...) (function-candidates ...) (others ...)) ;; these are candidates for unboxing
(let*-values #:with ((candidates ...) (function-candidates ...) (others ...))
(((candidates rest) (let*-values
;; clauses of form ((v) rhs), currently only supports 1 lhs var (((candidates rest)
(partition ;; clauses of form ((v) rhs), currently only supports 1 lhs var
(lambda (p) (partition
(and (subtypeof? (cadr p) -FloatComplex) (lambda (p)
(could-be-unboxed-in? (car (syntax-e (car p))) (and (subtypeof? (cadr p) -FloatComplex)
#'(begin body ...)))) (could-be-unboxed-in? (car (syntax-e (car p)))
(syntax-map syntax->list #'(clause ...)))) #'(begin body ...))))
((function-candidates others) (syntax-map syntax->list #'(clause ...))))
;; extract function bindings that have float-complex arguments ((function-candidates others)
;; we may be able to pass arguments unboxed ;; extract function bindings that have float-complex arguments
;; this covers loop variables ;; we may be able to pass arguments unboxed
(partition ;; this covers loop variables
(lambda (p) (partition
(and (lambda (p)
;; typed racket introduces let-values that bind no values (and
;; we can't optimize these ;; typed racket introduces let-values that bind no values
(not (null? (syntax-e (car p)))) ;; we can't optimize these
(let ((fun-name (car (syntax-e (car p))))) (not (null? (syntax-e (car p))))
(and (let ((fun-name (car (syntax-e (car p)))))
;; if the function escapes, we can't change its interface (and
(not (is-var-mutated? fun-name)) ;; if the function escapes, we can't change its interface
(not (escapes? fun-name #'(begin rhs ... ...) #f)) (not (is-var-mutated? fun-name))
(not (escapes? fun-name #'(begin body ...) let-loop?)) (not (escapes? fun-name #'(begin rhs ... ...) #f))
(match (type-of (cadr p)) ; rhs, we want a lambda (not (escapes? fun-name #'(begin body ...) let-loop?))
[(tc-result1: (Function: (list (arr: doms rngs (match (type-of (cadr p)) ; rhs, we want a lambda
(and rests #f) [(tc-result1: (Function: (list (arr: doms rngs
(and drests #f) (and rests #f)
(and kws '()))))) (and drests #f)
;; at least 1 argument has to be of type float-complex (and kws '())))))
;; and can be unboxed ;; at least 1 argument has to be of type float-complex
(syntax-parse (cadr p) ;; and can be unboxed
[((~literal #%plain-lambda) params body ...) (syntax-parse (cadr p)
;; keep track of the param # of each param that can be unboxed [((~literal #%plain-lambda) params body ...)
(let loop ((unboxed '()) ;; keep track of the param # of each param that can be
(boxed '()) ;; unboxed
(i 0) (let loop ((unboxed '())
(params (syntax->list #'params)) (boxed '())
(doms doms)) (i 0)
(cond [(null? params) (params (syntax->list #'params))
;; done. can we unbox anything? (doms doms))
(when (> (length unboxed) 0) (cond [(null? params)
;; if so, add to the table of functions with ;; done. can we unbox anything?
;; unboxed params, so we can modify its call (when (> (length unboxed) 0)
;; sites, its body and its header) ;; if so, add to the table of functions with
(log-optimization ;; unboxed params, so we can modify its call
"unboxed function -> table" ;; sites, its body and its header)
arity-raising-opt-msg (log-optimization
fun-name) "unboxed function -> table"
(dict-set! unboxed-funs-table fun-name arity-raising-opt-msg
(list (reverse unboxed) fun-name)
(reverse boxed))))] (dict-set! unboxed-funs-table fun-name
[(and (equal? (car doms) -FloatComplex) (list (reverse unboxed)
(could-be-unboxed-in? (reverse boxed))))]
(car params) #'(begin body ...))) [(and (equal? (car doms) -FloatComplex)
;; we can unbox (could-be-unboxed-in?
(log-optimization "unboxed var -> table" (car params) #'(begin body ...)))
arity-raising-opt-msg ;; we can unbox
(car params)) (log-optimization "unboxed var -> table"
(loop (cons i unboxed) boxed arity-raising-opt-msg
(add1 i) (cdr params) (cdr doms))] (car params))
[else ; can't unbox (loop (cons i unboxed) boxed
(loop unboxed (cons i boxed) (add1 i) (cdr params) (cdr doms))]
(add1 i) (cdr params) (cdr doms))]))] [else ; can't unbox
[_ #f])] (loop unboxed (cons i boxed)
[_ #f]))))) (add1 i) (cdr params) (cdr doms))]))]
rest))) [_ #f])]
(list candidates function-candidates others)) [_ #f])))))
#:with (opt-candidates:unboxed-let-clause ...) #'(candidates ...) rest)))
#:with (opt-functions:unboxed-fun-clause ...) #'(function-candidates ...) (list candidates function-candidates others))
#:with (opt-others:opt-let-clause ...) #'(others ...) #:with (opt-candidates:unboxed-let-clause ...) #'(candidates ...)
#:with opt #:with (opt-functions:unboxed-fun-clause ...) #'(function-candidates ...)
(begin (when (not (null? (syntax->list #'(opt-candidates.id ...)))) #:with (opt-others:opt-let-clause ...) #'(others ...)
;; only log when we actually optimize #:with opt
(log-optimization "unboxed let bindings" (begin (when (not (null? (syntax->list #'(opt-candidates.id ...))))
arity-raising-opt-msg ;; only log when we actually optimize
this-syntax)) (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-list (syntax->list #'(opt-candidates.id ...)))) ;; add the unboxed bindings to the table, for them to be used by
(r (in-list (syntax->list #'(opt-candidates.real-binding ...)))) ;; further optimizations
(i (in-list (syntax->list #'(opt-candidates.imag-binding ...))))) (for ((v (in-list (syntax->list
(dict-set! unboxed-vars-table v (list r i v))) #'(opt-candidates.id ...))))
;; in the case where no bindings are unboxed, we create a let (r (in-list (syntax->list
;; that is equivalent to the original, but with all parts #'(opt-candidates.real-binding ...))))
;; optimized (i (in-list (syntax->list
(quasisyntax/loc/origin this-syntax #'letk.kw #'(opt-candidates.imag-binding ...)))))
(letk.key ... (dict-set! unboxed-vars-table v (list r i v)))
(opt-candidates.bindings ... ... ;; in the case where no bindings are unboxed, we create a let
opt-functions.res ... ;; that is equivalent to the original, but with all parts
opt-others.res ...) ;; optimized
#,@(syntax-map (optimize) #'(body ...))))))) (quasisyntax/loc/origin
this-syntax #'letk.kw
(letk.key ...
(opt-candidates.bindings ... ...
opt-functions.res ...
opt-others.res ...)
#,@(syntax-map (optimize) #'(body ...)))))))
(define-splicing-syntax-class let-like-keyword (define-splicing-syntax-class let-like-keyword
#:commit #:commit
@ -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,10 +307,12 @@
#: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 ...)
#'(to-unbox ...)) (syntax-map (lambda (x) (unboxed-gensym "unboxed-real-"))
#:with (imag-params ...) (syntax-map (lambda (x) (unboxed-gensym "unboxed-imag-")) #'(to-unbox ...))
#'(to-unbox ...)) #:with (imag-params ...)
(syntax-map (lambda (x) (unboxed-gensym "unboxed-imag-"))
#'(to-unbox ...))
#:with res #:with res
(begin (begin
(log-optimization "fun -> unboxed fun" arity-raising-opt-msg #'v) (log-optimization "fun -> unboxed fun" arity-raising-opt-msg #'v)
@ -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)]