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

Last change on this file since 14261 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: 4.1 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
20
21
22void
23print_lisp_frame(lisp_frame *frame)
24{
25  LispObj pc = frame->tra, fun=0;
26  int delta = 0;
27
28  if (pc == lisp_global(RET1VALN)) {
29    pc = frame->xtra;
30  }
31#ifdef X8632
32  if (fulltag_of(pc) == fulltag_tra) {
33    if (*((unsigned char *)pc) == RECOVER_FN_OPCODE) {
34      natural n = *((natural *)(pc + 1));
35      fun = (LispObj)n;
36    }
37    if (fun && header_subtag(header_of(fun)) == subtag_function) {
38      delta = pc - fun;
39      Dprintf("(#x%08X) #x%08X : %s + %d", frame, pc, print_lisp_object(fun), delta);
40      return;
41    }
42  }
43  if (pc == 0) {
44    fun = ((xcf *)frame)->nominal_function;
45    Dprintf("(#x%08X) #x%08X : %s + ??", frame, pc, print_lisp_object(fun));
46    return;
47  }
48#else
49  if (tag_of(pc) == tag_tra) {
50    if ((*((unsigned short *)pc) == RECOVER_FN_FROM_RIP_WORD0) &&
51        (*((unsigned char *)(pc+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
52      int sdisp = (*(int *) (pc+3));
53      fun = RECOVER_FN_FROM_RIP_LENGTH+pc+sdisp;
54    }
55    if (fulltag_of(fun) == fulltag_function) {
56      delta = pc - fun;
57      Dprintf("(#x%016lX) #x%016lX : %s + %d", frame, pc, print_lisp_object(fun), delta);
58      return;
59    }
60  }
61  if (pc == 0) {
62    fun = ((xcf *)frame)->nominal_function;
63    Dprintf("(#x%016lX) #x%016lX : %s + ??", frame, pc, print_lisp_object(fun));
64    return;
65  }
66#endif
67}
68
69Boolean
70lisp_frame_p(lisp_frame *f)
71{
72  LispObj ra;
73
74  if (f) {
75    ra = f->tra;
76    if (ra == lisp_global(RET1VALN)) {
77      ra = f->xtra;
78    }
79
80#ifdef X8632
81    if (fulltag_of(ra) == fulltag_tra) {
82#else
83    if (tag_of(ra) == tag_tra) {
84#endif
85      return true;
86    } else if ((ra == lisp_global(LEXPR_RETURN)) ||
87               (ra == lisp_global(LEXPR_RETURN1V))) {
88      return true;
89    } else if (ra == 0) {
90      return true;
91    }
92  }
93  return false;
94}
95
96void
97walk_stack_frames(lisp_frame *start, lisp_frame *end) 
98{
99  lisp_frame *next;
100  Dprintf("\n");
101  while (start < end) {
102
103    if (lisp_frame_p(start)) {
104      print_lisp_frame(start);
105    } else {
106      if (start->backlink) {
107        fprintf(dbgout, "Bogus  frame %lx\n", start);
108      }
109      return;
110    }
111   
112    next = start->backlink;
113    if (next == 0) {
114      next = end;
115    }
116    if (next < start) {
117      fprintf(dbgout, "Bad frame! (%x < %x)\n", next, start);
118      break;
119    }
120    start = next;
121  }
122}
123
124char *
125interrupt_level_description(TCR *tcr)
126{
127  signed_natural level = (signed_natural) TCR_INTERRUPT_LEVEL(tcr);
128  if (level < 0) {
129    if (tcr->interrupt_pending) {
130      return "disabled(pending)";
131    } else {
132      return "disabled";
133    }
134  } else {
135    return "enabled";
136  }
137}
138
139void
140plbt_sp(LispObj current_fp)
141{
142  area *vs_area, *cs_area;
143  TCR *tcr = (TCR *)get_tcr(true);
144  char *ilevel = interrupt_level_description(tcr);
145
146  vs_area = tcr->vs_area;
147  cs_area = tcr->cs_area;
148  if ((((LispObj) ptr_to_lispobj(vs_area->low)) > current_fp) ||
149      (((LispObj) ptr_to_lispobj(vs_area->high)) < current_fp)) {
150    current_fp = (LispObj) (tcr->save_fp);
151  }
152  if ((((LispObj) ptr_to_lispobj(vs_area->low)) > current_fp) ||
153      (((LispObj) ptr_to_lispobj(vs_area->high)) < current_fp)) {
154    Dprintf("\nFrame pointer [#x" LISP "] in unknown area.", current_fp);
155  } else {
156    fprintf(dbgout, "current thread: tcr = 0x" LISP ", native thread ID = 0x" LISP ", interrupts %s\n", tcr, tcr->native_thread_id, ilevel);
157    walk_stack_frames((lisp_frame *) ptr_from_lispobj(current_fp), (lisp_frame *) (vs_area->high));
158    /*      walk_other_areas();*/
159  }
160}
161
162
163void
164plbt(ExceptionInformation *xp)
165{
166#ifdef X8632
167  plbt_sp(xpGPR(xp,Iebp));
168#else
169  plbt_sp(xpGPR(xp,Irbp));
170#endif
171}
Note: See TracBrowser for help on using the repository browser.