diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/apply.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/apply.rkt index dff34e2f..a90dda30 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/apply.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/apply.rkt @@ -1,5 +1,5 @@ #lang racket/base -(require syntax/parse +(require syntax/parse racket/syntax (for-template racket/unsafe/ops racket/base (prefix-in k: '#%kernel)) "../utils/utils.rkt" (utils tc-utils) @@ -18,21 +18,19 @@ #:literals (k:apply map #%plain-app #%app) (pattern ((~and kw #%plain-app) (~and appl k:apply) op:apply-op ((~and kw2 #%plain-app) (~and m map) f l)) - #:with opt - (begin (reset-unboxed-gensym) - (with-syntax ([(f* lp v lst) (map unboxed-gensym '(f* loop v lst))] - [l ((optimize) #'l)] - [f ((optimize) #'f)]) - (log-optimization "apply-map" "apply-map deforestation." - this-syntax) - (add-disappeared-use #'appl) - (add-disappeared-use #'kw2) - (add-disappeared-use #'m) - (syntax/loc/origin - this-syntax #'kw - (let ([f* f]) - (let lp ([v op.identity] [lst l]) - (if (null? lst) - v - (lp (op v (f* (unsafe-car lst))) - (unsafe-cdr lst)))))))))) + #:with opt (with-syntax ([(f* lp v lst) (map generate-temporary '(f* loop v lst))] + [l ((optimize) #'l)] + [f ((optimize) #'f)]) + (log-optimization "apply-map" "apply-map deforestation." + this-syntax) + (add-disappeared-use #'appl) + (add-disappeared-use #'kw2) + (add-disappeared-use #'m) + (syntax/loc/origin + this-syntax #'kw + (let ([f* f]) + (let lp ([v op.identity] [lst l]) + (if (null? lst) + v + (lp (op v (f* (unsafe-car lst))) + (unsafe-cdr lst))))))))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/float-complex.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/float-complex.rkt index 2af9c3e8..51dd2d39 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/float-complex.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/float-complex.rkt @@ -1,7 +1,7 @@ #lang racket/base (require syntax/parse syntax/stx syntax/id-table racket/dict - unstable/syntax racket/match + unstable/syntax racket/match racket/syntax "../utils/utils.rkt" racket/unsafe/ops unstable/sequence (for-template racket/base racket/math racket/flonum racket/unsafe/ops) (utils tc-utils) @@ -89,8 +89,8 @@ c2:unboxed-float-complex-opt-expr cs:unboxed-float-complex-opt-expr ...) #:when (subtypeof? this-syntax -FloatComplex) - #:with real-binding (unboxed-gensym "unboxed-real-") - #:with imag-binding (unboxed-gensym "unboxed-imag-") + #:with real-binding (generate-temporary "unboxed-real-") + #:with imag-binding (generate-temporary "unboxed-imag-") #:with (bindings ...) (begin (log-optimization "unboxed binary float complex" complex-unboxing-opt-msg @@ -117,8 +117,8 @@ c2:unboxed-float-complex-opt-expr cs:unboxed-float-complex-opt-expr ...) #:when (subtypeof? this-syntax -FloatComplex) - #:with real-binding (unboxed-gensym "unboxed-real-") - #:with imag-binding (unboxed-gensym "unboxed-imag-") + #:with real-binding (generate-temporary "unboxed-real-") + #:with imag-binding (generate-temporary "unboxed-imag-") #:with (bindings ...) (begin (log-optimization "unboxed binary float complex" complex-unboxing-opt-msg @@ -143,8 +143,8 @@ #`((imag-binding) #,(skip-0s #'(c1.imag-binding c2.imag-binding cs.imag-binding ...))))))))) (pattern (#%plain-app (~and op (~literal -)) c1:unboxed-float-complex-opt-expr) ; unary - #:when (subtypeof? this-syntax -FloatComplex) - #:with real-binding (unboxed-gensym "unboxed-real-") - #:with imag-binding (unboxed-gensym "unboxed-imag-") + #:with real-binding (generate-temporary "unboxed-real-") + #:with imag-binding (generate-temporary "unboxed-imag-") #:with (bindings ...) (begin (log-optimization "unboxed unary float complex" complex-unboxing-opt-msg @@ -159,8 +159,8 @@ c2:unboxed-float-complex-opt-expr cs:unboxed-float-complex-opt-expr ...) #:when (or (subtypeof? this-syntax -FloatComplex) (subtypeof? this-syntax -Number)) - #:with real-binding (unboxed-gensym "unboxed-real-") - #:with imag-binding (unboxed-gensym "unboxed-imag-") + #:with real-binding (generate-temporary "unboxed-real-") + #:with imag-binding (generate-temporary "unboxed-imag-") #:with (bindings ...) (begin (log-optimization "unboxed binary float complex" complex-unboxing-opt-msg @@ -177,10 +177,10 @@ [o2 (car li)] [e1 (cdr lr)] [e2 (cdr li)] - [rs (append (stx-map (lambda (x) (unboxed-gensym "unboxed-real-")) + [rs (append (stx-map (lambda (x) (generate-temporary "unboxed-real-")) #'(cs.real-binding ...)) (list #'real-binding))] - [is (append (stx-map (lambda (x) (unboxed-gensym "unboxed-imag-")) + [is (append (stx-map (lambda (x) (generate-temporary "unboxed-imag-")) #'(cs.imag-binding ...)) (list #'imag-binding))] [res '()]) @@ -211,8 +211,8 @@ c2:unboxed-float-complex-opt-expr cs:unboxed-float-complex-opt-expr ...) #:when (subtypeof? this-syntax -FloatComplex) - #:with real-binding (unboxed-gensym "unboxed-real-") - #:with imag-binding (unboxed-gensym "unboxed-imag-") + #:with real-binding (generate-temporary "unboxed-real-") + #:with imag-binding (generate-temporary "unboxed-imag-") #:with reals (stx-map get-part-or-0.0 #'(c1.real-binding c2.real-binding cs.real-binding ...)) #:with imags (stx-map get-part-or-0.0 @@ -229,10 +229,10 @@ [b (stx-car #'imags)] [e1 (cdr (syntax->list #'reals))] [e2 (cdr (syntax->list #'imags))] - [rs (append (stx-map (lambda (x) (unboxed-gensym "unboxed-real-")) + [rs (append (stx-map (lambda (x) (generate-temporary "unboxed-real-")) #'(cs.real-binding ...)) (list #'real-binding))] - [is (append (stx-map (lambda (x) (unboxed-gensym "unboxed-imag-")) + [is (append (stx-map (lambda (x) (generate-temporary "unboxed-imag-")) #'(cs.imag-binding ...)) (list #'imag-binding))] [res '()]) @@ -243,8 +243,8 @@ res))))))) (pattern (#%plain-app (~and op (~literal /)) c1:unboxed-float-complex-opt-expr) ; unary / #:when (subtypeof? this-syntax -FloatComplex) - #:with real-binding (unboxed-gensym "unboxed-real-") - #:with imag-binding (unboxed-gensym "unboxed-imag-") + #:with real-binding (generate-temporary "unboxed-real-") + #:with imag-binding (generate-temporary "unboxed-imag-") #:with (bindings ...) (begin (log-optimization "unboxed unary float complex" complex-unboxing-opt-msg @@ -257,7 +257,7 @@ (pattern (#%plain-app (~and op (~literal conjugate)) c:unboxed-float-complex-opt-expr) #:when (subtypeof? this-syntax -FloatComplex) #:with real-binding #'c.real-binding - #:with imag-binding (unboxed-gensym "unboxed-imag-") + #:with imag-binding (generate-temporary "unboxed-imag-") #:with (bindings ...) (begin (log-optimization "unboxed unary float complex" complex-unboxing-opt-msg @@ -270,7 +270,7 @@ #'0.0))))))) (pattern (#%plain-app (~and op (~literal magnitude)) c:unboxed-float-complex-opt-expr) - #:with real-binding (unboxed-gensym "unboxed-real-") + #:with real-binding (generate-temporary "unboxed-real-") #:with imag-binding #'#f #:with (bindings ...) (begin (log-optimization "unboxed unary float complex" @@ -291,9 +291,9 @@ (unsafe-fl* c.imag-binding c.imag-binding))])))))) (pattern (#%plain-app (~and op (~literal exp)) c:unboxed-float-complex-opt-expr) - #:with real-binding (unboxed-gensym "unboxed-real-") - #:with imag-binding (unboxed-gensym "unboxed-imag-") - #:with scaling-factor (unboxed-gensym "unboxed-scaling-") + #:with real-binding (generate-temporary "unboxed-real-") + #:with imag-binding (generate-temporary "unboxed-imag-") + #:with scaling-factor (generate-temporary "unboxed-scaling-") #:with (bindings ...) (begin (log-optimization "unboxed unary float complex" complex-unboxing-opt-msg @@ -335,7 +335,7 @@ ;; special handling of reals inside complex operations ;; must be after any cases that we are supposed to handle (pattern e:float-arg-expr - #:with real-binding (unboxed-gensym 'unboxed-float-) + #:with real-binding (generate-temporary 'unboxed-float-) #:with imag-binding #'#f #:with (bindings ...) (begin (log-optimization "float-arg-expr in complex ops" @@ -348,8 +348,8 @@ (pattern (#%plain-app (~and op (~or (~literal make-rectangular) (~literal unsafe-make-flrectangular))) real:float-arg-expr imag:float-arg-expr) - #:with real-binding (unboxed-gensym "unboxed-real-") - #:with imag-binding (unboxed-gensym "unboxed-imag-") + #:with real-binding (generate-temporary "unboxed-real-") + #:with imag-binding (generate-temporary "unboxed-imag-") #:with (bindings ...) (begin (log-optimization "make-rectangular elimination" complex-unboxing-opt-msg @@ -359,10 +359,10 @@ ((imag-binding) imag.opt)))) (pattern (#%plain-app (~and op (~literal make-polar)) r:float-arg-expr theta:float-arg-expr) - #:with magnitude (unboxed-gensym) - #:with angle (unboxed-gensym) - #:with real-binding (unboxed-gensym "unboxed-real-") - #:with imag-binding (unboxed-gensym "unboxed-imag-") + #:with magnitude (generate-temporary) + #:with angle (generate-temporary) + #:with real-binding (generate-temporary "unboxed-real-") + #:with imag-binding (generate-temporary "unboxed-imag-") #:with (bindings ...) (begin (log-optimization "make-rectangular elimination" complex-unboxing-opt-msg @@ -395,8 +395,8 @@ #:when (let ((x (syntax->datum #'n))) (and (number? x) (not (eq? (imag-part x) 0)))) - #:with real-binding (unboxed-gensym "unboxed-real-") - #:with imag-binding (unboxed-gensym "unboxed-imag-") + #:with real-binding (generate-temporary "unboxed-real-") + #:with imag-binding (generate-temporary "unboxed-imag-") #:with (bindings ...) (begin (log-optimization "unboxed literal" complex-unboxing-opt-msg @@ -410,7 +410,7 @@ (exact->inexact (imag-part n)))))))) (pattern (quote n) #:when (real? (syntax->datum #'n)) - #:with real-binding (unboxed-gensym "unboxed-real-") + #:with real-binding (generate-temporary "unboxed-real-") #:with imag-binding #'#f #:with (bindings ...) (begin (log-optimization "unboxed literal" @@ -422,9 +422,9 @@ (pattern e:expr #:when (subtypeof? #'e -FloatComplex) - #:with e* (unboxed-gensym) - #:with real-binding (unboxed-gensym "unboxed-real-") - #:with imag-binding (unboxed-gensym "unboxed-imag-") + #:with e* (generate-temporary) + #:with real-binding (generate-temporary "unboxed-real-") + #:with imag-binding (generate-temporary "unboxed-imag-") #:with (bindings ...) (begin (log-optimization "unbox float-complex" complex-unboxing-opt-msg @@ -434,9 +434,9 @@ ((imag-binding) (unsafe-flimag-part e*))))) (pattern e:expr #:when (subtypeof? #'e -Number) ; complex, maybe exact, maybe not - #:with e* (unboxed-gensym) - #:with real-binding (unboxed-gensym "unboxed-real-") - #:with imag-binding (unboxed-gensym "unboxed-imag-") + #:with e* (generate-temporary) + #:with real-binding (generate-temporary "unboxed-real-") + #:with imag-binding (generate-temporary "unboxed-imag-") #:with (bindings ...) (begin (log-optimization "unbox complex" complex-unboxing-opt-msg @@ -524,7 +524,6 @@ complex-unboxing-opt-msg this-syntax) (add-disappeared-use #'op) - (reset-unboxed-gensym) #`(let*-values (c*.bindings ...) #,(if (or (free-identifier=? #'op #'real-part) (free-identifier=? #'op #'flreal-part) @@ -547,7 +546,6 @@ complex-unboxing-opt-msg this-syntax) (add-disappeared-use #'op) - (reset-unboxed-gensym) #`(let*-values (exp*.bindings ...) (unsafe-make-flrectangular #,(get-part-or-0.0 #'exp*.real-binding) #,(get-part-or-0.0 #'exp*.imag-binding))))) @@ -577,8 +575,7 @@ #:with imag-binding #'#f #:with (bindings ...) #'(exp*.bindings ...) #:with opt - (begin (reset-unboxed-gensym) - (add-disappeared-use #'op) + (begin (add-disappeared-use #'op) #`(let*-values (exp*.bindings ...) #,(get-part-or-0.0 #'real-binding)))) @@ -589,8 +586,7 @@ #:with imag-binding #'exp*.imag-binding #:with (bindings ...) #'(exp*.bindings ...) #:with opt - (begin (reset-unboxed-gensym) - (add-disappeared-use #'op) + (begin (add-disappeared-use #'op) #`(let*-values (exp*.bindings ...) (unsafe-make-flrectangular #,(get-part-or-0.0 #'exp*.real-binding) #,(get-part-or-0.0 #'exp*.imag-binding))))) @@ -624,8 +620,7 @@ #:with imag-binding #'exp*.imag-binding #:with (bindings ...) #'(exp*.bindings ...) #:with opt - (begin (reset-unboxed-gensym) - (add-disappeared-use #'op) + (begin (add-disappeared-use #'op) #`(let*-values (exp*.bindings ...) (unsafe-make-flrectangular #,(get-part-or-0.0 #'exp*.real-binding) #,(get-part-or-0.0 #'exp*.imag-binding))))) @@ -645,7 +640,6 @@ ;; same time (add-disappeared-use (syntax-local-introduce #'v)) (add-disappeared-binding (syntax-local-introduce #'orig-binding)) - (reset-unboxed-gensym) #'(unsafe-make-flrectangular real-binding imag-binding)))) ;; takes as argument a structure describing which arguments will be unboxed @@ -668,7 +662,6 @@ complex-unboxing-opt-msg this-syntax) (add-disappeared-use #'op) - (reset-unboxed-gensym) #`(let*-values (e.bindings ... ...) (#%plain-app #,opt-operator #,@(stx-map get-part-or-0.0 #'(e.real-binding ...)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/unboxed-let.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/unboxed-let.rkt index e9cf6664..62bdd09f 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/unboxed-let.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/unboxed-let.rkt @@ -1,7 +1,7 @@ #lang racket/base (require syntax/parse syntax/stx unstable/syntax unstable/sequence - racket/list racket/dict racket/match + racket/list racket/dict racket/match racket/syntax "../utils/utils.rkt" "../utils/tc-utils.rkt" (for-template racket/base) @@ -301,9 +301,9 @@ ;; partition of the arguments #:with ((to-unbox ...) (boxed ...)) #'unboxed-info #:with (real-params ...) - (stx-map (lambda (x) (unboxed-gensym "unboxed-real-")) #'(to-unbox ...)) + (stx-map (lambda (x) (generate-temporary "unboxed-real-")) #'(to-unbox ...)) #:with (imag-params ...) - (stx-map (lambda (x) (unboxed-gensym "unboxed-imag-")) #'(to-unbox ...)) + (stx-map (lambda (x) (generate-temporary "unboxed-imag-")) #'(to-unbox ...)) #:with res (begin (log-optimization "fun -> unboxed fun" arity-raising-opt-msg #'v) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt index f3a1a2be..cdc2b729 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt @@ -11,7 +11,6 @@ subtypeof? isoftype? mk-unsafe-tbl n-ary->binary n-ary-comp->binary - unboxed-gensym reset-unboxed-gensym optimize syntax/loc/origin quasisyntax/loc/origin) @@ -49,7 +48,7 @@ (define (n-ary-comp->binary op arg1 arg2 rest) ;; First, generate temps to bind the result of each arg2 args ... ;; to avoid computing them multiple times. - (define lifted (stx-map (lambda (x) (unboxed-gensym)) #`(#,arg2 #,@rest))) + (define lifted (stx-map (lambda (x) (generate-temporary)) #`(#,arg2 #,@rest))) ;; Second, build the list ((op arg1 tmp2) (op tmp2 tmp3) ...) (define tests (let loop ([res (list #`(#,op #,arg1 #,(car lifted)))] @@ -65,15 +64,6 @@ #`(#,lhs #,rhs)) (and #,@tests))) -;; to generate temporary symbols in a predictable manner -;; these identifiers are unique within a sequence of unboxed operations -(define *unboxed-gensym-counter* 0) -(define (unboxed-gensym [name 'unboxed-gensym-]) - (set! *unboxed-gensym-counter* (add1 *unboxed-gensym-counter*)) - (format-unique-id #'here "~a~a" name *unboxed-gensym-counter*)) -(define (reset-unboxed-gensym) - (set! *unboxed-gensym-counter* 0)) - ;; to avoid mutually recursive syntax classes ;; will be set to the actual optimization function at the entry point ;; of the optimizer