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

Last change on this file since 13095 was 13095, checked in by rme, 11 years ago

In readc(): Clear stream error status when retrying after EINTR or EIO. Also,
put a limit on how many times we'll retry after EINTR or EIO.

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