mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Code Activity

Avoid generating arity-adapting continuations if not needed

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2017-11-30 18:15:01 +01:00
parent 3e6857a535
commit 83042571c1
1 changed files with 36 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

42
module/language/tree-il/compile-cps.scm
View file

@ -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.