From eb60ac080abc9c25126dcacb9ec087927f8ebc12 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 23 Jul 2010 16:35:25 -0400 Subject: [PATCH] let bindings of inexact-complex numbers can be replaced by bindings 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 --- .../optimizer/generic/invalid-unboxed-let.rkt | 12 +++ .../generic/invalid-unboxed-let2.rkt | 7 ++ .../optimizer/generic/unboxed-let.rkt | 8 ++ .../optimizer/inexact-complex.rkt | 18 ++-- collects/typed-scheme/optimizer/optimizer.rkt | 18 ++-- .../typed-scheme/optimizer/unboxed-let.rkt | 100 ++++++++++++++++++ 6 files changed, 149 insertions(+), 14 deletions(-) create mode 100644 collects/tests/typed-scheme/optimizer/generic/invalid-unboxed-let.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/invalid-unboxed-let2.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/unboxed-let.rkt create mode 100644 collects/typed-scheme/optimizer/unboxed-let.rkt diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-unboxed-let.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-unboxed-let.rkt new file mode 100644 index 00000000..4039f652 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/invalid-unboxed-let.rkt @@ -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)) diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-unboxed-let2.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-unboxed-let2.rkt new file mode 100644 index 00000000..f41ef094 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/invalid-unboxed-let2.rkt @@ -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)) diff --git a/collects/tests/typed-scheme/optimizer/generic/unboxed-let.rkt b/collects/tests/typed-scheme/optimizer/generic/unboxed-let.rkt new file mode 100644 index 00000000..bbdf3f63 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/unboxed-let.rkt @@ -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)) diff --git a/collects/typed-scheme/optimizer/inexact-complex.rkt b/collects/typed-scheme/optimizer/inexact-complex.rkt index 2de39867..09586da6 100644 --- a/collects/typed-scheme/optimizer/inexact-complex.rkt +++ b/collects/typed-scheme/optimizer/inexact-complex.rkt @@ -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 diff --git a/collects/typed-scheme/optimizer/optimizer.rkt b/collects/typed-scheme/optimizer/optimizer.rkt index 5f6f6c49..d7ea4dff 100644 --- a/collects/typed-scheme/optimizer/optimizer.rkt +++ b/collects/typed-scheme/optimizer/optimizer.rkt @@ -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 diff --git a/collects/typed-scheme/optimizer/unboxed-let.rkt b/collects/typed-scheme/optimizer/unboxed-let.rkt new file mode 100644 index 00000000..40d11cdf --- /dev/null +++ b/collects/typed-scheme/optimizer/unboxed-let.rkt @@ -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))))