From 980de88902ec7002b174c63a817c0f1cfe73fa1a Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Tue, 21 Nov 2017 16:09:30 +0100
Subject: [PATCH] Add exact-integer? as interesting Tree-IL effect-free
 primitive

* module/language/tree-il/primitives.scm (*interesting-primitive-names*):
  (*effect-free-primitives*, *effect+exception-free-primitives*): Detect
  use of exact-integer?.
* module/language/tree-il/compile-cps.scm (canonicalize): Compile
  exact-integer? to a fixnum?-or-bignum? check.
---
 module/language/cps/types.scm           |  1 -
 module/language/tree-il/compile-cps.scm | 10 ++++++++++
 module/language/tree-il/primitives.scm  |  3 +++
 3 files changed, 13 insertions(+), 1 deletion(-)

diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 6aec93b5a..63ee1ce8b 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1352,7 +1352,6 @@ minimum, and maximum."
 ;; FIXME: If it's a flonum it may be an integer, but if it's not an
 ;; integer it also may be still be a flonum.
 ;; (define-simple-type-predicate-inferrer integer? (logior &exact-integer &flonum))
-(define-simple-type-predicate-inferrer exact-integer? &exact-integer)
 
 (define-simple-type-checker (exact? &number))
 (define-type-inferrer (exact? val result)
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 7d7100fa7..cb43447bb 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1072,6 +1072,16 @@ integer."
        (($ <conditional>)
         (reduce-conditional exp))
 
+       (($ <primcall> src 'exact-integer? (x))
+        ;; Both fixnum? and bignum? are branching primitives.
+        (with-lexicals src (x)
+          (make-conditional
+           src (make-primcall src 'fixnum? (list x))
+           (make-const src #t)
+           (make-conditional src (make-primcall src 'bignum? (list x))
+                             (make-const src #t)
+                             (make-const src #f)))))
+
        (($ <primcall> src '<= (a b))
         ;; No need to reduce as < is a branching primitive.
         (make-conditional src (make-primcall src '< (list b a))
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 646eea0c1..c9e1fc0e4 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -57,6 +57,7 @@
     procedure? thunk?
 
     complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
+    exact-integer?
 
     char<? char<=? char>=? char>?
 
@@ -174,6 +175,7 @@
     symbol? variable? vector? struct? string? number? char?
     bytevector? keyword? bitvector? atomic-box?
     complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
+    exact-integer?
     char<? char<=? char>=? char>?
     integer->char char->integer number->string string->number
     struct-vtable
@@ -194,6 +196,7 @@
     not
     pair? null? nil? list?
     symbol? variable? vector? struct? string? number? char?
+    exact-integer?
     bytevector? keyword? bitvector?
     procedure? thunk? atomic-box?
     acons cons cons* list vector))