1 |
|
;;; CMPTAG Tagbody and Go. |
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 |
|
(import 'si::switch) |
24 |
|
(import 'si::switch-finish) |
25 |
|
|
26 |
|
|
27 |
|
(si:putprop 'tagbody 'c1tagbody 'c1special) |
28 |
|
(si:putprop 'tagbody 'c2tagbody 'c2) |
29 |
|
|
30 |
|
(si:putprop 'go 'c1go 'c1special) |
31 |
|
(si:putprop 'go 'c2go 'c2) |
32 |
|
|
33 |
|
(defstruct tag |
34 |
|
name ;;; Tag name. |
35 |
|
ref ;;; Referenced or not. T or NIL. |
36 |
|
ref-clb ;;; Cross local function reference. |
37 |
|
;;; During Pass1, T or NIL. |
38 |
|
;;; During Pass2, the vs-address for the |
39 |
|
;;; tagbody id, or NIL. |
40 |
|
ref-ccb ;;; Cross closure reference. |
41 |
|
;;; During Pass1, T or NIL. |
42 |
|
;;; During Pass2, the vs-address for the |
43 |
|
;;; block id, or NIL. |
44 |
|
label ;;; Where to jump. A label. |
45 |
|
unwind-exit ;;; Where to unwind-no-exit. |
46 |
|
var ;;; The tag-name holder. A VV index. |
47 |
|
switch ;;; tag for switch. A fixnum or 'default |
48 |
|
) |
49 |
|
|
50 |
|
(defvar *tags* nil) |
51 |
|
|
52 |
|
;;; During Pass 1, *tags* holds a list of tag objects and the symbols 'CB' |
53 |
|
;;; (Closure Boundary) and 'LB' (Level Boundary). 'CB' will be pushed on |
54 |
|
;;; *tags* when the compiler begins to process a closure. 'LB' will be pushed |
55 |
|
;;; on *tags* when *level* is incremented. |
56 |
|
|
57 |
|
|
58 |
|
|
59 |
|
(defun jumps-to-p (clause tag-name &aux tem) |
60 |
|
;;Does CLAUSE have a go TAG-NAME in it? |
61 |
|
(cond ((atom clause)nil) |
62 |
|
((and (eq (car clause) 'go) |
63 |
|
(tag-p (setq tem (cadddr (cdr clause)))) |
64 |
|
(eq (tag-name tem) tag-name))) |
65 |
|
(t (or (jumps-to-p (car clause) tag-name) |
66 |
|
(jumps-to-p (cdr clause) tag-name))))) |
67 |
|
|
68 |
|
(defvar *reg-amount* 60) |
69 |
|
;;amount to increase var-register for each variable reference in side a loop |
70 |
|
|
71 |
|
(defun add-reg1 (form) |
72 |
|
;;increase the var-register in FORM for all vars |
73 |
|
(cond ((atom form) |
74 |
|
(cond ((typep form 'var) |
75 |
|
(setf (var-register form) |
76 |
|
(the fixnum (+ (the fixnum (var-register form)) |
77 |
|
(the fixnum *reg-amount*)))) |
78 |
|
))) |
79 |
|
(t (add-reg1 (car form)) |
80 |
|
(add-reg1 (cdr form))))) |
81 |
|
|
82 |
|
|
83 |
|
(defun add-loop-registers (tagbody) |
84 |
|
;;Find a maximal iteration interval in TAGBODY from first to end |
85 |
|
;;then increment the var-register slot. |
86 |
|
(do ((v tagbody (cdr v)) |
87 |
|
(end nil) |
88 |
|
(first nil)) |
89 |
|
((null v) |
90 |
|
(do ((ww first (cdr ww))) |
91 |
|
((eq ww end)(add-reg1 (car ww))) |
92 |
|
(add-reg1 (car ww)))) |
93 |
|
(cond ((typep (car v) 'tag) |
94 |
|
(or first (setq first v)) |
95 |
|
(do ((w (cdr v) (cdr w)) |
96 |
|
(name (tag-name (car v)))) |
97 |
|
((null w) ) |
98 |
|
(cond ((jumps-to-p (car w) name) |
99 |
|
(setq end w)))))))) |
100 |
|
|
101 |
|
(defun c1tagbody (body &aux (*tags* *tags*) (info (make-info))) |
102 |
|
;;; Establish tags. |
103 |
|
(setq body |
104 |
|
(mapcar |
105 |
|
#'(lambda (x) |
106 |
|
(cond ((or (symbolp x) (integerp x)) |
107 |
|
(let ((tag (make-tag :name x :ref nil |
108 |
|
:ref-ccb nil :ref-clb nil))) |
109 |
|
(push tag *tags*) |
110 |
|
tag)) |
111 |
|
(t x))) |
112 |
|
body)) |
113 |
|
|
114 |
|
;;; Process non-tag forms. |
115 |
|
(setq body (mapcar #'(lambda (x) (if (typep x 'tag) x (c1expr* x info))) |
116 |
|
body)) |
117 |
|
|
118 |
|
;;; Delete redundant tags. |
119 |
|
(do ((l body (cdr l)) |
120 |
|
(body1 nil) (ref nil) (ref-clb nil) (ref-ccb nil)) |
121 |
|
((endp l) |
122 |
|
(if (or ref-ccb ref-clb ref) |
123 |
|
(progn (setq body1 (reverse body1)) |
124 |
|
(cond ((or ref-clb ref-ccb) |
125 |
|
(incf *setjmps*)) |
126 |
|
(t |
127 |
|
(add-loop-registers body1 ))) |
128 |
|
(list 'tagbody info ref-clb ref-ccb body1)) |
129 |
|
(list 'progn info (reverse (cons (c1nil) body1))))) |
130 |
|
(declare (object l ref ref-clb ref-ccb)) |
131 |
|
(if (typep (car l) 'tag) |
132 |
|
(cond ((tag-ref-ccb (car l)) |
133 |
|
(push (car l) body1) |
134 |
|
(setf (tag-var (car l)) (add-object (tag-name (car l)))) |
135 |
|
(setq ref-ccb t)) |
136 |
|
((tag-ref-clb (car l)) |
137 |
|
(push (car l) body1) |
138 |
|
(setf (tag-var (car l)) (add-object (tag-name (car l)))) |
139 |
|
(setq ref-clb t)) |
140 |
|
((tag-ref (car l)) (push (car l) body1) (setq ref t))) |
141 |
|
(push (car l) body1)))) |
142 |
|
|
143 |
|
(defun c2tagbody (ref-clb ref-ccb body) |
144 |
|
(cond (ref-ccb (c2tagbody-ccb body)) |
145 |
|
(ref-clb (c2tagbody-clb body)) |
146 |
|
(t (c2tagbody-local body)))) |
147 |
|
|
148 |
|
(defun c2tagbody-local (body &aux (label (next-label))) |
149 |
|
;;; Allocate labels. |
150 |
|
(dolist** (x body) |
151 |
|
(when (typep x 'tag) |
152 |
|
(setf (tag-label x) (next-label*)) |
153 |
|
(setf (tag-unwind-exit x) label))) |
154 |
|
(let ((*unwind-exit* (cons label *unwind-exit*))) |
155 |
|
(c2tagbody-body body)) |
156 |
|
|
157 |
|
) |
158 |
|
|
159 |
|
(defun c2tagbody-body (body) |
160 |
|
(do ((l body (cdr l)) (written nil)) |
161 |
|
((endp (cdr l)) |
162 |
|
(cond (written (unwind-exit nil)) |
163 |
|
((typep (car l) 'tag) |
164 |
|
(wt-switch-case (tag-switch (car l))) |
165 |
|
(wt-label (tag-label (car l))) |
166 |
|
(unwind-exit nil)) |
167 |
|
(t (let* ((*exit* (next-label)) |
168 |
|
(*unwind-exit* (cons *exit* *unwind-exit*)) |
169 |
|
(*value-to-go* 'trash)) |
170 |
|
(c2expr (car l)) |
171 |
|
(wt-label *exit*)) |
172 |
|
(unless (eq (caar l) 'go) (unwind-exit nil))))) |
173 |
|
(declare (object l written)) |
174 |
|
(cond (written (setq written nil)) |
175 |
|
((typep (car l) 'tag) |
176 |
|
(wt-switch-case (tag-switch (car l))) |
177 |
|
(wt-label (tag-label (car l)))) |
178 |
|
(t (let* ((*exit* (if (typep (cadr l) 'tag) |
179 |
|
(progn (setq written t) (tag-label (cadr l))) |
180 |
|
(next-label))) |
181 |
|
(*unwind-exit* (cons *exit* *unwind-exit*)) |
182 |
|
(*value-to-go* 'trash)) |
183 |
|
(c2expr (car l)) |
184 |
|
(and (typep (cadr l) 'tag) |
185 |
|
(wt-switch-case (tag-switch (cadr l)))) |
186 |
|
(wt-label *exit*)))))) |
187 |
|
|
188 |
|
(defun c2tagbody-clb (body &aux (label (next-label)) (*vs* *vs*)) |
189 |
|
(let ((*unwind-exit* (cons 'frame *unwind-exit*)) |
190 |
|
(ref-clb (vs-push))) |
191 |
|
(wt-nl) (wt-vs ref-clb) (wt "=alloc_frame_id();") |
192 |
|
(wt-nl "frs_push(FRS_CATCH,") (wt-vs ref-clb) (wt ");") |
193 |
|
(wt-nl "if(nlj_active){") |
194 |
|
(wt-nl "nlj_active=FALSE;") |
195 |
|
;;; Allocate labels. |
196 |
|
(dolist** (tag body) |
197 |
|
(when (typep tag 'tag) |
198 |
|
(setf (tag-label tag) (next-label*)) |
199 |
|
(setf (tag-unwind-exit tag) label) |
200 |
|
(when (tag-ref-clb tag) |
201 |
|
(setf (tag-ref-clb tag) ref-clb) |
202 |
|
(wt-nl "if(eql(nlj_tag,VV[" (tag-var tag) "]))") |
203 |
|
(wt-go (tag-label tag))))) |
204 |
|
(wt-nl "FEerror(\"The GO tag ~s is not established.\",1,nlj_tag);") |
205 |
|
(wt-nl "}") |
206 |
|
(let ((*unwind-exit* (cons label *unwind-exit*))) |
207 |
|
(c2tagbody-body body)))) |
208 |
|
|
209 |
|
(defun c2tagbody-ccb (body &aux (label (next-label)) |
210 |
|
(*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) |
211 |
|
(let ((*unwind-exit* (cons 'frame *unwind-exit*)) |
212 |
|
(ref-clb (vs-push)) ref-ccb) |
213 |
|
(wt-nl) (wt-vs ref-clb) (wt "=alloc_frame_id();") |
214 |
|
(wt-nl) (wt-vs ref-clb) (wt "=MMcons(") (wt-vs ref-clb) (wt ",") |
215 |
|
(wt-clink) (wt ");") |
216 |
|
(clink ref-clb) |
217 |
|
(setq ref-ccb (ccb-vs-push)) |
218 |
|
(wt-nl "frs_push(FRS_CATCH,") (wt-vs* ref-clb) (wt ");") |
219 |
|
(wt-nl "if(nlj_active){") |
220 |
|
(wt-nl "nlj_active=FALSE;") |
221 |
|
;;; Allocate labels. |
222 |
|
(dolist** (tag body) |
223 |
|
(when (typep tag 'tag) |
224 |
|
(setf (tag-label tag) (next-label*)) |
225 |
|
(setf (tag-unwind-exit tag) label) |
226 |
|
(when (or (tag-ref-clb tag) (tag-ref-ccb tag)) |
227 |
|
(setf (tag-ref-clb tag) ref-clb) |
228 |
|
(when (tag-ref-ccb tag) (setf (tag-ref-ccb tag) ref-ccb)) |
229 |
|
(wt-nl "if(eql(nlj_tag,VV[" (tag-var tag) "]))") |
230 |
|
(wt-go (tag-label tag))))) |
231 |
|
(wt-nl "FEerror(\"The GO tag ~s is not established.\",1,nlj_tag);") |
232 |
|
(wt-nl "}") |
233 |
|
(let ((*unwind-exit* (cons label *unwind-exit*))) |
234 |
|
(c2tagbody-body body)))) |
235 |
|
|
236 |
|
(defun c1go (args) |
237 |
|
(cond ((endp args) (too-few-args 'go 1 0)) |
238 |
|
((not (endp (cdr args))) (too-many-args 'go 1 (length args))) |
239 |
|
((not (or (symbolp (car args)) (integerp (car args)))) |
240 |
|
"The tag name ~s is not a symbol nor an integer." (car args))) |
241 |
|
(do ((tags *tags* (cdr tags)) |
242 |
|
(name (car args)) |
243 |
|
(ccb nil) (clb nil)) |
244 |
|
((endp tags) (cmperr "The tag ~s is undefined." name)) |
245 |
|
(declare (object name ccb clb)) |
246 |
|
(case (car tags) |
247 |
|
(cb (setq ccb t)) |
248 |
|
(lb (setq clb t)) |
249 |
|
(t (when (eq (tag-name (car tags)) name) |
250 |
|
(let ((tag (car tags))) |
251 |
|
(cond (ccb (setf (tag-ref-ccb tag) t)) |
252 |
|
(clb (setf (tag-ref-clb tag) t)) |
253 |
|
(t (setf (tag-ref tag) t))) |
254 |
|
(return (list 'go *info* clb ccb tag)))))))) |
255 |
|
|
256 |
|
(defun c2go (clb ccb tag) |
257 |
|
(cond (ccb (c2go-ccb tag)) |
258 |
|
(clb (c2go-clb tag)) |
259 |
|
(t (c2go-local tag)))) |
260 |
|
|
261 |
|
(defun c2go-local (tag) |
262 |
|
(unwind-no-exit (tag-unwind-exit tag)) |
263 |
|
(wt-nl) (wt-go (tag-label tag))) |
264 |
|
|
265 |
|
(defun c2go-clb (tag) |
266 |
|
(wt-nl "vs_base=vs_top;") |
267 |
|
(wt-nl "unwind(frs_sch(") |
268 |
|
(if (tag-ref-ccb tag) |
269 |
|
(wt-vs* (tag-ref-clb tag)) |
270 |
|
(wt-vs (tag-ref-clb tag))) |
271 |
|
(wt "),VV[" (tag-var tag) "]);")) |
272 |
|
|
273 |
|
(defun c2go-ccb (tag) |
274 |
|
(wt-nl "{frame_ptr fr;") |
275 |
|
(wt-nl "fr=frs_sch(") (wt-ccb-vs (tag-ref-ccb tag)) (wt ");") |
276 |
|
(wt-nl "if(fr==NULL)FEerror(\"The GO tag ~s is missing.\",1,VV[" |
277 |
|
(tag-var tag) "]);") |
278 |
|
(wt-nl "vs_base=vs_top;") |
279 |
|
(wt-nl "unwind(fr,VV[" (tag-var tag) "]);}")) |
280 |
|
|
281 |
|
|
282 |
|
(defun wt-switch-case (x) |
283 |
|
(cond (x (wt-nl (if (typep x 'fixnum) "case " "") x ":")))) |
284 |
|
|
285 |
|
(defun c1switch(form &aux (*tags* *tags*)) |
286 |
|
(let* ((switch-op (car form)) |
287 |
|
(body (cdr form)) |
288 |
|
(switch-op-1 (c1expr switch-op))) |
289 |
|
(cond ((and (typep (second switch-op-1 ) 'info) |
290 |
|
(subtypep (info-type (second switch-op-1)) 'fixnum)) |
291 |
|
;;optimize into a C switch: |
292 |
|
;;If we ever get GCC to do switch's with an enum arg, |
293 |
|
;;which don't do bounds checking, then we will |
294 |
|
;;need to carry over the restricted range. |
295 |
|
;;more generally the compiler should carry along the original type |
296 |
|
;;decl, not just the coerced one. This needs another slot in |
297 |
|
;;info. |
298 |
|
(or (member t body) (setq body (append body (list t)))) |
299 |
|
(setq body |
300 |
|
(mapcar |
301 |
|
#'(lambda (x) |
302 |
|
(cond ((or (symbolp x) (integerp x)) |
303 |
|
(let ((tag (make-tag :name x :ref |
304 |
|
nil |
305 |
|
:ref-ccb nil |
306 |
|
:ref-clb nil))) |
307 |
|
(cond((typep x 'fixnum) |
308 |
|
(setf (tag-ref tag) t) |
309 |
|
(setf (tag-switch tag) x)) |
310 |
|
((eq t x) |
311 |
|
(setf (tag-ref tag) t) |
312 |
|
(setf (tag-switch tag) "default"))) |
313 |
|
tag)) |
314 |
|
(t x))) |
315 |
|
body)) |
316 |
|
(let ((tem (c1tagbody |
317 |
|
`(,@ body |
318 |
|
switch-finish-label)))) |
319 |
|
(nconc (list 'switch (cadr tem) switch-op-1) |
320 |
|
(cddr tem)) |
321 |
|
)) |
322 |
|
(t (c1expr (cmp-macroexpand-1 (cons 'switch form))))))) |
323 |
|
|
324 |
|
(defun c2switch (op ref-clb ref-ccb body &aux (*inline-blocks* 0)(*vs* *vs*)) |
325 |
|
(let ((args (inline-args (list op ) '(fixnum )))) |
326 |
|
(wt-inline-loc "switch(#0){" args) |
327 |
|
(cond (ref-ccb (c2tagbody-ccb body)) |
328 |
|
(ref-clb (c2tagbody-clb body)) |
329 |
|
(t (c2tagbody-local body))) |
330 |
|
(wt "}") |
331 |
|
(unwind-exit nil) |
332 |
|
(close-inline-blocks))) |
333 |
|
|
334 |
|
|
335 |
|
|
336 |
|
;; SWITCH construct for Common Lisp. (TEST &body BODY) (in package SI) |
337 |
|
|
338 |
|
;; TEST must evaluate to something of INTEGER TYPE. If test matches one |
339 |
|
;; of the labels (ie integers) in the body of switch, control will jump |
340 |
|
;; to that point. It is an error to have two or more constants which are |
341 |
|
;; eql in the the same switch. If none of the constants match the value, |
342 |
|
;; then control moves to a label T. If there is no label T, control |
343 |
|
;; flows as if the last term in the switch were a T. It is an error |
344 |
|
;; however if TEST were declared to be in a given integer range, and at |
345 |
|
;; runtime a value outside that range were provided. The value of a |
346 |
|
;; switch construct is undefined. If you wish to return a value use a |
347 |
|
;; block construct outside the switch and a return-from. `GO' may also |
348 |
|
;; be used to jump to labels in the SWITCH. |
349 |
|
|
350 |
|
;; Control falls through from case to case, just as if the cases were |
351 |
|
;; labels in a tagbody. To jump to the end of the switch, use |
352 |
|
;; (switch-finish). |
353 |
|
|
354 |
|
;; The reason for using a new construct rather than building on CASE, is |
355 |
|
;; that CASE does not allow the user to use invoke a `GO' if necessary. |
356 |
|
;; to switch from one case to another. Also CASE does not allow sharing |
357 |
|
;; of parts of code between different cases. They have to be either the |
358 |
|
;; same or disjoint. |
359 |
|
|
360 |
|
;; The SWITCH may be implemented very efficiently using a jump table, if |
361 |
|
;; the range of cases is not too much larger than the number of cases. |
362 |
|
;; If the range is much larger than the number of cases, a binary |
363 |
|
;; splitting of cases might be used. |
364 |
|
|
365 |
|
;; Sample usage: |
366 |
|
;; (defun goo (x) |
367 |
|
;; (switch x |
368 |
|
;; 1 (princ "x is one, ") |
369 |
|
;; 2 (princ "x is one or two, ") |
370 |
|
;; (switch-finish) |
371 |
|
;; 3 (princ "x is three, ") |
372 |
|
;; (switch-finish) |
373 |
|
;; t (princ "none"))) |
374 |
|
|
375 |
|
;; We provide a Common Lisp macro for implementing the above construct: |
376 |
|
|
377 |
|
|
378 |
|
(defmacro switch (test &body body &aux cases) |
379 |
|
(dolist (v body) |
380 |
|
(cond ((integerp v) (push `(if (eql ,v ,test) (go ,v) nil) cases)))) |
381 |
|
`(tagbody |
382 |
|
,@ (nreverse cases) |
383 |
|
(go t) |
384 |
|
,@ body |
385 |
|
,@ (if (member t body) nil '(t)) |
386 |
|
switch-finish-label )) |
387 |
|
|
388 |
|
(defmacro switch-finish nil '(go switch-finish-label)) |
389 |
|
|
390 |
|
|
391 |
|
(si::putprop 'switch 'c1switch 'c1special) |
392 |
|
(si::putprop 'switch 'c2switch 'c2) |