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

let bindings of inexact-complex numbers can be replaced by bindings

Browse Source 
for each of their components.

This allows unboxing of intermediate results that are bound and only
ever used in positions where they would be unboxed.

original commit: 83987fffac7719ab0c35d3df49ea0a7adf4bc9b6
This commit is contained in:
Vincent St-Amour 2010-07-23 16:35:25 -04:00
parent fe68e29caa
commit eb60ac080a
6 changed files with 149 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/tests/typed-scheme/optimizer/generic/invalid-unboxed-let.rkt Normal file
View File

@ -0,0 +1,12 @@
#lang typed/scheme #:optimize
(require racket/unsafe/ops)
(let ((t1 (+ 1.0+2.0i 2.0+4.0i)) ; can be unboxed
(t2 (+ 3.0+6.0i 4.0+8.0i)) ; can't be unboxed
(t3 1.0+2.0i) ; can't be unboxed
(t4 1))
(display (+ t1 t1))
(display t2)
(display t3)
(display t4))

7
collects/tests/typed-scheme/optimizer/generic/invalid-unboxed-let2.rkt Normal file
View File

@ -0,0 +1,7 @@
#lang typed/scheme #:optimize
(require racket/unsafe/ops)
;; unboxing of let bindings does not currently work with multiple values
(let-values (((t1 t2) (values (+ 1.0+2.0i 2.0+4.0i) (+ 3.0+6.0i 4.0+8.0i))))
(+ t1 t2))

8
collects/tests/typed-scheme/optimizer/generic/unboxed-let.rkt Normal file
View File

@ -0,0 +1,8 @@
#lang typed/scheme #:optimize
(require racket/unsafe/ops)
(let* ((t1 (+ 1.0+2.0i 2.0+4.0i))
(t2 (- t1 3.0+6.0i))
(t3 (- t1 4.0+8.0i)))
(+ t2 t3))

18
collects/typed-scheme/optimizer/inexact-complex.rkt
View File

@ -1,14 +1,19 @@
#lang scheme/base
(require syntax/parse
(require syntax/parse syntax/id-table scheme/dict
"../utils/utils.rkt"
(for-template scheme/base scheme/math scheme/flonum scheme/unsafe/ops)
(types abbrev type-table utils subtype)
(optimizer utils float fixnum))
(provide inexact-complex-opt-expr)
(provide inexact-complex-opt-expr inexact-complex-arith-opt-expr
unboxed-inexact-complex-opt-expr unboxed-vars-table)
;; contains the bindings which actually exist as separate bindings for each component
;; associates identifiers to lists (real-part imag-part)
(define unboxed-vars-table (make-free-id-table))
;; it's faster to take apart a complex number and use unsafe operations on
;; its parts than it is to use generic operations
;; we keep the real and imaginary parts unboxed as long as we stay within
@ -209,11 +214,10 @@
;; if we see a variable that's already unboxed, use the unboxed bindings
(pattern v:id
#:with unboxed-real-part (syntax-property #'v 'unboxed-real-part)
#:with unboxed-imag-part (syntax-property #'v 'unboxed-imag-part)
#:when (and (syntax-e #'unboxed-real-part) (syntax-e #'unboxed-imag-part))
#:with real-part #'unboxed-real-part
#:with imag-part #'unboxed-imag-part
#:with unboxed-info (dict-ref unboxed-vars-table #'v #f)
#:when (syntax->datum #'unboxed-info)
#:with real-part (car (syntax->list #'unboxed-info))
#:with imag-part (cadr (syntax->list #'unboxed-info))
#:with (bindings ...) #'())
;; else, do the unboxing here

18
collects/typed-scheme/optimizer/optimizer.rkt
View File

@ -8,7 +8,7 @@
"../utils/utils.rkt"
(types abbrev type-table utils subtype)
(optimizer utils number fixnum float inexact-complex vector string
pair sequence box struct dead-code apply))
pair sequence box struct dead-code apply unboxed-let))
(provide optimize-top)
@ -33,6 +33,7 @@
(pattern e:box-opt-expr #:with opt #'e.opt)
(pattern e:struct-opt-expr #:with opt #'e.opt)
(pattern e:dead-code-opt-expr #:with opt #'e.opt)
(pattern e:unboxed-let-opt-expr #:with opt #'e.opt)
;; boring cases, just recur down
(pattern ((~and op (~or (~literal #%plain-lambda) (~literal define-values)))
@ -40,12 +41,15 @@
#:with opt #'(op formals e.opt ...))
(pattern (case-lambda [formals e:opt-expr ...] ...)
#:with opt #'(case-lambda [formals e.opt ...] ...))
(pattern (let-values ([ids e-rhs:opt-expr] ...) e-body:opt-expr ...)
#:with opt #'(let-values ([ids e-rhs.opt] ...) e-body.opt ...))
(pattern (letrec-values ([ids e-rhs:opt-expr] ...) e-body:opt-expr ...)
#:with opt #'(letrec-values ([ids e-rhs.opt] ...) e-body.opt ...))
(pattern (letrec-syntaxes+values stx-bindings ([(ids ...) e-rhs:opt-expr] ...) e-body:opt-expr ...)
#:with opt #'(letrec-syntaxes+values stx-bindings ([(ids ...) e-rhs.opt] ...) e-body.opt ...))
(pattern ((~and op (~or (~literal let-values) (~literal letrec-values)))
([ids e-rhs:opt-expr] ...) e-body:opt-expr ...)
#:with opt #'(op ([ids e-rhs.opt] ...) e-body.opt ...))
(pattern (letrec-syntaxes+values stx-bindings
([(ids ...) e-rhs:opt-expr] ...)
e-body:opt-expr ...)
#:with opt #'(letrec-syntaxes+values stx-bindings
([(ids ...) e-rhs.opt] ...)
e-body.opt ...))
(pattern (kw:identifier expr ...)
#:when
(for/or ([k (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression

100
collects/typed-scheme/optimizer/unboxed-let.rkt Normal file
View File

@ -0,0 +1,100 @@
#lang scheme/base
(require syntax/parse
scheme/list scheme/dict
"../utils/utils.rkt"
"../utils/tc-utils.rkt"
(for-template scheme/base)
(types abbrev)
(optimizer utils inexact-complex))
(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
(define-syntax-class unboxed-let-opt-expr
#:literal-sets (kernel-literals)
(pattern (~and exp (let-values (clause:expr ...) body:expr ...))
;; we look for bindings of complexes that are not mutated and only
;; used in positions where we would unbox them
;; these are candidates for unboxing
#:with ((candidates ...) (others ...))
(let-values
(((candidates others)
;; clauses of form ((v) rhs), currently only suppose 1 lhs var
(partition (lambda (p)
(and (isoftype? (cadr p) -InexactComplex)
(let ((v (car (syntax-e (car p)))))
(not (is-var-mutated? v))
(could-be-unboxed-in? v #'(begin body ...)))))
(map syntax->list (syntax->list #'(clause ...))))))
(list candidates others))
#:with (opt-candidates:unboxed-let-clause ...) #'(candidates ...)
#:with (opt-others:let-clause ...) #'(others ...)
#:with opt
(begin (log-optimization "unboxed let bindings" #'exp)
;; 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-part ...))))
(i (in-list (syntax->list #'(opt-candidates.imag-part ...)))))
(dict-set! unboxed-vars-table v (list r i)))
#`(let* (opt-candidates.bindings ... ... opt-others.res ...)
#,@(map (optimize) (syntax->list #'(body ...)))))))
;; if a variable is only used in complex arithmetic operations, it's safe
;; to unbox it
(define (could-be-unboxed-in? v exp)
(define (direct-child-of? exp)
(ormap (lambda (x) (and (identifier? x) (free-identifier=? x v)))
(syntax->list exp)))
;; if v is a direct child of exp, that means it's used in a boxed
;; fashion, and is not safe to unboxed
;; if not, recur on the subforms
(define (look-at exp)
(and (not (direct-child-of? exp))
(andmap rec (syntax->list exp))))
(define (rec exp)
(syntax-parse exp
#:literal-sets (kernel-literals)
;; used within a complex arithmetic expression? safe to unbox
[exp:inexact-complex-arith-opt-expr
(direct-child-of? #'exp)]
;; recur down
[((~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 ...))]
;; not used, safe to unbox
[_ #t]))
(rec exp))
(define-syntax-class unboxed-let-clause
(pattern ((v:id) rhs:unboxed-inexact-complex-opt-expr)
#:with id #'v
#:with real-part #'rhs.real-part
#:with imag-part #'rhs.imag-part
#:with (bindings ...) #'(rhs.bindings ...)))
(define-syntax-class let-clause ; to turn let-values clauses into let clauses
(pattern ((v:id) rhs:expr)
#:with res #`(v #,((optimize) #'rhs))))