[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 06/07: Adapt return arities in Tree-IL -> CPS2 conversio
From: |
Andy Wingo |
Subject: |
[Guile-commits] 06/07: Adapt return arities in Tree-IL -> CPS2 conversion |
Date: |
Mon, 11 May 2015 20:46:12 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit 9833c545cc35e200482a09530ca5b38c9f3f2078
Author: Andy Wingo <address@hidden>
Date: Sat May 9 11:25:43 2015 +0200
Adapt return arities in Tree-IL -> CPS2 conversion
* module/language/tree-il/compile-cps2.scm (adapt-arity): New
procedure. This is equivalent to (language cps arities), but as it
is a necessary pass and not an optimization it's more proper to put
it in the converter itself. Unlike with the nested CPS
representation, it's possible to look up continuations without
making a DFG.
(convert): Adapt arities as necessary.
---
module/language/tree-il/compile-cps2.scm | 190 +++++++++++++++++++++++++++---
1 files changed, 173 insertions(+), 17 deletions(-)
diff --git a/module/language/tree-il/compile-cps2.scm
b/module/language/tree-il/compile-cps2.scm
index aa3c4d2..2f25451 100644
--- a/module/language/tree-il/compile-cps2.scm
+++ b/module/language/tree-il/compile-cps2.scm
@@ -309,6 +309,119 @@
(letk kunbound ($kargs () () ,init))
($ (unbound? src orig-var kunbound kbound)))))))))))
+;;; The conversion from Tree-IL to CPS essentially wraps every
+;;; expression in a $kreceive, which models the Tree-IL semantics that
+;;; extra values are simply truncated. In CPS, this means that the
+;;; $kreceive has a rest argument after the required arguments, if any,
+;;; and that the rest argument is unused.
+;;;
+;;; All CPS expressions that can return a variable number of values
+;;; (i.e., $call and $abort) must continue to $kreceive, which checks
+;;; the return arity and on success passes the parsed values along to a
+;;; $kargs. If the $call or $abort is in tail position they continue to
+;;; $ktail instead, and then the values are parsed by the $kreceive of
+;;; the non-tail caller.
+;;;
+;;; Other CPS terms like $values, $const, and the like all have a
+;;; specific return arity, and must continue to $kargs instead of
+;;; $kreceive or $ktail. This allows the compiler to reason precisely
+;;; about their result values. To make sure that this is the case,
+;;; whenever the CPS conversion would reify one of these terms it needs
+;;; to ensure that the continuation actually accepts the return arity of
+;;; the primcall.
+;;;
+;;; Some Tree-IL primcalls residualize CPS primcalls that return zero
+;;; values, for example box-set!. In this case the Tree-IL semantics
+;;; are that the result of the expression is the undefined value. That
+;;; is to say, the result of this expression is #t:
+;;;
+;;; (let ((x 30)) (eq? (set! x 10) (if #f #f)))
+;;;
+;;; So in the case that the continuation expects a value but the
+;;; primcall produces zero values, we insert the "unspecified" value.
+;;;
+(define (adapt-arity cps k src nvals)
+ (match nvals
+ (0
+ ;; As mentioned above, in the Tree-IL semantics the primcall
+ ;; produces the unspecified value, but in CPS it produces no
+ ;; values. Therefore we plug the unspecified value into the
+ ;; continuation.
+ (match (intmap-ref cps k)
+ (($ $ktail)
+ (with-cps cps
+ (let$ body (with-cps-constants ((unspecified *unspecified*))
+ (build-term
+ ($continue k src ($primcall 'return (unspecified))))))
+ (letk kvoid ($kargs () () ,body))
+ kvoid))
+ (($ $kreceive arity kargs)
+ (match arity
+ (($ $arity () () (not #f) () #f)
+ (with-cps cps
+ (letk kvoid ($kargs () () ($continue kargs src ($const '()))))
+ kvoid))
+ (($ $arity (_) () #f () #f)
+ (with-cps cps
+ (letk kvoid ($kargs () ()
+ ($continue kargs src ($const *unspecified*))))
+ kvoid))
+ (($ $arity (_) () _ () #f)
+ (with-cps cps
+ (let$ void (with-cps-constants ((unspecified *unspecified*)
+ (rest '()))
+ (build-term
+ ($continue kargs src
+ ($values (unspecified rest))))))
+ (letk kvoid ($kargs () () ,void))
+ kvoid))
+ (_
+ ;; Arity mismatch. Serialize a values call.
+ (with-cps cps
+ (let$ void (with-cps-constants ((unspecified *unspecified*))
+ (build-term
+ ($continue k src
+ ($primcall 'values (unspecified))))))
+ (letk kvoid ($kargs () () ,void))
+ kvoid))))))
+ (1
+ (match (intmap-ref cps k)
+ (($ $ktail)
+ (with-cps cps
+ (letv val)
+ (letk kval ($kargs ('val) (val)
+ ($continue k src ($primcall 'return (val)))))
+ kval))
+ (($ $kreceive arity kargs)
+ (match arity
+ (($ $arity () () (not #f) () #f)
+ (with-cps cps
+ (letv val)
+ (let$ body (with-cps-constants ((nil '()))
+ (build-term
+ ($continue kargs src ($primcall 'cons (val
nil))))))
+ (letk kval ($kargs ('val) (val) ,body))
+ kval))
+ (($ $arity (_) () #f () #f)
+ (with-cps cps
+ kargs))
+ (($ $arity (_) () _ () #f)
+ (with-cps cps
+ (letv val)
+ (let$ body (with-cps-constants ((rest '()))
+ (build-term
+ ($continue kargs src ($values (val rest))))))
+ (letk kval ($kargs ('val) (val) ,body))
+ kval))
+ (_
+ ;; Arity mismatch. Serialize a values call.
+ (with-cps cps
+ (letv val)
+ (letk kval ($kargs ('val) (val)
+ ($continue k src
+ ($primcall 'values (val)))))
+ kval))))))))
+
;; cps exp k-name alist -> cps term
(define (convert cps exp k subst)
;; exp (v-name -> term) -> term
@@ -364,6 +477,7 @@
(match exp
(($ <lexical-ref> src name sym)
(with-cps cps
+ (let$ k (adapt-arity k src 1))
(rewrite-term (hashq-ref subst sym)
((orig-var box #t) ($continue k src ($primcall 'box-ref (box))))
((orig-var subst-var #f) ($continue k src ($values (subst-var))))
@@ -371,14 +485,17 @@
(($ <void> src)
(with-cps cps
+ (let$ k (adapt-arity k src 1))
(build-term ($continue k src ($const *unspecified*)))))
(($ <const> src exp)
(with-cps cps
+ (let$ k (adapt-arity k src 1))
(build-term ($continue k src ($const exp)))))
(($ <primitive-ref> src name)
(with-cps cps
+ (let$ k (adapt-arity k src 1))
(build-term ($continue k src ($prim name)))))
(($ <lambda> fun-src meta body)
@@ -426,6 +543,7 @@
(letk ktail ($ktail))
(let$ kclause (convert-clauses body ktail))
(letk kfun ($kfun fun-src meta self ktail kclause))
+ (let$ k (adapt-arity k fun-src 1))
(build-term ($continue k fun-src ($fun kfun))))
(let ((scope-id (fresh-scope-id)))
(with-cps cps
@@ -440,6 +558,7 @@
cps src mod name public? #t
(lambda (cps box)
(with-cps cps
+ (let$ k (adapt-arity k src 1))
(build-term ($continue k src ($primcall 'box-ref (box))))))))
(($ <module-set> src mod name public? exp)
@@ -449,6 +568,7 @@
cps src mod name public? #t
(lambda (cps box)
(with-cps cps
+ (let$ k (adapt-arity k src 0))
(build-term
($continue k src ($primcall 'box-set! (box val))))))))))
@@ -457,6 +577,7 @@
cps src name #t
(lambda (cps box)
(with-cps cps
+ (let$ k (adapt-arity k src 1))
(build-term ($continue k src ($primcall 'box-ref (box))))))))
(($ <toplevel-set> src name exp)
@@ -466,6 +587,7 @@
cps src name #f
(lambda (cps box)
(with-cps cps
+ (let$ k (adapt-arity k src 0))
(build-term
($continue k src ($primcall 'box-set! (box val))))))))))
@@ -473,6 +595,7 @@
(convert-arg cps exp
(lambda (cps val)
(with-cps cps
+ (let$ k (adapt-arity k src 0))
($ (with-cps-constants ((name name))
(build-term
($continue k src ($primcall 'define! (name val))))))))))
@@ -490,6 +613,7 @@
(convert-args cps args
(lambda (cps args)
(with-cps cps
+ (let$ k (adapt-arity k src 1))
(letk kt ($kargs () () ($continue k src ($const #t))))
(letk kf ($kargs () () ($continue k src ($const #f))))
(build-term ($continue kf src
@@ -498,6 +622,7 @@
(convert-args cps args
(lambda (cps args)
(with-cps cps
+ (let$ k (adapt-arity k src 1))
(letk kt ($kargs () () ($continue k src ($const #f))))
(letk kf ($kargs () () ($continue k src ($const #t))))
(build-term ($continue kf src
@@ -512,26 +637,56 @@
args))
;; See note below in `canonicalize' about `vector'. The same
;; thing applies to `list'.
- (let lp ((cps cps) (args args) (k k))
- (match args
- (()
- (with-cps cps
- (build-term ($continue k src ($const '())))))
- ((arg . args)
- (with-cps cps
- (letv tail)
- (let$ body (convert-arg arg
- (lambda (cps head)
- (with-cps cps
- (build-term ($continue k src
- ($primcall 'cons (head
tail))))))))
- (letk ktail ($kargs ('tail) (tail) ,body))
- ($ (lp args ktail)))))))
+ (with-cps cps
+ (let$ k (adapt-arity k src 1))
+ ($ ((lambda (cps)
+ (let lp ((cps cps) (args args) (k k))
+ (match args
+ (()
+ (with-cps cps
+ (build-term ($continue k src ($const '())))))
+ ((arg . args)
+ (with-cps cps
+ (letv tail)
+ (let$ body (convert-arg arg
+ (lambda (cps head)
+ (with-cps cps
+ (build-term
+ ($continue k src
+ ($primcall 'cons (head tail))))))))
+ (letk ktail ($kargs ('tail) (tail) ,body))
+ ($ (lp args ktail)))))))))))
+ ((prim-instruction name)
+ => (lambda (name)
+ (convert-args cps args
+ (lambda (cps args)
+ ;; Tree-IL primcalls are sloppy, in that it could be
+ ;; that they are called with too many or too few
+ ;; arguments. In CPS we are more strict and only
+ ;; residualize a $primcall if the argument count
+ ;; matches.
+ (match (prim-arity name)
+ ((out . in)
+ (if (= in (length args))
+ (with-cps cps
+ (let$ k (adapt-arity k src out))
+ (build-term
+ ($continue k src
+ ($primcall name args))))
+ (with-cps cps
+ (letv prim)
+ (letk kprim ($kargs ('prim) (prim)
+ ($continue k src ($call prim args))))
+ (build-term ($continue kprim src ($prim
name)))))))))))
(else
+ ;; We have something that's a primcall for Tree-IL but not for
+ ;; CPS, which will get compiled as a call and so the right thing
+ ;; to do is to continue to the given $ktail or $kreceive.
(convert-args cps args
(lambda (cps args)
(with-cps cps
- (build-term ($continue k src ($primcall name args)))))))))
+ (build-term
+ ($continue k src ($primcall name args)))))))))
;; Prompts with inline handlers.
(($ <prompt> src escape-only? tag body
@@ -627,6 +782,7 @@
(match (hashq-ref subst gensym)
((orig-var box #t)
(with-cps cps
+ (let$ k (adapt-arity k src 0))
(build-term
($continue k src ($primcall 'box-set! (box exp))))))))))
@@ -885,7 +1041,7 @@ integer."
env))
;;; Local Variables:
-;;; eval: (put 'with-cps 'scheme-indent-function 2)
+;;; eval: (put 'with-cps 'scheme-indent-function 1)
;;; eval: (put 'with-cps-constants 'scheme-indent-function 1)
;;; eval: (put 'convert-arg 'scheme-indent-function 2)
;;; eval: (put 'convert-args 'scheme-indent-function 2)
- [Guile-commits] branch master updated (d99fedc -> b31af02), Andy Wingo, 2015/05/11
- [Guile-commits] 01/07: Fix intset-add! transient bug, Andy Wingo, 2015/05/11
- [Guile-commits] 02/07: Fix another intset transient bug, Andy Wingo, 2015/05/11
- [Guile-commits] 03/07: compute-dom-edges returns a persistent intmap, Andy Wingo, 2015/05/11
- [Guile-commits] 04/07: Tree-IL -> CPS2 -> CPS, Andy Wingo, 2015/05/11
- [Guile-commits] 06/07: Adapt return arities in Tree-IL -> CPS2 conversion,
Andy Wingo <=
- [Guile-commits] 05/07: Build CPS2 with transient intmaps, Andy Wingo, 2015/05/11
- [Guile-commits] 07/07: Consolidate CPS2 above CPS in the compiler, Andy Wingo, 2015/05/11