Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
cmucl
cmucl
Commits
c4f89427
Commit
c4f89427
authored
Sep 04, 1992
by
wlott
Browse files
Initial revision
parent
79f4d9b8
Changes
5
Hide whitespace changes
Inline
Side-by-side
lisp/hppa-arch.c
0 → 100644
View file @
c4f89427
#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
);
}
lisp/hppa-assem.S
0 → 100644
View file @
c4f89427
#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
lisp/hppa-assem.s
0 → 100644
View file @
c4f89427
#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