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

Last change on this file since 13766 was 13766, checked in by rme, 10 years ago

Make debug_identify_exception() do a little something on non-PPC
systems; enable "D" kernel debugger command.

In describe_memfault(), decode the siginfo_t arg in an attempt to provide
something quasi-informative for non-PPC systems.

When in batch mode, show the lisp memory areas before aborting.

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