source: trunk/source/lisp-kernel/xlbt.c @ 14977

Last change on this file since 14977 was 14977, checked in by rme, 9 years ago

In print_lisp_frame(), when we're looking at an exception
callback frame, try to figure out and print the relative
pc of the function.

A new function pc_from_xcf(), patterend after the similarly
named lisp function, does the dirty work. It does not yet try
to decode the case where the nominal function and the containing
object are not the same thing.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 6.7 KB
Line 
1/*
2   Copyright (C) 2005-2009 Clozure Associates
3   This file is part of Clozure CL. 
4
5   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
6   License , known as the LLGPL and distributed with Clozure CL as the
7   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
8   which is distributed with Clozure CL as the file "LGPL".  Where these
9   conflict, the preamble takes precedence. 
10
11   Clozure CL is referenced in the preamble as the "LIBRARY."
12
13   The LLGPL is also available online at
14   http://opensource.franz.com/preamble.html
15*/
16
17#include "lispdcmd.h"
18#include <stdio.h>
19#include <signal.h>
20
21static LispObj
22function_to_function_vector(LispObj f)
23{
24#ifdef X8664
25  return f - fulltag_function + fulltag_misc;
26#else
27  return f;
28#endif
29}
30
31static Boolean
32functionp(LispObj f)
33{
34#ifdef X8664
35  return fulltag_of(f) == fulltag_function;
36#else
37  return fulltag_of(f) == fulltag_misc &&
38    header_subtag(header_of(f)) == subtag_function;
39#endif
40}
41
42static LispObj
43tra_function(LispObj tra)
44{
45  LispObj f = 0;
46
47#ifdef X8664
48  if (tag_of(tra) == tag_tra) {
49    if ((*((unsigned short *)tra) == RECOVER_FN_FROM_RIP_WORD0) &&
50        (*((unsigned char *)(tra+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
51      int sdisp = (*(int *) (tra+3));
52      f = RECOVER_FN_FROM_RIP_LENGTH+tra+sdisp;
53    }
54  }
55#else
56  if (fulltag_of(tra) == fulltag_tra) {
57    if (*((unsigned char *)tra) == RECOVER_FN_OPCODE) {
58      natural n = *((natural *)(tra + 1));
59      f = (LispObj)n;
60    }
61  }
62#endif
63  return f;
64}
65
66#if 0
67/* untested */
68static int
69tra_offset(LispObj tra)
70{
71#ifdef X8664
72  if (tag_of(tra) == tag_tra) {
73    if ((*((unsigned short *)tra) == RECOVER_FN_FROM_RIP_WORD0) &&
74        (*((unsigned char *)(tra+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
75      int sdisp = (*(int *) (tra+3));
76
77      sdisp = - sdisp;
78      sdisp -= RECOVER_FN_FROM_RIP_LENGTH;
79      return sdisp;
80    }
81  }
82#else
83  if (fulltag_of(tra) == fulltag_tra) {
84    if (*((unsigned char *)tra) == RECOVER_FN_OPCODE) {
85      int n = *((int *)(tra + 1));
86      n = n - tra;
87      n = -n;
88      return n;
89    }
90  }
91#endif
92  return 0;
93}
94#endif
95
96natural
97pc_from_xcf(xcf *xcf)
98{
99  if (functionp(xcf->nominal_function)) {
100    LispObj fv = function_to_function_vector(xcf->nominal_function);
101    if (fv == xcf->containing_uvector) {
102      unsigned tag;
103
104#ifdef X8664
105      tag = tag_function;
106#else
107      tag = fulltag_misc;
108#endif
109      return unbox_fixnum(xcf->relative_pc) - tag;
110    } else {
111      LispObj tra = xcf->ra0;
112      LispObj f = tra_function(tra);
113
114      if (f && f == xcf->nominal_function)
115        return 0; /* punt for now */
116    }
117  }
118  return 0;
119}
120
121void
122print_lisp_frame(lisp_frame *frame)
123{
124  LispObj pc = frame->tra, fun=0;
125  int delta = 0;
126
127  if (pc == lisp_global(RET1VALN)) {
128    pc = frame->xtra;
129  }
130#ifdef X8632
131  if (fulltag_of(pc) == fulltag_tra) {
132    if (*((unsigned char *)pc) == RECOVER_FN_OPCODE) {
133      natural n = *((natural *)(pc + 1));
134      fun = (LispObj)n;
135    }
136    if (fun && header_subtag(header_of(fun)) == subtag_function) {
137      delta = pc - fun;
138      Dprintf("(#x%08X) #x%08X : %s + %d", frame, pc, print_lisp_object(fun), delta);
139      return;
140    }
141  }
142  if (pc == 0) {
143    natural rpc = pc_from_xcf((xcf *)frame);
144
145    fun = ((xcf *)frame)->nominal_function;
146    fprintf(dbgout, "(#x%08X) #x%08X : %s + ", frame, pc,
147            print_lisp_object(fun));
148    if (rpc)
149      fprintf(dbgout, "%d\n", rpc);
150    else
151      fprintf(dbgout, "??\n", rpc);
152    return;
153  }
154#else
155  if (tag_of(pc) == tag_tra) {
156    if ((*((unsigned short *)pc) == RECOVER_FN_FROM_RIP_WORD0) &&
157        (*((unsigned char *)(pc+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
158      int sdisp = (*(int *) (pc+3));
159      fun = RECOVER_FN_FROM_RIP_LENGTH+pc+sdisp;
160    }
161    if (fulltag_of(fun) == fulltag_function) {
162      delta = pc - fun;
163      Dprintf("(#x%016lX) #x%016lX : %s + %d", frame, pc, print_lisp_object(fun), delta);
164      return;
165    }
166  }
167  if (pc == 0) {
168    natural rpc = pc_from_xcf((xcf *)frame);
169
170    fun = ((xcf *)frame)->nominal_function;
171    fprintf(dbgout, "(#x%016lX) #x%016lX : %s + ", frame, pc,
172            print_lisp_object(fun));
173    if (rpc)
174      fprintf(dbgout, "%d\n", rpc);
175    else
176      fprintf(dbgout, "??\n");
177    return;
178  }
179#endif
180}
181
182Boolean
183lisp_frame_p(lisp_frame *f)
184{
185  LispObj ra;
186
187  if (f) {
188    ra = f->tra;
189    if (ra == lisp_global(RET1VALN)) {
190      ra = f->xtra;
191    }
192
193#ifdef X8632
194    if (fulltag_of(ra) == fulltag_tra) {
195#else
196    if (tag_of(ra) == tag_tra) {
197#endif
198      return true;
199    } else if ((ra == lisp_global(LEXPR_RETURN)) ||
200               (ra == lisp_global(LEXPR_RETURN1V))) {
201      return true;
202    } else if (ra == 0) {
203      return true;
204    }
205  }
206  return false;
207}
208
209void
210walk_stack_frames(lisp_frame *start, lisp_frame *end) 
211{
212  lisp_frame *next;
213  Dprintf("\n");
214  while (start < end) {
215
216    if (lisp_frame_p(start)) {
217      print_lisp_frame(start);
218    } else {
219      if (start->backlink) {
220        fprintf(dbgout, "Bogus frame %lx\n", start);
221      }
222      return;
223    }
224   
225    next = start->backlink;
226    if (next == 0) {
227      next = end;
228    }
229    if (next < start) {
230      fprintf(dbgout, "Bad frame! (%x < %x)\n", next, start);
231      break;
232    }
233    start = next;
234  }
235}
236
237char *
238interrupt_level_description(TCR *tcr)
239{
240  signed_natural level = (signed_natural) TCR_INTERRUPT_LEVEL(tcr);
241  if (level < 0) {
242    if (tcr->interrupt_pending) {
243      return "disabled(pending)";
244    } else {
245      return "disabled";
246    }
247  } else {
248    return "enabled";
249  }
250}
251
252void
253plbt_sp(LispObj current_fp)
254{
255  area *vs_area, *cs_area;
256  TCR *tcr = (TCR *)get_tcr(true);
257  char *ilevel = interrupt_level_description(tcr);
258
259  vs_area = tcr->vs_area;
260  cs_area = TCR_AUX(tcr)->cs_area;
261  if ((((LispObj) ptr_to_lispobj(vs_area->low)) > current_fp) ||
262      (((LispObj) ptr_to_lispobj(vs_area->high)) < current_fp)) {
263    current_fp = (LispObj) (tcr->save_fp);
264  }
265  if ((((LispObj) ptr_to_lispobj(vs_area->low)) > current_fp) ||
266      (((LispObj) ptr_to_lispobj(vs_area->high)) < current_fp)) {
267    Dprintf("\nFrame pointer [#x" LISP "] in unknown area.", current_fp);
268  } else {
269    fprintf(dbgout, "current thread: tcr = 0x" LISP ", native thread ID = 0x" LISP ", interrupts %s\n", tcr, TCR_AUX(tcr)->native_thread_id, ilevel);
270
271#ifndef WINDOWS
272    if (lisp_global(BATCH_FLAG)) {
273      /*
274       * In batch mode, we will be exiting.  Reset some signal actions
275       * to the default to avoid a loop of "Unhandled exception 11" or
276       * whatever if we try to print some call stack that is totally
277       * screwed up.  (Instead, we'll just die horribly and get it
278       * over with.)
279       */
280      signal(SIGBUS, SIG_DFL);
281      signal(SIGSEGV, SIG_DFL);
282    }
283#endif
284
285    walk_stack_frames((lisp_frame *) ptr_from_lispobj(current_fp), (lisp_frame *) (vs_area->high));
286    /*      walk_other_areas();*/
287  }
288}
289
290
291void
292plbt(ExceptionInformation *xp)
293{
294  plbt_sp(xpGPR(xp, Ifp));
295}
Note: See TracBrowser for help on using the repository browser.