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

Last change on this file since 16366 was 16366, checked in by gb, 5 years ago

newfangled --debug option. Seems to work on Linux, untested elsewhere.

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