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

CPS conversion avoids residualizing unknown primcalls

Browse source 
* module/language/tree-il/compile-cps.scm: Avoid residualizing "apply"
  or "abort-to-prompt" primcalls; instead, these are just calls to
  $prim.
This commit is contained in:
Andy Wingo 2017-12-27 11:06:25 +01:00
parent 7f7cbe8b65
commit c9efff30de
1 changed files with 15 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -864,13 +864,15 @@
(build-term ($continue kbody (tree-il-src body) (build-term ($continue kbody (tree-il-src body)
($prompt #f tag khargs)))))))) ($prompt #f tag khargs))))))))
(with-cps cps (with-cps cps
(letv prim vals) (letv prim vals apply)
(let$ hbody (convert hbody k subst)) (let$ hbody (convert hbody k subst))
(let$ hbody (box-bound-vars hnames hsyms hbody)) (let$ hbody (box-bound-vars hnames hsyms hbody))
(letk khbody ($kargs hnames bound-vars ,hbody)) (letk khbody ($kargs hnames bound-vars ,hbody))
(letk khargs ($kreceive hreq hrest khbody)) (letk khargs ($kreceive hreq hrest khbody))
(letk kapp ($kargs ('apply) (apply)
($continue k src ($call apply (prim vals)))))
(letk kprim ($kargs ('prim) (prim) (letk kprim ($kargs ('prim) (prim)
($continue k src ($primcall 'apply #f (prim vals))))) ($continue kapp src ($prim 'apply))))
(letk kret ($kargs () () (letk kret ($kargs () ()
($continue kprim src ($prim 'values)))) ($continue kprim src ($prim 'values))))
(letk kpop ($kargs ('rest) (vals) (letk kpop ($kargs ('rest) (vals)
@ -883,17 +885,24 @@
(convert-args cps (cons tag args) (convert-args cps (cons tag args)
(lambda (cps args*) (lambda (cps args*)
(with-cps cps (with-cps cps
(letv abort)
(letk kabort ($kargs ('abort) (abort)
($continue k src ($call abort args*))))
(build-term (build-term
($continue k src ($primcall 'abort-to-prompt #f args*))))))) ($continue kabort src ($prim 'abort-to-prompt)))))))
(($ <abort> src tag args tail) (($ <abort> src tag args tail)
(convert-args cps (convert-args cps
(append (list (make-primitive-ref #f 'abort-to-prompt) tag) (append (list (make-primitive-ref #f 'apply)
(make-primitive-ref #f 'abort-to-prompt)
tag)
args args
(list tail)) (list tail))
(lambda (cps args*) (lambda (cps args*)
(with-cps cps (match args*
(build-term ($continue k src ($primcall 'apply #f args*))))))) ((apply . apply-args)
(with-cps cps
(build-term ($continue k src ($call apply apply-args)))))))))
(($ <conditional> src test consequent alternate) (($ <conditional> src test consequent alternate)
(define (convert-test cps test kt kf) (define (convert-test cps test kt kf)