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

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

Update copyright notices.

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