Commit | Line | Data |
---|---|---|
6e8ad823 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 module to assign stack slots to variables in a CPS term. | |
22 | ;;; | |
23 | ;;; Code: | |
24 | ||
25 | (define-module (language cps slot-allocation) | |
26 | #:use-module (ice-9 match) | |
27 | #:use-module (srfi srfi-1) | |
28 | #:use-module (srfi srfi-9) | |
29 | #:use-module (srfi srfi-26) | |
30 | #:use-module (language cps) | |
31 | #:use-module (language cps dfg) | |
32 | #:export (allocate-slots | |
33 | lookup-slot | |
34 | lookup-constant-value | |
35 | lookup-maybe-constant-value | |
36 | lookup-nlocals | |
37 | lookup-call-proc-slot | |
38 | lookup-parallel-moves)) | |
39 | ||
40 | ;; Continuations can bind variables. The $allocation structure | |
41 | ;; represents the slot in which a variable is stored. | |
42 | ;; | |
43 | ;; Not all variables have slots allocated. Variables that are constant | |
44 | ;; and that are only used by primcalls that can accept constants | |
45 | ;; directly are not allocated to slots, and their SLOT value is false. | |
46 | ;; Likewise constants that are only used by calls are not allocated into | |
47 | ;; slots, to avoid needless copying. If a variable is constant, its | |
48 | ;; constant value is set to the CONST slot and HAS-CONST? is set to a | |
49 | ;; true value. | |
50 | ;; | |
6e8ad823 | 51 | (define-record-type $allocation |
e636f424 | 52 | (make-allocation slot has-const? const) |
6e8ad823 | 53 | allocation? |
6e8ad823 | 54 | (slot allocation-slot) |
6e8ad823 AW |
55 | (has-const? allocation-has-const?) |
56 | (const allocation-const)) | |
57 | ||
58 | ;; Continuations can also have associated allocation data. For example, | |
59 | ;; when a call happens in a labelled continuation, we need to know what | |
60 | ;; slot the procedure goes in. Likewise before branching to the target | |
61 | ;; continuation, we might need to shuffle values into the right place: a | |
62 | ;; parallel move. $cont-allocation stores allocation data keyed on the | |
63 | ;; continuation label. | |
64 | (define-record-type $cont-allocation | |
65 | (make-cont-allocation call-proc-slot parallel-moves) | |
66 | cont-allocation? | |
67 | ||
68 | ;; Currently calls are allocated in the caller frame, above all locals | |
69 | ;; that are live at the time of the call. Therefore there is no | |
70 | ;; parallel move problem. We could be more clever here. | |
8d59d55e AW |
71 | ;; |
72 | ;; $prompt expressions also use this call slot to indicate where the | |
73 | ;; handler's arguments are expected, but without reserving space for a | |
74 | ;; frame or for the procedure slot. | |
6e8ad823 AW |
75 | (call-proc-slot cont-call-proc-slot) |
76 | ||
77 | ;; Tail calls, multiple-value returns, and jumps to continuations with | |
78 | ;; multiple arguments are forms of parallel assignment. A | |
79 | ;; $parallel-move represents a specific solution to the parallel | |
80 | ;; assignment problem, with an ordered list of (SRC . DST) moves. This | |
81 | ;; may involve a temporary variable. | |
82 | ;; | |
83 | ;; ((src . dst) ...) | |
84 | (parallel-moves cont-parallel-moves)) | |
85 | ||
86 | (define (find-first-zero n) | |
87 | ;; Naive implementation. | |
88 | (let lp ((slot 0)) | |
89 | (if (logbit? slot n) | |
90 | (lp (1+ slot)) | |
91 | slot))) | |
92 | ||
93 | (define (find-first-trailing-zero n count) | |
94 | (let lp ((slot count)) | |
95 | (if (or (zero? slot) (logbit? (1- slot) n)) | |
96 | slot | |
97 | (lp (1- slot))))) | |
98 | ||
99 | (define (lookup-allocation sym allocation) | |
100 | (let ((res (hashq-ref allocation sym))) | |
101 | (unless res | |
102 | (error "Variable or continuation not defined" sym)) | |
103 | res)) | |
104 | ||
105 | (define (lookup-slot sym allocation) | |
106 | (match (lookup-allocation sym allocation) | |
e636f424 | 107 | (($ $allocation slot has-const? const) slot))) |
6e8ad823 AW |
108 | |
109 | (define (lookup-constant-value sym allocation) | |
110 | (match (lookup-allocation sym allocation) | |
e636f424 | 111 | (($ $allocation slot #t const) const) |
6e8ad823 AW |
112 | (_ |
113 | (error "Variable does not have constant value" sym)))) | |
114 | ||
115 | (define (lookup-maybe-constant-value sym allocation) | |
116 | (match (lookup-allocation sym allocation) | |
e636f424 | 117 | (($ $allocation slot has-const? const) |
6e8ad823 AW |
118 | (values has-const? const)))) |
119 | ||
120 | (define (lookup-call-proc-slot k allocation) | |
121 | (match (lookup-allocation k allocation) | |
122 | (($ $cont-allocation proc-slot parallel-moves) | |
123 | (unless proc-slot | |
124 | (error "Continuation not a call" k)) | |
125 | proc-slot) | |
126 | (_ | |
127 | (error "Continuation not a call" k)))) | |
128 | ||
129 | (define (lookup-nlocals k allocation) | |
130 | (match (lookup-allocation k allocation) | |
131 | ((? number? nlocals) nlocals) | |
132 | (_ | |
133 | (error "Not a clause continuation" k)))) | |
134 | ||
135 | (define (lookup-parallel-moves k allocation) | |
136 | (match (lookup-allocation k allocation) | |
137 | (($ $cont-allocation proc-slot parallel-moves) | |
138 | (unless parallel-moves | |
139 | (error "Continuation does not have parallel moves" k)) | |
140 | parallel-moves) | |
141 | (_ | |
142 | (error "Continuation not a call" k)))) | |
143 | ||
144 | (define (solve-parallel-move src dst tmp) | |
145 | "Solve the parallel move problem between src and dst slot lists, which | |
146 | are comparable with eqv?. A tmp slot may be used." | |
147 | ||
148 | ;; This algorithm is taken from: "Tilting at windmills with Coq: | |
149 | ;; formal verification of a compilation algorithm for parallel moves" | |
150 | ;; by Laurence Rideau, Bernard Paul Serpette, and Xavier Leroy | |
151 | ;; <http://gallium.inria.fr/~xleroy/publi/parallel-move.pdf> | |
152 | ||
153 | (define (split-move moves reg) | |
154 | (let loop ((revhead '()) (tail moves)) | |
155 | (match tail | |
156 | (((and s+d (s . d)) . rest) | |
157 | (if (eqv? s reg) | |
158 | (cons d (append-reverse revhead rest)) | |
159 | (loop (cons s+d revhead) rest))) | |
160 | (_ #f)))) | |
161 | ||
162 | (define (replace-last-source reg moves) | |
163 | (match moves | |
164 | ((moves ... (s . d)) | |
165 | (append moves (list (cons reg d)))))) | |
166 | ||
167 | (let loop ((to-move (map cons src dst)) | |
168 | (being-moved '()) | |
169 | (moved '()) | |
170 | (last-source #f)) | |
171 | ;; 'last-source' should always be equivalent to: | |
172 | ;; (and (pair? being-moved) (car (last being-moved))) | |
173 | (match being-moved | |
174 | (() (match to-move | |
175 | (() (reverse moved)) | |
176 | (((and s+d (s . d)) . t1) | |
177 | (if (or (eqv? s d) ; idempotent | |
178 | (not s)) ; src is a constant and can be loaded directly | |
179 | (loop t1 '() moved #f) | |
180 | (loop t1 (list s+d) moved s))))) | |
181 | (((and s+d (s . d)) . b) | |
182 | (match (split-move to-move d) | |
183 | ((r . t1) (loop t1 (acons d r being-moved) moved last-source)) | |
184 | (#f (match b | |
185 | (() (loop to-move '() (cons s+d moved) #f)) | |
186 | (_ (if (eqv? d last-source) | |
187 | (loop to-move | |
188 | (replace-last-source tmp b) | |
189 | (cons s+d (acons d tmp moved)) | |
190 | tmp) | |
191 | (loop to-move b (cons s+d moved) last-source)))))))))) | |
192 | ||
e636f424 AW |
193 | (define (dead-after-def? def-k v-idx dfa) |
194 | (let ((l (dfa-k-idx dfa def-k))) | |
195 | (not (bitvector-ref (dfa-k-in dfa l) v-idx)))) | |
196 | ||
197 | (define (dead-after-use? use-k v-idx dfa) | |
198 | (let ((l (dfa-k-idx dfa use-k))) | |
199 | (not (bitvector-ref (dfa-k-out dfa l) v-idx)))) | |
200 | ||
6e8ad823 | 201 | (define (allocate-slots fun) |
e636f424 AW |
202 | (define (empty-live-slots) |
203 | #b0) | |
6e8ad823 | 204 | |
e636f424 AW |
205 | (define (add-live-slot slot live-slots) |
206 | (logior live-slots (ash 1 slot))) | |
6e8ad823 | 207 | |
e636f424 AW |
208 | (define (kill-dead-slot slot live-slots) |
209 | (logand live-slots (lognot (ash 1 slot)))) | |
8d59d55e | 210 | |
e636f424 AW |
211 | (define (compute-slot live-slots hint) |
212 | (if (and hint (not (logbit? hint live-slots))) | |
213 | hint | |
214 | (find-first-zero live-slots))) | |
215 | ||
216 | (define (compute-call-proc-slot live-slots nlocals) | |
217 | (+ 3 (find-first-trailing-zero live-slots nlocals))) | |
218 | ||
219 | (define (compute-prompt-handler-proc-slot live-slots nlocals) | |
220 | (1- (find-first-trailing-zero live-slots nlocals))) | |
221 | ||
222 | (define (recompute-live-slots k slots nargs dfa) | |
223 | (let ((in (dfa-k-in dfa (dfa-k-idx dfa k)))) | |
224 | (let lp ((v 0) (live-slots (1- (ash 1 (1+ nargs))))) | |
225 | (let ((v (bit-position #t in v))) | |
226 | (if v | |
227 | (let ((slot (vector-ref slots v))) | |
228 | (lp (1+ v) | |
229 | (if slot | |
230 | (add-live-slot slot live-slots) | |
231 | live-slots))) | |
232 | live-slots))))) | |
233 | ||
234 | (define (visit-clause clause dfg dfa allocation slots live-slots) | |
235 | (define nlocals (compute-slot live-slots #f)) | |
6e8ad823 AW |
236 | (define nargs |
237 | (match clause | |
238 | (($ $cont _ _ ($ $kclause _ ($ $cont _ _ ($ $kargs names syms)))) | |
239 | (length syms)))) | |
240 | ||
e636f424 | 241 | (define (allocate! sym k hint live-slots) |
6e8ad823 | 242 | (match (hashq-ref allocation sym) |
e636f424 | 243 | (($ $allocation slot) |
6e8ad823 AW |
244 | ;; Parallel move already allocated this one. |
245 | (if slot | |
e636f424 AW |
246 | (add-live-slot slot live-slots) |
247 | live-slots)) | |
6e8ad823 AW |
248 | (_ |
249 | (call-with-values (lambda () (find-constant-value sym dfg)) | |
250 | (lambda (has-const? const) | |
251 | (cond | |
252 | ((and has-const? (not (constant-needs-allocation? sym const dfg))) | |
253 | (hashq-set! allocation sym | |
e636f424 AW |
254 | (make-allocation #f has-const? const)) |
255 | live-slots) | |
6e8ad823 | 256 | (else |
e636f424 | 257 | (let ((slot (compute-slot live-slots hint))) |
6e8ad823 AW |
258 | (when (>= slot nlocals) |
259 | (set! nlocals (+ slot 1))) | |
e636f424 | 260 | (vector-set! slots (dfa-var-idx dfa sym) slot) |
6e8ad823 | 261 | (hashq-set! allocation sym |
e636f424 AW |
262 | (make-allocation slot has-const? const)) |
263 | (add-live-slot slot live-slots))))))))) | |
6e8ad823 | 264 | |
e636f424 AW |
265 | (define (allocate-prompt-handler! k live-slots) |
266 | (let ((proc-slot (compute-prompt-handler-proc-slot live-slots nlocals))) | |
8d59d55e AW |
267 | (hashq-set! allocation k |
268 | (make-cont-allocation | |
269 | proc-slot | |
270 | (match (hashq-ref allocation k) | |
271 | (($ $cont-allocation #f moves) moves) | |
272 | (#f #f)))) | |
e636f424 | 273 | live-slots)) |
8d59d55e | 274 | |
e636f424 AW |
275 | (define (allocate-frame! k nargs live-slots) |
276 | (let ((proc-slot (compute-call-proc-slot live-slots nlocals))) | |
6e8ad823 AW |
277 | (set! nlocals (max nlocals (+ proc-slot 1 nargs))) |
278 | (hashq-set! allocation k | |
279 | (make-cont-allocation | |
280 | proc-slot | |
281 | (match (hashq-ref allocation k) | |
282 | (($ $cont-allocation #f moves) moves) | |
283 | (#f #f)))) | |
e636f424 | 284 | live-slots)) |
6e8ad823 | 285 | |
e636f424 AW |
286 | (define (parallel-move! src-k src-slots pre-live-slots post-live-slots dst-slots) |
287 | (let* ((tmp-slot (find-first-zero (logior pre-live-slots post-live-slots))) | |
6e8ad823 AW |
288 | (moves (solve-parallel-move src-slots dst-slots tmp-slot))) |
289 | (when (and (>= tmp-slot nlocals) (assv tmp-slot moves)) | |
290 | (set! nlocals (+ tmp-slot 1))) | |
291 | (hashq-set! allocation src-k | |
292 | (make-cont-allocation | |
293 | (match (hashq-ref allocation src-k) | |
294 | (($ $cont-allocation proc-slot #f) proc-slot) | |
295 | (#f #f)) | |
296 | moves)) | |
e636f424 | 297 | post-live-slots)) |
6e8ad823 | 298 | |
e636f424 AW |
299 | (define (visit-cont cont label live-slots) |
300 | (define (maybe-kill-definition sym live-slots) | |
301 | (let* ((v (dfa-var-idx dfa sym)) | |
302 | (slot (vector-ref slots v))) | |
303 | (if (and slot (> slot nargs) (dead-after-def? label v dfa)) | |
304 | (kill-dead-slot slot live-slots) | |
305 | live-slots))) | |
6e8ad823 | 306 | |
e636f424 AW |
307 | (define (maybe-recompute-live-slots live-slots) |
308 | (if (control-point? label dfg) | |
309 | (recompute-live-slots label slots nargs dfa) | |
310 | live-slots)) | |
311 | ||
312 | (match cont | |
6e8ad823 | 313 | (($ $kclause arity ($ $cont k src body)) |
e636f424 | 314 | (visit-cont body k live-slots)) |
6e8ad823 AW |
315 | |
316 | (($ $kargs names syms body) | |
317 | (visit-term body label | |
e636f424 | 318 | (maybe-recompute-live-slots |
6e8ad823 | 319 | (fold maybe-kill-definition |
e636f424 | 320 | (fold (cut allocate! <> label #f <>) live-slots syms) |
6e8ad823 AW |
321 | syms)))) |
322 | ||
e636f424 AW |
323 | (($ $ktrunc) live-slots) |
324 | (($ $kif) live-slots))) | |
6e8ad823 | 325 | |
e636f424 | 326 | (define (visit-term term label live-slots) |
6e8ad823 AW |
327 | (match term |
328 | (($ $letk conts body) | |
e636f424 | 329 | (let ((live-slots (visit-term body label live-slots))) |
6e8ad823 AW |
330 | (for-each (match-lambda |
331 | (($ $cont k src cont) | |
e636f424 | 332 | (visit-cont cont k live-slots))) |
6e8ad823 | 333 | conts)) |
e636f424 | 334 | live-slots) |
6e8ad823 AW |
335 | |
336 | (($ $continue k exp) | |
e636f424 | 337 | (visit-exp exp label k live-slots)))) |
6e8ad823 | 338 | |
e636f424 AW |
339 | (define (visit-exp exp label k live-slots) |
340 | (define (use sym live-slots) | |
341 | (let* ((v (dfa-var-idx dfa sym)) | |
342 | (l (dfa-k-idx dfa label)) | |
343 | (slot (vector-ref slots v))) | |
344 | (if (and slot (> slot nargs) (dead-after-use? label v dfa)) | |
345 | (kill-dead-slot slot live-slots) | |
346 | live-slots))) | |
6e8ad823 AW |
347 | |
348 | (match exp | |
349 | (($ $var sym) | |
e636f424 | 350 | (use sym live-slots)) |
6e8ad823 AW |
351 | |
352 | (($ $call proc args) | |
353 | (match (lookup-cont k (dfg-cont-table dfg)) | |
354 | (($ $ktail) | |
355 | (let ((tail-nlocals (1+ (length args)))) | |
356 | (set! nlocals (max nlocals tail-nlocals)) | |
357 | (parallel-move! label | |
358 | (map (cut lookup-slot <> allocation) | |
359 | (cons proc args)) | |
e636f424 | 360 | live-slots (fold use live-slots (cons proc args)) |
6e8ad823 AW |
361 | (iota tail-nlocals)))) |
362 | (($ $ktrunc arity kargs) | |
e636f424 | 363 | (let* ((live-slots |
6e8ad823 AW |
364 | (fold use |
365 | (use proc | |
e636f424 | 366 | (allocate-frame! label (length args) live-slots)) |
6e8ad823 AW |
367 | args)) |
368 | (proc-slot (lookup-call-proc-slot label allocation)) | |
369 | (dst-syms (lookup-bound-syms kargs dfg)) | |
370 | (nvals (length dst-syms)) | |
371 | (src-slots (map (cut + proc-slot 1 <>) (iota nvals))) | |
e636f424 AW |
372 | (live-slots* (fold (cut allocate! <> kargs <> <>) |
373 | live-slots dst-syms src-slots)) | |
6e8ad823 AW |
374 | (dst-slots (map (cut lookup-slot <> allocation) |
375 | dst-syms))) | |
e636f424 | 376 | (parallel-move! label src-slots live-slots live-slots* dst-slots))) |
6e8ad823 AW |
377 | (else |
378 | (fold use | |
e636f424 | 379 | (use proc (allocate-frame! label (length args) live-slots)) |
6e8ad823 AW |
380 | args)))) |
381 | ||
382 | (($ $primcall name args) | |
e636f424 | 383 | (fold use live-slots args)) |
6e8ad823 AW |
384 | |
385 | (($ $values args) | |
e636f424 | 386 | (let ((live-slots* (fold use live-slots args))) |
6e8ad823 AW |
387 | (define (compute-dst-slots) |
388 | (match (lookup-cont k (dfg-cont-table dfg)) | |
389 | (($ $ktail) | |
390 | (let ((tail-nlocals (1+ (length args)))) | |
391 | (set! nlocals (max nlocals tail-nlocals)) | |
392 | (cdr (iota tail-nlocals)))) | |
393 | (_ | |
394 | (let* ((src-slots (map (cut lookup-slot <> allocation) args)) | |
395 | (dst-syms (lookup-bound-syms k dfg)) | |
e636f424 AW |
396 | (dst-live-slots (fold (cut allocate! <> k <> <>) |
397 | live-slots* dst-syms src-slots))) | |
6e8ad823 AW |
398 | (map (cut lookup-slot <> allocation) dst-syms))))) |
399 | ||
400 | (parallel-move! label | |
401 | (map (cut lookup-slot <> allocation) args) | |
e636f424 | 402 | live-slots live-slots* |
6e8ad823 AW |
403 | (compute-dst-slots)))) |
404 | ||
96af4a18 | 405 | (($ $prompt escape? tag handler pop) |
8d59d55e AW |
406 | (match (lookup-cont handler (dfg-cont-table dfg)) |
407 | (($ $ktrunc arity kargs) | |
e636f424 | 408 | (let* ((live-slots (allocate-prompt-handler! label live-slots)) |
8d59d55e AW |
409 | (proc-slot (lookup-call-proc-slot label allocation)) |
410 | (dst-syms (lookup-bound-syms kargs dfg)) | |
411 | (nvals (length dst-syms)) | |
412 | (src-slots (map (cut + proc-slot 1 <>) (iota nvals))) | |
e636f424 AW |
413 | (live-slots* (fold (cut allocate! <> kargs <> <>) |
414 | live-slots dst-syms src-slots)) | |
8d59d55e AW |
415 | (dst-slots (map (cut lookup-slot <> allocation) |
416 | dst-syms))) | |
e636f424 AW |
417 | (parallel-move! handler src-slots live-slots live-slots* dst-slots)))) |
418 | (use tag live-slots)) | |
6e8ad823 | 419 | |
e636f424 | 420 | (_ live-slots))) |
6e8ad823 AW |
421 | |
422 | (match clause | |
423 | (($ $cont k _ body) | |
e636f424 | 424 | (visit-cont body k live-slots) |
6e8ad823 AW |
425 | (hashq-set! allocation k nlocals)))) |
426 | ||
427 | (match fun | |
e636f424 AW |
428 | (($ $fun meta free ($ $cont k _ ($ $kentry self |
429 | ($ $cont ktail _ ($ $ktail)) | |
430 | clauses))) | |
431 | (let* ((dfg (compute-dfg fun #:global? #f)) | |
432 | (dfa (compute-live-variables ktail dfg)) | |
433 | (allocation (make-hash-table)) | |
434 | (slots (make-vector (dfa-var-count dfa) #f)) | |
435 | (live-slots (add-live-slot 0 (empty-live-slots)))) | |
436 | (vector-set! slots (dfa-var-idx dfa self) 0) | |
437 | (hashq-set! allocation self (make-allocation 0 #f #f)) | |
438 | (for-each (cut visit-clause <> dfg dfa allocation slots live-slots) | |
439 | clauses) | |
6e8ad823 | 440 | allocation)))) |