Commit | Line | Data |
---|---|---|
026b5611 AW |
1 | ;;; Continuation-passing style (CPS) intermediate language (IL) |
2 | ||
36527695 | 3 | ;; Copyright (C) 2013, 2014 Free Software Foundation, Inc. |
026b5611 AW |
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 | ||
a0329d01 | 35 | (define (fix-arities* clause dfg) |
a6f823bd | 36 | (let ((ktail (match clause |
24b611e8 | 37 | (($ $cont _ |
8320f504 | 38 | ($ $kfun src meta _ ($ $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) | |
a0329d01 AW |
44 | ($letrec names syms (map (lambda (fun) |
45 | (rewrite-cps-exp fun | |
46 | (($ $fun free body) | |
47 | ($fun free ,(fix-arities* body dfg))))) | |
48 | funs) | |
49 | ,(visit-term body))) | |
6e422a35 AW |
50 | (($ $continue k src exp) |
51 | ,(visit-exp k src exp)))) | |
026b5611 | 52 | |
6e422a35 | 53 | (define (adapt-exp nvals k src exp) |
026b5611 AW |
54 | (match nvals |
55 | (0 | |
fbdb69b2 | 56 | (rewrite-cps-term (lookup-cont k dfg) |
026b5611 | 57 | (($ $ktail) |
828ed944 | 58 | ,(let-fresh (kvoid kunspec) (unspec) |
026b5611 | 59 | (build-cps-term |
6e422a35 AW |
60 | ($letk* ((kunspec ($kargs (unspec) (unspec) |
61 | ($continue k src | |
62 | ($primcall 'return (unspec))))) | |
63 | (kvoid ($kargs () () | |
64 | ($continue kunspec src ($void))))) | |
65 | ($continue kvoid src ,exp))))) | |
36527695 | 66 | (($ $kreceive arity kargs) |
7bbfc029 AW |
67 | ,(match arity |
68 | (($ $arity () () rest () #f) | |
69 | (if rest | |
828ed944 | 70 | (let-fresh (knil) () |
7bbfc029 AW |
71 | (build-cps-term |
72 | ($letk ((knil ($kargs () () | |
73 | ($continue kargs src ($const '()))))) | |
74 | ($continue knil src ,exp)))) | |
75 | (build-cps-term | |
76 | ($continue kargs src ,exp)))) | |
4fc6b4d2 | 77 | (_ |
828ed944 | 78 | (let-fresh (kvoid kvalues) (void) |
7bbfc029 AW |
79 | (build-cps-term |
80 | ($letk* ((kvalues ($kargs ('void) (void) | |
81 | ($continue k src | |
82 | ($primcall 'values (void))))) | |
83 | (kvoid ($kargs () () | |
84 | ($continue kvalues src | |
85 | ($void))))) | |
86 | ($continue kvoid src ,exp))))))) | |
026b5611 | 87 | (($ $kargs () () _) |
6e422a35 | 88 | ($continue k src ,exp)) |
026b5611 | 89 | (_ |
828ed944 | 90 | ,(let-fresh (k*) () |
026b5611 | 91 | (build-cps-term |
6e422a35 AW |
92 | ($letk ((k* ($kargs () () ($continue k src ($void))))) |
93 | ($continue k* src ,exp))))))) | |
026b5611 | 94 | (1 |
fbdb69b2 | 95 | (rewrite-cps-term (lookup-cont k dfg) |
4fc6b4d2 AW |
96 | (($ $ktail) |
97 | ,(rewrite-cps-term exp | |
30411abf | 98 | (($ $values (sym)) |
6e422a35 | 99 | ($continue ktail src ($primcall 'return (sym)))) |
4fc6b4d2 | 100 | (_ |
828ed944 | 101 | ,(let-fresh (k*) (v) |
4fc6b4d2 | 102 | (build-cps-term |
6e422a35 AW |
103 | ($letk ((k* ($kargs (v) (v) |
104 | ($continue k src | |
105 | ($primcall 'return (v)))))) | |
106 | ($continue k* src ,exp))))))) | |
36527695 | 107 | (($ $kreceive arity kargs) |
7bbfc029 AW |
108 | ,(match arity |
109 | (($ $arity (_) () rest () #f) | |
110 | (if rest | |
828ed944 | 111 | (let-fresh (kval) (val nil) |
7bbfc029 AW |
112 | (build-cps-term |
113 | ($letk ((kval ($kargs ('val) (val) | |
114 | ($letconst (('nil nil '())) | |
115 | ($continue kargs src | |
116 | ($values (val nil))))))) | |
117 | ($continue kval src ,exp)))) | |
118 | (build-cps-term ($continue kargs src ,exp)))) | |
4fc6b4d2 | 119 | (_ |
828ed944 | 120 | (let-fresh (kvalues) (value) |
7bbfc029 AW |
121 | (build-cps-term |
122 | ($letk ((kvalues ($kargs ('value) (value) | |
123 | ($continue k src | |
124 | ($primcall 'values (value)))))) | |
125 | ($continue kvalues src ,exp))))))) | |
4fc6b4d2 | 126 | (($ $kargs () () _) |
828ed944 | 127 | ,(let-fresh (k*) (drop) |
4fc6b4d2 | 128 | (build-cps-term |
6e422a35 AW |
129 | ($letk ((k* ($kargs ('drop) (drop) |
130 | ($continue k src ($values ()))))) | |
131 | ($continue k* src ,exp))))) | |
4fc6b4d2 | 132 | (_ |
6e422a35 | 133 | ($continue k src ,exp)))))) |
026b5611 | 134 | |
6e422a35 | 135 | (define (visit-exp k src exp) |
026b5611 AW |
136 | (rewrite-cps-term exp |
137 | ((or ($ $void) | |
138 | ($ $const) | |
139 | ($ $prim) | |
13085a82 | 140 | ($ $values (_))) |
6e422a35 | 141 | ,(adapt-exp 1 k src exp)) |
a0329d01 AW |
142 | (($ $fun free body) |
143 | ,(adapt-exp 1 k src (build-cps-exp | |
144 | ($fun free ,(fix-arities* body dfg))))) | |
b3ae2b50 | 145 | ((or ($ $call) ($ $callk)) |
026b5611 | 146 | ;; In general, calls have unknown return arity. For that |
b3ae2b50 AW |
147 | ;; reason every non-tail call has a $kreceive continuation to |
148 | ;; adapt the return to the target continuation, and we don't | |
149 | ;; need to do any adapting here. | |
6e422a35 | 150 | ($continue k src ,exp)) |
92805e21 AW |
151 | (($ $branch) |
152 | ;; Assume branching primcalls have the correct arity. | |
153 | ($continue k src ,exp)) | |
026b5611 AW |
154 | (($ $primcall 'return (arg)) |
155 | ;; Primcalls to return are in tail position. | |
6e422a35 | 156 | ($continue ktail src ,exp)) |
026b5611 | 157 | (($ $primcall (? (lambda (name) |
691697de | 158 | (and (not (prim-instruction name)) |
026b5611 | 159 | (not (branching-primitive? name)))))) |
6e422a35 | 160 | ($continue k src ,exp)) |
026b5611 AW |
161 | (($ $primcall name args) |
162 | ,(match (prim-arity name) | |
163 | ((out . in) | |
164 | (if (= in (length args)) | |
6e422a35 | 165 | (adapt-exp out k src |
691697de | 166 | (let ((inst (prim-instruction name))) |
6165d812 AW |
167 | (if (and inst (not (eq? inst name))) |
168 | (build-cps-exp ($primcall inst args)) | |
169 | exp))) | |
828ed944 | 170 | (let-fresh (k*) (p*) |
026b5611 | 171 | (build-cps-term |
6e422a35 AW |
172 | ($letk ((k* ($kargs ('prim) (p*) |
173 | ($continue k src ($call p* args))))) | |
174 | ($continue k* src ($prim name))))))))) | |
026b5611 | 175 | (($ $values) |
13085a82 AW |
176 | ;; Non-unary values nodes are inserted by CPS optimization |
177 | ;; passes, so we assume they are correct. | |
6e422a35 | 178 | ($continue k src ,exp)) |
026b5611 | 179 | (($ $prompt) |
6e422a35 | 180 | ($continue k src ,exp)))) |
026b5611 AW |
181 | |
182 | (define (visit-cont cont) | |
183 | (rewrite-cps-cont cont | |
6e422a35 AW |
184 | (($ $cont sym ($ $kargs names syms body)) |
185 | (sym ($kargs names syms ,(visit-term body)))) | |
90dce16d AW |
186 | (($ $cont sym ($ $kclause arity body alternate)) |
187 | (sym ($kclause ,arity ,(visit-cont body) | |
188 | ,(and alternate (visit-cont alternate))))) | |
026b5611 AW |
189 | (($ $cont) |
190 | ,cont))) | |
191 | ||
192 | (rewrite-cps-cont clause | |
8320f504 AW |
193 | (($ $cont sym ($ $kfun src meta self tail clause)) |
194 | (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))))) | |
026b5611 | 195 | |
828ed944 | 196 | (define (fix-arities fun) |
a0329d01 | 197 | (let ((dfg (compute-dfg fun))) |
3e1b97c1 AW |
198 | (with-fresh-name-state-from-dfg dfg |
199 | (fix-arities* fun dfg)))) |