From ccbf54bdf7c9a16284d9230dbf93c2c61a4cc914 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 2 Jul 2010 20:57:09 -0400 Subject: [PATCH] Added support for make-flrectangular, flreal-part, flimag-part and their unsafe counterparts to Typed Scheme and its optimizer. original commit: 389a20795a5bb6db25341b899e7ec58e6eb5a0d1 --- .../generic/invalid-inexact-complex-parts.rkt | 2 ++ .../generic/invalid-make-flrectangular.rkt | 2 ++ .../optimizer/generic/make-flrectangular.rkt | 4 +++ .../typed-scheme/private/base-env-numeric.rkt | 6 ++++ collects/typed-scheme/private/optimize.rkt | 28 +++++++++++++++++-- 5 files changed, 39 insertions(+), 3 deletions(-) create mode 100644 collects/tests/typed-scheme/optimizer/generic/invalid-inexact-complex-parts.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/invalid-make-flrectangular.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/make-flrectangular.rkt diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-inexact-complex-parts.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-inexact-complex-parts.rkt new file mode 100644 index 00000000..b0a2ab9d --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/invalid-inexact-complex-parts.rkt @@ -0,0 +1,2 @@ +(module invalid-inexact-complex-parts.rkt typed/scheme #:optimize + (real-part 1+2i)) diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-make-flrectangular.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-make-flrectangular.rkt new file mode 100644 index 00000000..ce166151 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/invalid-make-flrectangular.rkt @@ -0,0 +1,2 @@ +(module invalid-make-flrectangular typed/scheme #:optimize + (make-rectangular 1 2)) diff --git a/collects/tests/typed-scheme/optimizer/generic/make-flrectangular.rkt b/collects/tests/typed-scheme/optimizer/generic/make-flrectangular.rkt new file mode 100644 index 00000000..b9250d0e --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/make-flrectangular.rkt @@ -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)) diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index e42c0b77..fe546c38 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -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 diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index 269e42a9..670cd8ae 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -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)