source: branches/arm/lisp-kernel/lisp-debug.c @ 13802

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

Preliminary ARM GPR display in kernel debugger.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 31.9 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#ifdef ARM
288  fprintf(dbgout, "r%02d (%s) = %s\n", r, label, print_lisp_object(val));
289#endif
290}
291
292
293void
294describe_memfault(ExceptionInformation *xp, siginfo_t *info)
295{
296#ifdef PPC
297  void *addr = (void *)xpDAR(xp);
298  natural dsisr = xpDSISR(xp);
299
300  fprintf(dbgout, "%s operation to %s address 0x%lx\n",
301          dsisr & (1<<25) ? "Write" : "Read",
302          dsisr & (1<<27) ? "protected" : "unmapped",
303          addr);
304#endif
305}
306
307#ifdef PPC
308void
309describe_ppc_illegal(ExceptionInformation *xp)
310{
311  pc where = xpPC(xp);
312  opcode the_uuo = *where;
313  Boolean described = false;
314
315  if (IS_UUO(the_uuo)) {
316    unsigned 
317      minor = UUO_MINOR(the_uuo),
318      errnum = 0x3ff & (the_uuo >> 16);
319
320    switch(minor) {
321    case UUO_INTERR:
322      switch (errnum) {
323      case error_udf_call:
324        fprintf(dbgout, "ERROR: undefined function call: %s\n",
325                print_lisp_object(xpGPR(xp,fname)));
326        described = true;
327        break;
328       
329      default:
330        fprintf(dbgout, "ERROR: lisp error %d\n", errnum);
331        described = true;
332        break;
333      }
334      break;
335     
336    default:
337      break;
338    }
339  }
340  if (!described) {
341    fprintf(dbgout, "Illegal instruction (0x%08x) at 0x%lx\n",
342            the_uuo, where);
343  }
344}
345#endif
346
347#ifdef PPC
348void
349describe_ppc_trap(ExceptionInformation *xp)
350{
351  pc where = xpPC(xp);
352  opcode the_trap = *where, instr;
353  int err_arg2, ra, rs;
354  Boolean identified = false;
355
356  if ((the_trap & OP_MASK) == OP(major_opcode_TRI)) {
357    /* TWI/TDI.  If the RA field is "nargs", that means that the
358       instruction is either a number-of-args check or an
359       event-poll.  Otherwise, the trap is some sort of
360       typecheck. */
361
362    if (RA_field(the_trap) == nargs) {
363      switch (TO_field(the_trap)) {
364      case TO_NE:
365        if (xpGPR(xp, nargs) < D_field(the_trap)) {
366          fprintf(dbgout, "Too few arguments (no opt/rest)\n");
367        } else {
368          fprintf(dbgout, "Too many arguments (no opt/rest)\n");
369        }
370        identified = true;
371        break;
372       
373      case TO_GT:
374        fprintf(dbgout, "Event poll !\n");
375        identified = true;
376        break;
377       
378      case TO_HI:
379        fprintf(dbgout, "Too many arguments (with opt)\n");
380        identified = true;
381        break;
382       
383      case TO_LT:
384        fprintf(dbgout, "Too few arguments (with opt/rest/key)\n");
385        identified = true;
386        break;
387       
388      default:                /* some weird trap, not ours. */
389        identified = false;
390        break;
391      }
392    } else {
393      /* A type or boundp trap of some sort. */
394      switch (TO_field(the_trap)) {
395      case TO_EQ:
396        /* Boundp traps are of the form:
397           treqi rX,unbound
398           where some preceding instruction is of the form:
399           lwz/ld rX,symbol.value(rY).
400           The error message should try to say that rY is unbound. */
401       
402        if (D_field(the_trap) == unbound) {
403#ifdef PPC64
404          instr = scan_for_instr(LD_instruction(RA_field(the_trap),
405                                                unmasked_register,
406                                                offsetof(lispsymbol,vcell)-fulltag_misc),
407                                 D_RT_IMM_MASK,
408                                 where);
409#else
410          instr = scan_for_instr(LWZ_instruction(RA_field(the_trap),
411                                                 unmasked_register,
412                                                 offsetof(lispsymbol,vcell)-fulltag_misc),
413                                 D_RT_IMM_MASK,
414                                 where);
415#endif
416          if (instr) {
417            ra = RA_field(instr);
418            if (lisp_reg_p(ra)) {
419              fprintf(dbgout, "Unbound variable: %s\n",
420                      print_lisp_object(xpGPR(xp,ra)));
421              identified = true;       
422            }
423          }
424        }
425        break;
426       
427      case TO_NE:
428        /* A type check.  If the type (the immediate field of the trap
429           instruction) is a header type, an "lbz
430           rX,misc_header_offset(rY)" should precede it, in which case
431           we say that "rY is not of header type <type>."  If the type
432           is not a header type, then rX should have been set by a
433           preceding "clrlwi rX,rY,29/30".  In that case, scan
434           backwards for an RLWINM instruction that set rX and report
435           that rY isn't of the indicated type. */
436        err_arg2 = D_field(the_trap);
437        if (nodeheader_tag_p(err_arg2) ||
438            immheader_tag_p(err_arg2)) {
439          instr = scan_for_instr(LBZ_instruction(RA_field(the_trap),
440                                                 unmasked_register,
441                                                 misc_subtag_offset),
442                                 D_RT_IMM_MASK,
443                                 where);
444          if (instr) {
445            ra = RA_field(instr);
446            if (lisp_reg_p(ra)) {
447              fprintf(dbgout, "value 0x%lX is not of the expected header type 0x%02X\n", xpGPR(xp, ra), err_arg2);
448              identified = true;
449            }
450          }
451        } else {               
452          /* Not a header type, look for rlwinm whose RA field matches the_trap's */
453          instr = scan_for_instr((OP(major_opcode_RLWINM) | (the_trap & RA_MASK)),
454                                 (OP_MASK | RA_MASK),
455                                 where);
456          if (instr) {
457            rs = RS_field(instr);
458            if (lisp_reg_p(rs)) {
459              fprintf(dbgout, "value 0x%lX is not of the expected type 0x%02X\n",
460                      xpGPR(xp, rs), err_arg2);
461              identified = true;
462            }
463          }
464        }
465        break;
466      }
467    }
468  } else {
469    /* a "TW <to>,ra,rb" instruction."
470       twltu sp,rN is stack-overflow on SP.
471       twgeu rX,rY is subscript out-of-bounds, which was preceded
472       by an "lwz rM,misc_header_offset(rN)" instruction.
473       rM may or may not be the same as rY, but no other header
474       would have been loaded before the trap. */
475    switch (TO_field(the_trap)) {
476    case TO_LO:
477      if (RA_field(the_trap) == sp) {
478        fprintf(dbgout, "Stack overflow! Run away! Run away!\n");
479        identified = true;
480      }
481      break;
482     
483    case (TO_HI|TO_EQ):
484      instr = scan_for_instr(OP(major_opcode_LWZ) | (D_MASK & misc_header_offset),
485                             (OP_MASK | D_MASK),
486                             where);
487      if (instr) {
488        ra = RA_field(instr);
489        if (lisp_reg_p(ra)) {
490          fprintf(dbgout, "Bad index %d for vector %lX length %d\n",
491                  unbox_fixnum(xpGPR(xp, RA_field(the_trap))),
492                  xpGPR(xp, ra),
493                  unbox_fixnum(xpGPR(xp, RB_field(the_trap))));
494          identified = true;
495        }
496      }
497      break;
498    }
499  }
500
501  if (!identified) {
502    fprintf(dbgout, "Unknown trap: 0x%08x\n", the_trap);
503  }
504
505
506}
507#endif
508
509debug_command_return
510debug_lisp_registers(ExceptionInformation *xp, siginfo_t *info, int arg)
511{
512  if (lisp_debugger_in_foreign_code == false) {
513#ifdef PPC
514    TCR *xpcontext = (TCR *)ptr_from_lispobj(xpGPR(xp, rcontext));
515
516    fprintf(dbgout, "rcontext = 0x%lX ", xpcontext);
517    if (!active_tcr_p(xpcontext)) {
518      fprintf(dbgout, "(INVALID)\n");
519    } else {
520      fprintf(dbgout, "\nnargs = %d\n", xpGPR(xp, nargs) >> fixnumshift);
521      show_lisp_register(xp, "fn", fn);
522      show_lisp_register(xp, "arg_z", arg_z);
523      show_lisp_register(xp, "arg_y", arg_y);
524      show_lisp_register(xp, "arg_x", arg_x);
525      show_lisp_register(xp, "temp0", temp0);
526      show_lisp_register(xp, "temp1/next_method_context", temp1);
527      show_lisp_register(xp, "temp2/nfn", temp2);
528      show_lisp_register(xp, "temp3/fname", temp3);
529
530      show_lisp_register(xp, "save0", save0);
531      show_lisp_register(xp, "save1", save1);
532      show_lisp_register(xp, "save2", save2);
533      show_lisp_register(xp, "save3", save3);
534      show_lisp_register(xp, "save4", save4);
535      show_lisp_register(xp, "save5", save5);
536      show_lisp_register(xp, "save6", save6);
537      show_lisp_register(xp, "save7", save7);
538    }
539#endif
540#ifdef X8664
541
542    show_lisp_register(xp, "arg_z", Iarg_z);
543    show_lisp_register(xp, "arg_y", Iarg_y);
544    show_lisp_register(xp, "arg_x", Iarg_x);
545    fprintf(dbgout,"------\n");
546    show_lisp_register(xp, "fn", Ifn);
547    fprintf(dbgout,"------\n");
548    show_lisp_register(xp, "save0", Isave0);
549    show_lisp_register(xp, "save1", Isave1);
550    show_lisp_register(xp, "save2", Isave2);
551    show_lisp_register(xp, "save3", Isave3);
552    fprintf(dbgout,"------\n");
553    show_lisp_register(xp, "temp0", Itemp0);
554    show_lisp_register(xp, "temp1", Itemp1);
555    show_lisp_register(xp, "temp2", Itemp2);
556    fprintf(dbgout,"------\n");
557    if (tag_of(xpGPR(xp,Inargs)) == tag_fixnum) {
558      fprintf(dbgout,"%%rcx (nargs) = %ld (maybe)\n", unbox_fixnum(xpGPR(xp,Inargs)&0xffff));
559    }
560#endif
561
562#ifdef X8632
563  show_lisp_register(xp, "arg_z", Iarg_z);
564  show_lisp_register(xp, "arg_y", Iarg_y);
565  fprintf(dbgout,"------\n");
566  show_lisp_register(xp, "fn", Ifn);
567  fprintf(dbgout,"------\n");
568  show_lisp_register(xp, "temp0", Itemp0);
569  show_lisp_register(xp, "temp1", Itemp1);
570  fprintf(dbgout,"------\n");
571  if (tag_of(xpGPR(xp,Inargs)) == tag_fixnum) {
572    fprintf(dbgout,"%%edx (nargs) = %d (maybe)\n", unbox_fixnum(xpGPR(xp,Inargs)));
573  }
574#endif
575#ifdef ARM
576    TCR *xpcontext = (TCR *)ptr_from_lispobj(xpGPR(xp, rcontext));
577
578    fprintf(dbgout, "rcontext = 0x%lX ", xpcontext);
579    if (!active_tcr_p(xpcontext)) {
580      fprintf(dbgout, "(INVALID)\n");
581    } else {
582      fprintf(dbgout, "\nnargs = %d\n", xpGPR(xp, nargs) >> fixnumshift);
583      show_lisp_register(xp, "fn", fn);
584      show_lisp_register(xp, "arg_z", arg_z);
585      show_lisp_register(xp, "arg_y", arg_y);
586      show_lisp_register(xp, "arg_x", arg_x);
587      show_lisp_register(xp, "temp0", temp0);
588      show_lisp_register(xp, "temp1/fname/next_method_context", temp1);
589      show_lisp_register(xp, "temp2/nfn", temp2);
590    }
591#endif
592  }
593 
594  return debug_continue;
595}
596
597#ifdef PPC
598debug_command_return
599debug_advance_pc(ExceptionInformation *xp, siginfo_t *info, int arg)
600{
601  adjust_exception_pc(xp,4);
602  return debug_continue;
603}
604#endif
605
606debug_command_return
607debug_identify_exception(ExceptionInformation *xp, siginfo_t *info, int arg)
608{
609#ifdef PPC
610  pc program_counter = xpPC(xp);
611  opcode instruction = 0;
612
613  switch (arg) {
614  case SIGILL:
615  case SIGTRAP:
616    instruction = *program_counter;
617    if (major_opcode_p(instruction, major_opcode_TRI) ||
618        X_opcode_p(instruction,major_opcode_X31,minor_opcode_TR)) {
619      describe_ppc_trap(xp);
620    } else {
621      describe_ppc_illegal(xp);
622    }
623    break;
624  case SIGSEGV:
625  case SIGBUS:
626    describe_memfault(xp, info);
627    break;
628  default:
629    break;
630  }
631#endif
632  return debug_continue;
633}
634
635char *
636debug_get_string_value(char *prompt)
637{
638  static char buf[128];
639  char *p, *res;
640
641  do {
642    fpurge(stdin);
643    fprintf(dbgout, "\n %s :",prompt);
644    buf[0] = 0;
645    res = fgets(buf, sizeof(buf), stdin);
646  } while (0);
647  p = strchr(res, '\n');
648  if (p) {
649    *p = 0;
650    return buf;
651  }
652  return NULL;
653}
654
655natural
656debug_get_natural_value(char *prompt)
657{
658  char s[32], *res;
659  int n;
660  natural val;
661
662  do {
663    fpurge(stdin);
664    fprintf(dbgout, "\n  %s :", prompt);
665    s[0]=0;
666    res = fgets(s, 24, stdin);
667    n = sscanf(s, "%lu", &val);
668  } while (n != 1);
669  return val;
670}
671
672unsigned
673debug_get_u5_value(char *prompt)
674{
675  char s[32], *res;
676  int n;
677  unsigned val;
678
679  do {
680    fpurge(stdin);
681    fprintf(dbgout, "\n  %s :", prompt);
682    res = fgets(s, 24, stdin);
683    n = sscanf(res, "%i", &val);
684  } while ((n != 1) || (val > 31));
685  return val;
686}
687
688debug_command_return
689debug_show_symbol(ExceptionInformation *xp, siginfo_t *info, int arg)
690{
691  char *pname = debug_get_string_value("symbol name");
692  extern void *plsym(ExceptionInformation *,char*);
693 
694  if (pname != NULL) {
695    plsym(xp, pname);
696  }
697  return debug_continue;
698}
699
700debug_command_return
701debug_thread_info(ExceptionInformation *xp, siginfo_t *info, int arg)
702{
703  TCR * tcr = get_tcr(false);
704 
705  if (tcr) {
706    area *vs_area = tcr->vs_area, *cs_area = tcr->cs_area;
707
708    fprintf(dbgout, "Current Thread Context Record (tcr) = 0x" LISP "\n", tcr);
709    fprintf(dbgout, "Control (C) stack area:  low = 0x" LISP ", high = 0x" LISP "\n",
710            (cs_area->low), (cs_area->high));
711    fprintf(dbgout, "Value (lisp) stack area: low = 0x" LISP ", high = 0x" LISP "\n",
712            (u64_t)(natural)(vs_area->low), (u64_t)(natural)vs_area->high);
713    if (xp) {
714      fprintf(dbgout, "Exception stack pointer = 0x" LISP "\n",
715#ifdef PPC
716              (u64_t) (natural)(xpGPR(xp,1))
717#endif
718#ifdef X86
719              (u64_t) (natural)(xpGPR(xp,Isp))
720#endif           
721#ifdef ARM
722              (u64_t) (natural)(xpGPR(xp,Rsp))
723#endif
724              );
725    }
726  }
727  return debug_continue;
728}
729     
730
731debug_command_return
732debug_set_gpr(ExceptionInformation *xp, siginfo_t *info, int arg)
733{
734  char buf[32];
735  natural val;
736
737  sprintf(buf, "value for GPR %d", arg);
738  val = debug_get_natural_value(buf);
739  xpGPR(xp,arg) = val;
740  return debug_continue;
741}
742
743debug_command_return
744debug_show_registers(ExceptionInformation *xp, siginfo_t *info, int arg)
745{
746
747
748#ifdef PPC
749#ifdef PPC64
750  int a, b;
751  for (a = 0, b = 16; a < 16; a++, b++) {
752    fprintf(dbgout,"r%02d = 0x%016lX    r%02d = 0x%016lX\n",
753            a, xpGPR(xp, a),
754            b, xpGPR(xp, b));
755  }
756 
757  fprintf(dbgout, "\n PC = 0x%016lX     LR = 0x%016lX\n",
758          xpPC(xp), xpLR(xp));
759  fprintf(dbgout, "CTR = 0x%016lX    CCR = 0x%08X\n",
760          xpCTR(xp), xpCCR(xp));
761  fprintf(dbgout, "XER = 0x%08X            MSR = 0x%016lX\n",
762          xpXER(xp), xpMSR(xp));
763  fprintf(dbgout,"DAR = 0x%016lX  DSISR = 0x%08X\n",
764          xpDAR(xp), xpDSISR(xp));
765#else
766  int a, b, c, d;;
767  for (a = 0, b = 8, c = 16, d = 24; a < 8; a++, b++, c++, d++) {
768    fprintf(dbgout,"r%02d = 0x%08X  r%02d = 0x%08X  r%02d = 0x%08X  r%02d = 0x%08X\n",
769            a, xpGPR(xp, a),
770            b, xpGPR(xp, b),
771            c, xpGPR(xp, c),
772            d, xpGPR(xp, d));
773  }
774  fprintf(dbgout, "\n PC = 0x%08X   LR = 0x%08X  CTR = 0x%08X  CCR = 0x%08X\n",
775          xpPC(xp), xpLR(xp), xpCTR(xp), xpCCR(xp));
776  fprintf(dbgout, "XER = 0x%08X  MSR = 0x%08X  DAR = 0x%08X  DSISR = 0x%08X\n",
777          xpXER(xp), xpMSR(xp), xpDAR(xp), xpDSISR(xp));
778#endif
779#endif
780
781#ifdef X8664
782  fprintf(dbgout,"%%rax = 0x" ZLISP "      %%r8  = 0x" ZLISP "\n", xpGPR(xp,REG_RAX),xpGPR(xp,REG_R8));
783  fprintf(dbgout,"%%rcx = 0x" ZLISP "      %%r9  = 0x" ZLISP "\n", xpGPR(xp,REG_RCX),xpGPR(xp,REG_R9));
784  fprintf(dbgout,"%%rdx = 0x" ZLISP "      %%r10 = 0x" ZLISP "\n", xpGPR(xp,REG_RDX),xpGPR(xp,REG_R10));
785  fprintf(dbgout,"%%rbx = 0x" ZLISP "      %%r11 = 0x" ZLISP "\n", xpGPR(xp,REG_RBX),xpGPR(xp,REG_R11));
786  fprintf(dbgout,"%%rsp = 0x" ZLISP "      %%r12 = 0x" ZLISP "\n", xpGPR(xp,REG_RSP),xpGPR(xp,REG_R12));
787  fprintf(dbgout,"%%rbp = 0x" ZLISP "      %%r13 = 0x" ZLISP "\n", xpGPR(xp,REG_RBP),xpGPR(xp,REG_R13));
788  fprintf(dbgout,"%%rsi = 0x" ZLISP "      %%r14 = 0x" ZLISP "\n", xpGPR(xp,REG_RSI),xpGPR(xp,REG_R14));
789  fprintf(dbgout,"%%rdi = 0x" ZLISP "      %%r15 = 0x" ZLISP "\n", xpGPR(xp,REG_RDI),xpGPR(xp,REG_R15));
790  fprintf(dbgout,"%%rip = 0x" ZLISP "   %%rflags = 0x%08lx\n",
791          xpGPR(xp, Iip), eflags_register(xp));
792#endif
793
794#ifdef X8632
795  unsigned short rcs,rds,res,rfs,rgs,rss;
796#ifdef DARWIN
797  rcs = xp->uc_mcontext->__ss.__cs;
798  rds = xp->uc_mcontext->__ss.__ds;
799  res = xp->uc_mcontext->__ss.__es;
800  rfs = xp->uc_mcontext->__ss.__fs;
801  rgs = xp->uc_mcontext->__ss.__gs;
802  rss = xp->uc_mcontext->__ss.__ss;
803#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
804#endif
805#ifdef LINUX
806  rcs = xp->uc_mcontext.gregs[REG_CS];
807  rds = xp->uc_mcontext.gregs[REG_DS];
808  res = xp->uc_mcontext.gregs[REG_ES];
809  rfs = xp->uc_mcontext.gregs[REG_FS];
810  rgs = xp->uc_mcontext.gregs[REG_GS];
811  rss = xp->uc_mcontext.gregs[REG_SS];
812#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
813#endif
814#ifdef FREEBSD
815  rcs = xp->uc_mcontext.mc_cs;
816  rds = xp->uc_mcontext.mc_ds;
817  res = xp->uc_mcontext.mc_es;
818  rfs = xp->uc_mcontext.mc_fs;
819  rgs = xp->uc_mcontext.mc_gs;
820  rss = xp->uc_mcontext.mc_ss;
821#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
822#endif
823#ifdef SOLARIS
824  rcs = xp->uc_mcontext.gregs[CS];
825  rds = xp->uc_mcontext.gregs[DS];
826  res = xp->uc_mcontext.gregs[ES];
827  rfs = xp->uc_mcontext.gregs[FS];
828  rgs = xp->uc_mcontext.gregs[GS];
829  rss = xp->uc_mcontext.gregs[SS];
830#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
831#endif
832#ifdef WINDOWS
833  rcs = xp->SegCs;
834  rds = xp->SegDs;
835  res = xp->SegEs;
836  rfs = xp->SegFs;
837  rgs = xp->SegGs;
838  rss = xp->SegSs;
839#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
840#endif
841
842
843
844  fprintf(dbgout, "%%eax = 0x" ZLISP "\n", xpGPR(xp, REG_EAX));
845  fprintf(dbgout, "%%ecx = 0x" ZLISP "\n", xpGPR(xp, REG_ECX));
846  fprintf(dbgout, "%%edx = 0x" ZLISP "\n", xpGPR(xp, REG_EDX));
847  fprintf(dbgout, "%%ebx = 0x" ZLISP "\n", xpGPR(xp, REG_EBX));
848  fprintf(dbgout, "%%esp = 0x" ZLISP "\n", xpGPR(xp, REG_ESP));
849  fprintf(dbgout, "%%ebp = 0x" ZLISP "\n", xpGPR(xp, REG_EBP));
850  fprintf(dbgout, "%%esi = 0x" ZLISP "\n", xpGPR(xp, REG_ESI));
851  fprintf(dbgout, "%%edi = 0x" ZLISP "\n", xpGPR(xp, REG_EDI));
852  fprintf(dbgout, "%%eip = 0x" ZLISP "\n", xpGPR(xp, REG_EIP));
853  fprintf(dbgout, "%%eflags = 0x" ZLISP "\n", xpGPR(xp, REG_EFL));
854#ifdef DEBUG_SHOW_X86_SEGMENT_REGISTERS
855  fprintf(dbgout,"\n");
856  fprintf(dbgout, "%%cs = 0x%04x\n", rcs);
857  fprintf(dbgout, "%%ds = 0x%04x\n", rds);
858  fprintf(dbgout, "%%ss = 0x%04x\n", rss);
859  fprintf(dbgout, "%%es = 0x%04x\n", res);
860  fprintf(dbgout, "%%fs = 0x%04x\n", rfs);
861  fprintf(dbgout, "%%gs = 0x%04x\n", rgs);
862
863#endif
864
865#endif
866
867#ifdef ARM
868  int a, b;
869  for (a = 0, b = 8; a < 8; a++, b++) {
870    fprintf(dbgout,"r%02d = 0x%08lX    r%02d = 0x%08lX\n",
871            a, xpGPR(xp, a),
872            b, xpGPR(xp, b));
873  }
874#endif
875
876  return debug_continue;
877}
878
879debug_command_return
880debug_show_fpu(ExceptionInformation *xp, siginfo_t *info, int arg)
881{
882  double *dp;
883  int *np, i;
884#ifdef PPC
885  dp = xpFPRvector(xp);
886  np = (int *) dp;
887 
888  for (i = 0; i < 32; i++, np+=2) {
889    fprintf(dbgout, "f%02d : 0x%08X%08X (%f)\n", i,  np[0], np[1], *dp++);
890  }
891  fprintf(dbgout, "FPSCR = %08X\n", xpFPSCR(xp));
892#endif
893#ifdef X8664
894#ifdef LINUX
895  struct _libc_xmmreg * xmmp = &(xp->uc_mcontext.fpregs->_xmm[0]);
896#endif
897#ifdef DARWIN
898  struct xmm {
899    char fpdata[16];
900  };
901  struct xmm *xmmp = (struct xmm *)(xpFPRvector(xp));
902#endif
903#ifdef WINDOWS
904  struct xmm {
905    char fpdata[16];
906  };
907  struct xmm *xmmp; /* XXX: actually get them */
908#endif
909#ifdef FREEBSD
910  struct xmmacc *xmmp = xpXMMregs(xp);
911#endif
912#ifdef SOLARIS
913  upad128_t *xmmp = xpXMMregs(xp);
914#endif
915  float *sp;
916
917
918  for (i = 0; i < 16; i++, xmmp++) {
919    sp = (float *) xmmp;
920    dp = (double *) xmmp;
921    np = (int *) xmmp;
922    fprintf(dbgout, "f%02d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np, (double)(*sp), np[1], np[0], *dp);
923  }
924  fprintf(dbgout, "mxcsr = 0x%08x\n",
925#ifdef LINUX
926          xp->uc_mcontext.fpregs->mxcsr
927#endif
928#ifdef DARWIN
929          UC_MCONTEXT(xp)->__fs.__fpu_mxcsr
930#endif
931#ifdef FREEBSD
932          (((struct savefpu *)(&(xp)->uc_mcontext.mc_fpstate))->sv_env.en_mxcsr)
933#endif
934#ifdef SOLARIS
935          xp->uc_mcontext.fpregs.fp_reg_set.fpchip_state.xstatus
936#endif
937#ifdef WINDOWS
938          *(xpMXCSRptr(xp))
939#endif
940          );
941#endif 
942#ifdef X8632
943#ifdef DARWIN
944  struct xmm {
945    char fpdata[8];
946  };
947  struct xmm *xmmp = (struct xmm *)(xpFPRvector(xp));
948
949  for (i = 0; i < 8; i++, xmmp++) {
950    float *sp = (float *)xmmp;
951    dp = (double *)xmmp;
952    np = (int *)xmmp;
953    fprintf(dbgout, "f%1d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np,
954            (double)(*sp), np[1], np[0], *dp);
955  }
956  fprintf(dbgout, "mxcsr = 0x%08x\n", UC_MCONTEXT(xp)->__fs.__fpu_mxcsr);
957#endif
958#endif
959
960  return debug_continue;
961}
962
963debug_command_return
964debug_kill_process(ExceptionInformation *xp, siginfo_t *info, int arg) {
965  return debug_kill;
966}
967
968debug_command_return
969debug_win(ExceptionInformation *xp, siginfo_t *info, int arg) {
970  return debug_exit_success;
971}
972
973debug_command_return
974debug_lose(ExceptionInformation *xp, siginfo_t *info, int arg) {
975  return debug_exit_fail;
976}
977
978debug_command_return
979debug_help(ExceptionInformation *xp, siginfo_t *info, int arg) {
980  debug_command_entry *entry;
981
982  for (entry = debug_command_entries; entry->f; entry++) {
983    /* If we have an XP or don't need one, call the function */
984    if (xp || !(entry->flags & DEBUG_COMMAND_FLAG_REQUIRE_XP)) {
985      fprintf(dbgout, "(%c)  %s\n", entry->c, entry->help_text);
986    }
987  }
988  return debug_continue;
989}
990             
991
992 
993
994debug_command_return
995debug_backtrace(ExceptionInformation *xp, siginfo_t *info, int arg)
996{
997  extern LispObj current_stack_pointer();
998  extern void plbt_sp(LispObj);
999  extern void plbt(ExceptionInformation *);
1000
1001  if (xp) {
1002    plbt(xp);
1003#ifndef X86
1004  } else {
1005    plbt_sp(current_stack_pointer());
1006#endif
1007  }
1008  return debug_continue;
1009}
1010
1011debug_command_return
1012debug_thread_reset(ExceptionInformation *xp, siginfo_t *info, int arg)
1013{
1014  reset_lisp_process(xp);
1015  return debug_exit_success;
1016}
1017
1018
1019debug_command_entry debug_command_entries[] = 
1020{
1021  {debug_set_gpr,
1022   "Set specified GPR to new value",
1023   DEBUG_COMMAND_FLAG_AUX_REGNO,
1024   "GPR to set (0-31) ?",
1025   'G'},
1026#ifdef PPC
1027  {debug_advance_pc,
1028   "Advance the program counter by one instruction (use with caution!)",
1029   DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY,
1030   NULL,
1031   'A'},
1032  {debug_identify_exception,
1033   "Describe the current exception in greater detail",
1034   DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY |
1035   DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG,
1036   NULL,
1037   'D'},
1038#endif
1039  {debug_show_registers, 
1040   "Show raw GPR/SPR register values", 
1041   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1042   NULL,
1043   'R'},
1044  {debug_lisp_registers,
1045   "Show Lisp values of tagged registers",
1046   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1047   NULL,
1048   'L'},
1049  {debug_show_fpu,
1050   "Show FPU registers",
1051   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1052   NULL,
1053   'F'},
1054  {debug_show_symbol,
1055   "Find and describe symbol matching specified name",
1056   0,
1057   NULL,
1058   'S'},
1059  {debug_backtrace,
1060   "Show backtrace",
1061   0,
1062   NULL,
1063   'B'},
1064  {debug_thread_info,
1065   "Show info about current thread",
1066   0,
1067   NULL,
1068   'T'},
1069  {debug_win,
1070   "Exit from this debugger, asserting that any exception was handled",
1071   0,
1072   NULL,
1073   'X'},
1074#ifdef DARWIN
1075  {debug_lose,
1076   "Propagate the exception to another handler (debugger or OS)",
1077   DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY,
1078   NULL,
1079   'P'},
1080#endif
1081#if 0
1082  {debug_thread_reset,
1083   "Reset current thread (as if in response to stack overflow)",
1084   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1085   NULL,
1086   'T'},
1087#endif
1088  {debug_kill_process,
1089   "Kill Clozure CL process",
1090   0,
1091   NULL,
1092   'K'},
1093  {debug_help,
1094   "Show this help",
1095   0,
1096   NULL,
1097   '?'},
1098  /* end-of-table */
1099  {NULL,
1100   NULL,
1101   0,
1102   NULL,
1103   0}
1104};
1105
1106debug_command_return
1107apply_debug_command(ExceptionInformation *xp, int c, siginfo_t *info, int why) 
1108{
1109  if (c == EOF) {
1110    return debug_kill;
1111  } else {
1112    debug_command_entry *entry;
1113    debug_command f;
1114    c = toupper(c);
1115
1116    for (entry = debug_command_entries; (f = entry->f) != NULL; entry++) {
1117      if (toupper(entry->c) == c) {
1118        /* If we have an XP or don't need one, call the function */
1119        if ((xp || !(entry->flags & DEBUG_COMMAND_FLAG_REQUIRE_XP)) &&
1120            ((why > debug_entry_exception) || 
1121             !(entry->flags & DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY))) {
1122          int arg = 0;
1123          if ((entry->flags & DEBUG_COMMAND_REG_FLAGS)
1124              == DEBUG_COMMAND_FLAG_AUX_REGNO) {
1125            arg = debug_get_u5_value("register number");
1126          }
1127          if (entry->flags & DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG) {
1128            arg = why;
1129          }
1130          return (f)(xp, info, arg);
1131        }
1132        break;
1133      }
1134    }
1135    return debug_continue;
1136  }
1137}
1138
1139debug_identify_function(ExceptionInformation *xp, siginfo_t *info) 
1140{
1141#ifdef PPC
1142  if (xp) {
1143    if (active_tcr_p((TCR *)(ptr_from_lispobj(xpGPR(xp, rcontext))))) {
1144      LispObj f = xpGPR(xp, fn), codev;
1145      pc where = xpPC(xp);
1146     
1147      if (!(codev = register_codevector_contains_pc(f, where))) {
1148        f = xpGPR(xp, nfn);
1149        codev =  register_codevector_contains_pc(f, where);
1150      }
1151      if (codev) {
1152        fprintf(dbgout, " While executing: %s\n", print_lisp_object(f));
1153      }
1154    } else {
1155      int disp;
1156      char *foreign_name;
1157      natural where = (natural)xpPC(xp);
1158
1159      fprintf(dbgout, " In foreign code at address 0x" ZLISP "\n", where);
1160      foreign_name = foreign_name_and_offset(where, &disp);
1161      if (foreign_name) {
1162        fprintf(dbgout, "  [%s + %d]\n", foreign_name, disp);
1163      }
1164    }
1165  }
1166#endif
1167}
1168
1169#ifndef WINDOWS
1170extern pid_t main_thread_pid;
1171#endif
1172
1173
1174OSStatus
1175lisp_Debugger(ExceptionInformation *xp, 
1176              siginfo_t *info, 
1177              int why, 
1178              Boolean in_foreign_code,
1179              char *message, 
1180              ...)
1181{
1182  va_list args;
1183  debug_command_return state = debug_continue;
1184
1185
1186  if (stdin_is_dev_null()) {
1187    return -1;
1188  }
1189
1190  va_start(args,message);
1191  vfprintf(dbgout, message, args);
1192  fprintf(dbgout, "\n");
1193  va_end(args);
1194
1195  if (threads_initialized) {
1196    suspend_other_threads(false);
1197  }
1198
1199  lisp_debugger_in_foreign_code = in_foreign_code;
1200  if (in_foreign_code) {   
1201    char *foreign_name;
1202    int disp;
1203    fprintf(dbgout, "Exception occurred while executing foreign code\n");
1204    foreign_name = foreign_name_and_offset((natural)xpPC(xp), &disp);
1205    if (foreign_name) {
1206      fprintf(dbgout, " at %s + %d\n", foreign_name, disp);
1207    }
1208  }
1209
1210  if (xp) {
1211    if (why > debug_entry_exception) {
1212      debug_identify_exception(xp, info, why);
1213    }
1214    debug_identify_function(xp, info);
1215  }
1216  if (lisp_global(BATCH_FLAG)) {
1217#ifdef WINDOWS
1218    fprintf(dbgout, "Current Process Id %d\n", (int)GetCurrentProcessId());
1219#else
1220    fprintf(dbgout, "Main thread pid %d\n", main_thread_pid);
1221#endif
1222    debug_thread_info(xp, info, 0);
1223    if (xp) {
1224      debug_show_registers(xp, info, 0);
1225      debug_lisp_registers(xp, info, 0);
1226      debug_show_fpu(xp, info, 0);
1227    }
1228    debug_backtrace(xp, info, 0);
1229
1230    abort();
1231  }
1232
1233  fprintf(dbgout, "? for help\n");
1234  while (state == debug_continue) {
1235#ifdef WINDOWS
1236    fprintf(dbgout, "[%d] Clozure CL kernel debugger: ", (int)GetCurrentProcessId());
1237#else
1238    fprintf(dbgout, "[%d] Clozure CL kernel debugger: ", main_thread_pid);
1239#endif
1240    fflush(dbgout);             /* dbgout should be unbuffered, so this shouldn't be necessary.  But it can't hurt ... */
1241    state = apply_debug_command(xp, readc(), info, why);
1242  }
1243  switch (state) {
1244  case debug_exit_success:
1245    if (threads_initialized) {
1246      resume_other_threads(false);
1247    }
1248    return 0;
1249  case debug_exit_fail:
1250    if (threads_initialized) {
1251      resume_other_threads(false);
1252    }
1253    return -1;
1254  case debug_kill:
1255    terminate_lisp();
1256  default:
1257    return 0;
1258  }
1259}
1260
1261void
1262Bug(ExceptionInformation *xp, const char *format, ...)
1263{
1264  va_list args;
1265  char s[512];
1266 
1267  va_start(args, format);
1268  vsnprintf(s, sizeof(s),format, args);
1269  va_end(args);
1270  lisp_Debugger(xp, NULL, debug_entry_bug, false, s);
1271
1272}
1273
1274void
1275FBug(ExceptionInformation *xp, const char *format, ...)
1276{
1277  va_list args;
1278  char s[512];
1279 
1280  va_start(args, format);
1281  vsnprintf(s, sizeof(s),format, args);
1282  va_end(args);
1283  lisp_Debugger(xp, NULL, debug_entry_bug, true, s);
1284
1285}
1286
1287void
1288lisp_bug(char *string)
1289{
1290  Bug(NULL, "Bug in Clozure CL system code:\n%s", string);
1291}
1292
Note: See TracBrowser for help on using the repository browser.