This is an automated email from the git hooks/post-receive script.
wingo pushed a commit to branch main
in repository guile.
The following commit(s) were added to refs/heads/main by this push:
new 55256ab33 Better compilation for rational?, exact?, and so on
55256ab33 is described below
commit 55256ab33f14cd75778f089c5d96ea42f5b44397
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Fri Sep 15 15:21:26 2023 +0200
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 | 14 +-
module/language/cps/guile-vm/lower-primcalls.scm | 81 ++++++
module/language/cps/type-fold.scm | 304 ++++++++++++++++++++++-
module/language/cps/types.scm | 38 ++-
module/language/tree-il/compile-cps.scm | 44 ++--
module/language/tree-il/cps-primitives.scm | 42 +++-
6 files changed, 458 insertions(+), 65 deletions(-)
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index 66f95a6bb..b22dff92e 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/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)
- ((real? _) &type-check)
- ((rational? _) &type-check)
+ ((number? _))
+ ((complex? _))
+ ((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)
diff --git a/module/language/cps/guile-vm/lower-primcalls.scm
b/module/language/cps/guile-vm/lower-primcalls.scm
index cff370431..a0271b9cc 100644
--- a/module/language/cps/guile-vm/lower-primcalls.scm
+++ b/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
diff --git a/module/language/cps/type-fold.scm
b/module/language/cps/type-fold.scm
index f030c41e4..a07950d81 100644
--- a/module/language/cps/type-fold.scm
+++ b/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)
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 422e31ec0..94473de5b 100644
--- a/module/language/cps/types.scm
+++ b/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?
- type
- (logand (&type val) (lognot type)))))
- (restrict! val type -inf.0 +inf.0))))
+ (restrict! val (if true? type (lognot 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)
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 42a1c90da..1c4139439 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/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)
- (with-cps cps
- (letk kt* ($kargs () ()
- ($branch kf kt src name #f args)))
- (build-term
- ($branch kf kt* src 'heap-object? #f args)))
- (with-cps cps
- (build-term ($branch kf kt src name #f args)))))))
+ (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))))
+ ((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
+ (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))
diff --git a/module/language/tree-il/cps-primitives.scm
b/module/language/tree-il/cps-primitives.scm
index 5e7199d78..367a1cb4b 100644
--- a/module/language/tree-il/cps-primitives.scm
+++ 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))
+
