source: release/1.9/source/lisp-kernel/lisp-debug.c @ 16083

Last change on this file since 16083 was 15638, checked in by gb, 6 years ago

Try to keep Apple C quiet(er).
Darwin x86 kernels.

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