Model all special immediates under one type bit (with range)

* module/language/cps/types.scm (&special-immediate): Model all special
  immediates (iflags) under this type bit.  This makes type analysis
  less precise on these values as we have to use ranges instead of sets
  to represent the values, but it frees up bits for other purposes,
  allowing us to totally model all types in Guile.
  (&eof): New &special-immediate value.
  (&other-heap-object): New type bit.
  Adapt inferrers.
* module/language/cps/type-fold.scm
  (define-special-immediate-predicate-folder): New helper, used for
  iflag comparisons.
  (local-type-fold): Adapt scalar-value for &special-immediate change.
  Delegate branch on $values to a primcall to `false?'.

module/language/cps/type-fold.scm

@@ -41,7 +41,7 @@
 ;; Branch folders.
 
 (define &scalar-types
-  (logior &fixnum &bignum &flonum &char &unspecified &false &true &nil &null))
+  (logior &fixnum &bignum &flonum &char &special-immediate))
 
 (define *branch-folders* (make-hash-table))
 
@@ -59,6 +59,29 @@
                       body ...)
   (define-branch-folder name (lambda (arg0 min0 max0 arg1 min1 max1) body ...)))
 
+(define-syntax-rule (define-special-immediate-predicate-folder name imin imax)
+  (define-unary-branch-folder (name type min max)
+    (let ((type* (logand type &special-immediate)))
+      (cond
+       ((zero? (logand type &special-immediate)) (values #t #f))
+       ((eqv? type &special-immediate)
+        (cond
+         ((or (< imax min) (< max imin)) (values #t #f))
+         ((<= imin min max imax) (values #t #t))
+         (else (values #f #f))))
+       (else (values #f #f))))))
+
+(define-special-immediate-predicate-folder eq-nil? &nil &nil)
+(define-special-immediate-predicate-folder eq-eol? &null &null)
+(define-special-immediate-predicate-folder eq-false? &false &false)
+(define-special-immediate-predicate-folder eq-true? &true &true)
+(define-special-immediate-predicate-folder unspecified? &unspecified &unspecified)
+(define-special-immediate-predicate-folder undefined? &undefined &undefined)
+(define-special-immediate-predicate-folder eof-object? &eof &eof)
+(define-special-immediate-predicate-folder null? &null &nil)
+(define-special-immediate-predicate-folder false? &nil &false)
+(define-special-immediate-predicate-folder nil? &null &false) ;; &nil in middle
+
 (define-syntax-rule (define-unary-type-predicate-folder name &type)
   (define-unary-branch-folder (name type min max)
     (let ((type* (logand type &type)))
@@ -69,8 +92,6 @@
 
 ;; All the cases that are in compile-bytecode.
 (define-unary-type-predicate-folder pair? &pair)
-(define-unary-type-predicate-folder null? &null)
-(define-unary-type-predicate-folder nil? &nil)
 (define-unary-type-predicate-folder symbol? &symbol)
 (define-unary-type-predicate-folder variable? &box)
 (define-unary-type-predicate-folder vector? &vector)
@@ -309,11 +330,16 @@
      ((eqv? type &bignum) val)
      ((eqv? type &flonum) (exact->inexact val))
      ((eqv? type &char) (integer->char val))
-     ((eqv? type &unspecified) *unspecified*)
+     ((eqv? type &special-immediate)
-     ((eqv? type &false) #f)
+      (cond
-     ((eqv? type &true) #t)
+       ((eqv? val &null) '())
-     ((eqv? type &nil) #nil)
+       ((eqv? val &nil) #nil)
-     ((eqv? type &null) '())
+       ((eqv? val &false) #f)
+       ((eqv? val &true) #t)
+       ((eqv? val &unspecified) *unspecified*)
+       ;; FIXME: &undefined here
+       ((eqv? val &eof) the-eof-object)
+       (else (error "unhandled immediate" val))))
      (else (error "unhandled type" type val))))
   (let ((types (infer-types cps start)))
     (define (fold-primcall cps label names vars k src name args def)
@@ -416,19 +442,10 @@
             (or (fold-binary-branch cps label names vars k kt src name x y)
                 cps))))
         (($ $branch kt ($ $values (arg)))
-         ;; We might be able to fold branches on values.
+         ;; We might be able to fold a branch on the false? primcall.
-         (call-with-values (lambda () (lookup-pre-type types label arg))
+         ;; Note inverted true and false continuations.
-           (lambda (type min max)
+         (or (fold-unary-branch cps label names vars kt k src 'false? arg)
-             (cond
+             cps))
-              ((zero? (logand type (logior &false &nil)))
-               (with-cps cps
-                 (setk label
-                       ($kargs names vars ($continue kt src ($values ()))))))
-              ((zero? (logand type (lognot (logior &false &nil))))
-               (with-cps cps
-                 (setk label
-                       ($kargs names vars ($continue k src ($values ()))))))
-              (else cps)))))
         (_ cps)))
     (let lp ((label start) (cps cps))
       (if (<= label end)

module/language/cps/types.scm

@@ -93,17 +93,10 @@
             &fraction
 
             &char
-            &unspecified
+            &special-immediate
-            &unbound
-            &false
-            &true
-            &nil
-            &null
             &symbol
             &keyword
-
             &procedure
-
             &pointer
             &fluid
             &pair
@@ -115,6 +108,10 @@
             &bitvector
             &array
             &syntax
+            &other-heap-object
+
+            ;; Special immediate values.
+            &null &nil &false &true &unspecified &undefined &eof
 
             ;; Union types.
             &exact-integer &number &real
@@ -155,17 +152,11 @@
   &fraction
 
   &char
-  &unspecified
+  &special-immediate
-  &unbound
+
-  &false
-  &true
-  &nil
-  &null
   &symbol
   &keyword
-
   &procedure
-
   &pointer
   &fluid
   &pair
@@ -177,6 +168,7 @@
   &bitvector
   &array
   &syntax
+  &other-heap-object
 
   &f64
   &u64
@@ -184,6 +176,16 @@
 
 (define-syntax &no-type (identifier-syntax 0))
 
+;; Special immediate values.  Note that the values for the first 4 of
+;; these are important; see uses below.
+(define-syntax &null        (identifier-syntax 0))
+(define-syntax &nil         (identifier-syntax 1))
+(define-syntax &false       (identifier-syntax 2))
+(define-syntax &true        (identifier-syntax 3))
+(define-syntax &unspecified (identifier-syntax 4))
+(define-syntax &undefined   (identifier-syntax 5))
+(define-syntax &eof         (identifier-syntax 6))
+
 (define-syntax &exact-integer
   (identifier-syntax (logior &fixnum &bignum)))
 (define-syntax &number
@@ -350,12 +352,12 @@ minimum, and maximum."
            (if (rational? val) (inexact->exact (floor val)) val)
            (if (rational? val) (inexact->exact (ceiling val)) val))))
      (else (return &complex #f))))
-   ((eq? val '()) (return &null #f))
+   ((eq? val '()) (return &special-immediate &null))
-   ((eq? val #nil) (return &nil #f))
+   ((eq? val #nil) (return &special-immediate &nil))
-   ((eq? val #t) (return &true #f))
+   ((eq? val #t) (return &special-immediate &true))
-   ((eq? val #f) (return &false #f))
+   ((eq? val #f) (return &special-immediate &false))
+   ((eqv? val *unspecified*) (return &special-immediate &unspecified))
    ((char? val) (return &char (char->integer val)))
-   ((eqv? val *unspecified*) (return &unspecified #f))
    ((symbol? val) (return &symbol #f))
    ((keyword? val) (return &keyword #f))
    ((pair? val) (return &pair #f))
@@ -365,7 +367,8 @@ minimum, and maximum."
    ((bitvector? val) (return &bitvector (bitvector-length val)))
    ((array? val) (return &array (array-rank val)))
    ((syntax? val) (return &syntax 0))
-   ((not (variable-bound? (make-variable val))) (return &unbound #f))
+   ((not (variable-bound? (make-variable val)))
+    (return &special-immediate &undefined))
 
    (else (error "unhandled constant" val))))
 
@@ -540,15 +543,58 @@ minimum, and maximum."
 ;;; Generic effect-free predicates.
 ;;;
 
-(define-predicate-inferrer (eq? a b true?)
+(define-syntax-rule (define-special-immediate-predicate-inferrer pred imm*)
-  ;; We can only propagate information down the true leg.
+  (define-predicate-inferrer (pred val true?)
-  (when true?
+    (let ((imm imm*))
-    (let ((type (logand (&type a) (&type b)))
+      (define (range-subtract lo hi x)
-          (min (max (&min a) (&min b)))
+        (values (if (eqv? lo x) (1+ lo) lo)
-          (max (min (&max a) (&max b))))
+                (if (eqv? hi x) (1- hi) hi)))
-      (restrict! a type min max)
+      (cond
-      (restrict! b type min max))))
+       (true? (restrict! val &special-immediate imm imm))
-(define-type-inferrer-aliases eq? eqv?)
+       (else
+        (when (eqv? (&type val) &special-immediate)
+          (let-values (((lo hi) (range-subtract (&min val) (&max val) imm)))
+            (restrict! val &special-immediate lo hi))))))))
+
+(define-special-immediate-predicate-inferrer eq-nil? &nil)
+(define-special-immediate-predicate-inferrer eq-eol? &null)
+(define-special-immediate-predicate-inferrer eq-false? &false)
+(define-special-immediate-predicate-inferrer eq-true? &true)
+(define-special-immediate-predicate-inferrer unspecified? &unspecified)
+(define-special-immediate-predicate-inferrer undefined? &undefined)
+(define-special-immediate-predicate-inferrer eof-object? &eof)
+
+;; Various inferrers rely on these having contiguous values starting from 0.
+(eval-when (expand)
+  (unless (< -1 &null &nil &false &true 4)
+    (error "unexpected special immediate values")))
+(define-predicate-inferrer (null? val true?)
+  (cond
+   (true? (restrict! val &special-immediate &null &nil))
+   (else
+    (when (eqv? (&type val) &special-immediate)
+      (restrict! val &special-immediate (1+ &nil) +inf.0)))))
+
+(define-predicate-inferrer (false? val true?)
+  (cond
+   (true? (restrict! val &special-immediate &nil &false))
+   (else
+    (when (and (eqv? (&type val) &special-immediate) (> (&min val) &null))
+      (restrict! val &special-immediate (1+ &false) +inf.0)))))
+
+(define-predicate-inferrer (nil? val true?)
+  (cond
+   (true? (restrict! val &special-immediate &null &false))
+   (else
+    (when (eqv? (&type val) &special-immediate)
+      (restrict! val &special-immediate (1+ &false) +inf.0)))))
+
+(define-predicate-inferrer (heap-object? val true?)
+  (define &immediate-types
+    (logior &fixnum &char &special-immediate))
+  (define &heap-object-types
+    (logand &all-types (lognot &immediate-types)))
+  (restrict! val (if true? &heap-object-types &immediate-types) -inf.0 +inf.0))
 
 (define-syntax-rule (define-simple-predicate-inferrer predicate type)
   (define-predicate-inferrer (predicate val true?)
@@ -556,9 +602,8 @@ minimum, and maximum."
                     type
                     (logand (&type val) (lognot type)))))
       (restrict! val type -inf.0 +inf.0))))
+
 (define-simple-predicate-inferrer pair? &pair)
-(define-simple-predicate-inferrer null? &null)
-(define-simple-predicate-inferrer nil? &nil)
 (define-simple-predicate-inferrer symbol? &symbol)
 (define-simple-predicate-inferrer variable? &box)
 (define-simple-predicate-inferrer vector? &vector)
@@ -572,6 +617,16 @@ minimum, and maximum."
 (define-simple-predicate-inferrer procedure? &procedure)
 (define-simple-predicate-inferrer thunk? &procedure)
 
+(define-predicate-inferrer (eq? a b true?)
+  ;; We can only propagate information down the true leg.
+  (when true?
+    (let ((type (logand (&type a) (&type b)))
+          (min (max (&min a) (&min b)))
+          (max (min (&max a) (&max b))))
+      (restrict! a type min max)
+      (restrict! b type min max))))
+(define-type-inferrer-aliases eq? eqv?)
+
 
 
 ;;;
@@ -747,7 +802,7 @@ minimum, and maximum."
 
 (define-simple-type (number->string &number) (&string 0 *max-size-t*))
 (define-simple-type (string->number (&string 0 *max-size-t*))
-  ((logior &number &false) -inf.0 +inf.0))
+  ((logior &number &special-immediate) -inf.0 +inf.0))
 
 
 
@@ -1194,46 +1249,33 @@ minimum, and maximum."
       (define-exact-integer! result 0 max-abs-mod)))))
 
 ;; Predicates.
-(define-syntax-rule (define-number-kind-predicate-inferrer name type)
+(define-syntax-rule (define-type-predicate-result val result type)
+  (cond
+   ((zero? (logand (&type val) type))
+    (define! result &special-immediate &false &false))
+   ((zero? (logand (&type val) (lognot type)))
+    (define! result &special-immediate &true &true))
+   (else
+    (define! result &special-immediate &false &true))))
+;; Bah, needs rewrite to turn into actual control flow.
+(define-syntax-rule (define-simple-type-predicate-inferrer name type)
   (define-type-inferrer (name val result)
-    (cond
+    (define-type-predicate-result val result type)))
-     ((zero? (logand (&type val) type))
+(define-simple-type-predicate-inferrer complex? &number)
-      (define! result &false 0 0))
+(define-simple-type-predicate-inferrer real? &real)
-     ((zero? (logand (&type val) (lognot type)))
+(define-simple-type-predicate-inferrer rational? (logior &exact-integer &fraction))
-      (define! result &true 0 0))
+(define-simple-type-predicate-inferrer integer? (logior &exact-integer &flonum))
-     (else
+(define-simple-type-predicate-inferrer exact-integer? &exact-integer)
-      (define! result (logior &true &false) 0 0)))))
-(define-number-kind-predicate-inferrer complex? &number)
-(define-number-kind-predicate-inferrer real? &real)
-(define-number-kind-predicate-inferrer rational?
-  (logior &exact-integer &fraction))
-(define-number-kind-predicate-inferrer integer?
-  (logior &exact-integer &flonum))
-(define-number-kind-predicate-inferrer exact-integer?
-  &exact-integer)
 
 (define-simple-type-checker (exact? &number))
 (define-type-inferrer (exact? val result)
   (restrict! val &number -inf.0 +inf.0)
-  (cond
+  (define-type-predicate-result val result (logior &exact-integer &fraction)))
-   ((zero? (logand (&type val) (logior &exact-integer &fraction)))
-    (define! result &false 0 0))
-   ((zero? (logand (&type val) (lognot (logior &exact-integer &fraction))))
-    (define! result &true 0 0))
-   (else
-    (define! result (logior &true &false) 0 0))))
 
 (define-simple-type-checker (inexact? &number))
 (define-type-inferrer (inexact? val result)
   (restrict! val &number -inf.0 +inf.0)
-  (cond
+  (define-type-predicate-result val result (logior &flonum &complex)))
-   ((zero? (logand (&type val) (logior &flonum &complex)))
-    (define! result &false 0 0))
-   ((zero? (logand (&type val) (logand &number
-                                       (lognot (logior &flonum &complex)))))
-    (define! result &true 0 0))
-   (else
-    (define! result (logior &true &false) 0 0))))
 
 (define-simple-type-checker (inf? &real))
 (define-type-inferrer (inf? val result)
@@ -1241,14 +1283,14 @@ minimum, and maximum."
   (cond
    ((or (zero? (logand (&type val) (logior &flonum &complex)))
         (and (not (inf? (&min val))) (not (inf? (&max val)))))
-    (define! result &false 0 0))
+    (define! result &special-immediate &false &false))
    (else
-    (define! result (logior &true &false) 0 0))))
+    (define! result &special-immediate &false &true))))
 
 (define-type-aliases inf? nan?)
 
 (define-simple-type (even? &exact-integer)
-  ((logior &true &false) 0 0))
+  (&special-immediate &false &true))
 (define-type-aliases even? odd?)
 
 ;; Bit operations.
@@ -1413,9 +1455,9 @@ minimum, and maximum."
         (b-max (&max b)))
     (if (and (eqv? a-min a-max) (>= a-min 0) (not (inf? a-min))
              (eqv? b-min b-max) (>= b-min 0) (not (inf? b-min)))
-        (let ((type (if (logbit? a-min b-min) &true &false)))
+        (let ((bool (if (logbit? a-min b-min) &true &false)))
-          (define! result type 0 0))
+          (define! result &special-immediate bool bool))
-        (define! result (logior &true &false) 0 0))))
+        (define! result &special-immediate &false &true))))
 
 ;; Flonums.
 (define-simple-type-checker (sqrt &number))
@@ -1613,17 +1655,12 @@ maximum, where type is a bitset as a fixnum."
         (values (append changed0 changed1) typev)))
     ;; Each of these branches must propagate to its successors.
     (match exp
-      (($ $branch kt ($ $values (arg)))
+      (($ $branch kt ($ $values args))
-       ;; The "normal" continuation is the #f branch.
+       ;; In the future a branch on $values will be replaced by a
-       (let ((kf-types (restrict-var types arg
+       ;; primcall to 'false?; manually do that here.  Note that the
-                                     (make-type-entry (logior &false &nil)
+       ;; sense of the test is reversed.
-                                                      0
+       (let ((kt-types (infer-primcall types 0 'false? args #f))
-                                                      0)))
+             (kf-types (infer-primcall types 1 'false? args #f)))
-             (kt-types (restrict-var types arg
-                                     (make-type-entry
-                                      (logand &all-types 
-                                              (lognot (logior &false &nil)))
-                                      -inf.0 +inf.0))))
          (propagate2 k kf-types kt kt-types)))
       (($ $branch kt ($ $primcall name args))
        ;; The "normal" continuation is the #f branch.