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

Last change on this file since 14261 was 14119, checked in by gb, 9 years ago

Changes from ARM branch. Need testing ...

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    if (dladdr((void *)ptr_from_lispobj(rpc), &info)) {
155      spname = (char *)(info.dli_sname);
156#ifdef DARWIN
157      if (spname[-1] != '_') {
158        --spname;
159      }
160#endif
161    }
162#endif
163    Dprintf("(#x%08X) #x%08X : (subprimitive %s)", frame, rpc, spname);
164  } else {
165    if ((fulltag_of(fun) != fulltag_misc) ||
166        (header_subtag(header_of(fun)) != subtag_function)) {
167      Dprintf("(#x%08X) #x%08X : (not a function!)", frame, rpc);
168    } else {
169      LispObj code_vector = deref(fun, 2);
170     
171      if ((rpc >= (code_vector+misc_data_offset)) &&
172          (rpc < ((code_vector+misc_data_offset)+(header_element_count(header_of(code_vector))<<2)))) {
173        delta = (rpc - (code_vector+misc_data_offset));
174      }
175      Dprintf("(#x%08X) #x%08X : %s + %d", frame, rpc, print_lisp_object(fun), delta);
176    }
177  }
178}
179
180
181
182
183/* Walk frames from "start" to "end".
184   Say whatever can be said about foreign frames and lisp frames.
185*/
186
187void
188walk_stack_frames(lisp_frame *start, lisp_frame *end) 
189{
190  lisp_frame *next;
191  Dprintf("\n");
192  while (start < end) {
193
194    if (lisp_frame_p(start)) {
195      print_lisp_frame(start);
196      next = start + 1;     
197    } else {
198      LispObj *current = (LispObj *)start,
199        header = *current;
200      int tag = fulltag_of(header);
201      natural elements;
202
203      if (immheader_tag_p(tag)) {
204        next = (lisp_frame *)skip_over_ivector((natural)current, header);
205      } else if (nodeheader_tag_p(tag)) {
206        elements = (header_element_count(header)+2)&~1;
207        next = (lisp_frame *)(current+elements);
208      } else if (header == stack_alloc_marker) {
209        next = (lisp_frame *)(current[1]);
210      } else {
211        fprintf(dbgout, "Bad frame! (0x%x)\n", start);
212        next = end;
213      }
214    }
215    start = next;
216  }
217}
218
219char *
220interrupt_level_description(TCR *tcr)
221{
222  signed_natural level = (signed_natural) TCR_INTERRUPT_LEVEL(tcr);
223  if (level < 0) {
224    if (tcr->interrupt_pending) {
225      return "disabled(pending)";
226    } else {
227      return "disabled";
228    }
229  } else {
230    return "enabled";
231  }
232}
233
234void
235walk_other_areas()
236{
237  TCR *start = (TCR *)get_tcr(true), *tcr = start->next;
238  area *a;
239  char *ilevel = interrupt_level_description(tcr);
240
241  while (tcr != start) {
242    a = tcr->cs_area;
243    Dprintf("\n\n TCR = 0x%lx, cstack area #x%lx,  native thread ID = 0x%lx, interrupts %s", tcr, a,  tcr->native_thread_id, ilevel);
244    walk_stack_frames((lisp_frame *) (a->active), (lisp_frame *) (a->high));
245    tcr = tcr->next;
246  }
247}
248
249void
250plbt_sp(LispObj currentSP)
251{
252  area *cs_area;
253 
254{
255    TCR *tcr = (TCR *)get_tcr(true);
256    char *ilevel = interrupt_level_description(tcr);
257    cs_area = tcr->cs_area;
258    if ((((LispObj) ptr_to_lispobj(cs_area->low)) > currentSP) ||
259        (((LispObj) ptr_to_lispobj(cs_area->high)) < currentSP)) {
260      Dprintf("\nStack pointer [#x%lX] in unknown area.", currentSP);
261    } else {
262      fprintf(dbgout, "current thread: tcr = 0x%lx, native thread ID = 0x%lx, interrupts %s\n", tcr, tcr->native_thread_id, ilevel);
263      walk_stack_frames((lisp_frame *) ptr_from_lispobj(currentSP), (lisp_frame *) (cs_area->high));
264      walk_other_areas();
265    }
266  } 
267}
268
269 
270void
271plbt(ExceptionInformation *xp)
272{
273  plbt_sp(xpGPR(xp, Rsp));
274}
275   
Note: See TracBrowser for help on using the repository browser.