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

Last change on this file since 15267 was 14837, checked in by gb, 8 years ago

Try to show ARM fp state in the kernel debugger.
(Trying to find the vfp state in the ucontext is a bit of an adventure,
and I'm not sure that that state contains a valid FPSCR value.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 38.4 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;
883
884    if (TCR_AUX(tcr))
885      cs_area = TCR_AUX(tcr)->cs_area;
886
887    fprintf(dbgout, "Current Thread Context Record (tcr) = 0x" LISP "\n", tcr);
888    fprintf(dbgout, "Control (C) stack area:  low = 0x" LISP ", high = 0x" LISP "\n",
889            (cs_area->low), (cs_area->high));
890    fprintf(dbgout, "Value (lisp) stack area: low = 0x" LISP ", high = 0x" LISP "\n",
891            (natural)(vs_area->low), (natural)vs_area->high);
892    if (xp) {
893      fprintf(dbgout, "Exception stack pointer = 0x" LISP "\n",
894#ifdef PPC
895              (natural)(xpGPR(xp,1))
896#endif
897#ifdef X86
898              (natural)(xpGPR(xp,Isp))
899#endif           
900#ifdef ARM
901              (natural)(xpGPR(xp,Rsp))
902#endif
903              );
904    }
905  }
906  return debug_continue;
907}
908     
909
910debug_command_return
911debug_set_gpr(ExceptionInformation *xp, siginfo_t *info, int arg)
912{
913  char buf[32];
914  natural val;
915
916  sprintf(buf, "value for GPR %d", arg);
917  val = debug_get_natural_value(buf);
918  xpGPR(xp,arg) = val;
919  return debug_continue;
920}
921
922debug_command_return
923debug_show_registers(ExceptionInformation *xp, siginfo_t *info, int arg)
924{
925
926
927#ifdef PPC
928#ifdef PPC64
929  int a, b;
930  for (a = 0, b = 16; a < 16; a++, b++) {
931    fprintf(dbgout,"r%02d = 0x%016lX    r%02d = 0x%016lX\n",
932            a, xpGPR(xp, a),
933            b, xpGPR(xp, b));
934  }
935 
936  fprintf(dbgout, "\n PC = 0x%016lX     LR = 0x%016lX\n",
937          xpPC(xp), xpLR(xp));
938  fprintf(dbgout, "CTR = 0x%016lX    CCR = 0x%08X\n",
939          xpCTR(xp), xpCCR(xp));
940  fprintf(dbgout, "XER = 0x%08X            MSR = 0x%016lX\n",
941          xpXER(xp), xpMSR(xp));
942  fprintf(dbgout,"DAR = 0x%016lX  DSISR = 0x%08X\n",
943          xpDAR(xp), xpDSISR(xp));
944#else
945  int a, b, c, d;;
946  for (a = 0, b = 8, c = 16, d = 24; a < 8; a++, b++, c++, d++) {
947    fprintf(dbgout,"r%02d = 0x%08X  r%02d = 0x%08X  r%02d = 0x%08X  r%02d = 0x%08X\n",
948            a, xpGPR(xp, a),
949            b, xpGPR(xp, b),
950            c, xpGPR(xp, c),
951            d, xpGPR(xp, d));
952  }
953  fprintf(dbgout, "\n PC = 0x%08X   LR = 0x%08X  CTR = 0x%08X  CCR = 0x%08X\n",
954          xpPC(xp), xpLR(xp), xpCTR(xp), xpCCR(xp));
955  fprintf(dbgout, "XER = 0x%08X  MSR = 0x%08X  DAR = 0x%08X  DSISR = 0x%08X\n",
956          xpXER(xp), xpMSR(xp), xpDAR(xp), xpDSISR(xp));
957#endif
958#endif
959
960#ifdef X8664
961  fprintf(dbgout,"%%rax = 0x" ZLISP "      %%r8  = 0x" ZLISP "\n", xpGPR(xp,REG_RAX),xpGPR(xp,REG_R8));
962  fprintf(dbgout,"%%rcx = 0x" ZLISP "      %%r9  = 0x" ZLISP "\n", xpGPR(xp,REG_RCX),xpGPR(xp,REG_R9));
963  fprintf(dbgout,"%%rdx = 0x" ZLISP "      %%r10 = 0x" ZLISP "\n", xpGPR(xp,REG_RDX),xpGPR(xp,REG_R10));
964  fprintf(dbgout,"%%rbx = 0x" ZLISP "      %%r11 = 0x" ZLISP "\n", xpGPR(xp,REG_RBX),xpGPR(xp,REG_R11));
965  fprintf(dbgout,"%%rsp = 0x" ZLISP "      %%r12 = 0x" ZLISP "\n", xpGPR(xp,REG_RSP),xpGPR(xp,REG_R12));
966  fprintf(dbgout,"%%rbp = 0x" ZLISP "      %%r13 = 0x" ZLISP "\n", xpGPR(xp,REG_RBP),xpGPR(xp,REG_R13));
967  fprintf(dbgout,"%%rsi = 0x" ZLISP "      %%r14 = 0x" ZLISP "\n", xpGPR(xp,REG_RSI),xpGPR(xp,REG_R14));
968  fprintf(dbgout,"%%rdi = 0x" ZLISP "      %%r15 = 0x" ZLISP "\n", xpGPR(xp,REG_RDI),xpGPR(xp,REG_R15));
969  fprintf(dbgout,"%%rip = 0x" ZLISP "   %%rflags = 0x%08lx\n",
970          xpGPR(xp, Iip), eflags_register(xp));
971#endif
972
973#ifdef X8632
974  unsigned short rcs,rds,res,rfs,rgs,rss;
975#ifdef DARWIN
976  rcs = xp->uc_mcontext->__ss.__cs;
977  rds = xp->uc_mcontext->__ss.__ds;
978  res = xp->uc_mcontext->__ss.__es;
979  rfs = xp->uc_mcontext->__ss.__fs;
980  rgs = xp->uc_mcontext->__ss.__gs;
981  rss = xp->uc_mcontext->__ss.__ss;
982#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
983#endif
984#ifdef LINUX
985  rcs = xp->uc_mcontext.gregs[REG_CS];
986  rds = xp->uc_mcontext.gregs[REG_DS];
987  res = xp->uc_mcontext.gregs[REG_ES];
988  rfs = xp->uc_mcontext.gregs[REG_FS];
989  rgs = xp->uc_mcontext.gregs[REG_GS];
990  rss = xp->uc_mcontext.gregs[REG_SS];
991#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
992#endif
993#ifdef FREEBSD
994  rcs = xp->uc_mcontext.mc_cs;
995  rds = xp->uc_mcontext.mc_ds;
996  res = xp->uc_mcontext.mc_es;
997  rfs = xp->uc_mcontext.mc_fs;
998  rgs = xp->uc_mcontext.mc_gs;
999  rss = xp->uc_mcontext.mc_ss;
1000#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
1001#endif
1002#ifdef SOLARIS
1003  rcs = xp->uc_mcontext.gregs[CS];
1004  rds = xp->uc_mcontext.gregs[DS];
1005  res = xp->uc_mcontext.gregs[ES];
1006  rfs = xp->uc_mcontext.gregs[FS];
1007  rgs = xp->uc_mcontext.gregs[GS];
1008  rss = xp->uc_mcontext.gregs[SS];
1009#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
1010#endif
1011#ifdef WINDOWS
1012  rcs = xp->SegCs;
1013  rds = xp->SegDs;
1014  res = xp->SegEs;
1015  rfs = xp->SegFs;
1016  rgs = xp->SegGs;
1017  rss = xp->SegSs;
1018#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
1019#endif
1020
1021
1022
1023  fprintf(dbgout, "%%eax = 0x" ZLISP "\n", xpGPR(xp, REG_EAX));
1024  fprintf(dbgout, "%%ecx = 0x" ZLISP "\n", xpGPR(xp, REG_ECX));
1025  fprintf(dbgout, "%%edx = 0x" ZLISP "\n", xpGPR(xp, REG_EDX));
1026  fprintf(dbgout, "%%ebx = 0x" ZLISP "\n", xpGPR(xp, REG_EBX));
1027  fprintf(dbgout, "%%esp = 0x" ZLISP "\n", xpGPR(xp, REG_ESP));
1028  fprintf(dbgout, "%%ebp = 0x" ZLISP "\n", xpGPR(xp, REG_EBP));
1029  fprintf(dbgout, "%%esi = 0x" ZLISP "\n", xpGPR(xp, REG_ESI));
1030  fprintf(dbgout, "%%edi = 0x" ZLISP "\n", xpGPR(xp, REG_EDI));
1031  fprintf(dbgout, "%%eip = 0x" ZLISP "\n", xpGPR(xp, REG_EIP));
1032  fprintf(dbgout, "%%eflags = 0x" ZLISP "\n", xpGPR(xp, REG_EFL));
1033#ifdef DEBUG_SHOW_X86_SEGMENT_REGISTERS
1034  fprintf(dbgout,"\n");
1035  fprintf(dbgout, "%%cs = 0x%04x\n", rcs);
1036  fprintf(dbgout, "%%ds = 0x%04x\n", rds);
1037  fprintf(dbgout, "%%ss = 0x%04x\n", rss);
1038  fprintf(dbgout, "%%es = 0x%04x\n", res);
1039  fprintf(dbgout, "%%fs = 0x%04x\n", rfs);
1040  fprintf(dbgout, "%%gs = 0x%04x\n", rgs);
1041
1042#endif
1043
1044#endif
1045
1046#ifdef ARM
1047  int a, b;
1048  for (a = 0, b = 8; a < 8; a++, b++) {
1049    fprintf(dbgout,"r%02d = 0x%08lX    r%02d = 0x%08lX\n",
1050            a, xpGPR(xp, a),
1051            b, xpGPR(xp, b));
1052  }
1053#endif
1054
1055  return debug_continue;
1056}
1057
1058#ifdef ARM
1059#ifdef LINUX
1060
1061/* This stuff is buried in kernel headers.  Why ? */
1062
1063/* The uc_regspace field of a ucontext can contain coprocessor
1064   info in structures whose first word is one of these magic
1065   values; the structure list is terminated by something that's
1066   not one of these magic values.
1067
1068   Good thinking! That'll make the mechanism easy to extend!
1069   (In practice, a word of 0 seems to terminate the structure
1070   list.)
1071*/
1072#define VFP_MAGIC               0x56465001
1073#define IWMMXT_MAGIC            0x12ef842a
1074#define CRUNCH_MAGIC            0x5065cf03
1075
1076
1077struct user_vfp {
1078        unsigned long long fpregs[32];
1079        unsigned long fpscr;
1080};
1081
1082struct user_vfp *
1083find_vfp_info(ExceptionInformation *xp)
1084{
1085  char *p = (char *)(xp->uc_regspace);
1086  unsigned *q, magic;
1087
1088  while (1) {
1089    q = (unsigned *)p;                       
1090    magic = *q;
1091    if (magic == VFP_MAGIC) {
1092      return (struct user_vfp *)(q+2);
1093    }
1094    if ((magic == CRUNCH_MAGIC) ||
1095        (magic == IWMMXT_MAGIC)) {
1096      p += q[1];
1097    }
1098    else {
1099      return NULL;
1100    }
1101  }
1102}
1103
1104#endif
1105#endif
1106
1107debug_command_return
1108debug_show_fpu(ExceptionInformation *xp, siginfo_t *info, int arg)
1109{
1110  double *dp;
1111  int *np, i;
1112#ifdef PPC
1113  dp = xpFPRvector(xp);
1114  np = (int *) dp;
1115 
1116  for (i = 0; i < 32; i++, np+=2) {
1117    fprintf(dbgout, "f%02d : 0x%08X%08X (%f)\n", i,  np[0], np[1], *dp++);
1118  }
1119  fprintf(dbgout, "FPSCR = %08X\n", xpFPSCR(xp));
1120#endif
1121#ifdef X8664
1122#ifdef LINUX
1123  struct _libc_xmmreg * xmmp = NULL;
1124#endif
1125#ifdef DARWIN
1126  struct xmm {
1127    char fpdata[16];
1128  };
1129  struct xmm *xmmp = (struct xmm *)(xpFPRvector(xp));
1130#endif
1131#ifdef WINDOWS
1132  struct xmm {
1133    char fpdata[16];
1134  };
1135  struct xmm *xmmp; /* XXX: actually get them */
1136#endif
1137#ifdef FREEBSD
1138  struct xmmacc *xmmp = xpXMMregs(xp);
1139#endif
1140#ifdef SOLARIS
1141  upad128_t *xmmp = xpXMMregs(xp);
1142#endif
1143  float *sp;
1144
1145#ifdef LINUX
1146  if (xp->uc_mcontext.fpregs)
1147    xmmp = &(xp->uc_mcontext.fpregs->_xmm[0]);
1148  else
1149    /* no fp state, apparently */
1150    return debug_continue;
1151#endif
1152
1153  for (i = 0; i < 16; i++, xmmp++) {
1154    sp = (float *) xmmp;
1155    dp = (double *) xmmp;
1156    np = (int *) xmmp;
1157    fprintf(dbgout, "f%02d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np, (double)(*sp), np[1], np[0], *dp);
1158  }
1159  fprintf(dbgout, "mxcsr = 0x%08x\n",
1160#ifdef LINUX
1161          xp->uc_mcontext.fpregs->mxcsr
1162#endif
1163#ifdef DARWIN
1164          UC_MCONTEXT(xp)->__fs.__fpu_mxcsr
1165#endif
1166#ifdef FREEBSD
1167          (((struct savefpu *)(&(xp)->uc_mcontext.mc_fpstate))->sv_env.en_mxcsr)
1168#endif
1169#ifdef SOLARIS
1170          xp->uc_mcontext.fpregs.fp_reg_set.fpchip_state.xstatus
1171#endif
1172#ifdef WINDOWS
1173          *(xpMXCSRptr(xp))
1174#endif
1175          );
1176#endif 
1177#ifdef X8632
1178#ifdef DARWIN
1179  struct xmm {
1180    char fpdata[8];
1181  };
1182  struct xmm *xmmp = (struct xmm *)(xpFPRvector(xp));
1183
1184  for (i = 0; i < 8; i++, xmmp++) {
1185    float *sp = (float *)xmmp;
1186    dp = (double *)xmmp;
1187    np = (int *)xmmp;
1188    fprintf(dbgout, "f%1d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np,
1189            (double)(*sp), np[1], np[0], *dp);
1190  }
1191  fprintf(dbgout, "mxcsr = 0x%08x\n", UC_MCONTEXT(xp)->__fs.__fpu_mxcsr);
1192#endif
1193#endif
1194#ifdef ARM
1195#ifdef LINUX
1196  struct user_vfp *vfp = find_vfp_info(xp);
1197 
1198  if (vfp != NULL) {
1199    float *fp = (float *)vfp;
1200    double *dp = (double *)vfp;
1201    unsigned *up = (unsigned *)vfp;
1202    unsigned long long *llp = (unsigned long long *)vfp;
1203    int dn,fn;
1204
1205    for (dn=0,fn=0;dn<16;dn++) {
1206      fprintf(dbgout, "s%02d = %10e (0x%08x)        s%02d = %10e (0x%08x)\n",fn,fp[fn],up[fn],fn+1,fp[fn+1],up[fn+1]);
1207      fn+=2;
1208      fprintf(dbgout, "d%02d = %10e (0x%015llx)\n",dn,dp[dn],llp[dn]);
1209    }
1210    fprintf(dbgout, "FPSCR = 0x%08x\n", vfp->fpscr);
1211  }
1212#endif
1213#endif
1214  return debug_continue;
1215}
1216
1217debug_command_return
1218debug_kill_process(ExceptionInformation *xp, siginfo_t *info, int arg) {
1219  return debug_kill;
1220}
1221
1222debug_command_return
1223debug_win(ExceptionInformation *xp, siginfo_t *info, int arg) {
1224  return debug_exit_success;
1225}
1226
1227debug_command_return
1228debug_lose(ExceptionInformation *xp, siginfo_t *info, int arg) {
1229  return debug_exit_fail;
1230}
1231
1232debug_command_return
1233debug_help(ExceptionInformation *xp, siginfo_t *info, int arg) {
1234  debug_command_entry *entry;
1235
1236  for (entry = debug_command_entries; entry->f; entry++) {
1237    /* If we have an XP or don't need one, call the function */
1238    if (xp || !(entry->flags & DEBUG_COMMAND_FLAG_REQUIRE_XP)) {
1239      fprintf(dbgout, "(%c)  %s\n", entry->c, entry->help_text);
1240    }
1241  }
1242  return debug_continue;
1243}
1244             
1245
1246 
1247
1248debug_command_return
1249debug_backtrace(ExceptionInformation *xp, siginfo_t *info, int arg)
1250{
1251  extern LispObj current_stack_pointer();
1252  extern void plbt_sp(LispObj);
1253  extern void plbt(ExceptionInformation *);
1254
1255  if (xp) {
1256    plbt(xp);
1257#ifndef X86
1258  } else {
1259    plbt_sp(current_stack_pointer());
1260#endif
1261  }
1262  return debug_continue;
1263}
1264
1265debug_command_return
1266debug_thread_reset(ExceptionInformation *xp, siginfo_t *info, int arg)
1267{
1268  reset_lisp_process(xp);
1269  return debug_exit_success;
1270}
1271
1272
1273debug_command_entry debug_command_entries[] = 
1274{
1275  {debug_set_gpr,
1276   "Set specified GPR to new value",
1277   DEBUG_COMMAND_FLAG_AUX_REGNO,
1278   "GPR to set (0-31) ?",
1279   'G'},
1280#ifndef X86
1281  {debug_advance_pc,
1282   "Advance the program counter by one instruction (use with caution!)",
1283   DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY,
1284   NULL,
1285   'A'},
1286  {debug_identify_exception,
1287   "Describe the current exception in greater detail",
1288   DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY |
1289   DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG,
1290   NULL,
1291   'D'},
1292#endif
1293  {debug_show_registers, 
1294   "Show raw GPR/SPR register values", 
1295   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1296   NULL,
1297   'R'},
1298  {debug_lisp_registers,
1299   "Show Lisp values of tagged registers",
1300   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1301   NULL,
1302   'L'},
1303  {debug_show_fpu,
1304   "Show FPU registers",
1305   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1306   NULL,
1307   'F'},
1308  {debug_show_symbol,
1309   "Find and describe symbol matching specified name",
1310   0,
1311   NULL,
1312   'S'},
1313  {debug_backtrace,
1314   "Show backtrace",
1315   0,
1316   NULL,
1317   'B'},
1318  {debug_thread_info,
1319   "Show info about current thread",
1320   0,
1321   NULL,
1322   'T'},
1323  {debug_memory_areas,
1324   "Show memory areas",
1325   0,
1326   NULL,
1327   'M'},
1328  {debug_win,
1329   "Exit from this debugger, asserting that any exception was handled",
1330   0,
1331   NULL,
1332   'X'},
1333#ifdef DARWIN
1334  {debug_lose,
1335   "Propagate the exception to another handler (debugger or OS)",
1336   DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY,
1337   NULL,
1338   'P'},
1339#endif
1340#if 0
1341  {debug_thread_reset,
1342   "Reset current thread (as if in response to stack overflow)",
1343   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1344   NULL,
1345   'T'},
1346#endif
1347  {debug_kill_process,
1348   "Kill Clozure CL process",
1349   0,
1350   NULL,
1351   'K'},
1352  {debug_show_lisp_version,
1353   "Show Subversion revision information",
1354   0,
1355   NULL,
1356   'V'},
1357  {debug_help,
1358   "Show this help",
1359   0,
1360   NULL,
1361   '?'},
1362  /* end-of-table */
1363  {NULL,
1364   NULL,
1365   0,
1366   NULL,
1367   0}
1368};
1369
1370debug_command_return
1371apply_debug_command(ExceptionInformation *xp, int c, siginfo_t *info, int why) 
1372{
1373  if (c == EOF) {
1374    return debug_kill;
1375  } else {
1376    debug_command_entry *entry;
1377    debug_command f;
1378    c = toupper(c);
1379
1380    for (entry = debug_command_entries; (f = entry->f) != NULL; entry++) {
1381      if (toupper(entry->c) == c) {
1382        /* If we have an XP or don't need one, call the function */
1383        if ((xp || !(entry->flags & DEBUG_COMMAND_FLAG_REQUIRE_XP)) &&
1384            ((why > debug_entry_exception) || 
1385             !(entry->flags & DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY))) {
1386          int arg = 0;
1387          if ((entry->flags & DEBUG_COMMAND_REG_FLAGS)
1388              == DEBUG_COMMAND_FLAG_AUX_REGNO) {
1389            arg = debug_get_u5_value("register number");
1390          }
1391          if (entry->flags & DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG) {
1392            arg = why;
1393          }
1394          return (f)(xp, info, arg);
1395        }
1396        break;
1397      }
1398    }
1399    return debug_continue;
1400  }
1401}
1402
1403void
1404debug_identify_function(ExceptionInformation *xp, siginfo_t *info) 
1405{
1406#ifdef PPC
1407  if (xp) {
1408    if (active_tcr_p((TCR *)(ptr_from_lispobj(xpGPR(xp, rcontext))))) {
1409      LispObj f = xpGPR(xp, fn), codev;
1410      pc where = xpPC(xp);
1411     
1412      if (!(codev = register_codevector_contains_pc(f, where))) {
1413        f = xpGPR(xp, nfn);
1414        codev =  register_codevector_contains_pc(f, where);
1415      }
1416      if (codev) {
1417        fprintf(dbgout, " While executing: %s\n", print_lisp_object(f));
1418      }
1419    } else {
1420      int disp;
1421      char *foreign_name;
1422      natural where = (natural)xpPC(xp);
1423
1424      fprintf(dbgout, " In foreign code at address 0x" ZLISP "\n", where);
1425      foreign_name = foreign_name_and_offset(where, &disp);
1426      if (foreign_name) {
1427        fprintf(dbgout, "  [%s + %d]\n", foreign_name, disp);
1428      }
1429    }
1430  }
1431#endif
1432}
1433
1434#ifndef WINDOWS
1435extern pid_t main_thread_pid;
1436#endif
1437
1438
1439OSStatus
1440lisp_Debugger(ExceptionInformation *xp, 
1441              siginfo_t *info, 
1442              int why, 
1443              Boolean in_foreign_code,
1444              char *message, 
1445              ...)
1446{
1447  va_list args;
1448  debug_command_return state = debug_continue;
1449
1450
1451  if (stdin_is_dev_null()) {
1452    return -1;
1453  }
1454
1455  va_start(args,message);
1456  vfprintf(dbgout, message, args);
1457  fprintf(dbgout, "\n");
1458  va_end(args);
1459
1460  if (threads_initialized) {
1461    suspend_other_threads(false);
1462  }
1463
1464  lisp_debugger_in_foreign_code = in_foreign_code;
1465  if (in_foreign_code) {   
1466    char *foreign_name;
1467    int disp;
1468    fprintf(dbgout, "Exception occurred while executing foreign code\n");
1469    foreign_name = foreign_name_and_offset((natural)xpPC(xp), &disp);
1470    if (foreign_name) {
1471      fprintf(dbgout, " at %s + %d\n", foreign_name, disp);
1472    }
1473  }
1474
1475  if (xp) {
1476    if (why > debug_entry_exception) {
1477      debug_identify_exception(xp, info, why);
1478    }
1479    debug_identify_function(xp, info);
1480  }
1481  if (lisp_global(BATCH_FLAG)) {
1482#ifdef WINDOWS
1483    fprintf(dbgout, "Current Process Id %d\n", (int)GetCurrentProcessId());
1484#else
1485    fprintf(dbgout, "Main thread pid %d\n", main_thread_pid);
1486#endif
1487    debug_thread_info(xp, info, 0);
1488    if (xp) {
1489      debug_show_registers(xp, info, 0);
1490      debug_lisp_registers(xp, info, 0);
1491      debug_show_fpu(xp, info, 0);
1492    }
1493    debug_memory_areas(xp, info, 0);
1494    debug_show_lisp_version(xp, info, 0);
1495    debug_backtrace(xp, info, 0);
1496    abort();
1497  }
1498
1499  fprintf(dbgout, "? for help\n");
1500  while (state == debug_continue) {
1501#ifdef WINDOWS
1502    fprintf(dbgout, "[%d] Clozure CL kernel debugger: ", (int)GetCurrentProcessId());
1503#else
1504    fprintf(dbgout, "[%d] Clozure CL kernel debugger: ", main_thread_pid);
1505#endif
1506    fflush(dbgout);             /* dbgout should be unbuffered, so this shouldn't be necessary.  But it can't hurt ... */
1507    state = apply_debug_command(xp, readc(), info, why);
1508  }
1509  switch (state) {
1510  case debug_exit_success:
1511    if (threads_initialized) {
1512      resume_other_threads(false);
1513    }
1514    return 0;
1515  case debug_exit_fail:
1516    if (threads_initialized) {
1517      resume_other_threads(false);
1518    }
1519    return -1;
1520  case debug_kill:
1521    terminate_lisp();
1522  default:
1523    return 0;
1524  }
1525}
1526
1527void
1528Bug(ExceptionInformation *xp, const char *format, ...)
1529{
1530  va_list args;
1531  char s[512];
1532 
1533  va_start(args, format);
1534  vsnprintf(s, sizeof(s),format, args);
1535  va_end(args);
1536  lisp_Debugger(xp, NULL, debug_entry_bug, false, s);
1537
1538}
1539
1540void
1541FBug(ExceptionInformation *xp, const char *format, ...)
1542{
1543  va_list args;
1544  char s[512];
1545 
1546  va_start(args, format);
1547  vsnprintf(s, sizeof(s),format, args);
1548  va_end(args);
1549  lisp_Debugger(xp, NULL, debug_entry_bug, true, s);
1550}
1551
1552void
1553lisp_bug(char *string)
1554{
1555  Bug(NULL, "Bug in Clozure CL system code:\n%s", string);
1556}
1557
Note: See TracBrowser for help on using the repository browser.