Commit c4f89427 authored by wlott's avatar wlott
Browse files

Initial revision

parent 79f4d9b8
#include <stdio.h>
#include <mach.h>
#include <machine/trap.h>
#include "lisp.h"
#include "globals.h"
#include "validate.h"
#include "os.h"
#include "arch.h"
#include "lispregs.h"
#include "signal.h"
#include "internals.h"
#include "breakpoint.h"
char *arch_init(void)
{
return NULL;
}
os_vm_address_t arch_get_bad_addr(struct sigcontext *scp)
{
struct hp800_thread_state *state;
os_vm_address_t addr;
state = (struct hp800_thread_state *)(scp->sc_ap);
if (state == NULL)
return NULL;
/* Check the instruction address first. */
addr = scp->sc_pcoqh & ~3;
if (addr < 0x1000)
return addr;
/* Otherwise, it must have been a data fault. */
return state->cr21;
}
unsigned char *arch_internal_error_arguments(struct sigcontext *scp)
{
return (unsigned char *)((scp->sc_pcoqh&~0x3)+4);
}
boolean arch_pseudo_atomic_atomic(struct sigcontext *scp)
{
/* Pseudo-atomic-atomic is implemented by oring 0x4 into ALLOC. */
if (SC_REG(scp, reg_ALLOC) & 0x4)
return TRUE;
else
return FALSE;
}
void arch_set_pseudo_atomic_interrupted(struct sigcontext *scp)
{
/* Pseudo-atomic-atomic is implemented by oring 0x1 into ALLOC. */
SC_REG(scp, reg_ALLOC) |= 1;
}
void arch_skip_instruction(struct sigcontext *scp)
{
/* Skip the offending instruction */
scp->sc_pcoqh = scp->sc_pcoqt;
scp->sc_pcoqt += 4;
}
unsigned long arch_install_breakpoint(void *pc)
{
unsigned long *ulpc = (unsigned long *)pc;
unsigned long orig_inst = *ulpc;
*ulpc = trap_Breakpoint;
return orig_inst;
}
void arch_remove_breakpoint(void *pc, unsigned long orig_inst)
{
unsigned long *ulpc = (unsigned long *)pc;
*ulpc = orig_inst;
}
void arch_do_displaced_inst(struct sigcontext *scp, unsigned long orig_inst)
{
/* We set the recovery counter to cover one instruction, put the */
/* original instruction back in, and then resume. We will then trap */
/* after executing that one instruction, at which time we can put */
/* the breakpoint back in. */
((struct hp800_thread_state *)scp->sc_ap)->cr0 = 1;
scp->sc_ps |= 0x10;
*(unsigned long *)SC_PC(scp) = orig_inst;
undo_fake_foreign_function_call(scp);
sigreturn(scp);
}
static void sigtrap_handler(int signal, int code, struct sigcontext *scp)
{
unsigned long bad_inst;
sigsetmask(scp->sc_mask);
printf("sigtrap_handler, pc=0x%08x\n", scp->sc_pcoqh);
bad_inst = *(unsigned long *)(scp->sc_pcoqh & ~3);
if (bad_inst & 0xfc001fe0)
interrupt_handle_now(signal, code, scp);
else {
int im5 = bad_inst & 0x1f;
switch (im5) {
case trap_Halt:
fake_foreign_function_call(scp);
lose("%%primitive halt called; the party is over.\n");
case trap_Error:
case trap_Cerror:
interrupt_internal_error(signal, code, scp, im5==trap_Cerror);
break;
case trap_Breakpoint:
sigsetmask(scp->sc_mask);
fake_foreign_function_call(scp);
handle_breakpoint(signal, code, scp);
undo_fake_foreign_function_call(scp);
break;
case trap_FunctionEndBreakpoint:
sigsetmask(scp->sc_mask);
fake_foreign_function_call(scp);
{
void *pc;
pc = handle_function_end_breakpoint(signal, code, scp);
scp->sc_pcoqh = (unsigned long)pc;
scp->sc_pcoqt = (unsigned long)pc + 4;
}
undo_fake_foreign_function_call(scp);
break;
default:
interrupt_handle_now(signal, code, scp);
break;
}
}
}
static void sigfpe_handler(int signal, int code, struct sigcontext *scp)
{
if (code == I_OVFLO) {
unsigned long badinst = *(unsigned long *)(SC_PC(scp)&~3);
int opcode = badinst >> 26;
int r1, r2, t;
long op1, op2, res;
if (opcode == 2) {
/* reg/reg inst. */
r1 = (badinst >> 16) & 0x1f;
op1 = fixnum_value(SC_REG(scp, r1));
r2 = (badinst >> 21) & 0x1f;
op2 = fixnum_value(SC_REG(scp, r2));
t = badinst & 0x1f;
switch ((badinst >> 5) & 0x7f) {
case 0x70:
/* Add and trap on overflow. */
res = op1 + op2;
break;
case 0x60:
/* Subtract and trap on overflow. */
res = op1 - op2;
break;
default:
goto not_interesting;
}
}
else if ((opcode & 0x37) == 0x25 && (badinst & (1<<11))) {
/* Add or subtract immediate. */
op1 = ((badinst >> 3) & 0xff) | ((-badinst&1)<<8);
r2 = (badinst >> 16) & 0x1f;
op2 = fixnum_value(SC_REG(scp, r1));
t = (badinst >> 21) & 0x1f;
if (opcode == 0x2d)
res = op1 + op2;
else
res = op1 - op2;
}
else
goto not_interesting;
current_dynamic_space_free_pointer = (lispobj *)SC_REG(scp, reg_ALLOC);
SC_REG(scp, t) = alloc_number(res);
SC_REG(scp, reg_ALLOC)
= (unsigned long)current_dynamic_space_free_pointer;
arch_skip_instruction(scp);
}
else
not_interesting:
interrupt_handle_now(signal, code, scp);
}
void arch_install_interrupt_handlers(void)
{
interrupt_install_low_level_handler(SIGTRAP,sigtrap_handler);
interrupt_install_low_level_handler(SIGFPE,sigfpe_handler);
}
lispobj funcall0(lispobj function)
{
lispobj *args = current_control_stack_pointer;
return call_into_lisp(function, args, 0);
}
lispobj funcall1(lispobj function, lispobj arg0)
{
lispobj *args = current_control_stack_pointer;
current_control_stack_pointer += 1;
args[0] = arg0;
return call_into_lisp(function, args, 1);
}
lispobj funcall2(lispobj function, lispobj arg0, lispobj arg1)
{
lispobj *args = current_control_stack_pointer;
current_control_stack_pointer += 2;
args[0] = arg0;
args[1] = arg1;
return call_into_lisp(function, args, 2);
}
lispobj funcall3(lispobj function, lispobj arg0, lispobj arg1, lispobj arg2)
{
lispobj *args = current_control_stack_pointer;
current_control_stack_pointer += 3;
args[0] = arg0;
args[1] = arg1;
args[2] = arg2;
return call_into_lisp(function, args, 3);
}
#define LANGUAGE_ASSEMBLY
#include <machine/asm.h>
#include "internals.h"
#include "lispregs.h"
.import $global$,data
.import foreign_function_call_active,data
.import current_control_stack_pointer,data
.import current_control_frame_pointer,data
.import current_binding_stack_pointer,data
.import current_dynamic_space_free_pointer,data
.space $TEXT$
.subspa $CODE$
/*
* Call-into-lisp
*/
.export call_into_lisp
call_into_lisp
.proc
.callinfo entry_gr=18,save_rp
.enter
/* arg0=function, arg1=cfp, arg2=nargs */
/* Clear the descriptor regs, moving in args as approporate. */
copy r0,reg_CODE
copy r0,reg_FDEFN
copy arg0,reg_LEXENV
zdep arg2,29,30,reg_NARGS
copy r0,reg_OCFP
copy r0,reg_LRA
copy r0,reg_A0
copy r0,reg_A1
copy r0,reg_A2
copy r0,reg_A3
copy r0,reg_A4
copy r0,reg_A5
copy r0,reg_L0
copy r0,reg_L1
copy r0,reg_L2
/* Establish NIL. */
ldil L%NIL,reg_NULL
ldo R%NIL(reg_NULL),reg_NULL
/* Turn on pseudo-atomic. */
ldo 4(r0),reg_ALLOC
/* No longer in foreign function call land. */
addil L%foreign_function_call_active-$global$,dp
stw r0,R%foreign_function_call_active-$global$(0,r1)
/* Load lisp state. */
addil L%current_dynamic_space_free_pointer-$global$,dp
ldw R%current_dynamic_space_free_pointer-$global$(0,r1),r1
add reg_ALLOC,r1,reg_ALLOC
addil L%current_binding_stack_pointer-$global$,dp
ldw R%current_binding_stack_pointer-$global$(0,r1),reg_BSP
addil L%current_control_stack_pointer-$global$,dp
ldw R%current_control_stack_pointer-$global$(0,r1),reg_CSP
addil L%current_control_frame_pointer-$global$,dp
ldw R%current_control_frame_pointer-$global$(0,r1),reg_OCFP
copy arg1,reg_CFP
/* End of pseudo-atomic. */
addit,od -4,reg_ALLOC,reg_ALLOC
/* Establish lisp arguments. */
ldw 0(reg_CFP),reg_A0
ldw 4(reg_CFP),reg_A1
ldw 8(reg_CFP),reg_A2
ldw 12(reg_CFP),reg_A3
ldw 16(reg_CFP),reg_A4
ldw 20(reg_CFP),reg_A5
/* Calculate the LRA. */
ldil L%lra+type_OtherPointer,reg_LRA
ldo R%lra+type_OtherPointer(reg_LRA),reg_LRA
/* Indirect the closure */
ldw CLOSURE_FUNCTION_OFFSET(0,reg_LEXENV),reg_CODE
addi 6*4-type_FunctionPointer,reg_CODE,reg_LIP
/* And into lisp we go. */
.export break_here
break_here
be,n 0(sr4,reg_LIP)
.align 8
lra
.word type_ReturnPcHeader
copy reg_OCFP,reg_CSP
/* Copy CFP (r4) into someplace else and restore r4. */
copy reg_CFP,reg_NL1
ldw -64(0,sp),r4
/* Copy the return value. */
copy reg_A0,ret0
/* Turn on pseudo-atomic. */
addi 4,reg_ALLOC,reg_ALLOC
/* Store the lisp state. */
copy reg_ALLOC,reg_NL0
depi 0,31,3,reg_NL0
addil L%current_dynamic_space_free_pointer-$global$,dp
stw reg_NL0,R%current_dynamic_space_free_pointer-$global$(0,r1)
addil L%current_binding_stack_pointer-$global$,dp
stw reg_BSP,R%current_binding_stack_pointer-$global$(0,r1)
addil L%current_control_stack_pointer-$global$,dp
stw reg_CSP,R%current_control_stack_pointer-$global$(0,r1)
addil L%current_control_frame_pointer-$global$,dp
stw reg_NL1,R%current_control_frame_pointer-$global$(0,r1)
/* Back in C land. [CSP is just a handy non-zero value.] */
addil L%foreign_function_call_active-$global$,dp
stw reg_CSP,R%foreign_function_call_active-$global$(0,r1)
/* Turn off pseudo-atomic and check for traps. */
addit,od -4,reg_ALLOC,reg_ALLOC
/* And thats all. */
.leave
.procend
/*
* Call-into-C
*/
.export call_into_c
call_into_c
/* Set up a lisp stack frame. Note: we convert the raw return pc into
* a fixnum pc-offset because we don't have ahold of an lra object.
*/
copy reg_CFP, reg_OCFP
copy reg_CSP, reg_CFP
addi 32, reg_CSP, reg_CSP
stw reg_OCFP, 0(0,reg_CFP)
sub reg_LIP, reg_CODE, reg_NL5
addi 3-type_OtherPointer, reg_NL5, reg_NL5
stw reg_NL5, 4(0,reg_CFP)
stw reg_CODE, 8(0,reg_CFP)
/* Turn on pseudo-atomic. */
addi 4, reg_ALLOC, reg_ALLOC
/* Store the lisp state. */
copy reg_ALLOC,reg_NL5
depi 0,31,3,reg_NL5
addil L%current_dynamic_space_free_pointer-$global$,dp
stw reg_NL5,R%current_dynamic_space_free_pointer-$global$(0,r1)
addil L%current_binding_stack_pointer-$global$,dp
stw reg_BSP,R%current_binding_stack_pointer-$global$(0,r1)
addil L%current_control_stack_pointer-$global$,dp
stw reg_CSP,R%current_control_stack_pointer-$global$(0,r1)
addil L%current_control_frame_pointer-$global$,dp
stw reg_CFP,R%current_control_frame_pointer-$global$(0,r1)
/* Back in C land. [CSP is just a handy non-zero value.] */
addil L%foreign_function_call_active-$global$,dp
stw reg_CSP,R%foreign_function_call_active-$global$(0,r1)
/* Turn off pseudo-atomic and check for traps. */
addit,od -4,reg_ALLOC,reg_ALLOC
/* Now we can call the C function. */
ble 0(4,reg_CFUNC)
copy r31, r2
/* Clear the callee saves descriptor regs. */
copy r0, reg_A5
copy r0, reg_L0
copy r0, reg_L1
copy r0, reg_L2
/* Turn on pseudo-atomic. */
ldi 4, reg_ALLOC
/* Turn off foreign function call. */
addil L%foreign_function_call_active-$global$,dp
stw r0,R%foreign_function_call_active-$global$(0,r1)
/* Load ALLOC. */
addil L%current_dynamic_space_free_pointer-$global$,dp
ldw R%current_dynamic_space_free_pointer-$global$(0,r1),r1
add reg_ALLOC,r1,reg_ALLOC
/* We don't need to load OCFP, CFP, CSP, or BSP because they are
* in caller saves registers.
*/
/* End of pseudo-atomic. */
addit,od -4,reg_ALLOC,reg_ALLOC
/* Restore CODE. Even though it is in a callee saves register
* it might have been GC'ed.
*/
ldw 8(0,reg_CFP), reg_CODE
/* Restore the return pc. */
ldw 4(0,reg_CFP), reg_NL0
addi type_OtherPointer-3, reg_NL0, reg_NL0
add reg_CODE, reg_NL0, reg_LIP
/* Pop the lisp stack frame, and back we go. */
copy reg_CFP, reg_CSP
be 0(4,reg_LIP)
copy reg_OCFP, reg_CFP
/*
* Trampolines.
*/
.EXPORT closure_tramp
closure_tramp
/* reg_FDEFN holds the fdefn object. */
ldw FDEFN_FUNCTION_OFFSET(0,reg_FDEFN),reg_LEXENV
ldw CLOSURE_FUNCTION_OFFSET(0,reg_LEXENV),reg_L0
addi FUNCTION_HEADER_CODE_OFFSET, reg_L0, reg_LIP
bv,n 0(reg_LIP)
.EXPORT undefined_tramp
undefined_tramp
break trap_Error,0
.byte 4
.byte 23
.byte 254
.byte 46
.byte 1
.align 4
/*
* Core saving/restoring support
*/
.export call_on_stack
call_on_stack
/* arg0 = fn to invoke, arg1 = new stack base */
/* Compute the new stack pointer. */
addi 64,arg1,sp
/* Zero out the previous stack pointer. */
stw r0,-4(0,sp)
/* Invoke the function. */
ble 0(4,arg0)
copy r31, r2
/* Flame out. */
break 0,0
.export save_state
save_state
.proc
.callinfo entry_gr=18,entry_fr=21,save_rp,calls
.enter
/* Remember the function we want to invoke */
copy arg0,r19
/* Pass the new stack pointer in as arg0 */
copy sp,arg0
/* Leave arg1 as arg1. */
/* do the call. */
ble 0(4,r19)
copy r31, r2
_restore_state
.leave
.procend
.export restore_state
restore_state
.proc
.callinfo
copy arg0,sp
b _restore_state
copy arg1,ret0
.procend
#define LANGUAGE_ASSEMBLY
#include <machine/asm.h>
#include "internals.h"
#include "lispregs.h"
.import $global$,data
.import foreign_function_call_active,data
.import current_control_stack_pointer,data
.import current_control_frame_pointer,data
.import current_binding_stack_pointer,data
.import current_dynamic_space_free_pointer,data
.space $TEXT$
.subspa $CODE$
/*
* Call-into-lisp
*/
.export call_into_lisp
call_into_lisp
.proc
.callinfo entry_gr=18,save_rp
.enter
/* arg0=function, arg1=cfp, arg2=nargs */
/* Clear the descriptor regs, moving in args as approporate. */
copy r0,reg_CODE
copy r0,reg_FDEFN
copy arg0,reg_LEXENV
zdep arg2,29,30,reg_NARGS
copy r0,reg_OCFP
copy r0,reg_LRA
copy r0,reg_A0
copy r0,reg_A1
copy r0,reg_A2
copy r0,reg_A3
copy r0,reg_A4
copy r0,reg_A5
copy r0,reg_L0
copy r0,reg_L1
copy r0,reg_L2
/* Establish NIL. */
ldil L%NIL,reg_NULL
ldo R%NIL(reg_NULL),reg_NULL
/* Turn on pseudo-atomic. */
ldo 4(r0),reg_ALLOC
/* No longer in foreign function call land. */
addil L%foreign_function_call_active-$global$,dp
stw r0,R%foreign_function_call_active-$global$(0,r1)
/* Load lisp state. */
addil L%current_dynamic_space_free_pointer-$global$,dp
ldw R%current_dynamic_space_free_pointer-$global$(0,r1),r1
add reg_ALLOC,r1,reg_ALLOC
addil L%current_binding_stack_pointer-$global$,dp
ldw R%current_binding_stack_pointer-$global$(0,r1),reg_BSP
addil L%current_control_stack_pointer-$global$,dp
ldw R%current_control_stack_pointer-$global$(0,r1),reg_CSP
addil L%current_control_frame_pointer-$global$,dp
ldw R%current_control_frame_pointer-$global$(0,r1),reg_OCFP
copy arg1,reg_CFP
/* End of pseudo-atomic. */
addit,od -4,reg_ALLOC,reg_ALLOC
/* Establish lisp arguments. */
ldw 0(reg_CFP),reg_A0
ldw 4(reg_CFP),reg_A1