summaryrefslogtreecommitdiff
path: root/module/language/tree-il
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2023-09-15 15:21:26 +0200
committerAndy Wingo <wingo@pobox.com>2023-09-15 15:21:26 +0200
commit55256ab33f14cd75778f089c5d96ea42f5b44397 (patch)
tree165b71bc0f4378fb57d66d5e2e42ce5705d8ffbc /module/language/tree-il
parentd5347b59fb25a61c37990db6248072c7cb413a7f (diff)
downloadguile-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.scm44
-rw-r--r--module/language/tree-il/cps-primitives.scm42
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))
+