source: branches/gb-egc/lisp-kernel/lisp-debug.c @ 15840

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

meaningless workaround for meaningless compiler warning

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