/[cmucl]/src/code/interr.lisp
ViewVC logotype

Contents of /src/code/interr.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.40 - (hide annotations)
Sun Mar 23 21:23:42 2003 UTC (11 years ago) by gerd
Branch: MAIN
Changes since 1.39: +37 -2 lines
	Optional control stack checking.  This is controlled by the
	feature :stack-checking because it's not implemented for other
	systems/architectures yet.  It is currently known to work on
	FreeBSD 4.8-RC/x86 and Debian 2.2.20/x86.

	* bootfiles/18e/boot3.lisp: New boot file, well, only a
	description of the boot procedure since no boot file is needed.

	* lisp/x86-validate.h (SIGNAL_STACK_START, SIGNAL_STACK_SIZE)
	[__FreeBSD__, __linux__]: New defines.
	(CONTROL_STACK_SIZE) {__FreeBSD__, __linux__]:
	Adjust for signal stack.

	* lisp/validate.c (validate) [RED_ZONE_HIT]: Call
	os_guard_control_stack.  Some cleanup.

	* lisp/os.h (BOTH_ZONES, YELLOW_ZONE, RED_ZONE): New enums.
	Add function prototypes.

	* lisp/interrupt.c (interrupt_install_low_level_handler)
	[RED_ZONE_HIT]: Deliver protection violations on a dedicated
	signal stack.

	* lisp/os-common.c (os_stack_grows_down_1, os_stack_grows_down):
	New functions.
	(guard_zones, control_stack_zone, os_guard_control_stack)
	(os_control_stack_overflow) [RED_ZONE_HIT]: New functions.
	(os_control_stack_overflow) [!RED_ZONE_HIT]: Dummy function.

	* lisp/Linux-os.c (sigsegv_handler) [RED_ZONE_HIT]: Handle control
	stack overflows.

	* lisp/FreeBSD-os.c: General cleansing.
	(sigbus_handler) [RED_ZONE_HIT]: Handle control stack overflows.

	* lisp/FreeBSD-os.h (PROTECTION_VIOLATION_SIGNAL): New define.

	* lisp/Linux-os.h (PROTECTION_VIOLATION_SIGNAL): New define.

	* compiler/x86/system.lisp (lisp::%scrub-control-stack): Change
	defknown from sys:scrub-control-stack.
	(%scrub-control-stack): Rename VOP.

	* code/lispinit.lisp (os-guard-control-stack) [#+stack-checking]:
	Define alien os_guard_control_stack.
	(%scrub-control-stack) [#+x86]: New function.
	(scrub-control-stack) [#+x86]: Call %scrub-control-stack,
	call os-guard-control-stack if #+stack-checking.

	* code/interr.lisp (yellow-zone-hit,
	red-zone-hit) [#+stack-checking]: New functions.

	* code/error.lisp (stack-overflow) [#+stack-checking]: New
	condition.

	* compiler/generic/new-genesis.lisp (finish-symbols)
	[#+stack-checking]: Add symbols for control stack checking.

	* compiler/x86/parms.lisp (static-symbols): Likewise.
1 wlott 1.1 ;;; -*- Log: code.log; Package: KERNEL -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.16 ;;; 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 gerd 1.40 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/interr.lisp,v 1.40 2003/03/23 21:23:42 gerd Exp $")
9 ram 1.16 ;;;
10 wlott 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; Functions and macros to define and deal with internal errors (i.e.
13     ;;; problems that can be signaled from assembler code).
14     ;;;
15     ;;; Written by William Lott.
16     ;;;
17    
18     (in-package "KERNEL")
19    
20 gerd 1.40 (export '(infinite-error-protect find-caller-name *maximum-error-depth*
21     red-zone-hit yellow-zone-hit))
22 wlott 1.1
23    
24    
25     ;;;; Internal Errors
26    
27 wlott 1.24 (defvar *internal-errors*
28     (macrolet ((frob ()
29     (map 'vector #'cdr (c:backend-internal-errors c:*backend*))))
30     (frob)))
31 wlott 1.1
32    
33     (eval-when (compile eval)
34    
35 wlott 1.24 (defmacro deferr (name args &rest body)
36 wlott 1.7 (let* ((rest-pos (position '&rest args))
37     (required (if rest-pos (subseq args 0 rest-pos) args))
38     (fp (gensym))
39     (sigcontext (gensym))
40     (sc-offsets (gensym))
41 wlott 1.24 (temp (gensym))
42     (fn-name (symbolicate name "-HANDLER")))
43     `(progn
44     (defun ,fn-name (name ,fp ,sigcontext ,sc-offsets)
45     (declare (ignorable name ,fp ,sigcontext ,sc-offsets))
46     (macrolet ((set-value (var value)
47     (let ((pos (position var ',required)))
48     (unless pos
49     (error "~S isn't one of the required args."
50     var))
51     `(let ((,',temp ,value))
52     (di::sub-set-debug-var-slot
53     ,',fp (nth ,pos ,',sc-offsets)
54     ,',temp ,',sigcontext)
55     (setf ,var ,',temp)))))
56     (let (,@(let ((offset -1))
57     (mapcar #'(lambda (var)
58     `(,var (di::sub-access-debug-var-slot
59     ,fp
60     (nth ,(incf offset)
61     ,sc-offsets)
62     ,sigcontext)))
63     required))
64     ,@(when rest-pos
65     `((,(nth (1+ rest-pos) args)
66     (mapcar #'(lambda (sc-offset)
67     (di::sub-access-debug-var-slot
68     ,fp
69     sc-offset
70     ,sigcontext))
71     (nthcdr ,rest-pos ,sc-offsets))))))
72     ,@body)))
73     (setf (svref *internal-errors* ,(error-number-or-lose name))
74     #',fn-name))))
75 wlott 1.1
76 wlott 1.7 ) ; Eval-When (Compile Eval)
77 wlott 1.1
78    
79    
80 wlott 1.24 (deferr unknown-error (&rest args)
81 wlott 1.1 (error "Unknown error:~{ ~S~})" args))
82    
83 wlott 1.24 (deferr object-not-function-error (object)
84 wlott 1.15 (error 'type-error
85     :function-name name
86     :datum object
87     :expected-type 'function))
88 wlott 1.1
89 wlott 1.24 (deferr object-not-list-error (object)
90 wlott 1.15 (error 'type-error
91     :function-name name
92     :datum object
93     :expected-type 'list))
94 wlott 1.1
95 wlott 1.24 (deferr object-not-bignum-error (object)
96 wlott 1.15 (error 'type-error
97     :function-name name
98     :datum object
99     :expected-type 'bignum))
100 wlott 1.1
101 wlott 1.24 (deferr object-not-ratio-error (object)
102 wlott 1.15 (error 'type-error
103     :function-name name
104     :datum object
105     :expected-type 'ratio))
106 wlott 1.1
107 wlott 1.24 (deferr object-not-single-float-error (object)
108 wlott 1.15 (error 'type-error
109     :function-name name
110     :datum object
111     :expected-type 'single-float))
112 wlott 1.1
113 wlott 1.24 (deferr object-not-double-float-error (object)
114 wlott 1.15 (error 'type-error
115     :function-name name
116     :datum object
117     :expected-type 'double-float))
118 wlott 1.1
119 dtc 1.33 #+long-float
120     (deferr object-not-long-float-error (object)
121     (error 'type-error
122     :function-name name
123     :datum object
124     :expected-type 'long-float))
125    
126 wlott 1.24 (deferr object-not-simple-string-error (object)
127 wlott 1.15 (error 'type-error
128     :function-name name
129     :datum object
130     :expected-type 'simple-string))
131 wlott 1.1
132 wlott 1.24 (deferr object-not-simple-bit-vector-error (object)
133 wlott 1.15 (error 'type-error
134     :function-name name
135     :datum object
136     :expected-type 'simple-bit-vector))
137 wlott 1.1
138 wlott 1.24 (deferr object-not-simple-vector-error (object)
139 wlott 1.15 (error 'type-error
140     :function-name name
141     :datum object
142     :expected-type 'simple-vector))
143 wlott 1.1
144 wlott 1.24 (deferr object-not-fixnum-error (object)
145 wlott 1.15 (error 'type-error
146     :function-name name
147     :datum object
148     :expected-type 'fixnum))
149 wlott 1.1
150 wlott 1.24 (deferr object-not-function-or-symbol-error (object)
151 wlott 1.15 (error 'type-error
152     :function-name name
153     :datum object
154     :expected-type '(or function symbol)))
155 wlott 1.1
156 wlott 1.24 (deferr object-not-vector-error (object)
157 wlott 1.15 (error 'type-error
158     :function-name name
159     :datum object
160     :expected-type 'vector))
161 wlott 1.1
162 wlott 1.24 (deferr object-not-string-error (object)
163 wlott 1.15 (error 'type-error
164     :function-name name
165     :datum object
166     :expected-type 'string))
167 wlott 1.1
168 wlott 1.24 (deferr object-not-bit-vector-error (object)
169 wlott 1.15 (error 'type-error
170     :function-name name
171     :datum object
172     :expected-type 'bit-vector))
173 wlott 1.1
174 wlott 1.24 (deferr object-not-array-error (object)
175 wlott 1.15 (error 'type-error
176     :function-name name
177     :datum object
178     :expected-type 'array))
179 wlott 1.1
180 wlott 1.24 (deferr object-not-number-error (object)
181 wlott 1.15 (error 'type-error
182     :function-name name
183     :datum object
184     :expected-type 'number))
185 wlott 1.1
186 wlott 1.24 (deferr object-not-rational-error (object)
187 wlott 1.15 (error 'type-error
188     :function-name name
189     :datum object
190     :expected-type 'rational))
191 wlott 1.1
192 wlott 1.24 (deferr object-not-float-error (object)
193 wlott 1.15 (error 'type-error
194     :function-name name
195     :datum object
196     :expected-type 'float))
197 wlott 1.1
198 wlott 1.24 (deferr object-not-real-error (object)
199 wlott 1.15 (error 'type-error
200     :function-name name
201     :datum object
202     :expected-type 'real))
203 wlott 1.1
204 wlott 1.24 (deferr object-not-integer-error (object)
205 wlott 1.15 (error 'type-error
206     :function-name name
207     :datum object
208     :expected-type 'integer))
209 wlott 1.1
210 wlott 1.24 (deferr object-not-cons-error (object)
211 wlott 1.15 (error 'type-error
212     :function-name name
213     :datum object
214     :expected-type 'cons))
215 wlott 1.1
216 wlott 1.24 (deferr object-not-symbol-error (object)
217 wlott 1.15 (error 'type-error
218     :function-name name
219     :datum object
220     :expected-type 'symbol))
221 wlott 1.1
222 wlott 1.25 (deferr undefined-symbol-error (fdefn-or-symbol)
223 wlott 1.15 (error 'undefined-function
224     :function-name name
225 wlott 1.25 :name (etypecase fdefn-or-symbol
226     (symbol fdefn-or-symbol)
227     (fdefn (fdefn-name fdefn-or-symbol)))))
228 wlott 1.1
229 wlott 1.24 (deferr object-not-coercable-to-function-error (object)
230 wlott 1.15 (error 'type-error
231     :function-name name
232     :datum object
233     :expected-type 'coercable-to-function))
234 wlott 1.1
235 wlott 1.24 (deferr invalid-argument-count-error (nargs)
236 dtc 1.36 (error 'simple-program-error
237 wlott 1.15 :function-name name
238 ram 1.28 :format-control "Invalid number of arguments: ~S"
239 wlott 1.15 :format-arguments (list nargs)))
240 wlott 1.1
241 wlott 1.24 (deferr bogus-argument-to-values-list-error (list)
242 dtc 1.36 (error 'simple-type-error
243 wlott 1.15 :function-name name
244 dtc 1.36 :datum list
245     :expected-type 'list
246 ram 1.28 :format-control "Attempt to use VALUES-LIST on a dotted-list:~% ~S"
247 wlott 1.15 :format-arguments (list list)))
248 wlott 1.1
249 wlott 1.24 (deferr unbound-symbol-error (symbol)
250 wlott 1.15 (error 'unbound-variable :function-name name :name symbol))
251 wlott 1.1
252 wlott 1.24 (deferr object-not-base-char-error (object)
253 wlott 1.15 (error 'type-error
254     :function-name name
255     :datum object
256 wlott 1.18 :expected-type 'base-char))
257 wlott 1.1
258 wlott 1.24 (deferr object-not-sap-error (object)
259 wlott 1.15 (error 'type-error
260     :function-name name
261     :datum object
262     :expected-type 'system-area-pointer))
263 wlott 1.1
264 wlott 1.24 (deferr invalid-unwind-error ()
265 dtc 1.35 (error 'simple-control-error
266 wlott 1.15 :function-name name
267 ram 1.28 :format-control
268 wlott 1.15 "Attempt to RETURN-FROM a block or GO to a tag that no longer exists"))
269 wlott 1.1
270 wlott 1.24 (deferr unseen-throw-tag-error (tag)
271 dtc 1.35 (error 'simple-control-error
272 wlott 1.15 :function-name name
273 ram 1.28 :format-control "Attempt to THROW to a tag that does not exist: ~S"
274 wlott 1.15 :format-arguments (list tag)))
275 ram 1.19
276 wlott 1.24 (deferr nil-function-returned-error (function)
277 dtc 1.35 (error 'simple-control-error
278 ram 1.19 :function-name name
279 ram 1.28 :format-control
280 ram 1.19 "Function with declared result type NIL returned:~% ~S"
281     :format-arguments (list function)))
282 wlott 1.1
283 wlott 1.24 (deferr division-by-zero-error (this that)
284 wlott 1.15 (error 'division-by-zero
285     :function-name name
286     :operation 'division
287     :operands (list this that)))
288 wlott 1.1
289 wlott 1.24 (deferr object-not-type-error (object type)
290 ram 1.26 (error (if (and (%instancep object)
291     (layout-invalid (%instance-layout object)))
292     'layout-invalid
293     'type-error)
294 wlott 1.15 :function-name name
295     :datum object
296     :expected-type type))
297 wlott 1.1
298 ram 1.26 (deferr layout-invalid-error (object layout)
299     (error 'layout-invalid
300     :function-name name
301     :datum object
302     :expected-type (layout-class layout)))
303    
304 wlott 1.24 (deferr odd-keyword-arguments-error ()
305 pmai 1.38 (error 'simple-program-error
306 wlott 1.15 :function-name name
307 ram 1.28 :format-control "Odd number of keyword arguments."))
308 wlott 1.1
309 wlott 1.24 (deferr unknown-keyword-argument-error (key)
310 dtc 1.36 (error 'simple-program-error
311 wlott 1.15 :function-name name
312 ram 1.28 :format-control "Unknown keyword: ~S"
313 wlott 1.15 :format-arguments (list key)))
314 wlott 1.1
315 wlott 1.24 (deferr invalid-array-index-error (array bound index)
316 wlott 1.15 (error 'simple-error
317     :function-name name
318 ram 1.28 :format-control
319 dtc 1.37 (cond ((zerop bound)
320     "Invalid array index, ~D for ~S. Array has no elements.")
321     ((minusp index)
322     "Invalid array index, ~D for ~S. Should have greater than or equal to 0.")
323     (t
324     "Invalid array index, ~D for ~S. Should have been less than ~D"))
325 wlott 1.15 :format-arguments (list index array bound)))
326 wlott 1.1
327 wlott 1.24 (deferr object-not-simple-array-error (object)
328 wlott 1.15 (error 'type-error
329     :function-name name
330     :datum object
331     :expected-type 'simple-array))
332 wlott 1.1
333 wlott 1.24 (deferr object-not-signed-byte-32-error (object)
334 wlott 1.15 (error 'type-error
335     :function-name name
336     :datum object
337     :expected-type '(signed-byte 32)))
338 wlott 1.1
339 wlott 1.24 (deferr object-not-unsigned-byte-32-error (object)
340 wlott 1.15 (error 'type-error
341     :function-name name
342     :datum object
343     :expected-type '(unsigned-byte 32)))
344 wlott 1.1
345 wlott 1.24 (deferr object-not-simple-array-unsigned-byte-2-error (object)
346 wlott 1.15 (error 'type-error
347     :function-name name
348     :datum object
349     :expected-type '(simple-array (unsigned-byte 2) (*))))
350 wlott 1.1
351 wlott 1.24 (deferr object-not-simple-array-unsigned-byte-4-error (object)
352 wlott 1.15 (error 'type-error
353     :function-name name
354     :datum object
355     :expected-type '(simple-array (unsigned-byte 4) (*))))
356 wlott 1.1
357 wlott 1.24 (deferr object-not-simple-array-unsigned-byte-8-error (object)
358 wlott 1.15 (error 'type-error
359     :function-name name
360     :datum object
361     :expected-type '(simple-array (unsigned-byte 8) (*))))
362 wlott 1.1
363 wlott 1.24 (deferr object-not-simple-array-unsigned-byte-16-error (object)
364 wlott 1.15 (error 'type-error
365     :function-name name
366     :datum object
367     :expected-type '(simple-array (unsigned-byte 16) (*))))
368 wlott 1.1
369 wlott 1.24 (deferr object-not-simple-array-unsigned-byte-32-error (object)
370 wlott 1.15 (error 'type-error
371     :function-name name
372     :datum object
373     :expected-type '(simple-array (unsigned-byte 32) (*))))
374 dtc 1.30
375     (deferr object-not-simple-array-signed-byte-8-error (object)
376     (error 'type-error
377     :function-name name
378     :datum object
379     :expected-type '(simple-array (signed-byte 8) (*))))
380    
381     (deferr object-not-simple-array-signed-byte-16-error (object)
382     (error 'type-error
383     :function-name name
384     :datum object
385     :expected-type '(simple-array (signed-byte 16) (*))))
386    
387     (deferr object-not-simple-array-signed-byte-30-error (object)
388     (error 'type-error
389     :function-name name
390     :datum object
391     :expected-type '(simple-array (signed-byte 30) (*))))
392    
393     (deferr object-not-simple-array-signed-byte-32-error (object)
394     (error 'type-error
395     :function-name name
396     :datum object
397     :expected-type '(simple-array (signed-byte 32) (*))))
398 wlott 1.1
399 wlott 1.24 (deferr object-not-simple-array-single-float-error (object)
400 wlott 1.15 (error 'type-error
401     :function-name name
402     :datum object
403     :expected-type '(simple-array single-float (*))))
404 wlott 1.1
405 wlott 1.24 (deferr object-not-simple-array-double-float-error (object)
406 wlott 1.15 (error 'type-error
407     :function-name name
408     :datum object
409     :expected-type '(simple-array double-float (*))))
410 wlott 1.1
411 dtc 1.31 (deferr object-not-simple-array-complex-single-float-error (object)
412     (error 'type-error
413     :function-name name
414     :datum object
415     :expected-type '(simple-array (complex single-float) (*))))
416    
417     (deferr object-not-simple-array-complex-double-float-error (object)
418     (error 'type-error
419     :function-name name
420     :datum object
421     :expected-type '(simple-array (complex double-float) (*))))
422    
423 dtc 1.34 #+long-float
424 dtc 1.33 (deferr object-not-simple-array-complex-long-float-error (object)
425     (error 'type-error
426     :function-name name
427     :datum object
428     :expected-type '(simple-array (complex long-float) (*))))
429    
430 wlott 1.24 (deferr object-not-complex-error (object)
431 wlott 1.15 (error 'type-error
432     :function-name name
433     :datum object
434     :expected-type 'complex))
435 dtc 1.32
436     (deferr object-not-complex-rational-error (object)
437     (error 'type-error
438     :function-name name
439     :datum object
440     :expected-type '(complex rational)))
441 dtc 1.31
442     (deferr object-not-complex-single-float-error (object)
443     (error 'type-error
444     :function-name name
445     :datum object
446     :expected-type '(complex single-float)))
447    
448     (deferr object-not-complex-double-float-error (object)
449     (error 'type-error
450     :function-name name
451     :datum object
452     :expected-type '(complex double-float)))
453 dtc 1.33
454 dtc 1.34 #+long-float
455 dtc 1.33 (deferr object-not-complex-long-float-error (object)
456     (error 'type-error
457     :function-name name
458     :datum object
459     :expected-type '(complex long-float)))
460 wlott 1.1
461 wlott 1.24 (deferr object-not-weak-pointer-error (object)
462 wlott 1.15 (error 'type-error
463     :function-name name
464     :datum object
465     :expected-type 'weak-pointer))
466 wlott 1.11
467 ram 1.26 (deferr object-not-instance-error (object)
468 wlott 1.15 (error 'type-error
469 wlott 1.11 :function-name name
470 wlott 1.15 :datum object
471 ram 1.26 :expected-type 'instance))
472 wlott 1.15
473 pmai 1.39 #+linkage-table
474     (deferr undefined-foreign-symbol-error (symbol)
475     (error 'simple-program-error
476     :function-name name
477     :format-control "Undefined foreign symbol: ~S"
478     :format-arguments (list symbol)))
479 wlott 1.1
480    
481 ram 1.20 ;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out of
482     ;;; hyperspace.
483     ;;;
484     (defmacro infinite-error-protect (&rest forms)
485     `(if (and (boundp '*error-system-initialized*)
486     (numberp *current-error-depth*))
487     (let ((*current-error-depth* (1+ *current-error-depth*)))
488     (if (> *current-error-depth* *maximum-error-depth*)
489 ram 1.21 (error-error "Help! " *current-error-depth* " nested errors. "
490 ram 1.20 "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
491     (progn ,@forms)))
492     (%primitive halt)))
493 wlott 1.1
494 ram 1.20 ;;; Track the depth of recursive errors.
495     ;;;
496     (defvar *maximum-error-depth* 10
497     "The maximum number of nested errors allowed. Internal errors are
498     double-counted.")
499     (defvar *current-error-depth* 0 "The current number of nested errors.")
500 wlott 1.6
501 ram 1.20 ;;; These specials are used by ERROR-ERROR to track the success of recovery
502     ;;; attempts.
503     ;;;
504     (defvar *error-error-depth* 0)
505     (defvar *error-throw-up-count* 0)
506    
507     ;;; This protects against errors that happen before we run this top-level form.
508     ;;;
509     (defvar *error-system-initialized* t)
510    
511     ;;; ERROR-ERROR can be called when the error system is in trouble and needs
512     ;;; to punt fast. Prints a message without using format. If we get into
513     ;;; this recursively, then halt.
514     ;;;
515     (defun error-error (&rest messages)
516     (let ((*error-error-depth* (1+ *error-error-depth*)))
517     (when (> *error-throw-up-count* 50)
518     (%primitive halt)
519     (throw 'lisp::top-level-catcher nil))
520     (case *error-error-depth*
521     (1)
522     (2
523     (lisp::stream-init))
524     (3
525     (incf *error-throw-up-count*)
526     (throw 'lisp::top-level-catcher nil))
527     (t
528     (%primitive halt)
529     (throw 'lisp::top-level-catcher nil)))
530    
531     (with-standard-io-syntax
532 ram 1.21 (let ((*print-readably* nil))
533     (dolist (item messages) (princ item *terminal-io*))
534     (debug:internal-debug)))))
535 ram 1.20
536    
537     ;;;; Fetching errorful function name.
538    
539     ;;; Used to prevent infinite recursive lossage when we can't find the caller
540     ;;; for some reason.
541     ;;;
542 ram 1.21 (defvar *finding-name* nil)
543 ram 1.20
544     ;;; FIND-CALLER-NAME -- Internal
545     ;;;
546     (defun find-caller-name ()
547 ram 1.21 (if *finding-name*
548 wlott 1.23 (values "<error finding name>" nil)
549 ram 1.20 (handler-case
550 wlott 1.23 (let* ((*finding-name* t)
551     (frame (di:frame-down (di:frame-down (di:top-frame))))
552     (name (di:debug-function-name
553     (di:frame-debug-function frame))))
554     (di:flush-frames-above frame)
555     (values name frame))
556     (error ()
557     (values "<error finding name>" nil))
558     (di:debug-condition ()
559     (values "<error finding name>" nil)))))
560 ram 1.20
561    
562 wlott 1.6 (defun find-interrupted-name ()
563     (if *finding-name*
564 wlott 1.23 (values "<error finding name>" nil)
565 wlott 1.6 (handler-case
566     (let ((*finding-name* t))
567     (do ((frame (di:top-frame) (di:frame-down frame)))
568 wlott 1.27 ((null frame)
569     (values "<error finding name>" nil))
570     (when (and (di::compiled-frame-p frame)
571     (di::compiled-frame-escaped frame))
572     (di:flush-frames-above frame)
573     (return (values (di:debug-function-name
574     (di:frame-debug-function frame))
575     frame)))))
576 wlott 1.23 (error ()
577     (values "<error finding name>" nil))
578     (di:debug-condition ()
579     (values "<error finding name>" nil)))))
580 wlott 1.6
581 ram 1.20
582     ;;;; internal-error signal handler.
583 wlott 1.6
584 wlott 1.13 (defun internal-error (scp continuable)
585 wlott 1.22 (declare (type system-area-pointer scp) (ignore continuable))
586 ram 1.20 (infinite-error-protect
587 wlott 1.24 (let ((scp (locally
588     (declare (optimize (inhibit-warnings 3)))
589     (alien:sap-alien scp (* unix:sigcontext)))))
590 wlott 1.22 (multiple-value-bind
591     (error-number arguments)
592     (vm:internal-error-arguments scp)
593 wlott 1.23 (multiple-value-bind
594     (name debug:*stack-top-hint*)
595     (find-interrupted-name)
596     (let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset)))
597 wlott 1.24 (handler (and (< -1 error-number (length *internal-errors*))
598     (svref *internal-errors* error-number))))
599     (cond ((null handler)
600 wlott 1.23 (error 'simple-error
601     :function-name name
602 ram 1.28 :format-control
603 wlott 1.23 "Unknown internal error, ~D? args=~S"
604     :format-arguments
605     (list error-number
606     (mapcar #'(lambda (sc-offset)
607     (di::sub-access-debug-var-slot
608     fp sc-offset scp))
609     arguments))))
610 wlott 1.24 ((not (functionp handler))
611 wlott 1.23 (error 'simple-error
612     :function-name name
613 ram 1.28 :format-control
614 wlott 1.23 "Internal error ~D: ~A. args=~S"
615     :format-arguments
616     (list error-number
617 wlott 1.24 handler
618 wlott 1.23 (mapcar #'(lambda (sc-offset)
619     (di::sub-access-debug-var-slot
620     fp sc-offset scp))
621     arguments))))
622     (t
623 wlott 1.24 (funcall handler name fp scp arguments)))))))))
624 gerd 1.40
625     ;;;
626     ;;; Called from C when the yellow control stack guard zone is hit.
627     ;;; The yellow zone is unprotected in the C code prior to calling this
628     ;;; function, to give some room for debugging. The red zone is still
629     ;;; protected.
630     ;;;
631     #+stack-checking
632     (defun yellow-zone-hit ()
633     (let ((debug:*stack-top-hint* nil))
634     (format *error-output*
635     "~2&~@<A control stack overflow has occurred: ~
636     the program has entered the yellow control stack guard zone. ~
637     Please note that you will be returned to the Top-Level if you ~
638     enter the red control stack guard zone while debugging.~@:>~2%")
639     (infinite-error-protect (error 'stack-overflow))))
640    
641     ;;;
642     ;;; Called from C when the red control stack guard zone is hit. We
643     ;;; could ABORT here, which would usually take us back to the debugger
644     ;;; or top-level, and add code to the restarts re-protecting the red
645     ;;; zone (which can't be done here because we're still in the red
646     ;;; zone). Using ABORT is too dangerous because users may be using
647     ;;; abort restarts which don't do the necessary re-protecting of the
648     ;;; red zone, and would thus render CMUCL unprotected.
649     ;;;
650     #+stack-checking
651     (defun red-zone-hit ()
652     (format *error-output*
653     "~2&~@<Fatal control stack overflow. You have entered ~
654     the red control stack guard zone while debugging. ~
655     Returning to Top-Level.~@:>~2%")
656     (throw 'lisp::top-level-catcher nil))
657    
658 ram 1.20

  ViewVC Help
Powered by ViewVC 1.1.5