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

Add nicer optimization reporting messages.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-06-29 14:38:20 -04:00
parent d33c13e0f6
commit bfc4ad4225
14 changed files with 151 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/typed-scheme/optimizer/apply.rkt
View File

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

2
collects/typed-scheme/optimizer/box.rkt
View File

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

8
collects/typed-scheme/optimizer/dead-code.rkt
View File

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

32
collects/typed-scheme/optimizer/fixnum.rkt
View File

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

93
collects/typed-scheme/optimizer/float-complex.rkt
View File

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

24
collects/typed-scheme/optimizer/float.rkt
View File

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

4
collects/typed-scheme/optimizer/logging.rkt
View File

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

2
collects/typed-scheme/optimizer/number.rkt
View File

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

11
collects/typed-scheme/optimizer/pair.rkt
View File

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

10
collects/typed-scheme/optimizer/sequence.rkt
View File

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

8
collects/typed-scheme/optimizer/string.rkt
View File

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

6
collects/typed-scheme/optimizer/struct.rkt
View File

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

14
collects/typed-scheme/optimizer/unboxed-let.rkt
View File

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

10
collects/typed-scheme/optimizer/vector.rkt
View File

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