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

Last change on this file since 11993 was 11993, checked in by gb, 10 years ago

Propagate r11949 (print bug report info if kernel debugger entered
and --batch) to trunk.

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