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

Last change on this file since 15606 was 15606, checked in by gb, 7 years ago

This is a work-in-progress; there will need to be new binaries
and similar changes for other architectures.

compiler/nx2.lisp: do late constant-folding on comparisons. (This depends

on being able to use operators for T and NIL in the backend; since backends
don't necessarily support that, check first.)

compiler/optimizers.lisp: bind temporaries for 3-arg numeric comparisons.

compiler/vinsn.lisp: do dead-code elimination at the vinsn level. Because

of the way that "aligned labels" work on x86, introduce an :align vinsn
attribute. Add/change some utilities for finding next/previous vinsn, etc.

compiler/X86/x862.lisp: Handle operators for T/NIL. Peephole optimize

things like (if (let ...)) where the LET returns a constant value and
we need to discard some words from the stack.

compiler/X86/X8632/x8632-arch.lisp:
compiler/X86/X8664/x8664-arch.lisp: Bump image version

compiler/X86/X8632/x8632-vinsns.lisp:
compiler/X86/X8664/x8664-vinsns.lisp: EMIT-ALIGNED-LABEL has :align

attribute

level-0/l0-hash.lisp: Don't assume that GC maintains weak-deletions; do

assume that it maintains count/deleted-count, so lock-based code adjusts
those slots atomically.

level-0/l0-misc.lisp: We don't want to use futexes (at least not instead

of spinlocks.)

level-0/X86/x86-misc.lisp: %ATOMIC-INCF-NODE needs to pause while spinning.

(Note that a locked ADD may be faster on x86, but wouldn't return a
meaningful value and some callers expect it to.)

level-1/l1-clos-boot.lisp: no more DESTRUCTURE-STATE.
level-1/l1-files.lisp: indentation change
level-1/l1-utils.lisp: no more DESTRUCTURE-STATE.
level-1/linux-files.lisp: UNSETENV

lib/hash.lisp: no need to %NORMALIZE-HASH-TABLE-COUNT.
lib/macros.lisp: no more DESTRUCTURE-STATE.

library/lispequ.lisp: no more DESTRUCTURE-STATE.

lisp-kernel/gc-common.c: decrement count when removing weak key from

hash vector; increment deleted-count if not lock-free.

lisp-kernel/x86-constants32.h:
lisp-kernel/x86-constants64.h: bump current, max image versions

lisp-kernel/linuxx8632/Makefile:
lisp-kernel/linuxx8664/Makefile: don't define USE_FUTEX.

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