diff --git a/collects/tests/typed-scheme/optimizer/generic/binary-fixnum.rkt b/collects/tests/typed-scheme/optimizer/generic/binary-fixnum.rkt new file mode 100644 index 0000000000..6c1dcba32f --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/binary-fixnum.rkt @@ -0,0 +1,5 @@ +(module binary-fixnum typed/scheme #:optimize + (require racket/unsafe/ops) + (: f (All (X) ((Vectorof X) -> Natural))) + (define (f v) + (bitwise-and (vector-length v) 1))) diff --git a/collects/tests/typed-scheme/optimizer/generic/binary-nonzero-fixnum.rkt b/collects/tests/typed-scheme/optimizer/generic/binary-nonzero-fixnum.rkt new file mode 100644 index 0000000000..0e5c46a638 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/binary-nonzero-fixnum.rkt @@ -0,0 +1,3 @@ +(module binary-nonzero-fixnum typed/scheme #:optimize + (require racket/unsafe/ops) + (quotient (vector-length '#(1 2 3)) 2)) diff --git a/collects/tests/typed-scheme/optimizer/generic/exact-inexact.rkt b/collects/tests/typed-scheme/optimizer/generic/exact-inexact.rkt new file mode 100644 index 0000000000..f19e381299 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/exact-inexact.rkt @@ -0,0 +1,3 @@ +(module exact-inexact typed/scheme #:optimize + (require racket/flonum) + (exact->inexact (expt 10 100))) ; must not be a fixnum diff --git a/collects/tests/typed-scheme/optimizer/generic/fixnum-comparison.rkt b/collects/tests/typed-scheme/optimizer/generic/fixnum-comparison.rkt new file mode 100644 index 0000000000..905b4c8be5 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/fixnum-comparison.rkt @@ -0,0 +1,3 @@ +(module fixnum-comparison typed/scheme #:optimize + (require racket/unsafe/ops) + (< (vector-length '#(1 2 3)) (string-length "asdf"))) diff --git a/collects/tests/typed-scheme/optimizer/generic/float-comp.rkt b/collects/tests/typed-scheme/optimizer/generic/float-comp.rkt new file mode 100644 index 0000000000..d644a1c9a7 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/float-comp.rkt @@ -0,0 +1,3 @@ +(module float-comp typed/scheme #:optimize + (require racket/unsafe/ops) + (< 1.0 2.0)) diff --git a/collects/tests/typed-scheme/optimizer/generic/fx-fl.rkt b/collects/tests/typed-scheme/optimizer/generic/fx-fl.rkt new file mode 100644 index 0000000000..ee505dfd08 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/fx-fl.rkt @@ -0,0 +1,3 @@ +(module fx-fl typed/scheme #:optimize + (require racket/unsafe/ops) + (exact->inexact 1)) diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-binary-nonzero-fixnum.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-binary-nonzero-fixnum.rkt new file mode 100644 index 0000000000..e1e94c4706 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/invalid-binary-nonzero-fixnum.rkt @@ -0,0 +1,4 @@ +(module invalid-binary-nonzero-fixnum typed/scheme #:optimize + (: f ( -> Void)) + (define (f) ; in a function, to prevent evaluation + (display (quotient 4 0)))) ; 2 fixnums, but the second is 0, cannot optimize diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-exact-inexact.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-exact-inexact.rkt new file mode 100644 index 0000000000..f0fec02575 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/invalid-exact-inexact.rkt @@ -0,0 +1,2 @@ +(module exact-inexact typed/scheme #:optimize + (exact->inexact 1.0)) ; not an integer, can't optimize diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-float-comp.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-float-comp.rkt new file mode 100644 index 0000000000..1f972d6b67 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/invalid-float-comp.rkt @@ -0,0 +1,3 @@ +(module float-comp typed/scheme #:optimize + (require racket/unsafe/ops) + (< 1.0 2)) diff --git a/collects/tests/typed-scheme/optimizer/generic/unary-fixnum-nested.rkt b/collects/tests/typed-scheme/optimizer/generic/unary-fixnum-nested.rkt new file mode 100644 index 0000000000..710197af9f --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/unary-fixnum-nested.rkt @@ -0,0 +1,3 @@ +(module unary-fixnum-nested typed/scheme #:optimize + (require racket/unsafe/ops racket/fixnum) + (abs (bitwise-not (length '(1 2 3))))) diff --git a/collects/tests/typed-scheme/optimizer/generic/unary-fixnum.rkt b/collects/tests/typed-scheme/optimizer/generic/unary-fixnum.rkt new file mode 100644 index 0000000000..b9309084a7 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/unary-fixnum.rkt @@ -0,0 +1,3 @@ +(module unary-fixnum typed/scheme #:optimize + (require racket/unsafe/ops) + (bitwise-not 4)) diff --git a/collects/tests/typed-scheme/optimizer/hand-optimized/binary-fixnum.rkt b/collects/tests/typed-scheme/optimizer/hand-optimized/binary-fixnum.rkt new file mode 100644 index 0000000000..b7c442f822 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/hand-optimized/binary-fixnum.rkt @@ -0,0 +1,5 @@ +(module binary-fixnum typed/scheme #:optimize + (require racket/unsafe/ops) + (: f (All (X) ((Vectorof X) -> Natural))) + (define (f v) + (unsafe-fxand (vector-length v) 1))) diff --git a/collects/tests/typed-scheme/optimizer/hand-optimized/binary-nonzero-fixnum.rkt b/collects/tests/typed-scheme/optimizer/hand-optimized/binary-nonzero-fixnum.rkt new file mode 100644 index 0000000000..944e65ce45 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/hand-optimized/binary-nonzero-fixnum.rkt @@ -0,0 +1,3 @@ +(module binary-nonzero-fixnum typed/scheme #:optimize + (require racket/unsafe/ops) + (unsafe-fxquotient (vector-length '#(1 2 3)) 2)) diff --git a/collects/tests/typed-scheme/optimizer/hand-optimized/exact-inexact.rkt b/collects/tests/typed-scheme/optimizer/hand-optimized/exact-inexact.rkt new file mode 100644 index 0000000000..7a86e20125 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/hand-optimized/exact-inexact.rkt @@ -0,0 +1,3 @@ +(module exact-inexact typed/scheme #:optimize + (require racket/flonum) + (->fl (expt 10 100))) ; must not be a fixnum diff --git a/collects/tests/typed-scheme/optimizer/hand-optimized/fixnum-comparison.rkt b/collects/tests/typed-scheme/optimizer/hand-optimized/fixnum-comparison.rkt new file mode 100644 index 0000000000..0f1e9f2821 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/hand-optimized/fixnum-comparison.rkt @@ -0,0 +1,3 @@ +(module fixnum-comparison typed/scheme #:optimize + (require racket/unsafe/ops) + (unsafe-fx< (vector-length '#(1 2 3)) (string-length "asdf"))) diff --git a/collects/tests/typed-scheme/optimizer/hand-optimized/float-comp.rkt b/collects/tests/typed-scheme/optimizer/hand-optimized/float-comp.rkt new file mode 100644 index 0000000000..d9d32f3fc6 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/hand-optimized/float-comp.rkt @@ -0,0 +1,3 @@ +(module float-comp typed/scheme #:optimize + (require racket/unsafe/ops) + (unsafe-fl< 1.0 2.0)) diff --git a/collects/tests/typed-scheme/optimizer/hand-optimized/fx-fl.rkt b/collects/tests/typed-scheme/optimizer/hand-optimized/fx-fl.rkt new file mode 100644 index 0000000000..a95ace83d3 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/hand-optimized/fx-fl.rkt @@ -0,0 +1,3 @@ +(module fx-fl typed/scheme #:optimize + (require racket/unsafe/ops) + (unsafe-fx->fl 1)) diff --git a/collects/tests/typed-scheme/optimizer/hand-optimized/invalid-binary-nonzero-fixnum.rkt b/collects/tests/typed-scheme/optimizer/hand-optimized/invalid-binary-nonzero-fixnum.rkt new file mode 100644 index 0000000000..e1e94c4706 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/hand-optimized/invalid-binary-nonzero-fixnum.rkt @@ -0,0 +1,4 @@ +(module invalid-binary-nonzero-fixnum typed/scheme #:optimize + (: f ( -> Void)) + (define (f) ; in a function, to prevent evaluation + (display (quotient 4 0)))) ; 2 fixnums, but the second is 0, cannot optimize diff --git a/collects/tests/typed-scheme/optimizer/hand-optimized/invalid-exact-inexact.rkt b/collects/tests/typed-scheme/optimizer/hand-optimized/invalid-exact-inexact.rkt new file mode 100644 index 0000000000..c7f63bf79c --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/hand-optimized/invalid-exact-inexact.rkt @@ -0,0 +1,2 @@ +(module exact-inexact typed/scheme #:optimize + (exact->inexact 1.0)) ; not a integer, can't optimize diff --git a/collects/tests/typed-scheme/optimizer/hand-optimized/invalid-float-comp.rkt b/collects/tests/typed-scheme/optimizer/hand-optimized/invalid-float-comp.rkt new file mode 100644 index 0000000000..1f972d6b67 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/hand-optimized/invalid-float-comp.rkt @@ -0,0 +1,3 @@ +(module float-comp typed/scheme #:optimize + (require racket/unsafe/ops) + (< 1.0 2)) diff --git a/collects/tests/typed-scheme/optimizer/hand-optimized/unary-fixnum-nested.rkt b/collects/tests/typed-scheme/optimizer/hand-optimized/unary-fixnum-nested.rkt new file mode 100644 index 0000000000..b71683bc0d --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/hand-optimized/unary-fixnum-nested.rkt @@ -0,0 +1,3 @@ +(module unary-fixnum-nested typed/scheme #:optimize + (require racket/unsafe/ops racket/fixnum) + (unsafe-fxabs (unsafe-fxnot (length '(1 2 3))))) diff --git a/collects/tests/typed-scheme/optimizer/hand-optimized/unary-fixnum.rkt b/collects/tests/typed-scheme/optimizer/hand-optimized/unary-fixnum.rkt new file mode 100644 index 0000000000..6436650f08 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/hand-optimized/unary-fixnum.rkt @@ -0,0 +1,3 @@ +(module unary-fixnum typed/scheme #:optimize + (require racket/unsafe/ops) + (unsafe-fxnot 4)) diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index b77d9802e2..6a786067cf 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -1,6 +1,6 @@ #lang scheme/base -(require syntax/parse (for-template scheme/base scheme/flonum scheme/unsafe/ops) +(require syntax/parse (for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops) "../utils/utils.rkt" unstable/match scheme/match unstable/syntax (rep type-rep) syntax/id-table racket/dict (types abbrev type-table utils subtype)) @@ -18,6 +18,20 @@ [(tc-result1: (== -Integer (lambda (x y) (subtype y x)))) #t] [_ #f]) #:with opt #'e.opt)) +(define-syntax-class fixnum-opt-expr + (pattern e:opt-expr + #:when (match (type-of #'e) + [(tc-result1: (== -Fixnum (lambda (x y) (subtype y x)))) #t] [_ #f]) + #:with opt #'e.opt)) +(define-syntax-class nonzero-fixnum-opt-expr + (pattern e:opt-expr + #:when (match (type-of #'e) + [(tc-result1: (== -PositiveFixnum type-equal?)) #t] + [(tc-result1: (== -NegativeFixnum type-equal?)) #t] + [_ #f]) + #:with opt #'e.opt)) + + ;; if the result of an operation is of type float, its non float arguments ;; can be promoted, and we can use unsafe float operations ;; note: none of the unary operations have types where non-float arguments @@ -28,16 +42,18 @@ (pattern e:float-opt-expr #:with opt #'e.opt)) -(define (mk-float-tbl generic) +(define (mk-unsafe-tbl generic safe-pattern unsafe-pattern) (for/fold ([h (make-immutable-free-id-table)]) ([g generic]) - (let ([f (format-id g "fl~a" g)] [u (format-id g "unsafe-fl~a" g)]) + (let ([f (format-id g safe-pattern g)] [u (format-id g unsafe-pattern g)]) (dict-set (dict-set h g u) f u)))) +(define (mk-float-tbl generic) + (mk-unsafe-tbl generic "fl~a" "unsafe-fl~a")) + (define binary-float-ops (mk-float-tbl (list #'+ #'- #'* #'/ #'min #'max))) (define binary-float-comps (mk-float-tbl (list #'= #'<= #'< #'> #'>=))) - (define unary-float-ops (mk-float-tbl (list #'abs #'sin #'cos #'tan #'asin #'acos #'atan #'log #'exp #'sqrt #'round #'floor #'ceiling #'truncate))) @@ -47,6 +63,42 @@ #:when (dict-ref tbl #'i #f) #:with unsafe (dict-ref tbl #'i))) + +(define (mk-fixnum-tbl generic) + (mk-unsafe-tbl generic "fx~a" "unsafe-fx~a")) + +;; due to undefined behavior when results are out of the fixnum range, only some +;; fixnum operations can be optimized +;; the following must be closed on fixnums +(define binary-fixnum-ops + (dict-set + (dict-set + (dict-set + (dict-set + (dict-set + (dict-set + (mk-fixnum-tbl (list #'= #'<= #'< #'> #'>= #'min #'max)) + #'bitwise-and #'unsafe-fxand) + #'fxand #'unsafe-fxand) + #'bitwise-ior #'unsafe-fxior) + #'fxior #'unsafe-fxior) + #'bitwise-xor #'unsafe-fxxor) + #'fxxor #'unsafe-fxxor)) +(define-syntax-class fixnum-unary-op + (pattern (~or (~literal bitwise-not) (~literal fxnot)) #:with unsafe #'unsafe-fxnot) + (pattern (~or (~literal abs) (~literal fxabs)) #:with unsafe #'unsafe-fxabs)) +;; closed on fixnums, but 2nd argument must not be 0 +(define-syntax-class nonzero-fixnum-binary-op + (pattern (~or (~literal quotient) (~literal fxquotient)) #:with unsafe #'unsafe-fxquotient) + (pattern (~or (~literal modulo) (~literal fxmodulo)) #:with unsafe #'unsafe-fxmodulo) + (pattern (~or (~literal remainder) (~literal fxremainder)) #:with unsafe #'unsafe-fxremainder)) + +(define-syntax-class (fixnum-op tbl) + (pattern i:id + #:when (dict-ref tbl #'i #f) + #:with unsafe (dict-ref tbl #'i))) + + (define-syntax-class pair-opt-expr (pattern e:opt-expr #:when (match (type-of #'e) ; type of the operand @@ -85,6 +137,12 @@ kind) #t)) +;; unlike their safe counterparts, unsafe binary operators can only take 2 arguments +(define (n-ary->binary op arg1 arg2 rest) + (for/fold ([o arg1]) + ([e (syntax->list #`(#,arg2 #,@rest))]) + #`(#,op #,o #,e))) + (define-syntax-class opt-expr* #:literal-sets (kernel-literals) @@ -93,24 +151,36 @@ #:with opt (begin (log-optimization "unary float" #'op) #'(op.unsafe f.opt))) - ;; unlike their safe counterparts, unsafe binary operators can only take 2 arguments (pattern (~and res (#%plain-app (~var op (float-op binary-float-ops)) f1:float-arg-expr f2:float-arg-expr fs:float-arg-expr ...)) #:when (match (type-of #'res) ;; if the result is a float, we can coerce integers to floats and optimize [(tc-result1: (== -Flonum type-equal?)) #t] [_ #f]) #:with opt (begin (log-optimization "binary float" #'op) - (for/fold ([o #'f1.opt]) - ([e (syntax->list #'(f2.opt fs.opt ...))]) - #`(op.unsafe #,o #,e)))) + (n-ary->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...)))) (pattern (~and res (#%plain-app (~var op (float-op binary-float-comps)) f1:float-opt-expr f2:float-opt-expr fs:float-opt-expr ...)) #:when (match (type-of #'res) [(tc-result1: (== -Boolean type-equal?)) #t] [_ #f]) #:with opt (begin (log-optimization "binary float comp" #'op) - (for/fold ([o #'f1.opt]) - ([e (syntax->list #'(f2.opt fs.opt ...))]) - #`(op.unsafe #,o #,e)))) + (n-ary->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...)))) + + (pattern (#%plain-app op:fixnum-unary-op n:fixnum-opt-expr) + #:with opt + (begin (log-optimization "unary fixnum" #'op) + #'(op.unsafe n.opt))) + (pattern (#%plain-app (~var op (fixnum-op binary-fixnum-ops)) n1:fixnum-opt-expr n2:fixnum-opt-expr ns:fixnum-opt-expr ...) + #:with opt + (begin (log-optimization "binary fixnum" #'op) + (n-ary->binary #'op.unsafe #'n1.opt #'n2.opt #'(ns.opt ...)))) + (pattern (#%plain-app op:nonzero-fixnum-binary-op n1:fixnum-opt-expr n2:nonzero-fixnum-opt-expr) + #:with opt + (begin (log-optimization "binary nonzero fixnum" #'op) + #'(op.unsafe n1.opt n2.opt))) + (pattern (#%plain-app (~and op (~literal exact->inexact)) n:fixnum-opt-expr) + #:with opt + (begin (log-optimization "fixnum to float" #'op) + #'(unsafe-fx->fl n.opt))) ;; we can optimize exact->inexact if we know we're giving it an Integer (pattern (#%plain-app (~and op (~literal exact->inexact)) n:int-opt-expr)