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

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

Don't ignore the return value from fgets() (to keep some versions of gcc
quiet), but don't really expect to handle a NULL, either.

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