From: Taylor R Campbell <campbell@mumble.net>
Date: Wed, 28 Nov 2018 09:15:45 +0000 (+0000)
Subject: Teach RTL compression to search through object->float too.
X-Git-Tag: mit-scheme-pucked-10.1.7~3^2~145
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=52126d30c39437aa5200f23b28d928317cf74c10;p=mit-scheme.git

Teach RTL compression to search through object->float too.

This way it can fold (object->float (constant #x1p+0)) in both

(assign (register #x22) (object->float (constant #x1p+0))
(assign (register #x23) (offset (register 4) (machine-constant 0)))
(assign (register #x24) (object->float (register #x23)))
(jumpc (flonum-pred-2-args flonum-is-greater? (register #x22) (register #x24)) label-3)

and

(assign (register #x21) (offset (register 4) (machine-constant 0)))
(assign (register #x22) (object->float (register #x21)))
(assign (register #x24) (object->float (constant #x1p+0)))
(jumpc (flonum-pred-2-args flonum-is-greater? (register #x22) (register #x24)) label-3)

where previously it could handle only the second one because the
reference appeared in the immediately subsequent instruction.

This exposes a latent bug in the x86-64 code generator, to be fixed
in a subsequent commit.
---

diff --git a/src/compiler/rtlopt/rcompr.scm b/src/compiler/rtlopt/rcompr.scm
index 15d702c98..755111d88 100644
--- a/src/compiler/rtlopt/rcompr.scm
+++ b/src/compiler/rtlopt/rcompr.scm
@@ -204,6 +204,9 @@ USA.
 	      ((rtl:object->unsigned-fixnum? expression)
 	       (recursion rtl:object->unsigned-fixnum-expression
 			  rtl:make-object->unsigned-fixnum))
+	      ((rtl:object->float? expression)
+	       (recurse-and-search rtl:object->float-expression
+				   rtl:make-object->float))
 	      (else
 	       (values false false)))))))
 
diff --git a/tests/runtime/test-flonum.scm b/tests/runtime/test-flonum.scm
index 83c5f3cc0..84a042123 100644
--- a/tests/runtime/test-flonum.scm
+++ b/tests/runtime/test-flonum.scm
@@ -335,6 +335,12 @@ USA.
        (define-lconstcomp-test (symbol name '/lconst) safe unsafe x0 cases)
        (define-rconstcomp-test (symbol name '/rconst) safe unsafe x0 cases)))))
 
+(define expect-failure-x86-64
+  (if (and (eq? microcode-id/compiled-code-type 'x86-64)
+           (compiled-procedure? (lambda (x) x)))
+      expect-failure
+      #!default))
+
 (define-constcomp-test '< flo:safe< flo:< 0.
   `((-inf.0 #f #t)
     (-1. #f #t)
@@ -368,7 +374,18 @@ USA.
     (+inf.0 #t #f)
     (+nan.0 #f #f)))
 
-(define-constcomp-test '>= flo:safe>= flo:>= 0.
+(define-lconstcomp-test '>=/lconst flo:safe>= flo:>= 0.
+  `((-inf.0 #t #f ,expect-failure-x86-64)
+    (-1. #t #f ,expect-failure-x86-64)
+    (,subnormal- #t #f ,expect-failure-x86-64)
+    (-0. #t #t)
+    (+0. #t #t)
+    (,subnormal+ #f #t ,expect-failure-x86-64)
+    (+1. #f #t ,expect-failure-x86-64)
+    (+inf.0 #f #t ,expect-failure-x86-64)
+    (+nan.0 #f #f)))
+
+(define-rconstcomp-test '>=/rconst flo:safe>= flo:>= 0.
   `((-inf.0 #t #f)
     (-1. #t #f)
     (,subnormal- #t #f)
@@ -423,7 +440,18 @@ USA.
     (+inf.0 #t #f)
     (+nan.0 #f #f)))
 
-(define-constcomp-test '>= flo:safe>= flo:>= 1.
+(define-lconstcomp-test '>=/lconst flo:safe>= flo:>= 1.
+  `((-inf.0 #t #f ,expect-failure-x86-64)
+    (-1. #t #f ,expect-failure-x86-64)
+    (,subnormal- #t #f ,expect-failure-x86-64)
+    (-0. #t #f ,expect-failure-x86-64)
+    (+0. #t #f ,expect-failure-x86-64)
+    (,subnormal+ #t #f ,expect-failure-x86-64)
+    (+1. #t #t)
+    (+inf.0 #f #t ,expect-failure-x86-64)
+    (+nan.0 #f #f)))
+
+(define-rconstcomp-test '>=/rconst flo:safe>= flo:>= 1.
   `((-inf.0 #t #f)
     (-1. #t #f)
     (,subnormal- #t #f)