Precise range inference on <, <=, >=, > branches

[bpt/guile.git] / module / language / cps / types.scm

diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index ca90f50..e508bf4 100644 (file)
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1,5 +1,5 @@
 ;;; Type analysis on CPS
-;;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
 ;;;
 ;;; This library is free software: you can redistribute it and/or modify
 ;;; it under the terms of the GNU Lesser General Public License as
@@ -480,6 +480,9 @@ minimum, and maximum."
 (define-simple-predicate-inferrer vector? &vector)
 (define-simple-predicate-inferrer struct? &struct)
 (define-simple-predicate-inferrer string? &string)
+(define-simple-predicate-inferrer bytevector? &bytevector)
+(define-simple-predicate-inferrer bitvector? &bitvector)
+(define-simple-predicate-inferrer keyword? &keyword)
 (define-simple-predicate-inferrer number? &number)
 (define-simple-predicate-inferrer char? &char)
 (define-simple-predicate-inferrer procedure? &procedure)
@@ -720,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)
@@ -1273,8 +1308,6 @@ mapping symbols to types."
          (match (lookup-cont k dfg)
            (($ $kargs (_) (var))
             (let ((entry (match exp
-                           (($ $void)
-                            (make-type-entry &unspecified -inf.0 +inf.0))
                            (($ $const val)
                             (constant-type val))
                            ((or ($ $prim) ($ $fun) ($ $closure))