source: branches/qres/ccl/lisp-kernel/lisp-debug.c @ 14261

Last change on this file since 14261 was 14261, checked in by rme, 9 years ago

Merge r14260 from trunk (guard against null uc_mcontext.fpregs on Linux).

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