mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
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.
This commit is contained in:
Andy Wingo
parent
d5347b59fb
commit
55256ab33f
6 changed files with 458 additions and 65 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue