/[gcl]/gcl/cmpnew/gcl_cmptag.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmptag.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Sun Sep 14 02:30:33 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:01 2003 UTC
# Line 0  Line 1 
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)

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26