Clean up RCS ids
[projects/cmucl/cmucl.git] / src / lisp / interrupt.c
1 /*
2
3  This code was written as part of the CMU Common Lisp project at
4  Carnegie Mellon University, and has been placed in the public domain.
5
6 */
7
8 /* Interrupt handling magic. */
9
10 #include <stdio.h>
11 #include <unistd.h>
12 #include <stdlib.h>
13 #include <signal.h>
14 #include <assert.h>
15
16 #include "lisp.h"
17 #include "arch.h"
18 #include "internals.h"
19 #include "os.h"
20 #include "interrupt.h"
21 #include "globals.h"
22 #include "lispregs.h"
23 #include "validate.h"
24 #include "monitor.h"
25 #include "gc.h"
26 #include "alloc.h"
27 #include "dynbind.h"
28 #include "interr.h"
29
30 boolean internal_errors_enabled = 0;
31
32 os_context_t *lisp_interrupt_contexts[MAX_INTERRUPTS];
33
34 union interrupt_handler interrupt_handlers[NSIG];
35 void (*interrupt_low_level_handlers[NSIG])(HANDLER_ARGS) = {0};
36
37 static int pending_signal = 0;
38 static siginfo_t pending_code = {0};
39 static sigset_t pending_mask;
40 static boolean maybe_gc_pending = FALSE;
41
42
43 /****************************************************************\
44 * Utility routines used by various signal handlers.              *
45 \****************************************************************/
46
47 void
48 build_fake_control_stack_frame(os_context_t * context)
49 {
50 #if !(defined(i386) || defined(__x86_64))
51     lispobj oldcont;
52
53     /* Build a fake stack frame */
54     current_control_frame_pointer = (lispobj *) SC_REG(context, reg_CSP);
55     if ((lispobj *) SC_REG(context, reg_CFP) == current_control_frame_pointer) {
56         /* There is a small window during call where the callee's frame */
57         /* isn't built yet. */
58         if (LowtagOf(SC_REG(context, reg_CODE)) == type_FunctionPointer) {
59             /* We have called, but not built the new frame, so
60                build it for them. */
61             current_control_frame_pointer[0] = SC_REG(context, reg_OCFP);
62             current_control_frame_pointer[1] = SC_REG(context, reg_LRA);
63             current_control_frame_pointer += 8;
64             /* Build our frame on top of it. */
65             oldcont = (lispobj) SC_REG(context, reg_CFP);
66         } else {
67             /* We haven't yet called, build our frame as if the
68                partial frame wasn't there. */
69             oldcont = (lispobj) SC_REG(context, reg_OCFP);
70         }
71     }
72     /* ### We can't tell if we are still in the caller if it had to
73        reg_ALLOCate the stack frame due to stack arguments. */
74     /* ### Can anything strange happen during return? */
75     else {
76
77         /* Normal case. */
78         oldcont = (lispobj) SC_REG(context, reg_CFP);
79     }
80
81     current_control_stack_pointer = current_control_frame_pointer + 8;
82
83     current_control_frame_pointer[0] = oldcont;
84     current_control_frame_pointer[1] = NIL;
85     current_control_frame_pointer[2] = (lispobj) SC_REG(context, reg_CODE);
86 #endif
87 }
88
89 void
90 fake_foreign_function_call(os_context_t * context)
91 {
92     int context_index;
93
94     /* Get current LISP state from context */
95 #ifdef reg_ALLOC
96     current_dynamic_space_free_pointer = (lispobj *) SC_REG(context, reg_ALLOC);
97 #ifdef alpha
98     if ((long) current_dynamic_space_free_pointer & 1) {
99         printf("Dead in fake_foriegn_function-call, context = %x\n", context);
100         lose("");
101     }
102 #endif
103 #endif
104 #ifdef reg_BSP
105     current_binding_stack_pointer = (lispobj *) SC_REG(context, reg_BSP);
106 #endif
107
108     build_fake_control_stack_frame(context);
109
110     /* Do dynamic binding of the active interrupt context index
111        and save the context in the context array. */
112     context_index = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX) >> 2;
113
114     if (context_index >= MAX_INTERRUPTS) {
115         fprintf(stderr,
116                 "Maximum number (%d) of interrupts exceeded.  Exiting.\n",
117                 MAX_INTERRUPTS);
118         exit(1);
119     }
120
121     bind_variable(FREE_INTERRUPT_CONTEXT_INDEX, make_fixnum(context_index + 1));
122
123     lisp_interrupt_contexts[context_index] = context;
124
125     /* No longer in Lisp now. */
126     foreign_function_call_active = 1;
127 }
128
129 void
130 undo_fake_foreign_function_call(os_context_t * context)
131 {
132     /* Block all blockable signals */
133     sigset_t block;
134
135     sigemptyset(&block);
136     FILLBLOCKSET(&block);
137     sigprocmask(SIG_BLOCK, &block, 0);
138
139     /* Going back into lisp. */
140     foreign_function_call_active = 0;
141
142     /* Undo dynamic binding. */
143     /* ### Do I really need to unbind_to_here()? */
144     unbind();
145
146 #ifdef reg_ALLOC
147     /* Put the dynamic space free pointer back into the context. */
148     SC_REG(context, reg_ALLOC) =
149         (unsigned long) current_dynamic_space_free_pointer;
150 #endif
151 }
152
153 void
154 interrupt_internal_error(HANDLER_ARGS, boolean continuable)
155 {
156     ucontext_t *ucontext = (ucontext_t *) context;
157     lispobj context_sap = NIL;
158
159     fake_foreign_function_call(context);
160
161     /* Allocate the SAP object while the interrupts are still disabled. */
162     if (internal_errors_enabled)
163         context_sap = alloc_sap(context);
164
165     sigprocmask(SIG_SETMASK, &ucontext->uc_sigmask, 0);
166
167     if (internal_errors_enabled)
168         funcall2(SymbolFunction(INTERNAL_ERROR), context_sap,
169                  continuable ? T : NIL);
170     else
171         internal_error(context);
172     undo_fake_foreign_function_call(context);
173     if (continuable)
174         arch_skip_instruction(context);
175 }
176
177 static void
178 copy_sigmask(sigset_t *dst, sigset_t *src)
179 {
180 #ifndef __linux__
181     *dst = *src;
182 #else
183     memcpy(dst, src, NSIG / CHAR_BIT);
184 #endif
185 }
186
187 void
188 interrupt_handle_pending(os_context_t * context)
189 {
190 #ifndef i386
191     boolean were_in_lisp = !foreign_function_call_active;
192 #endif
193
194     SetSymbolValue(INTERRUPT_PENDING, NIL);
195
196     if (maybe_gc_pending) {
197         maybe_gc_pending = FALSE;
198 #ifndef i386
199         if (were_in_lisp)
200 #endif
201             fake_foreign_function_call(context);
202         funcall0(SymbolFunction(MAYBE_GC));
203 #ifndef i386
204         if (were_in_lisp)
205 #endif
206             undo_fake_foreign_function_call(context);
207     }
208
209     copy_sigmask(&context->uc_sigmask, &pending_mask);
210     sigemptyset(&pending_mask);
211
212     if (pending_signal) {
213         int signal;
214         siginfo_t code;
215
216         signal = pending_signal;
217         code = pending_code;
218         pending_signal = 0;
219         /* pending_code = 0; */
220         interrupt_handle_now(signal, &code, context);
221     }
222 }
223
224
225 /****************************************************************\
226 * interrupt_handle_now_handler, maybe_now_maybe_later            *
227 *    the two main signal handlers.                               *
228 * interrupt_handle_now                                           *
229 *    is called from those to do the real work, but isn't itself  *
230 *    a handler.                                                  *
231 \****************************************************************/
232
233 void
234 interrupt_handle_now_handler(HANDLER_ARGS)
235 {
236     interrupt_handle_now(signal, code, context);
237
238 #if defined(DARWIN) && defined(__ppc__)
239     /* Work around G5 bug; fix courtesy gbyers via chandler */
240     sigreturn(context);
241 #endif
242 }
243
244 void
245 interrupt_handle_now(HANDLER_ARGS)
246 {
247     int were_in_lisp;
248     ucontext_t *ucontext = (ucontext_t *) context;
249     union interrupt_handler handler;
250
251     handler = interrupt_handlers[signal];
252
253     RESTORE_FPU(context);
254     
255     if (handler.c == (void (*)(HANDLER_ARGS)) SIG_IGN)
256         return;
257
258     SAVE_CONTEXT();
259     /**/ were_in_lisp = !foreign_function_call_active;
260 #if ! (defined(i386) || defined(_x86_64))
261     if (were_in_lisp)
262 #endif
263         fake_foreign_function_call(context);
264
265     if (handler.c == (void (*)(HANDLER_ARGS)) SIG_DFL)
266         /* This can happen if someone tries to ignore or default on one of the */
267         /* signals we need for runtime support, and the runtime support */
268         /* decides to pass on it.  */
269         lose("interrupt_handle_now: No handler for signal %d?\n", signal);
270     else if (LowtagOf(handler.lisp) == type_FunctionPointer) {
271         /* Allocate the SAP object while the interrupts are still
272            disabled. */
273         lispobj context_sap = alloc_sap(context);
274
275         /* Allow signals again. */
276         sigprocmask(SIG_SETMASK, &ucontext->uc_sigmask, 0);
277
278 #if 1
279         funcall3(handler.lisp, make_fixnum(signal), make_fixnum(CODE(code)),
280                  context_sap);
281 #else
282         funcall3(handler.lisp, make_fixnum(signal), alloc_sap(code),
283                  alloc_sap(context));
284 #endif
285     } else {
286         /* Allow signals again. */
287         sigprocmask(SIG_SETMASK, &ucontext->uc_sigmask, 0);
288
289         (*handler.c) (signal, code, context);
290     }
291
292 #if !(defined(i386) || defined(__x86_64))
293     if (were_in_lisp)
294 #endif
295         undo_fake_foreign_function_call(context);
296 }
297
298 static void
299 setup_pending_signal(HANDLER_ARGS)
300 {
301     ucontext_t *ucontext = (ucontext_t *) context;
302     pending_signal = signal;
303     /*
304      * Note: We used to set pending_code = *code.  This doesn't work
305      * very well on Solaris since code is sometimes NULL.  AFAICT, we
306      * only care about the si_code value, so just get the si_code
307      * value.  The CODE macro does something appropriate when code is
308      * NULL.
309      *
310      * A look at the Lisp handlers shows that the code value is
311      * ignored anyway.
312      *
313      */
314     pending_code.si_code = CODE(code);
315     copy_sigmask(&pending_mask, &ucontext->uc_sigmask);
316     FILLBLOCKSET(&ucontext->uc_sigmask);
317 }
318
319 static void
320 maybe_now_maybe_later(HANDLER_ARGS)
321 {
322     SAVE_CONTEXT();
323     if (SymbolValue(INTERRUPTS_ENABLED) == NIL) {
324         setup_pending_signal(signal, code, context);
325         SetSymbolValue(INTERRUPT_PENDING, T);
326     } else if (
327 #if !(defined(i386) || defined(__x86_64))
328                   (!foreign_function_call_active) &&
329 #endif
330                   arch_pseudo_atomic_atomic(context)) {
331         setup_pending_signal(signal, code, context);
332         arch_set_pseudo_atomic_interrupted(context);
333     } else {
334         RESTORE_FPU(context);
335         interrupt_handle_now(signal, code, context);
336     }
337
338 #if defined(DARWIN) && defined(__ppc__)
339     /* Work around G5 bug; fix courtesy gbyers via chandler */
340     sigreturn(context);
341 #endif
342 }
343
344 /****************************************************************\
345 * Stuff to detect and handle hitting the gc trigger.             *
346 \****************************************************************/
347
348 #ifndef INTERNAL_GC_TRIGGER
349 static boolean
350 gc_trigger_hit(HANDLER_ARGS)
351 {
352     if (current_auto_gc_trigger == NULL) {
353         return FALSE;
354     } else {
355         lispobj *badaddr = (lispobj *) arch_get_bad_addr(signal, code, context);
356
357 #ifdef PRINTNOISE
358         fprintf(stderr,
359                 "gc_trigger_hit: badaddr=%p, current_auto_gc_trigger=%p, limit=%p\n",
360                 badaddr, current_auto_gc_trigger,
361                 current_dynamic_space + dynamic_space_size);
362 #endif
363         return (badaddr >= current_auto_gc_trigger &&
364                 (unsigned long) badaddr <
365                 (unsigned long) current_dynamic_space +
366                 (unsigned long) dynamic_space_size);
367     }
368 }
369 #endif
370
371 #if !(defined(i386) || defined(__x86_64) || defined(GENCGC))
372 boolean
373 interrupt_maybe_gc(HANDLER_ARGS)
374 {
375     if (!foreign_function_call_active
376 #ifndef INTERNAL_GC_TRIGGER
377         && gc_trigger_hit(signal, code, context)
378 #endif
379         ) {
380 #ifndef INTERNAL_GC_TRIGGER
381         clear_auto_gc_trigger();
382 #endif
383
384         if (arch_pseudo_atomic_atomic(context)) {
385             maybe_gc_pending = TRUE;
386             if (pending_signal == 0) {
387                 copy_sigmask(&pending_mask, &context->uc_sigmask);
388                 FILLBLOCKSET(&context->uc_sigmask);
389             }
390             arch_set_pseudo_atomic_interrupted(context);
391         } else {
392             fake_foreign_function_call(context);
393             funcall0(SymbolFunction(MAYBE_GC));
394             undo_fake_foreign_function_call(context);
395         }
396
397         return TRUE;
398     } else
399         return FALSE;
400 }
401 #endif
402
403 /****************************************************************\
404 * Noise to install handlers.                                     *
405 \****************************************************************/
406
407 #if !(defined(i386) || defined(__x86_64))
408 #define SIGNAL_STACK_SIZE SIGSTKSZ
409 static char altstack[SIGNAL_STACK_SIZE];
410 #endif
411
412 void
413 interrupt_install_low_level_handler(int signal, void handler(HANDLER_ARGS))
414 {
415     struct sigaction sa;
416
417     sa.sa_sigaction = (void (*)(HANDLER_ARGS)) handler;
418     sigemptyset(&sa.sa_mask);
419     FILLBLOCKSET(&sa.sa_mask);
420     sa.sa_flags = SA_RESTART | SA_SIGINFO;
421
422     /* Deliver protection violations on a dedicated signal stack,
423        because, when we get that signal because of hitting a control
424        stack guard zone, it's not a good idea to use more of the
425        control stack for handling the signal.  */
426     /* But we only need this on x86 since the Lisp control stack and the
427        C control stack are the same.  For others, they're separate so
428        the C stack can still be used.  */
429 #ifdef RED_ZONE_HIT
430     if (signal == PROTECTION_VIOLATION_SIGNAL) {
431         stack_t sigstack;
432
433 #if (defined( i386 ) || defined(__x86_64))
434         sigstack.ss_sp = (void *) SIGNAL_STACK_START;
435 #else
436         sigstack.ss_sp = (void *) altstack;
437 #endif
438         sigstack.ss_flags = 0;
439         sigstack.ss_size = SIGNAL_STACK_SIZE;
440         if (sigaltstack(&sigstack, 0) == -1)
441             perror("sigaltstack");
442         sa.sa_flags |= SA_ONSTACK;
443     }
444 #endif /* RED_ZONE_HIT */
445
446     sigaction(signal, &sa, NULL);
447
448
449     if (handler == (void (*)(HANDLER_ARGS)) SIG_DFL)
450         interrupt_low_level_handlers[signal] = 0;
451     else
452         interrupt_low_level_handlers[signal] = handler;
453 }
454
455 unsigned long
456 install_handler(int signal, void handler(HANDLER_ARGS))
457 {
458     struct sigaction sa;
459     sigset_t old, new;
460     union interrupt_handler oldhandler;
461
462     sigemptyset(&new);
463     sigaddset(&new, signal);
464     sigprocmask(SIG_BLOCK, &new, &old);
465
466     sigemptyset(&new);
467     FILLBLOCKSET(&new);
468
469     if (interrupt_low_level_handlers[signal] == 0) {
470         if (handler == (void (*)(HANDLER_ARGS)) SIG_DFL
471             || handler == (void (*)(HANDLER_ARGS)) SIG_IGN)
472             sa.sa_sigaction = (void (*)(HANDLER_ARGS)) handler;
473         else if (sigismember(&new, signal))
474             sa.sa_sigaction = (void (*)(HANDLER_ARGS)) maybe_now_maybe_later;
475         else
476             sa.sa_sigaction = (void (*)(HANDLER_ARGS)) interrupt_handle_now_handler;
477         
478         sigemptyset(&sa.sa_mask);
479         FILLBLOCKSET(&sa.sa_mask);
480         sa.sa_flags = SA_SIGINFO | SA_RESTART;
481
482         sigaction(signal, &sa, NULL);
483     }
484
485     oldhandler = interrupt_handlers[signal];
486     interrupt_handlers[signal].c = handler;
487
488     sigprocmask(SIG_SETMASK, &old, 0);
489
490     return (unsigned long) oldhandler.lisp;
491 }
492
493 #ifdef FEATURE_HEAP_OVERFLOW_CHECK
494 void
495 interrupt_handle_space_overflow(lispobj error, os_context_t * context)
496 {
497 #if defined(i386) || defined(__x86_64)
498     SC_PC(context) = (int) ((struct function *) PTR(error))->code;
499     SC_REG(context, reg_NARGS) = 0;
500 #elif defined(sparc)
501     build_fake_control_stack_frame(context);
502     /* This part should be common to all non-x86 ports */
503     SC_PC(context) = (long) ((struct function *) PTR(error))->code;
504     SC_NPC(context) = SC_PC(context) + 4;
505     SC_REG(context, reg_NARGS) = 0;
506     SC_REG(context, reg_LIP) = (long) ((struct function *) PTR(error))->code;
507     SC_REG(context, reg_CFP) = (long) current_control_frame_pointer;
508     /* This is sparc specific */
509     SC_REG(context, reg_CODE) = ((long) PTR(error)) + type_FunctionPointer;
510     /*
511      * Restore important Lisp regs.  Are there others we need to
512      * restore?
513      */
514     SC_REG(context, reg_ALLOC) = (long) current_dynamic_space_free_pointer;
515     SC_REG(context, reg_NIL) = NIL;
516 #else
517 #error interrupt_handle_space_overflow not implemented for this system
518 #endif
519 }
520 #endif /* FEATURE_HEAP_OVERFLOW_CHECK */
521
522 void
523 interrupt_init(void)
524 {
525     int i;
526
527     for (i = 0; i < NSIG; i++)
528         interrupt_handlers[i].c = (void (*)(HANDLER_ARGS)) SIG_DFL;
529 }