From bfc4ad42255d4f74fae6aa9275fb2ad3080f5bd3 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 29 Jun 2011 14:38:20 -0400 Subject: [PATCH] Add nicer optimization reporting messages. --- collects/typed-scheme/optimizer/apply.rkt | 2 +- collects/typed-scheme/optimizer/box.rkt | 2 +- collects/typed-scheme/optimizer/dead-code.rkt | 8 +- collects/typed-scheme/optimizer/fixnum.rkt | 32 ++++--- .../typed-scheme/optimizer/float-complex.rkt | 93 ++++++++++++++----- collects/typed-scheme/optimizer/float.rkt | 24 ++--- collects/typed-scheme/optimizer/logging.rkt | 4 +- collects/typed-scheme/optimizer/number.rkt | 2 +- collects/typed-scheme/optimizer/pair.rkt | 11 ++- collects/typed-scheme/optimizer/sequence.rkt | 10 +- collects/typed-scheme/optimizer/string.rkt | 8 +- collects/typed-scheme/optimizer/struct.rkt | 6 +- .../typed-scheme/optimizer/unboxed-let.rkt | 14 ++- collects/typed-scheme/optimizer/vector.rkt | 10 +- 14 files changed, 151 insertions(+), 75 deletions(-) diff --git a/collects/typed-scheme/optimizer/apply.rkt b/collects/typed-scheme/optimizer/apply.rkt index 975580fb05..eb14037089 100644 --- a/collects/typed-scheme/optimizer/apply.rkt +++ b/collects/typed-scheme/optimizer/apply.rkt @@ -21,7 +21,7 @@ (with-syntax ([(f* lp v lst) (map unboxed-gensym '(f* loop v lst))] [l ((optimize) #'l)] [f ((optimize) #'f)]) - (log-optimization "apply-map" this-syntax) + (log-optimization "apply-map" "apply-map deforestation." this-syntax) #'(let ([f* f]) (let lp ([v op.identity] [lst l]) (if (null? lst) diff --git a/collects/typed-scheme/optimizer/box.rkt b/collects/typed-scheme/optimizer/box.rkt index f7efd86319..241b8de0d0 100644 --- a/collects/typed-scheme/optimizer/box.rkt +++ b/collects/typed-scheme/optimizer/box.rkt @@ -28,5 +28,5 @@ #:commit (pattern (#%plain-app op:box-op b:box-expr new:expr ...) #:with opt - (begin (log-optimization "box" this-syntax) + (begin (log-optimization "box" "Box check elimination." this-syntax) #`(op.unsafe b.opt #,@(syntax-map (optimize) #'(new ...)))))) diff --git a/collects/typed-scheme/optimizer/dead-code.rkt b/collects/typed-scheme/optimizer/dead-code.rkt index 3be841925b..eb94414935 100644 --- a/collects/typed-scheme/optimizer/dead-code.rkt +++ b/collects/typed-scheme/optimizer/dead-code.rkt @@ -15,12 +15,16 @@ (pattern (if tst:expr thn:expr els:expr) #:when (tautology? #'tst) #:with opt - (begin (log-optimization "dead else branch" #'els) + (begin (log-optimization "dead else branch" + "Unreachable else branch elimination." + #'els) #`(#%expression (begin #,((optimize) #'tst) #,((optimize) #'thn))))) (pattern (if tst:expr thn:expr els:expr) #:when (contradiction? #'tst) #:with opt - (begin (log-optimization "dead then branch" #'thn) + (begin (log-optimization "dead then branch" + "Unreachable then branch elimination." + #'thn) #`(#%expression (begin #,((optimize) #'tst) #,((optimize) #'els)))))) diff --git a/collects/typed-scheme/optimizer/fixnum.rkt b/collects/typed-scheme/optimizer/fixnum.rkt index bf9d9e2ba0..1036affb2c 100644 --- a/collects/typed-scheme/optimizer/fixnum.rkt +++ b/collects/typed-scheme/optimizer/fixnum.rkt @@ -67,39 +67,41 @@ #:when (or (subtypeof? #'e -PosFixnum) (subtypeof? #'e -NegFixnum)) #:with opt ((optimize) #'e))) +(define fixnum-opt-msg "Fixnum arithmetic specialization.") + (define-syntax-class fixnum-opt-expr #:commit (pattern (#%plain-app op:fixnum-unary-op n:fixnum-expr) #:with opt - (begin (log-optimization "unary fixnum" this-syntax) + (begin (log-optimization "unary fixnum" fixnum-opt-msg this-syntax) #'(op.unsafe n.opt))) (pattern (#%plain-app (~var op (fixnum-op binary-fixnum-ops)) n1:fixnum-expr n2:fixnum-expr ns:fixnum-expr ...) #:with opt - (begin (log-optimization "binary fixnum" this-syntax) + (begin (log-optimization "binary fixnum" fixnum-opt-msg this-syntax) (n-ary->binary #'op.unsafe #'n1.opt #'n2.opt #'(ns.opt ...)))) (pattern (#%plain-app op:nonzero-fixnum-binary-op n1:fixnum-expr n2:nonzero-fixnum-expr) #:with opt - (begin (log-optimization "binary nonzero fixnum" this-syntax) + (begin (log-optimization "binary nonzero fixnum" fixnum-opt-msg this-syntax) #'(op.unsafe n1.opt n2.opt))) (pattern (#%plain-app (~and op (~literal -)) f:fixnum-expr) #:with opt - (begin (log-optimization "unary fixnum" this-syntax) + (begin (log-optimization "unary fixnum" fixnum-opt-msg this-syntax) #'(unsafe-fx- 0 f.opt))) (pattern (#%plain-app (~and op (~literal exact->inexact)) n:fixnum-expr) #:with opt - (begin (log-optimization "fixnum to float" this-syntax) + (begin (log-optimization "fixnum to float" fixnum-opt-msg this-syntax) #'(unsafe-fx->fl n.opt))) (pattern (#%plain-app (~and op (~literal zero?)) n:fixnum-expr) #:with opt - (begin (log-optimization "fixnum zero?" this-syntax) + (begin (log-optimization "fixnum zero?" fixnum-opt-msg this-syntax) #'(unsafe-fx= n.opt 0))) ;; The following are not closed on fixnums, but we can guarantee that results @@ -109,7 +111,7 @@ n1:fixnum-expr n2:fixnum-expr ns:fixnum-expr ...) #:when (subtypeof? this-syntax -Fixnum) #:with opt - (begin (log-optimization "fixnum bounded expr" this-syntax) + (begin (log-optimization "fixnum bounded expr" fixnum-opt-msg this-syntax) (let ([post-opt (syntax->list #'(n1.opt n2.opt ns.opt ...))]) (n-ary->binary #'op.unsafe (car post-opt) (cadr post-opt) (cddr post-opt))))) @@ -117,7 +119,7 @@ n1:fixnum-expr n2:nonzero-fixnum-expr) #:when (subtypeof? this-syntax -Fixnum) #:with opt - (begin (log-optimization "nonzero fixnum bounded expr" this-syntax) + (begin (log-optimization "nonzero fixnum bounded expr" fixnum-opt-msg this-syntax) #'(op.unsafe n1.opt n2.opt))) ;; for fx-specific ops, we need to mimic the typing rules of their generic ;; counterparts, since fx-specific ops rely on error behavior for typechecking @@ -127,36 +129,36 @@ (and (subtypeof? #'n1 -NonNegFixnum) (subtypeof? #'n2 -NonPosFixnum)) (and (subtypeof? #'n1 -NonPosFixnum) (subtypeof? #'n2 -NonNegFixnum))) #:with opt - (begin (log-optimization "fixnum fx+" this-syntax) + (begin (log-optimization "fixnum fx+" fixnum-opt-msg this-syntax) #'(unsafe-fx+ n1.opt n2.opt))) (pattern (#%plain-app (~and op (~literal fx-)) n1:fixnum-expr n2:fixnum-expr) #:when (and (subtypeof? #'n1 -NonNegFixnum) (subtypeof? #'n2 -NonNegFixnum)) #:with opt - (begin (log-optimization "fixnum fx-" this-syntax) + (begin (log-optimization "fixnum fx-" fixnum-opt-msg this-syntax) #'(unsafe-fx- n1.opt n2.opt))) (pattern (#%plain-app (~and op (~literal fx*)) n1:fixnum-expr n2:fixnum-expr) #:when (and (subtypeof? #'n1 -Byte) (subtypeof? #'n2 -Byte)) #:with opt - (begin (log-optimization "fixnum fx*" this-syntax) + (begin (log-optimization "fixnum fx*" fixnum-opt-msg this-syntax) #'(unsafe-fx* n1.opt n2.opt))) (pattern (#%plain-app (~and op (~literal fxquotient)) n1:fixnum-expr n2:fixnum-expr) #:when (and (subtypeof? #'n1 -NonNegFixnum) (subtypeof? #'n2 -Fixnum)) #:with opt - (begin (log-optimization "fixnum fxquotient" this-syntax) + (begin (log-optimization "fixnum fxquotient" fixnum-opt-msg this-syntax) #'(unsafe-fxquotient n1.opt n2.opt))) (pattern (#%plain-app (~and op (~or (~literal fxabs) (~literal abs))) n:fixnum-expr) #:when (subtypeof? #'n -NonNegFixnum) ; (abs min-fixnum) is not a fixnum #:with opt - (begin (log-optimization "fixnum fxabs" this-syntax) + (begin (log-optimization "fixnum fxabs" fixnum-opt-msg this-syntax) #'(unsafe-fxabs n.opt))) (pattern (#%plain-app (~and op (~literal add1)) n:fixnum-expr) #:when (subtypeof? this-syntax -Fixnum) #:with opt - (begin (log-optimization "fixnum add1" this-syntax) + (begin (log-optimization "fixnum add1" fixnum-opt-msg this-syntax) #'(unsafe-fx+ n.opt 1))) (pattern (#%plain-app (~and op (~literal sub1)) n:fixnum-expr) #:when (subtypeof? this-syntax -Fixnum) #:with opt - (begin (log-optimization "fixnum sub1" this-syntax) + (begin (log-optimization "fixnum sub1" fixnum-opt-msg this-syntax) #'(unsafe-fx- n.opt 1)))) diff --git a/collects/typed-scheme/optimizer/float-complex.rkt b/collects/typed-scheme/optimizer/float-complex.rkt index e2e80bb15e..34be8c154b 100644 --- a/collects/typed-scheme/optimizer/float-complex.rkt +++ b/collects/typed-scheme/optimizer/float-complex.rkt @@ -9,7 +9,7 @@ (provide float-complex-opt-expr float-complex-arith-opt-expr unboxed-float-complex-opt-expr - float-complex-call-site-opt-expr + float-complex-call-site-opt-expr arity-raising-opt-msg unboxed-vars-table unboxed-funs-table) @@ -26,6 +26,9 @@ ;; params first, then all imaginary parts, then all boxed arguments (define unboxed-funs-table (make-free-id-table)) +(define complex-unboxing-opt-msg "Complex number unboxing.") +(define arity-raising-opt-msg "Complex number arity raising.") + ;; 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 @@ -41,7 +44,9 @@ #:with real-binding (unboxed-gensym "unboxed-real-") #:with imag-binding (unboxed-gensym "unboxed-imag-") #:with (bindings ...) - (begin (log-optimization "unboxed binary float complex" this-syntax) + (begin (log-optimization "unboxed binary float complex" + complex-unboxing-opt-msg + this-syntax) #`(#,@(append (syntax->list #'(c1.bindings ... c2.bindings ... cs.bindings ... ...)) (let () ;; we can skip the real parts of imaginaries (#f) and vice versa @@ -66,7 +71,9 @@ #:with real-binding (unboxed-gensym "unboxed-real-") #:with imag-binding (unboxed-gensym "unboxed-imag-") #:with (bindings ...) - (begin (log-optimization "unboxed binary float complex" this-syntax) + (begin (log-optimization "unboxed binary float complex" + complex-unboxing-opt-msg + this-syntax) #`(#,@(append (syntax->list #'(c1.bindings ... c2.bindings ... cs.bindings ... ...)) (let () ;; unlike addition, we simply can't skip real parts of imaginaries @@ -93,7 +100,9 @@ #:with real-binding (unboxed-gensym "unboxed-real-") #:with imag-binding (unboxed-gensym "unboxed-imag-") #:with (bindings ...) - (begin (log-optimization "unboxed binary float complex" this-syntax) + (begin (log-optimization "unboxed binary float complex" + complex-unboxing-opt-msg + this-syntax) #`(c1.bindings ... c2.bindings ... cs.bindings ... ... ;; we want to bind the intermediate results to reuse them ;; the final results are bound to real-binding and imag-binding @@ -146,7 +155,9 @@ #:with imags (syntax-map (lambda (x) (if (syntax->datum x) x #'0.0)) #'(c1.imag-binding c2.imag-binding cs.imag-binding ...)) #:with (bindings ...) - (begin (log-optimization "unboxed binary float complex" this-syntax) + (begin (log-optimization "unboxed binary float complex" + complex-unboxing-opt-msg + this-syntax) #`(c1.bindings ... c2.bindings ... cs.bindings ... ... ;; we want to bind the intermediate results to reuse them ;; the final results are bound to real-binding and imag-binding @@ -210,7 +221,9 @@ #:with real-binding #'c.real-binding #:with imag-binding (unboxed-gensym "unboxed-imag-") #:with (bindings ...) - (begin (log-optimization "unboxed unary float complex" this-syntax) + (begin (log-optimization "unboxed unary float complex" + complex-unboxing-opt-msg + this-syntax) #`(#,@(append (syntax->list #'(c.bindings ...)) (list #'((imag-binding) (unsafe-fl- 0.0 c.imag-binding))))))) @@ -218,7 +231,9 @@ #:with real-binding (unboxed-gensym "unboxed-real-") #:with imag-binding #f #:with (bindings ...) - (begin (log-optimization "unboxed unary float complex" this-syntax) + (begin (log-optimization "unboxed unary float complex" + complex-unboxing-opt-msg + this-syntax) #`(c.bindings ... ((real-binding) (unsafe-flsqrt (unsafe-fl+ (unsafe-fl* c.real-binding c.real-binding) @@ -229,14 +244,18 @@ #:with real-binding #'c.real-binding #:with imag-binding #f #:with (bindings ...) - (begin (log-optimization "unboxed unary float complex" this-syntax) + (begin (log-optimization "unboxed unary float complex" + complex-unboxing-opt-msg + this-syntax) #'(c.bindings ...))) (pattern (#%plain-app (~and op (~or (~literal imag-part) (~literal unsafe-flimag-part))) c:unboxed-float-complex-opt-expr) #:with real-binding #'c.imag-binding #:with imag-binding #f #:with (bindings ...) - (begin (log-optimization "unboxed unary float complex" this-syntax) + (begin (log-optimization "unboxed unary float complex" + complex-unboxing-opt-msg + this-syntax) #'(c.bindings ...))) ;; special handling of reals inside complex operations @@ -245,7 +264,9 @@ #:with real-binding (unboxed-gensym 'unboxed-float-) #:with imag-binding #f #:with (bindings ...) - (begin (log-optimization "float-arg-expr in complex ops" this-syntax) + (begin (log-optimization "float-arg-expr in complex ops" + complex-unboxing-opt-msg + this-syntax) #`(((real-binding) e.opt)))) @@ -256,7 +277,9 @@ #:with real-binding (unboxed-gensym "unboxed-real-") #:with imag-binding (unboxed-gensym "unboxed-imag-") #:with (bindings ...) - (begin (log-optimization "make-rectangular elimination" this-syntax) + (begin (log-optimization "make-rectangular elimination" + complex-unboxing-opt-msg + this-syntax) #'(((real-binding) real.opt) ((imag-binding) imag.opt)))) (pattern (#%plain-app (~and op (~literal make-polar)) @@ -266,7 +289,9 @@ #:with real-binding (unboxed-gensym "unboxed-real-") #:with imag-binding (unboxed-gensym "unboxed-imag-") #:with (bindings ...) - (begin (log-optimization "make-rectangular elimination" this-syntax) + (begin (log-optimization "make-rectangular elimination" + complex-unboxing-opt-msg + this-syntax) #'(((magnitude) r.opt) ((angle) theta.opt) ((real-binding) (unsafe-fl* magnitude (unsafe-flcos angle))) @@ -279,7 +304,9 @@ #:with real-binding (car (syntax->list #'unboxed-info)) #:with imag-binding (cadr (syntax->list #'unboxed-info)) #:with (bindings ...) - (begin (log-optimization "leave var unboxed" this-syntax) + (begin (log-optimization "leave var unboxed" + complex-unboxing-opt-msg + this-syntax) #'())) ;; else, do the unboxing here @@ -292,7 +319,9 @@ #:with real-binding (unboxed-gensym "unboxed-real-") #:with imag-binding (unboxed-gensym "unboxed-imag-") #:with (bindings ...) - (begin (log-optimization "unboxed literal" this-syntax) + (begin (log-optimization "unboxed literal" + complex-unboxing-opt-msg + this-syntax) (let ((n (syntax->datum #'n))) #`(((real-binding) #,(datum->syntax #'here @@ -305,7 +334,9 @@ #:with real-binding (unboxed-gensym "unboxed-real-") #:with imag-binding #f #:with (bindings ...) - (begin (log-optimization "unboxed literal" this-syntax) + (begin (log-optimization "unboxed literal" + complex-unboxing-opt-msg + this-syntax) #`(((real-binding) #,(datum->syntax #'here (exact->inexact (syntax->datum #'n))))))) @@ -316,7 +347,9 @@ #:with real-binding (unboxed-gensym "unboxed-real-") #:with imag-binding (unboxed-gensym "unboxed-imag-") #:with (bindings ...) - (begin (log-optimization "unbox float-complex" this-syntax) + (begin (log-optimization "unbox float-complex" + complex-unboxing-opt-msg + this-syntax) #`(((e*) #,((optimize) #'e)) ((real-binding) (unsafe-flreal-part e*)) ((imag-binding) (unsafe-flimag-part e*))))) @@ -326,7 +359,9 @@ #:with real-binding (unboxed-gensym "unboxed-real-") #:with imag-binding (unboxed-gensym "unboxed-imag-") #:with (bindings ...) - (begin (log-optimization "unbox complex" this-syntax) + (begin (log-optimization "unbox complex" + complex-unboxing-opt-msg + this-syntax) #`(((e*) #,((optimize) #'e)) ((real-binding) (exact->inexact (real-part e*))) ((imag-binding) (exact->inexact (imag-part e*)))))) @@ -396,7 +431,9 @@ c:float-complex-expr) #:with c*:unboxed-float-complex-opt-expr #'c #:with opt - (begin (log-optimization "complex accessor elimination" this-syntax) + (begin (log-optimization "complex accessor elimination" + complex-unboxing-opt-msg + this-syntax) (reset-unboxed-gensym) #`(let*-values (c*.bindings ...) #,(if (or (free-identifier=? #'op #'real-part) @@ -407,14 +444,18 @@ (pattern (#%plain-app op:float-complex-unary-op n:float-complex-expr) #:with opt - (begin (log-optimization "unary float complex" this-syntax) + (begin (log-optimization "unary float complex" + complex-unboxing-opt-msg + this-syntax) #'(op.unsafe n.opt))) (pattern (#%plain-app (~and op (~literal make-polar)) r theta) #:when (subtypeof? this-syntax -FloatComplex) #:with exp*:unboxed-float-complex-opt-expr this-syntax #:with opt - (begin (log-optimization "make-polar" this-syntax) + (begin (log-optimization "make-polar" + complex-unboxing-opt-msg + this-syntax) (reset-unboxed-gensym) #'(let*-values (exp*.bindings ...) (unsafe-make-flrectangular exp*.real-binding @@ -427,7 +468,9 @@ #'unboxed-info #'op)) ; no need to optimize op this-syntax #:with opt - (begin (log-optimization "call to fun with unboxed args" this-syntax) + (begin (log-optimization "call to fun with unboxed args" + arity-raising-opt-msg + this-syntax) #'e*.opt)) (pattern e:float-complex-arith-opt-expr @@ -467,7 +510,9 @@ #:with (bindings ...) #'() ;; unboxed variable used in a boxed fashion, we have to box #:with opt - (begin (log-optimization "unboxed complex variable" this-syntax) + (begin (log-optimization "unboxed complex variable" + complex-unboxing-opt-msg + this-syntax) (reset-unboxed-gensym) #'(unsafe-make-flrectangular real-binding imag-binding)))) @@ -487,7 +532,9 @@ (define (get-arg i) (list-ref args i)) (syntax-parse (map get-arg unboxed) [(e:unboxed-float-complex-opt-expr ...) - (log-optimization "unboxed call site" this-syntax) + (log-optimization "unboxed call site" + complex-unboxing-opt-msg + this-syntax) (reset-unboxed-gensym) #`(let*-values (e.bindings ... ...) (#%plain-app #,opt-operator diff --git a/collects/typed-scheme/optimizer/float.rkt b/collects/typed-scheme/optimizer/float.rkt index 26a1606675..af2ee2c936 100644 --- a/collects/typed-scheme/optimizer/float.rkt +++ b/collects/typed-scheme/optimizer/float.rkt @@ -80,6 +80,8 @@ "This expression has a Real type. It would be better optimized if it had a Float type. To fix this, change the circled expression(s) to have Float type(s)." stx irritants)) +(define float-opt-msg "Float arithmetic specialization.") + (define-syntax-class float-opt-expr #:commit (pattern (#%plain-app (~var op (float-op unary-float-ops)) f:float-arg-expr) @@ -90,7 +92,7 @@ (log-float-real-missed-opt this-syntax (list #'f))) safe-to-opt?) #:with opt - (begin (log-optimization "unary float" this-syntax) + (begin (log-optimization "unary float" float-opt-msg this-syntax) #'(op.unsafe f.opt))) (pattern (#%plain-app (~var op (float-op binary-float-ops)) f1:float-arg-expr @@ -136,50 +138,50 @@ [_ #f]))) safe-to-opt?) #:with opt - (begin (log-optimization "binary float" this-syntax) + (begin (log-optimization "binary float" float-opt-msg this-syntax) (n-ary->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...)))) (pattern (#%plain-app (~var op (float-op binary-float-comps)) f1:float-expr f2:float-expr fs:float-expr ...) #:with opt - (begin (log-optimization "binary float comp" this-syntax) + (begin (log-optimization "binary float comp" float-opt-msg this-syntax) (n-ary->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...)))) (pattern (#%plain-app (~and op (~literal -)) f:float-expr) #:with opt - (begin (log-optimization "unary float" this-syntax) + (begin (log-optimization "unary float" float-opt-msg this-syntax) #'(unsafe-fl- 0.0 f.opt))) (pattern (#%plain-app (~and op (~literal /)) f:float-expr) #:with opt - (begin (log-optimization "unary float" this-syntax) + (begin (log-optimization "unary float" float-opt-msg this-syntax) #'(unsafe-fl/ 1.0 f.opt))) (pattern (#%plain-app (~and op (~literal sqr)) f:float-expr) #:with opt - (begin (log-optimization "unary float" this-syntax) + (begin (log-optimization "unary float" float-opt-msg this-syntax) #'(let ([tmp f.opt]) (unsafe-fl* tmp tmp)))) ;; we can optimize exact->inexact if we know we're giving it an Integer (pattern (#%plain-app (~and op (~literal exact->inexact)) n:int-expr) #:with opt - (begin (log-optimization "int to float" this-syntax) + (begin (log-optimization "int to float" float-opt-msg this-syntax) #'(->fl n.opt))) ;; we can get rid of it altogether if we're giving it a float (pattern (#%plain-app (~and op (~literal exact->inexact)) f:float-expr) #:with opt - (begin (log-optimization "float to float" this-syntax) + (begin (log-optimization "float to float" float-opt-msg this-syntax) #'f.opt)) (pattern (#%plain-app (~and op (~literal zero?)) f:float-expr) #:with opt - (begin (log-optimization "float zero?" this-syntax) + (begin (log-optimization "float zero?" float-opt-msg this-syntax) #'(unsafe-fl= f.opt 0.0))) (pattern (#%plain-app (~and op (~literal add1)) n:float-expr) #:with opt - (begin (log-optimization "float add1" this-syntax) + (begin (log-optimization "float add1" float-opt-msg this-syntax) #'(unsafe-fl+ n.opt 1.0))) (pattern (#%plain-app (~and op (~literal sub1)) n:float-expr) #:with opt - (begin (log-optimization "float sub1" this-syntax) + (begin (log-optimization "float sub1" float-opt-msg this-syntax) #'(unsafe-fl- n.opt 1.0)))) diff --git a/collects/typed-scheme/optimizer/logging.rkt b/collects/typed-scheme/optimizer/logging.rkt index 9c450bb513..ebee253e2e 100644 --- a/collects/typed-scheme/optimizer/logging.rkt +++ b/collects/typed-scheme/optimizer/logging.rkt @@ -30,8 +30,8 @@ (struct opt-log-entry log-entry () #:prefab) -(define (log-optimization msg stx) - (let ([new-entry (opt-log-entry msg msg stx (syntax-position stx))]) +(define (log-optimization kind msg stx) + (let ([new-entry (opt-log-entry kind msg stx (syntax-position stx))]) (set! log-so-far (cons new-entry log-so-far)))) ;;-------------------------------------------------------------------- diff --git a/collects/typed-scheme/optimizer/number.rkt b/collects/typed-scheme/optimizer/number.rkt index 3e17ddb824..3ed192577c 100644 --- a/collects/typed-scheme/optimizer/number.rkt +++ b/collects/typed-scheme/optimizer/number.rkt @@ -13,5 +13,5 @@ (pattern (#%plain-app (~and op (~or (~literal +) (~literal *) (~literal min) (~literal max))) f:expr) #:with opt - (begin (log-optimization "unary number" this-syntax) + (begin (log-optimization "unary number" "Identity elimination." this-syntax) ((optimize) #'f)))) diff --git a/collects/typed-scheme/optimizer/pair.rkt b/collects/typed-scheme/optimizer/pair.rkt index 2bdd64ed9b..cb812d7f82 100644 --- a/collects/typed-scheme/optimizer/pair.rkt +++ b/collects/typed-scheme/optimizer/pair.rkt @@ -39,11 +39,16 @@ "According to its type, the circled list could be empty. Access to it cannot be safely optimized. To fix this, restrict the type to non-empty lists, maybe by wrapping this expression in a check for non-emptiness." stx irritant)) +(define pair-opt-msg "Pair check elimination.") + +(define (log-pair-opt stx) + (log-optimization "pair" pair-opt-msg stx)) + (define-syntax-class pair-opt-expr #:commit (pattern e:pair-derived-opt-expr #:with opt - (begin (log-optimization "derived pair" this-syntax) + (begin (log-optimization "derived pair" pair-opt-msg this-syntax) #'e.opt)) (pattern (#%plain-app op:pair-op p:expr) #:when (or (has-pair-type? #'p) @@ -52,13 +57,13 @@ ;; a type error (begin (log-pair-missed-opt this-syntax #'p) #f)) #:with opt - (begin (log-optimization "pair" this-syntax) + (begin (log-pair-opt this-syntax) #`(op.unsafe #,((optimize) #'p)))) (pattern (#%plain-app op:mpair-op p:expr e:expr ...) #:when (or (has-mpair-type? #'p) (begin (log-pair-missed-opt this-syntax #'p) #f)) #:with opt - (begin (log-optimization "mutable pair" this-syntax) + (begin (log-pair-opt this-syntax) #`(op.unsafe #,@(syntax-map (optimize) #'(p e ...)))))) diff --git a/collects/typed-scheme/optimizer/sequence.rkt b/collects/typed-scheme/optimizer/sequence.rkt index 964993cf8a..aabb3ecd13 100644 --- a/collects/typed-scheme/optimizer/sequence.rkt +++ b/collects/typed-scheme/optimizer/sequence.rkt @@ -30,6 +30,8 @@ [_ #f]) #:with opt ((optimize) #'e))) +(define seq-opt-msg "Sequence type specialization.") + (define-syntax-class sequence-opt-expr #:commit ;; if we're iterating (with the for macros) over something we know is a list, @@ -38,7 +40,7 @@ #:when (id-from? #'op 'make-sequence 'racket/private/for) #:with l*:list-expr #'l #:with opt - (begin (log-optimization "in-list" this-syntax) + (begin (log-optimization "in-list" seq-opt-msg this-syntax) #'(let ((i l*.opt)) (values unsafe-car unsafe-cdr i (lambda (x) (not (null? x))) @@ -49,7 +51,7 @@ #:when (id-from? #'op 'make-sequence 'racket/private/for) #:with v*:vector-expr #'v #:with opt - (begin (log-optimization "in-vector" this-syntax) + (begin (log-optimization "in-vector" seq-opt-msg this-syntax) #'(let* ((i v*.opt) (len (unsafe-vector-length i))) (values (lambda (x) (unsafe-vector-ref i x)) @@ -63,7 +65,7 @@ #:when (id-from? #'op 'make-sequence 'racket/private/for) #:with s*:string-expr #'s #:with opt - (begin (log-optimization "in-string" this-syntax) + (begin (log-optimization "in-string" seq-opt-msg this-syntax) #'(let* ((i s*.opt) (len (string-length i))) (values (lambda (x) (string-ref i x)) @@ -76,7 +78,7 @@ #:when (id-from? #'op 'make-sequence 'racket/private/for) #:with s*:bytes-expr #'s #:with opt - (begin (log-optimization "in-bytes" this-syntax) + (begin (log-optimization "in-bytes" seq-opt-msg this-syntax) #'(let* ((i s*.opt) (len (bytes-length i))) (values (lambda (x) (bytes-ref i x)) diff --git a/collects/typed-scheme/optimizer/string.rkt b/collects/typed-scheme/optimizer/string.rkt index 13024e1284..2f9ee68bcb 100644 --- a/collects/typed-scheme/optimizer/string.rkt +++ b/collects/typed-scheme/optimizer/string.rkt @@ -23,9 +23,13 @@ #:commit (pattern (#%plain-app (~literal string-length) s:string-expr) #:with opt - (begin (log-optimization "string-length" this-syntax) + (begin (log-optimization "string-length" + "String check elimination." + this-syntax) #'(unsafe-string-length s.opt))) (pattern (#%plain-app (~literal bytes-length) s:bytes-expr) #:with opt - (begin (log-optimization "bytes-length" this-syntax) + (begin (log-optimization "bytes-length" + "Byte string check elimination." + this-syntax) #'(unsafe-bytes-length s.opt)))) diff --git a/collects/typed-scheme/optimizer/struct.rkt b/collects/typed-scheme/optimizer/struct.rkt index c91015a111..d5c5920237 100644 --- a/collects/typed-scheme/optimizer/struct.rkt +++ b/collects/typed-scheme/optimizer/struct.rkt @@ -8,6 +8,8 @@ (provide struct-opt-expr) +(define struct-opt-msg "Struct access specialization.") + (define-syntax-class struct-opt-expr #:commit ;; we can always optimize struct accessors and mutators @@ -17,8 +19,8 @@ #:with opt (let ([idx (struct-fn-idx #'op)]) (if (struct-accessor? #'op) - (begin (log-optimization "struct ref" this-syntax) + (begin (log-optimization "struct ref" struct-opt-msg this-syntax) #`(unsafe-struct-ref #,((optimize) #'s) #,idx)) - (begin (log-optimization "struct set" this-syntax) + (begin (log-optimization "struct set" struct-opt-msg this-syntax) #`(unsafe-struct-set! #,((optimize) #'s) #,idx #,@(syntax-map (optimize) #'(v ...)))))))) diff --git a/collects/typed-scheme/optimizer/unboxed-let.rkt b/collects/typed-scheme/optimizer/unboxed-let.rkt index e751fa0c7c..5278ec53bd 100644 --- a/collects/typed-scheme/optimizer/unboxed-let.rkt +++ b/collects/typed-scheme/optimizer/unboxed-let.rkt @@ -39,7 +39,9 @@ #'unboxed-info #'operator.opt)) this-syntax #:with opt - (begin (log-optimization "unboxed let loop" #'loop-fun) + (begin (log-optimization "unboxed let loop" + arity-raising-opt-msg + #'loop-fun) #'e*.opt))) ;; does the bulk of the work @@ -99,9 +101,10 @@ (and (> (length unboxed) 0) ;; if so, add to the table of functions with ;; unboxed params, so we can modify its call - ;; sites, it's body and its header + ;; sites, its body and its header (begin (log-optimization "unboxed function -> table" + arity-raising-opt-msg fun-name) #t) (dict-set! unboxed-funs-table fun-name @@ -112,6 +115,7 @@ (car params) #'(begin body ...))) ;; we can unbox (log-optimization "unboxed var -> table" + arity-raising-opt-msg (car params)) (loop (cons i unboxed) boxed (add1 i) (cdr params) (cdr doms))] @@ -128,7 +132,9 @@ #:with opt (begin (when (not (null? (syntax->list #'(opt-candidates.id ...)))) ;; only log when we actually optimize - (log-optimization "unboxed let bindings" this-syntax)) + (log-optimization "unboxed let bindings" + arity-raising-opt-msg + this-syntax)) ;; add the unboxed bindings to the table, for them to be used by ;; further optimizations (for ((v (in-list (syntax->list #'(opt-candidates.id ...)))) @@ -294,7 +300,7 @@ #'(to-unbox ...)) #:with res (begin - (log-optimization "fun -> unboxed fun" #'v) + (log-optimization "fun -> unboxed fun" arity-raising-opt-msg #'v) ;; add unboxed parameters to the unboxed vars table (let ((to-unbox (syntax-map syntax->datum #'(to-unbox ...)))) (let loop ((params (syntax->list #'params)) diff --git a/collects/typed-scheme/optimizer/vector.rkt b/collects/typed-scheme/optimizer/vector.rkt index cfc64ab3c9..52e62600b0 100644 --- a/collects/typed-scheme/optimizer/vector.rkt +++ b/collects/typed-scheme/optimizer/vector.rkt @@ -37,7 +37,9 @@ (~literal unsafe-vector*-length))) v:known-length-vector-expr) #:with opt - (begin (log-optimization "known-length vector-length" this-syntax) + (begin (log-optimization "known-length vector-length" + "Static vector length computation." + this-syntax) (match (type-of #'v) [(tc-result1: (HeterogenousVector: es)) #`(begin v.opt #,(length es))]))) ; v may have side effects @@ -46,12 +48,12 @@ ;; we can optimize no matter what. (pattern (#%plain-app (~and op (~literal vector-length)) v:expr) #:with opt - (begin (log-optimization "vector-length" this-syntax) + (begin (log-optimization "vector-length" "Vector check elimination." this-syntax) #`(unsafe-vector-length #,((optimize) #'v)))) ;; same for flvector-length (pattern (#%plain-app (~and op (~literal flvector-length)) v:expr) #:with opt - (begin (log-optimization "flvector-length" this-syntax) + (begin (log-optimization "flvector-length" "Float vector check elimination." this-syntax) #`(unsafe-flvector-length #,((optimize) #'v)))) ;; we can optimize vector ref and set! on vectors of known length if we know ;; the index is within bounds (for now, literal or singleton type) @@ -65,7 +67,7 @@ [_ #f])))) (and (integer? ival) (exact? ival) (<= 0 ival (sub1 len)))) #:with opt - (begin (log-optimization "vector" this-syntax) + (begin (log-optimization "vector" "Vector bounds checking elimination." this-syntax) #`(op.unsafe v.opt #,((optimize) #'i) #,@(syntax-map (optimize) #'(new ...)))))