source: release/1.7/source/lisp-kernel/xlbt.c @ 15267

Last change on this file since 15267 was 15099, checked in by rme, 8 years ago

Revert r15026.

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