1.0.24.44: bug in INVALID-ARRAY-INDEX-ERROR, leaving EXPECTED-TYPE slot unbound
[sbcl.git] / src / runtime / hppa-arch.c
1 /*
2  * This software is part of the SBCL system. See the README file for
3  * more information.
4  *
5  * This software is derived from the CMU CL system, which was
6  * written at Carnegie Mellon University and released into the
7  * public domain. The software is in the public domain and is
8  * provided with absolutely no warranty. See the COPYING and CREDITS
9  * files for more information.
10  */
11 #include <stdio.h>
12
13 /* Copied from sparc-arch.c.  Not all of these are necessary, probably */
14 #include "sbcl.h"
15 #include "runtime.h"
16 #include "arch.h"
17 #include "globals.h"
18 #include "validate.h"
19 #include "os.h"
20 #include "lispregs.h"
21 #include "signal.h"
22 #include "alloc.h"
23 #include "interrupt.h"
24 #include "interr.h"
25 #include "breakpoint.h"
26
27 void arch_init(void)
28 {
29     return;
30 }
31
32 static inline unsigned int
33 os_context_pc(os_context_t *context)
34 {
35     return (unsigned int)(*os_context_pc_addr(context));
36 }
37
38 os_vm_address_t arch_get_bad_addr(int signal, siginfo_t *siginfo, os_context_t *context)
39 {
40     return (os_vm_address_t)siginfo->si_addr;
41 #if 0
42 #ifdef LISP_FEATURE_HPUX
43     struct save_state *state;
44     os_vm_address_t addr;
45
46     state = (struct save_state *)(&(scp->sc_sl.sl_ss));
47
48     if (state == NULL)
49         return NULL;
50
51     /* Check the instruction address first. */
52     addr = (os_vm_address_t)((unsigned long)scp->sc_pcoq_head & ~3);
53     if (addr < (os_vm_address_t)0x1000)
54         return addr;
55
56     /* Otherwise, it must have been a data fault. */
57     return (os_vm_address_t)state->ss_cr21;
58 #else
59     struct hp800_thread_state *state;
60     os_vm_address_t addr;
61
62     state = (struct hp800_thread_state *)(scp->sc_ap);
63
64     if (state == NULL)
65         return NULL;
66
67     /* Check the instruction address first. */
68     addr = scp->sc_pcoqh & ~3;
69     if (addr < 0x1000)
70         return addr;
71
72     /* Otherwise, it must have been a data fault. */
73     return state->cr21;
74 #endif
75 #endif
76 }
77
78 unsigned char *arch_internal_error_arguments(os_context_t *context)
79 {
80     return (unsigned char *)((*os_context_pc_addr(context) & ~3) + 4);
81 }
82
83 boolean arch_pseudo_atomic_atomic(os_context_t *context)
84 {
85     /* FIXME: this foreign_function_call_active test is dubious at
86      * best. If a foreign call is made in a pseudo atomic section
87      * (?) or more likely a pseudo atomic section is in a foreign
88      * call then an interrupt is executed immediately. Maybe it
89      * has to do with C code not maintaining pseudo atomic
90      * properly. MG - 2005-08-10
91      *
92      * The foreign_function_call_active used to live at each call-site
93      * to arch_pseudo_atomic_atomic, but this seems clearer.
94      * --NS 2007-05-15 */
95
96       // FIX-lav: use accessor macro instead
97       return (!foreign_function_call_active) &&
98              *(&((ucontext_t *) context)->uc_mcontext.ss_wide.ss_64.ss_gr7) & 4;
99 }
100
101 void arch_set_pseudo_atomic_interrupted(os_context_t *context)
102 {
103
104     *(&((ucontext_t *) context)->uc_mcontext.ss_wide.ss_64.ss_gr7) |= 1;
105 /* on hpux do we need to watch out for the barbarian ? */
106 #ifdef LISP_FEATURE_HPUX
107     *((os_context_register_t *) &((ucontext_t *) context)->uc_mcontext.ss_flags)
108      |= SS_MODIFIEDWIDE;
109 #endif
110 }
111
112 /* FIXME: untested */
113 void arch_clear_pseudo_atomic_interrupted(os_context_t *context)
114 {
115     *(&((ucontext_t *) context)->uc_mcontext.ss_wide.ss_64.ss_gr7) &= ~1;
116 #ifdef LISP_FEATURE_HPUX
117     *((os_context_register_t *) &((ucontext_t *) context)->uc_mcontext.ss_flags)
118      |= SS_MODIFIEDWIDE;
119 #endif
120 }
121
122 void arch_skip_instruction(os_context_t *context)
123 {
124     *((unsigned int *) os_context_pc_addr(context)) = *((unsigned int *) os_context_npc_addr(context));
125     *((unsigned int *) os_context_npc_addr(context)) += 4;
126 #ifdef LISP_FEATURE_HPUX
127     *((os_context_register_t *) &((ucontext_t *) context)->uc_mcontext.ss_flags)
128      |= SS_MODIFIEDWIDE;
129 #endif
130 }
131
132 unsigned int arch_install_breakpoint(void *pc)
133 {
134     unsigned int *ulpc = (unsigned int *)pc;
135     unsigned int orig_inst = *ulpc;
136
137     *ulpc = trap_Breakpoint;
138     os_flush_icache((os_vm_address_t)pc, sizeof(*ulpc));
139     return orig_inst;
140 }
141
142 void arch_remove_breakpoint(void *pc, unsigned int orig_inst)
143 {
144     unsigned int *ulpc = (unsigned int *)pc;
145
146     *ulpc = orig_inst;
147     os_flush_icache((os_vm_address_t)pc, sizeof(*ulpc));
148 }
149
150 void arch_do_displaced_inst(os_context_t *context, unsigned int orig_inst)
151 {
152   fprintf(stderr, "arch_do_displaced_inst() WARNING: stub.\n");
153     /* FIXME: Fill this in */
154 #if 0
155 #ifdef LISP_FEATURE_HPUX
156     /* We change the next-pc to point to a breakpoint instruction, restore */
157     /* the original instruction, and exit.  We would like to be able to */
158     /* sigreturn, but we can't, because this is hpux. */
159     unsigned int *pc = (unsigned int *)(SC_PC(scp) & ~3);
160
161     NextPc = SC_NPC(scp);
162     SC_NPC(scp) = (unsigned int)SingleStepTraps | (SC_NPC(scp)&3);
163
164     BreakpointAddr = pc;
165     *pc = orig_inst;
166     os_flush_icache((os_vm_address_t)pc, sizeof(unsigned int));
167 #else
168     /* We set the recovery counter to cover one instruction, put the */
169     /* original instruction back in, and then resume.  We will then trap */
170     /* after executing that one instruction, at which time we can put */
171     /* the breakpoint back in. */
172
173     ((struct hp800_thread_state *)scp->sc_ap)->cr0 = 1;
174     scp->sc_ps |= 0x10;
175     *(unsigned int *)SC_PC(scp) = orig_inst;
176
177     sigreturn(scp);
178 #endif
179 #endif
180 }
181
182 #ifdef LISP_FEATURE_HPUX
183 #if 0
184 static void restore_breakpoint(struct sigcontext *scp)
185 {
186     /* We just single-stepped over an instruction that we want to replace */
187     /* with a breakpoint.  So we put the breakpoint back in, and tweek the */
188     /* state so that we will continue as if nothing happened. */
189
190     if (NextPc == NULL)
191         lose("SingleStepBreakpoint trap at strange time.\n");
192
193     if ((SC_PC(scp)&~3) == (unsigned int)SingleStepTraps) {
194         /* The next instruction was not nullified. */
195         SC_PC(scp) = NextPc;
196         if ((SC_NPC(scp)&~3) == (unsigned int)SingleStepTraps + 4) {
197             /* The instruction we just stepped over was not a branch, so */
198             /* we need to fix it up.  If it was a branch, it will point to */
199             /* the correct place. */
200             SC_NPC(scp) = NextPc + 4;
201         }
202     }
203     else {
204         /* The next instruction was nullified, so we want to skip it. */
205         SC_PC(scp) = NextPc + 4;
206         SC_NPC(scp) = NextPc + 8;
207     }
208     NextPc = NULL;
209
210     if (BreakpointAddr) {
211         *BreakpointAddr = trap_Breakpoint;
212         os_flush_icache((os_vm_address_t)BreakpointAddr,
213                         sizeof(unsigned int));
214         BreakpointAddr = NULL;
215     }
216 }
217 #endif
218 #endif
219
220
221
222 void
223 arch_handle_breakpoint(os_context_t *context)
224 {
225     /*sigsetmask(scp->sc_mask); */
226     handle_breakpoint(context);
227 }
228
229 void
230 arch_handle_fun_end_breakpoint(os_context_t *context)
231 {
232     /*sigsetmask(scp->sc_mask); */
233     unsigned long pc;
234     pc = (unsigned long)
235         handle_fun_end_breakpoint(context);
236     *os_context_pc_addr(context) = pc;
237     *os_context_npc_addr(context) = pc + 4;
238     *((os_context_register_t *) &((ucontext_t *) context)->uc_mcontext.ss_flags)
239      |= SS_MODIFIEDWIDE;
240 }
241
242
243 //FIX-lav: this whole is copied from mips
244 void
245 arch_handle_single_step_trap(os_context_t *context, int trap)
246 {
247     unsigned int code = *((u32 *)(os_context_pc(context)));
248     int register_offset = code >> 11 & 0x1f;
249     handle_single_step_trap(context, trap, register_offset);
250     arch_skip_instruction(context);
251 }
252
253 static void
254 sigtrap_handler(int signal, siginfo_t *siginfo, void *void_context)
255 {
256     os_context_t *context = arch_os_get_context(&void_context);
257     unsigned int bad_inst;
258
259     bad_inst = *(unsigned int *)(*os_context_pc_addr(context) & ~3);
260     if (bad_inst & 0xfc001fe0)
261         interrupt_handle_now(signal, siginfo, context);
262     else {
263         int im5 = bad_inst & 0x1f;
264         handle_trap(context, im5);
265     }
266 }
267
268 static void
269 sigill_handler(int signal, siginfo_t *siginfo, void *void_context)
270 {
271   os_context_t *context = arch_os_get_context(&void_context);
272   unsigned int bad_inst;
273
274   bad_inst = *(unsigned int *)(*os_context_pc_addr(context) & ~3);
275   if (bad_inst == 9) { /* pending-interrupt */
276     arch_clear_pseudo_atomic_interrupted(context);
277     arch_skip_instruction(context);
278     interrupt_handle_pending(context);
279   } else {
280     handle_trap(context,bad_inst);
281   }
282 }
283
284 static void sigfpe_handler(int signal, siginfo_t *siginfo, void *void_context)
285 {
286     os_context_t *context = arch_os_get_context(&void_context);
287     unsigned int badinst;
288     int opcode, r1, r2, t;
289     long op1, op2, res;
290
291     switch (siginfo->si_code) {
292     case FPE_INTOVF: /*I_OVFLO: */
293         badinst = *(unsigned int *)(*os_context_pc_addr(context) & ~3);
294         opcode = badinst >> 26;
295
296         if (opcode == 2) {
297             /* reg/reg inst. */
298             r1 = (badinst >> 16) & 0x1f;
299             op1 = fixnum_value(*os_context_register_addr(context, r1));
300             r2 = (badinst >> 21) & 0x1f;
301             op2 = fixnum_value(*os_context_register_addr(context, r2));
302             t = badinst & 0x1f;
303
304             switch ((badinst >> 5) & 0x7f) {
305             case 0x70:
306                 /* Add and trap on overflow. */
307                 res = op1 + op2;
308                 break;
309
310             case 0x60:
311                 /* Subtract and trap on overflow. */
312                 res = op1 - op2;
313                 break;
314
315             default:
316                 goto not_interesting;
317             }
318         }
319         else if ((opcode & 0x37) == 0x25 && (badinst & (1<<11))) {
320             /* Add or subtract immediate. */
321             op1 = ((badinst >> 3) & 0xff) | ((-badinst&1)<<8);
322             r2 = (badinst >> 16) & 0x1f;
323             op2 = fixnum_value(*os_context_register_addr(context, r2));
324             t = (badinst >> 21) & 0x1f;
325             if (opcode == 0x2d)
326                 res = op1 + op2;
327             else
328                 res = op1 - op2;
329         }
330         else
331             goto not_interesting;
332         /* ?? What happens here if we hit the end of dynamic space? */
333         dynamic_space_free_pointer = (lispobj *) *os_context_register_addr(context, reg_ALLOC);
334         *os_context_register_addr(context, t) = alloc_number(res);
335         *os_context_register_addr(context, reg_ALLOC)
336             = (unsigned long) dynamic_space_free_pointer;
337         arch_skip_instruction(context);
338
339         break;
340 //#ifdef LINUX
341 //    case 0:
342 //#endif
343     case FPE_COND:
344         badinst = *(unsigned int *)(*os_context_pc_addr(context) & ~3);
345         if ((badinst&0xfffff800) == (0xb000e000|reg_ALLOC<<21|reg_ALLOC<<16)) {
346             /* It is an ADDIT,OD i,ALLOC,ALLOC instruction that trapped.
347              * That means that it is the end of a pseudo-atomic.  So do the
348              * add stripping off the pseudo-atomic-interrupted bit, and then
349              * tell the machine-independent code to process the pseudo-
350              * atomic. We cant skip the instruction because it holds
351              * extra-bytes that we must add to reg_alloc in context.
352              * It is so because we optimized away 'addi ,extra-bytes reg_alloc'
353              */
354             int immed = (badinst>>1)&0x3ff;
355             if (badinst & 1)
356                 immed |= -1<<10;
357             *os_context_register_addr(context, reg_ALLOC) += (immed-1);
358             arch_skip_instruction(context);
359             interrupt_handle_pending(context);
360             break;
361         }
362         /* else drop-through. */
363     default:
364     not_interesting:
365         interrupt_handle_now(signal, siginfo, context);
366     }
367 }
368
369 /* Merrily cut'n'pasted from sigfpe_handler.  On Linux, until
370    2.4.19-pa4 (hopefully), the overflow_trap wasn't implemented,
371    resulting in a SIGBUS instead. We adapt the sigfpe_handler here, in
372    the hope that it will do as a replacement until the new kernel sees
373    the light of day. Since the instructions that we need to fix up
374    tend not to be doing unaligned memory access, this should be a safe
375    workaround.  -- CSR, 2002-08-17 */
376 static void sigbus_handler(int signal, siginfo_t *siginfo, void *void_context)
377 {
378     os_context_t *context = arch_os_get_context(&void_context);
379     unsigned int badinst;
380     int opcode, r1, r2, t;
381     long op1, op2, res;
382
383     badinst = *(unsigned int *)(*os_context_pc_addr(context) & ~3);
384     /* First, test for the pseudo-atomic instruction */
385     if ((badinst & 0xfffff800) == (0xb000e000 |
386                                    reg_ALLOC<<21 |
387                                    reg_ALLOC<<16)) {
388         /* It is an ADDIT,OD i,ALLOC,ALLOC instruction that trapped.
389            That means that it is the end of a pseudo-atomic.  So do
390            the add stripping off the pseudo-atomic-interrupted bit,
391            and then tell the machine-independent code to process the
392            pseudo-atomic. */
393         int immed = (badinst>>1) & 0x3ff;
394         if (badinst & 1)
395             immed |= -1<<10;
396         *os_context_register_addr(context, reg_ALLOC) += (immed-1);
397         arch_skip_instruction(context);
398         interrupt_handle_pending(context);
399         return;
400     } else {
401         opcode = badinst >> 26;
402         if (opcode == 2) {
403             /* reg/reg inst. */
404             r1 = (badinst >> 16) & 0x1f;
405             op1 = fixnum_value(*os_context_register_addr(context, r1));
406             r2 = (badinst >> 21) & 0x1f;
407             op2 = fixnum_value(*os_context_register_addr(context, r2));
408             t = badinst & 0x1f;
409
410             switch ((badinst >> 5) & 0x7f) {
411             case 0x70:
412                 /* Add and trap on overflow. */
413                 res = op1 + op2;
414                 break;
415
416             case 0x60:
417                 /* Subtract and trap on overflow. */
418                 res = op1 - op2;
419                 break;
420
421             default:
422                 goto not_interesting;
423             }
424         } else if ((opcode & 0x37) == 0x25 && (badinst & (1<<11))) {
425             /* Add or subtract immediate. */
426             op1 = ((badinst >> 3) & 0xff) | ((-badinst&1)<<8);
427             r2 = (badinst >> 16) & 0x1f;
428             op2 = fixnum_value(*os_context_register_addr(context, r2));
429             t = (badinst >> 21) & 0x1f;
430             if (opcode == 0x2d)
431                 res = op1 + op2;
432             else
433                 res = op1 - op2;
434         }
435         else
436             goto not_interesting;
437
438         /* ?? What happens here if we hit the end of dynamic space? */
439         dynamic_space_free_pointer = (lispobj *) *os_context_register_addr(context, reg_ALLOC);
440         *os_context_register_addr(context, t) = alloc_number(res);
441         *os_context_register_addr(context, reg_ALLOC)
442             = (unsigned long) dynamic_space_free_pointer;
443         arch_skip_instruction(context);
444
445         return;
446
447     not_interesting:
448         interrupt_handle_now(signal, siginfo, context);
449     }
450 }
451
452 static void
453 ignore_handler(int signal, siginfo_t *siginfo, void *void_context)
454 {
455 }
456
457 /* this routine installs interrupt handlers that will
458  * bypass the lisp interrupt handlers */
459 void arch_install_interrupt_handlers(void)
460 {
461     undoably_install_low_level_interrupt_handler(SIGTRAP,sigtrap_handler);
462     undoably_install_low_level_interrupt_handler(SIGILL,sigill_handler);
463     undoably_install_low_level_interrupt_handler(SIGFPE,sigfpe_handler);
464     /* FIXME: beyond 2.4.19-pa4 this shouldn't be necessary. */
465     undoably_install_low_level_interrupt_handler(SIGBUS,sigbus_handler);
466 #ifdef LISP_FEATURE_HPUX
467     undoably_install_low_level_interrupt_handler(SIGXCPU,ignore_handler);
468     undoably_install_low_level_interrupt_handler(SIGXFSZ,ignore_handler);
469 #endif
470 }
471