source: release/1.7/source/lisp-kernel/plbt.c @ 15267

Last change on this file since 15267 was 13067, checked in by rme, 10 years ago

Update copyright notices.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 8.2 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, pc = 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    if (dladdr((void *)ptr_from_lispobj(pc), &info)) {
155      spname = (char *)(info.dli_sname);
156#ifdef DARWIN
157      if (spname[-1] != '_') {
158        --spname;
159      }
160#endif
161    }
162#endif
163#ifdef PPC64
164    Dprintf("(#x%016lX) #x%016lX : (subprimitive %s)", frame, pc, spname);
165#else
166    Dprintf("(#x%08X) #x%08X : (subprimitive %s)", frame, pc, spname);
167#endif
168  } else {
169    if ((fulltag_of(fun) != fulltag_misc) ||
170        (header_subtag(header_of(fun)) != subtag_function)) {
171#ifdef PPC64
172      Dprintf("(#x%016lX) #x%016lX : (not a function!)", frame, pc);
173#else
174      Dprintf("(#x%08X) #x%08X : (not a function!)", frame, pc);
175#endif
176    } else {
177      LispObj code_vector = deref(fun, 1);
178     
179      if ((pc >= (code_vector+misc_data_offset)) &&
180          (pc < ((code_vector+misc_data_offset)+(header_element_count(header_of(code_vector))<<2)))) {
181        delta = (pc - (code_vector+misc_data_offset));
182      }
183#ifdef PPC64
184      Dprintf("(#x%016lX) #x%016lX : %s + %d", frame, pc, print_lisp_object(fun), delta);
185#else
186      Dprintf("(#x%08X) #x%08X : %s + %d", frame, pc, print_lisp_object(fun), delta);
187#endif
188    }
189  }
190}
191
192
193void
194print_foreign_frame(void *frame)
195{
196#ifdef LINUX
197  natural pc = (natural) (((eabi_c_frame *)frame)->savelr);
198#endif
199#ifdef DARWIN
200  natural pc = (natural) (((c_frame *)frame)->savelr);
201#endif
202  Dl_info foreign_info;
203
204#ifndef STATIC
205  if (dladdr((void *)pc, &foreign_info)) {
206    Dprintf(
207#ifdef PPC64
208"(#x%016lx) #x%016lX : %s + %d"
209#else
210"(#x%08x) #x%08X : %s + %d"
211#endif
212, frame, pc, foreign_info.dli_sname,
213            pc-((long)foreign_info.dli_saddr));
214  } else {
215#endif
216    Dprintf(
217#ifdef PPC64
218"(#x%016X) #x%016X : foreign code (%s)"
219#else
220"(#x%08X) #x%08X : foreign code (%s)"
221#endif
222, frame, pc, "unknown");
223#ifndef STATIC
224  }
225#endif
226}
227
228
229/* Walk frames from "start" to "end".
230   Say whatever can be said about foreign frames and lisp frames.
231*/
232
233void
234walk_stack_frames(lisp_frame *start, lisp_frame *end) 
235{
236  lisp_frame *next;
237  Dprintf("\n");
238  while (start < end) {
239
240    if (lisp_frame_p(start)) {
241      print_lisp_frame(start);
242    } else {
243#ifdef DARWIN
244      print_foreign_frame((c_frame *)start);
245#else
246      print_foreign_frame((eabi_c_frame *)start);
247#endif
248    }
249   
250    next = start->backlink;
251    if (next == 0) {
252      next = end;
253    }
254    if (next < start) {
255      fprintf(dbgout, "Bad frame! (%x < %x)\n", next, start);
256      break;
257    }
258    start = next;
259  }
260}
261
262char *
263interrupt_level_description(TCR *tcr)
264{
265  signed_natural level = (signed_natural) TCR_INTERRUPT_LEVEL(tcr);
266  if (level < 0) {
267    if (tcr->interrupt_pending) {
268      return "disabled(pending)";
269    } else {
270      return "disabled";
271    }
272  } else {
273    return "enabled";
274  }
275}
276
277void
278walk_other_areas()
279{
280  TCR *start = (TCR *)get_tcr(true), *tcr = start->next;
281  area *a;
282  char *ilevel = interrupt_level_description(tcr);
283
284  while (tcr != start) {
285    a = tcr->cs_area;
286    Dprintf("\n\n TCR = 0x%lx, cstack area #x%lx,  native thread ID = 0x%lx, interrupts %s", tcr, a,  tcr->native_thread_id, ilevel);
287    walk_stack_frames((lisp_frame *) (a->active), (lisp_frame *) (a->high));
288    tcr = tcr->next;
289  }
290}
291
292void
293plbt_sp(LispObj currentSP)
294{
295  area *cs_area;
296 
297{
298    TCR *tcr = (TCR *)get_tcr(true);
299    char *ilevel = interrupt_level_description(tcr);
300    cs_area = tcr->cs_area;
301    if ((((LispObj) ptr_to_lispobj(cs_area->low)) > currentSP) ||
302        (((LispObj) ptr_to_lispobj(cs_area->high)) < currentSP)) {
303      Dprintf("\nStack pointer [#x%lX] in unknown area.", currentSP);
304    } else {
305      fprintf(dbgout, "current thread: tcr = 0x%lx, native thread ID = 0x%lx, interrupts %s\n", tcr, tcr->native_thread_id, ilevel);
306      walk_stack_frames((lisp_frame *) ptr_from_lispobj(currentSP), (lisp_frame *) (cs_area->high));
307      walk_other_areas();
308    }
309  } 
310}
311
312 
313void
314plbt(ExceptionInformation *xp)
315{
316  plbt_sp(xpGPR(xp, sp));
317}
318   
Note: See TracBrowser for help on using the repository browser.