Better compilation for rational?, exact?, and so on

These numeric predicates now have CPS branching primcalls, which allows
type inference and folding to reduce them to less-strong instructions.

* module/language/cps/effects-analysis.scm (heap-numbers-equal?): Put
all the number predicates together.  None have type checks.
* module/language/cps/guile-vm/lower-primcalls.scm
(define-branching-primcall-alias): New helper.
(complex?): Same as number?.
* module/language/cps/guile-vm/lower-primcalls.scm (real?)
(rational?, integer?, exact-integer?, exact?, inexact?): Define
lowerers.
* module/language/cps/type-fold.scm (number?, complex?, real?)
(rational?, integer?, exact-integer?, exact?, inexact?): Add folders and
reducers for all of these.
* module/language/cps/type.scm (number?, complex?, real?)
(rational?, integer?, exact-integer?, exact?, inexact?): Add type
inference for these.
* module/language/tree-il/compile-cps.scm (convert): Add number? checks
before exact? and inexact?.  Remove the eager lowering of
exact-integer?; instead rely on folders.
* module/language/tree-il/cps-primitives.scm (number?, complex?)
(real?, rational?, integer?, exact-integer?, exact?, inexact?): Add
primitive decls.  Define as "number-type-predicates?", meaning they need
a number? guard.

module/language/cps/effects-analysis.scm

@@ -385,7 +385,6 @@ the LABELS that are clobbered by the effects of LABEL."
   ((nil? arg))
   ((null? arg))
   ((mutable-vector? arg))
-  ((number? arg))
   ((pair? arg))
   ((pointer? arg))
   ((procedure? arg))
@@ -673,14 +672,15 @@ the LABELS that are clobbered by the effects of LABEL."
   ((mod . _)                       &type-check)
   ((inexact _)                     &type-check)
   ((s64->f64 _))
-  ((complex? _)                    &type-check)
+  ((number? _))
-  ((real? _)                       &type-check)
+  ((complex? _))
-  ((rational? _)                   &type-check)
+  ((real? _))
+  ((rational? _))
+  ((integer? _))
+  ((exact? _))
+  ((inexact? _))
   ((inf? _)                        &type-check)
   ((nan? _)                        &type-check)
-  ((integer? _)                    &type-check)
-  ((exact? _)                      &type-check)
-  ((inexact? _)                    &type-check)
   ((even? _)                       &type-check)
   ((odd? _)                        &type-check)
   ((rsh n m)                       &type-check)

module/language/cps/guile-vm/lower-primcalls.scm

@@ -57,6 +57,11 @@
       (match (cons param args)
         ((param-pat . args-pat)
          body ...)))))
+(define-syntax-rule (define-branching-primcall-alias def use ...)
+  (let ((proc (or (hashq-ref *branching-primcall-lowerers* 'def)
+                  (error "def not found" 'def))))
+    (hashq-set! *branching-primcall-lowerers* 'use proc)
+    ...))
 
 ;; precondition: v is vector.  result is u64
 (define-primcall-lowerer (vector-length cps k src #f (v))
@@ -622,6 +627,82 @@
             ($branch kf kheap-num src 'heap-object? #f (x))))
     (build-term
       ($branch kheap kt src 'fixnum? #f (x)))))
+(define-branching-primcall-alias number? complex?)
+
+(define-branching-primcall-lowerer (real? cps kf kt src #f (x))
+  (with-cps cps
+    (letk kcomp
+          ($kargs () ()
+            ($branch kt kf src 'compnum? #f (x))))
+    (letk kheap-num
+          ($kargs () ()
+            ($branch kf kcomp src 'heap-number? #f (x))))
+    (letk kheap
+          ($kargs () ()
+            ($branch kf kheap-num src 'heap-object? #f (x))))
+    (build-term
+      ($branch kheap kt src 'fixnum? #f (x)))))
+
+(define-branching-primcall-lowerer (rational? cps kf kt src #f (x))
+  (with-cps cps
+    (letv res prim)
+    (letk ktest
+          ($kargs ('res) (res)
+            ($branch kt kf src 'false? #f (res))))
+    (letk krecv
+          ($kreceive '(val) #f ktest))
+    (letk kcall
+          ($kargs ('prim) (prim)
+            ($continue krecv src ($call prim (x)))))
+    (build-term
+      ($continue kcall src ($prim 'rational?)))))
+
+(define-branching-primcall-lowerer (integer? cps kf kt src #f (x))
+  (with-cps cps
+    (letv res prim)
+    (letk ktest
+          ($kargs ('res) (res)
+            ($branch kt kf src 'false? #f (res))))
+    (letk krecv
+          ($kreceive '(val) #f ktest))
+    (letk kcall
+          ($kargs ('prim) (prim)
+            ($continue krecv src ($call prim (x)))))
+    (build-term
+      ($continue kcall src ($prim 'integer?)))))
+
+(define-branching-primcall-lowerer (exact-integer? cps kf kt src #f (x))
+  (with-cps cps
+    (letk kbig
+          ($kargs () ()
+            ($branch kf kt src 'bignum? #f (x))))
+    (letk kheap
+          ($kargs () ()
+            ($branch kf kbig src 'heap-object? #f (x))))
+    (build-term
+      ($branch kheap kt src 'fixnum? #f (x)))))
+
+(define-branching-primcall-lowerer (exact? cps kf kt src #f (x))
+  (with-cps cps
+    (letk kfrac
+          ($kargs () ()
+            ($branch kf kt src 'fracnum? #f (x))))
+    (letk kbig
+          ($kargs () ()
+            ($branch kfrac kt src 'bignum? #f (x))))
+    (build-term
+      ($branch kbig kt src 'fixnum? #f (x)))))
+
+(define-branching-primcall-lowerer (inexact? cps kf kt src #f (x))
+  (with-cps cps
+    (letk kcomp
+          ($kargs () ()
+            ($branch kf kt src 'compnum? #f (x))))
+    (letk kflo
+          ($kargs () ()
+            ($branch kcomp kt src 'flonum? #f (x))))
+    (build-term
+      ($branch kflo kf src 'fixnum? #f (x)))))
 
 (define (lower-primcalls cps)
   (with-fresh-name-state cps

module/language/cps/type-fold.scm

@@ -134,13 +134,6 @@
    ((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 bignum? &bignum)
 (define-unary-type-predicate-folder bitvector? &bitvector)
@@ -154,7 +147,6 @@
 (define-unary-type-predicate-folder immutable-vector? &immutable-vector)
 (define-unary-type-predicate-folder keyword? &keyword)
 (define-unary-type-predicate-folder mutable-vector? &mutable-vector)
-(define-unary-type-predicate-folder number? &number)
 (define-unary-type-predicate-folder pair? &pair)
 (define-unary-type-predicate-folder pointer? &pointer)
 (define-unary-type-predicate-folder program? &procedure)
@@ -177,6 +169,28 @@
    ((= type &procedure) (values #t #t))
    (else (values #f #f))))
 
+(let ((&heap-number (logior &bignum &flonum &fraction &complex)))
+  (define-unary-type-predicate-folder heap-number? &heap-number))
+(define-unary-type-predicate-folder number? &number)
+(define-unary-type-predicate-folder complex? &number)
+(define-unary-type-predicate-folder real? &real)
+(define-unary-type-predicate-folder exact-integer? &exact-integer)
+(define-unary-type-predicate-folder exact? &exact-number)
+(let ((&inexact (logior &flonum &complex)))
+  (define-unary-type-predicate-folder inexact? &inexact))
+
+(define-unary-branch-folder (rational? type min max)
+  (cond
+   ((zero? (logand type &number)) (values #t #f))
+   ((eqv? type (logand type &exact-number)) (values #t #t))
+   (else (values #f #f))))
+
+(define-unary-branch-folder (integer? type min max)
+  (cond
+   ((zero? (logand type &number)) (values #t #f))
+   ((eqv? type (logand type &exact-integer)) (values #t #t))
+   (else (values #f #f))))
+
 (define-binary-branch-folder (eq? type0 min0 max0 type1 min1 max1)
   (cond
    ((or (zero? (logand type0 type1)) (< max0 min1) (< max1 min0))
@@ -274,6 +288,19 @@
 (define-syntax-rule (define-branch-reducer op f)
   (hashq-set! *branch-reducers* 'op f))
 
+(define-syntax-rule (define-branch-reducer-aliases def use ...)
+  (let ((proc (or (hashq-ref *branch-reducers* 'def)
+                  (error "not found" 'def))))
+    (define-branch-reducer use proc)
+    ...))
+
+(define-syntax-rule (define-unary-branch-reducer
+                      (op cps kf kt src arg type min max)
+                      body ...)
+  (define-branch-reducer op
+    (lambda (cps kf kt src param arg type min max)
+      body ...)))
+
 (define-syntax-rule (define-binary-branch-reducer
                       (op cps kf kt src
                           arg0 type0 min0 max0
@@ -283,6 +310,256 @@
     (lambda (cps kf kt src param arg0 type0 min0 max0 arg1 type1 min1 max1)
       body ...)))
 
+(define-unary-branch-reducer (number? cps kf kt src arg type min max)
+  (let ((number-types (logand type &number)))
+    (when (or (zero? number-types) (eqv? type number-types))
+      (error "should have folded!"))
+    (define-syntax-rule (define-heap-number-test test &type pred next-test)
+      (define (test cps)
+        (if (logtest type &type)
+            (with-cps cps
+              (let$ kf (next-test))
+              (letk k ($kargs () ()
+                        ($branch kf kt src 'pred #f (arg))))
+              k)
+            (next-test cps))))
+    (define (done cps) (with-cps cps kf))
+    (define-heap-number-test compnum-test &complex compnum? done)
+    (define-heap-number-test fracnum-test &fraction fracnum? compnum-test)
+    (define-heap-number-test bignum-test &bignum bignum? fracnum-test)
+    (define-heap-number-test flonum-test &flonum flonum? bignum-test)
+    (define (heap-number-tests cps) (flonum-test cps))
+    (cond
+     ((eqv? number-types &number)
+      ;; Generic: no reduction.
+      (with-cps cps #f))
+     ((eqv? number-types &fixnum)
+      (with-cps cps
+        (build-term
+          ($branch kf kt src 'fixnum? #f (arg)))))
+     ((logtest type &fixnum)
+      (with-cps cps
+        (let$ ktest (heap-number-tests))
+        (letk kheap ($kargs () ()
+                      ($branch kf ktest src 'heap-object? #f (arg))))
+        (build-term
+          ($branch kheap kt src 'fixnum? #f (arg)))))
+     (else
+      (with-cps cps
+        (let$ ktest (heap-number-tests))
+        (build-term
+          ($branch kf ktest src 'heap-object? #f (arg))))))))
+(define-branch-reducer-aliases number? complex?)
+
+(define-unary-branch-reducer (real? cps kf kt src arg type min max)
+  (let ((real-types (logand type &real)))
+    (when (or (zero? real-types) (eqv? type real-types))
+      (error "should have folded!"))
+    (define-syntax-rule (define-heap-number-test test &type pred next-test)
+      (define (test cps)
+        (if (logtest type &type)
+            (with-cps cps
+              (let$ kf (next-test))
+              (letk k ($kargs () ()
+                        ($branch kf kt src 'pred #f (arg))))
+              k)
+            (next-test cps))))
+    (define (done cps) (with-cps cps kf))
+    (define-heap-number-test fracnum-test &fraction fracnum? done)
+    (define-heap-number-test bignum-test &bignum bignum? fracnum-test)
+    (define-heap-number-test flonum-test &flonum flonum? bignum-test)
+    (define (heap-number-tests cps) (flonum-test cps))
+    (cond
+     ((eqv? real-types &real)
+      ;; Generic: no reduction.
+      (with-cps cps #f))
+     ((eqv? real-types &fixnum)
+      (with-cps cps
+        (build-term
+          ($branch kf kt src 'fixnum? #f (arg)))))
+     ((logtest type &fixnum)
+      (with-cps cps
+        (let$ ktest (heap-number-tests))
+        (letk kheap ($kargs () ()
+                      ($branch kf ktest src 'heap-object? #f (arg))))
+        (build-term
+          ($branch kheap kt src 'fixnum? #f (arg)))))
+     (else
+      (with-cps cps
+        (let$ ktest (heap-number-tests))
+        (build-term
+          ($branch kf ktest src 'heap-object? #f (arg))))))))
+
+(define-unary-branch-reducer (rational? cps kf kt src arg type min max)
+  (let ((number-types (logand type &number)))
+    (when (or (zero? number-types) (eqv? type (logand type &exact-number)))
+      (error "should have folded!"))
+    (define-syntax-rule (define-heap-number-test test &type pred next-test)
+      (define (test cps)
+        (if (logtest type &type)
+            (with-cps cps
+              (let$ kf (next-test))
+              (letk k ($kargs () ()
+                        ($branch kf kt src 'pred #f (arg))))
+              k)
+            (next-test cps))))
+    (define (done cps) (with-cps cps kf))
+    (define-heap-number-test fracnum-test &fraction fracnum? done)
+    (define-heap-number-test bignum-test &bignum bignum? fracnum-test)
+    (define (heap-number-tests cps) (bignum-test cps))
+    (cond
+     ((logtest type (logior &complex &flonum))
+      ;; Too annoying to inline inf / nan tests.
+      (with-cps cps #f))
+     ((eqv? number-types &fixnum)
+      (with-cps cps
+        (build-term
+          ($branch kf kt src 'fixnum? #f (arg)))))
+     ((logtest type &fixnum)
+      (with-cps cps
+        (let$ ktest (heap-number-tests))
+        (letk kheap ($kargs () ()
+                      ($branch kf ktest src 'heap-object? #f (arg))))
+        (build-term
+          ($branch kheap kt src 'fixnum? #f (arg)))))
+     (else
+      (with-cps cps
+        (let$ ktest (heap-number-tests))
+        (build-term
+          ($branch kf ktest src 'heap-object? #f (arg))))))))
+
+(define-unary-branch-reducer (integer? cps kf kt src arg type min max)
+  (define &integer-types (logior &fixnum &bignum &flonum &complex))
+  (let ((integer-types (logand type &integer-types)))
+    (when (or (zero? integer-types) (eqv? type (logand type &exact-integer)))
+      (error "should have folded!"))
+    (define-syntax-rule (define-heap-number-test test &type pred next-test)
+      (define (test cps)
+        (if (logtest type &type)
+            (with-cps cps
+              (let$ kf (next-test))
+              (letk k ($kargs () ()
+                        ($branch kf kt src 'pred #f (arg))))
+              k)
+            (next-test cps))))
+    (define (done cps) (with-cps cps kf))
+    (define-heap-number-test bignum-test &bignum bignum? done)
+    (define (heap-number-tests cps) (bignum-test cps))
+    (cond
+     ((logtest type (logior &complex &flonum))
+      ;; Too annoying to inline integer tests.
+      (with-cps cps #f))
+     ((eqv? integer-types &fixnum)
+      (with-cps cps
+        (build-term
+          ($branch kf kt src 'fixnum? #f (arg)))))
+     ((logtest type &fixnum)
+      (with-cps cps
+        (let$ ktest (heap-number-tests))
+        (letk kheap ($kargs () ()
+                      ($branch kf ktest src 'heap-object? #f (arg))))
+        (build-term
+          ($branch kheap kt src 'fixnum? #f (arg)))))
+     (else
+      (with-cps cps
+        (let$ ktest (heap-number-tests))
+        (build-term
+          ($branch kf ktest src 'heap-object? #f (arg))))))))
+
+(define-unary-branch-reducer (exact-integer? cps kf kt src arg type min max)
+  (let ((integer-types (logand type &exact-integer)))
+    (when (or (zero? integer-types) (eqv? type integer-types))
+      (error "should have folded!"))
+    (cond
+     ((eqv? integer-types &fixnum)
+      (with-cps cps
+        (build-term
+          ($branch kf kt src 'fixnum? #f (arg)))))
+     ((eqv? integer-types &bignum)
+      (with-cps cps
+        (letk kbig? ($kargs () ()
+                      ($branch kf kt src 'bignum? #f (arg))))
+        (build-term
+          ($branch kf kbig? src 'heap-object? #f (arg)))))
+     (else
+      ;; No reduction.
+      (with-cps cps #f)))))
+
+(define-unary-branch-reducer (exact? cps kf kt src arg type min max)
+  (let ((exact-types (logand type &exact-number)))
+    (when (or (zero? exact-types) (eqv? type exact-types))
+      (error "should have folded!"))
+    ;; We have already passed a number? check, so we can assume either
+    ;; fixnum or heap number.
+    (define-syntax-rule (define-number-test test &type pred next-test)
+      (define (test cps)
+        (if (logtest type &type)
+            (with-cps cps
+              (let$ kf (next-test))
+              (letk k ($kargs () ()
+                        ($branch kf kt src 'pred #f (arg))))
+              k)
+            (next-test cps))))
+    (define (done cps) (with-cps cps kf))
+    (define-number-test fracnum-test &fraction fracnum? done)
+    (define-number-test bignum-test &bignum bignum? fracnum-test)
+    (define-number-test fixnum-test &fixnum fixnum? bignum-test)
+    (define (number-tests cps) (fixnum-test cps))
+    (cond
+     ((eqv? exact-types &exact-number)
+      ;; Generic: no reduction.
+      (with-cps cps #f))
+     (else
+      (with-cps cps
+        (let$ ktest (number-tests))
+        (build-term
+          ($continue ktest #f ($values ()))))))))
+
+(define-unary-branch-reducer (inexact? cps kf kt src arg type min max)
+  (define &inexact-number (logior &flonum &complex))
+  (let ((inexact-types (logand type &inexact-number)))
+    (when (or (zero? inexact-types) (eqv? type inexact-types))
+      (error "should have folded!"))
+    ;; We have already passed a number? check, so we can assume either
+    ;; fixnum or heap number.
+    (cond
+     ((eqv? (logand type &exact-number) &fixnum)
+      (with-cps cps
+        (build-term
+          ($branch kt kf src 'fixnum? #f (arg)))))
+     ((logtest type &fixnum)
+      (cond
+       ((eqv? inexact-types &flonum)
+        (with-cps cps
+          (letk kflo ($kargs () ()
+                       ($branch kf kt src 'flonum? #f (arg))))
+          (build-term
+            ($branch kflo kf src 'fixnum? #f (arg)))))
+       ((eqv? inexact-types &complex)
+        (with-cps cps
+          (letk kcomp ($kargs () ()
+                        ($branch kf kt src 'compnum? #f (arg))))
+          (build-term
+            ($branch kcomp kf src 'fixnum? #f (arg)))))
+       (else
+        ;; Generic: no reduction.
+        (with-cps cps #f))))
+     ((eqv? inexact-types &flonum)
+      (with-cps cps
+        (build-term
+          ($branch kf kt src 'flonum? #f (arg)))))
+     ((eqv? inexact-types &complex)
+      (with-cps cps
+        (build-term
+          ($branch kf kt src 'compnum? #f (arg)))))
+     (else
+      ;; Still specialize, as we avoid heap-object?.
+      (with-cps cps
+        (letk kcomp ($kargs () ()
+                      ($branch kf kt src 'compnum? #f (arg))))
+        (build-term
+          ($branch kcomp kt src 'flonum? #f (arg))))))))
+
 (define-binary-branch-reducer (eq? cps kf kt src
                                    arg0 type0 min0 max0
                                    arg1 type1 min1 max1)
@@ -680,6 +957,17 @@
        (hashq-ref *branch-reducers* op)
        (lambda (reducer)
          (match args
+           ((arg0)
+            (call-with-values (lambda () (lookup-pre-type types label arg0))
+              (lambda (type0 min0 max0)
+                (call-with-values (lambda ()
+                                    (reducer cps kf kt src param
+                                             arg0 type0 min0 max0))
+                  (lambda (cps term)
+                    (and term
+                         (with-cps cps
+                           (setk label
+                                 ($kargs names vars ,term)))))))))
            ((arg0 arg1)
             (call-with-values (lambda () (lookup-pre-type types label arg0))
               (lambda (type0 min0 max0)

module/language/cps/types.scm

@@ -195,6 +195,8 @@
   (identifier-syntax (logior &fixnum &bignum &fraction)))
 (define-syntax &real
   (identifier-syntax (logior &fixnum &bignum &flonum &fraction)))
+(define-syntax &heap-number
+  (identifier-syntax (logior &flonum &bignum &complex &fraction)))
 (define-syntax &number
   (identifier-syntax (logior &fixnum &bignum &flonum &complex &fraction)))
 
@@ -633,13 +635,6 @@ 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-predicate-inferrer (fixnum? val true?)
   (cond
    (true?
@@ -674,10 +669,7 @@ minimum, and maximum."
 
 (define-syntax-rule (define-simple-predicate-inferrer predicate type)
   (define-predicate-inferrer (predicate val true?)
-    (let ((type (if true?
+    (restrict! val (if true? type (lognot type)) -inf.0 +inf.0)))
-                    type
-                    (logand (&type val) (lognot type)))))
-      (restrict! val type -inf.0 +inf.0))))
 
 (define-simple-predicate-inferrer bignum? &bignum)
 (define-simple-predicate-inferrer bitvector? &bitvector)
@@ -691,7 +683,6 @@ minimum, and maximum."
 (define-simple-predicate-inferrer immutable-vector? &immutable-vector)
 (define-simple-predicate-inferrer keyword? &keyword)
 (define-simple-predicate-inferrer mutable-vector? &mutable-vector)
-(define-simple-predicate-inferrer number? &number)
 (define-simple-predicate-inferrer pair? &pair)
 (define-simple-predicate-inferrer pointer? &pointer)
 (define-simple-predicate-inferrer program? &procedure)
@@ -701,6 +692,19 @@ minimum, and maximum."
 (define-simple-predicate-inferrer syntax? &syntax)
 (define-simple-predicate-inferrer variable? &box)
 
+(define-simple-predicate-inferrer number? &number)
+(define-type-inferrer-aliases number? rational? complex?)
+(define-simple-predicate-inferrer heap-number? &heap-number)
+(define-simple-predicate-inferrer real? &real)
+(let ((&maybe-integer (logior &exact-integer &flonum &complex)))
+  (define-simple-predicate-inferrer integer? &maybe-integer))
+(define-simple-predicate-inferrer exact-integer? &exact-integer)
+(define-simple-predicate-inferrer exact? &exact-number)
+(let ((&inexact-number (logior &flonum &complex)))
+  (define-simple-predicate-inferrer inexact? &inexact-number))
+
+(define-type-inferrer-aliases eq? heap-numbers-equal?)
+
 (define-predicate-inferrer (procedure? val true?)
   ;; Besides proper procedures, structs and smobs can also be applicable
   ;; in the guile-vm target.
@@ -1439,16 +1443,6 @@ minimum, and maximum."
    (else
     (define! result &special-immediate &false &true))))
 
-(define-simple-type-checker (exact? &number))
-(define-type-inferrer (exact? val result)
-  (restrict! val &number -inf.0 +inf.0)
-  (define-type-predicate-result val result &exact-number))
-
-(define-simple-type-checker (inexact? &number))
-(define-type-inferrer (inexact? val result)
-  (restrict! val &number -inf.0 +inf.0)
-  (define-type-predicate-result val result (logior &flonum &complex)))
-
 (define-simple-type-checker (inf? &real))
 (define-type-inferrer (inf? val result)
   (restrict! val &real -inf.0 +inf.0)

module/language/tree-il/compile-cps.scm

@@ -2004,14 +2004,32 @@ use as the proc slot."
          (($ <primcall> src (? branching-primitive? name) args)
           (convert-args cps args
             (lambda (cps args)
-              (if (heap-type-predicate? name)
+              (cond
+               ((heap-type-predicate? name)
                 (with-cps cps
                   (letk kt* ($kargs () ()
                               ($branch kf kt src name #f args)))
                   (build-term
-                      ($branch kf kt* src 'heap-object? #f args)))
+                    ($branch kf kt* src 'heap-object? #f args))))
+               ((number-type-predicate? name)
+                (match args
+                  ((arg)
+                   (define not-number
+                     (vector
+                      'wrong-type-arg
+                      (symbol->string name)
+                      "Wrong type argument in position 1 (expecting number): ~S"))
                    (with-cps cps
-                    (build-term ($branch kf kt src name #f args)))))))
+                     (letk kerr
+                           ($kargs () ()
+                             ($throw src 'throw/value+data not-number (arg))))
+                     (letk ktest ($kargs () ()
+                                   ($branch kf kt src name #f (arg))))
+                     (build-term
+                       ($branch kerr ktest src 'number? #f (arg)))))))
+               (else
+                (with-cps cps
+                  (build-term ($branch kf kt src name #f args))))))))
          (($ <conditional> src test consequent alternate)
           (with-cps cps
             (let$ t (convert-test consequent kt kf))
@@ -2230,16 +2248,6 @@ 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 a b))

module/language/tree-il/cps-primitives.scm

@@ -29,7 +29,8 @@
   #:use-module (system base types internal)
   #:export (tree-il-primitive->cps-primitive+nargs+nvalues
             branching-primitive?
-            heap-type-predicate?))
+            heap-type-predicate?
+            number-type-predicate?))
 
 (define *primitives* (make-hash-table))
 
@@ -175,15 +176,6 @@
 (visit-immediate-tags define-immediate-type-predicate)
 (visit-heap-tags define-heap-type-predicate)
 
-(define (branching-primitive? name)
-  "Is @var{name} a primitive that can only appear in $branch CPS terms?"
-  (hashq-ref *branching-primitive-arities* name))
-
-(define (heap-type-predicate? name)
-  "Is @var{name} a predicate that needs guarding by @code{heap-object?}
- before it is lowered to CPS?"
-  (hashq-ref *heap-type-predicates* name))
-
 ;; We only need to define those branching primitives that are used as
 ;; Tree-IL primitives.  There are others like u64-= which are emitted by
 ;; CPS code.
@@ -194,4 +186,34 @@
 (define-branching-primitive = 2)
 
 (define-branching-primitive procedure? 1)
+
 (define-branching-primitive number? 1)
+(define-branching-primitive complex? 1)
+(define-branching-primitive real? 1)
+(define-branching-primitive rational? 1)
+(define-branching-primitive integer? 1)
+(define-branching-primitive exact-integer? 1)
+
+(define *number-type-predicates* (make-hash-table))
+(define-syntax-rule (define-number-type-predicate pred nargs)
+  (begin
+    (hashq-set! *number-type-predicates* 'pred #t)
+    (define-branching-primitive pred nargs)))
+
+(define-number-type-predicate exact? 1)
+(define-number-type-predicate inexact? 1)
+
+(define (branching-primitive? name)
+  "Is @var{name} a primitive that can only appear in $branch CPS terms?"
+  (hashq-ref *branching-primitive-arities* name))
+
+(define (heap-type-predicate? name)
+  "Is @var{name} a predicate that needs guarding by @code{heap-object?}
+ before it is lowered to CPS?"
+  (hashq-ref *heap-type-predicates* name))
+
+(define (number-type-predicate? name)
+  "Is @var{name} a predicate that needs guarding by @code{number?}
+ before it is lowered to CPS?"
+  (hashq-ref *number-type-predicates* name))
+