source: branches/arm/lisp-kernel/lisp-debug.c @ 13729

Last change on this file since 13729 was 13729, checked in by gb, 9 years ago

Needs a little bit of conditionalization and perhaps some thought.
Conditionalize first, think later.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 31.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
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    if (xp) {
695      fprintf(dbgout, "Exception stack pointer = 0x" LISP "\n",
696#ifdef PPC
697              (u64_t) (natural)(xpGPR(xp,1))
698#endif
699#ifdef X86
700              (u64_t) (natural)(xpGPR(xp,Isp))
701#endif           
702#ifdef ARM
703              (u64_t) (natural)(xpGPR(xp,Rsp))
704#endif
705              );
706    }
707  }
708  return debug_continue;
709}
710     
711
712debug_command_return
713debug_set_gpr(ExceptionInformation *xp, siginfo_t *info, int arg)
714{
715  char buf[32];
716  natural val;
717
718  sprintf(buf, "value for GPR %d", arg);
719  val = debug_get_natural_value(buf);
720  xpGPR(xp,arg) = val;
721  return debug_continue;
722}
723
724debug_command_return
725debug_show_registers(ExceptionInformation *xp, siginfo_t *info, int arg)
726{
727
728
729#ifdef PPC
730#ifdef PPC64
731  int a, b;
732  for (a = 0, b = 16; a < 16; a++, b++) {
733    fprintf(dbgout,"r%02d = 0x%016lX    r%02d = 0x%016lX\n",
734            a, xpGPR(xp, a),
735            b, xpGPR(xp, b));
736  }
737 
738  fprintf(dbgout, "\n PC = 0x%016lX     LR = 0x%016lX\n",
739          xpPC(xp), xpLR(xp));
740  fprintf(dbgout, "CTR = 0x%016lX    CCR = 0x%08X\n",
741          xpCTR(xp), xpCCR(xp));
742  fprintf(dbgout, "XER = 0x%08X            MSR = 0x%016lX\n",
743          xpXER(xp), xpMSR(xp));
744  fprintf(dbgout,"DAR = 0x%016lX  DSISR = 0x%08X\n",
745          xpDAR(xp), xpDSISR(xp));
746#else
747  int a, b, c, d;;
748  for (a = 0, b = 8, c = 16, d = 24; a < 8; a++, b++, c++, d++) {
749    fprintf(dbgout,"r%02d = 0x%08X  r%02d = 0x%08X  r%02d = 0x%08X  r%02d = 0x%08X\n",
750            a, xpGPR(xp, a),
751            b, xpGPR(xp, b),
752            c, xpGPR(xp, c),
753            d, xpGPR(xp, d));
754  }
755  fprintf(dbgout, "\n PC = 0x%08X   LR = 0x%08X  CTR = 0x%08X  CCR = 0x%08X\n",
756          xpPC(xp), xpLR(xp), xpCTR(xp), xpCCR(xp));
757  fprintf(dbgout, "XER = 0x%08X  MSR = 0x%08X  DAR = 0x%08X  DSISR = 0x%08X\n",
758          xpXER(xp), xpMSR(xp), xpDAR(xp), xpDSISR(xp));
759#endif
760#endif
761
762#ifdef X8664
763  fprintf(dbgout,"%%rax = 0x" ZLISP "      %%r8  = 0x" ZLISP "\n", xpGPR(xp,REG_RAX),xpGPR(xp,REG_R8));
764  fprintf(dbgout,"%%rcx = 0x" ZLISP "      %%r9  = 0x" ZLISP "\n", xpGPR(xp,REG_RCX),xpGPR(xp,REG_R9));
765  fprintf(dbgout,"%%rdx = 0x" ZLISP "      %%r10 = 0x" ZLISP "\n", xpGPR(xp,REG_RDX),xpGPR(xp,REG_R10));
766  fprintf(dbgout,"%%rbx = 0x" ZLISP "      %%r11 = 0x" ZLISP "\n", xpGPR(xp,REG_RBX),xpGPR(xp,REG_R11));
767  fprintf(dbgout,"%%rsp = 0x" ZLISP "      %%r12 = 0x" ZLISP "\n", xpGPR(xp,REG_RSP),xpGPR(xp,REG_R12));
768  fprintf(dbgout,"%%rbp = 0x" ZLISP "      %%r13 = 0x" ZLISP "\n", xpGPR(xp,REG_RBP),xpGPR(xp,REG_R13));
769  fprintf(dbgout,"%%rsi = 0x" ZLISP "      %%r14 = 0x" ZLISP "\n", xpGPR(xp,REG_RSI),xpGPR(xp,REG_R14));
770  fprintf(dbgout,"%%rdi = 0x" ZLISP "      %%r15 = 0x" ZLISP "\n", xpGPR(xp,REG_RDI),xpGPR(xp,REG_R15));
771  fprintf(dbgout,"%%rip = 0x" ZLISP "   %%rflags = 0x%08lx\n",
772          xpGPR(xp, Iip), eflags_register(xp));
773#endif
774
775#ifdef X8632
776  unsigned short rcs,rds,res,rfs,rgs,rss;
777#ifdef DARWIN
778  rcs = xp->uc_mcontext->__ss.__cs;
779  rds = xp->uc_mcontext->__ss.__ds;
780  res = xp->uc_mcontext->__ss.__es;
781  rfs = xp->uc_mcontext->__ss.__fs;
782  rgs = xp->uc_mcontext->__ss.__gs;
783  rss = xp->uc_mcontext->__ss.__ss;
784#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
785#endif
786#ifdef LINUX
787  rcs = xp->uc_mcontext.gregs[REG_CS];
788  rds = xp->uc_mcontext.gregs[REG_DS];
789  res = xp->uc_mcontext.gregs[REG_ES];
790  rfs = xp->uc_mcontext.gregs[REG_FS];
791  rgs = xp->uc_mcontext.gregs[REG_GS];
792  rss = xp->uc_mcontext.gregs[REG_SS];
793#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
794#endif
795#ifdef FREEBSD
796  rcs = xp->uc_mcontext.mc_cs;
797  rds = xp->uc_mcontext.mc_ds;
798  res = xp->uc_mcontext.mc_es;
799  rfs = xp->uc_mcontext.mc_fs;
800  rgs = xp->uc_mcontext.mc_gs;
801  rss = xp->uc_mcontext.mc_ss;
802#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
803#endif
804#ifdef SOLARIS
805  rcs = xp->uc_mcontext.gregs[CS];
806  rds = xp->uc_mcontext.gregs[DS];
807  res = xp->uc_mcontext.gregs[ES];
808  rfs = xp->uc_mcontext.gregs[FS];
809  rgs = xp->uc_mcontext.gregs[GS];
810  rss = xp->uc_mcontext.gregs[SS];
811#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
812#endif
813#ifdef WINDOWS
814  rcs = xp->SegCs;
815  rds = xp->SegDs;
816  res = xp->SegEs;
817  rfs = xp->SegFs;
818  rgs = xp->SegGs;
819  rss = xp->SegSs;
820#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
821#endif
822
823
824
825  fprintf(dbgout, "%%eax = 0x" ZLISP "\n", xpGPR(xp, REG_EAX));
826  fprintf(dbgout, "%%ecx = 0x" ZLISP "\n", xpGPR(xp, REG_ECX));
827  fprintf(dbgout, "%%edx = 0x" ZLISP "\n", xpGPR(xp, REG_EDX));
828  fprintf(dbgout, "%%ebx = 0x" ZLISP "\n", xpGPR(xp, REG_EBX));
829  fprintf(dbgout, "%%esp = 0x" ZLISP "\n", xpGPR(xp, REG_ESP));
830  fprintf(dbgout, "%%ebp = 0x" ZLISP "\n", xpGPR(xp, REG_EBP));
831  fprintf(dbgout, "%%esi = 0x" ZLISP "\n", xpGPR(xp, REG_ESI));
832  fprintf(dbgout, "%%edi = 0x" ZLISP "\n", xpGPR(xp, REG_EDI));
833  fprintf(dbgout, "%%eip = 0x" ZLISP "\n", xpGPR(xp, REG_EIP));
834  fprintf(dbgout, "%%eflags = 0x" ZLISP "\n", xpGPR(xp, REG_EFL));
835#ifdef DEBUG_SHOW_X86_SEGMENT_REGISTERS
836  fprintf(dbgout,"\n");
837  fprintf(dbgout, "%%cs = 0x%04x\n", rcs);
838  fprintf(dbgout, "%%ds = 0x%04x\n", rds);
839  fprintf(dbgout, "%%ss = 0x%04x\n", rss);
840  fprintf(dbgout, "%%es = 0x%04x\n", res);
841  fprintf(dbgout, "%%fs = 0x%04x\n", rfs);
842  fprintf(dbgout, "%%gs = 0x%04x\n", rgs);
843
844#endif
845
846#endif
847
848  return debug_continue;
849}
850
851debug_command_return
852debug_show_fpu(ExceptionInformation *xp, siginfo_t *info, int arg)
853{
854  double *dp;
855  int *np, i;
856#ifdef PPC
857  dp = xpFPRvector(xp);
858  np = (int *) dp;
859 
860  for (i = 0; i < 32; i++, np+=2) {
861    fprintf(dbgout, "f%02d : 0x%08X%08X (%f)\n", i,  np[0], np[1], *dp++);
862  }
863  fprintf(dbgout, "FPSCR = %08X\n", xpFPSCR(xp));
864#endif
865#ifdef X8664
866#ifdef LINUX
867  struct _libc_xmmreg * xmmp = &(xp->uc_mcontext.fpregs->_xmm[0]);
868#endif
869#ifdef DARWIN
870  struct xmm {
871    char fpdata[16];
872  };
873  struct xmm *xmmp = (struct xmm *)(xpFPRvector(xp));
874#endif
875#ifdef WINDOWS
876  struct xmm {
877    char fpdata[16];
878  };
879  struct xmm *xmmp; /* XXX: actually get them */
880#endif
881#ifdef FREEBSD
882  struct xmmacc *xmmp = xpXMMregs(xp);
883#endif
884#ifdef SOLARIS
885  upad128_t *xmmp = xpXMMregs(xp);
886#endif
887  float *sp;
888
889
890  for (i = 0; i < 16; i++, xmmp++) {
891    sp = (float *) xmmp;
892    dp = (double *) xmmp;
893    np = (int *) xmmp;
894    fprintf(dbgout, "f%02d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np, (double)(*sp), np[1], np[0], *dp);
895  }
896  fprintf(dbgout, "mxcsr = 0x%08x\n",
897#ifdef LINUX
898          xp->uc_mcontext.fpregs->mxcsr
899#endif
900#ifdef DARWIN
901          UC_MCONTEXT(xp)->__fs.__fpu_mxcsr
902#endif
903#ifdef FREEBSD
904          (((struct savefpu *)(&(xp)->uc_mcontext.mc_fpstate))->sv_env.en_mxcsr)
905#endif
906#ifdef SOLARIS
907          xp->uc_mcontext.fpregs.fp_reg_set.fpchip_state.xstatus
908#endif
909#ifdef WINDOWS
910          *(xpMXCSRptr(xp))
911#endif
912          );
913#endif 
914#ifdef X8632
915#ifdef DARWIN
916  struct xmm {
917    char fpdata[8];
918  };
919  struct xmm *xmmp = (struct xmm *)(xpFPRvector(xp));
920
921  for (i = 0; i < 8; i++, xmmp++) {
922    float *sp = (float *)xmmp;
923    dp = (double *)xmmp;
924    np = (int *)xmmp;
925    fprintf(dbgout, "f%1d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np,
926            (double)(*sp), np[1], np[0], *dp);
927  }
928  fprintf(dbgout, "mxcsr = 0x%08x\n", UC_MCONTEXT(xp)->__fs.__fpu_mxcsr);
929#endif
930#endif
931
932  return debug_continue;
933}
934
935debug_command_return
936debug_kill_process(ExceptionInformation *xp, siginfo_t *info, int arg) {
937  return debug_kill;
938}
939
940debug_command_return
941debug_win(ExceptionInformation *xp, siginfo_t *info, int arg) {
942  return debug_exit_success;
943}
944
945debug_command_return
946debug_lose(ExceptionInformation *xp, siginfo_t *info, int arg) {
947  return debug_exit_fail;
948}
949
950debug_command_return
951debug_help(ExceptionInformation *xp, siginfo_t *info, int arg) {
952  debug_command_entry *entry;
953
954  for (entry = debug_command_entries; entry->f; entry++) {
955    /* If we have an XP or don't need one, call the function */
956    if (xp || !(entry->flags & DEBUG_COMMAND_FLAG_REQUIRE_XP)) {
957      fprintf(dbgout, "(%c)  %s\n", entry->c, entry->help_text);
958    }
959  }
960  return debug_continue;
961}
962             
963
964 
965
966debug_command_return
967debug_backtrace(ExceptionInformation *xp, siginfo_t *info, int arg)
968{
969  extern LispObj current_stack_pointer();
970  extern void plbt_sp(LispObj);
971  extern void plbt(ExceptionInformation *);
972
973  if (xp) {
974    plbt(xp);
975#ifndef X86
976  } else {
977    plbt_sp(current_stack_pointer());
978#endif
979  }
980  return debug_continue;
981}
982
983debug_command_return
984debug_thread_reset(ExceptionInformation *xp, siginfo_t *info, int arg)
985{
986  reset_lisp_process(xp);
987  return debug_exit_success;
988}
989
990
991debug_command_entry debug_command_entries[] = 
992{
993  {debug_set_gpr,
994   "Set specified GPR to new value",
995   DEBUG_COMMAND_FLAG_AUX_REGNO,
996   "GPR to set (0-31) ?",
997   'G'},
998#ifdef PPC
999  {debug_advance_pc,
1000   "Advance the program counter by one instruction (use with caution!)",
1001   DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY,
1002   NULL,
1003   'A'},
1004  {debug_identify_exception,
1005   "Describe the current exception in greater detail",
1006   DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY |
1007   DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG,
1008   NULL,
1009   'D'},
1010#endif
1011  {debug_show_registers, 
1012   "Show raw GPR/SPR register values", 
1013   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1014   NULL,
1015   'R'},
1016  {debug_lisp_registers,
1017   "Show Lisp values of tagged registers",
1018   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1019   NULL,
1020   'L'},
1021  {debug_show_fpu,
1022   "Show FPU registers",
1023   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1024   NULL,
1025   'F'},
1026  {debug_show_symbol,
1027   "Find and describe symbol matching specified name",
1028   0,
1029   NULL,
1030   'S'},
1031  {debug_backtrace,
1032   "Show backtrace",
1033   0,
1034   NULL,
1035   'B'},
1036  {debug_thread_info,
1037   "Show info about current thread",
1038   0,
1039   NULL,
1040   'T'},
1041  {debug_win,
1042   "Exit from this debugger, asserting that any exception was handled",
1043   0,
1044   NULL,
1045   'X'},
1046#ifdef DARWIN
1047  {debug_lose,
1048   "Propagate the exception to another handler (debugger or OS)",
1049   DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY,
1050   NULL,
1051   'P'},
1052#endif
1053#if 0
1054  {debug_thread_reset,
1055   "Reset current thread (as if in response to stack overflow)",
1056   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1057   NULL,
1058   'T'},
1059#endif
1060  {debug_kill_process,
1061   "Kill Clozure CL process",
1062   0,
1063   NULL,
1064   'K'},
1065  {debug_help,
1066   "Show this help",
1067   0,
1068   NULL,
1069   '?'},
1070  /* end-of-table */
1071  {NULL,
1072   NULL,
1073   0,
1074   NULL,
1075   0}
1076};
1077
1078debug_command_return
1079apply_debug_command(ExceptionInformation *xp, int c, siginfo_t *info, int why) 
1080{
1081  if (c == EOF) {
1082    return debug_kill;
1083  } else {
1084    debug_command_entry *entry;
1085    debug_command f;
1086    c = toupper(c);
1087
1088    for (entry = debug_command_entries; (f = entry->f) != NULL; entry++) {
1089      if (toupper(entry->c) == c) {
1090        /* If we have an XP or don't need one, call the function */
1091        if ((xp || !(entry->flags & DEBUG_COMMAND_FLAG_REQUIRE_XP)) &&
1092            ((why > debug_entry_exception) || 
1093             !(entry->flags & DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY))) {
1094          int arg = 0;
1095          if ((entry->flags & DEBUG_COMMAND_REG_FLAGS)
1096              == DEBUG_COMMAND_FLAG_AUX_REGNO) {
1097            arg = debug_get_u5_value("register number");
1098          }
1099          if (entry->flags & DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG) {
1100            arg = why;
1101          }
1102          return (f)(xp, info, arg);
1103        }
1104        break;
1105      }
1106    }
1107    return debug_continue;
1108  }
1109}
1110
1111debug_identify_function(ExceptionInformation *xp, siginfo_t *info) 
1112{
1113#ifdef PPC
1114  if (xp) {
1115    if (active_tcr_p((TCR *)(ptr_from_lispobj(xpGPR(xp, rcontext))))) {
1116      LispObj f = xpGPR(xp, fn), codev;
1117      pc where = xpPC(xp);
1118     
1119      if (!(codev = register_codevector_contains_pc(f, where))) {
1120        f = xpGPR(xp, nfn);
1121        codev =  register_codevector_contains_pc(f, where);
1122      }
1123      if (codev) {
1124        fprintf(dbgout, " While executing: %s\n", print_lisp_object(f));
1125      }
1126    } else {
1127      int disp;
1128      char *foreign_name;
1129      natural where = (natural)xpPC(xp);
1130
1131      fprintf(dbgout, " In foreign code at address 0x" ZLISP "\n", where);
1132      foreign_name = foreign_name_and_offset(where, &disp);
1133      if (foreign_name) {
1134        fprintf(dbgout, "  [%s + %d]\n", foreign_name, disp);
1135      }
1136    }
1137  }
1138#endif
1139}
1140
1141#ifndef WINDOWS
1142extern pid_t main_thread_pid;
1143#endif
1144
1145
1146OSStatus
1147lisp_Debugger(ExceptionInformation *xp, 
1148              siginfo_t *info, 
1149              int why, 
1150              Boolean in_foreign_code,
1151              char *message, 
1152              ...)
1153{
1154  va_list args;
1155  debug_command_return state = debug_continue;
1156
1157
1158  if (stdin_is_dev_null()) {
1159    return -1;
1160  }
1161
1162  va_start(args,message);
1163  vfprintf(dbgout, message, args);
1164  fprintf(dbgout, "\n");
1165  va_end(args);
1166
1167  if (threads_initialized) {
1168    suspend_other_threads(false);
1169  }
1170
1171  lisp_debugger_in_foreign_code = in_foreign_code;
1172  if (in_foreign_code) {   
1173    char *foreign_name;
1174    int disp;
1175    fprintf(dbgout, "Exception occurred while executing foreign code\n");
1176    foreign_name = foreign_name_and_offset((natural)xpPC(xp), &disp);
1177    if (foreign_name) {
1178      fprintf(dbgout, " at %s + %d\n", foreign_name, disp);
1179    }
1180  }
1181
1182  if (xp) {
1183    if (why > debug_entry_exception) {
1184      debug_identify_exception(xp, info, why);
1185    }
1186    debug_identify_function(xp, info);
1187  }
1188  if (lisp_global(BATCH_FLAG)) {
1189#ifdef WINDOWS
1190    fprintf(dbgout, "Current Process Id %d\n", (int)GetCurrentProcessId());
1191#else
1192    fprintf(dbgout, "Main thread pid %d\n", main_thread_pid);
1193#endif
1194    debug_thread_info(xp, info, 0);
1195    if (xp) {
1196      debug_show_registers(xp, info, 0);
1197      debug_lisp_registers(xp, info, 0);
1198      debug_show_fpu(xp, info, 0);
1199    }
1200    debug_backtrace(xp, info, 0);
1201
1202    abort();
1203  }
1204
1205  fprintf(dbgout, "? for help\n");
1206  while (state == debug_continue) {
1207#ifdef WINDOWS
1208    fprintf(dbgout, "[%d] Clozure CL kernel debugger: ", (int)GetCurrentProcessId());
1209#else
1210    fprintf(dbgout, "[%d] Clozure CL kernel debugger: ", main_thread_pid);
1211#endif
1212    fflush(dbgout);             /* dbgout should be unbuffered, so this shouldn't be necessary.  But it can't hurt ... */
1213    state = apply_debug_command(xp, readc(), info, why);
1214  }
1215  switch (state) {
1216  case debug_exit_success:
1217    if (threads_initialized) {
1218      resume_other_threads(false);
1219    }
1220    return 0;
1221  case debug_exit_fail:
1222    if (threads_initialized) {
1223      resume_other_threads(false);
1224    }
1225    return -1;
1226  case debug_kill:
1227    terminate_lisp();
1228  default:
1229    return 0;
1230  }
1231}
1232
1233void
1234Bug(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, false, s);
1243
1244}
1245
1246void
1247FBug(ExceptionInformation *xp, const char *format, ...)
1248{
1249  va_list args;
1250  char s[512];
1251 
1252  va_start(args, format);
1253  vsnprintf(s, sizeof(s),format, args);
1254  va_end(args);
1255  lisp_Debugger(xp, NULL, debug_entry_bug, true, s);
1256
1257}
1258
1259void
1260lisp_bug(char *string)
1261{
1262  Bug(NULL, "Bug in Clozure CL system code:\n%s", string);
1263}
1264
Note: See TracBrowser for help on using the repository browser.