mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 22:31:12 +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 • committed by Andy Wingo
parent 67901cde76
commit 4002849393
1 changed files with 35 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -285,6 +285,7 @@
(letk kval ($kargs ('val) (val) (letk kval ($kargs ('val) (val)
($continue k src ($values (val))))) ($continue k src ($values (val)))))
kval)) kval))
(($ $kargs (_)) (with-cps cps k))
(($ $kreceive arity kargs) (($ $kreceive arity kargs)
(match arity (match arity
(($ $arity () () (not #f) () #f) (($ $arity () () (not #f) () #f)
@ -317,6 +318,23 @@
;; cps exp k-name alist -> cps term ;; cps exp k-name alist -> cps term
(define (convert cps exp k subst) (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 ;; exp (v-name -> term) -> term
(define (convert-arg cps exp k) (define (convert-arg cps exp k)
(match exp (match exp
@ -330,7 +348,13 @@
(build-term ($continue kunboxed src ($primcall 'box-ref #f (box)))))) (build-term ($continue kunboxed src ($primcall 'box-ref #f (box))))))
((orig-var subst-var #f) (k cps subst-var)) ((orig-var subst-var #f) (k cps subst-var))
(var (k cps 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 (with-cps cps
(letv arg rest) (letv arg rest)
(let$ body (k arg)) (let$ body (k arg))
@ -900,10 +924,16 @@
(with-cps cps (with-cps cps
(let$ body (lp names syms vals)) (let$ body (lp names syms vals))
(let$ body (box-bound-var name sym body)) (let$ body (box-bound-var name sym body))
(letv rest) ($ ((lambda (cps)
(letk klet ($kargs (name 'rest) ((bound-var sym) rest) ,body)) (if (single-valued? val)
(letk kreceive ($kreceive (list name) 'rest klet)) (with-cps cps
($ (convert val kreceive subst))))))) (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) (($ <fix> src names gensyms funs body)
;; Some letrecs can be contified; that happens later. ;; Some letrecs can be contified; that happens later.