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

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

Kernel debugger command "M" to show lisp memory areas.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 32.1 KB
Line 
1/*
2   Copyright (C) 2009 Clozure Associates
3   Copyright (C) 1994-2001 Digitool, Inc
4   This file is part of Clozure CL. 
5
6   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7   License , known as the LLGPL and distributed with Clozure CL as the
8   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9   which is distributed with Clozure CL as the file "LGPL".  Where these
10   conflict, the preamble takes precedence. 
11
12   Clozure CL is referenced in the preamble as the "LIBRARY."
13
14   The LLGPL is also available online at
15   http://opensource.franz.com/preamble.html
16*/
17
18#include "lisp.h"
19#include "lisp-exceptions.h"
20#include "lisp_globals.h"
21#include "area.h"
22#include "Threads.h"
23#include <ctype.h>
24#include <stdio.h>
25#include <stddef.h>
26#include <string.h>
27#include <stdarg.h>
28#include <errno.h>
29#include <stdio.h>
30
31#ifdef WINDOWS
32#include <fcntl.h>
33#else
34#include <sys/socket.h>
35#include <dlfcn.h>
36#endif
37#include <sys/stat.h>
38
39FILE *dbgout = NULL;
40
41typedef enum {
42  debug_continue,               /* stay in the repl */
43  debug_exit_success,           /* return 0 from lisp_Debugger */
44  debug_exit_fail,              /* return non-zero from lisp_Debugger */
45  debug_kill
46} debug_command_return;
47
48
49Boolean
50open_debug_output(int fd)
51{
52  FILE *f = fdopen(fd, "w");
53 
54  if (f) {
55    if (setvbuf(f, NULL, _IONBF, 0) == 0) {
56#ifdef WINDOWS
57      if (fileno(stdin) < 0) {
58        stdin->_file = 0;
59      }
60#endif
61      dbgout = f;
62      return true;
63    }
64    fclose(f);
65  }
66  return false;
67}
68
69
70typedef debug_command_return (*debug_command) (ExceptionInformation *,
71                                               siginfo_t *,
72                                               int);
73
74#define DEBUG_COMMAND_FLAG_REQUIRE_XP 1 /* function  */
75#define DEBUG_COMMAND_FLAG_AUX_REGNO  (2 | DEBUG_COMMAND_FLAG_REQUIRE_XP)
76#define DEBUG_COMMAND_FLAG_AUX_SPR (4 | DEBUG_COMMAND_FLAG_REQUIRE_XP)
77#define DEBUG_COMMAND_REG_FLAGS 7
78#define DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY 8
79#define DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG 16
80
81typedef struct {
82  debug_command f;
83  char *help_text;
84  unsigned flags;
85  char *aux_prompt;
86  int c;
87} debug_command_entry;
88
89
90extern
91debug_command_entry debug_command_entries[];
92
93Boolean lisp_debugger_in_foreign_code = false;
94
95#ifndef WINDOWS
96Boolean
97stdin_is_dev_null()
98{
99  struct stat fd0stat, devnullstat;
100
101  if (fstat(fileno(stdin),&fd0stat)) {
102    return true;
103  }
104  if (stat("/dev/null",&devnullstat)) {
105    return true;
106  }
107  return ((fd0stat.st_ino == devnullstat.st_ino) &&
108          (fd0stat.st_dev == devnullstat.st_dev));
109}
110#endif
111
112#ifdef WINDOWS
113Boolean
114stdin_is_dev_null()
115{
116  HANDLE stdIn;
117  stdIn = GetStdHandle(STD_INPUT_HANDLE);
118  return (stdIn == NULL);
119}
120#endif
121
122
123
124
125char *
126foreign_name_and_offset(natural addr, int *delta)
127{
128#ifndef WINDOWS
129  Dl_info info;
130#endif
131  char *ret = NULL;
132
133  if (delta) {
134    *delta = 0;
135  }
136#ifndef WINDOWS
137  if (dladdr((void *)addr, &info)) {
138    ret = (char *)info.dli_sname;
139    if (delta) {
140      *delta = ((natural)addr - (natural)info.dli_saddr);
141    }
142  }
143#endif
144  return ret;
145}
146
147
148#if defined(LINUX) || defined(SOLARIS)
149#define fpurge __fpurge
150#endif
151
152#ifdef WINDOWS
153void
154fpurge (FILE* file)
155{
156}
157#endif
158
159int
160readc()
161{
162  unsigned tries = 1000;
163  int c;
164
165  while (tries) {
166    c = getchar();
167    switch(c) {
168    case '\n':
169      continue;
170    case '\r':
171      continue;
172    case EOF:
173      if (ferror(stdin)) {
174        if ((errno == EINTR) || (errno == EIO)) {
175          clearerr(stdin);
176          tries--;
177          continue;
178        }
179      }
180      /* fall through */
181    default:
182      return c;
183    }
184  }
185  return EOF;
186}
187
188#ifdef X8664
189#ifdef LINUX
190char* Iregnames[] = {"r8 ","r9 ","r10","r11","r12","r13","r14","r15",
191                     "rdi","rsi","rbp", "rbx", "rdx", "rax", "rcx","rsp"};
192#endif
193#ifdef SOLARIS
194char* Iregnames[] = {"r15 ","r14 ","r13","r12","r11","r10","r9 ","r8 ",
195                     "rdi","rsi","rbp", "rbx", "rdx", "rcx", "rcx","rsp"};
196#endif
197#ifdef FREEBSD
198char* Iregnames[] = {"???", "rdi", "rsi", "rdx", "rcx", "r8 ", "r9 ", "rax",
199                     "rbx", "rbp", "r10", "r11", "r12", "r13", "r14", "r15",
200                     "???", "???", "???", "???", "???", "???", "???", "rsp"};
201#endif
202#ifdef DARWIN
203char* Iregnames[] = {"rax", "rbx", "rcx", "rdx", "rdi", "rsi",
204                     "rbp", "rsp", "r8 ", "r9 ", "r10", "r11", "r12", "r13",
205                     "r14", "r15", "rip", "rfl"};
206#endif
207#ifdef WINDOWS
208char* Iregnames[] = {"rax ","rcx ","rdx","rbx","rsp","rrbp","rsi","rdi",
209                     "r8","r9","r10", "r11", "r12", "r13", "r14","r15"};
210#endif
211#endif
212
213#ifdef X8632
214#ifdef DARWIN
215char *Iregnames[] = {"eax", "ebx", "ecx", "edx", "edi", "esi",
216                     "ebp", "???", "efl", "eip"};
217#endif
218#ifdef LINUX
219char *Iregnames[] = {"???", "???", "???", "???",
220                     "edi", "esi", "ebp", "esp",
221                     "ebx", "edx", "ecx", "eax",
222                     "???", "???", "eip", "???", "efl"};
223#endif
224#ifdef WINDOWS
225char *Iregnames[] = {"edi", "esi", "ebx", "edx", "ecx", "eax",
226                     "ebp", "eip", "???", "efl", "esp"};
227#endif
228#ifdef FREEBSD
229char *Iregnames[] = {"???", "???", "???", "???", "???"
230                     "edi", "esi", "ebp", "ebx", "edx", 
231                     "ecx", "eax", "???", "???", "eip",
232                     "???", "efl", "esp"};
233#endif
234#ifdef SOLARIS
235char *Iregnames[] = {"???", "???", "???", "???", "???",
236                     "edi", "esi", "ebp", "???", "ebx",
237                     "edx", "ecx", "eax", "???", "???",
238                     "eip", "???", "efl", "esp"};
239#endif
240#endif
241
242#ifdef X8632
243int bit_for_regnum(int r)
244{
245  switch (r) {
246  case REG_EAX: return 1<<0;
247  case REG_ECX: return 1<<1;
248  case REG_EDX: return 1<<2;
249  case REG_EBX: return 1<<3;
250  case REG_ESP: return 1<<4;
251  case REG_EBP: return 1<<5;
252  case REG_ESI: return 1<<6;
253  case REG_EDI: return 1<<7;
254  }
255}
256#endif
257
258void
259show_lisp_register(ExceptionInformation *xp, char *label, int r)
260{
261
262  extern char* print_lisp_object(LispObj);
263
264  LispObj val = xpGPR(xp, r);
265
266#ifdef PPC
267  fprintf(dbgout, "r%02d (%s) = %s\n", r, label, print_lisp_object(val));
268#endif
269#ifdef X8664
270  fprintf(dbgout, "%%%s (%s) = %s\n",Iregnames[r], label, print_lisp_object(val));
271#endif
272#ifdef X8632
273  {
274    TCR *tcr = get_tcr(false);
275    char *s;
276
277    if (r == REG_EDX && (xpGPR(xp, REG_EFL) & EFL_DF))
278      s = "marked as unboxed (DF set)";
279    else if (tcr && (tcr->node_regs_mask & bit_for_regnum(r)) == 0)
280      s = "marked as unboxed (node_regs_mask)";
281    else
282      s = print_lisp_object(val);
283
284    fprintf(dbgout, "%%%s (%s) = %s\n", Iregnames[r], label, s);
285  }
286#endif
287
288}
289
290
291void
292describe_memfault(ExceptionInformation *xp, siginfo_t *info)
293{
294#ifdef PPC
295  void *addr = (void *)xpDAR(xp);
296  natural dsisr = xpDSISR(xp);
297
298  fprintf(dbgout, "%s operation to %s address 0x%lx\n",
299          dsisr & (1<<25) ? "Write" : "Read",
300          dsisr & (1<<27) ? "protected" : "unmapped",
301          addr);
302#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
507char *
508area_code_name(int code)
509{
510  switch (code) {
511    case AREA_VOID: return "void";
512    case AREA_CSTACK: return "cstack";
513    case AREA_VSTACK: return "vstack";
514    case AREA_TSTACK: return "tstack";
515    case AREA_READONLY: return "readonly";
516    case AREA_WATCHED: return "watched";
517    case AREA_STATIC_CONS: return "static cons";
518    case AREA_MANAGED_STATIC: return "managed static";
519    case AREA_STATIC: return "static";
520    case AREA_DYNAMIC: return "dynamic";
521    default: return "unknown";
522  }
523}
524
525debug_command_return
526debug_memory_areas(ExceptionInformation *xp, siginfo_t *info, int arg)
527{
528  int i;
529  area *a, *header = all_areas;
530  char label[100];
531
532  fprintf(dbgout, "Lisp memory areas:\n");
533  fprintf(dbgout, "%20s %20s %20s\n", "code", "low", "high");
534  for (a = header->succ; a != header; a = a->succ) {
535    snprintf(label, sizeof(label), "%s (%d)", area_code_name(a->code),
536             a->code >> fixnumshift);
537    fprintf(dbgout, "%20s %20p %20p\n", label, a->low, a->high);
538  }
539  return debug_continue;
540}
541
542debug_command_return
543debug_lisp_registers(ExceptionInformation *xp, siginfo_t *info, int arg)
544{
545  if (lisp_debugger_in_foreign_code == false) {
546#ifdef PPC
547    TCR *xpcontext = (TCR *)ptr_from_lispobj(xpGPR(xp, rcontext));
548
549    fprintf(dbgout, "rcontext = 0x%lX ", xpcontext);
550    if (!active_tcr_p(xpcontext)) {
551      fprintf(dbgout, "(INVALID)\n");
552    } else {
553      fprintf(dbgout, "\nnargs = %d\n", xpGPR(xp, nargs) >> fixnumshift);
554      show_lisp_register(xp, "fn", fn);
555      show_lisp_register(xp, "arg_z", arg_z);
556      show_lisp_register(xp, "arg_y", arg_y);
557      show_lisp_register(xp, "arg_x", arg_x);
558      show_lisp_register(xp, "temp0", temp0);
559      show_lisp_register(xp, "temp1/next_method_context", temp1);
560      show_lisp_register(xp, "temp2/nfn", temp2);
561      show_lisp_register(xp, "temp3/fname", temp3);
562      /*    show_lisp_register(xp, "new_fn", new_fn); */
563      show_lisp_register(xp, "save0", save0);
564      show_lisp_register(xp, "save1", save1);
565      show_lisp_register(xp, "save2", save2);
566      show_lisp_register(xp, "save3", save3);
567      show_lisp_register(xp, "save4", save4);
568      show_lisp_register(xp, "save5", save5);
569      show_lisp_register(xp, "save6", save6);
570      show_lisp_register(xp, "save7", save7);
571    }
572#endif
573#ifdef X8664
574
575    show_lisp_register(xp, "arg_z", Iarg_z);
576    show_lisp_register(xp, "arg_y", Iarg_y);
577    show_lisp_register(xp, "arg_x", Iarg_x);
578    fprintf(dbgout,"------\n");
579    show_lisp_register(xp, "fn", Ifn);
580    fprintf(dbgout,"------\n");
581    show_lisp_register(xp, "save0", Isave0);
582    show_lisp_register(xp, "save1", Isave1);
583    show_lisp_register(xp, "save2", Isave2);
584    show_lisp_register(xp, "save3", Isave3);
585    fprintf(dbgout,"------\n");
586    show_lisp_register(xp, "temp0", Itemp0);
587    show_lisp_register(xp, "temp1", Itemp1);
588    show_lisp_register(xp, "temp2", Itemp2);
589    fprintf(dbgout,"------\n");
590    if (tag_of(xpGPR(xp,Inargs)) == tag_fixnum) {
591      fprintf(dbgout,"%%rcx (nargs) = %ld (maybe)\n", unbox_fixnum(xpGPR(xp,Inargs)&0xffff));
592    }
593#endif
594
595#ifdef X8632
596  show_lisp_register(xp, "arg_z", Iarg_z);
597  show_lisp_register(xp, "arg_y", Iarg_y);
598  fprintf(dbgout,"------\n");
599  show_lisp_register(xp, "fn", Ifn);
600  fprintf(dbgout,"------\n");
601  show_lisp_register(xp, "temp0", Itemp0);
602  show_lisp_register(xp, "temp1", Itemp1);
603  fprintf(dbgout,"------\n");
604  if (tag_of(xpGPR(xp,Inargs)) == tag_fixnum) {
605    fprintf(dbgout,"%%edx (nargs) = %d (maybe)\n", unbox_fixnum(xpGPR(xp,Inargs)));
606  }
607#endif
608  }
609 
610  return debug_continue;
611}
612
613#ifdef PPC
614debug_command_return
615debug_advance_pc(ExceptionInformation *xp, siginfo_t *info, int arg)
616{
617  adjust_exception_pc(xp,4);
618  return debug_continue;
619}
620#endif
621
622debug_command_return
623debug_identify_exception(ExceptionInformation *xp, siginfo_t *info, int arg)
624{
625#ifdef PPC
626  pc program_counter = xpPC(xp);
627  opcode instruction = 0;
628
629  switch (arg) {
630  case SIGILL:
631  case SIGTRAP:
632    instruction = *program_counter;
633    if (major_opcode_p(instruction, major_opcode_TRI) ||
634        X_opcode_p(instruction,major_opcode_X31,minor_opcode_TR)) {
635      describe_ppc_trap(xp);
636    } else {
637      describe_ppc_illegal(xp);
638    }
639    break;
640  case SIGSEGV:
641  case SIGBUS:
642    describe_memfault(xp, info);
643    break;
644  default:
645    break;
646  }
647#endif
648  return debug_continue;
649}
650
651char *
652debug_get_string_value(char *prompt)
653{
654  static char buf[128];
655  char *p, *res;
656
657  do {
658    fpurge(stdin);
659    fprintf(dbgout, "\n %s :",prompt);
660    buf[0] = 0;
661    res = fgets(buf, sizeof(buf), stdin);
662  } while (0);
663  p = strchr(res, '\n');
664  if (p) {
665    *p = 0;
666    return buf;
667  }
668  return NULL;
669}
670
671natural
672debug_get_natural_value(char *prompt)
673{
674  char s[32], *res;
675  int n;
676  natural val;
677
678  do {
679    fpurge(stdin);
680    fprintf(dbgout, "\n  %s :", prompt);
681    s[0]=0;
682    res = fgets(s, 24, stdin);
683    n = sscanf(s, "%lu", &val);
684  } while (n != 1);
685  return val;
686}
687
688unsigned
689debug_get_u5_value(char *prompt)
690{
691  char s[32], *res;
692  int n;
693  unsigned val;
694
695  do {
696    fpurge(stdin);
697    fprintf(dbgout, "\n  %s :", prompt);
698    res = fgets(s, 24, stdin);
699    n = sscanf(res, "%i", &val);
700  } while ((n != 1) || (val > 31));
701  return val;
702}
703
704debug_command_return
705debug_show_symbol(ExceptionInformation *xp, siginfo_t *info, int arg)
706{
707  char *pname = debug_get_string_value("symbol name");
708  extern void *plsym(ExceptionInformation *,char*);
709 
710  if (pname != NULL) {
711    plsym(xp, pname);
712  }
713  return debug_continue;
714}
715
716debug_command_return
717debug_thread_info(ExceptionInformation *xp, siginfo_t *info, int arg)
718{
719  TCR * tcr = get_tcr(false);
720 
721  if (tcr) {
722    area *vs_area = tcr->vs_area, *cs_area = tcr->cs_area;
723
724    fprintf(dbgout, "Current Thread Context Record (tcr) = 0x" LISP "\n", tcr);
725    fprintf(dbgout, "Control (C) stack area:  low = 0x" LISP ", high = 0x" LISP "\n",
726            (cs_area->low), (cs_area->high));
727    fprintf(dbgout, "Value (lisp) stack area: low = 0x" LISP ", high = 0x" LISP "\n",
728            (u64_t)(natural)(vs_area->low), (u64_t)(natural)vs_area->high);
729    if (xp) {
730      fprintf(dbgout, "Exception stack pointer = 0x" LISP "\n",
731#ifdef PPC
732              (u64_t) (natural)(xpGPR(xp,1))
733#endif
734#ifdef X86
735              (u64_t) (natural)(xpGPR(xp,Isp))
736#endif           
737              );
738    }
739  }
740  return debug_continue;
741}
742     
743
744debug_command_return
745debug_set_gpr(ExceptionInformation *xp, siginfo_t *info, int arg)
746{
747  char buf[32];
748  natural val;
749
750  sprintf(buf, "value for GPR %d", arg);
751  val = debug_get_natural_value(buf);
752  xpGPR(xp,arg) = val;
753  return debug_continue;
754}
755
756debug_command_return
757debug_show_registers(ExceptionInformation *xp, siginfo_t *info, int arg)
758{
759
760
761#ifdef PPC
762#ifdef PPC64
763  int a, b;
764  for (a = 0, b = 16; a < 16; a++, b++) {
765    fprintf(dbgout,"r%02d = 0x%016lX    r%02d = 0x%016lX\n",
766            a, xpGPR(xp, a),
767            b, xpGPR(xp, b));
768  }
769 
770  fprintf(dbgout, "\n PC = 0x%016lX     LR = 0x%016lX\n",
771          xpPC(xp), xpLR(xp));
772  fprintf(dbgout, "CTR = 0x%016lX    CCR = 0x%08X\n",
773          xpCTR(xp), xpCCR(xp));
774  fprintf(dbgout, "XER = 0x%08X            MSR = 0x%016lX\n",
775          xpXER(xp), xpMSR(xp));
776  fprintf(dbgout,"DAR = 0x%016lX  DSISR = 0x%08X\n",
777          xpDAR(xp), xpDSISR(xp));
778#else
779  int a, b, c, d;;
780  for (a = 0, b = 8, c = 16, d = 24; a < 8; a++, b++, c++, d++) {
781    fprintf(dbgout,"r%02d = 0x%08X  r%02d = 0x%08X  r%02d = 0x%08X  r%02d = 0x%08X\n",
782            a, xpGPR(xp, a),
783            b, xpGPR(xp, b),
784            c, xpGPR(xp, c),
785            d, xpGPR(xp, d));
786  }
787  fprintf(dbgout, "\n PC = 0x%08X   LR = 0x%08X  CTR = 0x%08X  CCR = 0x%08X\n",
788          xpPC(xp), xpLR(xp), xpCTR(xp), xpCCR(xp));
789  fprintf(dbgout, "XER = 0x%08X  MSR = 0x%08X  DAR = 0x%08X  DSISR = 0x%08X\n",
790          xpXER(xp), xpMSR(xp), xpDAR(xp), xpDSISR(xp));
791#endif
792#endif
793
794#ifdef X8664
795  fprintf(dbgout,"%%rax = 0x" ZLISP "      %%r8  = 0x" ZLISP "\n", xpGPR(xp,REG_RAX),xpGPR(xp,REG_R8));
796  fprintf(dbgout,"%%rcx = 0x" ZLISP "      %%r9  = 0x" ZLISP "\n", xpGPR(xp,REG_RCX),xpGPR(xp,REG_R9));
797  fprintf(dbgout,"%%rdx = 0x" ZLISP "      %%r10 = 0x" ZLISP "\n", xpGPR(xp,REG_RDX),xpGPR(xp,REG_R10));
798  fprintf(dbgout,"%%rbx = 0x" ZLISP "      %%r11 = 0x" ZLISP "\n", xpGPR(xp,REG_RBX),xpGPR(xp,REG_R11));
799  fprintf(dbgout,"%%rsp = 0x" ZLISP "      %%r12 = 0x" ZLISP "\n", xpGPR(xp,REG_RSP),xpGPR(xp,REG_R12));
800  fprintf(dbgout,"%%rbp = 0x" ZLISP "      %%r13 = 0x" ZLISP "\n", xpGPR(xp,REG_RBP),xpGPR(xp,REG_R13));
801  fprintf(dbgout,"%%rsi = 0x" ZLISP "      %%r14 = 0x" ZLISP "\n", xpGPR(xp,REG_RSI),xpGPR(xp,REG_R14));
802  fprintf(dbgout,"%%rdi = 0x" ZLISP "      %%r15 = 0x" ZLISP "\n", xpGPR(xp,REG_RDI),xpGPR(xp,REG_R15));
803  fprintf(dbgout,"%%rip = 0x" ZLISP "   %%rflags = 0x%08lx\n",
804          xpGPR(xp, Iip), eflags_register(xp));
805#endif
806
807#ifdef X8632
808  unsigned short rcs,rds,res,rfs,rgs,rss;
809#ifdef DARWIN
810  rcs = xp->uc_mcontext->__ss.__cs;
811  rds = xp->uc_mcontext->__ss.__ds;
812  res = xp->uc_mcontext->__ss.__es;
813  rfs = xp->uc_mcontext->__ss.__fs;
814  rgs = xp->uc_mcontext->__ss.__gs;
815  rss = xp->uc_mcontext->__ss.__ss;
816#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
817#endif
818#ifdef LINUX
819  rcs = xp->uc_mcontext.gregs[REG_CS];
820  rds = xp->uc_mcontext.gregs[REG_DS];
821  res = xp->uc_mcontext.gregs[REG_ES];
822  rfs = xp->uc_mcontext.gregs[REG_FS];
823  rgs = xp->uc_mcontext.gregs[REG_GS];
824  rss = xp->uc_mcontext.gregs[REG_SS];
825#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
826#endif
827#ifdef FREEBSD
828  rcs = xp->uc_mcontext.mc_cs;
829  rds = xp->uc_mcontext.mc_ds;
830  res = xp->uc_mcontext.mc_es;
831  rfs = xp->uc_mcontext.mc_fs;
832  rgs = xp->uc_mcontext.mc_gs;
833  rss = xp->uc_mcontext.mc_ss;
834#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
835#endif
836#ifdef SOLARIS
837  rcs = xp->uc_mcontext.gregs[CS];
838  rds = xp->uc_mcontext.gregs[DS];
839  res = xp->uc_mcontext.gregs[ES];
840  rfs = xp->uc_mcontext.gregs[FS];
841  rgs = xp->uc_mcontext.gregs[GS];
842  rss = xp->uc_mcontext.gregs[SS];
843#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
844#endif
845#ifdef WINDOWS
846  rcs = xp->SegCs;
847  rds = xp->SegDs;
848  res = xp->SegEs;
849  rfs = xp->SegFs;
850  rgs = xp->SegGs;
851  rss = xp->SegSs;
852#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
853#endif
854
855
856
857  fprintf(dbgout, "%%eax = 0x" ZLISP "\n", xpGPR(xp, REG_EAX));
858  fprintf(dbgout, "%%ecx = 0x" ZLISP "\n", xpGPR(xp, REG_ECX));
859  fprintf(dbgout, "%%edx = 0x" ZLISP "\n", xpGPR(xp, REG_EDX));
860  fprintf(dbgout, "%%ebx = 0x" ZLISP "\n", xpGPR(xp, REG_EBX));
861  fprintf(dbgout, "%%esp = 0x" ZLISP "\n", xpGPR(xp, REG_ESP));
862  fprintf(dbgout, "%%ebp = 0x" ZLISP "\n", xpGPR(xp, REG_EBP));
863  fprintf(dbgout, "%%esi = 0x" ZLISP "\n", xpGPR(xp, REG_ESI));
864  fprintf(dbgout, "%%edi = 0x" ZLISP "\n", xpGPR(xp, REG_EDI));
865  fprintf(dbgout, "%%eip = 0x" ZLISP "\n", xpGPR(xp, REG_EIP));
866  fprintf(dbgout, "%%eflags = 0x" ZLISP "\n", xpGPR(xp, REG_EFL));
867#ifdef DEBUG_SHOW_X86_SEGMENT_REGISTERS
868  fprintf(dbgout,"\n");
869  fprintf(dbgout, "%%cs = 0x%04x\n", rcs);
870  fprintf(dbgout, "%%ds = 0x%04x\n", rds);
871  fprintf(dbgout, "%%ss = 0x%04x\n", rss);
872  fprintf(dbgout, "%%es = 0x%04x\n", res);
873  fprintf(dbgout, "%%fs = 0x%04x\n", rfs);
874  fprintf(dbgout, "%%gs = 0x%04x\n", rgs);
875
876#endif
877
878#endif
879
880  return debug_continue;
881}
882
883debug_command_return
884debug_show_fpu(ExceptionInformation *xp, siginfo_t *info, int arg)
885{
886  double *dp;
887  int *np, i;
888#ifdef PPC
889  dp = xpFPRvector(xp);
890  np = (int *) dp;
891 
892  for (i = 0; i < 32; i++, np+=2) {
893    fprintf(dbgout, "f%02d : 0x%08X%08X (%f)\n", i,  np[0], np[1], *dp++);
894  }
895  fprintf(dbgout, "FPSCR = %08X\n", xpFPSCR(xp));
896#endif
897#ifdef X8664
898#ifdef LINUX
899  struct _libc_xmmreg * xmmp = &(xp->uc_mcontext.fpregs->_xmm[0]);
900#endif
901#ifdef DARWIN
902  struct xmm {
903    char fpdata[16];
904  };
905  struct xmm *xmmp = (struct xmm *)(xpFPRvector(xp));
906#endif
907#ifdef WINDOWS
908  struct xmm {
909    char fpdata[16];
910  };
911  struct xmm *xmmp; /* XXX: actually get them */
912#endif
913#ifdef FREEBSD
914  struct xmmacc *xmmp = xpXMMregs(xp);
915#endif
916#ifdef SOLARIS
917  upad128_t *xmmp = xpXMMregs(xp);
918#endif
919  float *sp;
920
921
922  for (i = 0; i < 16; i++, xmmp++) {
923    sp = (float *) xmmp;
924    dp = (double *) xmmp;
925    np = (int *) xmmp;
926    fprintf(dbgout, "f%02d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np, (double)(*sp), np[1], np[0], *dp);
927  }
928  fprintf(dbgout, "mxcsr = 0x%08x\n",
929#ifdef LINUX
930          xp->uc_mcontext.fpregs->mxcsr
931#endif
932#ifdef DARWIN
933          UC_MCONTEXT(xp)->__fs.__fpu_mxcsr
934#endif
935#ifdef FREEBSD
936          (((struct savefpu *)(&(xp)->uc_mcontext.mc_fpstate))->sv_env.en_mxcsr)
937#endif
938#ifdef SOLARIS
939          xp->uc_mcontext.fpregs.fp_reg_set.fpchip_state.xstatus
940#endif
941#ifdef WINDOWS
942          *(xpMXCSRptr(xp))
943#endif
944          );
945#endif 
946#ifdef X8632
947#ifdef DARWIN
948  struct xmm {
949    char fpdata[8];
950  };
951  struct xmm *xmmp = (struct xmm *)(xpFPRvector(xp));
952
953  for (i = 0; i < 8; i++, xmmp++) {
954    float *sp = (float *)xmmp;
955    dp = (double *)xmmp;
956    np = (int *)xmmp;
957    fprintf(dbgout, "f%1d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np,
958            (double)(*sp), np[1], np[0], *dp);
959  }
960  fprintf(dbgout, "mxcsr = 0x%08x\n", UC_MCONTEXT(xp)->__fs.__fpu_mxcsr);
961#endif
962#endif
963
964  return debug_continue;
965}
966
967debug_command_return
968debug_kill_process(ExceptionInformation *xp, siginfo_t *info, int arg) {
969  return debug_kill;
970}
971
972debug_command_return
973debug_win(ExceptionInformation *xp, siginfo_t *info, int arg) {
974  return debug_exit_success;
975}
976
977debug_command_return
978debug_lose(ExceptionInformation *xp, siginfo_t *info, int arg) {
979  return debug_exit_fail;
980}
981
982debug_command_return
983debug_help(ExceptionInformation *xp, siginfo_t *info, int arg) {
984  debug_command_entry *entry;
985
986  for (entry = debug_command_entries; entry->f; entry++) {
987    /* If we have an XP or don't need one, call the function */
988    if (xp || !(entry->flags & DEBUG_COMMAND_FLAG_REQUIRE_XP)) {
989      fprintf(dbgout, "(%c)  %s\n", entry->c, entry->help_text);
990    }
991  }
992  return debug_continue;
993}
994             
995
996 
997
998debug_command_return
999debug_backtrace(ExceptionInformation *xp, siginfo_t *info, int arg)
1000{
1001  extern LispObj current_stack_pointer();
1002  extern void plbt_sp(LispObj);
1003  extern void plbt(ExceptionInformation *);
1004
1005  if (xp) {
1006    plbt(xp);
1007#ifndef X86
1008  } else {
1009    plbt_sp(current_stack_pointer());
1010#endif
1011  }
1012  return debug_continue;
1013}
1014
1015debug_command_return
1016debug_thread_reset(ExceptionInformation *xp, siginfo_t *info, int arg)
1017{
1018  reset_lisp_process(xp);
1019  return debug_exit_success;
1020}
1021
1022
1023debug_command_entry debug_command_entries[] = 
1024{
1025  {debug_set_gpr,
1026   "Set specified GPR to new value",
1027   DEBUG_COMMAND_FLAG_AUX_REGNO,
1028   "GPR to set (0-31) ?",
1029   'G'},
1030#ifdef PPC
1031  {debug_advance_pc,
1032   "Advance the program counter by one instruction (use with caution!)",
1033   DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY,
1034   NULL,
1035   'A'},
1036  {debug_identify_exception,
1037   "Describe the current exception in greater detail",
1038   DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY |
1039   DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG,
1040   NULL,
1041   'D'},
1042#endif
1043  {debug_show_registers, 
1044   "Show raw GPR/SPR register values", 
1045   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1046   NULL,
1047   'R'},
1048  {debug_lisp_registers,
1049   "Show Lisp values of tagged registers",
1050   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1051   NULL,
1052   'L'},
1053  {debug_show_fpu,
1054   "Show FPU registers",
1055   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1056   NULL,
1057   'F'},
1058  {debug_show_symbol,
1059   "Find and describe symbol matching specified name",
1060   0,
1061   NULL,
1062   'S'},
1063  {debug_backtrace,
1064   "Show backtrace",
1065   0,
1066   NULL,
1067   'B'},
1068  {debug_thread_info,
1069   "Show info about current thread",
1070   0,
1071   NULL,
1072   'T'},
1073  {debug_memory_areas,
1074   "Show memory areas",
1075   0,
1076   NULL,
1077   'M'},
1078  {debug_win,
1079   "Exit from this debugger, asserting that any exception was handled",
1080   0,
1081   NULL,
1082   'X'},
1083#ifdef DARWIN
1084  {debug_lose,
1085   "Propagate the exception to another handler (debugger or OS)",
1086   DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY,
1087   NULL,
1088   'P'},
1089#endif
1090#if 0
1091  {debug_thread_reset,
1092   "Reset current thread (as if in response to stack overflow)",
1093   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1094   NULL,
1095   'T'},
1096#endif
1097  {debug_kill_process,
1098   "Kill Clozure CL process",
1099   0,
1100   NULL,
1101   'K'},
1102  {debug_help,
1103   "Show this help",
1104   0,
1105   NULL,
1106   '?'},
1107  /* end-of-table */
1108  {NULL,
1109   NULL,
1110   0,
1111   NULL,
1112   0}
1113};
1114
1115debug_command_return
1116apply_debug_command(ExceptionInformation *xp, int c, siginfo_t *info, int why) 
1117{
1118  if (c == EOF) {
1119    return debug_kill;
1120  } else {
1121    debug_command_entry *entry;
1122    debug_command f;
1123    c = toupper(c);
1124
1125    for (entry = debug_command_entries; (f = entry->f) != NULL; entry++) {
1126      if (toupper(entry->c) == c) {
1127        /* If we have an XP or don't need one, call the function */
1128        if ((xp || !(entry->flags & DEBUG_COMMAND_FLAG_REQUIRE_XP)) &&
1129            ((why > debug_entry_exception) || 
1130             !(entry->flags & DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY))) {
1131          int arg = 0;
1132          if ((entry->flags & DEBUG_COMMAND_REG_FLAGS)
1133              == DEBUG_COMMAND_FLAG_AUX_REGNO) {
1134            arg = debug_get_u5_value("register number");
1135          }
1136          if (entry->flags & DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG) {
1137            arg = why;
1138          }
1139          return (f)(xp, info, arg);
1140        }
1141        break;
1142      }
1143    }
1144    return debug_continue;
1145  }
1146}
1147
1148debug_identify_function(ExceptionInformation *xp, siginfo_t *info) 
1149{
1150#ifdef PPC
1151  if (xp) {
1152    if (active_tcr_p((TCR *)(ptr_from_lispobj(xpGPR(xp, rcontext))))) {
1153      LispObj f = xpGPR(xp, fn), codev;
1154      pc where = xpPC(xp);
1155     
1156      if (!(codev = register_codevector_contains_pc(f, where))) {
1157        f = xpGPR(xp, nfn);
1158        codev =  register_codevector_contains_pc(f, where);
1159      }
1160      if (codev) {
1161        fprintf(dbgout, " While executing: %s\n", print_lisp_object(f));
1162      }
1163    } else {
1164      int disp;
1165      char *foreign_name;
1166      natural where = (natural)xpPC(xp);
1167
1168      fprintf(dbgout, " In foreign code at address 0x" ZLISP "\n", where);
1169      foreign_name = foreign_name_and_offset(where, &disp);
1170      if (foreign_name) {
1171        fprintf(dbgout, "  [%s + %d]\n", foreign_name, disp);
1172      }
1173    }
1174  }
1175#endif
1176}
1177
1178#ifndef WINDOWS
1179extern pid_t main_thread_pid;
1180#endif
1181
1182
1183OSStatus
1184lisp_Debugger(ExceptionInformation *xp, 
1185              siginfo_t *info, 
1186              int why, 
1187              Boolean in_foreign_code,
1188              char *message, 
1189              ...)
1190{
1191  va_list args;
1192  debug_command_return state = debug_continue;
1193
1194
1195  if (stdin_is_dev_null()) {
1196    return -1;
1197  }
1198
1199  va_start(args,message);
1200  vfprintf(dbgout, message, args);
1201  fprintf(dbgout, "\n");
1202  va_end(args);
1203
1204  if (threads_initialized) {
1205    suspend_other_threads(false);
1206  }
1207
1208  lisp_debugger_in_foreign_code = in_foreign_code;
1209  if (in_foreign_code) {   
1210    char *foreign_name;
1211    int disp;
1212    fprintf(dbgout, "Exception occurred while executing foreign code\n");
1213    foreign_name = foreign_name_and_offset((natural)xpPC(xp), &disp);
1214    if (foreign_name) {
1215      fprintf(dbgout, " at %s + %d\n", foreign_name, disp);
1216    }
1217  }
1218
1219  if (xp) {
1220    if (why > debug_entry_exception) {
1221      debug_identify_exception(xp, info, why);
1222    }
1223    debug_identify_function(xp, info);
1224  }
1225  if (lisp_global(BATCH_FLAG)) {
1226#ifdef WINDOWS
1227    fprintf(dbgout, "Current Process Id %d\n", (int)GetCurrentProcessId());
1228#else
1229    fprintf(dbgout, "Main thread pid %d\n", main_thread_pid);
1230#endif
1231    debug_thread_info(xp, info, 0);
1232    if (xp) {
1233      debug_show_registers(xp, info, 0);
1234      debug_lisp_registers(xp, info, 0);
1235      debug_show_fpu(xp, info, 0);
1236    }
1237    debug_backtrace(xp, info, 0);
1238
1239    abort();
1240  }
1241
1242  fprintf(dbgout, "? for help\n");
1243  while (state == debug_continue) {
1244#ifdef WINDOWS
1245    fprintf(dbgout, "[%d] Clozure CL kernel debugger: ", (int)GetCurrentProcessId());
1246#else
1247    fprintf(dbgout, "[%d] Clozure CL kernel debugger: ", main_thread_pid);
1248#endif
1249    fflush(dbgout);             /* dbgout should be unbuffered, so this shouldn't be necessary.  But it can't hurt ... */
1250    state = apply_debug_command(xp, readc(), info, why);
1251  }
1252  switch (state) {
1253  case debug_exit_success:
1254    if (threads_initialized) {
1255      resume_other_threads(false);
1256    }
1257    return 0;
1258  case debug_exit_fail:
1259    if (threads_initialized) {
1260      resume_other_threads(false);
1261    }
1262    return -1;
1263  case debug_kill:
1264    terminate_lisp();
1265  default:
1266    return 0;
1267  }
1268}
1269
1270void
1271Bug(ExceptionInformation *xp, const char *format, ...)
1272{
1273  va_list args;
1274  char s[512];
1275 
1276  va_start(args, format);
1277  vsnprintf(s, sizeof(s),format, args);
1278  va_end(args);
1279  lisp_Debugger(xp, NULL, debug_entry_bug, false, s);
1280
1281}
1282
1283void
1284FBug(ExceptionInformation *xp, const char *format, ...)
1285{
1286  va_list args;
1287  char s[512];
1288 
1289  va_start(args, format);
1290  vsnprintf(s, sizeof(s),format, args);
1291  va_end(args);
1292  lisp_Debugger(xp, NULL, debug_entry_bug, true, s);
1293}
1294
1295void
1296lisp_bug(char *string)
1297{
1298  Bug(NULL, "Bug in Clozure CL system code:\n%s", string);
1299}
1300
Note: See TracBrowser for help on using the repository browser.