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/tree-il | |
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/tree-il')
-rw-r--r-- | module/language/tree-il/compile-cps.scm | 44 | ||||
-rw-r--r-- | module/language/tree-il/cps-primitives.scm | 42 |
2 files changed, 58 insertions, 28 deletions
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)) + |