fix bug in SYMBOL-VALUE CAS expansion for constant arguments
[sbcl.git] / src / runtime / interr.c
1 /*
2  * stuff to handle internal errors
3  */
4
5 /*
6  * This software is part of the SBCL system. See the README file for
7  * more information.
8  *
9  * This software is derived from the CMU CL system, which was
10  * written at Carnegie Mellon University and released into the
11  * public domain. The software is in the public domain and is
12  * provided with absolutely no warranty. See the COPYING and CREDITS
13  * files for more information.
14  */
15
16 #include <stdio.h>
17 #include <stdarg.h>
18 #include <stdlib.h>
19
20 #include "sbcl.h"
21 #include "arch.h"
22 #include "signal.h"
23
24 #include "runtime.h"
25 #include "interr.h"
26 #include "print.h"
27 #include "lispregs.h"
28 #include "genesis/static-symbols.h"
29 #include "genesis/vector.h"
30 #include "thread.h"
31 #include "monitor.h"
32 \f
33 /* the way that we shut down the system on a fatal error */
34
35 static void
36 default_lossage_handler(void)
37 {
38     exit(1);
39 }
40 static void (*lossage_handler)(void) = default_lossage_handler;
41
42 void enable_lossage_handler(void)
43 {
44     lossage_handler = monitor_or_something;
45 }
46 void disable_lossage_handler(void)
47 {
48     lossage_handler = default_lossage_handler;
49 }
50
51 static
52 void print_message(char *fmt, va_list ap)
53 {
54     fprintf(stderr, " in SBCL pid %d",getpid());
55 #if defined(LISP_FEATURE_SB_THREAD)
56     fprintf(stderr, "(tid %lu)", (unsigned long) thread_self());
57 #endif
58     if (fmt) {
59         fprintf(stderr, ":\n");
60         vfprintf(stderr, fmt, ap);
61     }
62     fprintf(stderr, "\n");
63 }
64
65 static inline void
66 call_lossage_handler() never_returns;
67
68 static inline void
69 call_lossage_handler()
70 {
71     lossage_handler();
72     fprintf(stderr, "Argh! lossage_handler() returned, total confusion..\n");
73     exit(1);
74 }
75
76 void
77 lose(char *fmt, ...)
78 {
79     va_list ap;
80     /* Block signals to prevent other threads, timers and such from
81      * interfering. If only all threads could be stopped somehow. */
82     block_blockable_signals(0, 0);
83     fprintf(stderr, "fatal error encountered");
84     va_start(ap, fmt);
85     print_message(fmt, ap);
86     va_end(ap);
87     fprintf(stderr, "\n");
88     fflush(stderr);
89     call_lossage_handler();
90 }
91
92 boolean lose_on_corruption_p = 0;
93
94 void
95 corruption_warning_and_maybe_lose(char *fmt, ...)
96 {
97     va_list ap;
98 #ifndef LISP_FEATURE_WIN32
99     sigset_t oldset;
100     block_blockable_signals(0, &oldset);
101 #endif
102     fprintf(stderr, "CORRUPTION WARNING");
103     va_start(ap, fmt);
104     print_message(fmt, ap);
105     va_end(ap);
106     fprintf(stderr, "The integrity of this image is possibly compromised.\n");
107     if (lose_on_corruption_p)
108         fprintf(stderr, "Exiting.\n");
109     else
110         fprintf(stderr, "Continuing with fingers crossed.\n");
111     fflush(stderr);
112     if (lose_on_corruption_p)
113         call_lossage_handler();
114 #ifndef LISP_FEATURE_WIN32
115     else
116         thread_sigmask(SIG_SETMASK,&oldset,0);
117 #endif
118 }
119 \f
120 char *internal_error_descriptions[] = {INTERNAL_ERROR_NAMES};
121 /* internal error handler for when the Lisp error system doesn't exist
122  *
123  * FIXME: Shouldn't error output go to stderr instead of stdout? (Alas,
124  * this'd require changes in a number of things like brief_print(..),
125  * or I'd have changed it immediately.) */
126 void
127 describe_internal_error(os_context_t *context)
128 {
129     unsigned char *ptr = arch_internal_error_arguments(context);
130     int len, scoffset, sc, offset, ch;
131
132     len = *ptr++;
133     printf("internal error #%d (%s)\n", *ptr,
134            internal_error_descriptions[*ptr]);
135     ptr++;
136     len--;
137     while (len > 0) {
138         scoffset = *ptr++;
139         len--;
140         if (scoffset == 253) {
141             scoffset = *ptr++;
142             len--;
143         }
144         else if (scoffset == 254) {
145             scoffset = ptr[0] + ptr[1]*256;
146             ptr += 2;
147             len -= 2;
148         }
149         else if (scoffset == 255) {
150             scoffset = ptr[0] + (ptr[1]<<8) + (ptr[2]<<16) + (ptr[3]<<24);
151             ptr += 4;
152             len -= 4;
153         }
154         sc = scoffset & 0x1f;
155         offset = scoffset >> 5;
156
157         printf("    SC: %d, Offset: %d", sc, offset);
158         switch (sc) {
159         case sc_AnyReg:
160         case sc_DescriptorReg:
161             putchar('\t');
162             brief_print(*os_context_register_addr(context, offset));
163             break;
164
165         case sc_CharacterReg:
166             ch = *os_context_register_addr(context, offset);
167 #ifdef LISP_FEATURE_X86
168             if (offset&1)
169                 ch = ch>>8;
170             ch = ch & 0xff;
171 #endif
172             switch (ch) {
173             case '\n': printf("\t'\\n'\n"); break;
174             case '\b': printf("\t'\\b'\n"); break;
175             case '\t': printf("\t'\\t'\n"); break;
176             case '\r': printf("\t'\\r'\n"); break;
177             default:
178                 if (ch < 32 || ch > 127)
179                     printf("\\%03o", ch);
180                 else
181                     printf("\t'%c'\n", ch);
182                 break;
183             }
184             break;
185         case sc_SapReg:
186 #ifdef sc_WordPointerReg
187         case sc_WordPointerReg:
188 #endif
189             printf("\t0x%08lx\n", (unsigned long) *os_context_register_addr(context, offset));
190             break;
191         case sc_SignedReg:
192             printf("\t%ld\n", (long) *os_context_register_addr(context, offset));
193             break;
194         case sc_UnsignedReg:
195             printf("\t%lu\n", (unsigned long) *os_context_register_addr(context, offset));
196             break;
197 #ifdef sc_SingleFloatReg
198         case sc_SingleFloatReg:
199             printf("\t%g\n", *(float *)&context->sc_fpregs[offset]);
200             break;
201 #endif
202 #ifdef sc_DoubleFloatReg
203         case sc_DoubleFloatReg:
204             printf("\t%g\n", *(double *)&context->sc_fpregs[offset]);
205             break;
206 #endif
207         default:
208             printf("\t???\n");
209             break;
210         }
211     }
212 }
213 \f
214 /* utility routines used by miscellaneous pieces of code */
215
216 lispobj debug_print(lispobj string)
217 {
218     /* This is a kludge.  It's not actually safe - in general - to use
219        %primitive print on the alpha, because it skips half of the
220        number stack setup that should usually be done on a function
221        call, so the called routine (i.e. this one) ends up being able
222        to overwrite local variables in the caller.  Rather than fix
223        this everywhere that %primitive print is used (it's only a
224        debugging aid anyway) we just guarantee our safety by putting
225        an unused buffer on the stack before doing anything else
226        here */
227     char untouched[32];
228     fprintf(stderr, "%s\n",
229             (char *)(((struct vector *)native_pointer(string))->data));
230     /* shut GCC up about not using this, because that's the point.. */
231     (void)untouched;
232     return NIL;
233 }