diff options
author | Andy Wingo <wingo@pobox.com> | 2023-09-15 15:21:26 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2023-09-15 15:21:26 +0200 |
commit | 55256ab33f14cd75778f089c5d96ea42f5b44397 (patch) | |
tree | 165b71bc0f4378fb57d66d5e2e42ce5705d8ffbc /module/language | |
parent | d5347b59fb25a61c37990db6248072c7cb413a7f (diff) | |
download | guile-55256ab33f14cd75778f089c5d96ea42f5b44397.tar.gz |
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.
Diffstat (limited to 'module/language')
-rw-r--r-- | module/language/cps/effects-analysis.scm | 14 | ||||
-rw-r--r-- | module/language/cps/guile-vm/lower-primcalls.scm | 81 | ||||
-rw-r--r-- | module/language/cps/type-fold.scm | 304 | ||||
-rw-r--r-- | module/language/cps/types.scm | 38 | ||||
-rw-r--r-- | module/language/tree-il/compile-cps.scm | 44 | ||||
-rw-r--r-- | 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)) + |