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

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

Look for SVN_REVISION macro, and by means of ridiculous C preprocessor
macros, set kernel_svn_revision from it if it is defined. (It is
expected to be defined from the lisp kernel makefiles).

Add a kernel debugger command to print out this version information.
Look for the symbol *OPENMCL-VERSION* by grovelling the lisp heap and
print out its value also.

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