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

Last change on this file since 11596 was 11596, checked in by gb, 11 years ago

Print the message before suspending other threads on entry to the
kernel debugger.

Also, check to see if fd 0 is open to /dev/null on entry to the
kernel debugger (after printing the message but before suspending
threads.) If so, exit from the kernel debugger with a non-zero
value; this should cause cases where it's entered in response to
an unhandled exception to set a bit in the TCR and should cause
the exception handler to return (repeating the trap/fault). On
Darwin, the Mach exception handler will assert that the exception
wasn't handled, causing the exception to be passed to a task-level
handler (or signal handler); for an OSX GUI application, this can
cause Apple's crash dialog to be invoked.

We could get a vaguely similar effect on other platforms by
de-installing our signal handler (or Windows exception handler),
but it wouldn't be guaranteed that the next (now fatal) exception
would be the one that we tried to propagate in this way: some
other thread might do something innocuous - like consing - that
raises an unrelated exception.

In the case of an OSX GUI application (that hasn't redirected
its standard fds), we may be able to generate a more meaningful
crash report (with lisp thread info, lisp-aware backtraces, etc.)
than what Apple's crash dialog provides. Apple's mechanism does
at least make it clear that the application terminated abnormally;
writing to syslog or writing to a text file somewhere may leave
some end-users (at least) puzzled ("the application terminated
unexpectedly, and I wasn't notified ?").

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 28.2 KB
Line 
1/*
2   Copyright (C) 1994-2001 Digitool, Inc
3   This file is part of OpenMCL. 
4
5   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
6   License , known as the LLGPL and distributed with OpenMCL as the
7   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
8   which is distributed with OpenMCL as the file "LGPL".  Where these
9   conflict, the preamble takes precedence. 
10
11   OpenMCL is referenced in the preamble as the "LIBRARY."
12
13   The LLGPL is also available online at
14   http://opensource.franz.com/preamble.html
15*/
16
17#include "lisp.h"
18#include "lisp-exceptions.h"
19#include "lisp_globals.h"
20#include "area.h"
21#include "Threads.h"
22#include <ctype.h>
23#include <stdio.h>
24#include <stddef.h>
25#include <string.h>
26#include <stdarg.h>
27#include <errno.h>
28#include <stdio.h>
29
30#ifndef WINDOWS
31#include <sys/socket.h>
32#include <dlfcn.h>
33#endif
34#include <sys/stat.h>
35
36
37typedef enum {
38  debug_continue,               /* stay in the repl */
39  debug_exit_success,           /* return 0 from lisp_Debugger */
40  debug_exit_fail,              /* return non-zero from lisp_Debugger */
41  debug_kill
42} debug_command_return;
43
44
45
46typedef debug_command_return (*debug_command) (ExceptionInformation *,
47                                               siginfo_t *,
48                                               int);
49
50#define DEBUG_COMMAND_FLAG_REQUIRE_XP 1 /* function  */
51#define DEBUG_COMMAND_FLAG_AUX_REGNO  (2 | DEBUG_COMMAND_FLAG_REQUIRE_XP)
52#define DEBUG_COMMAND_FLAG_AUX_SPR (4 | DEBUG_COMMAND_FLAG_REQUIRE_XP)
53#define DEBUG_COMMAND_REG_FLAGS 7
54#define DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY 8
55#define DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG 16
56
57typedef struct {
58  debug_command f;
59  char *help_text;
60  unsigned flags;
61  char *aux_prompt;
62  int c;
63} debug_command_entry;
64
65
66extern
67debug_command_entry debug_command_entries[];
68
69Boolean lisp_debugger_in_foreign_code = false;
70
71#ifndef WINDOWS
72Boolean
73fd0_is_dev_null()
74{
75  struct stat fd0stat, devnullstat;
76
77  if (fstat(0,&fd0stat)) {
78    return true;
79  }
80  if (stat("/dev/null",&devnullstat)) {
81    return true;
82  }
83  return ((fd0stat.st_ino == devnullstat.st_ino) &&
84          (fd0stat.st_dev == devnullstat.st_dev));
85}
86
87#endif
88
89char *
90foreign_name_and_offset(natural addr, int *delta)
91{
92#ifndef WINDOWS
93  Dl_info info;
94#endif
95  char *ret = NULL;
96
97  if (delta) {
98    *delta = 0;
99  }
100#ifndef WINDOWS
101  if (dladdr((void *)addr, &info)) {
102    ret = (char *)info.dli_sname;
103    if (delta) {
104      *delta = ((natural)addr - (natural)info.dli_saddr);
105    }
106  }
107#endif
108  return ret;
109}
110
111
112#if defined(LINUX) || defined(SOLARIS)
113#define fpurge __fpurge
114#endif
115
116#ifdef WINDOWS
117void
118fpurge (FILE* file)
119{
120}
121#endif
122
123int
124readc()
125{
126  int c;
127  while (1) {
128    c = getchar();
129    switch(c) {
130    case '\n':
131      continue;
132    case EOF:
133      if (ferror(stdin)) {
134        if ((errno == EINTR) || (errno == EIO)) {
135          continue;
136        }
137      }
138      /* fall through */
139    default:
140      return c;
141    }
142  }
143}
144
145#ifdef X8664
146#ifdef LINUX
147char* Iregnames[] = {"r8 ","r9 ","r10","r11","r12","r13","r14","r15",
148                     "rdi","rsi","rbp", "rbx", "rdx", "rax", "rcx","rsp"};
149#endif
150#ifdef SOLARIS
151char* Iregnames[] = {"r15 ","r14 ","r13","r12","r11","r10","r9 ","r8 ",
152                     "rdi","rsi","rbp", "rbx", "rdx", "rcx", "rcx","rsp"};
153#endif
154#ifdef FREEBSD
155char* Iregnames[] = {"???", "rdi", "rsi", "rdx", "rcx", "r8 ", "r9 ", "rax",
156                     "rbx", "rbp", "r10", "r11", "r12", "r13", "r14", "r15",
157                     "???", "???", "???", "???", "???", "???", "???", "rsp"};
158#endif
159#ifdef DARWIN
160char* Iregnames[] = {"rax", "rbx", "rcx", "rdx", "rdi", "rsi",
161                     "rbp", "rsp", "r8 ", "r9 ", "r10", "r11", "r12", "r13",
162                     "r14", "r15", "rip", "rfl"};
163#endif
164#ifdef WINDOWS
165char* Iregnames[] = {"rax ","rcx ","rdx","rbx","rsp","rrbp","rsi","rdi",
166                     "r8","r9","r10", "r11", "r12", "r13", "r14","r15"};
167#endif
168#endif
169
170#ifdef X8632
171#ifdef DARWIN
172char *Iregnames[] = {"eax", "ebx", "ecx", "edx", "edi", "esi",
173                     "ebp", "???", "efl", "eip"};
174#endif
175#ifdef LINUX
176char *Iregnames[] = {"???", "???", "???", "???",
177                     "edi", "esi", "ebp", "esp",
178                     "ebx", "edx", "ecx", "eax",
179                     "???", "???", "eip", "???", "efl"};
180#endif
181#ifdef WINDOWS
182char *Iregnames[] = {"edi", "esi", "ebx", "edx", "ecx", "eax",
183                     "ebp", "eip", "???", "efl", "esp"};
184#endif
185#ifdef FREEBSD
186char *Iregnames[] = {"???", "???", "???", "???", "???"
187                     "edi", "esi", "ebp", "ebx", "edx", 
188                     "ecx", "eax", "???", "???", "eip",
189                     "???", "efl", "esp"};
190#endif
191#ifdef SOLARIS
192char *Iregnames[] = {"???", "???", "???", "???", "???",
193                     "edi", "esi", "ebp", "???", "ebx",
194                     "edx", "ecx", "eax", "???", "???",
195                     "eip", "???", "efl", "esp"};
196#endif
197#endif
198
199#ifdef X8632
200int bit_for_regnum(int r)
201{
202  switch (r) {
203  case REG_EAX: return 1<<0;
204  case REG_ECX: return 1<<1;
205  case REG_EDX: return 1<<2;
206  case REG_EBX: return 1<<3;
207  case REG_ESP: return 1<<4;
208  case REG_EBP: return 1<<5;
209  case REG_ESI: return 1<<6;
210  case REG_EDI: return 1<<7;
211  }
212}
213#endif
214
215void
216show_lisp_register(ExceptionInformation *xp, char *label, int r)
217{
218
219  extern char* print_lisp_object(LispObj);
220
221  LispObj val = xpGPR(xp, r);
222
223#ifdef PPC
224  fprintf(stderr, "r%02d (%s) = %s\n", r, label, print_lisp_object(val));
225#endif
226#ifdef X8664
227  fprintf(stderr, "%%%s (%s) = %s\n",Iregnames[r], label, print_lisp_object(val));
228#endif
229#ifdef X8632
230  {
231    TCR *tcr = get_tcr(false);
232    char *s;
233
234    if (r == REG_EDX && (xpGPR(xp, REG_EFL) & EFL_DF))
235      s = "marked as unboxed (DF set)";
236    else if (tcr && (tcr->node_regs_mask & bit_for_regnum(r)) == 0)
237      s = "marked as unboxed (node_regs_mask)";
238    else
239      s = print_lisp_object(val);
240
241    fprintf(stderr, "%%%s (%s) = %s\n", Iregnames[r], label, s);
242  }
243#endif
244
245}
246
247
248void
249describe_memfault(ExceptionInformation *xp, siginfo_t *info)
250{
251#ifdef PPC
252  void *addr = (void *)xpDAR(xp);
253  natural dsisr = xpDSISR(xp);
254
255  fprintf(stderr, "%s operation to %s address 0x%lx\n",
256          dsisr & (1<<25) ? "Write" : "Read",
257          dsisr & (1<<27) ? "protected" : "unmapped",
258          addr);
259#endif
260}
261
262#ifdef PPC
263void
264describe_ppc_illegal(ExceptionInformation *xp)
265{
266  pc where = xpPC(xp);
267  opcode the_uuo = *where;
268  Boolean described = false;
269
270  if (IS_UUO(the_uuo)) {
271    unsigned 
272      minor = UUO_MINOR(the_uuo),
273      errnum = 0x3ff & (the_uuo >> 16);
274
275    switch(minor) {
276    case UUO_INTERR:
277      switch (errnum) {
278      case error_udf_call:
279        fprintf(stderr, "ERROR: undefined function call: %s\n",
280                print_lisp_object(xpGPR(xp,fname)));
281        described = true;
282        break;
283       
284      default:
285        fprintf(stderr, "ERROR: lisp error %d\n", errnum);
286        described = true;
287        break;
288      }
289      break;
290     
291    default:
292      break;
293    }
294  }
295  if (!described) {
296    fprintf(stderr, "Illegal instruction (0x%08x) at 0x%lx\n",
297            the_uuo, where);
298  }
299}
300#endif
301
302#ifdef PPC
303void
304describe_ppc_trap(ExceptionInformation *xp)
305{
306  pc where = xpPC(xp);
307  opcode the_trap = *where, instr;
308  int err_arg2, ra, rs;
309  Boolean identified = false;
310
311  if ((the_trap & OP_MASK) == OP(major_opcode_TRI)) {
312    /* TWI/TDI.  If the RA field is "nargs", that means that the
313       instruction is either a number-of-args check or an
314       event-poll.  Otherwise, the trap is some sort of
315       typecheck. */
316
317    if (RA_field(the_trap) == nargs) {
318      switch (TO_field(the_trap)) {
319      case TO_NE:
320        if (xpGPR(xp, nargs) < D_field(the_trap)) {
321          fprintf(stderr, "Too few arguments (no opt/rest)\n");
322        } else {
323          fprintf(stderr, "Too many arguments (no opt/rest)\n");
324        }
325        identified = true;
326        break;
327       
328      case TO_GT:
329        fprintf(stderr, "Event poll !\n");
330        identified = true;
331        break;
332       
333      case TO_HI:
334        fprintf(stderr, "Too many arguments (with opt)\n");
335        identified = true;
336        break;
337       
338      case TO_LT:
339        fprintf(stderr, "Too few arguments (with opt/rest/key)\n");
340        identified = true;
341        break;
342       
343      default:                /* some weird trap, not ours. */
344        identified = false;
345        break;
346      }
347    } else {
348      /* A type or boundp trap of some sort. */
349      switch (TO_field(the_trap)) {
350      case TO_EQ:
351        /* Boundp traps are of the form:
352           treqi rX,unbound
353           where some preceding instruction is of the form:
354           lwz/ld rX,symbol.value(rY).
355           The error message should try to say that rY is unbound. */
356       
357        if (D_field(the_trap) == unbound) {
358#ifdef PPC64
359          instr = scan_for_instr(LD_instruction(RA_field(the_trap),
360                                                unmasked_register,
361                                                offsetof(lispsymbol,vcell)-fulltag_misc),
362                                 D_RT_IMM_MASK,
363                                 where);
364#else
365          instr = scan_for_instr(LWZ_instruction(RA_field(the_trap),
366                                                 unmasked_register,
367                                                 offsetof(lispsymbol,vcell)-fulltag_misc),
368                                 D_RT_IMM_MASK,
369                                 where);
370#endif
371          if (instr) {
372            ra = RA_field(instr);
373            if (lisp_reg_p(ra)) {
374              fprintf(stderr, "Unbound variable: %s\n",
375                      print_lisp_object(xpGPR(xp,ra)));
376              identified = true;       
377            }
378          }
379        }
380        break;
381       
382      case TO_NE:
383        /* A type check.  If the type (the immediate field of the trap
384           instruction) is a header type, an "lbz
385           rX,misc_header_offset(rY)" should precede it, in which case
386           we say that "rY is not of header type <type>."  If the type
387           is not a header type, then rX should have been set by a
388           preceding "clrlwi rX,rY,29/30".  In that case, scan
389           backwards for an RLWINM instruction that set rX and report
390           that rY isn't of the indicated type. */
391        err_arg2 = D_field(the_trap);
392        if (nodeheader_tag_p(err_arg2) ||
393            immheader_tag_p(err_arg2)) {
394          instr = scan_for_instr(LBZ_instruction(RA_field(the_trap),
395                                                 unmasked_register,
396                                                 misc_subtag_offset),
397                                 D_RT_IMM_MASK,
398                                 where);
399          if (instr) {
400            ra = RA_field(instr);
401            if (lisp_reg_p(ra)) {
402              fprintf(stderr, "value 0x%lX is not of the expected header type 0x%02X\n", xpGPR(xp, ra), err_arg2);
403              identified = true;
404            }
405          }
406        } else {               
407          /* Not a header type, look for rlwinm whose RA field matches the_trap's */
408          instr = scan_for_instr((OP(major_opcode_RLWINM) | (the_trap & RA_MASK)),
409                                 (OP_MASK | RA_MASK),
410                                 where);
411          if (instr) {
412            rs = RS_field(instr);
413            if (lisp_reg_p(rs)) {
414              fprintf(stderr, "value 0x%lX is not of the expected type 0x%02X\n",
415                      xpGPR(xp, rs), err_arg2);
416              identified = true;
417            }
418          }
419        }
420        break;
421      }
422    }
423  } else {
424    /* a "TW <to>,ra,rb" instruction."
425       twltu sp,rN is stack-overflow on SP.
426       twgeu rX,rY is subscript out-of-bounds, which was preceded
427       by an "lwz rM,misc_header_offset(rN)" instruction.
428       rM may or may not be the same as rY, but no other header
429       would have been loaded before the trap. */
430    switch (TO_field(the_trap)) {
431    case TO_LO:
432      if (RA_field(the_trap) == sp) {
433        fprintf(stderr, "Stack overflow! Run away! Run away!\n");
434        identified = true;
435      }
436      break;
437     
438    case (TO_HI|TO_EQ):
439      instr = scan_for_instr(OP(major_opcode_LWZ) | (D_MASK & misc_header_offset),
440                             (OP_MASK | D_MASK),
441                             where);
442      if (instr) {
443        ra = RA_field(instr);
444        if (lisp_reg_p(ra)) {
445          fprintf(stderr, "Bad index %d for vector %lX length %d\n",
446                  unbox_fixnum(xpGPR(xp, RA_field(the_trap))),
447                  xpGPR(xp, ra),
448                  unbox_fixnum(xpGPR(xp, RB_field(the_trap))));
449          identified = true;
450        }
451      }
452      break;
453    }
454  }
455
456  if (!identified) {
457    fprintf(stderr, "Unknown trap: 0x%08x\n", the_trap);
458  }
459
460
461}
462#endif
463
464debug_command_return
465debug_lisp_registers(ExceptionInformation *xp, siginfo_t *info, int arg)
466{
467  if (lisp_debugger_in_foreign_code == false) {
468#ifdef PPC
469    TCR *xpcontext = (TCR *)ptr_from_lispobj(xpGPR(xp, rcontext));
470
471    fprintf(stderr, "rcontext = 0x%lX ", xpcontext);
472    if (!active_tcr_p(xpcontext)) {
473      fprintf(stderr, "(INVALID)\n");
474    } else {
475      fprintf(stderr, "\nnargs = %d\n", xpGPR(xp, nargs) >> fixnumshift);
476      show_lisp_register(xp, "fn", fn);
477      show_lisp_register(xp, "arg_z", arg_z);
478      show_lisp_register(xp, "arg_y", arg_y);
479      show_lisp_register(xp, "arg_x", arg_x);
480      show_lisp_register(xp, "temp0", temp0);
481      show_lisp_register(xp, "temp1/next_method_context", temp1);
482      show_lisp_register(xp, "temp2/nfn", temp2);
483      show_lisp_register(xp, "temp3/fname", temp3);
484      /*    show_lisp_register(xp, "new_fn", new_fn); */
485      show_lisp_register(xp, "save0", save0);
486      show_lisp_register(xp, "save1", save1);
487      show_lisp_register(xp, "save2", save2);
488      show_lisp_register(xp, "save3", save3);
489      show_lisp_register(xp, "save4", save4);
490      show_lisp_register(xp, "save5", save5);
491      show_lisp_register(xp, "save6", save6);
492      show_lisp_register(xp, "save7", save7);
493    }
494#endif
495#ifdef X8664
496
497    show_lisp_register(xp, "arg_z", Iarg_z);
498    show_lisp_register(xp, "arg_y", Iarg_y);
499    show_lisp_register(xp, "arg_x", Iarg_x);
500    fprintf(stderr,"------\n");
501    show_lisp_register(xp, "fn", Ifn);
502    fprintf(stderr,"------\n");
503    show_lisp_register(xp, "save0", Isave0);
504    show_lisp_register(xp, "save1", Isave1);
505    show_lisp_register(xp, "save2", Isave2);
506    show_lisp_register(xp, "save3", Isave3);
507    fprintf(stderr,"------\n");
508    show_lisp_register(xp, "temp0", Itemp0);
509    show_lisp_register(xp, "temp1", Itemp1);
510    show_lisp_register(xp, "temp2", Itemp2);
511    fprintf(stderr,"------\n");
512    if (tag_of(xpGPR(xp,Inargs)) == tag_fixnum) {
513      fprintf(stderr,"%%rcx (nargs) = %ld (maybe)\n", unbox_fixnum(xpGPR(xp,Inargs)&0xffff));
514    }
515#endif
516  }
517
518#ifdef X8632
519  show_lisp_register(xp, "arg_z", Iarg_z);
520  show_lisp_register(xp, "arg_y", Iarg_y);
521  fprintf(stderr,"------\n");
522  show_lisp_register(xp, "fn", Ifn);
523  fprintf(stderr,"------\n");
524  show_lisp_register(xp, "temp0", Itemp0);
525  show_lisp_register(xp, "temp1", Itemp1);
526  fprintf(stderr,"------\n");
527  if (tag_of(xpGPR(xp,Inargs)) == tag_fixnum) {
528    fprintf(stderr,"%%edx (nargs) = %d (maybe)\n", unbox_fixnum(xpGPR(xp,Inargs)));
529  }
530#endif
531 
532  return debug_continue;
533}
534
535#ifdef PPC
536debug_command_return
537debug_advance_pc(ExceptionInformation *xp, siginfo_t *info, int arg)
538{
539  adjust_exception_pc(xp,4);
540  return debug_continue;
541}
542#endif
543
544debug_command_return
545debug_identify_exception(ExceptionInformation *xp, siginfo_t *info, int arg)
546{
547#ifdef PPC
548  pc program_counter = xpPC(xp);
549  opcode instruction = 0;
550
551  switch (arg) {
552  case SIGILL:
553  case SIGTRAP:
554    instruction = *program_counter;
555    if (major_opcode_p(instruction, major_opcode_TRI) ||
556        X_opcode_p(instruction,major_opcode_X31,minor_opcode_TR)) {
557      describe_ppc_trap(xp);
558    } else {
559      describe_ppc_illegal(xp);
560    }
561    break;
562  case SIGSEGV:
563  case SIGBUS:
564    describe_memfault(xp, info);
565    break;
566  default:
567    break;
568  }
569#endif
570  return debug_continue;
571}
572
573char *
574debug_get_string_value(char *prompt)
575{
576  static char buf[128];
577  char *p, *res;
578
579  do {
580    fpurge(stdin);
581    fprintf(stderr, "\n %s :",prompt);
582    buf[0] = 0;
583    res = fgets(buf, sizeof(buf), stdin);
584  } while (0);
585  p = strchr(res, '\n');
586  if (p) {
587    *p = 0;
588    return buf;
589  }
590  return NULL;
591}
592
593natural
594debug_get_natural_value(char *prompt)
595{
596  char s[32], *res;
597  int n;
598  natural val;
599
600  do {
601    fpurge(stdin);
602    fprintf(stderr, "\n  %s :", prompt);
603    s[0]=0;
604    res = fgets(s, 24, stdin);
605    n = sscanf(s, "%lu", &val);
606  } while (n != 1);
607  return val;
608}
609
610unsigned
611debug_get_u5_value(char *prompt)
612{
613  char s[32], *res;
614  int n;
615  unsigned val;
616
617  do {
618    fpurge(stdin);
619    fprintf(stderr, "\n  %s :", prompt);
620    res = fgets(s, 24, stdin);
621    n = sscanf(res, "%i", &val);
622  } while ((n != 1) || (val > 31));
623  return val;
624}
625
626debug_command_return
627debug_show_symbol(ExceptionInformation *xp, siginfo_t *info, int arg)
628{
629  char *pname = debug_get_string_value("symbol name");
630  extern void *plsym(ExceptionInformation *,char*);
631 
632  if (pname != NULL) {
633    plsym(xp, pname);
634  }
635  return debug_continue;
636}
637
638debug_command_return
639debug_thread_info(ExceptionInformation *xp, siginfo_t *info, int arg)
640{
641  TCR * tcr = get_tcr(false);
642 
643  if (tcr) {
644    area *vs_area = tcr->vs_area, *cs_area = tcr->cs_area;
645
646    fprintf(stderr, "Current Thread Context Record (tcr) = 0x" LISP "\n", tcr);
647    fprintf(stderr, "Control (C) stack area:  low = 0x" LISP ", high = 0x" LISP "\n",
648            (cs_area->low), (cs_area->high));
649    fprintf(stderr, "Value (lisp) stack area: low = 0x" LISP ", high = 0x" LISP "\n",
650            (u64_t)(natural)(vs_area->low), (u64_t)(natural)vs_area->high);
651    fprintf(stderr, "Exception stack pointer = 0x" LISP "\n",
652#ifdef PPC
653            (u64_t) (natural)(xpGPR(xp,1))
654#endif
655#ifdef X86
656            (u64_t) (natural)(xpGPR(xp,Isp))
657#endif
658            );
659  }
660  return debug_continue;
661}
662     
663
664debug_command_return
665debug_set_gpr(ExceptionInformation *xp, siginfo_t *info, int arg)
666{
667  char buf[32];
668  natural val;
669
670  sprintf(buf, "value for GPR %d", arg);
671  val = debug_get_natural_value(buf);
672  xpGPR(xp,arg) = val;
673  return debug_continue;
674}
675
676debug_command_return
677debug_show_registers(ExceptionInformation *xp, siginfo_t *info, int arg)
678{
679
680#ifdef PPC
681#ifdef PPC64
682  int a, b;
683  for (a = 0, b = 16; a < 16; a++, b++) {
684    fprintf(stderr,"r%02d = 0x%016lX    r%02d = 0x%016lX\n",
685            a, xpGPR(xp, a),
686            b, xpGPR(xp, b));
687  }
688 
689  fprintf(stderr, "\n PC = 0x%016lX     LR = 0x%016lX\n",
690          xpPC(xp), xpLR(xp));
691  fprintf(stderr, "CTR = 0x%016lX    CCR = 0x%08X\n",
692          xpCTR(xp), xpCCR(xp));
693  fprintf(stderr, "XER = 0x%08X            MSR = 0x%016lX\n",
694          xpXER(xp), xpMSR(xp));
695  fprintf(stderr,"DAR = 0x%016lX  DSISR = 0x%08X\n",
696          xpDAR(xp), xpDSISR(xp));
697#else
698  int a, b, c, d;;
699  for (a = 0, b = 8, c = 16, d = 24; a < 8; a++, b++, c++, d++) {
700    fprintf(stderr,"r%02d = 0x%08X  r%02d = 0x%08X  r%02d = 0x%08X  r%02d = 0x%08X\n",
701            a, xpGPR(xp, a),
702            b, xpGPR(xp, b),
703            c, xpGPR(xp, c),
704            d, xpGPR(xp, d));
705  }
706  fprintf(stderr, "\n PC = 0x%08X   LR = 0x%08X  CTR = 0x%08X  CCR = 0x%08X\n",
707          xpPC(xp), xpLR(xp), xpCTR(xp), xpCCR(xp));
708  fprintf(stderr, "XER = 0x%08X  MSR = 0x%08X  DAR = 0x%08X  DSISR = 0x%08X\n",
709          xpXER(xp), xpMSR(xp), xpDAR(xp), xpDSISR(xp));
710#endif
711#endif
712
713#ifdef X8664
714  fprintf(stderr,"%%rax = 0x" ZLISP "      %%r8  = 0x" ZLISP "\n", xpGPR(xp,REG_RAX),xpGPR(xp,REG_R8));
715  fprintf(stderr,"%%rcx = 0x" ZLISP "      %%r9  = 0x" ZLISP "\n", xpGPR(xp,REG_RCX),xpGPR(xp,REG_R9));
716  fprintf(stderr,"%%rdx = 0x" ZLISP "      %%r10 = 0x" ZLISP "\n", xpGPR(xp,REG_RDX),xpGPR(xp,REG_R10));
717  fprintf(stderr,"%%rbx = 0x" ZLISP "      %%r11 = 0x" ZLISP "\n", xpGPR(xp,REG_RBX),xpGPR(xp,REG_R11));
718  fprintf(stderr,"%%rsp = 0x" ZLISP "      %%r12 = 0x" ZLISP "\n", xpGPR(xp,REG_RSP),xpGPR(xp,REG_R12));
719  fprintf(stderr,"%%rbp = 0x" ZLISP "      %%r13 = 0x" ZLISP "\n", xpGPR(xp,REG_RBP),xpGPR(xp,REG_R13));
720  fprintf(stderr,"%%rsi = 0x" ZLISP "      %%r14 = 0x" ZLISP "\n", xpGPR(xp,REG_RSI),xpGPR(xp,REG_R14));
721  fprintf(stderr,"%%rdi = 0x" ZLISP "      %%r15 = 0x" ZLISP "\n", xpGPR(xp,REG_RDI),xpGPR(xp,REG_R15));
722  fprintf(stderr,"%%rip = 0x" ZLISP "   %%rflags = 0x%08lx\n",
723          xpGPR(xp, Iip), eflags_register(xp));
724#endif
725
726#ifdef X8632
727  fprintf(stderr, "%%eax = 0x" ZLISP "\n", xpGPR(xp, REG_EAX));
728  fprintf(stderr, "%%ecx = 0x" ZLISP "\n", xpGPR(xp, REG_ECX));
729  fprintf(stderr, "%%edx = 0x" ZLISP "\n", xpGPR(xp, REG_EDX));
730  fprintf(stderr, "%%ebx = 0x" ZLISP "\n", xpGPR(xp, REG_EBX));
731  fprintf(stderr, "%%esp = 0x" ZLISP "\n", xpGPR(xp, REG_ESP));
732  fprintf(stderr, "%%ebp = 0x" ZLISP "\n", xpGPR(xp, REG_EBP));
733  fprintf(stderr, "%%esi = 0x" ZLISP "\n", xpGPR(xp, REG_ESI));
734  fprintf(stderr, "%%edi = 0x" ZLISP "\n", xpGPR(xp, REG_EDI));
735  fprintf(stderr, "%%eip = 0x" ZLISP "\n", xpGPR(xp, REG_EIP));
736  fprintf(stderr, "%%eflags = 0x" ZLISP "\n", xpGPR(xp, REG_EFL));
737#endif
738
739  return debug_continue;
740}
741
742debug_command_return
743debug_show_fpu(ExceptionInformation *xp, siginfo_t *info, int arg)
744{
745  double *dp;
746  int *np, i;
747#ifdef PPC
748  dp = xpFPRvector(xp);
749  np = (int *) dp;
750 
751  for (i = 0; i < 32; i++, np+=2) {
752    fprintf(stderr, "f%02d : 0x%08X%08X (%f)\n", i,  np[0], np[1], *dp++);
753  }
754  fprintf(stderr, "FPSCR = %08X\n", xpFPSCR(xp));
755#endif
756#ifdef X8664
757#ifdef LINUX
758  struct _libc_xmmreg * xmmp = &(xp->uc_mcontext.fpregs->_xmm[0]);
759#endif
760#ifdef DARWIN
761  struct xmm {
762    char fpdata[16];
763  };
764  struct xmm *xmmp = (struct xmm *)(xpFPRvector(xp));
765#endif
766#ifdef WINDOWS
767  struct xmm {
768    char fpdata[16];
769  };
770  struct xmm *xmmp; /* XXX: actually get them */
771#endif
772#ifdef FREEBSD
773  struct xmmacc *xmmp = xpXMMregs(xp);
774#endif
775#ifdef SOLARIS
776  upad128_t *xmmp = xpXMMregs(xp);
777#endif
778  float *sp;
779
780
781  for (i = 0; i < 16; i++, xmmp++) {
782    sp = (float *) xmmp;
783    dp = (double *) xmmp;
784    np = (int *) xmmp;
785    fprintf(stderr, "f%02d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np, (double)(*sp), np[1], np[0], *dp);
786  }
787  fprintf(stderr, "mxcsr = 0x%08x\n",
788#ifdef LINUX
789          xp->uc_mcontext.fpregs->mxcsr
790#endif
791#ifdef DARWIN
792          UC_MCONTEXT(xp)->__fs.__fpu_mxcsr
793#endif
794#ifdef FREEBSD
795          (((struct savefpu *)(&(xp)->uc_mcontext.mc_fpstate))->sv_env.en_mxcsr)
796#endif
797#ifdef SOLARIS
798          xp->uc_mcontext.fpregs.fp_reg_set.fpchip_state.xstatus
799#endif
800#ifdef WINDOWS
801          0 /* XXX: get from somewhere */
802#endif
803          );
804#endif 
805#ifdef X8632
806#ifdef DARWIN
807  struct xmm {
808    char fpdata[8];
809  };
810  struct xmm *xmmp = (struct xmm *)(xpFPRvector(xp));
811
812  for (i = 0; i < 8; i++, xmmp++) {
813    float *sp = (float *)xmmp;
814    dp = (double *)xmmp;
815    np = (int *)xmmp;
816    fprintf(stderr, "f%1d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np,
817            (double)(*sp), np[1], np[0], *dp);
818  }
819  fprintf(stderr, "mxcsr = 0x%08x\n", UC_MCONTEXT(xp)->__fs.__fpu_mxcsr);
820#endif
821#endif
822
823  return debug_continue;
824}
825
826debug_command_return
827debug_kill_process(ExceptionInformation *xp, siginfo_t *info, int arg) {
828  return debug_kill;
829}
830
831debug_command_return
832debug_win(ExceptionInformation *xp, siginfo_t *info, int arg) {
833  return debug_exit_success;
834}
835
836debug_command_return
837debug_lose(ExceptionInformation *xp, siginfo_t *info, int arg) {
838  return debug_exit_fail;
839}
840
841debug_command_return
842debug_help(ExceptionInformation *xp, siginfo_t *info, int arg) {
843  debug_command_entry *entry;
844
845  for (entry = debug_command_entries; entry->f; entry++) {
846    /* If we have an XP or don't need one, call the function */
847    if (xp || !(entry->flags & DEBUG_COMMAND_FLAG_REQUIRE_XP)) {
848      fprintf(stderr, "(%c)  %s\n", entry->c, entry->help_text);
849    }
850  }
851  return debug_continue;
852}
853             
854
855 
856
857debug_command_return
858debug_backtrace(ExceptionInformation *xp, siginfo_t *info, int arg)
859{
860  extern LispObj current_stack_pointer();
861  extern void plbt_sp(LispObj);
862  extern void plbt(ExceptionInformation *);
863
864  if (xp) {
865    plbt(xp);
866  } else {
867    plbt_sp(current_stack_pointer());
868  }
869  return debug_continue;
870}
871
872debug_command_return
873debug_thread_reset(ExceptionInformation *xp, siginfo_t *info, int arg)
874{
875  reset_lisp_process(xp);
876  return debug_exit_success;
877}
878
879
880debug_command_entry debug_command_entries[] = 
881{
882  {debug_set_gpr,
883   "Set specified GPR to new value",
884   DEBUG_COMMAND_FLAG_AUX_REGNO,
885   "GPR to set (0-31) ?",
886   'G'},
887#ifdef PPC
888  {debug_advance_pc,
889   "Advance the program counter by one instruction (use with caution!)",
890   DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY,
891   NULL,
892   'A'},
893  {debug_identify_exception,
894   "Describe the current exception in greater detail",
895   DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY |
896   DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG,
897   NULL,
898   'D'},
899#endif
900  {debug_show_registers, 
901   "Show raw GPR/SPR register values", 
902   DEBUG_COMMAND_FLAG_REQUIRE_XP,
903   NULL,
904   'R'},
905  {debug_lisp_registers,
906   "Show Lisp values of tagged registers",
907   DEBUG_COMMAND_FLAG_REQUIRE_XP,
908   NULL,
909   'L'},
910  {debug_show_fpu,
911   "Show FPU registers",
912   DEBUG_COMMAND_FLAG_REQUIRE_XP,
913   NULL,
914   'F'},
915  {debug_show_symbol,
916   "Find and describe symbol matching specified name",
917   0,
918   NULL,
919   'S'},
920  {debug_backtrace,
921   "Show backtrace",
922   0,
923   NULL,
924   'B'},
925  {debug_thread_info,
926   "Show info about current thread",
927   0,
928   NULL,
929   'T'},
930  {debug_win,
931   "Exit from this debugger, asserting that any exception was handled",
932   0,
933   NULL,
934   'X'},
935#ifdef DARWIN
936  {debug_lose,
937   "Propagate the exception to another handler (debugger or OS)",
938   DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY,
939   NULL,
940   'P'},
941#endif
942#if 0
943  {debug_thread_reset,
944   "Reset current thread (as if in response to stack overflow)",
945   DEBUG_COMMAND_FLAG_REQUIRE_XP,
946   NULL,
947   'T'},
948#endif
949  {debug_kill_process,
950   "Kill Clozure CL process",
951   0,
952   NULL,
953   'K'},
954  {debug_help,
955   "Show this help",
956   0,
957   NULL,
958   '?'},
959  /* end-of-table */
960  {NULL,
961   NULL,
962   0,
963   NULL,
964   0}
965};
966
967debug_command_return
968apply_debug_command(ExceptionInformation *xp, int c, siginfo_t *info, int why) 
969{
970  if (c == EOF) {
971    return debug_kill;
972  } else {
973    debug_command_entry *entry;
974    debug_command f;
975    c = toupper(c);
976
977    for (entry = debug_command_entries; (f = entry->f) != NULL; entry++) {
978      if (toupper(entry->c) == c) {
979        /* If we have an XP or don't need one, call the function */
980        if ((xp || !(entry->flags & DEBUG_COMMAND_FLAG_REQUIRE_XP)) &&
981            ((why > debug_entry_exception) || 
982             !(entry->flags & DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY))) {
983          int arg = 0;
984          if ((entry->flags & DEBUG_COMMAND_REG_FLAGS)
985              == DEBUG_COMMAND_FLAG_AUX_REGNO) {
986            arg = debug_get_u5_value("register number");
987          }
988          if (entry->flags & DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG) {
989            arg = why;
990          }
991          return (f)(xp, info, arg);
992        }
993        break;
994      }
995    }
996    return debug_continue;
997  }
998}
999
1000debug_identify_function(ExceptionInformation *xp, siginfo_t *info) 
1001{
1002#ifdef PPC
1003  if (xp) {
1004    if (active_tcr_p((TCR *)(ptr_from_lispobj(xpGPR(xp, rcontext))))) {
1005      LispObj f = xpGPR(xp, fn), codev;
1006      pc where = xpPC(xp);
1007     
1008      if (!(codev = register_codevector_contains_pc(f, where))) {
1009        f = xpGPR(xp, nfn);
1010        codev =  register_codevector_contains_pc(f, where);
1011      }
1012      if (codev) {
1013        fprintf(stderr, " While executing: %s\n", print_lisp_object(f));
1014      }
1015    } else {
1016      int disp;
1017      char *foreign_name;
1018      natural where = (natural)xpPC(xp);
1019
1020      fprintf(stderr, " In foreign code at address 0x" ZLISP "\n", where);
1021      foreign_name = foreign_name_and_offset(where, &disp);
1022      if (foreign_name) {
1023        fprintf(stderr, "  [%s + %d]\n", foreign_name, disp);
1024      }
1025    }
1026  }
1027#endif
1028}
1029
1030#ifndef WINDOWS
1031extern pid_t main_thread_pid;
1032#endif
1033
1034
1035OSStatus
1036lisp_Debugger(ExceptionInformation *xp, 
1037              siginfo_t *info, 
1038              int why, 
1039              Boolean in_foreign_code,
1040              char *message, 
1041              ...)
1042{
1043  va_list args;
1044  debug_command_return state = debug_continue;
1045
1046  va_start(args,message);
1047  vfprintf(stderr, message, args);
1048  fprintf(stderr, "\n");
1049  va_end(args);
1050 
1051
1052#ifndef WINDOWS
1053  if (fd0_is_dev_null()) {
1054    return -1;
1055  }
1056#endif
1057  if (threads_initialized) {
1058    suspend_other_threads(false);
1059  }
1060
1061  lisp_debugger_in_foreign_code = in_foreign_code;
1062  if (in_foreign_code) {   
1063    char *foreign_name;
1064    int disp;
1065    fprintf(stderr, "Exception occurred while executing foreign code\n");
1066    foreign_name = foreign_name_and_offset((natural)xpPC(xp), &disp);
1067    if (foreign_name) {
1068      fprintf(stderr, " at %s + %d\n", foreign_name, disp);
1069    }
1070  }
1071
1072  if (lisp_global(BATCH_FLAG)) {
1073    abort();
1074  }
1075  if (xp) {
1076    if (why > debug_entry_exception) {
1077      debug_identify_exception(xp, info, why);
1078    }
1079    debug_identify_function(xp, info);
1080  }
1081  fprintf(stderr, "? for help\n");
1082  while (state == debug_continue) {
1083#ifdef WINDOWS
1084    fprintf(stderr, "[%d] Clozure CL kernel debugger: ", (int)GetCurrentProcessId());
1085#else
1086    fprintf(stderr, "[%d] Clozure CL kernel debugger: ", main_thread_pid);
1087#endif
1088    state = apply_debug_command(xp, readc(), info, why);
1089  }
1090  switch (state) {
1091  case debug_exit_success:
1092    if (threads_initialized) {
1093      resume_other_threads(false);
1094    }
1095    return 0;
1096  case debug_exit_fail:
1097    if (threads_initialized) {
1098      resume_other_threads(false);
1099    }
1100    return -1;
1101  case debug_kill:
1102    terminate_lisp();
1103  default:
1104    return 0;
1105  }
1106}
1107
1108void
1109Bug(ExceptionInformation *xp, const char *format, ...)
1110{
1111  va_list args;
1112  char s[512];
1113 
1114  va_start(args, format);
1115  vsnprintf(s, sizeof(s),format, args);
1116  va_end(args);
1117  lisp_Debugger(xp, NULL, debug_entry_bug, false, s);
1118
1119}
1120
1121void
1122FBug(ExceptionInformation *xp, const char *format, ...)
1123{
1124  va_list args;
1125  char s[512];
1126 
1127  va_start(args, format);
1128  vsnprintf(s, sizeof(s),format, args);
1129  va_end(args);
1130  lisp_Debugger(xp, NULL, debug_entry_bug, true, s);
1131
1132}
1133
1134void
1135lisp_bug(char *string)
1136{
1137  Bug(NULL, "Bug in Clozure CL system code:\n%s", string);
1138}
1139
Note: See TracBrowser for help on using the repository browser.