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

Last change on this file since 10010 was 10010, checked in by gb, 12 years ago

Mostly cosmetic changes (to avoid some gcc warnings at -Wall).
gc-common.c : initialize the fields in a timeval struct, to avoid spurious

warning.

lisp-debug.c : fix typo when printing %rsi value, use %l for nargs.

lisp.h prototype for print_lisp_object()

macros.h : kinder, gentler ptr_to_lispobj(), ptr_from_lispobj(), deref()

macros. (GC seems to miscompile at -low- optimization settings, may
have to do with these macros.)

pmcl-kernel.c : make implicit comparison operands explicit in a few

cases. Use %l when printing paging info.

ppc-constants32.h, ppc-constants64.h, x86-constants64.h: define new

hash-table-vector-header fields, now that we're using them in the
trunk.

thread_manager.c : use signed_natural for futex pointers

x86-gc.c : in mark_root(), use a simpler construct to set a pool's

data to NIL. (This may have been losing under -low- optimization.)

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