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))))