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

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

Try to undo some of the damage done (mostly) by r13497.

image.c: handle relocation of weak vectors (hopefully) better.

lisp-debug.c: if we enter the kernel debugger with the batch flag

on, be more careful not to assume that we have exception context.
(We generally don't if 'Bug(NULL, "some message")' was used to
enter the debugger.)

ppc-gc.c, x86-gc.c: don't complain if the refbit for an intergenerational

reference from population.data of a weak list may have been cleared by
init_weakvll().

x86-gc.c: immutable_function_p() returns false on closures. Enter the

kernel debugger if purify_displaced_object() would try to copy a weak
vector out of dynamic space. (For now; need to take care to maintain
WEAKVLL if we do, and it's probably not something we'd want to do.)
Add purify_noderef(), which calls purify_locref() if ref points to
a tagged lisp pointer and does nothing otherwise.
Use purify_noderef() when recursively scanning in copy_reference(),
so we don't misinterpet immediate objects/headers as pointers to
dynamic space (as we've been doing since r13497.)
Make immutable_function_p() - which returns true if the function
can be copied to readonly memory - return false for closures, since
a closure's "constants" aren't as constant as a simple function's.

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