e5b02a10eac3f6a281fa13a196f57c21fcb33900
[sbcl.git] / src / runtime / backtrace.c
1 /*
2  * simple backtrace facility
3  */
4
5 /*
6  * This software is part of the SBCL system. See the README file for
7  * more information.
8  *
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.
14  */
15
16 #include <stdio.h>
17 #include <signal.h>
18 #include "sbcl.h"
19 #include "runtime.h"
20 #include "globals.h"
21 #include "os.h"
22 #include "interrupt.h"
23 #include "lispregs.h"
24 #ifdef LISP_FEATURE_GENCGC
25 #include <wchar.h>
26 #include "arch.h"
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"
31 #endif
32 #include "genesis/static-symbols.h"
33 #include "genesis/primitive-objects.h"
34 #include "thread.h"
35
36 #ifdef LISP_FEATURE_OS_PROVIDES_DLADDR
37 # ifndef __USE_GNU
38 /* __USE_GNU needed if we want dladdr() and Dl_Info from glibc. */
39 # define __USE_GNU
40 # endif
41 # include "dlfcn.h"
42 #endif
43
44 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
45
46 /* KLUDGE: Sigh ... I know what the call frame looks like and it had
47  * better not change. */
48
49 struct call_frame {
50 #ifndef LISP_FEATURE_ALPHA
51         struct call_frame *old_cont;
52 #else
53         u32 old_cont;
54 #endif
55         lispobj saved_lra;
56         lispobj code;
57         lispobj other_state[5];
58 };
59
60 struct call_info {
61 #ifndef LISP_FEATURE_ALPHA
62     struct call_frame *frame;
63 #else
64     u32 frame;
65 #endif
66     int interrupted;
67 #ifndef LISP_FEATURE_ALPHA
68     struct code *code;
69 #else
70     u32 code;
71 #endif
72     lispobj lra;
73     int pc; /* Note: this is the trace file offset, not the actual pc. */
74 };
75
76 #define HEADER_LENGTH(header) ((header)>>8)
77
78 static int previous_info(struct call_info *info);
79
80 static struct code *
81 code_pointer(lispobj object)
82 {
83     lispobj *headerp, header;
84     int type, len;
85
86     headerp = (lispobj *) native_pointer(object);
87     header = *headerp;
88     type = widetag_of(header);
89
90     switch (type) {
91         case CODE_HEADER_WIDETAG:
92             break;
93         case RETURN_PC_HEADER_WIDETAG:
94         case SIMPLE_FUN_HEADER_WIDETAG:
95             len = HEADER_LENGTH(header);
96             if (len == 0)
97                 headerp = NULL;
98             else
99                 headerp -= len;
100             break;
101         default:
102             headerp = NULL;
103     }
104
105     return (struct code *) headerp;
106 }
107
108 static boolean
109 cs_valid_pointer_p(struct call_frame *pointer)
110 {
111     struct thread *thread=arch_os_get_current_thread();
112     return (((char *) thread->control_stack_start <= (char *) pointer) &&
113             ((char *) pointer < (char *) access_control_stack_pointer(thread)));
114 }
115
116 static void
117 call_info_from_lisp_state(struct call_info *info)
118 {
119     info->frame = (struct call_frame *)access_control_frame_pointer(arch_os_get_current_thread());
120     info->interrupted = 0;
121     info->code = NULL;
122     info->lra = 0;
123     info->pc = 0;
124
125     previous_info(info);
126 }
127
128 static void
129 call_info_from_context(struct call_info *info, os_context_t *context)
130 {
131     unsigned long pc;
132
133     info->interrupted = 1;
134     if (lowtag_of(*os_context_register_addr(context, reg_CODE))
135         == FUN_POINTER_LOWTAG) {
136         /* We tried to call a function, but crapped out before $CODE could
137          * be fixed up. Probably an undefined function. */
138         info->frame =
139             (struct call_frame *)(unsigned long)
140                 (*os_context_register_addr(context, reg_OCFP));
141         info->lra = (lispobj)(*os_context_register_addr(context, reg_LRA));
142         info->code = code_pointer(info->lra);
143         pc = (unsigned long)native_pointer(info->lra);
144     }
145     else {
146         info->frame =
147             (struct call_frame *)(unsigned long)
148                 (*os_context_register_addr(context, reg_CFP));
149         info->code =
150             code_pointer(*os_context_register_addr(context, reg_CODE));
151         info->lra = NIL;
152         pc = *os_context_pc_addr(context);
153     }
154     if (info->code != NULL)
155         info->pc = pc - (unsigned long) info->code -
156 #ifndef LISP_FEATURE_ALPHA
157             (HEADER_LENGTH(info->code->header) * sizeof(lispobj));
158 #else
159             (HEADER_LENGTH(((struct code *)info->code)->header) * sizeof(lispobj));
160 #endif
161     else
162         info->pc = 0;
163 }
164
165 static int
166 previous_info(struct call_info *info)
167 {
168     struct call_frame *this_frame;
169     struct thread *thread=arch_os_get_current_thread();
170     int free_ici;
171
172     if (!cs_valid_pointer_p(info->frame)) {
173         printf("Bogus callee value (0x%08lx).\n", (unsigned long)info->frame);
174         return 0;
175     }
176
177     this_frame = info->frame;
178     info->lra = this_frame->saved_lra;
179     info->frame = this_frame->old_cont;
180     info->interrupted = 0;
181
182     if (info->frame == NULL || info->frame == this_frame)
183         return 0;
184
185     if (info->lra == NIL) {
186         /* We were interrupted. Find the correct signal context. */
187         free_ici = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread));
188         while (free_ici-- > 0) {
189             os_context_t *context =
190                 thread->interrupt_contexts[free_ici];
191             if ((struct call_frame *)(unsigned long)
192                     (*os_context_register_addr(context, reg_CFP))
193                 == info->frame) {
194                 call_info_from_context(info, context);
195                 break;
196             }
197         }
198     }
199     else {
200         info->code = code_pointer(info->lra);
201         if (info->code != NULL)
202             info->pc = (unsigned long)native_pointer(info->lra) -
203                 (unsigned long)info->code -
204 #ifndef LISP_FEATURE_ALPHA
205                 (HEADER_LENGTH(info->code->header) * sizeof(lispobj));
206 #else
207                 (HEADER_LENGTH(((struct code *)info->code)->header) * sizeof(lispobj));
208 #endif
209         else
210             info->pc = 0;
211     }
212
213     return 1;
214 }
215
216 void
217 lisp_backtrace(int nframes)
218 {
219     struct call_info info;
220
221     call_info_from_lisp_state(&info);
222
223     do {
224         printf("<Frame 0x%08lx%s, ", (unsigned long) info.frame,
225                 info.interrupted ? " [interrupted]" : "");
226
227         if (info.code != (struct code *) 0) {
228             lispobj function;
229
230             printf("CODE: 0x%08lX, ", (unsigned long) info.code | OTHER_POINTER_LOWTAG);
231
232 #ifndef LISP_FEATURE_ALPHA
233             function = info.code->entry_points;
234 #else
235             function = ((struct code *)info.code)->entry_points;
236 #endif
237             while (function != NIL) {
238                 struct simple_fun *header;
239                 lispobj name;
240
241                 header = (struct simple_fun *) native_pointer(function);
242                 name = header->name;
243
244                 if (lowtag_of(name) == OTHER_POINTER_LOWTAG) {
245                     lispobj *object;
246
247                     object = (lispobj *) native_pointer(name);
248
249                     if (widetag_of(*object) == SYMBOL_HEADER_WIDETAG) {
250                         struct symbol *symbol;
251
252                         symbol = (struct symbol *) object;
253                         object = (lispobj *) native_pointer(symbol->name);
254                     }
255                     if (widetag_of(*object) == SIMPLE_BASE_STRING_WIDETAG) {
256                         struct vector *string;
257
258                         string = (struct vector *) object;
259                         printf("%s, ", (char *) string->data);
260                     } else
261                         /* FIXME: broken from (VECTOR NIL) */
262                         printf("(Not simple string??\?), ");
263                 } else
264                     printf("(Not other pointer??\?), ");
265
266
267                 function = header->next;
268             }
269         }
270         else
271             printf("CODE: ???, ");
272
273         if (info.lra != NIL)
274             printf("LRA: 0x%08lx, ", (unsigned long)info.lra);
275         else
276             printf("<no LRA>, ");
277
278         if (info.pc)
279             printf("PC: 0x%x>\n", info.pc);
280         else
281             printf("PC: ??\?>\n");
282
283     } while (--nframes > 0 && previous_info(&info));
284 }
285
286 #else
287
288 static int
289 altstack_pointer_p (void *p) {
290 #ifndef LISP_FEATURE_WIN32
291     void* stack_start = ((void *)arch_os_get_current_thread()) + dynamic_values_bytes;
292     void* stack_end = stack_start + 32*SIGSTKSZ;
293
294     return (p > stack_start && p <= stack_end);
295 #else
296     /* Win32 doesn't do altstack */
297     return 0;
298 #endif
299 }
300
301 static int
302 stack_pointer_p (void *p)
303 {
304   /* we are using sizeof(long) here, because that is the right value on both
305    * x86 and x86-64.  (But note that false positives would not cause much harm
306    * given the heuristical nature of x86_call_context.) */
307   unsigned long stack_alignment = sizeof(void*);
308
309   return (altstack_pointer_p(p)
310           || (p < (void *) arch_os_get_current_thread()->control_stack_end
311               && (p > (void *) &p || altstack_pointer_p(&p))
312               && (((unsigned long) p) & (stack_alignment-1)) == 0));
313 }
314
315 static int
316 ra_pointer_p (void *ra)
317 {
318   /* the check against 4096 is still a mystery to everyone interviewed about
319    * it, but recent changes to sb-sprof seem to suggest that such values
320    * do occur sometimes. */
321   return ((unsigned long) ra) > 4096 && !stack_pointer_p (ra);
322 }
323
324 static int
325 x86_call_context (void *fp, void **ra, void **ocfp)
326 {
327   void *c_ocfp;
328   void *c_ra;
329   int c_valid_p;
330
331   if (!stack_pointer_p(fp))
332     return 0;
333
334   c_ocfp    = *((void **) fp);
335   c_ra      = *((void **) fp + 1);
336
337   c_valid_p = (c_ocfp > fp
338                && stack_pointer_p(c_ocfp)
339                && ra_pointer_p(c_ra));
340
341   if (c_valid_p)
342     *ra = c_ra, *ocfp = c_ocfp;
343   else
344     return 0;
345
346   return 1;
347 }
348
349 struct compiled_debug_fun *
350 debug_function_from_pc (struct code* code, void *pc)
351 {
352   unsigned long code_header_len = sizeof(lispobj) * HeaderValue(code->header);
353   unsigned long offset
354     = (unsigned long) pc - (unsigned long) code - code_header_len;
355   struct compiled_debug_fun *df;
356   struct compiled_debug_info *di;
357   struct vector *v;
358   int i, len;
359
360   if (lowtag_of(code->debug_info) != INSTANCE_POINTER_LOWTAG)
361     return 0;
362
363   di = (struct compiled_debug_info *) native_pointer(code->debug_info);
364   v = (struct vector *) native_pointer(di->fun_map);
365   len = fixnum_value(v->length);
366   df = (struct compiled_debug_fun *) native_pointer(v->data[0]);
367
368   if (len == 1)
369     return df;
370
371   for (i = 1;; i += 2) {
372     unsigned next_pc;
373
374     if (i == len)
375       return ((struct compiled_debug_fun *) native_pointer(v->data[i - 1]));
376
377     if (offset >= (unsigned long)fixnum_value(df->elsewhere_pc)) {
378       struct compiled_debug_fun *p
379         = ((struct compiled_debug_fun *) native_pointer(v->data[i + 1]));
380       next_pc = fixnum_value(p->elsewhere_pc);
381     } else
382       next_pc = fixnum_value(v->data[i]);
383
384     if (offset < next_pc)
385       return ((struct compiled_debug_fun *) native_pointer(v->data[i - 1]));
386   }
387
388   return NULL;
389 }
390
391 static void
392 sbcl_putwc(wchar_t c, FILE *file)
393 {
394 #ifdef LISP_FEATURE_OS_PROVIDES_PUTWC
395     putwc(c, file);
396 #else
397     if (c < 256) {
398         fputc(c, file);
399     } else {
400         fputc('?', file);
401     }
402 #endif
403 }
404
405 static void
406 print_string (lispobj *object)
407 {
408   int tag = widetag_of(*object);
409   struct vector *vector = (struct vector *) object;
410
411 #define doit(TYPE)                              \
412   do {                                          \
413     int i;                                      \
414     int n = fixnum_value(vector->length);       \
415     TYPE *data = (TYPE *) vector->data;         \
416     for (i = 0; i < n; i++) {                   \
417       wchar_t c = (wchar_t) data[i];            \
418       if (c == '\\' || c == '"')                \
419         putchar('\\');                          \
420       sbcl_putwc(c, stdout);                    \
421     }                                           \
422   } while (0)
423
424   switch (tag) {
425   case SIMPLE_BASE_STRING_WIDETAG:
426     doit(unsigned char);
427     break;
428 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
429   case SIMPLE_CHARACTER_STRING_WIDETAG:
430     doit(unsigned int);
431     break;
432 #endif
433   default:
434     printf("<??? type %d>", tag);
435   }
436 #undef doit
437 }
438
439 static void
440 print_entry_name (lispobj name)
441 {
442   if (lowtag_of (name) == LIST_POINTER_LOWTAG) {
443     putchar('(');
444     while (name != NIL) {
445       struct cons *cons = (struct cons *) native_pointer(name);
446       print_entry_name(cons->car);
447       name = cons->cdr;
448       if (name != NIL)
449         putchar(' ');
450     }
451     putchar(')');
452   } else if (lowtag_of(name) == OTHER_POINTER_LOWTAG) {
453     lispobj *object = (lispobj *) native_pointer(name);
454     if (widetag_of(*object) == SYMBOL_HEADER_WIDETAG) {
455       struct symbol *symbol = (struct symbol *) object;
456       if (symbol->package != NIL) {
457         struct package *pkg
458           = (struct package *) native_pointer(symbol->package);
459         lispobj pkg_name = pkg->_name;
460         print_string(native_pointer(pkg_name));
461         fputs("::", stdout);
462       }
463       print_string(native_pointer(symbol->name));
464     } else if (widetag_of(*object) == SIMPLE_BASE_STRING_WIDETAG) {
465          putchar('"');
466          print_string(object);
467          putchar('"');
468 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
469       } else if (widetag_of(*object) == SIMPLE_CHARACTER_STRING_WIDETAG) {
470          putchar('"');
471          print_string(object);
472          putchar('"');
473 #endif
474     } else {
475       printf("<??? type %d>", (int) widetag_of(*object));
476     }
477   } else {
478     printf("<??? lowtag %d>", (int) lowtag_of(name));
479   }
480 }
481
482 static void
483 print_entry_points (struct code *code)
484 {
485   lispobj function = code->entry_points;
486
487   while (function != NIL) {
488     struct simple_fun *header = (struct simple_fun *) native_pointer(function);
489     print_entry_name(header->name);
490
491     function = header->next;
492     if (function != NIL)
493       printf (", ");
494   }
495 }
496
497 void
498 describe_thread_state(void)
499 {
500     sigset_t mask;
501     struct thread *thread = arch_os_get_current_thread();
502     struct interrupt_data *data = thread->interrupt_data;
503 #ifndef LISP_FEATURE_WIN32
504     get_current_sigmask(&mask);
505     printf("Signal mask:\n");
506     printf(" SIGALRM = %d\n", sigismember(&mask, SIGALRM));
507     printf(" SIGINT = %d\n", sigismember(&mask, SIGINT));
508     printf(" SIGPROF = %d\n", sigismember(&mask, SIGPROF));
509 #ifdef SIG_STOP_FOR_GC
510     printf(" SIG_STOP_FOR_GC = %d\n", sigismember(&mask, SIG_STOP_FOR_GC));
511 #endif
512 #endif
513     printf("Specials:\n");
514     printf(" *GC-INHIBIT* = %s\n", (SymbolValue(GC_INHIBIT, thread) == T) ? "T" : "NIL");
515     printf(" *GC-PENDING* = %s\n",
516            (SymbolValue(GC_PENDING, thread) == T) ?
517            "T" : ((SymbolValue(GC_PENDING, thread) == NIL) ?
518                   "NIL" : ":IN-PROGRESS"));
519     printf(" *INTERRUPTS-ENABLED* = %s\n", (SymbolValue(INTERRUPTS_ENABLED, thread) == T) ? "T" : "NIL");
520 #ifdef STOP_FOR_GC_PENDING
521     printf(" *STOP-FOR-GC-PENDING* = %s\n", (SymbolValue(STOP_FOR_GC_PENDING, thread) == T) ? "T" : "NIL");
522 #endif
523     printf("Pending handler = %p\n", data->pending_handler);
524 }
525
526 /* This function has been split from lisp_backtrace() to enable Lisp
527  * backtraces from gdb with call backtrace_from_fp(...). Useful for
528  * example when debugging threading deadlocks.
529  */
530 void
531 backtrace_from_fp(void *fp, int nframes)
532 {
533   int i;
534
535   for (i = 0; i < nframes; ++i) {
536     lispobj *p;
537     void *ra;
538     void *next_fp;
539
540     if (!x86_call_context(fp, &ra, &next_fp))
541       break;
542
543     printf("%4d: ", i);
544
545     p = (lispobj *) component_ptr_from_pc((lispobj *) ra);
546     if (p) {
547       struct code *cp = (struct code *) p;
548       struct compiled_debug_fun *df = debug_function_from_pc(cp, ra);
549       if (df)
550         print_entry_name(df->name);
551       else
552         print_entry_points(cp);
553     } else {
554 #ifdef LISP_FEATURE_OS_PROVIDES_DLADDR
555         Dl_info info;
556         if (dladdr(ra, &info)) {
557             printf("Foreign function %s, fp = 0x%lx, ra = 0x%lx",
558                    info.dli_sname,
559                    (unsigned long) next_fp,
560                    (unsigned long) ra);
561         } else
562 #endif
563         printf("Foreign fp = 0x%p, ra = 0x%p",
564                (void*) next_fp,
565                (void*) ra);
566     }
567
568     putchar('\n');
569     fp = next_fp;
570   }
571 }
572
573 void
574 lisp_backtrace(int nframes)
575 {
576   void *fp;
577
578 #if defined(LISP_FEATURE_X86)
579   asm("movl %%ebp,%0" : "=g" (fp));
580 #elif defined (LISP_FEATURE_X86_64)
581   asm("movq %%rbp,%0" : "=g" (fp));
582 #else
583 #error "How did we get here?"
584 #endif
585
586   backtrace_from_fp(fp, nframes);
587 }
588
589 #endif