From bc5339d19cf46f88fa27432b90d0d56624b0e738 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 11 Aug 2011 14:52:13 -0400 Subject: [PATCH] Add disappeared uses to have optimized code play nice with check-syntax. original commit: 281e1003e3ef60892188e8b4f5313f8fdd9e4c72 --- collects/typed-scheme/core.rkt | 6 ++-- collects/typed-scheme/optimizer/apply.rkt | 7 ++++- collects/typed-scheme/optimizer/box.rkt | 2 ++ collects/typed-scheme/optimizer/fixnum.rkt | 28 ++++++++++++++++--- .../typed-scheme/optimizer/float-complex.rkt | 24 ++++++++++++++-- collects/typed-scheme/optimizer/float.rkt | 12 +++++++- collects/typed-scheme/optimizer/list.rkt | 3 ++ collects/typed-scheme/optimizer/number.rkt | 2 ++ collects/typed-scheme/optimizer/pair.rkt | 3 ++ collects/typed-scheme/optimizer/string.rkt | 7 +++-- collects/typed-scheme/optimizer/struct.rkt | 2 ++ collects/typed-scheme/optimizer/vector.rkt | 7 +++++ 12 files changed, 90 insertions(+), 13 deletions(-) diff --git a/collects/typed-scheme/core.rkt b/collects/typed-scheme/core.rkt index 3fd8f24b..658ddde1 100644 --- a/collects/typed-scheme/core.rkt +++ b/collects/typed-scheme/core.rkt @@ -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))))))])) diff --git a/collects/typed-scheme/optimizer/apply.rkt b/collects/typed-scheme/optimizer/apply.rkt index 062f2691..73dc5f2c 100644 --- a/collects/typed-scheme/optimizer/apply.rkt +++ b/collects/typed-scheme/optimizer/apply.rkt @@ -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) diff --git a/collects/typed-scheme/optimizer/box.rkt b/collects/typed-scheme/optimizer/box.rkt index 241b8de0..a5e15b5b 100644 --- a/collects/typed-scheme/optimizer/box.rkt +++ b/collects/typed-scheme/optimizer/box.rkt @@ -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 ...)))))) diff --git a/collects/typed-scheme/optimizer/fixnum.rkt b/collects/typed-scheme/optimizer/fixnum.rkt index 8aa5e07d..f541386e 100644 --- a/collects/typed-scheme/optimizer/fixnum.rkt +++ b/collects/typed-scheme/optimizer/fixnum.rkt @@ -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)))) diff --git a/collects/typed-scheme/optimizer/float-complex.rkt b/collects/typed-scheme/optimizer/float-complex.rkt index 34be8c15..67a5532e 100644 --- a/collects/typed-scheme/optimizer/float-complex.rkt +++ b/collects/typed-scheme/optimizer/float-complex.rkt @@ -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 diff --git a/collects/typed-scheme/optimizer/float.rkt b/collects/typed-scheme/optimizer/float.rkt index fcdb6ccb..b6620a22 100644 --- a/collects/typed-scheme/optimizer/float.rkt +++ b/collects/typed-scheme/optimizer/float.rkt @@ -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)))) diff --git a/collects/typed-scheme/optimizer/list.rkt b/collects/typed-scheme/optimizer/list.rkt index fb822759..e6965a58 100644 --- a/collects/typed-scheme/optimizer/list.rkt +++ b/collects/typed-scheme/optimizer/list.rkt @@ -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))])))) diff --git a/collects/typed-scheme/optimizer/number.rkt b/collects/typed-scheme/optimizer/number.rkt index 5e180bda..3aecb681 100644 --- a/collects/typed-scheme/optimizer/number.rkt +++ b/collects/typed-scheme/optimizer/number.rkt @@ -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)))) diff --git a/collects/typed-scheme/optimizer/pair.rkt b/collects/typed-scheme/optimizer/pair.rkt index bef64473..ffdae500 100644 --- a/collects/typed-scheme/optimizer/pair.rkt +++ b/collects/typed-scheme/optimizer/pair.rkt @@ -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 ...)))))) diff --git a/collects/typed-scheme/optimizer/string.rkt b/collects/typed-scheme/optimizer/string.rkt index 2f9ee68b..974180ec 100644 --- a/collects/typed-scheme/optimizer/string.rkt +++ b/collects/typed-scheme/optimizer/string.rkt @@ -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)))) diff --git a/collects/typed-scheme/optimizer/struct.rkt b/collects/typed-scheme/optimizer/struct.rkt index d5c59202..394d19c6 100644 --- a/collects/typed-scheme/optimizer/struct.rkt +++ b/collects/typed-scheme/optimizer/struct.rkt @@ -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)) diff --git a/collects/typed-scheme/optimizer/vector.rkt b/collects/typed-scheme/optimizer/vector.rkt index 329df5a3..ef289327 100644 --- a/collects/typed-scheme/optimizer/vector.rkt +++ b/collects/typed-scheme/optimizer/vector.rkt @@ -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)]