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

Add disappeared uses to have optimized code play nice with check-syntax.

Browse Source 
original commit: 281e1003e3ef60892188e8b4f5313f8fdd9e4c72
This commit is contained in:
Vincent St-Amour 2011-08-11 14:52:13 -04:00
parent 9f8918b441
commit bc5339d19c
12 changed files with 90 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/typed-scheme/core.rkt
View File

@ -30,14 +30,14 @@
(with-syntax*
(;; pmb = #%plain-module-begin
[(pmb . body2) new-mod]
;; add in syntax property on useless expression to draw check-syntax arrows
[check-syntax-help (syntax-property #'(void) 'disappeared-use (disappeared-use-todo))]
;; perform the provide transformation from [Culpepper 07]
[transformed-body (remove-provides #'body2)]
;; add the real definitions of contracts on requires
[transformed-body (change-contract-fixups #'transformed-body)]
;; potentially optimize the code based on the type information
[(optimized-body ...) (maybe-optimize #'transformed-body)])
[(optimized-body ...) (maybe-optimize #'transformed-body)]
;; add in syntax property on useless expression to draw check-syntax arrows
[check-syntax-help (syntax-property #'(void) 'disappeared-use (disappeared-use-todo))])
;; reconstruct the module with the extra code
;; use the regular %#module-begin from `racket/base' for top-level printing
(arm #`(#%module-begin optimized-body ... #,after-code check-syntax-help))))))]))

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

@ -2,6 +2,7 @@
(require syntax/parse
(for-template scheme/unsafe/ops racket/base (prefix-in k: '#%kernel))
"../utils/utils.rkt"
(utils tc-utils)
(optimizer utils logging))
(provide apply-opt-expr)
@ -15,7 +16,8 @@
(define-syntax-class apply-opt-expr
#:commit
#:literals (k:apply map #%plain-app #%app)
(pattern (#%plain-app k:apply op:apply-op (#%plain-app map f l))
(pattern (#%plain-app (~and app k:apply) op:apply-op
(#%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))]
@ -23,6 +25,9 @@
[f ((optimize) #'f)])
(log-optimization "apply-map" "apply-map deforestation."
this-syntax)
(add-disappeared-use #'app)
(add-disappeared-use #'op)
(add-disappeared-use #'m)
#'(let ([f* f])
(let lp ([v op.identity] [lst l])
(if (null? lst)

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

@ -4,6 +4,7 @@
racket/match
"../utils/utils.rkt"
(for-template scheme/base scheme/unsafe/ops)
(utils tc-utils)
(rep type-rep)
(types type-table utils)
(optimizer utils logging))
@ -29,4 +30,5 @@
(pattern (#%plain-app op:box-op b:box-expr new:expr ...)
#:with opt
(begin (log-optimization "box" "Box check elimination." this-syntax)
(add-disappeared-use #'op)
#`(op.unsafe b.opt #,@(syntax-map (optimize) #'(new ...))))))

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

@ -3,6 +3,7 @@
(require syntax/parse
"../utils/utils.rkt"
(for-template scheme/base scheme/fixnum scheme/unsafe/ops)
(utils tc-utils)
(types numeric-tower)
(optimizer utils logging))
@ -31,13 +32,19 @@
#'fxxor #'unsafe-fxxor))
(define-syntax-class fixnum-unary-op
#:commit
(pattern (~or (~literal bitwise-not) (~literal fxnot)) #:with unsafe #'unsafe-fxnot))
(pattern (~or (~literal bitwise-not) (~literal fxnot))
#:with unsafe (begin (add-disappeared-use this-syntax)
#'unsafe-fxnot)))
;; closed on fixnums, but 2nd argument must not be 0
(define-syntax-class nonzero-fixnum-binary-op
#:commit
;; quotient is not closed. (quotient most-negative-fixnum -1) is not a fixnum
(pattern (~or (~literal modulo) (~literal fxmodulo)) #:with unsafe #'unsafe-fxmodulo)
(pattern (~or (~literal remainder) (~literal fxremainder)) #:with unsafe #'unsafe-fxremainder))
(pattern (~or (~literal modulo) (~literal fxmodulo))
#:with unsafe (begin (add-disappeared-use this-syntax)
#'unsafe-fxmodulo))
(pattern (~or (~literal remainder) (~literal fxremainder))
#:with unsafe (begin (add-disappeared-use this-syntax)
#'unsafe-fxremainder)))
;; these operations are not closed on fixnums, but we can sometimes guarantee
;; that results will be within fixnum range
@ -53,7 +60,8 @@
#:commit
(pattern i:id
#:when (dict-ref tbl #'i #f)
#:with unsafe (dict-ref tbl #'i)))
#:with unsafe (begin (add-disappeared-use #'i)
(dict-ref tbl #'i))))
(define-syntax-class fixnum-expr
@ -108,16 +116,19 @@
(pattern (#%plain-app (~and op (~literal -)) f:fixnum-expr)
#:with opt
(begin (log-optimization "unary fixnum" fixnum-opt-msg this-syntax)
(add-disappeared-use #'op)
#'(unsafe-fx- 0 f.opt)))
(pattern (#%plain-app (~and op (~literal exact->inexact)) n:fixnum-expr)
#:with opt
(begin (log-optimization "fixnum to float" fixnum-opt-msg this-syntax)
(add-disappeared-use #'op)
#'(unsafe-fx->fl n.opt)))
(pattern (#%plain-app (~and op (~literal zero?)) n:fixnum-expr)
#:with opt
(begin (log-optimization "fixnum zero?" fixnum-opt-msg this-syntax)
(add-disappeared-use #'op)
#'(unsafe-fx= n.opt 0)))
;; The following are not closed on fixnums, but we can guarantee that results
@ -128,6 +139,7 @@
#:when (check-if-safe this-syntax)
#:with opt
(begin (log-optimization "fixnum bounded expr" fixnum-opt-msg this-syntax)
(add-disappeared-use #'op)
(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)))))
@ -136,6 +148,7 @@
#:when (check-if-safe this-syntax)
#:with opt
(begin (log-optimization "nonzero fixnum bounded expr" fixnum-opt-msg this-syntax)
(add-disappeared-use #'op)
#'(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
@ -150,6 +163,7 @@
safe-to-opt?)
#:with opt
(begin (log-optimization "fixnum fx+" fixnum-opt-msg this-syntax)
(add-disappeared-use #'op)
#'(unsafe-fx+ n1.opt n2.opt)))
(pattern (#%plain-app (~and op (~literal fx-)) n1:fixnum-expr n2:fixnum-expr)
#:when (let ([safe-to-opt? (and (subtypeof? #'n1 -NonNegFixnum)
@ -159,6 +173,7 @@
safe-to-opt?)
#:with opt
(begin (log-optimization "fixnum fx-" fixnum-opt-msg this-syntax)
(add-disappeared-use #'op)
#'(unsafe-fx- n1.opt n2.opt)))
(pattern (#%plain-app (~and op (~literal fx*)) n1:fixnum-expr n2:fixnum-expr)
#:when (let ([safe-to-opt? (and (subtypeof? #'n1 -Byte)
@ -168,6 +183,7 @@
safe-to-opt?)
#:with opt
(begin (log-optimization "fixnum fx*" fixnum-opt-msg this-syntax)
(add-disappeared-use #'op)
#'(unsafe-fx* n1.opt n2.opt)))
(pattern (#%plain-app (~and op (~literal fxquotient)) n1:fixnum-expr n2:fixnum-expr)
#:when (let ([safe-to-opt? (and (subtypeof? #'n1 -NonNegFixnum)
@ -177,6 +193,7 @@
safe-to-opt?)
#:with opt
(begin (log-optimization "fixnum fxquotient" fixnum-opt-msg this-syntax)
(add-disappeared-use #'op)
#'(unsafe-fxquotient n1.opt n2.opt)))
(pattern (#%plain-app (~and op (~or (~literal fxabs) (~literal abs))) n:fixnum-expr)
#:when (let ([safe-to-opt? (subtypeof? #'n -NonNegFixnum)]) ; (abs min-fixnum) is not a fixnum
@ -185,15 +202,18 @@
safe-to-opt?)
#:with opt
(begin (log-optimization "fixnum fxabs" fixnum-opt-msg this-syntax)
(add-disappeared-use #'op)
#'(unsafe-fxabs n.opt)))
(pattern (#%plain-app (~and op (~literal add1)) n:fixnum-expr)
#:when (check-if-safe this-syntax)
#:with opt
(begin (log-optimization "fixnum add1" fixnum-opt-msg this-syntax)
(add-disappeared-use #'op)
#'(unsafe-fx+ n.opt 1)))
(pattern (#%plain-app (~and op (~literal sub1)) n:fixnum-expr)
#:when (check-if-safe this-syntax)
#:with opt
(begin (log-optimization "fixnum sub1" fixnum-opt-msg this-syntax)
(add-disappeared-use #'op)
#'(unsafe-fx- n.opt 1))))

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

@ -3,6 +3,7 @@
(require syntax/parse syntax/id-table scheme/dict unstable/syntax
"../utils/utils.rkt" racket/unsafe/ops
(for-template scheme/base scheme/math racket/flonum scheme/unsafe/ops)
(utils tc-utils)
(types numeric-tower)
(optimizer utils numeric-utils logging float))
@ -47,6 +48,7 @@
(begin (log-optimization "unboxed binary float complex"
complex-unboxing-opt-msg
this-syntax)
(add-disappeared-use #'op)
#`(#,@(append (syntax->list #'(c1.bindings ... c2.bindings ... cs.bindings ... ...))
(let ()
;; we can skip the real parts of imaginaries (#f) and vice versa
@ -74,6 +76,7 @@
(begin (log-optimization "unboxed binary float complex"
complex-unboxing-opt-msg
this-syntax)
(add-disappeared-use #'op)
#`(#,@(append (syntax->list #'(c1.bindings ... c2.bindings ... cs.bindings ... ...))
(let ()
;; unlike addition, we simply can't skip real parts of imaginaries
@ -103,6 +106,7 @@
(begin (log-optimization "unboxed binary float complex"
complex-unboxing-opt-msg
this-syntax)
(add-disappeared-use #'op)
#`(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
@ -158,6 +162,7 @@
(begin (log-optimization "unboxed binary float complex"
complex-unboxing-opt-msg
this-syntax)
(add-disappeared-use #'op)
#`(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
@ -224,6 +229,7 @@
(begin (log-optimization "unboxed unary float complex"
complex-unboxing-opt-msg
this-syntax)
(add-disappeared-use #'op)
#`(#,@(append (syntax->list #'(c.bindings ...))
(list #'((imag-binding) (unsafe-fl- 0.0 c.imag-binding)))))))
@ -234,6 +240,7 @@
(begin (log-optimization "unboxed unary float complex"
complex-unboxing-opt-msg
this-syntax)
(add-disappeared-use #'op)
#`(c.bindings ...
((real-binding) (unsafe-flsqrt
(unsafe-fl+ (unsafe-fl* c.real-binding c.real-binding)
@ -247,6 +254,7 @@
(begin (log-optimization "unboxed unary float complex"
complex-unboxing-opt-msg
this-syntax)
(add-disappeared-use #'op)
#'(c.bindings ...)))
(pattern (#%plain-app (~and op (~or (~literal imag-part) (~literal unsafe-flimag-part)))
c:unboxed-float-complex-opt-expr)
@ -256,6 +264,7 @@
(begin (log-optimization "unboxed unary float complex"
complex-unboxing-opt-msg
this-syntax)
(add-disappeared-use #'op)
#'(c.bindings ...)))
;; special handling of reals inside complex operations
@ -280,6 +289,7 @@
(begin (log-optimization "make-rectangular elimination"
complex-unboxing-opt-msg
this-syntax)
(add-disappeared-use #'op)
#'(((real-binding) real.opt)
((imag-binding) imag.opt))))
(pattern (#%plain-app (~and op (~literal make-polar))
@ -292,6 +302,7 @@
(begin (log-optimization "make-rectangular elimination"
complex-unboxing-opt-msg
this-syntax)
(add-disappeared-use #'op)
#'(((magnitude) r.opt)
((angle) theta.opt)
((real-binding) (unsafe-fl* magnitude (unsafe-flcos angle)))
@ -373,8 +384,12 @@
(define-syntax-class float-complex-unary-op
#:commit
(pattern (~or (~literal real-part) (~literal flreal-part)) #:with unsafe #'unsafe-flreal-part)
(pattern (~or (~literal imag-part) (~literal flimag-part)) #:with unsafe #'unsafe-flimag-part))
(pattern (~or (~literal real-part) (~literal flreal-part))
#:with unsafe (begin (add-disappeared-use this-syntax)
#'unsafe-flreal-part))
(pattern (~or (~literal imag-part) (~literal flimag-part))
#:with unsafe (begin (add-disappeared-use this-syntax)
#'unsafe-flimag-part)))
(define-syntax-class float-complex-op
#:commit
@ -434,6 +449,7 @@
(begin (log-optimization "complex accessor elimination"
complex-unboxing-opt-msg
this-syntax)
(add-disappeared-use #'op)
(reset-unboxed-gensym)
#`(let*-values (c*.bindings ...)
#,(if (or (free-identifier=? #'op #'real-part)
@ -456,6 +472,7 @@
(begin (log-optimization "make-polar"
complex-unboxing-opt-msg
this-syntax)
(add-disappeared-use #'op)
(reset-unboxed-gensym)
#'(let*-values (exp*.bindings ...)
(unsafe-make-flrectangular exp*.real-binding
@ -487,6 +504,7 @@
#:with (bindings ...) #'(exp*.bindings ...)
#:with opt
(begin (reset-unboxed-gensym)
(add-disappeared-use #'op)
#'(let*-values (exp*.bindings ...)
real-binding)))
@ -498,6 +516,7 @@
#:with (bindings ...) #'(exp*.bindings ...)
#:with opt
(begin (reset-unboxed-gensym)
(add-disappeared-use #'op)
#'(let*-values (exp*.bindings ...)
(unsafe-make-flrectangular exp*.real-binding exp*.imag-binding))))
@ -535,6 +554,7 @@
(log-optimization "unboxed call site"
complex-unboxing-opt-msg
this-syntax)
(add-disappeared-use #'op)
(reset-unboxed-gensym)
#`(let*-values (e.bindings ... ...)
(#%plain-app #,opt-operator

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

@ -4,6 +4,7 @@
racket/dict racket/flonum
(for-template racket/base racket/flonum racket/unsafe/ops racket/math)
"../utils/utils.rkt"
(utils tc-utils)
(types numeric-tower type-table)
(optimizer utils numeric-utils logging fixnum))
@ -31,7 +32,8 @@
#:commit
(pattern i:id
#:when (dict-ref tbl #'i #f)
#:with unsafe (dict-ref tbl #'i)))
#:with unsafe (begin (add-disappeared-use #'i)
(dict-ref tbl #'i))))
(define-syntax-class float-expr
#:commit
@ -161,37 +163,45 @@
(pattern (#%plain-app (~and op (~literal -)) f:float-expr)
#:with opt
(begin (log-optimization "unary float" float-opt-msg this-syntax)
(add-disappeared-use #'op)
#'(unsafe-fl- 0.0 f.opt)))
(pattern (#%plain-app (~and op (~literal /)) f:float-expr)
#:with opt
(begin (log-optimization "unary float" float-opt-msg this-syntax)
(add-disappeared-use #'op)
#'(unsafe-fl/ 1.0 f.opt)))
(pattern (#%plain-app (~and op (~literal sqr)) f:float-expr)
#:with opt
(begin (log-optimization "unary float" float-opt-msg this-syntax)
(add-disappeared-use #'op)
#'(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" float-opt-msg this-syntax)
(add-disappeared-use #'op)
#'(->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" float-opt-msg this-syntax)
(add-disappeared-use #'op)
#'f.opt))
(pattern (#%plain-app (~and op (~literal zero?)) f:float-expr)
#:with opt
(begin (log-optimization "float zero?" float-opt-msg this-syntax)
(add-disappeared-use #'op)
#'(unsafe-fl= f.opt 0.0)))
(pattern (#%plain-app (~and op (~literal add1)) n:float-expr)
#:with opt
(begin (log-optimization "float add1" float-opt-msg this-syntax)
(add-disappeared-use #'op)
#'(unsafe-fl+ n.opt 1.0)))
(pattern (#%plain-app (~and op (~literal sub1)) n:float-expr)
#:with opt
(begin (log-optimization "float sub1" float-opt-msg this-syntax)
(add-disappeared-use #'op)
#'(unsafe-fl- n.opt 1.0))))

3
collects/typed-scheme/optimizer/list.rkt
View File

@ -2,6 +2,7 @@
(require syntax/parse racket/match
"../utils/utils.rkt"
(utils tc-utils)
(rep type-rep)
(types abbrev utils type-table)
(optimizer utils logging)
@ -44,6 +45,7 @@
(begin (log-optimization "known-length list op"
"List access specialization."
this-syntax)
(add-disappeared-use #'op)
#`(op.unsafe l.opt #,((optimize) #'i))))
;; We know the length of known-length lists statically.
(pattern (#%plain-app (~and op (~literal length)) l:known-length-list-expr)
@ -51,6 +53,7 @@
(begin (log-optimization "known-length list length"
"Static list length computation."
this-syntax)
(add-disappeared-use #'op)
(match (type-of #'l)
[(tc-result1: (List: es))
#`(begin l.opt #,(length es))]))))

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

@ -3,6 +3,7 @@
(require syntax/parse
(for-template scheme/base)
"../utils/utils.rkt"
(utils tc-utils)
(optimizer utils logging))
(provide number-opt-expr)
@ -16,4 +17,5 @@
#:with opt
(begin (log-optimization "unary number" "Identity elimination."
this-syntax)
(add-disappeared-use #'op)
((optimize) #'f))))

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

@ -4,6 +4,7 @@
racket/match
(for-template scheme/base scheme/unsafe/ops)
"../utils/utils.rkt"
(utils tc-utils)
(rep type-rep)
(types type-table utils)
(typecheck typechecker)
@ -58,12 +59,14 @@
(begin (log-pair-missed-opt this-syntax #'p) #f))
#:with opt
(begin (log-pair-opt this-syntax)
(add-disappeared-use #'op)
#`(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-pair-opt this-syntax)
(add-disappeared-use #'op)
#`(op.unsafe #,@(syntax-map (optimize) #'(p e ...))))))

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

@ -3,6 +3,7 @@
(require syntax/parse
(for-template scheme/base scheme/unsafe/ops)
"../utils/utils.rkt"
(utils tc-utils)
(types abbrev)
(optimizer utils logging))
@ -21,15 +22,17 @@
(define-syntax-class string-opt-expr
#:commit
(pattern (#%plain-app (~literal string-length) s:string-expr)
(pattern (#%plain-app (~and op (~literal string-length)) s:string-expr)
#:with opt
(begin (log-optimization "string-length"
"String check elimination."
this-syntax)
(add-disappeared-use #'op)
#'(unsafe-string-length s.opt)))
(pattern (#%plain-app (~literal bytes-length) s:bytes-expr)
(pattern (#%plain-app (~and op (~literal bytes-length)) s:bytes-expr)
#:with opt
(begin (log-optimization "bytes-length"
"Byte string check elimination."
this-syntax)
(add-disappeared-use #'op)
#'(unsafe-bytes-length s.opt))))

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

@ -3,6 +3,7 @@
(require syntax/parse unstable/syntax
(for-template scheme/base scheme/unsafe/ops)
"../utils/utils.rkt"
(utils tc-utils)
(types type-table)
(optimizer utils logging))
@ -18,6 +19,7 @@
#:when (or (struct-accessor? #'op) (struct-mutator? #'op))
#:with opt
(let ([idx (struct-fn-idx #'op)])
(add-disappeared-use #'op)
(if (struct-accessor? #'op)
(begin (log-optimization "struct ref" struct-opt-msg this-syntax)
#`(unsafe-struct-ref #,((optimize) #'s) #,idx))

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

@ -4,6 +4,7 @@
racket/match racket/flonum
(for-template scheme/base racket/flonum scheme/unsafe/ops)
"../utils/utils.rkt"
(utils tc-utils)
(rep type-rep)
(types type-table utils numeric-tower)
(optimizer utils logging fixnum))
@ -40,6 +41,7 @@
(begin (log-optimization "known-length vector-length"
"Static vector length computation."
this-syntax)
(add-disappeared-use #'op)
(match (type-of #'v)
[(tc-result1: (HeterogenousVector: es))
#`(begin v.opt #,(length es))]))) ; v may have side effects
@ -49,11 +51,13 @@
(pattern (#%plain-app (~and op (~literal vector-length)) v:expr)
#:with opt
(begin (log-optimization "vector-length" "Vector check elimination." this-syntax)
(add-disappeared-use #'op)
#`(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" "Float vector check elimination." this-syntax)
(add-disappeared-use #'op)
#`(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)
@ -68,6 +72,7 @@
(and (integer? ival) (exact? ival) (<= 0 ival (sub1 len))))
#:with opt
(begin (log-optimization "vector" "Vector bounds checking elimination." this-syntax)
(add-disappeared-use #'op)
#`(op.unsafe v.opt #,((optimize) #'i)
#,@(syntax-map (optimize) #'(new ...)))))
@ -77,6 +82,7 @@
(begin (log-optimization "vector partial bounds checking elimination"
"Partial bounds checking elimination."
this-syntax)
(add-disappeared-use #'op)
(let ([safe-fallback #`(op new-v new-i #,@(syntax-map (optimize) #'(new ...)))]
[i-known-nonneg? (subtypeof? #'i -NonNegFixnum)])
#`(let ([new-i #,((optimize) #'i)]
@ -105,6 +111,7 @@
(begin (log-optimization "flvector partial bounds checking elimination"
"Partial bounds checking elimination."
this-syntax)
(add-disappeared-use #'op)
(let ([safe-fallback #`(op new-v new-i #,@(syntax-map (optimize) #'(new ...)))]
[i-known-nonneg? (subtypeof? #'i -NonNegFixnum)])
#`(let ([new-i #,((optimize) #'i)]