From 31e7f44340b47800399578b3fe5e9451e0b2be2e Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Sun, 29 Oct 2017 19:42:50 +0100
Subject: [PATCH] Add compiler support for fixnum? primcall predicate

* module/language/cps/compile-bytecode.scm (compile-function):
* module/language/cps/type-fold.scm (fixnum?):
* module/language/cps/types.scm (fixnum?):
* module/system/vm/assembler.scm (system): Add cases for fixnum?
  primcall predicate.
---
 module/language/cps/compile-bytecode.scm |  1 +
 module/language/cps/type-fold.scm        |  1 +
 module/language/cps/types.scm            | 15 +++++++++++++++
 module/system/vm/assembler.scm           |  2 +-
 4 files changed, 18 insertions(+), 1 deletion(-)

diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index 131249cdc..9c92eac4c 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -442,6 +442,7 @@
         (($ $primcall 'bitvector? (a)) (unary emit-bitvector? a))
         (($ $primcall 'keyword? (a)) (unary emit-keyword? a))
         (($ $primcall 'heap-number? (a)) (unary emit-heap-number? a))
+        (($ $primcall 'fixnum? (a)) (unary emit-fixnum? a))
         ;; Add more TC7 tests here.  Keep in sync with
         ;; *branching-primcall-arities* in (language cps primitives) and
         ;; the set of macro-instructions in assembly.scm.
diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm
index fdddd4a6d..75c8deae0 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -105,6 +105,7 @@
    (else (values #f #f))))
 
 ;; All the cases that are in compile-bytecode.
+(define-unary-type-predicate-folder fixnum? &fixnum)
 (define-unary-type-predicate-folder pair? &pair)
 (define-unary-type-predicate-folder symbol? &symbol)
 (define-unary-type-predicate-folder variable? &box)
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 2787cb540..715ab744b 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -603,6 +603,21 @@ minimum, and maximum."
     (logand &all-types (lognot &heap-number-types)))
   (restrict! val (if true? &heap-number-types &other-types) -inf.0 +inf.0))
 
+(define-predicate-inferrer (fixnum? val true?)
+  (cond
+   (true?
+    (restrict! val &fixnum most-negative-fixnum most-positive-fixnum))
+   ((type<=? (&type val) &exact-integer)
+    (cond
+     ((<= (&max val) most-positive-fixnum)
+      (restrict! val &bignum -inf.0 (1- most-negative-fixnum)))
+     ((>= (&min val) most-negative-fixnum)
+      (restrict! val &bignum most-positive-fixnum +inf.0))
+     (else
+      (restrict! val &bignum -inf.0 +inf.0))))
+   (else
+    (restrict! val (logand &all-types (lognot &fixnum)) -inf.0 +inf.0))))
+
 (define-syntax-rule (define-simple-predicate-inferrer predicate type)
   (define-predicate-inferrer (predicate val true?)
     (let ((type (if true?
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 704e0fc5d..732e69f52 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -86,7 +86,7 @@
             emit-jge
             emit-jnge
 
-            emit-inum?
+            emit-fixnum?
             emit-heap-object?
             emit-char?
             emit-eq-null?