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

Added fixnum optimizations.

Browse Source 
original commit: dfafc0b2958debe3953aa6c525a737f8c63859c8
This commit is contained in:
Vincent St-Amour 2010-06-25 16:50:06 -04:00
parent 18155bf2c5
commit d89e82755f
12 changed files with 116 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/tests/typed-scheme/optimizer/generic/binary-fixnum.rkt Normal file
View File

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

3
collects/tests/typed-scheme/optimizer/generic/binary-nonzero-fixnum.rkt Normal file
View File

@ -0,0 +1,3 @@
(module binary-nonzero-fixnum typed/scheme #:optimize
(require racket/unsafe/ops)
(quotient (vector-length '#(1 2 3)) 2))

3
collects/tests/typed-scheme/optimizer/generic/exact-inexact.rkt Normal file
View File

@ -0,0 +1,3 @@
(module exact-inexact typed/scheme #:optimize
(require racket/flonum)
(exact->inexact (expt 10 100))) ; must not be a fixnum

3
collects/tests/typed-scheme/optimizer/generic/fixnum-comparison.rkt Normal file
View File

@ -0,0 +1,3 @@
(module fixnum-comparison typed/scheme #:optimize
(require racket/unsafe/ops)
(< (vector-length '#(1 2 3)) (string-length "asdf")))

3
collects/tests/typed-scheme/optimizer/generic/float-comp.rkt Normal file
View File

@ -0,0 +1,3 @@
(module float-comp typed/scheme #:optimize
(require racket/unsafe/ops)
(< 1.0 2.0))

3
collects/tests/typed-scheme/optimizer/generic/fx-fl.rkt Normal file
View File

@ -0,0 +1,3 @@
(module fx-fl typed/scheme #:optimize
(require racket/unsafe/ops)
(exact->inexact 1))

4
collects/tests/typed-scheme/optimizer/generic/invalid-binary-nonzero-fixnum.rkt Normal file
View File

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

2
collects/tests/typed-scheme/optimizer/generic/invalid-exact-inexact.rkt Normal file
View File

@ -0,0 +1,2 @@
(module exact-inexact typed/scheme #:optimize
(exact->inexact 1.0)) ; not an integer, can't optimize

3
collects/tests/typed-scheme/optimizer/generic/invalid-float-comp.rkt Normal file
View File

@ -0,0 +1,3 @@
(module float-comp typed/scheme #:optimize
(require racket/unsafe/ops)
(< 1.0 2))

3
collects/tests/typed-scheme/optimizer/generic/unary-fixnum-nested.rkt Normal file
View File

@ -0,0 +1,3 @@
(module unary-fixnum-nested typed/scheme #:optimize
(require racket/unsafe/ops racket/fixnum)
(abs (bitwise-not (length '(1 2 3)))))

3
collects/tests/typed-scheme/optimizer/generic/unary-fixnum.rkt Normal file
View File

@ -0,0 +1,3 @@
(module unary-fixnum typed/scheme #:optimize
(require racket/unsafe/ops)
(bitwise-not 4))

92
collects/typed-scheme/private/optimize.rkt
View File

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