source: trunk/ccl/lisp-kernel/xlbt.c @ 6910

Last change on this file since 6910 was 6910, checked in by gb, 13 years ago

Basically, all frames on the vstack are lisp frames.

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