Commit | Line | Data |
---|---|---|
cf10678f AW |
1 | ;;; TREE-IL -> GLIL compiler |
2 | ||
3 | ;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc. | |
4 | ||
5 | ;; This program is free software; you can redistribute it and/or modify | |
6 | ;; it under the terms of the GNU General Public License as published by | |
7 | ;; the Free Software Foundation; either version 2, or (at your option) | |
8 | ;; any later version. | |
9 | ;; | |
10 | ;; This program 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 | |
13 | ;; GNU General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU General Public License | |
16 | ;; along with this program; see the file COPYING. If not, write to | |
17 | ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
18 | ;; Boston, MA 02111-1307, USA. | |
19 | ||
20 | ;;; Code: | |
21 | ||
22 | (define-module (language tree-il analyze) | |
23 | #:use-module (system base syntax) | |
24 | #:use-module (language tree-il) | |
25 | #:export (analyze-lexicals)) | |
26 | ||
27 | ;; allocation: the process of assigning a type and index to each var | |
28 | ;; a var is external if it is heaps; assigning index is easy | |
29 | ;; args are assigned in order | |
30 | ;; locals are indexed as their linear position in the binding path | |
31 | ;; (let (0 1) | |
32 | ;; (let (2 3) ...) | |
33 | ;; (let (2) ...)) | |
34 | ;; (let (2 3 4) ...)) | |
35 | ;; etc. | |
36 | ;; | |
5af166bd AW |
37 | ;; This algorithm has the problem that variables are only allocated |
38 | ;; indices at the end of the binding path. If variables bound early in | |
39 | ;; the path are not used in later portions of the path, their indices | |
40 | ;; will not be recycled. This problem is particularly egregious in the | |
41 | ;; expansion of `or': | |
42 | ;; | |
43 | ;; (or x y z) | |
44 | ;; -> (let ((a x)) (if a a (let ((b y)) (if b b z)))) | |
45 | ;; | |
46 | ;; As you can see, the `a' binding is only used in the ephemeral `then' | |
47 | ;; clause of the first `if', but its index would be reserved for the | |
48 | ;; whole of the `or' expansion. So we have a hack for this specific | |
49 | ;; case. A proper solution would be some sort of liveness analysis, and | |
50 | ;; not our linear allocation algorithm. | |
51 | ;; | |
cf10678f AW |
52 | ;; allocation: |
53 | ;; sym -> (local . index) | (heap level . index) | |
54 | ;; lambda -> (nlocs . nexts) | |
55 | ||
56 | (define (analyze-lexicals x) | |
57 | ;; parents: lambda -> parent | |
58 | ;; useful when we see a closed-over var, so we can calculate its | |
59 | ;; coordinates (depth and index). | |
60 | ;; bindings: lambda -> (sym ...) | |
61 | ;; useful for two reasons: one, so we know how much space to allocate | |
62 | ;; when we go into a lambda; and two, so that we know when to stop, | |
63 | ;; when looking for closed-over vars. | |
64 | ;; heaps: sym -> lambda | |
65 | ;; allows us to heapify vars in an O(1) fashion | |
5af166bd AW |
66 | ;; refcounts: sym -> count |
67 | ;; allows us to detect the or-expansion an O(1) time | |
cf10678f AW |
68 | |
69 | (define (find-heap sym parent) | |
70 | ;; fixme: check displaced lexicals here? | |
71 | (if (memq sym (hashq-ref bindings parent)) | |
72 | parent | |
73 | (find-heap sym (hashq-ref parents parent)))) | |
74 | ||
75 | (define (analyze! x parent level) | |
76 | (define (step y) (analyze! y parent level)) | |
77 | (define (recur x parent) (analyze! x parent (1+ level))) | |
78 | (record-case x | |
79 | ((<application> proc args) | |
80 | (step proc) (for-each step args)) | |
81 | ||
82 | ((<conditional> test then else) | |
83 | (step test) (step then) (step else)) | |
84 | ||
85 | ((<lexical-ref> name gensym) | |
5af166bd | 86 | (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0))) |
cf10678f AW |
87 | (if (and (not (memq gensym (hashq-ref bindings parent))) |
88 | (not (hashq-ref heaps gensym))) | |
89 | (hashq-set! heaps gensym (find-heap gensym parent)))) | |
90 | ||
91 | ((<lexical-set> name gensym exp) | |
92 | (step exp) | |
93 | (if (not (hashq-ref heaps gensym)) | |
94 | (hashq-set! heaps gensym (find-heap gensym parent)))) | |
95 | ||
96 | ((<module-set> mod name public? exp) | |
97 | (step exp)) | |
98 | ||
99 | ((<toplevel-set> name exp) | |
100 | (step exp)) | |
101 | ||
102 | ((<toplevel-define> name exp) | |
103 | (step exp)) | |
104 | ||
105 | ((<sequence> exps) | |
106 | (for-each step exps)) | |
107 | ||
108 | ((<lambda> vars meta body) | |
109 | (hashq-set! parents x parent) | |
110 | (hashq-set! bindings x | |
111 | (let rev* ((vars vars) (out '())) | |
112 | (cond ((null? vars) out) | |
113 | ((pair? vars) (rev* (cdr vars) | |
114 | (cons (car vars) out))) | |
115 | (else (cons vars out))))) | |
116 | (recur body x) | |
117 | (hashq-set! bindings x (reverse! (hashq-ref bindings x)))) | |
118 | ||
f4aa8d53 | 119 | ((<let> vars vals body) |
cf10678f AW |
120 | (for-each step vals) |
121 | (hashq-set! bindings parent | |
122 | (append (reverse vars) (hashq-ref bindings parent))) | |
f4aa8d53 | 123 | (step body)) |
cf10678f | 124 | |
f4aa8d53 | 125 | ((<letrec> vars vals body) |
cf10678f AW |
126 | (hashq-set! bindings parent |
127 | (append (reverse vars) (hashq-ref bindings parent))) | |
128 | (for-each step vals) | |
f4aa8d53 AW |
129 | (step body)) |
130 | ||
131 | ((<let-values> vars exp body) | |
132 | (hashq-set! bindings parent | |
133 | (let lp ((out (hashq-ref bindings parent)) (in vars)) | |
134 | (if (pair? in) | |
135 | (lp (cons (car in) out) (cdr in)) | |
136 | (if (null? in) out (cons in out))))) | |
137 | (step exp) | |
138 | (step body)) | |
cf10678f AW |
139 | |
140 | (else #f))) | |
141 | ||
142 | (define (allocate-heap! binder) | |
143 | (hashq-set! heap-indexes binder | |
144 | (1+ (hashq-ref heap-indexes binder -1)))) | |
145 | ||
146 | (define (allocate! x level n) | |
147 | (define (recur y) (allocate! y level n)) | |
148 | (record-case x | |
149 | ((<application> proc args) | |
150 | (apply max (recur proc) (map recur args))) | |
151 | ||
152 | ((<conditional> test then else) | |
153 | (max (recur test) (recur then) (recur else))) | |
154 | ||
155 | ((<lexical-set> name gensym exp) | |
156 | (recur exp)) | |
157 | ||
158 | ((<module-set> mod name public? exp) | |
159 | (recur exp)) | |
160 | ||
161 | ((<toplevel-set> name exp) | |
162 | (recur exp)) | |
163 | ||
164 | ((<toplevel-define> name exp) | |
165 | (recur exp)) | |
166 | ||
167 | ((<sequence> exps) | |
168 | (apply max (map recur exps))) | |
169 | ||
170 | ((<lambda> vars meta body) | |
171 | (let lp ((vars vars) (n 0)) | |
172 | (if (null? vars) | |
173 | (hashq-set! allocation x | |
a1a482e0 | 174 | (let ((nlocs (- (allocate! body (1+ level) n) n))) |
cf10678f AW |
175 | (cons nlocs (1+ (hashq-ref heap-indexes x -1))))) |
176 | (let ((v (if (pair? vars) (car vars) vars))) | |
177 | (let ((binder (hashq-ref heaps v))) | |
178 | (hashq-set! | |
179 | allocation v | |
180 | (if binder | |
181 | (cons* 'heap (1+ level) (allocate-heap! binder)) | |
182 | (cons 'stack n)))) | |
183 | (lp (if (pair? vars) (cdr vars) '()) (1+ n))))) | |
184 | n) | |
185 | ||
f4aa8d53 | 186 | ((<let> vars vals body) |
cf10678f | 187 | (let ((nmax (apply max (map recur vals)))) |
5af166bd AW |
188 | (cond |
189 | ;; the `or' hack | |
f4aa8d53 | 190 | ((and (conditional? body) |
5af166bd AW |
191 | (= (length vars) 1) |
192 | (let ((v (car vars))) | |
193 | (and (not (hashq-ref heaps v)) | |
194 | (= (hashq-ref refcounts v 0) 2) | |
f4aa8d53 AW |
195 | (lexical-ref? (conditional-test body)) |
196 | (eq? (lexical-ref-gensym (conditional-test body)) v) | |
197 | (lexical-ref? (conditional-then body)) | |
198 | (eq? (lexical-ref-gensym (conditional-then body)) v)))) | |
5af166bd AW |
199 | (hashq-set! allocation (car vars) (cons 'stack n)) |
200 | ;; the 1+ for this var | |
f4aa8d53 | 201 | (max nmax (1+ n) (allocate! (conditional-else body) level n))) |
5af166bd AW |
202 | (else |
203 | (let lp ((vars vars) (n n)) | |
204 | (if (null? vars) | |
f4aa8d53 | 205 | (max nmax (allocate! body level n)) |
5af166bd AW |
206 | (let ((v (car vars))) |
207 | (let ((binder (hashq-ref heaps v))) | |
208 | (hashq-set! | |
209 | allocation v | |
210 | (if binder | |
211 | (cons* 'heap level (allocate-heap! binder)) | |
212 | (cons 'stack n))) | |
213 | (lp (cdr vars) (if binder n (1+ n))))))))))) | |
cf10678f | 214 | |
f4aa8d53 | 215 | ((<letrec> vars vals body) |
cf10678f AW |
216 | (let lp ((vars vars) (n n)) |
217 | (if (null? vars) | |
218 | (let ((nmax (apply max | |
219 | (map (lambda (x) | |
220 | (allocate! x level n)) | |
221 | vals)))) | |
f4aa8d53 | 222 | (max nmax (allocate! body level n))) |
cf10678f AW |
223 | (let ((v (car vars))) |
224 | (let ((binder (hashq-ref heaps v))) | |
225 | (hashq-set! | |
226 | allocation v | |
227 | (if binder | |
228 | (cons* 'heap level (allocate-heap! binder)) | |
ce09ee19 AW |
229 | (cons 'stack n))) |
230 | (lp (cdr vars) (if binder n (1+ n)))))))) | |
cf10678f | 231 | |
f4aa8d53 AW |
232 | ((<let-values> vars exp body) |
233 | (let ((nmax (recur exp))) | |
234 | (let lp ((vars vars) (n n)) | |
235 | (if (null? vars) | |
236 | (max nmax (allocate! body level n)) | |
237 | (let ((v (if (pair? vars) (car vars) vars))) | |
238 | (let ((binder (hashq-ref heaps v))) | |
239 | (hashq-set! | |
240 | allocation v | |
241 | (if binder | |
242 | (cons* 'heap level (allocate-heap! binder)) | |
243 | (cons 'stack n))) | |
244 | (lp (if (pair? vars) (cdr vars) '()) | |
245 | (if binder n (1+ n))))))))) | |
246 | ||
cf10678f AW |
247 | (else n))) |
248 | ||
249 | (define parents (make-hash-table)) | |
250 | (define bindings (make-hash-table)) | |
251 | (define heaps (make-hash-table)) | |
5af166bd | 252 | (define refcounts (make-hash-table)) |
cf10678f AW |
253 | (define allocation (make-hash-table)) |
254 | (define heap-indexes (make-hash-table)) | |
255 | ||
256 | (analyze! x #f -1) | |
257 | (allocate! x -1 0) | |
258 | ||
259 | allocation) |