5a87f4c356ebd791d4a19e44a79c676474bbdc59
[projects/cmucl/cmucl.git] / src / lisp / hppa-arch.c
1 /*
2
3  $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/hppa-arch.c,v 1.10 2005/09/15 18:26:51 rtoy Rel $
4
5  This code was written as part of the CMU Common Lisp project at
6  Carnegie Mellon University, and has been placed in the public domain.
7
8 */
9
10 #include <stdio.h>
11 #include <machine/trap.h>
12
13 #include "lisp.h"
14 #include "globals.h"
15 #include "validate.h"
16 #include "os.h"
17 #include "arch.h"
18 #include "lispregs.h"
19 #include "signal.h"
20 #include "internals.h"
21 #include "breakpoint.h"
22
23 char *
24 arch_init(void)
25 {
26     return NULL;
27 }
28
29 os_vm_address_t
30 arch_get_bad_addr(int signal, int code, struct sigcontext * scp)
31 {
32 #ifdef hpux
33     struct save_state *state;
34     os_vm_address_t addr;
35
36     state = (struct save_state *) (&(scp->sc_sl.sl_ss));
37
38     if (state == NULL)
39         return NULL;
40
41     /* Check the instruction address first. */
42     addr = (os_vm_address_t) ((unsigned long) scp->sc_pcoq_head & ~3);
43     if (addr < (os_vm_address_t) 0x1000)
44         return addr;
45
46     /* Otherwise, it must have been a data fault. */
47     return (os_vm_address_t) state->ss_cr21;
48 #else
49     struct hp800_thread_state *state;
50     os_vm_address_t addr;
51
52     state = (struct hp800_thread_state *) (scp->sc_ap);
53
54     if (state == NULL)
55         return NULL;
56
57     /* Check the instruction address first. */
58     addr = scp->sc_pcoqh & ~3;
59     if (addr < 0x1000)
60         return addr;
61
62     /* Otherwise, it must have been a data fault. */
63     return state->cr21;
64 #endif
65 }
66
67 unsigned char *
68 arch_internal_error_arguments(struct sigcontext *scp)
69 {
70 #ifdef hpux
71     return (unsigned char *) ((scp->sc_pcoq_head & ~0x3) + 4);
72 #else
73     return (unsigned char *) ((scp->sc_pcoqh & ~0x3) + 4);
74 #endif
75 }
76
77 boolean
78 arch_pseudo_atomic_atomic(struct sigcontext *scp)
79 {
80     /* Pseudo-atomic-atomic is implemented by oring 0x4 into ALLOC. */
81
82     if (SC_REG(scp, reg_ALLOC) & 0x4)
83         return TRUE;
84     else
85         return FALSE;
86 }
87
88 void
89 arch_set_pseudo_atomic_interrupted(struct sigcontext *scp)
90 {
91     /* Pseudo-atomic-atomic is implemented by oring 0x1 into ALLOC. */
92
93     SC_REG(scp, reg_ALLOC) |= 1;
94 }
95
96 void
97 arch_skip_instruction(struct sigcontext *scp)
98 {
99     /* Skip the offending instruction */
100 #ifdef hpux
101     scp->sc_pcoq_head = scp->sc_pcoq_tail;
102     scp->sc_pcoq_tail += 4;
103 #else
104     scp->sc_pcoqh = scp->sc_pcoqt;
105     scp->sc_pcoqt += 4;
106 #endif
107 }
108
109 unsigned long
110 arch_install_breakpoint(void *pc)
111 {
112     unsigned long *ulpc = (unsigned long *) pc;
113     unsigned long orig_inst = *ulpc;
114
115     *ulpc = trap_Breakpoint;
116     os_flush_icache((os_vm_address_t) pc, sizeof(*ulpc));
117     return orig_inst;
118 }
119
120 void
121 arch_remove_breakpoint(void *pc, unsigned long orig_inst)
122 {
123     unsigned long *ulpc = (unsigned long *) pc;
124
125     *ulpc = orig_inst;
126     os_flush_icache((os_vm_address_t) pc, sizeof(*ulpc));
127 }
128
129 #ifdef hpux
130 extern void SingleStepTraps();
131 static unsigned long *BreakpointAddr = NULL;
132 static unsigned long NextPc = NULL;
133 #endif
134
135 void
136 arch_do_displaced_inst(struct sigcontext *scp, unsigned long orig_inst)
137 {
138 #ifdef hpux
139     /* We change the next-pc to point to a breakpoint instruction, restore */
140     /* the original instruction, and exit.  We would like to be able to */
141     /* sigreturn, but we can't, because this is hpux. */
142     unsigned long *pc = (unsigned long *) (SC_PC(scp) & ~3);
143
144     NextPc = SC_NPC(scp);
145     SC_NPC(scp) = (unsigned) SingleStepTraps | (SC_NPC(scp) & 3);
146
147     BreakpointAddr = pc;
148     *pc = orig_inst;
149     os_flush_icache((os_vm_address_t) pc, sizeof(unsigned long));
150 #else
151     /* We set the recovery counter to cover one instruction, put the */
152     /* original instruction back in, and then resume.  We will then trap */
153     /* after executing that one instruction, at which time we can put */
154     /* the breakpoint back in. */
155
156     ((struct hp800_thread_state *) scp->sc_ap)->cr0 = 1;
157     scp->sc_ps |= 0x10;
158     *(unsigned long *) SC_PC(scp) = orig_inst;
159
160     sigreturn(scp);
161 #endif
162 }
163
164 #ifdef hpux
165 static void
166 restore_breakpoint(struct sigcontext *scp)
167 {
168     /* We just single-stepped over an instruction that we want to replace */
169     /* with a breakpoint.  So we put the breakpoint back in, and tweek the */
170     /* state so that we will continue as if nothing happened. */
171
172     if (NextPc == NULL)
173         lose("SingleStepBreakpoint trap at strange time.");
174
175     if ((SC_PC(scp) & ~3) == (unsigned long) SingleStepTraps) {
176         /* The next instruction was not nullified. */
177         SC_PC(scp) = NextPc;
178         if ((SC_NPC(scp) & ~3) == (unsigned long) SingleStepTraps + 4) {
179             /* The instruction we just stepped over was not a branch, so */
180             /* we need to fix it up.  If it was a branch, it will point to */
181             /* the correct place. */
182             SC_NPC(scp) = NextPc + 4;
183         }
184     } else {
185         /* The next instruction was nullified, so we want to skip it. */
186         SC_PC(scp) = NextPc + 4;
187         SC_NPC(scp) = NextPc + 8;
188     }
189     NextPc = NULL;
190
191     if (BreakpointAddr) {
192         *BreakpointAddr = trap_Breakpoint;
193         os_flush_icache((os_vm_address_t) BreakpointAddr,
194
195                         sizeof(unsigned long));
196         BreakpointAddr = NULL;
197     }
198 }
199 #endif
200
201 static void
202 sigtrap_handler(int signal, int code, struct sigcontext *scp)
203 {
204     unsigned long bad_inst;
205
206     sigsetmask(scp->sc_mask);
207
208 #if 0
209     printf("sigtrap_handler, pc=0x%08x, alloc=0x%08x\n", scp->sc_pcoqh,
210            SC_REG(scp, reg_ALLOC));
211 #endif
212
213 #ifdef hpux
214     bad_inst = *(unsigned long *) (scp->sc_pcoq_head & ~3);
215 #else
216     bad_inst = *(unsigned long *) (scp->sc_pcoqh & ~3);
217 #endif
218
219     if (bad_inst & 0xfc001fe0)
220         interrupt_handle_now(signal, code, scp);
221     else {
222         int im5 = bad_inst & 0x1f;
223
224         switch (im5) {
225           case trap_Halt:
226               fake_foreign_function_call(scp);
227               lose("%%primitive halt called; the party is over.\n");
228
229           case trap_PendingInterrupt:
230               arch_skip_instruction(scp);
231               interrupt_handle_pending(scp);
232               break;
233
234           case trap_Error:
235           case trap_Cerror:
236               interrupt_internal_error(signal, code, scp, im5 == trap_Cerror);
237               break;
238
239           case trap_Breakpoint:
240               sigsetmask(scp->sc_mask);
241               handle_breakpoint(signal, code, scp);
242               break;
243
244           case trap_FunctionEndBreakpoint:
245               sigsetmask(scp->sc_mask);
246               {
247                   unsigned long pc;
248
249                   pc = (unsigned long)
250                       handle_function_end_breakpoint(signal, code, scp);
251 #ifdef hpux
252                   scp->sc_pcoq_head = pc;
253                   scp->sc_pcoq_tail = pc + 4;
254 #else
255                   scp->sc_pcoqh = pc;
256                   scp->sc_pcoqt = pc + 4;
257 #endif
258               }
259               break;
260
261           case trap_SingleStepBreakpoint:
262               restore_breakpoint(scp);
263               break;
264
265           default:
266               interrupt_handle_now(signal, code, scp);
267               break;
268         }
269     }
270 }
271
272 static void
273 sigfpe_handler(int signal, int code, struct sigcontext *scp)
274 {
275     unsigned long badinst;
276     int opcode, r1, r2, t;
277     long op1, op2, res;
278
279 #if 0
280     printf("sigfpe_handler, pc=0x%08x, alloc=0x%08x\n", scp->sc_pcoqh,
281            SC_REG(scp, reg_ALLOC));
282 #endif
283
284     switch (code) {
285       case I_OVFLO:
286           badinst = *(unsigned long *) (SC_PC(scp) & ~3);
287           opcode = badinst >> 26;
288
289           if (opcode == 2) {
290               /* reg/reg inst. */
291               r1 = (badinst >> 16) & 0x1f;
292               op1 = fixnum_value(SC_REG(scp, r1));
293               r2 = (badinst >> 21) & 0x1f;
294               op2 = fixnum_value(SC_REG(scp, r2));
295               t = badinst & 0x1f;
296
297               switch ((badinst >> 5) & 0x7f) {
298                 case 0x70:
299                     /* Add and trap on overflow. */
300                     res = op1 + op2;
301                     break;
302
303                 case 0x60:
304                     /* Subtract and trap on overflow. */
305                     res = op1 - op2;
306                     break;
307
308                 default:
309                     goto not_interesting;
310               }
311           } else if ((opcode & 0x37) == 0x25 && (badinst & (1 << 11))) {
312               /* Add or subtract immediate. */
313               op1 = ((badinst >> 3) & 0xff) | ((-badinst & 1) << 8);
314               r2 = (badinst >> 16) & 0x1f;
315               op2 = fixnum_value(SC_REG(scp, r1));
316               t = (badinst >> 21) & 0x1f;
317               if (opcode == 0x2d)
318                   res = op1 + op2;
319               else
320                   res = op1 - op2;
321           } else
322               goto not_interesting;
323
324           current_dynamic_space_free_pointer =
325               (lispobj *) SC_REG(scp, reg_ALLOC);
326           SC_REG(scp, t) = alloc_number(res);
327           SC_REG(scp, reg_ALLOC)
328               = (unsigned long) current_dynamic_space_free_pointer;
329           arch_skip_instruction(scp);
330
331           break;
332
333       case I_COND:
334           badinst = *(unsigned long *) (SC_PC(scp) & ~3);
335           if ((badinst & 0xfffff800) ==
336               (0xb000e000 | reg_ALLOC << 21 | reg_ALLOC << 16)) {
337               /* It is an ADDIT,OD i,ALLOC,ALLOC instruction that trapped. */
338               /* That means that it is the end of a pseudo-atomic.  So do the */
339               /* add stripping off the pseudo-atomic-interrupted bit, and then */
340               /* tell the machine-independent code to process the pseudo- */
341               /* atomic. */
342               int immed = (badinst >> 1) & 0x3ff;
343
344               if (badinst & 1)
345                   immed |= -1 << 10;
346               SC_REG(scp, reg_ALLOC) += (immed - 1);
347               arch_skip_instruction(scp);
348               interrupt_handle_pending(scp);
349               break;
350           }
351           /* else drop-through. */
352       default:
353         not_interesting:
354           interrupt_handle_now(signal, code, scp);
355     }
356 }
357
358 void
359 arch_install_interrupt_handlers(void)
360 {
361 #ifdef hpux
362     interrupt_install_low_level_handler(SIGILL, sigtrap_handler);
363 #endif
364     interrupt_install_low_level_handler(SIGTRAP, sigtrap_handler);
365     interrupt_install_low_level_handler(SIGFPE, sigfpe_handler);
366 }
367
368 lispobj
369 funcall0(lispobj function)
370 {
371     lispobj *args = current_control_stack_pointer;
372
373     return call_into_lisp(function, args, 0);
374 }
375
376 lispobj
377 funcall1(lispobj function, lispobj arg0)
378 {
379     lispobj *args = current_control_stack_pointer;
380
381     current_control_stack_pointer += 1;
382     args[0] = arg0;
383
384     return call_into_lisp(function, args, 1);
385 }
386
387 lispobj
388 funcall2(lispobj function, lispobj arg0, lispobj arg1)
389 {
390     lispobj *args = current_control_stack_pointer;
391
392     current_control_stack_pointer += 2;
393     args[0] = arg0;
394     args[1] = arg1;
395
396     return call_into_lisp(function, args, 2);
397 }
398
399 lispobj
400 funcall3(lispobj function, lispobj arg0, lispobj arg1, lispobj arg2)
401 {
402     lispobj *args = current_control_stack_pointer;
403
404     current_control_stack_pointer += 3;
405     args[0] = arg0;
406     args[1] = arg1;
407     args[2] = arg2;
408
409     return call_into_lisp(function, args, 3);
410 }