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

Added support for make-flrectangular, flreal-part, flimag-part and

Browse Source 
their unsafe counterparts to Typed Scheme and its optimizer.

original commit: 389a20795a5bb6db25341b899e7ec58e6eb5a0d1
This commit is contained in:
Vincent St-Amour 2010-07-02 20:57:09 -04:00
parent a3a3bd1e2e
commit ccbf54bdf7
5 changed files with 39 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -0,0 +1,2 @@
(module invalid-inexact-complex-parts.rkt typed/scheme #:optimize
(real-part 1+2i))

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

@ -0,0 +1,2 @@
(module invalid-make-flrectangular typed/scheme #:optimize
(make-rectangular 1 2))

4
collects/tests/typed-scheme/optimizer/generic/make-flrectangular.rkt Normal file
View File

@ -0,0 +1,4 @@
(module make-flrectangular typed/scheme #:optimize
(require racket/unsafe/ops racket/flonum)
(make-rectangular 1.0 2.2)
(make-flrectangular 1.0 2.2))

6
collects/typed-scheme/private/base-env-numeric.rkt
View File

@ -468,6 +468,9 @@
[unsafe-flexp fl-rounder]
[unsafe-flsqrt fl-rounder]
[unsafe-fx->fl (cl->* (-Nat . -> . -NonnegativeFlonum) (-Integer . -> . -Flonum))]
[unsafe-make-flrectangular (-Flonum -Flonum . -> . -InexactComplex)]
[unsafe-flreal-part (-InexactComplex . -> . -Flonum)]
[unsafe-flimag-part (-InexactComplex . -> . -Flonum)]
[unsafe-fx+ fx+-type]
[unsafe-fx- fx-intop]
@ -545,6 +548,9 @@
[flexp fl-unop]
[flsqrt fl-unop]
[->fl (-Integer . -> . -Flonum)]
[make-flrectangular (-Flonum -Flonum . -> . -InexactComplex)]
[flreal-part (-InexactComplex . -> . -Flonum)]
[flimag-part (-InexactComplex . -> . -Flonum)]
;; safe flvector ops

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

@ -44,7 +44,13 @@
(define binary-float-ops
(mk-float-tbl (list #'+ #'- #'* #'/ #'min #'max)))
(define binary-float-comps
(mk-float-tbl (list #'= #'<= #'< #'> #'>=)))
(dict-set
(dict-set
(mk-float-tbl (list #'= #'<= #'< #'> #'>=))
;; not a comparison, but takes 2 floats and does not return a float,
;; unlike binary-float-ops
#'make-rectangular #'unsafe-make-flrectangular)
#'make-flrectangular #'unsafe-make-flrectangular))
(define unary-float-ops
(mk-float-tbl (list #'abs #'sin #'cos #'tan #'asin #'acos #'atan #'log #'exp
#'sqrt #'round #'floor #'ceiling #'truncate)))
@ -54,6 +60,18 @@
#:when (dict-ref tbl #'i #f)
#:with unsafe (dict-ref tbl #'i)))
(define-syntax-class inexact-complex-opt-expr
(pattern e:opt-expr
;; can't work on inexact reals, which are a subtype of inexact
;; complexes, so this has to be equality
#:when (match (type-of #'e)
[(tc-result1: (== -InexactComplex type-equal?)) #t] [_ #f])
#:with opt #'e.opt))
(define-syntax-class inexact-complex-unary-op
(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))
(define-syntax-class fixnum-opt-expr
(pattern e:opt-expr
@ -171,8 +189,6 @@
(begin (log-optimization "binary float" #'op)
(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)
(n-ary->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...))))
@ -189,6 +205,12 @@
#:with opt
(begin (log-optimization "binary nonzero fixnum" #'op)
#'(op.unsafe n1.opt n2.opt)))
(pattern (#%plain-app op:inexact-complex-unary-op n:inexact-complex-opt-expr)
#:with opt
(begin (log-optimization "unary inexact complex" #'op)
#'(op.unsafe n.opt)))
(pattern (#%plain-app (~and op (~literal exact->inexact)) n:fixnum-opt-expr)
#:with opt
(begin (log-optimization "fixnum to float" #'op)