[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/02: Avoid generating arity-adapting zero-value conts
From: |
Andy Wingo |
Subject: |
[Guile-commits] 02/02: Avoid generating arity-adapting zero-value conts where possible |
Date: |
Sat, 2 Dec 2017 04:21:42 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit 0cbba8efe0ca7ea195ca6579a6f2d8f16c2115da
Author: Andy Wingo <address@hidden>
Date: Thu Nov 30 18:42:35 2017 +0100
Avoid generating arity-adapting zero-value conts where possible
* module/language/tree-il/compile-cps.scm (adapt-arity, convert): Avoid
generating arity-adapting continuations for nullary continuations.
---
module/language/tree-il/compile-cps.scm | 39 ++++++++++++++++++++++++++++-----
1 file changed, 33 insertions(+), 6 deletions(-)
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 875aa8e..49274c4 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -248,6 +248,7 @@
($continue k src ($values (unspecified))))))
(letk kvoid ($kargs () () ,body))
kvoid))
+ (($ $kargs ()) (with-cps cps k))
(($ $kreceive arity kargs)
(match arity
(($ $arity () () (not #f) () #f)
@@ -318,6 +319,26 @@
;; cps exp k-name alist -> cps term
(define (convert cps exp k subst)
+ (define (zero-valued? exp)
+ (match exp
+ ((or ($ <module-set>) ($ <toplevel-set>) ($ <toplevel-define>)
+ ($ <lexical-set>))
+ #t)
+ (($ <let> src names syms vals body) (zero-valued? body))
+ ;; Can't use <fix> here as the hack that <fix> uses to convert its
+ ;; functions relies on continuation being single-valued.
+ ;; (($ <fix> src names syms vals body) (zero-valued? body))
+ (($ <let-values> src exp body) (zero-valued? body))
+ (($ <seq> src head tail) (zero-valued? tail))
+ (($ <primcall> src name args)
+ (match (prim-instruction name)
+ (#f #f)
+ (inst
+ (match (prim-arity inst)
+ ((out . in)
+ (and (eqv? out 0)
+ (eqv? in (length args))))))))
+ (_ #f)))
(define (single-valued? exp)
(match exp
((or ($ <void>) ($ <const>) ($ <primitive-ref>) ($ <module-ref>)
@@ -326,6 +347,7 @@
(($ <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))
+ (($ <seq> src head tail) (single-valued? tail))
(($ <primcall> src name args)
(match (prim-instruction name)
(#f #f)
@@ -909,12 +931,17 @@
($continue k src ($primcall 'box-set! #f (box exp))))))))))
(($ <seq> src head tail)
- (with-cps cps
- (let$ tail (convert tail k subst))
- (letv vals)
- (letk kseq ($kargs ('vals) (vals) ,tail))
- (letk kreceive ($kreceive '() 'vals kseq))
- ($ (convert head kreceive subst))))
+ (if (zero-valued? head)
+ (with-cps cps
+ (let$ tail (convert tail k subst))
+ (letk kseq ($kargs () () ,tail))
+ ($ (convert head kseq subst)))
+ (with-cps cps
+ (let$ tail (convert tail k subst))
+ (letv vals)
+ (letk kseq ($kargs ('vals) (vals) ,tail))
+ (letk kreceive ($kreceive '() 'vals kseq))
+ ($ (convert head kreceive subst)))))
(($ <let> src names syms vals body)
(let lp ((cps cps) (names names) (syms syms) (vals vals))