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

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

arm-asm.lisp, arm-lap.lisp: drain-constant-pool. At least slightly
better than nothing. Check to make sure that :mem12 pc-relative label
references are within 12 bits of their target.

arm-backend: uncomment code to require arm-vinsns

arm-disassemble: hook up to DISASSEMBLE.

arm-vinsns: in REQUIRE-U32, get subtag from the right place.

arm2.lisp: assume that .SPprogvsave sets up an unwind-protect.

arm-bignum.lisp: %ADD-THE-CARRRY is indeed silly.

arm-misc.lisp: unscramble %UNLOCK-GC-LOCK, don't clobber address
in %PTR-STORE-FIXNUM-CONDITIONAL.

arm-utils.lisp: GC.

l1-boot-1.lisp: add ARM to PLATFORM-CPU-NAMES.

l1-boot-2.lisp: require disassembler, lapmacros files on ARM.

l1-boot-3.lisp: comment out error-callback activation on ARM.

l1-init.lisp: set *SAVE-SOURCE-LOCATIONS* to NIL on ARM for now. (More code
to step through/debug, and not short of that.)

version.lisp: don't say "arm-cross" if #+arm-target.

arm-gc.c: get a lot of this working, seemingly.

arm-macros.s: fix skip_stack_vector.

arm-spentry.s: get PROGV support working.

gc-common.c: check static-cons freelist only if GCDebug.

linuxarm/Makefile: enable GC integrity checks.

lisp-debug.c: start to support 'describe exception" for ARM.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 33.3 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
509#ifdef ARM
510void
511describe_arm_uuo(ExceptionInformation *xp)
512{
513  pc program_counter = xpPC(xp);
514  opcode instruction = *program_counter;
515
516  if (IS_UUO(instruction)) {
517    unsigned format = UUO_FORMAT(instruction);
518
519    switch(format) {
520    case uuo_format_nullary:
521    case uuo_format_nullary_error:
522      switch UUOA_field(instruction) {
523      case 0:
524        fprintf(dbgout,"alloc_trap\n");
525        break;
526      case 1:
527        fprintf(dbgout,"wrong number of args (%d) to %s\n",xpGPR(xp,nargs)>>node_shift,
528                print_lisp_object(xpGPR(xp,nfn)));
529        break;
530      case 2:
531        fprintf(dbgout,"gc trap\n");
532        break;
533      case 3:
534        fprintf(dbgout,"debug trap\n");
535        break;
536      case 4:
537        fprintf(dbgout,"deferred interrupt\n");
538        break;
539      case 5:
540        fprintf(dbgout,"deferred suspend\n");
541        break;
542      default:
543        break;
544      }
545      break;
546
547    case uuo_format_unary_error:
548      switch (UUO_UNARY_field(instruction)) {
549      case 0:
550      case 1:
551        fprintf(dbgout,"%s is unbound\n", print_lisp_object(xpGPR(xp,UUOA_field(instruction))));
552        break;
553
554      default:
555        break;
556      }
557    default:
558      break;
559    }
560  }
561}
562#endif
563
564debug_command_return
565debug_lisp_registers(ExceptionInformation *xp, siginfo_t *info, int arg)
566{
567  if (lisp_debugger_in_foreign_code == false) {
568#ifdef PPC
569    TCR *xpcontext = (TCR *)ptr_from_lispobj(xpGPR(xp, rcontext));
570
571    fprintf(dbgout, "rcontext = 0x%lX ", xpcontext);
572    if (!active_tcr_p(xpcontext)) {
573      fprintf(dbgout, "(INVALID)\n");
574    } else {
575      fprintf(dbgout, "\nnargs = %d\n", xpGPR(xp, nargs) >> fixnumshift);
576      show_lisp_register(xp, "fn", fn);
577      show_lisp_register(xp, "arg_z", arg_z);
578      show_lisp_register(xp, "arg_y", arg_y);
579      show_lisp_register(xp, "arg_x", arg_x);
580      show_lisp_register(xp, "temp0", temp0);
581      show_lisp_register(xp, "temp1/next_method_context", temp1);
582      show_lisp_register(xp, "temp2/nfn", temp2);
583      show_lisp_register(xp, "temp3/fname", temp3);
584
585      show_lisp_register(xp, "save0", save0);
586      show_lisp_register(xp, "save1", save1);
587      show_lisp_register(xp, "save2", save2);
588      show_lisp_register(xp, "save3", save3);
589      show_lisp_register(xp, "save4", save4);
590      show_lisp_register(xp, "save5", save5);
591      show_lisp_register(xp, "save6", save6);
592      show_lisp_register(xp, "save7", save7);
593    }
594#endif
595#ifdef X8664
596
597    show_lisp_register(xp, "arg_z", Iarg_z);
598    show_lisp_register(xp, "arg_y", Iarg_y);
599    show_lisp_register(xp, "arg_x", Iarg_x);
600    fprintf(dbgout,"------\n");
601    show_lisp_register(xp, "fn", Ifn);
602    fprintf(dbgout,"------\n");
603    show_lisp_register(xp, "save0", Isave0);
604    show_lisp_register(xp, "save1", Isave1);
605    show_lisp_register(xp, "save2", Isave2);
606    show_lisp_register(xp, "save3", Isave3);
607    fprintf(dbgout,"------\n");
608    show_lisp_register(xp, "temp0", Itemp0);
609    show_lisp_register(xp, "temp1", Itemp1);
610    show_lisp_register(xp, "temp2", Itemp2);
611    fprintf(dbgout,"------\n");
612    if (tag_of(xpGPR(xp,Inargs)) == tag_fixnum) {
613      fprintf(dbgout,"%%rcx (nargs) = %ld (maybe)\n", unbox_fixnum(xpGPR(xp,Inargs)&0xffff));
614    }
615#endif
616
617#ifdef X8632
618  show_lisp_register(xp, "arg_z", Iarg_z);
619  show_lisp_register(xp, "arg_y", Iarg_y);
620  fprintf(dbgout,"------\n");
621  show_lisp_register(xp, "fn", Ifn);
622  fprintf(dbgout,"------\n");
623  show_lisp_register(xp, "temp0", Itemp0);
624  show_lisp_register(xp, "temp1", Itemp1);
625  fprintf(dbgout,"------\n");
626  if (tag_of(xpGPR(xp,Inargs)) == tag_fixnum) {
627    fprintf(dbgout,"%%edx (nargs) = %d (maybe)\n", unbox_fixnum(xpGPR(xp,Inargs)));
628  }
629#endif
630#ifdef ARM
631    TCR *xpcontext = (TCR *)ptr_from_lispobj(xpGPR(xp, rcontext));
632
633    fprintf(dbgout, "rcontext = 0x%lX ", xpcontext);
634    if (!active_tcr_p(xpcontext)) {
635      fprintf(dbgout, "(INVALID)\n");
636    } else {
637      fprintf(dbgout, "\nnargs = %d\n", xpGPR(xp, nargs) >> fixnumshift);
638      show_lisp_register(xp, "fn", fn);
639      show_lisp_register(xp, "arg_z", arg_z);
640      show_lisp_register(xp, "arg_y", arg_y);
641      show_lisp_register(xp, "arg_x", arg_x);
642      show_lisp_register(xp, "temp0", temp0);
643      show_lisp_register(xp, "temp1/fname/next_method_context", temp1);
644      show_lisp_register(xp, "temp2/nfn", temp2);
645    }
646#endif
647  }
648 
649  return debug_continue;
650}
651
652#ifndef X86
653debug_command_return
654debug_advance_pc(ExceptionInformation *xp, siginfo_t *info, int arg)
655{
656  adjust_exception_pc(xp,4);
657  return debug_continue;
658}
659#endif
660
661debug_command_return
662debug_identify_exception(ExceptionInformation *xp, siginfo_t *info, int arg)
663{
664#ifdef PPC
665  pc program_counter = xpPC(xp);
666  opcode instruction = 0;
667
668  switch (arg) {
669  case SIGILL:
670  case SIGTRAP:
671    instruction = *program_counter;
672    if (major_opcode_p(instruction, major_opcode_TRI) ||
673        X_opcode_p(instruction,major_opcode_X31,minor_opcode_TR)) {
674      describe_ppc_trap(xp);
675    } else {
676      describe_ppc_illegal(xp);
677    }
678    break;
679  case SIGSEGV:
680  case SIGBUS:
681    describe_memfault(xp, info);
682    break;
683  default:
684    break;
685  }
686#endif
687#ifdef ARM
688  pc program_counter = xpPC(xp);
689  opcode instruction = 0;
690 
691  switch (arg) {
692  case SIGILL:
693    instruction = *program_counter;
694    if (IS_UUO(instruction)) {
695      describe_arm_uuo(xp);
696    }
697    break;
698  }
699#endif
700  return debug_continue;
701}
702
703char *
704debug_get_string_value(char *prompt)
705{
706  static char buf[128];
707  char *p, *res;
708
709  do {
710    fpurge(stdin);
711    fprintf(dbgout, "\n %s :",prompt);
712    buf[0] = 0;
713    res = fgets(buf, sizeof(buf), stdin);
714  } while (0);
715  p = strchr(res, '\n');
716  if (p) {
717    *p = 0;
718    return buf;
719  }
720  return NULL;
721}
722
723natural
724debug_get_natural_value(char *prompt)
725{
726  char s[32], *res, *endptr;
727  int n;
728  natural val;
729
730  do {
731    fpurge(stdin);
732    fprintf(dbgout, "\n  %s :", prompt);
733    s[0]=0;
734    res = fgets(s, 24, stdin);
735    val = strtoul(res,&endptr,0);
736  } while (*endptr);
737  return val;
738}
739
740unsigned
741debug_get_u5_value(char *prompt)
742{
743  char s[32], *res;
744  int n;
745  unsigned val;
746
747  do {
748    fpurge(stdin);
749    fprintf(dbgout, "\n  %s :", prompt);
750    res = fgets(s, 24, stdin);
751    n = sscanf(res, "%i", &val);
752  } while ((n != 1) || (val > 31));
753  return val;
754}
755
756debug_command_return
757debug_show_symbol(ExceptionInformation *xp, siginfo_t *info, int arg)
758{
759  char *pname = debug_get_string_value("symbol name");
760  extern void *plsym(ExceptionInformation *,char*);
761 
762  if (pname != NULL) {
763    plsym(xp, pname);
764  }
765  return debug_continue;
766}
767
768debug_command_return
769debug_thread_info(ExceptionInformation *xp, siginfo_t *info, int arg)
770{
771  TCR * tcr = get_tcr(false);
772 
773  if (tcr) {
774    area *vs_area = tcr->vs_area, *cs_area = tcr->cs_area;
775
776    fprintf(dbgout, "Current Thread Context Record (tcr) = 0x" LISP "\n", tcr);
777    fprintf(dbgout, "Control (C) stack area:  low = 0x" LISP ", high = 0x" LISP "\n",
778            (cs_area->low), (cs_area->high));
779    fprintf(dbgout, "Value (lisp) stack area: low = 0x" LISP ", high = 0x" LISP "\n",
780            (u64_t)(natural)(vs_area->low), (u64_t)(natural)vs_area->high);
781    if (xp) {
782      fprintf(dbgout, "Exception stack pointer = 0x" LISP "\n",
783#ifdef PPC
784              (u64_t) (natural)(xpGPR(xp,1))
785#endif
786#ifdef X86
787              (u64_t) (natural)(xpGPR(xp,Isp))
788#endif           
789#ifdef ARM
790              (u64_t) (natural)(xpGPR(xp,Rsp))
791#endif
792              );
793    }
794  }
795  return debug_continue;
796}
797     
798
799debug_command_return
800debug_set_gpr(ExceptionInformation *xp, siginfo_t *info, int arg)
801{
802  char buf[32];
803  natural val;
804
805  sprintf(buf, "value for GPR %d", arg);
806  val = debug_get_natural_value(buf);
807  xpGPR(xp,arg) = val;
808  return debug_continue;
809}
810
811debug_command_return
812debug_show_registers(ExceptionInformation *xp, siginfo_t *info, int arg)
813{
814
815
816#ifdef PPC
817#ifdef PPC64
818  int a, b;
819  for (a = 0, b = 16; a < 16; a++, b++) {
820    fprintf(dbgout,"r%02d = 0x%016lX    r%02d = 0x%016lX\n",
821            a, xpGPR(xp, a),
822            b, xpGPR(xp, b));
823  }
824 
825  fprintf(dbgout, "\n PC = 0x%016lX     LR = 0x%016lX\n",
826          xpPC(xp), xpLR(xp));
827  fprintf(dbgout, "CTR = 0x%016lX    CCR = 0x%08X\n",
828          xpCTR(xp), xpCCR(xp));
829  fprintf(dbgout, "XER = 0x%08X            MSR = 0x%016lX\n",
830          xpXER(xp), xpMSR(xp));
831  fprintf(dbgout,"DAR = 0x%016lX  DSISR = 0x%08X\n",
832          xpDAR(xp), xpDSISR(xp));
833#else
834  int a, b, c, d;;
835  for (a = 0, b = 8, c = 16, d = 24; a < 8; a++, b++, c++, d++) {
836    fprintf(dbgout,"r%02d = 0x%08X  r%02d = 0x%08X  r%02d = 0x%08X  r%02d = 0x%08X\n",
837            a, xpGPR(xp, a),
838            b, xpGPR(xp, b),
839            c, xpGPR(xp, c),
840            d, xpGPR(xp, d));
841  }
842  fprintf(dbgout, "\n PC = 0x%08X   LR = 0x%08X  CTR = 0x%08X  CCR = 0x%08X\n",
843          xpPC(xp), xpLR(xp), xpCTR(xp), xpCCR(xp));
844  fprintf(dbgout, "XER = 0x%08X  MSR = 0x%08X  DAR = 0x%08X  DSISR = 0x%08X\n",
845          xpXER(xp), xpMSR(xp), xpDAR(xp), xpDSISR(xp));
846#endif
847#endif
848
849#ifdef X8664
850  fprintf(dbgout,"%%rax = 0x" ZLISP "      %%r8  = 0x" ZLISP "\n", xpGPR(xp,REG_RAX),xpGPR(xp,REG_R8));
851  fprintf(dbgout,"%%rcx = 0x" ZLISP "      %%r9  = 0x" ZLISP "\n", xpGPR(xp,REG_RCX),xpGPR(xp,REG_R9));
852  fprintf(dbgout,"%%rdx = 0x" ZLISP "      %%r10 = 0x" ZLISP "\n", xpGPR(xp,REG_RDX),xpGPR(xp,REG_R10));
853  fprintf(dbgout,"%%rbx = 0x" ZLISP "      %%r11 = 0x" ZLISP "\n", xpGPR(xp,REG_RBX),xpGPR(xp,REG_R11));
854  fprintf(dbgout,"%%rsp = 0x" ZLISP "      %%r12 = 0x" ZLISP "\n", xpGPR(xp,REG_RSP),xpGPR(xp,REG_R12));
855  fprintf(dbgout,"%%rbp = 0x" ZLISP "      %%r13 = 0x" ZLISP "\n", xpGPR(xp,REG_RBP),xpGPR(xp,REG_R13));
856  fprintf(dbgout,"%%rsi = 0x" ZLISP "      %%r14 = 0x" ZLISP "\n", xpGPR(xp,REG_RSI),xpGPR(xp,REG_R14));
857  fprintf(dbgout,"%%rdi = 0x" ZLISP "      %%r15 = 0x" ZLISP "\n", xpGPR(xp,REG_RDI),xpGPR(xp,REG_R15));
858  fprintf(dbgout,"%%rip = 0x" ZLISP "   %%rflags = 0x%08lx\n",
859          xpGPR(xp, Iip), eflags_register(xp));
860#endif
861
862#ifdef X8632
863  unsigned short rcs,rds,res,rfs,rgs,rss;
864#ifdef DARWIN
865  rcs = xp->uc_mcontext->__ss.__cs;
866  rds = xp->uc_mcontext->__ss.__ds;
867  res = xp->uc_mcontext->__ss.__es;
868  rfs = xp->uc_mcontext->__ss.__fs;
869  rgs = xp->uc_mcontext->__ss.__gs;
870  rss = xp->uc_mcontext->__ss.__ss;
871#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
872#endif
873#ifdef LINUX
874  rcs = xp->uc_mcontext.gregs[REG_CS];
875  rds = xp->uc_mcontext.gregs[REG_DS];
876  res = xp->uc_mcontext.gregs[REG_ES];
877  rfs = xp->uc_mcontext.gregs[REG_FS];
878  rgs = xp->uc_mcontext.gregs[REG_GS];
879  rss = xp->uc_mcontext.gregs[REG_SS];
880#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
881#endif
882#ifdef FREEBSD
883  rcs = xp->uc_mcontext.mc_cs;
884  rds = xp->uc_mcontext.mc_ds;
885  res = xp->uc_mcontext.mc_es;
886  rfs = xp->uc_mcontext.mc_fs;
887  rgs = xp->uc_mcontext.mc_gs;
888  rss = xp->uc_mcontext.mc_ss;
889#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
890#endif
891#ifdef SOLARIS
892  rcs = xp->uc_mcontext.gregs[CS];
893  rds = xp->uc_mcontext.gregs[DS];
894  res = xp->uc_mcontext.gregs[ES];
895  rfs = xp->uc_mcontext.gregs[FS];
896  rgs = xp->uc_mcontext.gregs[GS];
897  rss = xp->uc_mcontext.gregs[SS];
898#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
899#endif
900#ifdef WINDOWS
901  rcs = xp->SegCs;
902  rds = xp->SegDs;
903  res = xp->SegEs;
904  rfs = xp->SegFs;
905  rgs = xp->SegGs;
906  rss = xp->SegSs;
907#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
908#endif
909
910
911
912  fprintf(dbgout, "%%eax = 0x" ZLISP "\n", xpGPR(xp, REG_EAX));
913  fprintf(dbgout, "%%ecx = 0x" ZLISP "\n", xpGPR(xp, REG_ECX));
914  fprintf(dbgout, "%%edx = 0x" ZLISP "\n", xpGPR(xp, REG_EDX));
915  fprintf(dbgout, "%%ebx = 0x" ZLISP "\n", xpGPR(xp, REG_EBX));
916  fprintf(dbgout, "%%esp = 0x" ZLISP "\n", xpGPR(xp, REG_ESP));
917  fprintf(dbgout, "%%ebp = 0x" ZLISP "\n", xpGPR(xp, REG_EBP));
918  fprintf(dbgout, "%%esi = 0x" ZLISP "\n", xpGPR(xp, REG_ESI));
919  fprintf(dbgout, "%%edi = 0x" ZLISP "\n", xpGPR(xp, REG_EDI));
920  fprintf(dbgout, "%%eip = 0x" ZLISP "\n", xpGPR(xp, REG_EIP));
921  fprintf(dbgout, "%%eflags = 0x" ZLISP "\n", xpGPR(xp, REG_EFL));
922#ifdef DEBUG_SHOW_X86_SEGMENT_REGISTERS
923  fprintf(dbgout,"\n");
924  fprintf(dbgout, "%%cs = 0x%04x\n", rcs);
925  fprintf(dbgout, "%%ds = 0x%04x\n", rds);
926  fprintf(dbgout, "%%ss = 0x%04x\n", rss);
927  fprintf(dbgout, "%%es = 0x%04x\n", res);
928  fprintf(dbgout, "%%fs = 0x%04x\n", rfs);
929  fprintf(dbgout, "%%gs = 0x%04x\n", rgs);
930
931#endif
932
933#endif
934
935#ifdef ARM
936  int a, b;
937  for (a = 0, b = 8; a < 8; a++, b++) {
938    fprintf(dbgout,"r%02d = 0x%08lX    r%02d = 0x%08lX\n",
939            a, xpGPR(xp, a),
940            b, xpGPR(xp, b));
941  }
942#endif
943
944  return debug_continue;
945}
946
947debug_command_return
948debug_show_fpu(ExceptionInformation *xp, siginfo_t *info, int arg)
949{
950  double *dp;
951  int *np, i;
952#ifdef PPC
953  dp = xpFPRvector(xp);
954  np = (int *) dp;
955 
956  for (i = 0; i < 32; i++, np+=2) {
957    fprintf(dbgout, "f%02d : 0x%08X%08X (%f)\n", i,  np[0], np[1], *dp++);
958  }
959  fprintf(dbgout, "FPSCR = %08X\n", xpFPSCR(xp));
960#endif
961#ifdef X8664
962#ifdef LINUX
963  struct _libc_xmmreg * xmmp = &(xp->uc_mcontext.fpregs->_xmm[0]);
964#endif
965#ifdef DARWIN
966  struct xmm {
967    char fpdata[16];
968  };
969  struct xmm *xmmp = (struct xmm *)(xpFPRvector(xp));
970#endif
971#ifdef WINDOWS
972  struct xmm {
973    char fpdata[16];
974  };
975  struct xmm *xmmp; /* XXX: actually get them */
976#endif
977#ifdef FREEBSD
978  struct xmmacc *xmmp = xpXMMregs(xp);
979#endif
980#ifdef SOLARIS
981  upad128_t *xmmp = xpXMMregs(xp);
982#endif
983  float *sp;
984
985
986  for (i = 0; i < 16; i++, xmmp++) {
987    sp = (float *) xmmp;
988    dp = (double *) xmmp;
989    np = (int *) xmmp;
990    fprintf(dbgout, "f%02d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np, (double)(*sp), np[1], np[0], *dp);
991  }
992  fprintf(dbgout, "mxcsr = 0x%08x\n",
993#ifdef LINUX
994          xp->uc_mcontext.fpregs->mxcsr
995#endif
996#ifdef DARWIN
997          UC_MCONTEXT(xp)->__fs.__fpu_mxcsr
998#endif
999#ifdef FREEBSD
1000          (((struct savefpu *)(&(xp)->uc_mcontext.mc_fpstate))->sv_env.en_mxcsr)
1001#endif
1002#ifdef SOLARIS
1003          xp->uc_mcontext.fpregs.fp_reg_set.fpchip_state.xstatus
1004#endif
1005#ifdef WINDOWS
1006          *(xpMXCSRptr(xp))
1007#endif
1008          );
1009#endif 
1010#ifdef X8632
1011#ifdef DARWIN
1012  struct xmm {
1013    char fpdata[8];
1014  };
1015  struct xmm *xmmp = (struct xmm *)(xpFPRvector(xp));
1016
1017  for (i = 0; i < 8; i++, xmmp++) {
1018    float *sp = (float *)xmmp;
1019    dp = (double *)xmmp;
1020    np = (int *)xmmp;
1021    fprintf(dbgout, "f%1d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np,
1022            (double)(*sp), np[1], np[0], *dp);
1023  }
1024  fprintf(dbgout, "mxcsr = 0x%08x\n", UC_MCONTEXT(xp)->__fs.__fpu_mxcsr);
1025#endif
1026#endif
1027
1028  return debug_continue;
1029}
1030
1031debug_command_return
1032debug_kill_process(ExceptionInformation *xp, siginfo_t *info, int arg) {
1033  return debug_kill;
1034}
1035
1036debug_command_return
1037debug_win(ExceptionInformation *xp, siginfo_t *info, int arg) {
1038  return debug_exit_success;
1039}
1040
1041debug_command_return
1042debug_lose(ExceptionInformation *xp, siginfo_t *info, int arg) {
1043  return debug_exit_fail;
1044}
1045
1046debug_command_return
1047debug_help(ExceptionInformation *xp, siginfo_t *info, int arg) {
1048  debug_command_entry *entry;
1049
1050  for (entry = debug_command_entries; entry->f; entry++) {
1051    /* If we have an XP or don't need one, call the function */
1052    if (xp || !(entry->flags & DEBUG_COMMAND_FLAG_REQUIRE_XP)) {
1053      fprintf(dbgout, "(%c)  %s\n", entry->c, entry->help_text);
1054    }
1055  }
1056  return debug_continue;
1057}
1058             
1059
1060 
1061
1062debug_command_return
1063debug_backtrace(ExceptionInformation *xp, siginfo_t *info, int arg)
1064{
1065  extern LispObj current_stack_pointer();
1066  extern void plbt_sp(LispObj);
1067  extern void plbt(ExceptionInformation *);
1068
1069  if (xp) {
1070    plbt(xp);
1071#ifndef X86
1072  } else {
1073    plbt_sp(current_stack_pointer());
1074#endif
1075  }
1076  return debug_continue;
1077}
1078
1079debug_command_return
1080debug_thread_reset(ExceptionInformation *xp, siginfo_t *info, int arg)
1081{
1082  reset_lisp_process(xp);
1083  return debug_exit_success;
1084}
1085
1086
1087debug_command_entry debug_command_entries[] = 
1088{
1089  {debug_set_gpr,
1090   "Set specified GPR to new value",
1091   DEBUG_COMMAND_FLAG_AUX_REGNO,
1092   "GPR to set (0-31) ?",
1093   'G'},
1094#ifndef X86
1095  {debug_advance_pc,
1096   "Advance the program counter by one instruction (use with caution!)",
1097   DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY,
1098   NULL,
1099   'A'},
1100  {debug_identify_exception,
1101   "Describe the current exception in greater detail",
1102   DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY |
1103   DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG,
1104   NULL,
1105   'D'},
1106#endif
1107  {debug_show_registers, 
1108   "Show raw GPR/SPR register values", 
1109   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1110   NULL,
1111   'R'},
1112  {debug_lisp_registers,
1113   "Show Lisp values of tagged registers",
1114   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1115   NULL,
1116   'L'},
1117  {debug_show_fpu,
1118   "Show FPU registers",
1119   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1120   NULL,
1121   'F'},
1122  {debug_show_symbol,
1123   "Find and describe symbol matching specified name",
1124   0,
1125   NULL,
1126   'S'},
1127  {debug_backtrace,
1128   "Show backtrace",
1129   0,
1130   NULL,
1131   'B'},
1132  {debug_thread_info,
1133   "Show info about current thread",
1134   0,
1135   NULL,
1136   'T'},
1137  {debug_win,
1138   "Exit from this debugger, asserting that any exception was handled",
1139   0,
1140   NULL,
1141   'X'},
1142#ifdef DARWIN
1143  {debug_lose,
1144   "Propagate the exception to another handler (debugger or OS)",
1145   DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY,
1146   NULL,
1147   'P'},
1148#endif
1149#if 0
1150  {debug_thread_reset,
1151   "Reset current thread (as if in response to stack overflow)",
1152   DEBUG_COMMAND_FLAG_REQUIRE_XP,
1153   NULL,
1154   'T'},
1155#endif
1156  {debug_kill_process,
1157   "Kill Clozure CL process",
1158   0,
1159   NULL,
1160   'K'},
1161  {debug_help,
1162   "Show this help",
1163   0,
1164   NULL,
1165   '?'},
1166  /* end-of-table */
1167  {NULL,
1168   NULL,
1169   0,
1170   NULL,
1171   0}
1172};
1173
1174debug_command_return
1175apply_debug_command(ExceptionInformation *xp, int c, siginfo_t *info, int why) 
1176{
1177  if (c == EOF) {
1178    return debug_kill;
1179  } else {
1180    debug_command_entry *entry;
1181    debug_command f;
1182    c = toupper(c);
1183
1184    for (entry = debug_command_entries; (f = entry->f) != NULL; entry++) {
1185      if (toupper(entry->c) == c) {
1186        /* If we have an XP or don't need one, call the function */
1187        if ((xp || !(entry->flags & DEBUG_COMMAND_FLAG_REQUIRE_XP)) &&
1188            ((why > debug_entry_exception) || 
1189             !(entry->flags & DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY))) {
1190          int arg = 0;
1191          if ((entry->flags & DEBUG_COMMAND_REG_FLAGS)
1192              == DEBUG_COMMAND_FLAG_AUX_REGNO) {
1193            arg = debug_get_u5_value("register number");
1194          }
1195          if (entry->flags & DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG) {
1196            arg = why;
1197          }
1198          return (f)(xp, info, arg);
1199        }
1200        break;
1201      }
1202    }
1203    return debug_continue;
1204  }
1205}
1206
1207debug_identify_function(ExceptionInformation *xp, siginfo_t *info) 
1208{
1209#ifdef PPC
1210  if (xp) {
1211    if (active_tcr_p((TCR *)(ptr_from_lispobj(xpGPR(xp, rcontext))))) {
1212      LispObj f = xpGPR(xp, fn), codev;
1213      pc where = xpPC(xp);
1214     
1215      if (!(codev = register_codevector_contains_pc(f, where))) {
1216        f = xpGPR(xp, nfn);
1217        codev =  register_codevector_contains_pc(f, where);
1218      }
1219      if (codev) {
1220        fprintf(dbgout, " While executing: %s\n", print_lisp_object(f));
1221      }
1222    } else {
1223      int disp;
1224      char *foreign_name;
1225      natural where = (natural)xpPC(xp);
1226
1227      fprintf(dbgout, " In foreign code at address 0x" ZLISP "\n", where);
1228      foreign_name = foreign_name_and_offset(where, &disp);
1229      if (foreign_name) {
1230        fprintf(dbgout, "  [%s + %d]\n", foreign_name, disp);
1231      }
1232    }
1233  }
1234#endif
1235}
1236
1237#ifndef WINDOWS
1238extern pid_t main_thread_pid;
1239#endif
1240
1241
1242OSStatus
1243lisp_Debugger(ExceptionInformation *xp, 
1244              siginfo_t *info, 
1245              int why, 
1246              Boolean in_foreign_code,
1247              char *message, 
1248              ...)
1249{
1250  va_list args;
1251  debug_command_return state = debug_continue;
1252
1253
1254  if (stdin_is_dev_null()) {
1255    return -1;
1256  }
1257
1258  va_start(args,message);
1259  vfprintf(dbgout, message, args);
1260  fprintf(dbgout, "\n");
1261  va_end(args);
1262
1263  if (threads_initialized) {
1264    suspend_other_threads(false);
1265  }
1266
1267  lisp_debugger_in_foreign_code = in_foreign_code;
1268  if (in_foreign_code) {   
1269    char *foreign_name;
1270    int disp;
1271    fprintf(dbgout, "Exception occurred while executing foreign code\n");
1272    foreign_name = foreign_name_and_offset((natural)xpPC(xp), &disp);
1273    if (foreign_name) {
1274      fprintf(dbgout, " at %s + %d\n", foreign_name, disp);
1275    }
1276  }
1277
1278  if (xp) {
1279    if (why > debug_entry_exception) {
1280      debug_identify_exception(xp, info, why);
1281    }
1282    debug_identify_function(xp, info);
1283  }
1284  if (lisp_global(BATCH_FLAG)) {
1285#ifdef WINDOWS
1286    fprintf(dbgout, "Current Process Id %d\n", (int)GetCurrentProcessId());
1287#else
1288    fprintf(dbgout, "Main thread pid %d\n", main_thread_pid);
1289#endif
1290    debug_thread_info(xp, info, 0);
1291    if (xp) {
1292      debug_show_registers(xp, info, 0);
1293      debug_lisp_registers(xp, info, 0);
1294      debug_show_fpu(xp, info, 0);
1295    }
1296    debug_backtrace(xp, info, 0);
1297
1298    abort();
1299  }
1300
1301  fprintf(dbgout, "? for help\n");
1302  while (state == debug_continue) {
1303#ifdef WINDOWS
1304    fprintf(dbgout, "[%d] Clozure CL kernel debugger: ", (int)GetCurrentProcessId());
1305#else
1306    fprintf(dbgout, "[%d] Clozure CL kernel debugger: ", main_thread_pid);
1307#endif
1308    fflush(dbgout);             /* dbgout should be unbuffered, so this shouldn't be necessary.  But it can't hurt ... */
1309    state = apply_debug_command(xp, readc(), info, why);
1310  }
1311  switch (state) {
1312  case debug_exit_success:
1313    if (threads_initialized) {
1314      resume_other_threads(false);
1315    }
1316    return 0;
1317  case debug_exit_fail:
1318    if (threads_initialized) {
1319      resume_other_threads(false);
1320    }
1321    return -1;
1322  case debug_kill:
1323    terminate_lisp();
1324  default:
1325    return 0;
1326  }
1327}
1328
1329void
1330Bug(ExceptionInformation *xp, const char *format, ...)
1331{
1332  va_list args;
1333  char s[512];
1334 
1335  va_start(args, format);
1336  vsnprintf(s, sizeof(s),format, args);
1337  va_end(args);
1338  lisp_Debugger(xp, NULL, debug_entry_bug, false, s);
1339
1340}
1341
1342void
1343FBug(ExceptionInformation *xp, const char *format, ...)
1344{
1345  va_list args;
1346  char s[512];
1347 
1348  va_start(args, format);
1349  vsnprintf(s, sizeof(s),format, args);
1350  va_end(args);
1351  lisp_Debugger(xp, NULL, debug_entry_bug, true, s);
1352
1353}
1354
1355void
1356lisp_bug(char *string)
1357{
1358  Bug(NULL, "Bug in Clozure CL system code:\n%s", string);
1359}
1360
Note: See TracBrowser for help on using the repository browser.