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

Last change on this file since 12832 was 12832, checked in by gb, 11 years ago

lisp_debug: no fileno macro on Win64, so access FILE->_file.
win64/makefile: use more recent toolchain naming convention.

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