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

Last change on this file since 14261 was 14260, checked in by rme, 9 years ago

In debug_show_fpu(), check to see if Linux's xp->uc_mcontext.fpregs is
NULL, and just return if so.

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