[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/02: Avoid generating arity-adapting continuations if
From: |
Andy Wingo |
Subject: |
[Guile-commits] 01/02: Avoid generating arity-adapting continuations if not needed |
Date: |
Sat, 2 Dec 2017 04:21:41 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit 40028493936a09278d5c6e907d4448e9aaa0f682
Author: Andy Wingo <address@hidden>
Date: Thu Nov 30 18:15:01 2017 +0100
Avoid generating arity-adapting continuations if not needed
* module/language/tree-il/compile-cps.scm (adapt-arity): Allow k to be
$kargs for the 1-valued case.
(convert): For single-valued continuations where the definition is
clearly single-valued, avoid making a needless $kreceive and extra
"rest" binding that will just be filled with () and have to be
eliminated later.
---
module/language/tree-il/compile-cps.scm | 40 ++++++++++++++++++++++++++++-----
1 file changed, 35 insertions(+), 5 deletions(-)
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index cb43447..875aa8e 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -285,6 +285,7 @@
(letk kval ($kargs ('val) (val)
($continue k src ($values (val)))))
kval))
+ (($ $kargs (_)) (with-cps cps k))
(($ $kreceive arity kargs)
(match arity
(($ $arity () () (not #f) () #f)
@@ -317,6 +318,23 @@
;; cps exp k-name alist -> cps term
(define (convert cps exp k subst)
+ (define (single-valued? exp)
+ (match exp
+ ((or ($ <void>) ($ <const>) ($ <primitive-ref>) ($ <module-ref>)
+ ($ <toplevel-ref>) ($ <lambda>))
+ #t)
+ (($ <let> src names syms vals body) (single-valued? body))
+ (($ <fix> src names syms vals body) (single-valued? body))
+ (($ <let-values> src exp body) (single-valued? body))
+ (($ <primcall> src name args)
+ (match (prim-instruction name)
+ (#f #f)
+ (inst
+ (match (prim-arity inst)
+ ((out . in)
+ (and (eqv? out 1)
+ (eqv? in (length args))))))))
+ (_ #f)))
;; exp (v-name -> term) -> term
(define (convert-arg cps exp k)
(match exp
@@ -330,7 +348,13 @@
(build-term ($continue kunboxed src ($primcall 'box-ref #f
(box))))))
((orig-var subst-var #f) (k cps subst-var))
(var (k cps var))))
- (else
+ ((? single-valued?)
+ (with-cps cps
+ (letv arg)
+ (let$ body (k arg))
+ (letk karg ($kargs ('arg) (arg) ,body))
+ ($ (convert exp karg subst))))
+ (_
(with-cps cps
(letv arg rest)
(let$ body (k arg))
@@ -900,10 +924,16 @@
(with-cps cps
(let$ body (lp names syms vals))
(let$ body (box-bound-var name sym body))
- (letv rest)
- (letk klet ($kargs (name 'rest) ((bound-var sym) rest) ,body))
- (letk kreceive ($kreceive (list name) 'rest klet))
- ($ (convert val kreceive subst)))))))
+ ($ ((lambda (cps)
+ (if (single-valued? val)
+ (with-cps cps
+ (letk klet ($kargs (name) ((bound-var sym)) ,body))
+ ($ (convert val klet subst)))
+ (with-cps cps
+ (letv rest)
+ (letk klet ($kargs (name 'rest) ((bound-var sym) rest)
,body))
+ (letk kreceive ($kreceive (list name) 'rest klet))
+ ($ (convert val kreceive subst))))))))))))
(($ <fix> src names gensyms funs body)
;; Some letrecs can be contified; that happens later.