Fix make-array transforms.
[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, os_context_t *context)
255 {
256     unsigned int bad_inst;
257
258     bad_inst = *(unsigned int *)(*os_context_pc_addr(context) & ~3);
259     if (bad_inst & 0xfc001fe0)
260         interrupt_handle_now(signal, siginfo, context);
261     else {
262         int im5 = bad_inst & 0x1f;
263         handle_trap(context, im5);
264     }
265 }
266
267 static void
268 sigill_handler(int signal, siginfo_t *siginfo, os_context_t *context)
269 {
270   unsigned int bad_inst;
271
272   bad_inst = *(unsigned int *)(*os_context_pc_addr(context) & ~3);
273   if (bad_inst == 9) { /* pending-interrupt */
274     arch_clear_pseudo_atomic_interrupted(context);
275     arch_skip_instruction(context);
276     interrupt_handle_pending(context);
277   } else {
278     handle_trap(context,bad_inst);
279   }
280 }
281
282 static void sigfpe_handler(int signal, siginfo_t *siginfo,
283                            os_context_t *context)
284 {
285     unsigned int badinst;
286     int opcode, r1, r2, t;
287     long op1, op2, res;
288
289     switch (siginfo->si_code) {
290     case FPE_INTOVF: /*I_OVFLO: */
291         badinst = *(unsigned int *)(*os_context_pc_addr(context) & ~3);
292         opcode = badinst >> 26;
293
294         if (opcode == 2) {
295             /* reg/reg inst. */
296             r1 = (badinst >> 16) & 0x1f;
297             op1 = fixnum_value(*os_context_register_addr(context, r1));
298             r2 = (badinst >> 21) & 0x1f;
299             op2 = fixnum_value(*os_context_register_addr(context, r2));
300             t = badinst & 0x1f;
301
302             switch ((badinst >> 5) & 0x7f) {
303             case 0x70:
304                 /* Add and trap on overflow. */
305                 res = op1 + op2;
306                 break;
307
308             case 0x60:
309                 /* Subtract and trap on overflow. */
310                 res = op1 - op2;
311                 break;
312
313             default:
314                 goto not_interesting;
315             }
316         }
317         else if ((opcode & 0x37) == 0x25 && (badinst & (1<<11))) {
318             /* Add or subtract immediate. */
319             op1 = ((badinst >> 3) & 0xff) | ((-badinst&1)<<8);
320             r2 = (badinst >> 16) & 0x1f;
321             op2 = fixnum_value(*os_context_register_addr(context, r2));
322             t = (badinst >> 21) & 0x1f;
323             if (opcode == 0x2d)
324                 res = op1 + op2;
325             else
326                 res = op1 - op2;
327         }
328         else
329             goto not_interesting;
330         /* ?? What happens here if we hit the end of dynamic space? */
331         dynamic_space_free_pointer = (lispobj *) *os_context_register_addr(context, reg_ALLOC);
332         *os_context_register_addr(context, t) = alloc_number(res);
333         *os_context_register_addr(context, reg_ALLOC)
334             = (unsigned long) dynamic_space_free_pointer;
335         arch_skip_instruction(context);
336
337         break;
338 //#ifdef LINUX
339 //    case 0:
340 //#endif
341     case FPE_COND:
342         badinst = *(unsigned int *)(*os_context_pc_addr(context) & ~3);
343         if ((badinst&0xfffff800) == (0xb000e000|reg_ALLOC<<21|reg_ALLOC<<16)) {
344             /* It is an ADDIT,OD i,ALLOC,ALLOC instruction that trapped.
345              * That means that it is the end of a pseudo-atomic.  So do the
346              * add stripping off the pseudo-atomic-interrupted bit, and then
347              * tell the machine-independent code to process the pseudo-
348              * atomic. We cant skip the instruction because it holds
349              * extra-bytes that we must add to reg_alloc in context.
350              * It is so because we optimized away 'addi ,extra-bytes reg_alloc'
351              */
352             int immed = (badinst>>1)&0x3ff;
353             if (badinst & 1)
354                 immed |= -1<<10;
355             *os_context_register_addr(context, reg_ALLOC) += (immed-1);
356             arch_skip_instruction(context);
357             interrupt_handle_pending(context);
358             break;
359         }
360         /* else drop-through. */
361     default:
362     not_interesting:
363         interrupt_handle_now(signal, siginfo, context);
364     }
365 }
366
367 /* Merrily cut'n'pasted from sigfpe_handler.  On Linux, until
368    2.4.19-pa4 (hopefully), the overflow_trap wasn't implemented,
369    resulting in a SIGBUS instead. We adapt the sigfpe_handler here, in
370    the hope that it will do as a replacement until the new kernel sees
371    the light of day. Since the instructions that we need to fix up
372    tend not to be doing unaligned memory access, this should be a safe
373    workaround.  -- CSR, 2002-08-17 */
374 static void sigbus_handler(int signal, siginfo_t *siginfo,
375                            os_context_t *context)
376 {
377     unsigned int badinst;
378     int opcode, r1, r2, t;
379     long op1, op2, res;
380
381     badinst = *(unsigned int *)(*os_context_pc_addr(context) & ~3);
382     /* First, test for the pseudo-atomic instruction */
383     if ((badinst & 0xfffff800) == (0xb000e000 |
384                                    reg_ALLOC<<21 |
385                                    reg_ALLOC<<16)) {
386         /* It is an ADDIT,OD i,ALLOC,ALLOC instruction that trapped.
387            That means that it is the end of a pseudo-atomic.  So do
388            the add stripping off the pseudo-atomic-interrupted bit,
389            and then tell the machine-independent code to process the
390            pseudo-atomic. */
391         int immed = (badinst>>1) & 0x3ff;
392         if (badinst & 1)
393             immed |= -1<<10;
394         *os_context_register_addr(context, reg_ALLOC) += (immed-1);
395         arch_skip_instruction(context);
396         interrupt_handle_pending(context);
397         return;
398     } else {
399         opcode = badinst >> 26;
400         if (opcode == 2) {
401             /* reg/reg inst. */
402             r1 = (badinst >> 16) & 0x1f;
403             op1 = fixnum_value(*os_context_register_addr(context, r1));
404             r2 = (badinst >> 21) & 0x1f;
405             op2 = fixnum_value(*os_context_register_addr(context, r2));
406             t = badinst & 0x1f;
407
408             switch ((badinst >> 5) & 0x7f) {
409             case 0x70:
410                 /* Add and trap on overflow. */
411                 res = op1 + op2;
412                 break;
413
414             case 0x60:
415                 /* Subtract and trap on overflow. */
416                 res = op1 - op2;
417                 break;
418
419             default:
420                 goto not_interesting;
421             }
422         } else if ((opcode & 0x37) == 0x25 && (badinst & (1<<11))) {
423             /* Add or subtract immediate. */
424             op1 = ((badinst >> 3) & 0xff) | ((-badinst&1)<<8);
425             r2 = (badinst >> 16) & 0x1f;
426             op2 = fixnum_value(*os_context_register_addr(context, r2));
427             t = (badinst >> 21) & 0x1f;
428             if (opcode == 0x2d)
429                 res = op1 + op2;
430             else
431                 res = op1 - op2;
432         }
433         else
434             goto not_interesting;
435
436         /* ?? What happens here if we hit the end of dynamic space? */
437         dynamic_space_free_pointer = (lispobj *) *os_context_register_addr(context, reg_ALLOC);
438         *os_context_register_addr(context, t) = alloc_number(res);
439         *os_context_register_addr(context, reg_ALLOC)
440             = (unsigned long) dynamic_space_free_pointer;
441         arch_skip_instruction(context);
442
443         return;
444
445     not_interesting:
446         interrupt_handle_now(signal, siginfo, context);
447     }
448 }
449
450 static void
451 ignore_handler(int signal, siginfo_t *siginfo, os_context_t *context)
452 {
453 }
454
455 /* this routine installs interrupt handlers that will
456  * bypass the lisp interrupt handlers */
457 void arch_install_interrupt_handlers(void)
458 {
459     undoably_install_low_level_interrupt_handler(SIGTRAP,sigtrap_handler);
460     undoably_install_low_level_interrupt_handler(SIGILL,sigill_handler);
461     undoably_install_low_level_interrupt_handler(SIGFPE,sigfpe_handler);
462     /* FIXME: beyond 2.4.19-pa4 this shouldn't be necessary. */
463     undoably_install_low_level_interrupt_handler(SIGBUS,sigbus_handler);
464 #ifdef LISP_FEATURE_HPUX
465     undoably_install_low_level_interrupt_handler(SIGXCPU,ignore_handler);
466     undoably_install_low_level_interrupt_handler(SIGXFSZ,ignore_handler);
467 #endif
468 }