1 |
|
;;; CMPLET Let and Let*. |
2 |
|
;;; |
3 |
|
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
4 |
|
|
5 |
|
;; This file is part of GNU Common Lisp, herein referred to as GCL |
6 |
|
;; |
7 |
|
;; GCL is free software; you can redistribute it and/or modify it under |
8 |
|
;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by |
9 |
|
;; the Free Software Foundation; either version 2, or (at your option) |
10 |
|
;; any later version. |
11 |
|
;; |
12 |
|
;; GCL is distributed in the hope that it will be useful, but WITHOUT |
13 |
|
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
14 |
|
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public |
15 |
|
;; License for more details. |
16 |
|
;; |
17 |
|
;; You should have received a copy of the GNU Library General Public License |
18 |
|
;; along with GCL; see the file COPYING. If not, write to the Free Software |
19 |
|
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
20 |
|
|
21 |
|
|
22 |
|
(in-package 'compiler) |
23 |
|
(eval-when (compile) |
24 |
|
(or (fboundp 'write-block-open) (load "cmplet.lsp"))) |
25 |
|
|
26 |
|
(si:putprop 'let 'c1let 'c1special) |
27 |
|
(si:putprop 'let 'c2let 'c2) |
28 |
|
(si:putprop 'let* 'c1let* 'c1special) |
29 |
|
(si:putprop 'let* 'c2let* 'c2) |
30 |
|
|
31 |
|
(defun c1let (args &aux (info (make-info))(setjmps *setjmps*) |
32 |
|
(forms nil) (vars nil) (vnames nil) |
33 |
|
ss is ts body other-decls |
34 |
|
(*vars* *vars*)) |
35 |
|
(when (endp args) (too-few-args 'let 1 0)) |
36 |
|
|
37 |
|
(multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) |
38 |
|
|
39 |
|
(c1add-globals ss) |
40 |
|
|
41 |
|
(dolist** (x (car args)) |
42 |
|
(cond ((symbolp x) |
43 |
|
(let ((v (c1make-var x ss is ts))) |
44 |
|
(push x vnames) |
45 |
|
(push v vars) |
46 |
|
(push (default-init (var-type v)) forms))) |
47 |
|
(t (cmpck (not (and (consp x) (or (endp (cdr x)) (endp (cddr x))))) |
48 |
|
"The variable binding ~s is illegal." x) |
49 |
|
(let ((v (c1make-var (car x) ss is ts))) |
50 |
|
(push (car x) vnames) |
51 |
|
(push v vars) |
52 |
|
(push (if (endp (cdr x)) |
53 |
|
(default-init (var-type v)) |
54 |
|
(and-form-type (var-type v) |
55 |
|
(c1expr* (cadr x) info) |
56 |
|
(cadr x))) |
57 |
|
forms))))) |
58 |
|
|
59 |
|
(dolist* (v (reverse vars)) (push v *vars*)) |
60 |
|
|
61 |
|
(check-vdecl vnames ts is) |
62 |
|
|
63 |
|
(setq body (c1decl-body other-decls body)) |
64 |
|
|
65 |
|
(add-info info (cadr body)) |
66 |
|
(setf (info-type info) (info-type (cadr body))) |
67 |
|
|
68 |
|
(dolist** (var vars) (check-vref var)) |
69 |
|
|
70 |
|
|
71 |
|
(or (eql setjmps *setjmps*) (setf (info-volatile info) t)) |
72 |
|
(list 'let info (reverse vars) (reverse forms) body) |
73 |
|
) |
74 |
|
|
75 |
|
(defun c2let (vars forms body |
76 |
|
&aux (block-p nil) (bindings nil) initials |
77 |
|
|
78 |
|
(*unwind-exit* *unwind-exit*) |
79 |
|
(*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) |
80 |
|
(declare (object block-p)) |
81 |
|
|
82 |
|
(do ((vl vars (cdr vl)) (fl forms (cdr fl)) (prev-ss nil)) |
83 |
|
((endp vl)) |
84 |
|
(declare (object vl fl)) |
85 |
|
(let* ((form (car fl)) (var (car vl)) |
86 |
|
(kind (c2var-kind var))) |
87 |
|
(declare (object form var)) |
88 |
|
(cond (kind (setf (var-kind var) kind) |
89 |
|
(setf (var-loc var) (next-cvar))) |
90 |
|
((eq (var-kind var) 'down) |
91 |
|
(or (si::fixnump (var-loc var)) (wfs-error))) |
92 |
|
(t (setf (var-ref var) (vs-push)))) |
93 |
|
(case (var-kind var) |
94 |
|
((FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT INTEGER) |
95 |
|
(push (list 'c2expr* (list 'var var nil) form) initials)) |
96 |
|
(otherwise |
97 |
|
(case (car form) |
98 |
|
(LOCATION |
99 |
|
(if (can-be-replaced var body) |
100 |
|
(progn (setf (var-kind var) 'REPLACED) |
101 |
|
(setf (var-loc var) (caddr form))) |
102 |
|
(push (list var (caddr form)) bindings))) |
103 |
|
(VAR |
104 |
|
(let ((var1 (caaddr form))) |
105 |
|
(declare (object var1)) |
106 |
|
(cond ((or (args-info-changed-vars var1 (cdr fl)) |
107 |
|
(and (member (var-kind var1) '(SPECIAL GLOBAL)) |
108 |
|
(member (var-name var1) prev-ss))) |
109 |
|
(push (list 'c2expr* |
110 |
|
(cond ((eq (var-kind var) 'object) |
111 |
|
(list 'var var nil)) |
112 |
|
((eq (var-kind var) 'down) |
113 |
|
;(push (list var) bindings) |
114 |
|
(list 'down (var-loc var))) |
115 |
|
(t(push (list var) bindings) |
116 |
|
(list 'vs (var-ref var)))) |
117 |
|
form)initials)) |
118 |
|
((and (can-be-replaced var body) |
119 |
|
(member (var-kind var1) |
120 |
|
'(LEXICAL REPLACED OBJECT)) |
121 |
|
(null (var-ref-ccb var1)) |
122 |
|
(not (member var1 (info-changed-vars |
123 |
|
(cadr body))))) |
124 |
|
(setf (var-kind var) 'REPLACED) |
125 |
|
(setf (var-loc var) |
126 |
|
(case (var-kind var1) |
127 |
|
(LEXICAL (list 'vs (var-ref var1))) |
128 |
|
(REPLACED (var-loc var1)) |
129 |
|
(OBJECT (list 'cvar (var-loc var1))) |
130 |
|
(otherwise (baboon))))) |
131 |
|
(t (push (list var |
132 |
|
(list 'var var1 (cadr (caddr form)))) |
133 |
|
bindings))))) |
134 |
|
(t (push (list 'c2expr* |
135 |
|
(cond ((eq (var-kind var) 'object) |
136 |
|
(list 'var var nil)) |
137 |
|
((eq (var-kind var) 'down) |
138 |
|
;(push (list var) bindings) |
139 |
|
(list 'down (var-loc var))) |
140 |
|
(t(push (list var) bindings) |
141 |
|
(list 'vs (var-ref var)))) |
142 |
|
form) initials)) |
143 |
|
))) |
144 |
|
(when (eq (var-kind var) 'SPECIAL) (push (var-name var) prev-ss)) |
145 |
|
)) |
146 |
|
|
147 |
|
(setq block-p (write-block-open vars)) |
148 |
|
|
149 |
|
(dolist* (binding (reverse initials)) |
150 |
|
(let ((*value-to-go* (second binding))) |
151 |
|
(c2expr* (third binding)))) |
152 |
|
(dolist* (binding (reverse bindings)) |
153 |
|
(if (cdr binding) |
154 |
|
(c2bind-loc (car binding) (cadr binding)) |
155 |
|
(c2bind (car binding)))) |
156 |
|
|
157 |
|
(c2expr body) |
158 |
|
(when block-p (wt "}")) |
159 |
|
) |
160 |
|
|
161 |
|
(defun c1let* (args &aux (forms nil) (vars nil) (vnames nil) |
162 |
|
(setjmps *setjmps*) |
163 |
|
ss is ts body other-decls |
164 |
|
(info (make-info)) (*vars* *vars*)) |
165 |
|
(when (endp args) (too-few-args 'let* 1 0)) |
166 |
|
|
167 |
|
(multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) |
168 |
|
(c1add-globals ss) |
169 |
|
|
170 |
|
(dolist** (x (car args)) |
171 |
|
(cond ((symbolp x) |
172 |
|
(let ((v (c1make-var x ss is ts))) |
173 |
|
(push x vnames) |
174 |
|
(push (default-init (var-type v)) forms) |
175 |
|
(push v vars) |
176 |
|
(push v *vars*))) |
177 |
|
((not (and (consp x) (or (endp (cdr x)) (endp (cddr x))))) |
178 |
|
(cmperr "The variable binding ~s is illegal." x)) |
179 |
|
(t (let ((v (c1make-var (car x) ss is ts))) |
180 |
|
(push (car x) vnames) |
181 |
|
(push (if (endp (cdr x)) |
182 |
|
(default-init (var-type v)) |
183 |
|
(and-form-type (var-type v) |
184 |
|
(c1expr* (cadr x) info) |
185 |
|
(cadr x))) |
186 |
|
forms) |
187 |
|
(push v vars) |
188 |
|
(push v *vars*))))) |
189 |
|
|
190 |
|
(check-vdecl vnames ts is) |
191 |
|
(setq body (c1decl-body other-decls body)) |
192 |
|
(add-info info (cadr body)) |
193 |
|
(setf (info-type info) (info-type (cadr body))) |
194 |
|
(dolist** (var vars) (check-vref var)) |
195 |
|
(or (eql setjmps *setjmps*) (setf (info-volatile info) t)) |
196 |
|
(list 'let* info (reverse vars) (reverse forms) body) |
197 |
|
) |
198 |
|
|
199 |
|
(defun c2let* (vars forms body |
200 |
|
&aux (block-p nil) |
201 |
|
(*unwind-exit* *unwind-exit*) |
202 |
|
(*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) |
203 |
|
(declare (object block-p)) |
204 |
|
|
205 |
|
|
206 |
|
(do ((vl vars (cdr vl)) |
207 |
|
(fl forms (cdr fl))) |
208 |
|
((endp vl)) |
209 |
|
(declare (object vl fl)) |
210 |
|
(let* ((form (car fl)) (var (car vl)) |
211 |
|
(kind (c2var-kind var))) |
212 |
|
(declare (object form var)) |
213 |
|
(cond (kind (setf (var-kind var) kind) |
214 |
|
(setf (var-loc var) (next-cvar)))) |
215 |
|
(if (member (var-kind var) |
216 |
|
'(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT INTEGER)) |
217 |
|
nil |
218 |
|
(case (car form) |
219 |
|
(LOCATION |
220 |
|
(cond ((can-be-replaced* var body (cdr fl)) |
221 |
|
(setf (var-kind var) 'REPLACED) |
222 |
|
(setf (var-loc var) (caddr form))) |
223 |
|
((eq (var-kind var) 'object)) |
224 |
|
((eq (var-kind var) 'down) |
225 |
|
(or (si::fixnump (var-loc var)) (baboon))) |
226 |
|
(t (setf (var-ref var) (vs-push)) |
227 |
|
))) |
228 |
|
(VAR |
229 |
|
(let ((var1 (caaddr form))) |
230 |
|
(declare (object var1)) |
231 |
|
(cond ((and (can-be-replaced* var body (cdr fl)) |
232 |
|
(member (var-kind var1) |
233 |
|
'(LEXICAL REPLACED OBJECT)) |
234 |
|
(null (var-ref-ccb var1)) |
235 |
|
(not (args-info-changed-vars var1 (cdr fl))) |
236 |
|
(not (member var1 (info-changed-vars |
237 |
|
(cadr body))))) |
238 |
|
(setf (var-kind var) 'REPLACED) |
239 |
|
(setf (var-loc var) |
240 |
|
(case (var-kind var1) |
241 |
|
(LEXICAL (list 'vs (var-ref var1))) |
242 |
|
(REPLACED (var-loc var1)) |
243 |
|
(OBJECT (list 'cvar (var-loc var1))) |
244 |
|
(t (baboon))))) |
245 |
|
((eq (var-kind var)'object)) |
246 |
|
(t (setf (var-ref var) (vs-push)) |
247 |
|
))) |
248 |
|
) |
249 |
|
((eq (var-kind var) 'object)) |
250 |
|
(t (setf (var-ref var) (vs-push)) |
251 |
|
))) |
252 |
|
)) |
253 |
|
|
254 |
|
(setq block-p (write-block-open vars)) |
255 |
|
|
256 |
|
(do ((vl vars (cdr vl)) |
257 |
|
(fl forms (cdr fl)) |
258 |
|
(var nil) (form nil)) |
259 |
|
((null vl)) |
260 |
|
(setq var (car vl))(setq form (car fl)) |
261 |
|
; (print (list (var-kind var) (car form))) |
262 |
|
(case |
263 |
|
(var-kind var) |
264 |
|
((FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT INTEGER) |
265 |
|
(let ((*value-to-go* (list 'var var nil))) |
266 |
|
(c2expr* form))) |
267 |
|
(REPLACED ) |
268 |
|
(t |
269 |
|
(case |
270 |
|
(car form) |
271 |
|
(LOCATION (c2bind-loc var (caddr form))) |
272 |
|
(VAR (c2bind-loc var (list 'var (caaddr form) (cadr (caddr form))))) |
273 |
|
(t (c2bind-init var form)))))) |
274 |
|
|
275 |
|
(c2expr body) |
276 |
|
|
277 |
|
(when block-p (wt "}")) |
278 |
|
) |
279 |
|
|
280 |
|
(defun can-be-replaced (var body) |
281 |
|
(and (or (eq (var-kind var) 'LEXICAL) |
282 |
|
(and (eq (var-kind var) 'object) |
283 |
|
(< (the fixnum (var-register var)) |
284 |
|
(the fixnum *register-min*)))) |
285 |
|
(null (var-ref-ccb var)) |
286 |
|
(not (eq (var-loc var) 'clb)) |
287 |
|
(not (member var (info-changed-vars (cadr body)))))) |
288 |
|
|
289 |
|
(defun can-be-replaced* (var body forms) |
290 |
|
(and (can-be-replaced var body) |
291 |
|
(dolist** (form forms t) |
292 |
|
(when (member var (info-changed-vars (cadr form))) |
293 |
|
(return nil))) |
294 |
|
)) |
295 |
|
|
296 |
|
|
297 |
|
(defun write-block-open (vars) |
298 |
|
(let ( block-p) |
299 |
|
(dolist** |
300 |
|
(var vars) |
301 |
|
(let ((kind (var-kind var))) |
302 |
|
(declare (object kind)) |
303 |
|
(when (member kind '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT |
304 |
|
INTEGER)) |
305 |
|
(wt-nl) |
306 |
|
(unless block-p (wt "{") (setq block-p t)) |
307 |
|
(wt-var-decl var) |
308 |
|
))) |
309 |
|
block-p )) |
310 |
|
|
311 |
|
|
312 |
|
;; ---------- stack-let for consing on stack --------- |
313 |
|
|
314 |
|
;; Usage: (stack-let ((a (cons 1 2)) (b (cons 3 4))) (foo a) (print b) 7) |
315 |
|
;; where foo must not keep a copy of `a', since the cons will be formed |
316 |
|
;; on the c stack. |
317 |
|
|
318 |
|
(setf (get 'stack-let 'c1special) 'c1stack-let) |
319 |
|
|
320 |
|
(defmacro stack-let (&rest x) (cons `let x)) |
321 |
|
|
322 |
|
(defun c1stack-let (args &aux npairs nums) |
323 |
|
(let ((pairs (car args)) |
324 |
|
) |
325 |
|
(dolist (v pairs) |
326 |
|
(push |
327 |
|
(cond ((atom v) v) |
328 |
|
((let ((var (car v)) |
329 |
|
(val (second v))) |
330 |
|
(and (consp val) |
331 |
|
(or (eq (car val) 'cons) |
332 |
|
(and (eq (car val) 'list) |
333 |
|
(null (cddr val)) |
334 |
|
(setq val `(cons ,(second val) nil)))) |
335 |
|
(progn |
336 |
|
(push (next-cvar) nums) |
337 |
|
`(,var (stack-cons ,(car nums) ,@ (cdr val))))))) |
338 |
|
(t (cmpwarn "Stack let = regular let for ~a ~a" |
339 |
|
v (cdr args)) |
340 |
|
v)) |
341 |
|
npairs)) |
342 |
|
(let ((result (c1expr (cons 'let (cons (nreverse npairs) (cdr args)))))) |
343 |
|
(list 'stack-let (second result) nums result)))) |
344 |
|
|
345 |
|
(setf (get 'stack-let 'c2) 'c2stack-let) |
346 |
|
|
347 |
|
(defun c2stack-let (nums form) |
348 |
|
(let ((n (next-cvar))) |
349 |
|
(wt-nl "{Cons_Macro" n ";") |
350 |
|
(c2expr form) |
351 |
|
(wt "}") |
352 |
|
(wt-h |
353 |
|
"#define Cons_Macro" n (format nil " struct cons ~{STcons~a ~^,~};" nums) |
354 |
|
))) |
355 |
|
|
356 |
|
(push '((fixnum t t) t #.(flags) |
357 |
|
"(STcons#0.t=t_cons,STcons#0.m=0,STcons#0.c_car=(#1), |
358 |
|
STcons#0.c_cdr=(#2),(object)&STcons#0)") |
359 |
|
(get 'stack-cons 'inline-always)) |
360 |
|
|
361 |
|
;; ---------- end stack-let for consing on stack --------- |
362 |
|
|