/[cmucl]/src/compiler/rt/nlx.lisp
ViewVC logotype

Contents of /src/compiler/rt/nlx.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Sun Aug 3 11:27:47 2003 UTC (10 years, 8 months ago) by gerd
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.5: +4 -4 lines
	Remove the function definition of FIXNUM, which it must not
	have according to CLtS.  Found by Paul Dietz.

	Use boot14.lisp to bootstrap.

	* src/compiler/generic/utils.lisp (fixnumize): Renamed from
	fixnum.

	* src/bootfiles/18e/boot14.lisp: New file.

	* src/code/exports.lisp ("VM"): Export fixnumize.

	* src/assembly/alpha/arith.lisp, src/assembly/alpha/array.lisp:
	* src/assembly/alpha/assem-rtns.lisp, src/assembly/hppa/arith.lisp
	* src/assembly/hppa/array.lisp, src/assembly/hppa/assem-rtns.lisp
	* src/assembly/mips/alloc.lisp, src/assembly/mips/arith.lisp
	* src/assembly/mips/array.lisp, src/assembly/mips/assem-rtns.lisp
	* src/assembly/mips/bit-bash.lisp, src/assembly/ppc/arith.lisp
	* src/assembly/ppc/array.lisp, src/assembly/ppc/assem-rtns.lisp
	* src/assembly/rt/alloc.lisp, src/assembly/rt/arith.lisp
	* src/assembly/rt/array.lisp, src/assembly/rt/assem-rtns.lisp
	* src/assembly/sparc/arith.lisp, src/assembly/sparc/array.lisp
	* src/assembly/sparc/assem-rtns.lisp, src/assembly/x86/arith.lisp
	* src/assembly/x86/array.lisp, src/assembly/x86/assem-rtns.lisp
	* src/compiler/alpha/alloc.lisp, src/compiler/alpha/arith.lisp
	* src/compiler/alpha/array.lisp, src/compiler/alpha/call.lisp
	* src/compiler/alpha/move.lisp, src/compiler/alpha/nlx.lisp
	* src/compiler/alpha/static-fn.lisp, src/compiler/alpha/subprim.lisp
	* src/compiler/alpha/values.lisp, src/compiler/generic/utils.lisp
	* src/compiler/hppa/alloc.lisp, src/compiler/hppa/arith.lisp
	* src/compiler/hppa/array.lisp, src/compiler/hppa/call.lisp
	* src/compiler/hppa/move.lisp, src/compiler/hppa/nlx.lisp
	* src/compiler/hppa/static-fn.lisp, src/compiler/hppa/subprim.lisp
	* src/compiler/hppa/values.lisp, src/compiler/mips/alloc.lisp
	* src/compiler/mips/arith.lisp, src/compiler/mips/array.lisp
	* src/compiler/mips/call.lisp, src/compiler/mips/move.lisp
	* src/compiler/mips/nlx.lisp, src/compiler/mips/static-fn.lisp
	* src/compiler/mips/subprim.lisp, src/compiler/mips/values.lisp
	* src/compiler/ppc/alloc.lisp, src/compiler/ppc/arith.lisp
	* src/compiler/ppc/array.lisp, src/compiler/ppc/call.lisp
	* src/compiler/ppc/move.lisp, src/compiler/ppc/nlx.lisp
	* src/compiler/ppc/static-fn.lisp, src/compiler/ppc/subprim.lisp
	* src/compiler/ppc/values.lisp, src/compiler/rt/alloc.lisp
	* src/compiler/rt/arith.lisp, src/compiler/rt/array.lisp
	* src/compiler/rt/call.lisp, src/compiler/rt/move.lisp
	* src/compiler/rt/nlx.lisp, src/compiler/rt/static-fn.lisp
	* src/compiler/rt/subprim.lisp, src/compiler/rt/values.lisp
	* src/compiler/sparc/alloc.lisp, src/compiler/sparc/arith.lisp
	* src/compiler/sparc/array.lisp, src/compiler/sparc/call.lisp
	* src/compiler/sparc/move.lisp, src/compiler/sparc/nlx.lisp
	* src/compiler/sparc/static-fn.lisp, src/compiler/sparc/subprim.lisp
	* src/compiler/sparc/values.lisp, src/compiler/x86/alloc.lisp
	* src/compiler/x86/arith.lisp, src/compiler/x86/array.lisp
	* src/compiler/x86/call.lisp, src/compiler/x86/cell.lisp
	* src/compiler/x86/macros.lisp, src/compiler/x86/memory.lisp
	* src/compiler/x86/move.lisp, src/compiler/x86/nlx.lisp
	* src/compiler/x86/pred.lisp, src/compiler/x86/static-fn.lisp
	* src/compiler/x86/subprim.lisp, src/compiler/x86/values.lisp:
	Use fixnumize instead of fixnum.
1 ;;; -*- Package: RT -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/rt/nlx.lisp,v 1.6 2003/08/03 11:27:47 gerd Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/rt/nlx.lisp,v 1.6 2003/08/03 11:27:47 gerd Rel $
13 ;;;
14 ;;; This file contains the definitions of VOPs used for non-local exit (throw,
15 ;;; lexical exit, etc.)
16 ;;;
17 ;;; Written by Rob MacLachlan
18 ;;; Converted to IBM RT by William Lott and Bill Chiles.
19 ;;;
20
21 (in-package "RT")
22
23
24 ;;; MAKE-NLX-SP-TN -- Interface.
25 ;;;
26 ;;; Make an environment-live stack TN for saving the SP for NLX entry.
27 ;;;
28 (def-vm-support-routine make-nlx-sp-tn (env)
29 (environment-live-tn
30 (make-representation-tn *word-pointer-type*
31 (sc-number-or-lose 'word-pointer-reg *backend*))
32 env))
33
34
35
36 ;;; Save and restore dynamic environment.
37 ;;;
38 ;;; These VOPs are used in the reentered function to restore the appropriate
39 ;;; dynamic environment. Currently we only save the Current-Catch and binding
40 ;;; stack pointer. We don't need to save/restore the current unwind-protect,
41 ;;; since unwind-protects are implicitly processed during unwinding. If there
42 ;;; were any additional stacks, then this would be the place to restore the top
43 ;;; pointers.
44
45
46 ;;; MAKE-DYNAMIC-STATE-TNS -- Interface.
47 ;;;
48 ;;; Return a list of TNs that can be used to snapshot the dynamic state for use
49 ;;; with the Save/Restore-Dynamic-Environment VOPs.
50 ;;;
51 (def-vm-support-routine make-dynamic-state-tns ()
52 (make-n-tns 4 *fixnum-primitive-type*))
53
54 (define-vop (save-dynamic-state)
55 (:results (catch :scs (any-reg))
56 (nfp :scs (any-reg))
57 (nsp :scs (any-reg))
58 (eval :scs (any-reg)))
59 (:vop-var vop)
60 (:generator 13
61 (load-symbol-value catch lisp::*current-catch-block*)
62 (let ((cur-nfp (current-nfp-tn vop)))
63 (if cur-nfp
64 (move nfp cur-nfp)
65 (inst li nfp 0)))
66 (move nsp nsp-tn)
67 (load-symbol-value eval lisp::*eval-stack-top*)))
68
69 (define-vop (restore-dynamic-state)
70 (:args (catch :scs (any-reg))
71 (nfp :scs (any-reg))
72 (nsp :scs (any-reg))
73 (eval :scs (any-reg)))
74 (:temporary (:scs (descriptor-reg) :from (:eval 0)) symbol value)
75 (:temporary (:scs (word-pointer-reg) :from (:eval 0)) bsp)
76 (:vop-var vop)
77 (:generator 10
78 (store-symbol-value catch lisp::*current-catch-block*)
79 (store-symbol-value eval lisp::*eval-stack-top*)
80 (let ((cur-nfp (current-nfp-tn vop)))
81 (when cur-nfp
82 (move cur-nfp nfp)))
83 (move nsp-tn nsp)))
84
85 (define-vop (current-stack-pointer)
86 (:results (res :scs (any-reg word-pointer-reg descriptor-reg)))
87 (:generator 1
88 (move res csp-tn)))
89
90 (define-vop (current-binding-pointer)
91 (:results (res :scs (any-reg word-pointer-reg descriptor-reg)))
92 (:generator 1
93 (load-symbol-value res *binding-stack-pointer*)))
94
95
96
97 ;;;; Unwind block hackery:
98
99 ;;; MAKE-UNWIND-BLOCK -- VOP.
100 ;;;
101 ;;; Compute the address of the catch block from its TN, then store into the
102 ;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
103 ;;;
104 (define-vop (make-unwind-block)
105 (:args (tn))
106 (:info entry-label)
107 (:results (block :scs (word-pointer-reg)))
108 (:temporary (:scs (word-pointer-reg) :target block) block-ptr)
109 (:temporary (:scs (descriptor-reg)) temp)
110 (:generator 22
111 (inst cal block-ptr cfp-tn (* (tn-offset tn) vm:word-bytes))
112 (load-symbol-value temp lisp::*current-unwind-protect-block*)
113 (storew temp block-ptr vm:unwind-block-current-uwp-slot)
114 (storew cfp-tn block-ptr vm:unwind-block-current-cont-slot)
115 (storew code-tn block-ptr vm:unwind-block-current-code-slot)
116 (inst compute-lra-from-code temp code-tn entry-label)
117 (storew temp block-ptr vm:catch-block-entry-pc-slot)
118 (move block block-ptr)))
119
120
121 ;;; MAKE-CATCH-BLOCK -- VOP.
122 ;;;
123 ;;; Like MAKE-UNWIND-BLOCK, except that we also store in the specified tag, and
124 ;;; link the block into the Current-Catch list.
125 ;;;
126 (define-vop (make-catch-block)
127 (:args (tn)
128 (tag :scs (descriptor-reg)))
129 (:info entry-label)
130 (:results (block :scs (word-pointer-reg)))
131 (:temporary (:scs (descriptor-reg)) temp)
132 (:temporary (:scs (word-pointer-reg) :target block :to (:result 0)) result)
133 (:generator 44
134 (inst cal result cfp-tn (* (tn-offset tn) vm:word-bytes))
135 (load-symbol-value temp lisp::*current-unwind-protect-block*)
136 (storew temp result vm:catch-block-current-uwp-slot)
137 (storew cfp-tn result vm:catch-block-current-cont-slot)
138 (storew code-tn result vm:catch-block-current-code-slot)
139 (inst compute-lra-from-code temp code-tn entry-label)
140 (storew temp result vm:catch-block-entry-pc-slot)
141
142 (storew tag result vm:catch-block-tag-slot)
143 (load-symbol-value temp lisp::*current-catch-block*)
144 (storew temp result vm:catch-block-previous-catch-slot)
145 (store-symbol-value result lisp::*current-catch-block*)
146
147 (move block result)))
148
149
150 ;;; SET-UNWIND-PROTECT -- VOP.
151 ;;;
152 ;;; Just set the current unwind-protect to TN's address. This instantiates an
153 ;;; unwind block as an unwind-protect.
154 ;;;
155 (define-vop (set-unwind-protect)
156 (:args (tn))
157 (:temporary (:scs (descriptor-reg)) new-uwp)
158 (:generator 7
159 (inst cal new-uwp cfp-tn (* (tn-offset tn) vm:word-bytes))
160 (store-symbol-value new-uwp lisp::*current-unwind-protect-block*)))
161
162 ;;; UNLINK-CATCH-BLOCK -- VOP.
163 ;;;
164 ;;; Remove the catch block from the chain of catches. This happens when
165 ;;; we drop out of a catch instead of throwing.
166 ;;;
167 (define-vop (unlink-catch-block)
168 (:temporary (:scs (word-pointer-reg)) block)
169 (:policy :fast-safe)
170 (:translate %catch-breakup)
171 (:generator 17
172 (load-symbol-value block lisp::*current-catch-block*)
173 (loadw block block vm:catch-block-previous-catch-slot)
174 (store-symbol-value block lisp::*current-catch-block*)))
175
176 ;;; UNLINK-UNWIND-PROTECT -- VOP.
177 ;;;
178 ;;; Same thing with unwind protects.
179 ;;;
180 (define-vop (unlink-unwind-protect)
181 (:temporary (:scs (word-pointer-reg)) block)
182 (:policy :fast-safe)
183 (:translate %unwind-protect-breakup)
184 (:generator 17
185 (load-symbol-value block lisp::*current-unwind-protect-block*)
186 (loadw block block vm:unwind-block-current-uwp-slot)
187 (store-symbol-value block lisp::*current-unwind-protect-block*)))
188
189
190 ;;;; NLX entry VOPs:
191
192
193 ;;; NLX-ENTRY -- VOP.
194 ;;;
195 ;;; We were just thrown to, so load up the results.
196 ;;;
197 (define-vop (nlx-entry)
198 (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
199 ; would be inserted before the LRA.
200 (start)
201 (count))
202 (:results (values :more t))
203 (:temporary (:scs (descriptor-reg)) move-temp)
204 (:info label nvals)
205 (:save-p :force-to-stack)
206 (:generator 30
207 (emit-return-pc label)
208 (cond ((zerop nvals))
209 ((= nvals 1)
210 (let ((no-values (gen-label)))
211 (inst c count 0)
212 (inst bcx :eq no-values)
213 (move (tn-ref-tn values) null-tn)
214 (loadw (tn-ref-tn values) start)
215 (emit-label no-values)))
216 (t
217 (collect ((defaults))
218 (inst c count 0)
219 (do ((i 0 (1+ i))
220 (tn-ref values (tn-ref-across tn-ref)))
221 ((null tn-ref))
222 (let ((default-lab (gen-label))
223 (tn (tn-ref-tn tn-ref)))
224 (defaults (cons default-lab tn))
225
226 (inst bc :eq default-lab)
227 (inst s count (fixnumize 1))
228 (sc-case tn
229 ((descriptor-reg any-reg)
230 (loadw tn start i))
231 (control-stack
232 (loadw move-temp start i)
233 (store-stack-tn move-temp tn)))))
234
235 (let ((defaulting-done (gen-label)))
236 (emit-label defaulting-done)
237 (assemble (*elsewhere*)
238 (dolist (def (defaults))
239 (emit-label (car def))
240 (let ((tn (cdr def)))
241 (sc-case tn
242 ((descriptor-reg any-reg)
243 (move tn null-tn))
244 (control-stack
245 (store-stack-tn null-tn tn)))))
246 (inst b defaulting-done))))))
247 (load-stack-tn csp-tn sp)))
248
249
250 (define-vop (nlx-entry-multiple)
251 ;; Again, no SC restrictions for the args, 'cause the loading would
252 ;; happen before the entry label. But we know that start and count will
253 ;; be in registers due to the way this vop is used.
254 (:args (top :target dst)
255 (start :target src)
256 (count :target num))
257 (:info label)
258 (:temporary (:scs (any-reg) :from (:argument 0)) dst)
259 (:temporary (:scs (any-reg) :from (:argument 1)) src)
260 (:temporary (:scs (any-reg) :from (:argument 2)) num)
261 (:temporary (:scs (descriptor-reg)) temp)
262 (:results (new-start) (new-count))
263 (:save-p :force-to-stack)
264 (:generator 30
265 (emit-return-pc label)
266 (let ((loop (gen-label))
267 (done (gen-label)))
268
269 ;; Copy args.
270 (load-stack-tn dst top)
271 (move src start)
272 (inst a num count 0)
273
274 ;; Establish results.
275 (sc-case new-start
276 ((any-reg word-pointer-reg) (move new-start dst))
277 (control-stack (store-stack-tn dst new-start)))
278 (inst bcx :eq done)
279 (sc-case new-count
280 (any-reg (inst move new-count num))
281 (control-stack (store-stack-tn num new-count)))
282
283 ;; Copy stuff on stack.
284 (emit-label loop)
285 (loadw temp src)
286 (inst inc src vm:word-bytes)
287 (storew temp dst)
288 (inst s num num (fixnumize 1))
289 (inst bncx :eq loop)
290 (inst inc dst vm:word-bytes)
291
292 (emit-label done)
293 (move csp-tn dst))))
294
295
296 ;;; This VOP is just to force the TNs used in the cleanup onto the stack.
297 ;;;
298 (define-vop (uwp-entry)
299 (:info label)
300 (:save-p :force-to-stack)
301 (:results (block) (start) (count))
302 (:ignore block start count)
303 (:generator 0
304 (emit-return-pc label)))

  ViewVC Help
Powered by ViewVC 1.1.5