2 * simple backtrace facility
6 * This software is part of the SBCL system. See the README file for
9 * This software is derived from the CMU CL system, which was
10 * written at Carnegie Mellon University and released into the
11 * public domain. The software is in the public domain and is
12 * provided with absolutely no warranty. See the COPYING and CREDITS
13 * files for more information.
22 #include "interrupt.h"
24 #ifdef LISP_FEATURE_GENCGC
27 #include "gencgc-alloc-region.h"
28 #include "genesis/compiled-debug-fun.h"
29 #include "genesis/compiled-debug-info.h"
30 #include "genesis/package.h"
32 #include "genesis/static-symbols.h"
33 #include "genesis/primitive-objects.h"
36 #ifdef LISP_FEATURE_OS_PROVIDES_DLADDR
37 /* __USE_GNU needed if we want dladdr() and Dl_Info from glibc. */
42 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
44 /* KLUDGE: Sigh ... I know what the call frame looks like and it had
45 * better not change. */
48 #ifndef LISP_FEATURE_ALPHA
49 struct call_frame
*old_cont
;
55 lispobj other_state
[5];
59 #ifndef LISP_FEATURE_ALPHA
60 struct call_frame
*frame
;
65 #ifndef LISP_FEATURE_ALPHA
71 int pc
; /* Note: this is the trace file offset, not the actual pc. */
74 #define HEADER_LENGTH(header) ((header)>>8)
76 static int previous_info(struct call_info
*info
);
79 code_pointer(lispobj object
)
81 lispobj
*headerp
, header
;
84 headerp
= (lispobj
*) native_pointer(object
);
86 type
= widetag_of(header
);
89 case CODE_HEADER_WIDETAG
:
91 case RETURN_PC_HEADER_WIDETAG
:
92 case SIMPLE_FUN_HEADER_WIDETAG
:
93 len
= HEADER_LENGTH(header
);
103 return (struct code
*) headerp
;
107 cs_valid_pointer_p(struct call_frame
*pointer
)
109 struct thread
*thread
=arch_os_get_current_thread();
110 return (((char *) thread
->control_stack_start
<= (char *) pointer
) &&
111 ((char *) pointer
< (char *) current_control_stack_pointer
));
115 call_info_from_lisp_state(struct call_info
*info
)
117 info
->frame
= (struct call_frame
*)current_control_frame_pointer
;
118 info
->interrupted
= 0;
127 call_info_from_context(struct call_info
*info
, os_context_t
*context
)
131 info
->interrupted
= 1;
132 if (lowtag_of(*os_context_register_addr(context
, reg_CODE
))
133 == FUN_POINTER_LOWTAG
) {
134 /* We tried to call a function, but crapped out before $CODE could
135 * be fixed up. Probably an undefined function. */
137 (struct call_frame
*)(unsigned long)
138 (*os_context_register_addr(context
, reg_OCFP
));
139 info
->lra
= (lispobj
)(*os_context_register_addr(context
, reg_LRA
));
140 info
->code
= code_pointer(info
->lra
);
141 pc
= (unsigned long)native_pointer(info
->lra
);
145 (struct call_frame
*)(unsigned long)
146 (*os_context_register_addr(context
, reg_CFP
));
148 code_pointer(*os_context_register_addr(context
, reg_CODE
));
150 pc
= *os_context_pc_addr(context
);
152 if (info
->code
!= NULL
)
153 info
->pc
= pc
- (unsigned long) info
->code
-
154 #ifndef LISP_FEATURE_ALPHA
155 (HEADER_LENGTH(info
->code
->header
) * sizeof(lispobj
));
157 (HEADER_LENGTH(((struct code
*)info
->code
)->header
) * sizeof(lispobj
));
164 previous_info(struct call_info
*info
)
166 struct call_frame
*this_frame
;
167 struct thread
*thread
=arch_os_get_current_thread();
170 if (!cs_valid_pointer_p(info
->frame
)) {
171 printf("Bogus callee value (0x%08lx).\n", (unsigned long)info
->frame
);
175 this_frame
= info
->frame
;
176 info
->lra
= this_frame
->saved_lra
;
177 info
->frame
= this_frame
->old_cont
;
178 info
->interrupted
= 0;
180 if (info
->frame
== NULL
|| info
->frame
== this_frame
)
183 if (info
->lra
== NIL
) {
184 /* We were interrupted. Find the correct signal context. */
185 free_ici
= fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX
,thread
));
186 while (free_ici
-- > 0) {
187 os_context_t
*context
=
188 thread
->interrupt_contexts
[free_ici
];
189 if ((struct call_frame
*)(unsigned long)
190 (*os_context_register_addr(context
, reg_CFP
))
192 call_info_from_context(info
, context
);
198 info
->code
= code_pointer(info
->lra
);
199 if (info
->code
!= NULL
)
200 info
->pc
= (unsigned long)native_pointer(info
->lra
) -
201 (unsigned long)info
->code
-
202 #ifndef LISP_FEATURE_ALPHA
203 (HEADER_LENGTH(info
->code
->header
) * sizeof(lispobj
));
205 (HEADER_LENGTH(((struct code
*)info
->code
)->header
) * sizeof(lispobj
));
215 backtrace(int nframes
)
217 struct call_info info
;
219 call_info_from_lisp_state(&info
);
222 printf("<Frame 0x%08lx%s, ", (unsigned long) info
.frame
,
223 info
.interrupted
? " [interrupted]" : "");
225 if (info
.code
!= (struct code
*) 0) {
228 printf("CODE: 0x%08lX, ", (unsigned long) info
.code
| OTHER_POINTER_LOWTAG
);
230 #ifndef LISP_FEATURE_ALPHA
231 function
= info
.code
->entry_points
;
233 function
= ((struct code
*)info
.code
)->entry_points
;
235 while (function
!= NIL
) {
236 struct simple_fun
*header
;
239 header
= (struct simple_fun
*) native_pointer(function
);
242 if (lowtag_of(name
) == OTHER_POINTER_LOWTAG
) {
245 object
= (lispobj
*) native_pointer(name
);
247 if (widetag_of(*object
) == SYMBOL_HEADER_WIDETAG
) {
248 struct symbol
*symbol
;
250 symbol
= (struct symbol
*) object
;
251 object
= (lispobj
*) native_pointer(symbol
->name
);
253 if (widetag_of(*object
) == SIMPLE_BASE_STRING_WIDETAG
) {
254 struct vector
*string
;
256 string
= (struct vector
*) object
;
257 printf("%s, ", (char *) string
->data
);
259 /* FIXME: broken from (VECTOR NIL) */
260 printf("(Not simple string??\?), ");
262 printf("(Not other pointer??\?), ");
265 function
= header
->next
;
269 printf("CODE: ???, ");
272 printf("LRA: 0x%08lx, ", (unsigned long)info
.lra
);
274 printf("<no LRA>, ");
277 printf("PC: 0x%x>\n", info
.pc
);
279 printf("PC: ??\?>\n");
281 } while (--nframes
> 0 && previous_info(&info
));
287 altstack_pointer_p (void *p
) {
288 #ifndef LISP_FEATURE_WIN32
289 char* stack_start
= ((char *) arch_os_get_current_thread())
290 + dynamic_values_bytes
;
291 char* stack_end
= stack_start
+ 32*SIGSTKSZ
;
293 return (p
> stack_start
&& p
<= stack_end
);
295 /* Win32 doesn't do altstack */
301 stack_pointer_p (void *p
)
303 /* we are using sizeof(long) here, because that is the right value on both
304 * x86 and x86-64. (But note that false positives would not cause much harm
305 * given the heuristical nature of x86_call_context.) */
306 unsigned long stack_alignment
= sizeof(long);
308 return (altstack_pointer_p(p
)
309 || (p
< (void *) arch_os_get_current_thread()->control_stack_end
310 && (p
> (void *) &p
|| altstack_pointer_p(&p
))
311 && (((unsigned long) p
) & (stack_alignment
-1)) == 0));
315 ra_pointer_p (void *ra
)
317 /* the check against 4096 is still a mystery to everyone interviewed about
318 * it, but recent changes to sb-sprof seem to suggest that such values
319 * do occur sometimes. */
320 return ((unsigned long) ra
) > 4096 && !stack_pointer_p (ra
);
324 x86_call_context (void *fp
, void **ra
, void **ocfp
)
330 int lisp_valid_p
, c_valid_p
;
332 if (!stack_pointer_p(fp
))
335 c_ocfp
= *((void **) fp
);
336 c_ra
= *((void **) fp
+ 1);
337 lisp_ocfp
= *((void **) fp
- 1);
338 lisp_ra
= *((void **) fp
- 2);
340 lisp_valid_p
= (lisp_ocfp
> fp
341 && stack_pointer_p(lisp_ocfp
)
342 && ra_pointer_p(lisp_ra
));
343 c_valid_p
= (c_ocfp
> fp
344 && stack_pointer_p(c_ocfp
)
345 && ra_pointer_p(c_ra
));
347 if (lisp_valid_p
&& c_valid_p
) {
352 int lisp_path_p
= x86_call_context(lisp_ocfp
, &lisp_path_fp
, &dummy
);
353 int c_path_p
= x86_call_context(c_ocfp
, &c_path_fp
, &dummy
);
355 if (lisp_path_p
&& c_path_p
) {
356 #if defined __FreeBSD__ && __FreeBSD_version > 400000
357 if (lisp_ocfp
> c_ocfp
)
358 *ra
= lisp_ra
, *ocfp
= lisp_ocfp
;
360 *ra
= c_ra
, *ocfp
= c_ocfp
;
362 *ra
= lisp_ra
, *ocfp
= lisp_ocfp
;
365 else if (lisp_path_p
)
366 *ra
= lisp_ra
, *ocfp
= lisp_ocfp
;
368 *ra
= c_ra
, *ocfp
= c_ocfp
;
372 else if (lisp_valid_p
)
373 *ra
= lisp_ra
, *ocfp
= lisp_ocfp
;
375 *ra
= c_ra
, *ocfp
= c_ocfp
;
382 struct compiled_debug_fun
*
383 debug_function_from_pc (struct code
* code
, void *pc
)
385 unsigned long code_header_len
= sizeof(lispobj
) * HeaderValue(code
->header
);
387 = (unsigned long) pc
- (unsigned long) code
- code_header_len
;
388 struct compiled_debug_fun
*df
;
389 struct compiled_debug_info
*di
;
393 if (lowtag_of(code
->debug_info
) != INSTANCE_POINTER_LOWTAG
)
396 di
= (struct compiled_debug_info
*) native_pointer(code
->debug_info
);
397 v
= (struct vector
*) native_pointer(di
->fun_map
);
398 len
= fixnum_value(v
->length
);
399 df
= (struct compiled_debug_fun
*) native_pointer(v
->data
[0]);
404 for (i
= 1;; i
+= 2) {
408 return ((struct compiled_debug_fun
*) native_pointer(v
->data
[i
- 1]));
410 if (offset
>= fixnum_value(df
->elsewhere_pc
)) {
411 struct compiled_debug_fun
*p
412 = ((struct compiled_debug_fun
*) native_pointer(v
->data
[i
+ 1]));
413 next_pc
= fixnum_value(p
->elsewhere_pc
);
415 next_pc
= fixnum_value(v
->data
[i
]);
417 if (offset
< next_pc
)
418 return ((struct compiled_debug_fun
*) native_pointer(v
->data
[i
- 1]));
425 sbcl_putwc(wchar_t c
, FILE *file
)
427 #ifdef LISP_FEATURE_OS_PROVIDES_PUTWC
439 print_string (lispobj
*object
)
441 int tag
= widetag_of(*object
);
442 struct vector
*vector
= (struct vector
*) object
;
447 int n = fixnum_value(vector->length); \
448 TYPE *data = (TYPE *) vector->data; \
449 for (i = 0; i < n; i++) { \
450 wchar_t c = (wchar_t) data[i]; \
451 if (c == '\\' || c == '"') \
453 sbcl_putwc(c, stdout); \
458 case SIMPLE_BASE_STRING_WIDETAG
:
461 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
462 case SIMPLE_CHARACTER_STRING_WIDETAG
:
467 printf("<??? type %d>", tag
);
473 print_entry_name (lispobj name
)
475 if (lowtag_of (name
) == LIST_POINTER_LOWTAG
) {
477 while (name
!= NIL
) {
478 struct cons
*cons
= (struct cons
*) native_pointer(name
);
479 print_entry_name(cons
->car
);
485 } else if (lowtag_of(name
) == OTHER_POINTER_LOWTAG
) {
486 lispobj
*object
= (lispobj
*) native_pointer(name
);
487 if (widetag_of(*object
) == SYMBOL_HEADER_WIDETAG
) {
488 struct symbol
*symbol
= (struct symbol
*) object
;
489 if (symbol
->package
!= NIL
) {
491 = (struct package
*) native_pointer(symbol
->package
);
492 lispobj pkg_name
= pkg
->_name
;
493 print_string(native_pointer(pkg_name
));
496 print_string(native_pointer(symbol
->name
));
497 } else if (widetag_of(*object
) == SIMPLE_BASE_STRING_WIDETAG
) {
499 print_string(object
);
501 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
502 } else if (widetag_of(*object
) == SIMPLE_CHARACTER_STRING_WIDETAG
) {
504 print_string(object
);
508 printf("<??? type %d>", (int) widetag_of(*object
));
511 printf("<??? lowtag %d>", (int) lowtag_of(name
));
516 print_entry_points (struct code
*code
)
518 lispobj function
= code
->entry_points
;
520 while (function
!= NIL
) {
521 struct simple_fun
*header
= (struct simple_fun
*) native_pointer(function
);
522 print_entry_name(header
->name
);
524 function
= header
->next
;
530 /* This function has been split from backtrace() to enable Lisp
531 * backtraces from gdb with call backtrace_from_fp(...). Useful for
532 * example when debugging threading deadlocks.
535 backtrace_from_fp(void *fp
, int nframes
)
539 for (i
= 0; i
< nframes
; ++i
) {
544 if (!x86_call_context(fp
, &ra
, &next_fp
))
549 p
= (lispobj
*) component_ptr_from_pc((lispobj
*) ra
);
551 struct code
*cp
= (struct code
*) p
;
552 struct compiled_debug_fun
*df
= debug_function_from_pc(cp
, ra
);
554 print_entry_name(df
->name
);
556 print_entry_points(cp
);
558 #ifdef LISP_FEATURE_OS_PROVIDES_DLADDR
560 if (dladdr(ra
, &info
)) {
561 printf("Foreign function %s, fp = 0x%lx, ra = 0x%lx",
563 (unsigned long) next_fp
,
567 printf("Foreign fp = 0x%lx, ra = 0x%lx",
568 (unsigned long) next_fp
,
578 backtrace(int nframes
)
583 #if defined(LISP_FEATURE_X86)
584 asm("movl %%ebp,%0" : "=g" (fp
));
585 #elif defined (LISP_FEATURE_X86_64)
586 asm("movq %%rbp,%0" : "=g" (fp
));
588 #error "How did we get here?"
591 backtrace_from_fp(fp
, nframes
);