source: branches/working-0711/ccl/lisp-kernel/xlbt.c @ 12198

Last change on this file since 12198 was 12198, checked in by gz, 10 years ago

Merge with trunk kernel (and a few compiler changes to match): a few bug fixes, a lot of changes for other platforms.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 4.2 KB
Line 
1/*
2   Copyright (C) 2005 Clozure Associates
3   This file is part of OpenMCL. 
4
5   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
6   License , known as the LLGPL and distributed with OpenMCL as the
7   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
8   which is distributed with OpenMCL as the file "LGPL".  Where these
9   conflict, the preamble takes precedence. 
10
11   OpenMCL 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 currentRBP)
141{
142  area *vs_area, *cs_area;
143 
144{
145    TCR *tcr = (TCR *)get_tcr(true);
146    char *ilevel = interrupt_level_description(tcr);
147    vs_area = tcr->vs_area;
148    cs_area = tcr->cs_area;
149    if ((((LispObj) ptr_to_lispobj(vs_area->low)) > currentRBP) ||
150        (((LispObj) ptr_to_lispobj(vs_area->high)) < currentRBP)) {
151#ifdef X8664
152      currentRBP = (LispObj) (tcr->save_rbp);
153#else
154      currentRBP = (LispObj) (tcr->save_ebp);
155#endif
156    }
157    if ((((LispObj) ptr_to_lispobj(vs_area->low)) > currentRBP) ||
158        (((LispObj) ptr_to_lispobj(vs_area->high)) < currentRBP)) {
159      Dprintf("\nFramepointer [#x%lX] in unknown area.", currentRBP);
160    } else {
161      fprintf(dbgout, "current thread: tcr = 0x%lx, native thread ID = 0x%lx, interrupts %s\n", tcr, tcr->native_thread_id, ilevel);
162      walk_stack_frames((lisp_frame *) ptr_from_lispobj(currentRBP), (lisp_frame *) (vs_area->high));
163      /*      walk_other_areas();*/
164    }
165  } 
166}
167
168
169void
170plbt(ExceptionInformation *xp)
171{
172#ifdef X8632
173  plbt_sp(xpGPR(xp,Iebp));
174#else
175  plbt_sp(xpGPR(xp,Irbp));
176#endif
177}
Note: See TracBrowser for help on using the repository browser.