[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Avoid generating arity-adapting zero-value conts
From: |
Andy Wingo |
Subject: |
[Guile-commits] 01/01: Avoid generating arity-adapting zero-value conts where possible |
Date: |
Fri, 1 Dec 2017 05:01:54 -0500 (EST) |
wingo pushed a commit to branch stable-2.2
in repository guile.
commit 19c0e302430af50d1b41316b929159d592f27ce3
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 4c71dc7..6afbc17 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -252,6 +252,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)
@@ -322,6 +323,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>)
@@ -330,6 +351,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)
@@ -845,12 +867,17 @@
($continue k src ($primcall 'box-set! (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))