source: release/1.9/source/lisp-kernel/xlbt.c @ 16083

Last change on this file since 16083 was 15003, checked in by rme, 8 years ago

Punt less often in pc_from_xcf().

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 5.3 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 "x86-utils.h"
19#include <stdio.h>
20#include <signal.h>
21
22natural
23pc_from_xcf(xcf *xcf)
24{
25  if (functionp(xcf->nominal_function)) {
26    LispObj fv = function_to_function_vector(xcf->nominal_function);
27    if (fv == xcf->containing_uvector) {
28      unsigned tag;
29
30#ifdef X8664
31      tag = tag_function;
32#else
33      tag = fulltag_misc;
34#endif
35      return unbox_fixnum(xcf->relative_pc) - tag;
36    } else {
37      LispObj tra = xcf->ra0;
38      LispObj f = tra_function(tra);
39
40      if (f && f == xcf->nominal_function)
41        return tra_offset(tra);
42    }
43  }
44  return 0;
45}
46
47void
48print_lisp_frame(lisp_frame *frame)
49{
50  LispObj pc = frame->tra, fun=0;
51  int delta = 0;
52
53  if (pc == lisp_global(RET1VALN)) {
54    pc = frame->xtra;
55  }
56#ifdef X8632
57  if (fulltag_of(pc) == fulltag_tra) {
58    if (*((unsigned char *)pc) == RECOVER_FN_OPCODE) {
59      natural n = *((natural *)(pc + 1));
60      fun = (LispObj)n;
61    }
62    if (fun && header_subtag(header_of(fun)) == subtag_function) {
63      delta = pc - fun;
64      Dprintf("(#x%08X) #x%08X : %s + %d", frame, pc, print_lisp_object(fun), delta);
65      return;
66    }
67  }
68  if (pc == 0) {
69    natural rpc = pc_from_xcf((xcf *)frame);
70
71    fun = ((xcf *)frame)->nominal_function;
72    fprintf(dbgout, "(#x%08X) #x%08X : %s + ", frame, pc,
73            print_lisp_object(fun));
74    if (rpc)
75      fprintf(dbgout, "%d\n", rpc);
76    else
77      fprintf(dbgout, "??\n", rpc);
78    return;
79  }
80#else
81  if (tag_of(pc) == tag_tra) {
82    if ((*((unsigned short *)pc) == RECOVER_FN_FROM_RIP_WORD0) &&
83        (*((unsigned char *)(pc+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
84      int sdisp = (*(int *) (pc+3));
85      fun = RECOVER_FN_FROM_RIP_LENGTH+pc+sdisp;
86    }
87    if (fulltag_of(fun) == fulltag_function) {
88      delta = pc - fun;
89      Dprintf("(#x%016lX) #x%016lX : %s + %d", frame, pc, print_lisp_object(fun), delta);
90      return;
91    }
92  }
93  if (pc == 0) {
94    natural rpc = pc_from_xcf((xcf *)frame);
95
96    fun = ((xcf *)frame)->nominal_function;
97    fprintf(dbgout, "(#x%016lX) #x%016lX : %s + ", frame, pc,
98            print_lisp_object(fun));
99    if (rpc)
100      fprintf(dbgout, "%d\n", rpc);
101    else
102      fprintf(dbgout, "??\n");
103    return;
104  }
105#endif
106}
107
108Boolean
109lisp_frame_p(lisp_frame *f)
110{
111  LispObj ra;
112
113  if (f) {
114    ra = f->tra;
115    if (ra == lisp_global(RET1VALN)) {
116      ra = f->xtra;
117    }
118
119#ifdef X8632
120    if (fulltag_of(ra) == fulltag_tra) {
121#else
122    if (tag_of(ra) == tag_tra) {
123#endif
124      return true;
125    } else if ((ra == lisp_global(LEXPR_RETURN)) ||
126               (ra == lisp_global(LEXPR_RETURN1V))) {
127      return true;
128    } else if (ra == 0) {
129      return true;
130    }
131  }
132  return false;
133}
134
135void
136walk_stack_frames(lisp_frame *start, lisp_frame *end) 
137{
138  lisp_frame *next;
139  Dprintf("\n");
140  while (start < end) {
141
142    if (lisp_frame_p(start)) {
143      print_lisp_frame(start);
144    } else {
145      if (start->backlink) {
146        fprintf(dbgout, "Bogus frame %lx\n", start);
147      }
148      return;
149    }
150   
151    next = start->backlink;
152    if (next == 0) {
153      next = end;
154    }
155    if (next < start) {
156      fprintf(dbgout, "Bad frame! (%x < %x)\n", next, start);
157      break;
158    }
159    start = next;
160  }
161}
162
163char *
164interrupt_level_description(TCR *tcr)
165{
166  signed_natural level = (signed_natural) TCR_INTERRUPT_LEVEL(tcr);
167  if (level < 0) {
168    if (tcr->interrupt_pending) {
169      return "disabled(pending)";
170    } else {
171      return "disabled";
172    }
173  } else {
174    return "enabled";
175  }
176}
177
178void
179plbt_sp(LispObj current_fp)
180{
181  area *vs_area, *cs_area;
182  TCR *tcr = (TCR *)get_tcr(true);
183  char *ilevel = interrupt_level_description(tcr);
184
185  vs_area = tcr->vs_area;
186  cs_area = TCR_AUX(tcr)->cs_area;
187  if ((((LispObj) ptr_to_lispobj(vs_area->low)) > current_fp) ||
188      (((LispObj) ptr_to_lispobj(vs_area->high)) < current_fp)) {
189    current_fp = (LispObj) (tcr->save_fp);
190  }
191  if ((((LispObj) ptr_to_lispobj(vs_area->low)) > current_fp) ||
192      (((LispObj) ptr_to_lispobj(vs_area->high)) < current_fp)) {
193    Dprintf("\nFrame pointer [#x" LISP "] in unknown area.", current_fp);
194  } else {
195    fprintf(dbgout, "current thread: tcr = 0x" LISP ", native thread ID = 0x" LISP ", interrupts %s\n", tcr, TCR_AUX(tcr)->native_thread_id, ilevel);
196
197#ifndef WINDOWS
198    if (lisp_global(BATCH_FLAG)) {
199      /*
200       * In batch mode, we will be exiting.  Reset some signal actions
201       * to the default to avoid a loop of "Unhandled exception 11" or
202       * whatever if we try to print some call stack that is totally
203       * screwed up.  (Instead, we'll just die horribly and get it
204       * over with.)
205       */
206      signal(SIGBUS, SIG_DFL);
207      signal(SIGSEGV, SIG_DFL);
208    }
209#endif
210
211    walk_stack_frames((lisp_frame *) ptr_from_lispobj(current_fp), (lisp_frame *) (vs_area->high));
212    /*      walk_other_areas();*/
213  }
214}
215
216
217void
218plbt(ExceptionInformation *xp)
219{
220  plbt_sp(xpGPR(xp, Ifp));
221}
Note: See TracBrowser for help on using the repository browser.