summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2017-11-03 10:36:00 +0100
committerAndy Wingo <wingo@pobox.com>2017-11-05 15:00:16 +0100
commitdea84a46b476643ea0abf7133ff4bdf59c46a88e (patch)
treeb3c403a65482ea332f4e5f0badc09b9b9790fb5d
parent5457f28af9c4cea934f61b0e11e2ebdd7e2ce718 (diff)
downloadguile-dea84a46b476643ea0abf7133ff4bdf59c46a88e.tar.gz
Earlier conversion to /imm primcalls
* module/language/tree-il/compile-cps.scm (convert): Convert to /imm variants of primcalls early on, to decrease complexity of later passes.
-rw-r--r--module/language/tree-il/compile-cps.scm75
1 files changed, 56 insertions, 19 deletions
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index be7fe642a..6835ce08e 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -646,27 +646,64 @@
(lambda (cps integer)
(have-args cps (list integer)))))))
(else (have-args cps args))))
+ (define (convert-primcall cps k src instruction args)
+ (define (default)
+ (convert-args cps args
+ (lambda (cps args)
+ (unbox-args
+ cps args
+ (lambda (cps args)
+ (with-cps cps
+ (build-term
+ ($continue k src
+ ($primcall instruction #f args)))))))))
+ (define-syntax-rule (specialize-case (pat (op c (arg ...))) ...
+ (_ def))
+ (match (cons instruction args)
+ (pat
+ (convert-args cps (list arg ...)
+ (lambda (cps args)
+ (with-cps cps
+ (build-term
+ ($continue k src ($primcall 'op c args)))))))
+ ...
+ (_ def)))
+ (define (uint? val) (and (exact-integer? val) (<= 0 val)))
+ ;; FIXME: Add cases for mul, rsh, lsh
+ (specialize-case
+ (('make-vector ($ <const> _ (? uint? n)) init)
+ (make-vector/immediate n (init)))
+ (('vector-ref v ($ <const> _ (? uint? n)))
+ (vector-ref/immediate n (v)))
+ (('vector-set! v ($ <const> _ (? uint? n)) x)
+ (vector-set!/immediate n (v x)))
+ (('allocate-struct v ($ <const> _ (? uint? n)))
+ (allocate-struct/immediate n (v)))
+ (('struct-ref s ($ <const> _ (? uint? n)))
+ (struct-ref/immediate n (s)))
+ (('struct-set! s ($ <const> _ (? uint? n)) x)
+ (struct-set!/immediate n (s x)))
+ (('add x ($ <const> _ (? number? y)))
+ (add/immediate y (x)))
+ (('add ($ <const> _ (? number? y)) x)
+ (add/immediate y (x)))
+ (('sub x ($ <const> _ (? number? y)))
+ (sub/immediate y (x)))
+ (_ (default))))
(when (branching-primitive? name)
(error "branching primcall in bad context" name))
- (convert-args cps args
- (lambda (cps args)
- ;; Tree-IL primcalls are sloppy, in that it could be
- ;; that they are called with too many or too few
- ;; arguments. In CPS we are more strict and only
- ;; residualize a $primcall if the argument count
- ;; matches.
- (match (prim-arity instruction)
- ((out . in)
- (if (= in (length args))
- (with-cps cps
- (let$ k (box+adapt-arity k src out))
- ($ (unbox-args
- args
- (lambda (cps args)
- (with-cps cps
- (build-term
- ($continue k src
- ($primcall instruction #f args))))))))
+ ;; Tree-IL primcalls are sloppy, in that it could be that
+ ;; they are called with too many or too few arguments. In
+ ;; CPS we are more strict and only residualize a $primcall
+ ;; if the argument count matches.
+ (match (prim-arity instruction)
+ ((out . in)
+ (if (= in (length args))
+ (with-cps cps
+ (let$ k (box+adapt-arity k src out))
+ ($ (convert-primcall k src instruction args)))
+ (convert-args cps args
+ (lambda (cps args)
(with-cps cps
(letv prim)
(letk kprim ($kargs ('prim) (prim)