source: trunk/source/lisp-kernel/albt.c @ 14347

Last change on this file since 14347 was 14276, checked in by gb, 9 years ago

Android doesn't have dladdr(), presumably because it might be useful.

File size: 7.6 KB
Line 
1/*
2   Copyright (C) 2009 Clozure Associates
3   Copyright (C) 1994-2001 Digitool, Inc
4   This file is part of Clozure CL. 
5
6   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7   License , known as the LLGPL and distributed with Clozure CL as the
8   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9   which is distributed with Clozure CL as the file "LGPL".  Where these
10   conflict, the preamble takes precedence. 
11
12   Clozure CL is referenced in the preamble as the "LIBRARY."
13
14   The LLGPL is also available online at
15   http://opensource.franz.com/preamble.html
16*/
17
18#include "lispdcmd.h"
19#ifdef LINUX
20#define __USE_GNU 1
21#include <dlfcn.h>
22#endif
23
24#ifdef DARWIN
25#if 0
26#undef undefined
27#include <stdint.h>
28#include <mach-o/dyld.h>
29#include <mach-o/nlist.h>
30
31typedef struct dl_info {
32  const char      *dli_fname;     /* Pathname of shared object */
33  void            *dli_fbase;     /* Base address of shared object */
34  const char      *dli_sname;     /* Name of nearest symbol */
35  void            *dli_saddr;     /* Address of nearest symbol */
36} Dl_info;
37
38int
39darwin_dladdr(void *p, Dl_info *info)
40{
41  unsigned long i;
42  unsigned long j;
43  uint32_t count = _dyld_image_count();
44  struct mach_header *mh = 0;
45  struct load_command *lc = 0;
46  unsigned long addr = 0;
47  unsigned long table_off = (unsigned long)0;
48  int found = 0;
49
50  if (!info)
51    return 0;
52  info->dli_fname = 0;
53  info->dli_fbase = 0;
54  info->dli_sname = 0;
55  info->dli_saddr = 0;
56  /* Some of this was swiped from code posted by Douglas Davidson
57   * <ddavidso AT apple DOT com> to darwin-development AT lists DOT
58   * apple DOT com and slightly modified
59   */
60  for (i = 0; i < count; i++) {
61    addr = (unsigned long)p - _dyld_get_image_vmaddr_slide(i);
62    mh = (struct mach_header *)_dyld_get_image_header(i);
63    if (mh) {
64      lc = (struct load_command *)((char *)mh + sizeof(struct mach_header));
65      for (j = 0; j < mh->ncmds; j++, lc = (struct load_command *)((char *)lc + lc->cmdsize)) {
66        if (LC_SEGMENT == lc->cmd &&
67            addr >= ((struct segment_command *)lc)->vmaddr &&
68            addr <
69            ((struct segment_command *)lc)->vmaddr + ((struct segment_command *)lc)->vmsize) {
70          info->dli_fname = _dyld_get_image_name(i);
71          info->dli_fbase = (void *)mh;
72          found = 1;
73          break;
74        }
75      }
76      if (found) {
77            break;
78      }
79    }
80  }
81  if (!found) {
82    return 0;
83  }
84  lc = (struct load_command *)((char *)mh + sizeof(struct mach_header));
85  for (j = 0;
86       j < mh->ncmds;
87       j++, lc = (struct load_command *)((char *)lc + lc->cmdsize)) {
88    if (LC_SEGMENT == lc->cmd) {
89      if (!strcmp(((struct segment_command *)lc)->segname, "__LINKEDIT"))
90        break;
91    }
92  }
93  table_off =
94    ((unsigned long)((struct segment_command *)lc)->vmaddr) -
95    ((unsigned long)((struct segment_command *)lc)->fileoff) + _dyld_get_image_vmaddr_slide(i);
96 
97  lc = (struct load_command *)((char *)mh + sizeof(struct mach_header));
98  for (j = 0;
99       j < mh->ncmds;
100       j++, lc = (struct load_command *)((char *)lc + lc->cmdsize)) {
101    if (LC_SYMTAB == lc->cmd) {
102      struct nlist *symtable = (struct nlist *)(((struct symtab_command *)lc)->symoff + table_off);
103      unsigned long numsyms = ((struct symtab_command *)lc)->nsyms;
104      struct nlist *nearest = NULL;
105      unsigned long diff = 0xffffffff;
106      unsigned long strtable = (unsigned long)(((struct symtab_command *)lc)->stroff + table_off);
107      for (i = 0; i < numsyms; i++) {
108        /* fprintf(dbgout,"%s : 0x%08x, 0x%x\n",(char *)(strtable + symtable->n_un.n_strx) ,symtable->n_value, symtable->n_type); */
109        /* Ignore the following kinds of Symbols */
110        if ((!symtable->n_value)        /* Undefined */
111            || (symtable->n_type & N_STAB)      /* Debug symbol */
112            || ((symtable->n_type & N_TYPE) != N_SECT)  /* Absolute, indirect, ... */
113            ) {
114          symtable++;
115          continue;
116        }
117        if ((addr >= symtable->n_value) &&
118            (diff >= addr - (symtable->n_value ))) {
119          diff = addr- (unsigned long)symtable->n_value;
120          nearest = symtable;
121        }
122        symtable++;
123      }
124      if (nearest) {
125        info->dli_saddr = nearest->n_value + ((void *)p - addr);
126        info->dli_sname = (char *)(strtable + nearest->n_un.n_strx);
127      }
128    }
129  }
130  return 1;
131}
132
133#define dladdr darwin_dladdr
134#else
135#include <dlfcn.h>
136#endif
137#endif
138
139
140
141extern Boolean lisp_frame_p(lisp_frame *);
142
143void
144print_lisp_frame(lisp_frame *frame)
145{
146  LispObj fun = frame->savefn, rpc = frame->savelr;
147  int delta = 0;
148  Dl_info info;
149  char *spname;
150
151  if ((fun == 0) || (fun == fulltag_misc)) {
152    spname = "unknown ?";
153#ifndef STATIC
154#ifndef ANDROID
155    if (dladdr((void *)ptr_from_lispobj(rpc), &info)) {
156      spname = (char *)(info.dli_sname);
157#ifdef DARWIN
158      if (spname[-1] != '_') {
159        --spname;
160      }
161#endif
162    }
163#endif
164#endif
165    Dprintf("(#x%08X) #x%08X : (subprimitive %s)", frame, rpc, spname);
166  } else {
167    if ((fulltag_of(fun) != fulltag_misc) ||
168        (header_subtag(header_of(fun)) != subtag_function)) {
169      Dprintf("(#x%08X) #x%08X : (not a function!)", frame, rpc);
170    } else {
171      LispObj code_vector = deref(fun, 2);
172     
173      if ((rpc >= (code_vector+misc_data_offset)) &&
174          (rpc < ((code_vector+misc_data_offset)+(header_element_count(header_of(code_vector))<<2)))) {
175        delta = (rpc - (code_vector+misc_data_offset));
176      }
177      Dprintf("(#x%08X) #x%08X : %s + %d", frame, rpc, print_lisp_object(fun), delta);
178    }
179  }
180}
181
182
183
184
185/* Walk frames from "start" to "end".
186   Say whatever can be said about foreign frames and lisp frames.
187*/
188
189void
190walk_stack_frames(lisp_frame *start, lisp_frame *end) 
191{
192  lisp_frame *next;
193  Dprintf("\n");
194  while (start < end) {
195
196    if (lisp_frame_p(start)) {
197      print_lisp_frame(start);
198      next = start + 1;     
199    } else {
200      LispObj *current = (LispObj *)start,
201        header = *current;
202      int tag = fulltag_of(header);
203      natural elements;
204
205      if (immheader_tag_p(tag)) {
206        next = (lisp_frame *)skip_over_ivector((natural)current, header);
207      } else if (nodeheader_tag_p(tag)) {
208        elements = (header_element_count(header)+2)&~1;
209        next = (lisp_frame *)(current+elements);
210      } else if (header == stack_alloc_marker) {
211        next = (lisp_frame *)(current[1]);
212      } else {
213        fprintf(dbgout, "Bad frame! (0x%x)\n", start);
214        next = end;
215      }
216    }
217    start = next;
218  }
219}
220
221char *
222interrupt_level_description(TCR *tcr)
223{
224  signed_natural level = (signed_natural) TCR_INTERRUPT_LEVEL(tcr);
225  if (level < 0) {
226    if (tcr->interrupt_pending) {
227      return "disabled(pending)";
228    } else {
229      return "disabled";
230    }
231  } else {
232    return "enabled";
233  }
234}
235
236void
237walk_other_areas()
238{
239  TCR *start = (TCR *)get_tcr(true), *tcr = start->next;
240  area *a;
241  char *ilevel = interrupt_level_description(tcr);
242
243  while (tcr != start) {
244    a = tcr->cs_area;
245    Dprintf("\n\n TCR = 0x%lx, cstack area #x%lx,  native thread ID = 0x%lx, interrupts %s", tcr, a,  tcr->native_thread_id, ilevel);
246    walk_stack_frames((lisp_frame *) (a->active), (lisp_frame *) (a->high));
247    tcr = tcr->next;
248  }
249}
250
251void
252plbt_sp(LispObj currentSP)
253{
254  area *cs_area;
255 
256{
257    TCR *tcr = (TCR *)get_tcr(true);
258    char *ilevel = interrupt_level_description(tcr);
259    cs_area = tcr->cs_area;
260    if ((((LispObj) ptr_to_lispobj(cs_area->low)) > currentSP) ||
261        (((LispObj) ptr_to_lispobj(cs_area->high)) < currentSP)) {
262      Dprintf("\nStack pointer [#x%lX] in unknown area.", currentSP);
263    } else {
264      fprintf(dbgout, "current thread: tcr = 0x%lx, native thread ID = 0x%lx, interrupts %s\n", tcr, tcr->native_thread_id, ilevel);
265      walk_stack_frames((lisp_frame *) ptr_from_lispobj(currentSP), (lisp_frame *) (cs_area->high));
266      walk_other_areas();
267    }
268  } 
269}
270
271 
272void
273plbt(ExceptionInformation *xp)
274{
275  plbt_sp(xpGPR(xp, Rsp));
276}
277   
Note: See TracBrowser for help on using the repository browser.