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))))) |