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 AW |
61 | (($ $ktrunc arity kargs) |
62 | ,(rewrite-cps-term arity | |
63 | (($ $arity () () #f () #f) | |
6e422a35 | 64 | ($continue kargs src ,exp)) |
4fc6b4d2 AW |
65 | (_ |
66 | ,(let-gensyms (kvoid kvalues void) | |
67 | (build-cps-term | |
6e422a35 AW |
68 | ($letk* ((kvalues ($kargs ('void) (void) |
69 | ($continue k src | |
70 | ($primcall 'values (void))))) | |
71 | (kvoid ($kargs () () | |
72 | ($continue kvalues src | |
73 | ($void))))) | |
74 | ($continue kvoid src ,exp))))))) | |
026b5611 | 75 | (($ $kargs () () _) |
6e422a35 | 76 | ($continue k src ,exp)) |
026b5611 AW |
77 | (_ |
78 | ,(let-gensyms (k*) | |
79 | (build-cps-term | |
6e422a35 AW |
80 | ($letk ((k* ($kargs () () ($continue k src ($void))))) |
81 | ($continue k* src ,exp))))))) | |
026b5611 | 82 | (1 |
4fc6b4d2 AW |
83 | (rewrite-cps-term (lookup-cont k conts) |
84 | (($ $ktail) | |
85 | ,(rewrite-cps-term exp | |
86 | (($var sym) | |
6e422a35 | 87 | ($continue ktail src ($primcall 'return (sym)))) |
4fc6b4d2 AW |
88 | (_ |
89 | ,(let-gensyms (k* v) | |
90 | (build-cps-term | |
6e422a35 AW |
91 | ($letk ((k* ($kargs (v) (v) |
92 | ($continue k src | |
93 | ($primcall 'return (v)))))) | |
94 | ($continue k* src ,exp))))))) | |
4fc6b4d2 AW |
95 | (($ $ktrunc arity kargs) |
96 | ,(rewrite-cps-term arity | |
97 | (($ $arity (_) () #f () #f) | |
6e422a35 | 98 | ($continue kargs src ,exp)) |
4fc6b4d2 AW |
99 | (_ |
100 | ,(let-gensyms (kvalues value) | |
101 | (build-cps-term | |
6e422a35 AW |
102 | ($letk ((kvalues ($kargs ('value) (value) |
103 | ($continue k src | |
104 | ($primcall 'values (value)))))) | |
105 | ($continue kvalues src ,exp))))))) | |
4fc6b4d2 AW |
106 | (($ $kargs () () _) |
107 | ,(let-gensyms (k* drop) | |
108 | (build-cps-term | |
6e422a35 AW |
109 | ($letk ((k* ($kargs ('drop) (drop) |
110 | ($continue k src ($values ()))))) | |
111 | ($continue k* src ,exp))))) | |
4fc6b4d2 | 112 | (_ |
6e422a35 | 113 | ($continue k src ,exp)))))) |
026b5611 | 114 | |
6e422a35 | 115 | (define (visit-exp k src exp) |
026b5611 AW |
116 | (rewrite-cps-term exp |
117 | ((or ($ $void) | |
118 | ($ $const) | |
119 | ($ $prim) | |
120 | ($ $var)) | |
6e422a35 | 121 | ,(adapt-exp 1 k src exp)) |
026b5611 | 122 | (($ $fun) |
6e422a35 | 123 | ,(adapt-exp 1 k src (fix-arities exp))) |
026b5611 AW |
124 | (($ $call) |
125 | ;; In general, calls have unknown return arity. For that | |
126 | ;; reason every non-tail call has an implicit adaptor | |
127 | ;; continuation to adapt the return to the target | |
128 | ;; continuation, and we don't need to do any adapting here. | |
6e422a35 | 129 | ($continue k src ,exp)) |
026b5611 AW |
130 | (($ $primcall 'return (arg)) |
131 | ;; Primcalls to return are in tail position. | |
6e422a35 | 132 | ($continue ktail src ,exp)) |
026b5611 AW |
133 | (($ $primcall (? (lambda (name) |
134 | (and (not (prim-rtl-instruction name)) | |
135 | (not (branching-primitive? name)))))) | |
6e422a35 | 136 | ($continue k src ,exp)) |
026b5611 AW |
137 | (($ $primcall name args) |
138 | ,(match (prim-arity name) | |
139 | ((out . in) | |
140 | (if (= in (length args)) | |
6e422a35 | 141 | (adapt-exp out k src |
6165d812 AW |
142 | (let ((inst (prim-rtl-instruction name))) |
143 | (if (and inst (not (eq? inst name))) | |
144 | (build-cps-exp ($primcall inst args)) | |
145 | exp))) | |
026b5611 AW |
146 | (let-gensyms (k* p*) |
147 | (build-cps-term | |
6e422a35 AW |
148 | ($letk ((k* ($kargs ('prim) (p*) |
149 | ($continue k src ($call p* args))))) | |
150 | ($continue k* src ($prim name))))))))) | |
026b5611 AW |
151 | (($ $values) |
152 | ;; Values nodes are inserted by CPS optimization passes, so | |
153 | ;; we assume they are correct. | |
6e422a35 | 154 | ($continue k src ,exp)) |
026b5611 | 155 | (($ $prompt) |
6e422a35 | 156 | ($continue k src ,exp)))) |
026b5611 AW |
157 | |
158 | (define (visit-cont cont) | |
159 | (rewrite-cps-cont cont | |
6e422a35 AW |
160 | (($ $cont sym ($ $kargs names syms body)) |
161 | (sym ($kargs names syms ,(visit-term body)))) | |
162 | (($ $cont sym ($ $kclause arity body)) | |
163 | (sym ($kclause ,arity ,(visit-cont body)))) | |
026b5611 AW |
164 | (($ $cont) |
165 | ,cont))) | |
166 | ||
167 | (rewrite-cps-cont clause | |
6e422a35 AW |
168 | (($ $cont sym ($ $kentry self tail clauses)) |
169 | (sym ($kentry self ,tail ,(map visit-cont clauses))))))) | |
026b5611 AW |
170 | |
171 | (define (fix-arities fun) | |
172 | (rewrite-cps-exp fun | |
6e422a35 AW |
173 | (($ $fun src meta free body) |
174 | ($fun src meta free ,(fix-clause-arities body))))) |