From c2fa345093ab79331d331b6765bf41a3da68eff1 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Sun, 29 Oct 2017 14:35:19 +0100
Subject: [PATCH] Add missing compiler support for heap-object? primcall et al.

* module/language/cps/effects-analysis.scm: Reorder effect-free
  primitives.  Add immediate predicates and heap-number?.
* module/language/cps/primitives.scm (*heap-type-predicates*): Add
  heap-number?.
* module/language/cps/type-fold.scm (heap-number?): New folder.
* module/language/cps/types.scm (heap-number?): New inferrer.
---
 module/language/cps/effects-analysis.scm | 24 +++++++++++++++++-------
 module/language/cps/primitives.scm       |  4 ++--
 module/language/cps/type-fold.scm        |  7 +++++++
 module/language/cps/types.scm            |  7 +++++++
 4 files changed, 33 insertions(+), 9 deletions(-)

diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index 1cc03c037..cdb482c96 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -263,24 +263,34 @@ is or might be a read or a write to the same location as A."
 
 ;; Generic effect-free predicates.
 (define-primitive-effects
-  ((eq? . _))
-  ((eqv? . _))
-  ((equal? . _))
-  ((pair? arg))
+  ((eq? x y))
+  ((equal? x y))
+  ((fixnum? arg))
+  ((char? arg))
+  ((eq-null? arg))
+  ((eq-nil? arg))
+  ((eq-false? arg))
+  ((eq-true? arg))
+  ((unspecified? arg))
+  ((undefined? arg))
+  ((eof-object? arg))
   ((null? arg))
-  ((nil? arg ))
+  ((false? arg))
+  ((nil? arg))
+  ((heap-object? arg))
+  ((pair? arg))
   ((symbol? arg))
   ((variable? arg))
   ((vector? arg))
   ((struct? arg))
   ((string? arg))
   ((number? arg))
-  ((char? arg))
   ((bytevector? arg))
   ((keyword? arg))
   ((bitvector? arg))
   ((procedure? arg))
-  ((thunk? arg)))
+  ((thunk? arg))
+  ((heap-number? arg)))
 
 ;; Fluids.
 (define-primitive-effects
diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm
index 71ce8deed..e62acd367 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -95,12 +95,12 @@
     string?
     keyword?
     bytevector?
-    bitvector?))
+    bitvector?
+    heap-number?))
 
 ;; FIXME: Support these.
 (define *other-predicates*
   '(weak-vector?
-    number?
     hash-table?
     pointer?
     fluid?
diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm
index 282462545..f216aca98 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -97,6 +97,13 @@
    ((type<=? type &immediate-types) (values #t #f))
    (else (values #f #f))))
 
+(define-unary-branch-folder (heap-number? type min max)
+  (define &types (logior &bignum &flonum &fraction &complex))
+  (cond
+   ((zero? (logand type &types)) (values #t #f))
+   ((type<=? type &types) (values #t #t))
+   (else (values #f #f))))
+
 ;; All the cases that are in compile-bytecode.
 (define-unary-type-predicate-folder pair? &pair)
 (define-unary-type-predicate-folder symbol? &symbol)
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index e07bb9244..90611bec8 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -596,6 +596,13 @@ minimum, and maximum."
     (logand &all-types (lognot &immediate-types)))
   (restrict! val (if true? &heap-object-types &immediate-types) -inf.0 +inf.0))
 
+(define-predicate-inferrer (heap-number? val true?)
+  (define &heap-number-types
+    (logior &bignum &flonum &complex &fraction))
+  (define &other-types
+    (logand &all-types (lognot &heap-number-types)))
+  (restrict! val (if true? &heap-number-types &other-types) -inf.0 +inf.0))
+
 (define-syntax-rule (define-simple-predicate-inferrer predicate type)
   (define-predicate-inferrer (predicate val true?)
     (let ((type (if true?