From fbf7cbd494d35cdbdf5ad8c96890cbd2959c2c79 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Thu, 1 Jul 2010 14:12:42 -0400
Subject: [PATCH] Fixed the behavior of the optimizer on sqrt.

original commit: 351de3f767cd7b32fe75963e206c7c8da379d26b
---
 .../optimizer/generic/invalid-sqrt.rkt        |  2 ++
 .../typed-scheme/optimizer/generic/sqrt.rkt   |  5 ++++
 collects/typed-scheme/private/optimize.rkt    | 24 +++++++++----------
 3 files changed, 18 insertions(+), 13 deletions(-)
 create mode 100644 collects/tests/typed-scheme/optimizer/generic/invalid-sqrt.rkt
 create mode 100644 collects/tests/typed-scheme/optimizer/generic/sqrt.rkt

diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-sqrt.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-sqrt.rkt
new file mode 100644
index 00000000..39b0336c
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/invalid-sqrt.rkt
@@ -0,0 +1,2 @@
+(module invalid-sqrt typed/scheme #:optimize
+  (sqrt -2.0)) ; not a nonnegative flonum, can't optimize
diff --git a/collects/tests/typed-scheme/optimizer/generic/sqrt.rkt b/collects/tests/typed-scheme/optimizer/generic/sqrt.rkt
new file mode 100644
index 00000000..411ff900
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/sqrt.rkt
@@ -0,0 +1,5 @@
+(module sqrt typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (: f (Nonnegative-Float -> Nonnegative-Float))
+  (define (f x)
+    (sqrt x)))
diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt
index a3922b87..e998e9b4 100644
--- a/collects/typed-scheme/private/optimize.rkt
+++ b/collects/typed-scheme/private/optimize.rkt
@@ -6,26 +6,24 @@
          (types abbrev type-table utils subtype))
 (provide optimize)
 
-;; for use in match
-(define (subtypeof x y)
-  (subtype y x))
+;; is the syntax object s's type a subtype of t?
+(define (subtypeof s t)
+  (match (type-of s)
+    [(tc-result1: (== t (lambda (x y) (subtype y x)))) #t] [_ #f]))
 
 (define-syntax-class float-opt-expr
   (pattern e:opt-expr
-           #:when (match (type-of #'e)
-                    [(tc-result1: (== -Flonum subtypeof)) #t] [_ #f])
+           #:when (subtypeof #'e -Flonum)
            #:with opt #'e.opt))
 
 (define-syntax-class int-opt-expr
   (pattern e:opt-expr
-           #:when (match (type-of #'e)
-                    [(tc-result1: (== -Integer subtypeof)) #t] [_ #f])
+           #:when (subtypeof #'e -Integer)
            #:with opt #'e.opt))
 
 (define-syntax-class fixnum-opt-expr
   (pattern e:opt-expr
-           #:when (match (type-of #'e)
-                    [(tc-result1: (== -Fixnum subtypeof)) #t] [_ #f])
+           #:when (subtypeof #'e -Fixnum)
            #:with opt #'e.opt))
 (define-syntax-class nonzero-fixnum-opt-expr
   (pattern e:opt-expr
@@ -151,14 +149,14 @@
   #:literal-sets (kernel-literals)
 
   ;; interesting cases, where something is optimized
-  (pattern (#%plain-app (~var op (float-op unary-float-ops)) f:float-opt-expr)
+  (pattern (~and res (#%plain-app (~var op (float-op unary-float-ops)) f:float-opt-expr))
+           #:when (subtypeof #'res -Flonum)
            #:with opt
            (begin (log-optimization "unary float" #'op)
                   #'(op.unsafe f.opt)))
   (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 subtypeof)) #t] [_ #f])
+           ;; if the result is a float, we can coerce integers to floats and optimize
+           #:when (subtypeof #'res -Flonum)
            #:with opt
            (begin (log-optimization "binary float" #'op)
                   (n-ary->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...))))