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

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

Android doesn't have dladdr(), presumably because it might be useful.

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