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

Diff of /gcl/cmpnew/gcl_cmplabel.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    ;;; CMPLABEL  Exit manager.
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    
24    (defvar *last-label* 0)
25    (defvar *exit*)
26    (defvar *unwind-exit*)
27    (defvar *record-call-info* nil)
28    
29    ;;; *last-label* holds the label# of the last used label.
30    ;;; *exit* holds an 'exit', which is
31    ;;;     ( label# . ref-flag ) or one of RETURNs (i.e. RETURN, RETURN-FIXNUM,
32    ;;;     RETURN-CHARACTER, RETURN-LONG-FLOAT, RETURN-SHORT-FLOAT, or
33    ;;;     RETURN-OBJECT).
34    ;;; *unwind-exit* holds a list consisting of:
35    ;;;     ( label# . ref-flag ), one of RETURNs, TAIL-RECURSION-MARK, FRAME,
36    ;;;     JUMP, BDS-BIND (each pushed for a single special binding), and
37    ;;;     cvar (which holds the bind stack pointer used to unbind).
38    
39    (defmacro next-label () `(cons (incf *last-label*) nil))
40    
41    (defmacro next-label* () `(cons (incf *last-label*) t))
42    
43    (defmacro wt-label (label)
44      `(when (cdr ,label) (wt-nl "goto T" (car ,label) ";")(wt-nl1 "T" (car ,label) ":;")))
45    
46    (defmacro wt-go (label)
47      `(progn (rplacd ,label t) (wt "goto T" (car ,label) ";")))
48    
49    
50    (defvar *restore-avma* nil)
51    
52    (defun unwind-bds (bds-cvar bds-bind)
53           (when (consp *inline-blocks*) (wt-nl "restore_avma; "))
54           (when bds-cvar (wt-nl "bds_unwind(V" bds-cvar ");"))
55           (dotimes* (n bds-bind) (wt-nl "bds_unwind1;")))
56    
57    (defun unwind-exit (loc &optional (jump-p nil) fname
58                            &aux (*vs* *vs*) (bds-cvar nil) (bds-bind 0) type.wt)
59      (declare (fixnum bds-bind))
60      (and *record-call-info* (record-call-info loc fname))
61      (when (and (eq loc 'fun-val)
62                 (not (eq *value-to-go* 'return))
63                 (not (eq *value-to-go* 'top)))
64            (wt-nl) (reset-top))
65      (cond ((and (consp *value-to-go*) (eq (car *value-to-go*) 'jump-true))
66             (set-jump-true loc (cadr *value-to-go*))
67             (when (eq loc t) (return-from unwind-exit)))
68            ((and (consp *value-to-go*) (eq (car *value-to-go*) 'jump-false))
69             (set-jump-false loc (cadr *value-to-go*))
70             (when (null loc) (return-from unwind-exit))))
71      (dolist* (ue *unwind-exit* (baboon))
72       (cond
73        ((consp ue)
74         (cond ((eq ue *exit*)
75                (cond ((and (consp *value-to-go*)
76                            (or (eq (car *value-to-go*) 'jump-true)
77                                (eq (car *value-to-go*) 'jump-false)))
78                       (unwind-bds bds-cvar bds-bind))
79                      (t
80                       (if (or bds-cvar   (plusp bds-bind))
81                              ;;; Save the value if LOC may possibly refer
82                              ;;; to special binding.
83                           (if (and (consp loc)
84                                    (or (and (eq (car loc) 'var)
85                                             (member (var-kind (cadr loc))
86                                                     '(SPECIAL GLOBAL)))
87                                        (member (car loc)
88                                                '(SIMPLE-CALL
89                                                  INLINE
90                                                  INLINE-COND INLINE-FIXNUM
91                                                  INLINE-CHARACTER
92                                                  INLINE-INTEGER
93                                                  INLINE-LONG-FLOAT
94                                                  INLINE-SHORT-FLOAT))))
95                               (cond ((and (consp *value-to-go*)
96                                           (eq (car *value-to-go*) 'vs))
97                                      (set-loc loc)
98                                      (unwind-bds bds-cvar bds-bind))
99                                     (t (let
100                                            ((temp (list 'cvar (cs-push))))
101                                          (let ((*value-to-go* temp))
102                                            (set-loc loc))
103                                          (unwind-bds bds-cvar bds-bind)
104                                          (set-loc temp))))
105                             (progn (unwind-bds bds-cvar bds-bind)
106                                    (set-loc loc)))
107                         (set-loc loc))))
108    
109                (when jump-p
110                  (when (consp *inline-blocks*) (wt-nl "restore_avma; "))
111                  (wt-nl) (wt-go *exit*))
112                (return))
113               (t (setq jump-p t))))
114        ((numberp ue) (setq bds-cvar ue bds-bind 0))
115        ((eq ue 'bds-bind) (incf bds-bind))
116        ((eq ue 'return)
117         (when (eq *exit* 'return)
118                  ;;; *VALUE-TO-GO* must be either *RETURN* or *TRASH*.
119           (set-loc loc)
120           (unwind-bds bds-cvar bds-bind)
121           (wt-nl "return;")
122           (return))
123            ;;; Never reached
124         )
125        ((eq ue 'frame)
126         (when (and (consp loc)
127                    (member (car loc)
128                            '(SIMPLE-CALL INLINE INLINE-COND INLINE-FIXNUM inline-integer
129                                          INLINE-CHARACTER INLINE-LONG-FLOAT
130                                          INLINE-SHORT-FLOAT)))
131           (cond ((and (consp *value-to-go*)
132                       (eq (car *value-to-go*) 'vs))
133                  (set-loc loc)
134                  (setq loc *value-to-go*))
135                 (t (let ((*value-to-go* (if *c-gc* (list 'cvar (cs-push))
136                                           (list 'vs (vs-push)))))
137                      (set-loc loc)
138                      (setq loc *value-to-go*)))))
139         (wt-nl "frs_pop();"))
140        ((eq ue 'tail-recursion-mark))
141        ((eq ue 'jump) (setq jump-p t))
142        ((setq type.wt
143               (assoc ue
144                      '((return-fixnum fixnum .  wt-fixnum-loc)
145                        (return-character character . wt-character-loc)
146                        (return-short-float short-float . wt-short-float-loc)
147                        (return-long-float long-float . wt-long-float-loc)
148                        (return-object t . wt-loc))))
149         (let ((cvar (next-cvar)))
150           (or (eq *exit* (car type.wt)) (wfs-error))
151           (setq type.wt (cdr type.wt))
152           (wt-nl "{" (rep-type (car type.wt)) "V" cvar " = ")
153           (funcall (cdr type.wt) loc)  (wt ";")
154           (unwind-bds bds-cvar bds-bind)
155           (wt-nl "VMR" *reservation-cmacro* "("
156                  (if (equal (rep-type (car type.wt)) "long ") "(object)" "")
157                  "V" cvar")}")
158           (return)))
159                    
160        (t (baboon))
161           ;;; Never reached
162        ))
163      )
164    
165    (defun unwind-no-exit (exit &aux (bds-cvar nil) (bds-bind 0))
166      (declare (fixnum bds-bind))
167      (dolist* (ue *unwind-exit* (baboon))
168        (cond
169           ((consp ue)
170            (when (eq ue exit)
171                  (unwind-bds bds-cvar bds-bind)
172                  (return)))
173           ((numberp ue) (setq bds-cvar ue bds-bind 0))
174           ((eq ue 'bds-bind) (incf bds-bind))
175           ((member ue '(return return-object return-fixnum return-character
176                                return-long-float return-short-float))
177            (cond ((eq exit ue) (unwind-bds bds-cvar bds-bind)
178                                (return))
179                  (t (baboon)))
180            ;;; Never reached
181            )
182           ((eq ue 'frame) (wt-nl "frs_pop();"))
183           ((eq ue 'tail-recursion-mark)
184            (cond ((eq exit 'tail-recursion-mark) (unwind-bds bds-cvar bds-bind)
185                                                  (return))
186                  (t (baboon)))
187            ;;; Never reached
188            )
189           ((eq ue 'jump))
190           (t (baboon))
191           ;;; Never reached
192           ))
193      )
194    
195    ;;; Tail-recursion optimization for a function F is possible only if
196    ;;;     1. the value of *DO-TAIL-RECURSION* is non-nil (this is default),
197    ;;;     2. F receives only required parameters, and
198    ;;;     3. no required parameter of F is enclosed in a closure.
199    ;;;
200    ;;; A recursive call (F e1 ... en) may be replaced by a loop only if
201    ;;;     1. F is not declared as NOTINLINE,
202    ;;;     2. n is equal to the number of required parameters of F,
203    ;;;     3. the form is a normal function call (i.e. the arguments are
204    ;;;        pushed on the stack,
205    ;;;     4. (F e1 ... en) is not surrounded by a form that causes dynamic
206    ;;;        binding (such as LET, LET*, PROGV),
207    ;;;     5. (F e1 ... en) is not surrounded by a form that that pushes a frame
208    ;;;        onto the frame-stack (such as BLOCK and TAGBODY whose tags are
209    ;;;        enclosed in a closure, and CATCH),
210    
211    (defun tail-recursion-possible ()
212      (dolist* (ue *unwind-exit* (baboon))
213        (cond ((eq ue 'tail-recursion-mark) (return t))
214              ((or (numberp ue) (eq ue 'bds-bind) (eq ue 'frame))
215               (return nil))
216              ((or (consp ue) (eq ue 'jump)))
217              (t (baboon)))))

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