source: trunk/source/lisp-kernel/lisp-debug.c @ 14484

Last change on this file since 14484 was 14484, checked in by rme, 10 years ago

When in batch mode, reset the signal action for SIGSEGV and SIGBUS
to the default before trying to print a backtrace in the lisp kernel
debugger. The idea is to avoid looping on "unhandled exception 11"
or whatever when trying to print out a trashed call stack.

Also print version information before the backtrace, so that we see
it if printing the backtrace fails.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 36.9 KB
Line 
1/*
2   Copyright (C) 2009 Clozure Associates
3   Copyright (C) 1994-2001 Digitool, Inc
4   This file is part of Clozure CL. 
5
6   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7   License , known as the LLGPL and distributed with Clozure CL as the
8   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9   which is distributed with Clozure CL as the file "LGPL".  Where these
10   conflict, the preamble takes precedence. 
11
12   Clozure CL is referenced in the preamble as the "LIBRARY."
13
14   The LLGPL is also available online at
15   http://opensource.franz.com/preamble.html
16*/
17
18#include "lisp.h"
19#include "lisp-exceptions.h"
20#include "lisp_globals.h"
21#include "area.h"
22#include "threads.h"
23#include <ctype.h>
24#include <stdio.h>
25#include <stddef.h>
26#include <string.h>
27#include <stdarg.h>
28#include <errno.h>
29#include <stdio.h>
30
31#ifdef WINDOWS
32#include <fcntl.h>
33#else
34#include <sys/socket.h>
35#include <dlfcn.h>
36#endif
37#include <sys/stat.h>
38
39FILE *dbgout = NULL;
40
41typedef enum {
42  debug_continue,               /* stay in the repl */
43  debug_exit_success,           /* return 0 from lisp_Debugger */
44  debug_exit_fail,              /* return non-zero from lisp_Debugger */
45  debug_kill
46} debug_command_return;
47
48#ifdef SVN_REVISION
49#define xstr(s) str(s)
50#define str(s) #s
51char *kernel_svn_revision = xstr(SVN_REVISION);
52#undef xstr
53#undef str
54#else
55char *kernel_svn_revision = "unknown";
56#endif
57
58Boolean
59open_debug_output(int fd)
60{
61  FILE *f = fdopen(fd, "w");
62 
63  if (f) {
64    if (setvbuf(f, NULL, _IONBF, 0) == 0) {
65#ifdef WINDOWS
66      if (fileno(stdin) < 0) {
67        stdin->_file = 0;
68      }
69#endif
70      dbgout = f;
71      return true;
72    }
73    fclose(f);
74  }
75  return false;
76}
77
78
79typedef debug_command_return (*debug_command) (ExceptionInformation *,
80                                               siginfo_t *,
81                                               int);
82
83#define DEBUG_COMMAND_FLAG_REQUIRE_XP 1 /* function  */
84#define DEBUG_COMMAND_FLAG_AUX_REGNO  (2 | DEBUG_COMMAND_FLAG_REQUIRE_XP)
85#define DEBUG_COMMAND_FLAG_AUX_SPR (4 | DEBUG_COMMAND_FLAG_REQUIRE_XP)
86#define DEBUG_COMMAND_REG_FLAGS 7
87#define DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY 8
88#define DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG 16
89
90typedef struct {
91  debug_command f;
92  char *help_text;
93  unsigned flags;
94  char *aux_prompt;
95  int c;
96} debug_command_entry;
97
98
99extern
100debug_command_entry debug_command_entries[];
101
102Boolean lisp_debugger_in_foreign_code = false;
103
104#ifndef WINDOWS
105Boolean
106stdin_is_dev_null()
107{
108  struct stat fd0stat, devnullstat;
109
110  if (fstat(fileno(stdin),&fd0stat)) {
111    return true;
112  }
113  if (stat("/dev/null",&devnullstat)) {
114    return true;
115  }
116  return ((fd0stat.st_ino == devnullstat.st_ino) &&
117          (fd0stat.st_dev == devnullstat.st_dev));
118}
119#endif
120
121#ifdef WINDOWS
122Boolean
123stdin_is_dev_null()
124{
125  HANDLE stdIn;
126  stdIn = GetStdHandle(STD_INPUT_HANDLE);
127  return (stdIn == NULL);
128}
129#endif
130
131
132
133
134char *
135foreign_name_and_offset(natural addr, int *delta)
136{
137#ifndef WINDOWS
138  Dl_info info;
139#endif
140  char *ret = NULL;
141
142  if (delta) {
143    *delta = 0;
144  }
145#ifndef WINDOWS
146#ifndef ANDROID
147  if (dladdr((void *)addr, &info)) {
148    ret = (char *)info.dli_sname;
149    if (delta) {
150      *delta = ((natural)addr - (natural)info.dli_saddr);
151    }
152  }
153#endif
154#endif
155  return ret;
156}
157
158
159#if defined(LINUX) || defined(SOLARIS)
160#define fpurge __fpurge
161#endif
162
163#ifdef WINDOWS
164void
165fpurge (FILE* file)
166{
167}
168#endif
169
170int
171readc()
172{
173  unsigned tries = 1000;
174  int c;
175
176  while (tries) {
177    c = getchar();
178    switch(c) {
179    case '\n':
180      continue;
181    case '\r':
182      continue;
183    case EOF:
184      if (ferror(stdin)) {
185        if ((errno == EINTR) || (errno == EIO)) {
186          clearerr(stdin);
187          tries--;
188          continue;
189        }
190      }
191      /* fall through */
192    default:
193      return c;
194    }
195  }
196  return EOF;
197}
198
199#ifdef X8664
200#ifdef LINUX
201char* Iregnames[] = {"r8 ","r9 ","r10","r11","r12","r13","r14","r15",
202                     "rdi","rsi","rbp", "rbx", "rdx", "rax", "rcx","rsp"};
203#endif
204#ifdef SOLARIS
205char* Iregnames[] = {"r15 ","r14 ","r13","r12","r11","r10","r9 ","r8 ",
206                     "rdi","rsi","rbp", "rbx", "rdx", "rcx", "rcx","rsp"};
207#endif
208#ifdef FREEBSD
209char* Iregnames[] = {"???", "rdi", "rsi", "rdx", "rcx", "r8 ", "r9 ", "rax",
210                     "rbx", "rbp", "r10", "r11", "r12", "r13", "r14", "r15",
211                     "???", "???", "???", "???", "???", "???", "???", "rsp"};
212#endif
213#ifdef DARWIN
214char* Iregnames[] = {"rax", "rbx", "rcx", "rdx", "rdi", "rsi",
215                     "rbp", "rsp", "r8 ", "r9 ", "r10", "r11", "r12", "r13",
216                     "r14", "r15", "rip", "rfl"};
217#endif
218#ifdef WINDOWS
219char* Iregnames[] = {"rax ","rcx ","rdx","rbx","rsp","rrbp","rsi","rdi",
220                     "r8","r9","r10", "r11", "r12", "r13", "r14","r15"};
221#endif
222#endif
223
224#ifdef X8632
225#ifdef DARWIN
226char *Iregnames[] = {"eax", "ebx", "ecx", "edx", "edi", "esi",
227                     "ebp", "???", "efl", "eip"};
228#endif
229#ifdef LINUX
230char *Iregnames[] = {"???", "???", "???", "???",
231                     "edi", "esi", "ebp", "esp",
232                     "ebx", "edx", "ecx", "eax",
233                     "???", "???", "eip", "???", "efl"};
234#endif
235#ifdef WINDOWS
236char *Iregnames[] = {"edi", "esi", "ebx", "edx", "ecx", "eax",
237                     "ebp", "eip", "???", "efl", "esp"};
238#endif
239#ifdef FREEBSD
240char *Iregnames[] = {"???", "???", "???", "???", "???"
241                     "edi", "esi", "ebp", "ebx", "edx", 
242                     "ecx", "eax", "???", "???", "eip",
243                     "???", "efl", "esp"};
244#endif
245#ifdef SOLARIS
246char *Iregnames[] = {"???", "???", "???", "???", "???",
247                     "edi", "esi", "ebp", "???", "ebx",
248                     "edx", "ecx", "eax", "???", "???",
249                     "eip", "???", "efl", "esp"};
250#endif
251#endif
252
253#ifdef X8632
254int bit_for_regnum(int r)
255{
256  switch (r) {
257  case REG_EAX: return 1<<0;
258  case REG_ECX: return 1<<1;
259  case REG_EDX: return 1<<2;
260  case REG_EBX: return 1<<3;
261  case REG_ESP: return 1<<4;
262  case REG_EBP: return 1<<5;
263  case REG_ESI: return 1<<6;
264  case REG_EDI: return 1<<7;
265  }
266}
267#endif
268
269void
270show_lisp_register(ExceptionInformation *xp, char *label, int r)
271{
272
273  extern char* print_lisp_object(LispObj);
274
275  LispObj val = xpGPR(xp, r);
276
277#ifdef PPC
278  fprintf(dbgout, "r%02d (%s) = %s\n", r, label, print_lisp_object(val));
279#endif
280#ifdef X8664
281  fprintf(dbgout, "%%%s (%s) = %s\n",Iregnames[r], label, print_lisp_object(val));
282#endif
283#ifdef X8632
284  {
285    TCR *tcr = get_tcr(false);
286    char *s;
287
288    if (r == REG_EDX && (xpGPR(xp, REG_EFL) & EFL_DF))
289      s = "marked as unboxed (DF set)";
290    else if (tcr && (tcr->node_regs_mask & bit_for_regnum(r)) == 0)
291      s = "marked as unboxed (node_regs_mask)";
292    else
293      s = print_lisp_object(val);
294
295    fprintf(dbgout, "%%%s (%s) = %s\n", Iregnames[r], label, s);
296  }
297#endif
298#ifdef ARM
299  fprintf(dbgout, "r%02d (%s) = %s\n", r, label, print_lisp_object(val));
300#endif
301}
302
303void
304describe_siginfo(siginfo_t *info)
305{
306#if defined(WINDOWS) || defined(FREEBSD) || defined(DARWIN)
307  /*
308   * It's not surprising that Windows doesn't have this signal stuff.
309   * It is somewhat surprising that FreeBSD 6.x lacks the si_code
310   * constants.  (Subsequent FreeBSD versions define them, though.)
311   *
312   * On Darwin, recall that we handle exceptions at the Mach level,
313   * and build a "fake" signal context ourselves.  We don't try very
314   * hard to translate the Mach exception information to Unix-style
315   * information, so avoid printing out possibly-misleading garbage.
316   * (bsd/dev/i386/unix_signal.c from the xnu sources is where that
317   * happens for Mac OS X's own Mach-exception-to-Unix-signal
318   * translation.
319   */
320#else
321  if (info->si_code > 0) {
322    if (info->si_signo == SIGSEGV) {
323      switch (info->si_code) {
324      case SEGV_MAPERR:
325        fprintf(dbgout, "address not mapped to object\n");
326        break;
327      case SEGV_ACCERR:
328        fprintf(dbgout, "invalid permissions for mapped object\n");
329        break;
330      default:
331        fprintf(dbgout, "unexpected si_code value: %d\n", info->si_code);
332        break;
333      }
334    } else if (info->si_signo == SIGBUS) {
335      switch (info->si_code) {
336      case BUS_ADRALN:
337        fprintf(dbgout, "invalid address alignment\n");
338        break;
339      case BUS_ADRERR:
340        fprintf(dbgout, "non-existent physical address");
341        break;
342      case BUS_OBJERR:
343        fprintf(dbgout, "object-specific hardware error");
344        break;
345      default:
346        fprintf(dbgout, "unexpected si_code value: %d\n", info->si_code);
347      }
348    }
349  }
350#endif
351}
352
353void
354describe_memfault(ExceptionInformation *xp, siginfo_t *info)
355{
356#ifdef PPC
357  void *addr = (void *)xpDAR(xp);
358  natural dsisr = xpDSISR(xp);
359
360  fprintf(dbgout, "%s operation to %s address 0x%lx\n",
361          dsisr & (1<<25) ? "Write" : "Read",
362          dsisr & (1<<27) ? "protected" : "unmapped",
363          addr);
364#elif !defined(WINDOWS)
365  if (info) {
366    fprintf(dbgout, "received signal %d; faulting address: %p\n",
367            info->si_signo, info->si_addr);
368    describe_siginfo(info);
369  }
370#endif
371}
372
373#ifdef PPC
374void
375describe_ppc_illegal(ExceptionInformation *xp)
376{
377  pc where = xpPC(xp);
378  opcode the_uuo = *where;
379  Boolean described = false;
380
381  if (IS_UUO(the_uuo)) {
382    unsigned 
383      minor = UUO_MINOR(the_uuo),
384      errnum = 0x3ff & (the_uuo >> 16);
385
386    switch(minor) {
387    case UUO_INTERR:
388      switch (errnum) {
389      case error_udf_call:
390        fprintf(dbgout, "ERROR: undefined function call: %s\n",
391                print_lisp_object(xpGPR(xp,fname)));
392        described = true;
393        break;
394       
395      default:
396        fprintf(dbgout, "ERROR: lisp error %d\n", errnum);
397        described = true;
398        break;
399      }
400      break;
401     
402    default:
403      break;
404    }
405  }
406  if (!described) {
407    fprintf(dbgout, "Illegal instruction (0x%08x) at 0x%lx\n",
408            the_uuo, where);
409  }
410}
411#endif
412
413#ifdef PPC
414void
415describe_ppc_trap(ExceptionInformation *xp)
416{
417  pc where = xpPC(xp);
418  opcode the_trap = *where, instr;
419  int err_arg2, ra, rs;
420  Boolean identified = false;
421
422  if ((the_trap & OP_MASK) == OP(major_opcode_TRI)) {
423    /* TWI/TDI.  If the RA field is "nargs", that means that the
424       instruction is either a number-of-args check or an
425       event-poll.  Otherwise, the trap is some sort of
426       typecheck. */
427
428    if (RA_field(the_trap) == nargs) {
429      switch (TO_field(the_trap)) {
430      case TO_NE:
431        if (xpGPR(xp, nargs) < D_field(the_trap)) {
432          fprintf(dbgout, "Too few arguments (no opt/rest)\n");
433        } else {
434          fprintf(dbgout, "Too many arguments (no opt/rest)\n");
435        }
436        identified = true;
437        break;
438       
439      case TO_GT:
440        fprintf(dbgout, "Event poll !\n");
441        identified = true;
442        break;
443       
444      case TO_HI:
445        fprintf(dbgout, "Too many arguments (with opt)\n");
446        identified = true;
447        break;
448       
449      case TO_LT:
450        fprintf(dbgout, "Too few arguments (with opt/rest/key)\n");
451        identified = true;
452        break;
453       
454      default:                /* some weird trap, not ours. */
455        identified = false;
456        break;
457      }
458    } else {
459      /* A type or boundp trap of some sort. */
460      switch (TO_field(the_trap)) {
461      case TO_EQ:
462        /* Boundp traps are of the form:
463           treqi rX,unbound
464           where some preceding instruction is of the form:
465           lwz/ld rX,symbol.value(rY).
466           The error message should try to say that rY is unbound. */
467       
468        if (D_field(the_trap) == unbound) {
469#ifdef PPC64
470          instr = scan_for_instr(LD_instruction(RA_field(the_trap),
471                                                unmasked_register,
472                                                offsetof(lispsymbol,vcell)-fulltag_misc),
473                                 D_RT_IMM_MASK,
474                                 where);
475#else
476          instr = scan_for_instr(LWZ_instruction(RA_field(the_trap),
477                                                 unmasked_register,
478                                                 offsetof(lispsymbol,vcell)-fulltag_misc),
479                                 D_RT_IMM_MASK,
480                                 where);
481#endif
482          if (instr) {
483            ra = RA_field(instr);
484            if (lisp_reg_p(ra)) {
485              fprintf(dbgout, "Unbound variable: %s\n",
486                      print_lisp_object(xpGPR(xp,ra)));
487              identified = true;       
488            }
489          }
490        }
491        break;
492       
493      case TO_NE:
494        /* A type check.  If the type (the immediate field of the trap
495           instruction) is a header type, an "lbz
496           rX,misc_header_offset(rY)" should precede it, in which case
497           we say that "rY is not of header type <type>."  If the type
498           is not a header type, then rX should have been set by a
499           preceding "clrlwi rX,rY,29/30".  In that case, scan
500           backwards for an RLWINM instruction that set rX and report
501           that rY isn't of the indicated type. */
502        err_arg2 = D_field(the_trap);
503        if (nodeheader_tag_p(err_arg2) ||
504            immheader_tag_p(err_arg2)) {
505          instr = scan_for_instr(LBZ_instruction(RA_field(the_trap),
506                                                 unmasked_register,
507                                                 misc_subtag_offset),
508                                 D_RT_IMM_MASK,
509                                 where);
510          if (instr) {
511            ra = RA_field(instr);
512            if (lisp_reg_p(ra)) {
513              fprintf(dbgout, "value 0x%lX is not of the expected header type 0x%02X\n", xpGPR(xp, ra), err_arg2);
514              identified = true;
515            }
516          }
517        } else {               
518          /* Not a header type, look for rlwinm whose RA field matches the_trap's */
519          instr = scan_for_instr((OP(major_opcode_RLWINM) | (the_trap & RA_MASK)),
520                                 (OP_MASK | RA_MASK),
521                                 where);
522          if (instr) {
523            rs = RS_field(instr);
524            if (lisp_reg_p(rs)) {
525              fprintf(dbgout, "value 0x%lX is not of the expected type 0x%02X\n",
526                      xpGPR(xp, rs), err_arg2);
527              identified = true;
528            }
529          }
530        }
531        break;
532      }
533    }
534  } else {
535    /* a "TW <to>,ra,rb" instruction."
536       twltu sp,rN is stack-overflow on SP.
537       twgeu rX,rY is subscript out-of-bounds, which was preceded
538       by an "lwz rM,misc_header_offset(rN)" instruction.
539       rM may or may not be the same as rY, but no other header
540       would have been loaded before the trap. */
541    switch (TO_field(the_trap)) {
542    case TO_LO:
543      if (RA_field(the_trap) == sp) {
544        fprintf(dbgout, "Stack overflow! Run away! Run away!\n");
545        identified = true;
546      }
547      break;
548     
549    case (TO_HI|TO_EQ):
550      instr = scan_for_instr(OP(major_opcode_LWZ) | (D_MASK & misc_header_offset),
551                             (OP_MASK | D_MASK),
552                             where);
553      if (instr) {
554        ra = RA_field(instr);
555        if (lisp_reg_p(ra)) {
556          fprintf(dbgout, "Bad index %d for vector %lX length %d\n",
557                  unbox_fixnum(xpGPR(xp, RA_field(the_trap))),
558                  xpGPR(xp, ra),
559                  unbox_fixnum(xpGPR(xp, RB_field(the_trap))));
560          identified = true;
561        }
562      }
563      break;
564    }
565  }
566
567  if (!identified) {
568    fprintf(dbgout, "Unknown trap: 0x%08x\n", the_trap);
569  }
570
571
572}
573#endif
574
575#ifdef ARM
576void
577describe_arm_uuo(ExceptionInformation *xp)
578{
579  pc program_counter = xpPC(xp);
580  opcode instruction = *program_counter;
581
582  if (IS_UUO(instruction)) {
583    unsigned format = UUO_FORMAT(instruction);
584
585    switch(format) {
586    case uuo_format_nullary:
587    case uuo_format_nullary_error:
588      switch UUOA_field(instruction) {
589      case 0:
590        fprintf(dbgout,"alloc_trap\n");
591        break;
592      case 1:
593        fprintf(dbgout,"wrong number of args (%d) to %s\n",xpGPR(xp,nargs)>>node_shift,
594                print_lisp_object(xpGPR(xp,nfn)));
595        break;
596      case 2:
597        fprintf(dbgout,"gc trap\n");
598        break;
599      case 3:
600        fprintf(dbgout,"debug trap\n");
601        break;
602      case 4:
603        fprintf(dbgout,"deferred interrupt\n");
604        break;
605      case 5:
606        fprintf(dbgout,"deferred suspend\n");
607        break;
608      default:
609        break;
610      }
611      break;
612
613    case uuo_format_unary_error:
614      switch (UUO_UNARY_field(instruction)) {
615      case 0:
616      case 1:
617        fprintf(dbgout,"%s is unbound\n", print_lisp_object(xpGPR(xp,UUOA_field(instruction))));
618        break;
619
620      default:
621        break;
622      }
623    default:
624      break;
625    }
626  }
627}
628#endif
629
630char *
631area_code_name(int code)
632{
633  switch (code) {
634    case AREA_VOID: return "void";
635    case AREA_CSTACK: return "cstack";
636    case AREA_VSTACK: return "vstack";
637    case AREA_TSTACK: return "tstack";
638    case AREA_READONLY: return "readonly";
639    case AREA_WATCHED: return "watched";
640    case AREA_STATIC_CONS: return "static cons";
641    case AREA_MANAGED_STATIC: return "managed static";
642    case AREA_STATIC: return "static";
643    case AREA_DYNAMIC: return "dynamic";
644    default: return "unknown";
645  }
646}
647
648debug_command_return
649debug_memory_areas(ExceptionInformation *xp, siginfo_t *info, int arg)
650{
651  area *a, *header = all_areas;
652  char label[100];
653
654  fprintf(dbgout, "Lisp memory areas:\n");
655  fprintf(dbgout, "%20s %20s %20s\n", "code", "low", "high");
656  for (a = header->succ; a != header; a = a->succ) {
657    snprintf(label, sizeof(label), "%s (%d)", area_code_name(a->code),
658             a->code >> fixnumshift);
659    fprintf(dbgout, "%20s %20p %20p\n", label, a->low, a->high);
660  }
661  return debug_continue;
662}
663
664debug_command_return
665debug_lisp_registers(ExceptionInformation *xp, siginfo_t *info, int arg)
666{
667  if (lisp_debugger_in_foreign_code == false) {
668#ifdef PPC
669    TCR *xpcontext = (TCR *)ptr_from_lispobj(xpGPR(xp, rcontext));
670
671    fprintf(dbgout, "rcontext = 0x%lX ", xpcontext);
672    if (!active_tcr_p(xpcontext)) {
673      fprintf(dbgout, "(INVALID)\n");
674    } else {
675      fprintf(dbgout, "\nnargs = %d\n", xpGPR(xp, nargs) >> fixnumshift);
676      show_lisp_register(xp, "fn", fn);
677      show_lisp_register(xp, "arg_z", arg_z);
678      show_lisp_register(xp, "arg_y", arg_y);
679      show_lisp_register(xp, "arg_x", arg_x);
680      show_lisp_register(xp, "temp0", temp0);
681      show_lisp_register(xp, "temp1/next_method_context", temp1);
682      show_lisp_register(xp, "temp2/nfn", temp2);
683      show_lisp_register(xp, "temp3/fname", temp3);
684      /*    show_lisp_register(xp, "new_fn", new_fn); */
685      show_lisp_register(xp, "save0", save0);
686      show_lisp_register(xp, "save1", save1);
687      show_lisp_register(xp, "save2", save2);
688      show_lisp_register(xp, "save3", save3);
689      show_lisp_register(xp, "save4", save4);
690      show_lisp_register(xp, "save5", save5);
691      show_lisp_register(xp, "save6", save6);
692      show_lisp_register(xp, "save7", save7);
693    }
694#endif
695#ifdef X8664
696
697    show_lisp_register(xp, "arg_z", Iarg_z);
698    show_lisp_register(xp, "arg_y", Iarg_y);
699    show_lisp_register(xp, "arg_x", Iarg_x);
700    fprintf(dbgout,"------\n");
701    show_lisp_register(xp, "fn", Ifn);
702    fprintf(dbgout,"------\n");
703    show_lisp_register(xp, "save0", Isave0);
704    show_lisp_register(xp, "save1", Isave1);
705    show_lisp_register(xp, "save2", Isave2);
706    show_lisp_register(xp, "save3", Isave3);
707    fprintf(dbgout,"------\n");
708    show_lisp_register(xp, "temp0", Itemp0);
709    show_lisp_register(xp, "temp1", Itemp1);
710    show_lisp_register(xp, "temp2", Itemp2);
711    fprintf(dbgout,"------\n");
712    if (tag_of(xpGPR(xp,Inargs)) == tag_fixnum) {
713      fprintf(dbgout,"%%rcx (nargs) = %ld (maybe)\n", unbox_fixnum(xpGPR(xp,Inargs)&0xffff));
714    }
715#endif
716
717#ifdef X8632
718  show_lisp_register(xp, "arg_z", Iarg_z);
719  show_lisp_register(xp, "arg_y", Iarg_y);
720  fprintf(dbgout,"------\n");
721  show_lisp_register(xp, "fn", Ifn);
722  fprintf(dbgout,"------\n");
723  show_lisp_register(xp, "temp0", Itemp0);
724  show_lisp_register(xp, "temp1", Itemp1);
725  fprintf(dbgout,"------\n");
726  if (tag_of(xpGPR(xp,Inargs)) == tag_fixnum) {
727    fprintf(dbgout,"%%edx (nargs) = %d (maybe)\n", unbox_fixnum(xpGPR(xp,Inargs)));
728  }
729#endif
730#ifdef ARM
731    TCR *xpcontext = (TCR *)ptr_from_lispobj(xpGPR(xp, rcontext));
732
733    fprintf(dbgout, "rcontext = 0x%lX ", xpcontext);
734    if (!active_tcr_p(xpcontext)) {
735      fprintf(dbgout, "(INVALID)\n");
736    } else {
737      fprintf(dbgout, "\nnargs = %d\n", xpGPR(xp, nargs) >> fixnumshift);
738      show_lisp_register(xp, "fn", Rfn);
739      show_lisp_register(xp, "arg_z", arg_z);
740      show_lisp_register(xp, "arg_y", arg_y);
741      show_lisp_register(xp, "arg_x", arg_x);
742      show_lisp_register(xp, "temp0", temp0);
743      show_lisp_register(xp, "temp1/fname/next_method_context", temp1);
744      show_lisp_register(xp, "temp2/nfn", temp2);
745    }
746#endif
747  }
748 
749  return debug_continue;
750}
751
752#ifndef X86
753debug_command_return
754debug_advance_pc(ExceptionInformation *xp, siginfo_t *info, int arg)
755{
756  adjust_exception_pc(xp,4);
757  return debug_continue;
758}
759#endif
760
761debug_command_return
762debug_identify_exception(ExceptionInformation *xp, siginfo_t *info, int arg)
763{
764#ifndef X86
765  pc program_counter = xpPC(xp);
766  opcode instruction = 0;
767#endif
768
769  switch (arg) {
770#ifdef PPC
771  case SIGILL:
772  case SIGTRAP:
773    instruction = *program_counter;
774    if (major_opcode_p(instruction, major_opcode_TRI) ||
775        X_opcode_p(instruction,major_opcode_X31,minor_opcode_TR)) {
776      describe_ppc_trap(xp);
777    } else {
778      describe_ppc_illegal(xp);
779    }
780    break;
781#endif
782
783#ifdef ARM 
784  case SIGILL:
785    instruction = *program_counter;
786    if (IS_UUO(instruction)) {
787      describe_arm_uuo(xp);
788    }
789    break;
790#endif
791  case SIGSEGV:
792  case SIGBUS:
793    describe_memfault(xp, info);
794    break;
795  default:
796    break;
797  }
798  return debug_continue;
799}
800
801char *
802debug_get_string_value(char *prompt)
803{
804  static char buf[128];
805  char *p, *res;
806
807  do {
808    fpurge(stdin);
809    fprintf(dbgout, "\n %s :",prompt);
810    buf[0] = 0;
811    res = fgets(buf, sizeof(buf), stdin);
812  } while (0);
813  p = strchr(res, '\n');
814  if (p) {
815    *p = 0;
816    return buf;
817  }
818  return NULL;
819}
820
821natural
822debug_get_natural_value(char *prompt)
823{
824  char s[32], *res, *endptr;
825  natural val;
826
827  do {
828    fpurge(stdin);
829    fprintf(dbgout, "\n  %s :", prompt);
830    s[0]=0;
831    res = fgets(s, 24, stdin);
832    val = strtoul(res,&endptr,0);
833  } while (*endptr);
834  return val;
835}
836
837unsigned
838debug_get_u5_value(char *prompt)
839{
840  char s[32], *res;
841  int n;
842  unsigned val;
843
844  do {
845    fpurge(stdin);
846    fprintf(dbgout, "\n  %s :", prompt);
847    res = fgets(s, 24, stdin);
848    n = sscanf(res, "%i", &val);
849  } while ((n != 1) || (val > 31));
850  return val;
851}
852
853debug_command_return
854debug_show_symbol(ExceptionInformation *xp, siginfo_t *info, int arg)
855{
856  char *pname = debug_get_string_value("symbol name");
857  extern void *plsym(ExceptionInformation *,char*);
858 
859  if (pname != NULL) {
860    plsym(xp, pname);
861  }
862  return debug_continue;
863}
864
865debug_command_return
866debug_show_lisp_version(ExceptionInformation *xp, siginfo_t *info, int arg)
867{
868  extern void *plsym(ExceptionInformation *,char*);
869
870  fprintf(dbgout, "Lisp kernel svn revision: %s\n", kernel_svn_revision);
871  if (xp)
872    plsym(xp, "*OPENMCL-VERSION*");
873  return debug_continue;
874}
875
876debug_command_return
877debug_thread_info(ExceptionInformation *xp, siginfo_t *info, int arg)
878{
879  TCR * tcr = get_tcr(false);
880 
881  if (tcr) {
882    area *vs_area = tcr->vs_area, *cs_area = tcr->cs_area;
883
884    fprintf(dbgout, "Current Thread Context Record (tcr) = 0x" LISP "\n", tcr);
885    fprintf(dbgout, "Control (C) stack area:  low = 0x" LISP ", high = 0x" LISP "\n",
886            (cs_area->low), (cs_area->high));
887    fprintf(dbgout, "Value (lisp) stack area: low = 0x" LISP ", high = 0x" LISP "\n",
888            (u64_t)(natural)(vs_area->low), (u64_t)(natural)vs_area->high);
889    if (xp) {
890      fprintf(dbgout, "Exception stack pointer = 0x" LISP "\n",
891#ifdef PPC
892              (u64_t) (natural)(xpGPR(xp,1))
893#endif
894#ifdef X86
895              (u64_t) (natural)(xpGPR(xp,Isp))
896#endif           
897#ifdef ARM
898              (u64_t) (natural)(xpGPR(xp,Rsp))
899#endif
900              );
901    }
902  }
903  return debug_continue;
904}
905     
906
907debug_command_return
908debug_set_gpr(ExceptionInformation *xp, siginfo_t *info, int arg)
909{
910  char buf[32];
911  natural val;
912
913  sprintf(buf, "value for GPR %d", arg);
914  val = debug_get_natural_value(buf);
915  xpGPR(xp,arg) = val;
916  return debug_continue;
917}
918
919debug_command_return
920debug_show_registers(ExceptionInformation *xp, siginfo_t *info, int arg)
921{
922
923
924#ifdef PPC
925#ifdef PPC64
926  int a, b;
927  for (a = 0, b = 16; a < 16; a++, b++) {
928    fprintf(dbgout,"r%02d = 0x%016lX    r%02d = 0x%016lX\n",
929            a, xpGPR(xp, a),
930            b, xpGPR(xp, b));
931  }
932 
933  fprintf(dbgout, "\n PC = 0x%016lX     LR = 0x%016lX\n",
934          xpPC(xp), xpLR(xp));
935  fprintf(dbgout, "CTR = 0x%016lX    CCR = 0x%08X\n",
936          xpCTR(xp), xpCCR(xp));
937  fprintf(dbgout, "XER = 0x%08X            MSR = 0x%016lX\n",
938          xpXER(xp), xpMSR(xp));
939  fprintf(dbgout,"DAR = 0x%016lX  DSISR = 0x%08X\n",
940          xpDAR(xp), xpDSISR(xp));
941#else
942  int a, b, c, d;;
943  for (a = 0, b = 8, c = 16, d = 24; a < 8; a++, b++, c++, d++) {
944    fprintf(dbgout,"r%02d = 0x%08X  r%02d = 0x%08X  r%02d = 0x%08X  r%02d = 0x%08X\n",
945            a, xpGPR(xp, a),
946            b, xpGPR(xp, b),
947            c, xpGPR(xp, c),
948            d, xpGPR(xp, d));
949  }
950  fprintf(dbgout, "\n PC = 0x%08X   LR = 0x%08X  CTR = 0x%08X  CCR = 0x%08X\n",
951          xpPC(xp), xpLR(xp), xpCTR(xp), xpCCR(xp));
952  fprintf(dbgout, "XER = 0x%08X  MSR = 0x%08X  DAR = 0x%08X  DSISR = 0x%08X\n",
953          xpXER(xp), xpMSR(xp), xpDAR(xp), xpDSISR(xp));
954#endif
955#endif
956
957#ifdef X8664
958  fprintf(dbgout,"%%rax = 0x" ZLISP "      %%r8  = 0x" ZLISP "\n", xpGPR(xp,REG_RAX),xpGPR(xp,REG_R8));
959  fprintf(dbgout,"%%rcx = 0x" ZLISP "      %%r9  = 0x" ZLISP "\n", xpGPR(xp,REG_RCX),xpGPR(xp,REG_R9));
960  fprintf(dbgout,"%%rdx = 0x" ZLISP "      %%r10 = 0x" ZLISP "\n", xpGPR(xp,REG_RDX),xpGPR(xp,REG_R10));
961  fprintf(dbgout,"%%rbx = 0x" ZLISP "      %%r11 = 0x" ZLISP "\n", xpGPR(xp,REG_RBX),xpGPR(xp,REG_R11));
962  fprintf(dbgout,"%%rsp = 0x" ZLISP "      %%r12 = 0x" ZLISP "\n", xpGPR(xp,REG_RSP),xpGPR(xp,REG_R12));
963  fprintf(dbgout,"%%rbp = 0x" ZLISP "      %%r13 = 0x" ZLISP "\n", xpGPR(xp,REG_RBP),xpGPR(xp,REG_R13));
964  fprintf(dbgout,"%%rsi = 0x" ZLISP "      %%r14 = 0x" ZLISP "\n", xpGPR(xp,REG_RSI),xpGPR(xp,REG_R14));
965  fprintf(dbgout,"%%rdi = 0x" ZLISP "      %%r15 = 0x" ZLISP "\n", xpGPR(xp,REG_RDI),xpGPR(xp,REG_R15));
966  fprintf(dbgout,"%%rip = 0x" ZLISP "   %%rflags = 0x%08lx\n",
967          xpGPR(xp, Iip), eflags_register(xp));
968#endif
969
970#ifdef X8632
971  unsigned short rcs,rds,res,rfs,rgs,rss;
972#ifdef DARWIN
973  rcs = xp->uc_mcontext->__ss.__cs;
974  rds = xp->uc_mcontext->__ss.__ds;
975  res = xp->uc_mcontext->__ss.__es;
976  rfs = xp->uc_mcontext->__ss.__fs;
977  rgs = xp->uc_mcontext->__ss.__gs;
978  rss = xp->uc_mcontext->__ss.__ss;
979#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
980#endif
981#ifdef LINUX
982  rcs = xp->uc_mcontext.gregs[REG_CS];
983  rds = xp->uc_mcontext.gregs[REG_DS];
984  res = xp->uc_mcontext.gregs[REG_ES];
985  rfs = xp->uc_mcontext.gregs[REG_FS];
986  rgs = xp->uc_mcontext.gregs[REG_GS];
987  rss = xp->uc_mcontext.gregs[REG_SS];
988#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
989#endif
990#ifdef FREEBSD
991  rcs = xp->uc_mcontext.mc_cs;
992  rds = xp->uc_mcontext.mc_ds;
993  res = xp->uc_mcontext.mc_es;
994  rfs = xp->uc_mcontext.mc_fs;
995  rgs = xp->uc_mcontext.mc_gs;
996  rss = xp->uc_mcontext.mc_ss;
997#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
998#endif
999#ifdef SOLARIS
1000  rcs = xp->uc_mcontext.gregs[CS];
1001  rds = xp->uc_mcontext.gregs[DS];
1002  res = xp->uc_mcontext.gregs[ES];
1003  rfs = xp->uc_mcontext.gregs[FS];
1004  rgs = xp->uc_mcontext.gregs[GS];
1005  rss = xp->uc_mcontext.gregs[SS];
1006#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
1007#endif
1008#ifdef WINDOWS
1009  rcs = xp->SegCs;
1010  rds = xp->SegDs;
1011  res = xp->SegEs;
1012  rfs = xp->SegFs;
1013  rgs = xp->SegGs;
1014  rss = xp->SegSs;
1015#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
1016#endif
1017
1018
1019
1020  fprintf(dbgout, "%%eax = 0x" ZLISP "\n", xpGPR(xp, REG_EAX));
1021  fprintf(dbgout, "%%ecx = 0x" ZLISP "\n", xpGPR(xp, REG_ECX));
1022  fprintf(dbgout, "%%edx = 0x" ZLISP "\n", xpGPR(xp, REG_EDX));
1023  fprintf(dbgout, "%%ebx = 0x" ZLISP "\n", xpGPR(xp, REG_EBX));
1024  fprintf(dbgout, "%%esp = 0x" ZLISP "\n", xpGPR(xp, REG_ESP));
1025  fprintf(dbgout, "%%ebp = 0x" ZLISP "\n", xpGPR(xp, REG_EBP));
1026  fprintf(dbgout, "%%esi = 0x" ZLISP "\n", xpGPR(xp, REG_ESI));
1027  fprintf(dbgout, "%%edi = 0x" ZLISP "\n", xpGPR(xp, REG_EDI));
1028  fprintf(dbgout, "%%eip = 0x" ZLISP "\n", xpGPR(xp, REG_EIP));
1029  fprintf(dbgout, "%%eflags = 0x" ZLISP "\n", xpGPR(xp, REG_EFL));
1030#ifdef DEBUG_SHOW_X86_SEGMENT_REGISTERS
1031  fprintf(dbgout,"\n");
1032  fprintf(dbgout, "%%cs = 0x%04x\n", rcs);
1033  fprintf(dbgout, "%%ds = 0x%04x\n", rds);
1034  fprintf(dbgout, "%%ss = 0x%04x\n", rss);
1035  fprintf(dbgout, "%%es = 0x%04x\n", res);
1036  fprintf(dbgout, "%%fs = 0x%04x\n", rfs);
1037  fprintf(dbgout, "%%gs = 0x%04x\n", rgs);
1038
1039#endif
1040
1041#endif
1042
1043#ifdef ARM
1044  int a, b;
1045  for (a = 0, b = 8; a < 8; a++, b++) {
1046    fprintf(dbgout,"r%02d = 0x%08lX    r%02d = 0x%08lX\n",
1047            a, xpGPR(xp, a),
1048            b, xpGPR(xp, b));
1049  }
1050#endif
1051
1052  return debug_continue;
1053}
1054
1055debug_command_return
1056debug_show_fpu(ExceptionInformation *xp, siginfo_t *info, int arg)
1057{
1058  double *dp;
1059  int *np, i;
1060#ifdef PPC
1061  dp = xpFPRvector(xp);
1062  np = (int *) dp;
1063 
1064  for (i = 0; i < 32; i++, np+=2) {
1065    fprintf(dbgout, "f%02d : 0x%08X%08X (%f)\n", i,  np[0], np[1], *dp++);
1066  }
1067  fprintf(dbgout, "FPSCR = %08X\n", xpFPSCR(xp));
1068#endif
1069#ifdef X8664
1070#ifdef LINUX
1071  struct _libc_xmmreg * xmmp = NULL;
1072#endif
1073#ifdef DARWIN
1074  struct xmm {
1075    char fpdata[16];
1076  };
1077  struct xmm *xmmp = (struct xmm *)(xpFPRvector(xp));
1078#endif
1079#ifdef WINDOWS
1080  struct xmm {
1081    char fpdata[16];
1082  };
1083  struct xmm *xmmp; /* XXX: actually get them */
1084#endif
1085#ifdef FREEBSD
1086  struct xmmacc *xmmp = xpXMMregs(xp);
1087#endif
1088#ifdef SOLARIS
1089  upad128_t *xmmp = xpXMMregs(xp);
1090#endif
1091  float *sp;
1092
1093#ifdef LINUX
1094  if (xp->uc_mcontext.fpregs)
1095    xmmp = &(xp->uc_mcontext.fpregs->_xmm[0]);
1096  else
1097    /* no fp state, apparently */
1098    return debug_continue;
1099#endif
1100
1101  for (i = 0; i < 16; i++, xmmp++) {
1102    sp = (float *) xmmp;
1103    dp = (double *) xmmp;
1104    np = (int *) xmmp;
1105    fprintf(dbgout, "f%02d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np, (double)(*sp), np[1], np[0], *dp);
1106  }
1107  fprintf(dbgout, "mxcsr = 0x%08x\n",
1108#ifdef LINUX
1109          xp->uc_mcontext.fpregs->mxcsr
1110#endif
1111#ifdef DARWIN
1112          UC_MCONTEXT(xp)->__fs.__fpu_mxcsr
1113#endif
1114#ifdef FREEBSD
1115          (((struct savefpu *)(&(xp)->uc_mcontext.mc_fpstate))->sv_env.en_mxcsr)
1116#endif
1117#ifdef SOLARIS
1118          xp->uc_mcontext.fpregs.fp_reg_set.fpchip_state.xstatus
1119#endif
1120#ifdef WINDOWS
1121          *(xpMXCSRptr(xp))
1122#endif
1123          );
1124#endif 
1125#ifdef X8632
1126#ifdef DARWIN
1127  struct xmm {
1128    char fpdata[8];
1129  };
1130  struct xmm *xmmp = (struct xmm *)(xpFPRvector(xp));
1131
1132  for (i = 0; i < 8; i++, xmmp++) {
1133    float *sp = (float *)xmmp;
1134    dp = (double *)xmmp;
1135    np = (int *)xmmp;
1136    fprintf(dbgout, "f%1d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np,
1137            (double)(*sp), np[1], np[0], *dp);
1138  }
1139  fprintf(dbgout, "mxcsr = 0x%08x\n", UC_MCONTEXT(xp)->__fs.__fpu_mxcsr);
1140#endif
1141#endif
1142
1143  return debug_continue;
1144}
1145
1146debug_command_return
1147debug_kill_process(ExceptionInformation *xp, siginfo_t *info, int arg) {
1148  return debug_kill;
1149}
1150
1151debug_command_return
1152debug_win(ExceptionInformation *xp, siginfo_t *info, int arg) {
1153  return debug_exit_success;
1154}
1155
1156debug_command_return
1157debug_lose(ExceptionInformation *xp, siginfo_t *info, int arg) {
1158  return debug_exit_fail;
1159}
1160
1161debug_command_return
1162debug_help(ExceptionInformation *xp, siginfo_t *info, int arg) {
1163  debug_command_entry *entry;
1164
1165  for (entry = debug_command_entries; entry->f; entry++) {
1166    /* If we have an XP or don't need one, call the function */
1167    if (xp || !(entry->flags & DEBUG_COMMAND_FLAG_REQUIRE_XP)) {
1168      fprintf(dbgout, "(%c)  %s\n", entry->c, entry->help_text);
1169    }
1170  }
1171  return debug_continue;
1172}
1173             
1174
1175 
1176
1177debug_command_return
1178debug_backtrace(ExceptionInformation *xp, siginfo_t *info, int arg)
1179{
1180  extern LispObj current_stack_pointer();
1181  extern void plbt_sp(LispObj);
1182  extern void plbt(ExceptionInformation *);
1183
1184  if (xp) {
1185    plbt(xp);
1186#ifndef X86
1187  } else {
1188    plbt_sp(current_stack_pointer());
1189#endif
1190  }
1191  return debug_continue;
1192}
1193
1194debug_command_return
1195debug_thread_reset(ExceptionInformation *xp, siginfo_t *info, int arg)
1196{
1197  reset_lisp_process(xp);
1198  return debug_exit_success;
1199}
1200
1201
1202debug_command_entry debug_command_entries[] = 
1203{
1204  {debug_set_gpr,
1205   "Set specified GPR to new value",
1206   DEBUG_COMMAND_FLAG_AUX_REGNO,
1207   "GPR to set (0-31) ?",
1208   'G'},
1209#ifndef X86
1210  {debug_advance_pc,
1211   "Advance the program counter by one instruction (use with caution!)",
1212   DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY,
1213   NULL,
1214   'A'},
1215  {debug_identify_exception,
1216   "Describe the current exception in greater detail",
1217   DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY |
1218   DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG,
1219   NULL,
1220   'D'},
1221#endif
1222  {debug_show_registers, 
1223   "Show raw GPR/SPR register values", 
1224   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1225   NULL,
1226   'R'},
1227  {debug_lisp_registers,
1228   "Show Lisp values of tagged registers",
1229   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1230   NULL,
1231   'L'},
1232  {debug_show_fpu,
1233   "Show FPU registers",
1234   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1235   NULL,
1236   'F'},
1237  {debug_show_symbol,
1238   "Find and describe symbol matching specified name",
1239   0,
1240   NULL,
1241   'S'},
1242  {debug_backtrace,
1243   "Show backtrace",
1244   0,
1245   NULL,
1246   'B'},
1247  {debug_thread_info,
1248   "Show info about current thread",
1249   0,
1250   NULL,
1251   'T'},
1252  {debug_memory_areas,
1253   "Show memory areas",
1254   0,
1255   NULL,
1256   'M'},
1257  {debug_win,
1258   "Exit from this debugger, asserting that any exception was handled",
1259   0,
1260   NULL,
1261   'X'},
1262#ifdef DARWIN
1263  {debug_lose,
1264   "Propagate the exception to another handler (debugger or OS)",
1265   DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY,
1266   NULL,
1267   'P'},
1268#endif
1269#if 0
1270  {debug_thread_reset,
1271   "Reset current thread (as if in response to stack overflow)",
1272   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1273   NULL,
1274   'T'},
1275#endif
1276  {debug_kill_process,
1277   "Kill Clozure CL process",
1278   0,
1279   NULL,
1280   'K'},
1281  {debug_show_lisp_version,
1282   "Show Subversion revision information",
1283   0,
1284   NULL,
1285   'V'},
1286  {debug_help,
1287   "Show this help",
1288   0,
1289   NULL,
1290   '?'},
1291  /* end-of-table */
1292  {NULL,
1293   NULL,
1294   0,
1295   NULL,
1296   0}
1297};
1298
1299debug_command_return
1300apply_debug_command(ExceptionInformation *xp, int c, siginfo_t *info, int why) 
1301{
1302  if (c == EOF) {
1303    return debug_kill;
1304  } else {
1305    debug_command_entry *entry;
1306    debug_command f;
1307    c = toupper(c);
1308
1309    for (entry = debug_command_entries; (f = entry->f) != NULL; entry++) {
1310      if (toupper(entry->c) == c) {
1311        /* If we have an XP or don't need one, call the function */
1312        if ((xp || !(entry->flags & DEBUG_COMMAND_FLAG_REQUIRE_XP)) &&
1313            ((why > debug_entry_exception) || 
1314             !(entry->flags & DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY))) {
1315          int arg = 0;
1316          if ((entry->flags & DEBUG_COMMAND_REG_FLAGS)
1317              == DEBUG_COMMAND_FLAG_AUX_REGNO) {
1318            arg = debug_get_u5_value("register number");
1319          }
1320          if (entry->flags & DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG) {
1321            arg = why;
1322          }
1323          return (f)(xp, info, arg);
1324        }
1325        break;
1326      }
1327    }
1328    return debug_continue;
1329  }
1330}
1331
1332void
1333debug_identify_function(ExceptionInformation *xp, siginfo_t *info) 
1334{
1335#ifdef PPC
1336  if (xp) {
1337    if (active_tcr_p((TCR *)(ptr_from_lispobj(xpGPR(xp, rcontext))))) {
1338      LispObj f = xpGPR(xp, fn), codev;
1339      pc where = xpPC(xp);
1340     
1341      if (!(codev = register_codevector_contains_pc(f, where))) {
1342        f = xpGPR(xp, nfn);
1343        codev =  register_codevector_contains_pc(f, where);
1344      }
1345      if (codev) {
1346        fprintf(dbgout, " While executing: %s\n", print_lisp_object(f));
1347      }
1348    } else {
1349      int disp;
1350      char *foreign_name;
1351      natural where = (natural)xpPC(xp);
1352
1353      fprintf(dbgout, " In foreign code at address 0x" ZLISP "\n", where);
1354      foreign_name = foreign_name_and_offset(where, &disp);
1355      if (foreign_name) {
1356        fprintf(dbgout, "  [%s + %d]\n", foreign_name, disp);
1357      }
1358    }
1359  }
1360#endif
1361}
1362
1363#ifndef WINDOWS
1364extern pid_t main_thread_pid;
1365#endif
1366
1367
1368OSStatus
1369lisp_Debugger(ExceptionInformation *xp, 
1370              siginfo_t *info, 
1371              int why, 
1372              Boolean in_foreign_code,
1373              char *message, 
1374              ...)
1375{
1376  va_list args;
1377  debug_command_return state = debug_continue;
1378
1379
1380  if (stdin_is_dev_null()) {
1381    return -1;
1382  }
1383
1384  va_start(args,message);
1385  vfprintf(dbgout, message, args);
1386  fprintf(dbgout, "\n");
1387  va_end(args);
1388
1389  if (threads_initialized) {
1390    suspend_other_threads(false);
1391  }
1392
1393  lisp_debugger_in_foreign_code = in_foreign_code;
1394  if (in_foreign_code) {   
1395    char *foreign_name;
1396    int disp;
1397    fprintf(dbgout, "Exception occurred while executing foreign code\n");
1398    foreign_name = foreign_name_and_offset((natural)xpPC(xp), &disp);
1399    if (foreign_name) {
1400      fprintf(dbgout, " at %s + %d\n", foreign_name, disp);
1401    }
1402  }
1403
1404  if (xp) {
1405    if (why > debug_entry_exception) {
1406      debug_identify_exception(xp, info, why);
1407    }
1408    debug_identify_function(xp, info);
1409  }
1410  if (lisp_global(BATCH_FLAG)) {
1411#ifdef WINDOWS
1412    fprintf(dbgout, "Current Process Id %d\n", (int)GetCurrentProcessId());
1413#else
1414    fprintf(dbgout, "Main thread pid %d\n", main_thread_pid);
1415#endif
1416    debug_thread_info(xp, info, 0);
1417    if (xp) {
1418      debug_show_registers(xp, info, 0);
1419      debug_lisp_registers(xp, info, 0);
1420      debug_show_fpu(xp, info, 0);
1421    }
1422    debug_memory_areas(xp, info, 0);
1423    debug_show_lisp_version(xp, info, 0);
1424    debug_backtrace(xp, info, 0);
1425    abort();
1426  }
1427
1428  fprintf(dbgout, "? for help\n");
1429  while (state == debug_continue) {
1430#ifdef WINDOWS
1431    fprintf(dbgout, "[%d] Clozure CL kernel debugger: ", (int)GetCurrentProcessId());
1432#else
1433    fprintf(dbgout, "[%d] Clozure CL kernel debugger: ", main_thread_pid);
1434#endif
1435    fflush(dbgout);             /* dbgout should be unbuffered, so this shouldn't be necessary.  But it can't hurt ... */
1436    state = apply_debug_command(xp, readc(), info, why);
1437  }
1438  switch (state) {
1439  case debug_exit_success:
1440    if (threads_initialized) {
1441      resume_other_threads(false);
1442    }
1443    return 0;
1444  case debug_exit_fail:
1445    if (threads_initialized) {
1446      resume_other_threads(false);
1447    }
1448    return -1;
1449  case debug_kill:
1450    terminate_lisp();
1451  default:
1452    return 0;
1453  }
1454}
1455
1456void
1457Bug(ExceptionInformation *xp, const char *format, ...)
1458{
1459  va_list args;
1460  char s[512];
1461 
1462  va_start(args, format);
1463  vsnprintf(s, sizeof(s),format, args);
1464  va_end(args);
1465  lisp_Debugger(xp, NULL, debug_entry_bug, false, s);
1466
1467}
1468
1469void
1470FBug(ExceptionInformation *xp, const char *format, ...)
1471{
1472  va_list args;
1473  char s[512];
1474 
1475  va_start(args, format);
1476  vsnprintf(s, sizeof(s),format, args);
1477  va_end(args);
1478  lisp_Debugger(xp, NULL, debug_entry_bug, true, s);
1479}
1480
1481void
1482lisp_bug(char *string)
1483{
1484  Bug(NULL, "Bug in Clozure CL system code:\n%s", string);
1485}
1486
Note: See TracBrowser for help on using the repository browser.