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 void* stack_start
= arch_os_get_current_thread() + dynamic_values_bytes
;
290 void* stack_end
= stack_start
+ 32*SIGSTKSZ
;
292 return (p
> stack_start
&& p
<= stack_end
);
294 /* Win32 doesn't do altstack */
300 stack_pointer_p (void *p
)
302 /* we are using sizeof(long) here, because that is the right value on both
303 * x86 and x86-64. (But note that false positives would not cause much harm
304 * given the heuristical nature of x86_call_context.) */
305 unsigned long stack_alignment
= sizeof(long);
307 return (altstack_pointer_p(p
)
308 || (p
< (void *) arch_os_get_current_thread()->control_stack_end
309 && (p
> (void *) &p
|| altstack_pointer_p(&p
))
310 && (((unsigned long) p
) & (stack_alignment
-1)) == 0));
314 ra_pointer_p (void *ra
)
316 /* the check against 4096 is still a mystery to everyone interviewed about
317 * it, but recent changes to sb-sprof seem to suggest that such values
318 * do occur sometimes. */
319 return ((unsigned long) ra
) > 4096 && !stack_pointer_p (ra
);
323 x86_call_context (void *fp
, void **ra
, void **ocfp
)
329 int lisp_valid_p
, c_valid_p
;
331 if (!stack_pointer_p(fp
))
334 c_ocfp
= *((void **) fp
);
335 c_ra
= *((void **) fp
+ 1);
336 lisp_ocfp
= *((void **) fp
- 1);
337 lisp_ra
= *((void **) fp
- 2);
339 lisp_valid_p
= (lisp_ocfp
> fp
340 && stack_pointer_p(lisp_ocfp
)
341 && ra_pointer_p(lisp_ra
));
342 c_valid_p
= (c_ocfp
> fp
343 && stack_pointer_p(c_ocfp
)
344 && ra_pointer_p(c_ra
));
346 if (lisp_valid_p
&& c_valid_p
) {
351 int lisp_path_p
= x86_call_context(lisp_ocfp
, &lisp_path_fp
, &dummy
);
352 int c_path_p
= x86_call_context(c_ocfp
, &c_path_fp
, &dummy
);
354 if (lisp_path_p
&& c_path_p
) {
355 #if defined __FreeBSD__ && __FreeBSD_version > 400000
356 if (lisp_ocfp
> c_ocfp
)
357 *ra
= lisp_ra
, *ocfp
= lisp_ocfp
;
359 *ra
= c_ra
, *ocfp
= c_ocfp
;
361 *ra
= lisp_ra
, *ocfp
= lisp_ocfp
;
364 else if (lisp_path_p
)
365 *ra
= lisp_ra
, *ocfp
= lisp_ocfp
;
367 *ra
= c_ra
, *ocfp
= c_ocfp
;
371 else if (lisp_valid_p
)
372 *ra
= lisp_ra
, *ocfp
= lisp_ocfp
;
374 *ra
= c_ra
, *ocfp
= c_ocfp
;
381 struct compiled_debug_fun
*
382 debug_function_from_pc (struct code
* code
, void *pc
)
384 unsigned long code_header_len
= sizeof(lispobj
) * HeaderValue(code
->header
);
386 = (unsigned long) pc
- (unsigned long) code
- code_header_len
;
387 struct compiled_debug_fun
*df
;
388 struct compiled_debug_info
*di
;
392 if (lowtag_of(code
->debug_info
) != INSTANCE_POINTER_LOWTAG
)
395 di
= (struct compiled_debug_info
*) native_pointer(code
->debug_info
);
396 v
= (struct vector
*) native_pointer(di
->fun_map
);
397 len
= fixnum_value(v
->length
);
398 df
= (struct compiled_debug_fun
*) native_pointer(v
->data
[0]);
403 for (i
= 1;; i
+= 2) {
407 return ((struct compiled_debug_fun
*) native_pointer(v
->data
[i
- 1]));
409 if (offset
>= fixnum_value(df
->elsewhere_pc
)) {
410 struct compiled_debug_fun
*p
411 = ((struct compiled_debug_fun
*) native_pointer(v
->data
[i
+ 1]));
412 next_pc
= fixnum_value(p
->elsewhere_pc
);
414 next_pc
= fixnum_value(v
->data
[i
]);
416 if (offset
< next_pc
)
417 return ((struct compiled_debug_fun
*) native_pointer(v
->data
[i
- 1]));
424 sbcl_putwc(wchar_t c
, FILE *file
)
426 #ifdef LISP_FEATURE_OS_PROVIDES_PUTWC
438 print_string (lispobj
*object
)
440 int tag
= widetag_of(*object
);
441 struct vector
*vector
= (struct vector
*) object
;
446 int n = fixnum_value(vector->length); \
447 TYPE *data = (TYPE *) vector->data; \
448 for (i = 0; i < n; i++) { \
449 wchar_t c = (wchar_t) data[i]; \
450 if (c == '\\' || c == '"') \
452 sbcl_putwc(c, stdout); \
457 case SIMPLE_BASE_STRING_WIDETAG
:
460 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
461 case SIMPLE_CHARACTER_STRING_WIDETAG
:
466 printf("<??? type %d>", tag
);
472 print_entry_name (lispobj name
)
474 if (lowtag_of (name
) == LIST_POINTER_LOWTAG
) {
476 while (name
!= NIL
) {
477 struct cons
*cons
= (struct cons
*) native_pointer(name
);
478 print_entry_name(cons
->car
);
484 } else if (lowtag_of(name
) == OTHER_POINTER_LOWTAG
) {
485 lispobj
*object
= (lispobj
*) native_pointer(name
);
486 if (widetag_of(*object
) == SYMBOL_HEADER_WIDETAG
) {
487 struct symbol
*symbol
= (struct symbol
*) object
;
488 if (symbol
->package
!= NIL
) {
490 = (struct package
*) native_pointer(symbol
->package
);
491 lispobj pkg_name
= pkg
->_name
;
492 print_string(native_pointer(pkg_name
));
495 print_string(native_pointer(symbol
->name
));
496 } else if (widetag_of(*object
) == SIMPLE_BASE_STRING_WIDETAG
) {
498 print_string(object
);
500 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
501 } else if (widetag_of(*object
) == SIMPLE_CHARACTER_STRING_WIDETAG
) {
503 print_string(object
);
507 printf("<??? type %d>", (int) widetag_of(*object
));
510 printf("<??? lowtag %d>", (int) lowtag_of(name
));
515 print_entry_points (struct code
*code
)
517 lispobj function
= code
->entry_points
;
519 while (function
!= NIL
) {
520 struct simple_fun
*header
= (struct simple_fun
*) native_pointer(function
);
521 print_entry_name(header
->name
);
523 function
= header
->next
;
529 /* This function has been split from backtrace() to enable Lisp
530 * backtraces from gdb with call backtrace_from_fp(...). Useful for
531 * example when debugging threading deadlocks.
534 backtrace_from_fp(void *fp
, int nframes
)
538 for (i
= 0; i
< nframes
; ++i
) {
543 if (!x86_call_context(fp
, &ra
, &next_fp
))
548 p
= (lispobj
*) component_ptr_from_pc((lispobj
*) ra
);
550 struct code
*cp
= (struct code
*) p
;
551 struct compiled_debug_fun
*df
= debug_function_from_pc(cp
, ra
);
553 print_entry_name(df
->name
);
555 print_entry_points(cp
);
557 #ifdef LISP_FEATURE_OS_PROVIDES_DLADDR
559 if (dladdr(ra
, &info
)) {
560 printf("Foreign function %s, fp = 0x%lx, ra = 0x%lx",
562 (unsigned long) next_fp
,
566 printf("Foreign fp = 0x%lx, ra = 0x%lx",
567 (unsigned long) next_fp
,
577 backtrace(int nframes
)
581 #if defined(LISP_FEATURE_X86)
582 asm("movl %%ebp,%0" : "=g" (fp
));
583 #elif defined (LISP_FEATURE_X86_64)
584 asm("movq %%rbp,%0" : "=g" (fp
));
586 #error "How did we get here?"
589 backtrace_from_fp(fp
, nframes
);