[Guile-commits] 02/04: Precise range inference on <, <=, >=, > branches

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 4ce1857019d046049923c910a19817b594930a5b
Author: Andy Wingo <address@hidden>
Date:   Tue Mar 31 11:13:01 2015 +0200

    Precise range inference on <, <=, >=, > branches
    
    * module/language/cps/types.scm (restricted-comparison-ranges): New
      helper.
      (define-comparison-inferrer): New helper.
      (<, <=, >=, >): Infer ranges precisely.
---
 module/language/cps/types.scm |   42 ++++++++++++++++++++++++++++++++++++----
 1 files changed, 37 insertions(+), 5 deletions(-)

diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index f9dee59..e508bf4 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -723,12 +723,44 @@ minimum, and maximum."
       (restrict! a &number min max)
       (restrict! b &number min max))))
 
+(define (restricted-comparison-ranges op type0 min0 max0 type1 min1 max1)
+  (define (infer-integer-ranges)
+    (match op
+      ('< (values min0 (min max0 (1- max1)) (max (1+ min0) min1) max1))
+      ('<= (values min0 (min max0 max1) (max min0 min1) max1))
+      ('>= (values (max min0 min1) max0 min1 (min max0 max1)))
+      ('> (values (max min0 (1+ min1)) max0 min1 (min (1- max0) max1)))))
+  (define (infer-real-ranges)
+    (match op
+      ((or '< '<=) (values min0 (min max0 max1) (max min0 min1) max1))
+      ((or '> '>=) (values (max min0 min1) max0 min1 (min max0 max1)))))
+  (if (= (logior type0 type1) &exact-integer)
+      (infer-integer-ranges)
+      (infer-real-ranges)))
+
+(define-syntax-rule (define-comparison-inferrer (op inverse))
+  (define-predicate-inferrer (op a b true?)
+    (when (zero? (logand (logior (&type a) (&type b)) (lognot &number)))
+      (call-with-values
+          (lambda ()
+            (restricted-comparison-ranges (if true? 'op 'inverse)
+                                          (&type a) (&min a) (&max a)
+                                          (&type b) (&min b) (&max b)))
+        (lambda (min0 max0 min1 max1)
+          (restrict! a &real min0 max0)
+          (restrict! b &real min1 max1))))))
+
 (define-simple-type-checker (< &real &real))
-(define-predicate-inferrer (< a b true?)
-  (when (zero? (logand (logior (&type a) (&type b)) (lognot &number)))
-    (restrict! a &real -inf.0 +inf.0)
-    (restrict! b &real -inf.0 +inf.0)))
-(define-type-aliases < <= > >=)
+(define-comparison-inferrer (< >=))
+
+(define-simple-type-checker (<= &real &real))
+(define-comparison-inferrer (<= >))
+
+(define-simple-type-checker (>= &real &real))
+(define-comparison-inferrer (>= <))
+
+(define-simple-type-checker (> &real &real))
+(define-comparison-inferrer (> <=))
 
 ;; Arithmetic.
 (define-syntax-rule (define-unary-result! a result min max)