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