Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | \ ========== Copyright Header Begin ========================================== |
2 | \ | |
3 | \ Hypervisor Software File: catchexc.fth | |
4 | \ | |
5 | \ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved. | |
6 | \ | |
7 | \ - Do no alter or remove copyright notices | |
8 | \ | |
9 | \ - Redistribution and use of this software in source and binary forms, with | |
10 | \ or without modification, are permitted provided that the following | |
11 | \ conditions are met: | |
12 | \ | |
13 | \ - Redistribution of source code must retain the above copyright notice, | |
14 | \ this list of conditions and the following disclaimer. | |
15 | \ | |
16 | \ - Redistribution in binary form must reproduce the above copyright notice, | |
17 | \ this list of conditions and the following disclaimer in the | |
18 | \ documentation and/or other materials provided with the distribution. | |
19 | \ | |
20 | \ Neither the name of Sun Microsystems, Inc. or the names of contributors | |
21 | \ may be used to endorse or promote products derived from this software | |
22 | \ without specific prior written permission. | |
23 | \ | |
24 | \ This software is provided "AS IS," without a warranty of any kind. | |
25 | \ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES, | |
26 | \ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A | |
27 | \ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN | |
28 | \ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR | |
29 | \ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR | |
30 | \ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN | |
31 | \ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR | |
32 | \ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE | |
33 | \ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY, | |
34 | \ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF | |
35 | \ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. | |
36 | \ | |
37 | \ You acknowledge that this software is not designed, licensed or | |
38 | \ intended for use in the design, construction, operation or maintenance of | |
39 | \ any nuclear facility. | |
40 | \ | |
41 | \ ========== Copyright Header End ============================================ | |
42 | id: @(#)catchexc.fth 1.7 07/06/05 | |
43 | purpose: | |
44 | copyright: Copyright 2007 Sun Microsystems, Inc. All Rights Reserved. | |
45 | copyright: Use is subject to license terms. | |
46 | ||
47 | headers | |
48 | ||
49 | \ TODO | |
50 | \ The allocation of the cpu structs really should be on a page boundary | |
51 | \ | |
52 | ||
53 | transient | |
54 | 0 value save-fstate | |
55 | resident | |
56 | ||
57 | chain: enterforth-chain | |
58 | \ put stuff to do on entry in this chain. | |
59 | ; | |
60 | defer enterforth-hook ' enterforth-chain is enterforth-hook | |
61 | ||
62 | : enterforth ( -- ) | |
63 | ||
64 | enterforth-hook | |
65 | ||
66 | init-cpu-state | |
67 | ||
68 | \ Clear any pending L15 Interrupts | |
69 | last-trap# h# 4f = if 1 h# 0f lshift clear-softint! then | |
70 | ||
71 | ?secure handle-breakpoint | |
72 | ; | |
73 | ||
74 | code slave-bp-loop ( -- ) | |
75 | scr rdpstate \ We should not be spinning in | |
76 | #sync membar \ this loop with IE = 0 | |
77 | scr 2 scr or \ set IE = 1 | |
78 | scr 0 wrpstate | |
79 | #sync membar | |
80 | up sc1 sc2 get-cpu-struct | |
81 | 0 >cpu-status sc1 set | |
82 | CPU-PARKED scr move | |
83 | scr sc2 sc1 stx \ Mark as Parked | |
84 | ||
85 | \ Wait here until we are restarted OR the master CPU advances us | |
86 | \ into the wait for lockfree phase | |
87 | begin | |
88 | h# 12 %o5 move \ cpu_yield, FN # 0x12 | |
89 | %g0 fast-trap# always htrapif \ Trap into HV and stay there | |
90 | nop \ until interrupted | |
91 | again nop \ Loop forever while in slave bp loop | |
92 | c; | |
93 | ||
94 | \itc : slave-bp-loop slave-bp-loop ; | |
95 | ||
96 | label save-state | |
97 | %g0 h# 38 %g4 add | |
98 | %g4 %g0 h# 20 %g5 ldxa \ CPU struct PA | |
99 | %g0 memory-asi wrasi | |
100 | ||
101 | %g7 rdtt %g7 %g5 save-reg last-trap# | |
102 | %g5 %g1 load-reg error-reset-trap | |
103 | %g1 0 cmp | |
104 | <> if | |
105 | nop | |
106 | \ Last trap is one of reset | |
107 | \ non-zero Indicates Error Reset | |
108 | %g1 %g5 save-reg last-trap# | |
109 | %g0 1 %g1 sub | |
110 | %g1 %g5 save-reg error-reset-trap | |
111 | then | |
112 | ||
113 | %g5 %g1 load-reg %state-valid | |
114 | %g1 %g0 cmp | |
115 | %g1 1 %g1 sub | |
116 | 0= if | |
117 | %g1 %g5 save-reg %state-valid | |
118 | ||
119 | %g0 1 %g6 add \ Full state save | |
120 | %g5 %g4 move \ CPU struct in %g4 | |
121 | save-cpu-state always brif | |
122 | %g7 rdpc | |
123 | ||
124 | \ Cannot rely upon %g's across save-cpu-state!! | |
125 | %g0 h# 38 %g4 add | |
126 | %g4 %g0 h# 20 %g4 ldxa \ CPU struct PA | |
127 | %g0 memory-asi wrasi | |
128 | ||
129 | 0 >stack-fence? %g1 set | |
130 | %g0 %g4 %g1 memory-asi stxa \ Stack Fence Off | |
131 | ||
132 | \ %o's are saved, it is now safe to make hcalls | |
133 | \ if the size is 0 we skip the tsb save | |
134 | \ Preserve the TSB Areas, and disable TSBs | |
135 | 0 >cpu-tsb-ctrl-area %g7 set | |
136 | %g4 %g7 %g7 add \ TSB ctrl base | |
137 | %g7 0 >tsb-allocation %o0 read-reg \ sizeof tsb ctx0 area | |
138 | %o0 %g0 %g0 subcc | |
139 | 0<> if | |
140 | %g7 0 >tsb-buffer-addr %o1 read-reg \ TSB CTX0 - RA | |
141 | %g0 h# 29 %o5 add \ MMU_TSB_CTX0INFO | |
142 | %g0 h# 80 always htrapif | |
143 | %o0 %g0 %g0 subcc | |
144 | 0= if | |
145 | %g0 %g7 0 >tsb-saved-size write-reg \ 0 as size (delay) | |
146 | %o1 %g7 0 >tsb-saved-size write-reg \ Save actual size | |
147 | %g0 %o1 move \ %o0 is already 0... | |
148 | %g0 h# 20 %o5 add \ MMU_TSB_CTX0 | |
149 | %g0 h# 80 always htrapif | |
150 | then | |
151 | then | |
152 | %g7 /tsb-data >tsb-allocation %o0 read-reg \ sizeof tsb ctxX area | |
153 | %o0 %g0 %g0 subcc | |
154 | 0<> if | |
155 | %g7 /tsb-data >tsb-buffer-addr %o1 read-reg \ TSB CTXNON0 - RA | |
156 | %g0 h# 2a %o5 add \ MMU_TSB_CTXNON0INFO | |
157 | %g0 h# 80 always htrapif | |
158 | %o0 %g0 %g0 subcc | |
159 | 0= if | |
160 | %g0 %g7 /tsb-data >tsb-saved-size write-reg \ 0 as size (delay) | |
161 | %o1 %g7 /tsb-data >tsb-saved-size write-reg \ Save actual size | |
162 | %g0 %o1 move \ %o0 is already 0... | |
163 | %g0 h# 21 %o5 add \ MMU_TSB_CTXNON0 | |
164 | %g0 h# 80 always htrapif | |
165 | then | |
166 | then | |
167 | else nop | |
168 | %g0 0 wrtl | |
169 | %g0 0 wrgl | |
170 | then | |
171 | ||
172 | trap-table %g4 set | |
173 | %g4 0 wrtba | |
174 | ||
175 | \ OK we go virtual from here on | |
176 | ||
177 | prom-main-task up set | |
178 | rombase base set | |
179 | up %g4 %g1 get-cpu-struct | |
180 | ||
181 | %g1 offset-of last-trap# scr ldx | |
182 | scr h# 17f %g0 subcc \ Breakpoint! | |
183 | 0= if nop | |
184 | \ turn off watchdog | |
185 | %g0 0 %o0 add \ timeout value | |
186 | %g0 h# 5 %o5 add \ func # (WD) | |
187 | %g0 h# 80 always htrapif | |
188 | then | |
189 | ||
190 | \ %g1 = cpu-state | |
191 | \ up = User area pointer | |
192 | \ base = Origin | |
193 | \ Save address of this location for later | |
194 | here to save-fstate | |
195 | ||
196 | \ Setup the SP and RP here | |
197 | \ we install a fence on the existing sp, rp IF: | |
198 | \ 1. The PC is inside the PROM | |
199 | \ 2. Primary Context is 0 | |
200 | \ 3. We have not hit a breakpoint. | |
201 | \ 4. This is the first time we have done this. | |
202 | \ | |
203 | %g1 offset-of %state-valid sc5 ldx \ Per CPU state-valid Lock | |
204 | %g1 offset-of %pcontext scr ldx \ get primary context | |
205 | scr %g0 %g0 subcc | |
206 | 0= if | |
207 | %g1 offset-of last-trap# scr ldx | |
208 | scr h# 17f %g0 subcc \ Breakpoint! | |
209 | 0<> if nop | |
210 | %g1 offset-of %pc scr ldx \ get PC | |
211 | scr d# 28 scr srax | |
212 | scr h# f %g0 subcc \ inside OBP space? | |
213 | 0= if | |
214 | sc5 -1 cmp \ State Valid = -1? | |
215 | 0= if nop | |
216 | 0 >stack-fence? scr set | |
217 | %g0 1 sc3 sub | |
218 | sc3 %g1 scr stx \ mark fence as active | |
219 | then | |
220 | then | |
221 | then | |
222 | then | |
223 | ||
224 | 0 >stack-fence? scr set | |
225 | %g1 scr scr ldx | |
226 | scr -1 cmp | |
227 | 0= if nop | |
228 | 0 >return-stack h# 40 /n* + scr set | |
229 | %g1 scr rp add \ END of RS | |
230 | 0 >cpu-rp0-fence scr set | |
231 | rp %g1 scr stx \ Mark rs stackbase | |
232 | 0 >data-stack h# 40 /n* + scr set | |
233 | %g1 scr sp add \ END of SP | |
234 | 0 >cpu-sp0-fence scr set | |
235 | sp %g1 scr stx \ Mark ds stackbase | |
236 | else nop | |
237 | %g1 rp get-rp0 | |
238 | %g1 sp get-sp0 | |
239 | then | |
240 | ||
241 | \ Check State Valid again | |
242 | sc5 -1 cmp | |
243 | 0= if | |
244 | nop | |
245 | ||
246 | 'user my-self scr nget | |
247 | scr %g1 offset-of %saved-my-self stx | |
248 | ||
249 | \ User Area (we only need to save the first few locations) | |
250 | 0 >user-save scr set | |
251 | %g1 scr scr add \ Address of save area | |
252 | up sc1 move \ Bottom of user area | |
253 | ua-size sc2 move \ Size of user area | |
254 | begin | |
255 | sc2 /n sc2 subcc | |
256 | sc1 sc2 sc3 ldx | |
257 | 0= until | |
258 | sc3 scr sc2 stx \ Delay slot | |
259 | ||
260 | then | |
261 | ||
262 | \ Account for the presence of the top of stack register | |
263 | sp /n sp add | |
264 | ||
265 | \dtc 'acf enterforth scr set | |
266 | \itc 'body enterforth scr set | |
267 | sc4 get-mid | |
268 | sc1 sc2 sc3 mutex-try-enter prom-lock | |
269 | sc1 -1 cmp | |
270 | 0<> if | |
271 | sc4 sc1 cmp | |
272 | 0<> if nop | |
273 | ||
274 | \ Initialize the Interpreter Pointer | |
275 | \dtc 'acf slave-bp-loop scr set | |
276 | \itc 'body slave-bp-loop scr set | |
277 | then | |
278 | then | |
279 | scr base ip add | |
280 | ||
281 | %g0 h# 0f wrpil \ PIL=15 | |
282 | ||
283 | \ We don't want to enable interrupts on CPUs that are in the middle | |
284 | \ of taking an error reset until later when we have idled all the | |
285 | \ other CPUs via cross calls. | |
286 | %g1 offset-of error-reset-trap scr ldx | |
287 | scr -1 cmp | |
288 | = if nop | |
289 | %g0 h# 14 wrpstate \ PEF=1, PRIV=1 | |
290 | else nop | |
291 | %g0 h# 16 wrpstate \ PEF=1, PRIV=1, IE=1 | |
292 | then | |
293 | ||
294 | \ Initialize the Window Registers & Stack Pointer | |
295 | ||
296 | sp %g7 move \ Save sp and rp so we don't lose them | |
297 | rp %g6 move | |
298 | ip %g5 move | |
299 | ||
300 | %g0 7 wrcleanwin | |
301 | %g0 0 wrotherwin | |
302 | %g0 0 wrwstate | |
303 | %g0 0 wrcanrestore | |
304 | %g0 6 wrcansave | |
305 | %g0 0 wrcwp | |
306 | ||
307 | %g1 window-registers %g4 add | |
308 | %g4 6 /n* %o6 ldx | |
309 | %o6 1 %g0 andcc | |
310 | 0= if nop | |
311 | %o6 /entry-frame %o6 save | |
312 | %o6 V9_SP_BIAS %o6 sub | |
313 | then | |
314 | ||
315 | %g7 sp move \ Restore sp and rp | |
316 | %g6 rp move | |
317 | %g5 ip move | |
318 | \itc next | |
319 | \dtc ip %g0 %g0 jmpl nop | |
320 | end-code | |
321 | ||
322 | \ | |
323 | \ XXX this really belongs in savecpu.fth, to match the small startup | |
324 | \ FWD refs prevent that working though. | |
325 | \ | |
326 | \ %gl = 2 | |
327 | \ %g1 is the structure offset | |
328 | label small-forth-save-state | |
329 | \ OK, we have to switch to the original fault-tl and tpc, tnpc | |
330 | \ we got here from the restore which does a retry at tl=1 having | |
331 | \ setup the tpc, tnpc to 'return', everything else should be restored | |
332 | %g0 2 wrtl | |
333 | %g0 h# 38 %g2 add | |
334 | %g2 %g0 h# 20 %g5 ldxa \ CPU struct PA | |
335 | %g5 %g1 %g5 add \ CPU save area | |
336 | %g7 rdasi | |
337 | %g0 memory-asi wrasi | |
338 | %g5 %g1 load-reg %tpc-1 | |
339 | %g5 %g2 load-reg %tnpc-1 | |
340 | %g5 %g3 load-reg %tl-c | |
341 | %g0 1 wrtl | |
342 | %g0 %g1 wrtpc | |
343 | %g0 %g2 wrtnpc | |
344 | %g0 %g7 wrasi | |
345 | save-state always brif | |
346 | %g0 %g3 wrtl | |
347 | end-code | |
348 | ||
349 | label slave-save-state | |
350 | \ Set the base register | |
351 | base rdpc | |
352 | here 4 - origin - %g4 set | |
353 | base %g4 base sub | |
354 | ||
355 | save-state origin- %g1 set | |
356 | %g2 %g1 %g0 jmpl nop | |
357 | end-code | |
358 | ||
359 | ||
360 | label save-RED-state | |
361 | %g0 0 wrtl | |
362 | %g0 0 wrgl | |
363 | prom-main-task %g4 up setx \ Set User Area Pointer | |
364 | ||
365 | \ Set the base register | |
366 | base rdpc | |
367 | here 4 - origin - %g4 set | |
368 | base %g4 base sub | |
369 | ||
370 | up %g4 %g1 get-cpu-struct | |
371 | ||
372 | \ %g1 = Base of cpu-state array | |
373 | \ %g2 = origin (base) | |
374 | \ %g3 = User Pointer (up) | |
375 | \ AG=0, MG=0, VG=0 | |
376 | \ TL=0 | |
377 | ||
378 | %g4 1 %g4 sub | |
379 | %g4 %g1 offset-of %state-valid stx | |
380 | %g0 2 %g4 add | |
381 | %g4 %g1 offset-of error-reset-trap stx | |
382 | ||
383 | 'user my-self %g4 nget | |
384 | %g4 %g1 offset-of %saved-my-self stx | |
385 | ||
386 | \ Continue with save-state | |
387 | save-fstate always brif nop | |
388 | end-code | |
389 | ||
390 | label (crestart) | |
391 | up %g2 %g7 get-cpu-struct | |
392 | CPU-STARTED %g1 %g6 %g7 mark-cpu-state | |
393 | ||
394 | \ After this point we are PHYSICAL access | |
395 | \ PSTATE.IE = 0, Tl=2, GL=2 | |
396 | %g0 2 wrtl | |
397 | %g0 2 wrgl | |
398 | %g0 memory-asi wrasi | |
399 | %g4 rdpstate | |
400 | %g4 2 %g4 andn | |
401 | %g4 0 wrpstate | |
402 | ||
403 | %g0 h# 38 %g4 add | |
404 | %g4 %g0 h# 20 %g5 ldxa \ CPU struct PA | |
405 | ||
406 | %g0 1 %g1 sub | |
407 | %g0 %g5 save-reg last-trap# | |
408 | %g0 %g5 save-reg %state-valid | |
409 | %g1 %g5 save-reg %restartable? | |
410 | ||
411 | \ restore the TSB areas | |
412 | 0 >cpu-tsb-ctrl-area %g1 set | |
413 | %g5 %g1 %g1 add \ control block | |
414 | %g1 0 >tsb-saved-size %o0 read-reg \ sizeof tsb ctx0 area | |
415 | %o0 %g0 %g0 subcc | |
416 | 0<> if | |
417 | %g1 0 >tsb-buffer-addr %o1 read-reg \ TSB CTX0 - RA | |
418 | %g0 h# 20 %o5 add \ MMU_TSB_CTX0 | |
419 | %g0 h# 80 always htrapif | |
420 | then | |
421 | %g1 /tsb-data >tsb-saved-size %o0 read-reg | |
422 | %o0 %g0 %g0 subcc | |
423 | 0<> if | |
424 | %g1 /tsb-data >tsb-buffer-addr %o1 read-reg \ TSB CTXNON0 - RA | |
425 | %g0 h# 21 %o5 add \ MMU_TSB_CTXNON0 | |
426 | %g0 h# 80 always htrapif | |
427 | then | |
428 | ||
429 | \ restore dev mondo queue | |
430 | 0 >cpu-devmondo-ptr %g1 set | |
431 | %g5 %g1 %g1 add \ target PA | |
432 | %g1 0 %g4 read-reg \ get saved value | |
433 | %g4 %g0 %g0 subcc | |
434 | 0< if | |
435 | %g4 1 %g4 sllx \ (delay) | |
436 | %g4 1 %g4 srlx \ restore | |
437 | %g0 h# 25 wrasi | |
438 | %g4 %g0 h# 3d0 %asi stxa \ restore original idx | |
439 | %g0 %g1 0 write-reg \ mark as done | |
440 | then | |
441 | ||
442 | restore-cpu-state always brif | |
443 | %g0 0 %g4 add \ retry! | |
444 | end-code | |
445 | ||
446 | code (crestart ( -- ) | |
447 | up sc2 sc1 get-cpu-struct | |
448 | scr sc1 sc2 mutex-exit prom-lock | |
449 | (crestart) call nop | |
450 | c; | |
451 | ||
452 | code wait-for-lock-free ( -- ) | |
453 | up sc1 sc4 get-cpu-struct | |
454 | CPU-WAIT-RESTART scr sc1 sc4 mark-cpu-state | |
455 | scr sc1 sc2 sc3 mutex-enter prom-lock | |
456 | CPU-OBP-WARM scr sc1 sc4 mark-cpu-state | |
457 | c; | |
458 | ||
459 | : restart-slave ( -- ) wait-for-lock-free restart ; | |
460 | ||
461 | code (restart-step ( -- ) | |
462 | nop nop | |
463 | (crestart) call | |
464 | nop nop | |
465 | c; | |
466 | ||
467 | ' (restart-step is restart-step | |
468 | ||
469 | headers | |
470 | also hidden definitions | |
471 | vocabulary trap-types | |
472 | : .tt ( n -- ) base @ >r hex <# u# u# u# u#> r> base ! type space ; | |
473 | : trap" ( trap# n -- ) \ name description" | |
474 | create swap w, 1- w, ," | |
475 | does> | |
476 | ??cr dup w@ over wa1+ w@ ( apf tt n ) | |
477 | bounds 2dup - if | |
478 | .tt ." ... " .tt | |
479 | else | |
480 | drop .tt | |
481 | then la1+ ". space | |
482 | ; | |
483 | hex | |
484 | also trap-types definitions | |
485 | 100 80 trap" tt-100 Trap Instruction (Ticc)" | |
486 | e0 20 trap" tt-0e0 Fill Other 0 - 7" | |
487 | c0 20 trap" tt-0c0 Fill Normal 0 - 7" | |
488 | a0 20 trap" tt-0a0 Spill Other 0 - 7" | |
489 | 80 20 trap" tt-080 Spill Normal 0 - 7" | |
490 | 7f 1 trap" tt-07f Non-Resumable Error" | |
491 | 7e 1 trap" tt-07e Resumable Error" | |
492 | 7d 1 trap" tt-07d Device Mondo" | |
493 | 70 1 trap" tt-070 Fast ECC Error" | |
494 | 6c 4 trap" tt-06c Fast Data Access Protection" | |
495 | 68 4 trap" tt-068 Fast Data Access MMU Miss" | |
496 | 64 4 trap" tt-064 Fast Instruction Access MMU Miss" | |
497 | 63 1 trap" tt-063 Corrected ECC Error" | |
498 | 62 1 trap" tt-062 VA Watchpoint" | |
499 | 61 1 trap" tt-061 PA Watchpoint" | |
500 | 60 1 trap" tt-060 Interrupt Vector" | |
501 | 41 f trap" tt-041 Interrupt Level 1 - 15" | |
502 | 37 1 trap" tt-037 Privileged Action" | |
503 | 36 1 trap" tt-036 STDF Memory Address not Aligned" | |
504 | 35 1 trap" tt-035 LDDF Memory Address not Aligned" | |
505 | 34 1 trap" tt-034 Memory Address not Aligned" | |
506 | 32 1 trap" tt-032 Data Access Error" | |
507 | 31 1 trap" tt-031 TSB Data Miss" | |
508 | 30 1 trap" tt-030 Data Access Exception" | |
509 | 28 1 trap" tt-028 Division by Zero" | |
510 | 24 4 trap" tt-024 Clean Window" | |
511 | 23 1 trap" tt-023 TAG Overflow" | |
512 | 22 1 trap" tt-022 FP Exception Other" | |
513 | 21 1 trap" tt-021 FP Exception IEEE 754" | |
514 | 20 1 trap" tt-020 FP Disabled" | |
515 | 11 1 trap" tt-011 Privileged Opcode" | |
516 | 10 1 trap" tt-010 Illegal Instruction" | |
517 | a 1 trap" tt-00a Instruction Access Error" | |
518 | 9 1 trap" tt-009 TSB Instruction MISS" | |
519 | 8 1 trap" tt-008 Instruction Access Exception" | |
520 | 5 1 trap" tt-005 RED State Exception" | |
521 | 4 1 trap" tt-004 Software Initiated Reset" | |
522 | 3 1 trap" tt-003 Externally Initiated Reset" | |
523 | 2 1 trap" tt-002 Watchdog Reset" | |
524 | 1 1 trap" tt-001 Power On Reset" | |
525 | ||
526 | previous previous definitions | |
527 | ||
528 | : .traps ( -- ) | |
529 | [ also hidden ] 0 ['] trap-types [ previous ] | |
530 | begin another-word? while ( alf' voc-acf anf ) | |
531 | name> execute exit? if 2drop exit then | |
532 | repeat | |
533 | ; | |
534 | ||
535 | : (last-trap) ( -- ?? fmt$ ) | |
536 | last-trap# dup h# 100 < if ( tt ) | |
537 | dup h# 41 h# 4f between if ( tt ) | |
538 | h# 40 - " Level %d Interrupt" ( n fmt$ ) | |
539 | exit ( ) | |
540 | then ( tt ) | |
541 | dup h# 80 >= if ( tt ) | |
542 | dup h# 9f <= if ( tt ) | |
543 | h# 80 - 2 >> " Spill %d Normal" ( n fmt$ ) | |
544 | exit ( ) | |
545 | then ( tt ) | |
546 | dup h# bf <= if ( tt ) | |
547 | h# a0 - 2 >> " Spill %d Other" ( n fmt$ ) | |
548 | exit ( ) | |
549 | then ( tt ) | |
550 | dup h# 0df <= if ( tt ) | |
551 | h# c0 - 2 >> " Fill %d Normal" ( n fmt$ ) | |
552 | exit | |
553 | then ( tt ) | |
554 | dup h# ff <= if ( tt ) | |
555 | h# e0 - 2 >> " Fill %d Other" ( n fmt$ ) | |
556 | exit ( ) | |
557 | then ( tt ) | |
558 | then ( tt ) | |
559 | >r 0 ( alf ) ( r: tt ) | |
560 | [ also hidden ] ['] trap-types [ previous ] ( alf vacf ) ( r: tt ) | |
561 | begin another-word? while ( alf' vacf anf ) ( r: tt ) | |
562 | name> >body dup w@ r@ = if ( alf' vacf apf ) ( r: tt ) | |
563 | nip nip ( apf ) | |
564 | la1+ count " %s" r> drop exit ( str$ fmt$ ) | |
565 | else ( alf' vacf apf ) ( r: tt ) | |
566 | drop ( alf' vacf ) ( r: tt ) | |
567 | then ( alf' vacf ) ( r: tt ) | |
568 | repeat r> drop ( ) | |
569 | " " ( null$ ) | |
570 | else ( tt ) | |
571 | h# 100 - " Trap %x" ( n fmt$ ) | |
572 | then ( ) | |
573 | ; | |
574 | ||
575 | : .last-trap ( -- ) | |
576 | (last-trap) ?dup if | |
577 | last-trap# h# 7f = if | |
578 | cmn-fatal[ " Last Trap: " cmn-append ]cmn-end | |
579 | .nonresumable-errinfo | |
580 | .trap-registers | |
581 | .registers | |
582 | else | |
583 | cmn-error[ " Last Trap: " cmn-append ]cmn-end | |
584 | then | |
585 | else | |
586 | drop | |
587 | then | |
588 | ; | |
589 | ||
590 | headerless | |
591 | ||
592 | : (do-last-trap) | |
593 | last-trap# 0= last-trap# h# 60 = or if exit then | |
594 | ||
595 | obp-control-relinquished? if | |
596 | [ also cmn-messaging ] | |
597 | current-frame$ @ >r 0 current-frame$ ! | |
598 | .last-trap | |
599 | r> current-frame$ ! | |
600 | [ previous ] | |
601 | else | |
602 | .last-trap | |
603 | state-valid off | |
604 | ||
605 | \ -256 throw \ Do not un-comment this throw. | |
606 | \ | |
607 | \ (Comment derived from sun4u/catchexc.fth) | |
608 | \ The above throw is meant to be caught by some outer intelligent catch | |
609 | \ that knows how to handle the -256 error code. There is no such catch, | |
610 | \ and even if there were, this throw would first be intercepted by one of | |
611 | \ the MANY badly behaving catches in the source tree, who then drive | |
612 | \ on without first examining the error code. | |
613 | \ | |
614 | \ Instead, fall through to caller (breakpoint-message), which falls into | |
615 | \ quit and takes us back to the ok prompt. | |
616 | \ | |
617 | \ The below code flushes the common messaging buffer, so we don't lose any | |
618 | \ pending error messages before we get to the ok prompt. | |
619 | ||
620 | flush-cmn-messages | |
621 | ||
622 | then | |
623 | ; | |
624 | ||
625 | ' false is breakpoint-trap? | |
626 | ' (do-last-trap) is .exception | |
627 | ||
628 | stand-init: Install .exception and enable errors | |
629 | ['] (do-last-trap) is .exception | |
630 | enable-cpu-errors | |
631 | ; | |
632 | headers | |
633 |