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

Insert explicit $ktrunc nodes everywhere that truncates multiple values

Browse source 
* module/language/tree-il/compile-cps.scm (init-default-value, convert):
  Explicitly insert $ktrunc nodes on all places that can truncate to
  single values.
This commit is contained in:
Andy Wingo 2014-01-10 17:44:10 +01:00
parent 22a79b55b8
commit 310866418b
1 changed files with 19 additions and 13 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -178,7 +178,7 @@
($continue k src ($primcall 'box (phi)))))) ($continue k src ($primcall 'box (phi))))))
,(make-body kbox)))) ,(make-body kbox))))
(make-body k))) (make-body k)))
(let-gensyms (knext kbound kunbound) (let-gensyms (knext kbound kunbound ktrunc krest val rest)
(build-cps-term (build-cps-term
($letk ((knext ($kargs (name) (subst-sym) ,body))) ($letk ((knext ($kargs (name) (subst-sym) ,body)))
,(maybe-box ,(maybe-box
@ -187,7 +187,11 @@
(build-cps-term (build-cps-term
($letk ((kbound ($kargs () () ($continue k src ($letk ((kbound ($kargs () () ($continue k src
($values (sym))))) ($values (sym)))))
(kunbound ($kargs () () ,(convert init k subst)))) (krest ($kargs (name 'rest) (val rest)
($continue k src ($values (val)))))
(ktrunc ($ktrunc (list name) 'rest krest))
(kunbound ($kargs () ()
,(convert init ktrunc subst))))
,(unbound? src sym kunbound kbound)))))))))))) ,(unbound? src sym kunbound kbound))))))))))))
;; exp k-name alist -> term ;; exp k-name alist -> term
@ -205,10 +209,11 @@
((subst #f) (k subst)) ((subst #f) (k subst))
(#f (k sym)))) (#f (k sym))))
(else (else
(let-gensyms (karg arg) (let-gensyms (ktrunc karg arg rest)
(build-cps-term (build-cps-term
($letk ((karg ($kargs ('arg) (arg) ,(k arg)))) ($letk ((karg ($kargs ('arg 'rest) (arg rest) ,(k arg)))
,(convert exp karg subst))))))) (ktrunc ($ktrunc '(arg) 'rest karg)))
,(convert exp ktrunc subst)))))))
;; (exp ...) ((v-name ...) -> term) -> term ;; (exp ...) ((v-name ...) -> term) -> term
(define (convert-args exps k) (define (convert-args exps k)
(match exps (match exps
@ -534,11 +539,11 @@
($continue k src ($primcall 'box-set! (box exp))))))))) ($continue k src ($primcall 'box-set! (box exp)))))))))
(($ <seq> src head tail) (($ <seq> src head tail)
(let-gensyms (ktrunc kseq) (let-gensyms (ktrunc kseq vals)
(build-cps-term (build-cps-term
($letk* ((kseq ($kargs () () ($letk* ((kseq ($kargs ('vals) (vals)
,(convert tail k subst))) ,(convert tail k subst)))
(ktrunc ($ktrunc '() #f kseq))) (ktrunc ($ktrunc '() 'vals kseq)))
,(convert head ktrunc subst))))) ,(convert head ktrunc subst)))))
(($ <let> src names syms vals body) (($ <let> src names syms vals body)
@ -546,12 +551,13 @@
(match (list names syms vals) (match (list names syms vals)
((() () ()) (convert body k subst)) ((() () ()) (convert body k subst))
(((name . names) (sym . syms) (val . vals)) (((name . names) (sym . syms) (val . vals))
(let-gensyms (klet) (let-gensyms (ktrunc klet rest)
(build-cps-term (build-cps-term
($letk ((klet ($kargs (name) (sym) ($letk* ((klet ($kargs (name 'rest) (sym rest)
,(box-bound-var name sym ,(box-bound-var name sym
(lp names syms vals))))) (lp names syms vals))))
,(convert val klet subst)))))))) (ktrunc ($ktrunc (list name) 'rest klet)))
,(convert val ktrunc 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.