[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Avoid generating arity-adapting continuations if
From: |
Andy Wingo |
Subject: |
[Guile-commits] 01/01: Avoid generating arity-adapting continuations if not needed |
Date: |
Thu, 30 Nov 2017 12:32:45 -0500 (EST) |
wingo pushed a commit to branch stable-2.2
in repository guile.
commit 83042571c1281d7fffb8882b3cfdd6dbaa19dbe0
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 | 42 ++++++++++++++++++++++++++++-----
1 file changed, 36 insertions(+), 6 deletions(-)
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 3e1c1d4..4c71dc7 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -289,6 +289,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)
@@ -321,6 +322,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
@@ -334,7 +352,13 @@
(build-term ($continue kunboxed src ($primcall 'box-ref (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))
@@ -836,10 +860,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.