Commit | Line | Data |
---|---|---|
026b5611 AW |
1 | ;;; Continuation-passing style (CPS) intermediate language (IL) |
2 | ||
3 | ;; Copyright (C) 2013 Free Software Foundation, Inc. | |
4 | ||
5 | ;;;; This library is free software; you can redistribute it and/or | |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | ||
19 | ;;; Commentary: | |
20 | ;;; | |
21 | ;;; A pass to adapt expressions to the arities of their continuations, | |
22 | ;;; and to rewrite some tail expressions as primcalls to "return". | |
23 | ;;; | |
24 | ;;; Code: | |
25 | ||
26 | (define-module (language cps arities) | |
27 | #:use-module (ice-9 match) | |
28 | #:use-module ((srfi srfi-1) #:select (fold)) | |
29 | #:use-module (srfi srfi-26) | |
30 | #:use-module (language cps) | |
31 | #:use-module (language cps dfg) | |
32 | #:use-module (language cps primitives) | |
33 | #:export (fix-arities)) | |
34 | ||
35 | (define (fix-clause-arities clause) | |
36 | (let ((conts (build-local-cont-table clause)) | |
37 | (ktail (match clause | |
6e422a35 | 38 | (($ $cont _ ($ $kentry _ ($ $cont ktail) _)) ktail)))) |
026b5611 AW |
39 | (define (visit-term term) |
40 | (rewrite-cps-term term | |
41 | (($ $letk conts body) | |
42 | ($letk ,(map visit-cont conts) ,(visit-term body))) | |
43 | (($ $letrec names syms funs body) | |
44 | ($letrec names syms (map fix-arities funs) ,(visit-term body))) | |
6e422a35 AW |
45 | (($ $continue k src exp) |
46 | ,(visit-exp k src exp)))) | |
026b5611 | 47 | |
6e422a35 | 48 | (define (adapt-exp nvals k src exp) |
026b5611 AW |
49 | (match nvals |
50 | (0 | |
51 | (rewrite-cps-term (lookup-cont k conts) | |
52 | (($ $ktail) | |
53 | ,(let-gensyms (kvoid kunspec unspec) | |
54 | (build-cps-term | |
6e422a35 AW |
55 | ($letk* ((kunspec ($kargs (unspec) (unspec) |
56 | ($continue k src | |
57 | ($primcall 'return (unspec))))) | |
58 | (kvoid ($kargs () () | |
59 | ($continue kunspec src ($void))))) | |
60 | ($continue kvoid src ,exp))))) | |
4fc6b4d2 | 61 | (($ $ktrunc arity kargs) |
7bbfc029 AW |
62 | ,(match arity |
63 | (($ $arity () () rest () #f) | |
64 | (if rest | |
65 | (let-gensyms (knil) | |
66 | (build-cps-term | |
67 | ($letk ((knil ($kargs () () | |
68 | ($continue kargs src ($const '()))))) | |
69 | ($continue knil src ,exp)))) | |
70 | (build-cps-term | |
71 | ($continue kargs src ,exp)))) | |
4fc6b4d2 | 72 | (_ |
7bbfc029 AW |
73 | (let-gensyms (kvoid kvalues void) |
74 | (build-cps-term | |
75 | ($letk* ((kvalues ($kargs ('void) (void) | |
76 | ($continue k src | |
77 | ($primcall 'values (void))))) | |
78 | (kvoid ($kargs () () | |
79 | ($continue kvalues src | |
80 | ($void))))) | |
81 | ($continue kvoid src ,exp))))))) | |
026b5611 | 82 | (($ $kargs () () _) |
6e422a35 | 83 | ($continue k src ,exp)) |
026b5611 AW |
84 | (_ |
85 | ,(let-gensyms (k*) | |
86 | (build-cps-term | |
6e422a35 AW |
87 | ($letk ((k* ($kargs () () ($continue k src ($void))))) |
88 | ($continue k* src ,exp))))))) | |
026b5611 | 89 | (1 |
4fc6b4d2 AW |
90 | (rewrite-cps-term (lookup-cont k conts) |
91 | (($ $ktail) | |
92 | ,(rewrite-cps-term exp | |
13085a82 | 93 | (($values (sym)) |
6e422a35 | 94 | ($continue ktail src ($primcall 'return (sym)))) |
4fc6b4d2 AW |
95 | (_ |
96 | ,(let-gensyms (k* v) | |
97 | (build-cps-term | |
6e422a35 AW |
98 | ($letk ((k* ($kargs (v) (v) |
99 | ($continue k src | |
100 | ($primcall 'return (v)))))) | |
101 | ($continue k* src ,exp))))))) | |
4fc6b4d2 | 102 | (($ $ktrunc arity kargs) |
7bbfc029 AW |
103 | ,(match arity |
104 | (($ $arity (_) () rest () #f) | |
105 | (if rest | |
106 | (let-gensyms (kval val nil) | |
107 | (build-cps-term | |
108 | ($letk ((kval ($kargs ('val) (val) | |
109 | ($letconst (('nil nil '())) | |
110 | ($continue kargs src | |
111 | ($values (val nil))))))) | |
112 | ($continue kval src ,exp)))) | |
113 | (build-cps-term ($continue kargs src ,exp)))) | |
4fc6b4d2 | 114 | (_ |
7bbfc029 AW |
115 | (let-gensyms (kvalues value) |
116 | (build-cps-term | |
117 | ($letk ((kvalues ($kargs ('value) (value) | |
118 | ($continue k src | |
119 | ($primcall 'values (value)))))) | |
120 | ($continue kvalues src ,exp))))))) | |
4fc6b4d2 AW |
121 | (($ $kargs () () _) |
122 | ,(let-gensyms (k* drop) | |
123 | (build-cps-term | |
6e422a35 AW |
124 | ($letk ((k* ($kargs ('drop) (drop) |
125 | ($continue k src ($values ()))))) | |
126 | ($continue k* src ,exp))))) | |
4fc6b4d2 | 127 | (_ |
6e422a35 | 128 | ($continue k src ,exp)))))) |
026b5611 | 129 | |
6e422a35 | 130 | (define (visit-exp k src exp) |
026b5611 AW |
131 | (rewrite-cps-term exp |
132 | ((or ($ $void) | |
133 | ($ $const) | |
134 | ($ $prim) | |
13085a82 | 135 | ($ $values (_))) |
6e422a35 | 136 | ,(adapt-exp 1 k src exp)) |
026b5611 | 137 | (($ $fun) |
6e422a35 | 138 | ,(adapt-exp 1 k src (fix-arities exp))) |
026b5611 AW |
139 | (($ $call) |
140 | ;; In general, calls have unknown return arity. For that | |
141 | ;; reason every non-tail call has an implicit adaptor | |
142 | ;; continuation to adapt the return to the target | |
143 | ;; continuation, and we don't need to do any adapting here. | |
6e422a35 | 144 | ($continue k src ,exp)) |
026b5611 AW |
145 | (($ $primcall 'return (arg)) |
146 | ;; Primcalls to return are in tail position. | |
6e422a35 | 147 | ($continue ktail src ,exp)) |
026b5611 | 148 | (($ $primcall (? (lambda (name) |
691697de | 149 | (and (not (prim-instruction name)) |
026b5611 | 150 | (not (branching-primitive? name)))))) |
6e422a35 | 151 | ($continue k src ,exp)) |
026b5611 AW |
152 | (($ $primcall name args) |
153 | ,(match (prim-arity name) | |
154 | ((out . in) | |
155 | (if (= in (length args)) | |
6e422a35 | 156 | (adapt-exp out k src |
691697de | 157 | (let ((inst (prim-instruction name))) |
6165d812 AW |
158 | (if (and inst (not (eq? inst name))) |
159 | (build-cps-exp ($primcall inst args)) | |
160 | exp))) | |
026b5611 AW |
161 | (let-gensyms (k* p*) |
162 | (build-cps-term | |
6e422a35 AW |
163 | ($letk ((k* ($kargs ('prim) (p*) |
164 | ($continue k src ($call p* args))))) | |
165 | ($continue k* src ($prim name))))))))) | |
026b5611 | 166 | (($ $values) |
13085a82 AW |
167 | ;; Non-unary values nodes are inserted by CPS optimization |
168 | ;; passes, so we assume they are correct. | |
6e422a35 | 169 | ($continue k src ,exp)) |
026b5611 | 170 | (($ $prompt) |
6e422a35 | 171 | ($continue k src ,exp)))) |
026b5611 AW |
172 | |
173 | (define (visit-cont cont) | |
174 | (rewrite-cps-cont cont | |
6e422a35 AW |
175 | (($ $cont sym ($ $kargs names syms body)) |
176 | (sym ($kargs names syms ,(visit-term body)))) | |
177 | (($ $cont sym ($ $kclause arity body)) | |
178 | (sym ($kclause ,arity ,(visit-cont body)))) | |
026b5611 AW |
179 | (($ $cont) |
180 | ,cont))) | |
181 | ||
182 | (rewrite-cps-cont clause | |
6e422a35 AW |
183 | (($ $cont sym ($ $kentry self tail clauses)) |
184 | (sym ($kentry self ,tail ,(map visit-cont clauses))))))) | |
026b5611 AW |
185 | |
186 | (define (fix-arities fun) | |
187 | (rewrite-cps-exp fun | |
6e422a35 AW |
188 | (($ $fun src meta free body) |
189 | ($fun src meta free ,(fix-clause-arities body))))) |