Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Carl Shapiro
cmucl
Commits
dfe07e37
Commit
dfe07e37
authored
32 years ago
by
hallgren
Browse files
Options
Downloads
Patches
Plain Diff
Insts file with most of the new disassembler working.
parent
b67b6930
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
compiler/sparc/insts.lisp
+327
-61
327 additions, 61 deletions
compiler/sparc/insts.lisp
with
327 additions
and
61 deletions
compiler/sparc/insts.lisp
+
327
−
61
View file @
dfe07e37
...
@@ -7,7 +7,7 @@
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
;;;
(
ext:file-comment
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/insts.lisp,v 1.
9
1992/07/
09
1
9
:46:
32
hallgren Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/insts.lisp,v 1.
10
1992/07/
23
1
7
:46:
06
hallgren Exp $"
)
;;;
;;;
;;; **********************************************************************
;;; **********************************************************************
;;;
;;;
...
@@ -15,9 +15,6 @@
...
@@ -15,9 +15,6 @@
;;;
;;;
;;; Written by William Lott.
;;; Written by William Lott.
;;;
;;;
;;; Converted to the SPARC by Sean Hallgren.
;;;
(
in-package
"SPARC"
)
(
in-package
"SPARC"
)
(
use-package
"NEW-ASSEM"
)
(
use-package
"NEW-ASSEM"
)
...
@@ -28,7 +25,7 @@
...
@@ -28,7 +25,7 @@
:scheduler-p
nil
)
:scheduler-p
nil
)
;;;;
Functions to convert TN's and random symbolic things into values
.
;;;;
Constants, types, conversion functions, some disassembler stuff
.
(
defun
reg-tn-encoding
(
tn
)
(
defun
reg-tn-encoding
(
tn
)
(
declare
(
type
tn
tn
))
(
declare
(
type
tn
tn
))
...
@@ -48,9 +45,63 @@
...
@@ -48,9 +45,63 @@
(
1+
(
tn-offset
tn
))
(
1+
(
tn-offset
tn
))
(
tn-offset
tn
)))
(
tn-offset
tn
)))
(
disassem:set-disassem-params
:instruction-alignment
32
)
(
defvar
*disassem-use-lisp-reg-names*
t
)
(
defconstant
reg-symbols
(
map
'vector
#'
(
lambda
(
name
)
(
cond
((
null
name
)
nil
)
(
t
(
make-symbol
(
concatenate
'string
"%"
name
)))))
sparc::*register-names*
))
(
disassem:define-argument-type
reg
:printer
#'
(
lambda
(
value
stream
dstate
)
(
declare
(
stream
stream
)
(
fixnum
value
))
(
let
((
regname
(
aref
reg-symbols
value
)))
(
princ
regname
stream
)
(
disassem:maybe-note-associated-storage-ref
value
'registers
regname
dstate
))))
(
defconstant
float-reg-symbols
(
coerce
(
loop
for
n
from
0
to
31
collect
(
make-symbol
(
format
nil
"%F~d"
n
)))
'vector
))
(
disassem:define-argument-type
fp-reg
:printer
#'
(
lambda
(
value
stream
dstate
)
(
declare
(
stream
stream
)
(
fixnum
value
))
(
let
((
regname
(
aref
float-reg-symbols
value
)))
(
princ
regname
stream
)
(
disassem:maybe-note-associated-storage-ref
value
'float-registers
regname
dstate
))))
(
disassem:define-argument-type
relative-label
:sign-extend
t
:use-label
#'
(
lambda
(
value
dstate
)
(
declare
(
type
(
signed-byte
13
)
value
)
(
type
disassem:disassem-state
dstate
))
(
+
(
ash
value
2
)
(
disassem:dstate-cur-addr
dstate
))))
(
defconstant
branch-conditions
(
defconstant
branch-conditions
'
(
:f
:eq
:le
:lt
:leu
:ltu
:n
:vs
:t
:ne
:gt
:ge
:gtu
:geu
:p
:vc
))
'
(
:f
:eq
:le
:lt
:leu
:ltu
:n
:vs
:t
:ne
:gt
:ge
:gtu
:geu
:p
:vc
))
;;; Note that these aren't the standard names for branch-conditions, I think
;;; they're a bit more readable (e.g., "eq" instead of "e"). You could just
;;; put a vector of the normal ones here too.
(
defconstant
branch-cond-name-vec
(
coerce
branch-conditions
'vector
))
(
disassem:define-argument-type
branch-condition
:printer
branch-cond-name-vec
)
(
deftype
branch-condition
()
(
deftype
branch-condition
()
`
(
member
,@
branch-conditions
))
`
(
member
,@
branch-conditions
))
...
@@ -59,16 +110,100 @@
...
@@ -59,16 +110,100 @@
(
error
"Unknown branch condition: ~S~%Must be one of: ~S"
(
error
"Unknown branch condition: ~S~%Must be one of: ~S"
condition
branch-conditions
)))
condition
branch-conditions
)))
(
defconstant
fp-branch-conditions
(
defconstant
branch-cond-true
#b1000
)
(
defconstant
branch-fp-conditions
'
(
:f
:ne
:lg
:ul
:l
:ug
:g
:u
:t
:eq
:ue
:ge
:uge
:le
:ule
:o
))
'
(
:f
:ne
:lg
:ul
:l
:ug
:g
:u
:t
:eq
:ue
:ge
:uge
:le
:ule
:o
))
(
defconstant
branch-fp-cond-name-vec
(
coerce
branch-fp-conditions
'vector
))
(
disassem:define-argument-type
branch-fp-condition
:printer
branch-fp-cond-name-vec
)
(
disassem:define-argument-type
call-fixup
:use-label
t
)
(
deftype
fp-branch-condition
()
(
deftype
fp-branch-condition
()
`
(
member
,@
fp-
branch-conditions
))
`
(
member
,@
branch-
fp-
conditions
))
(
defun
fp-branch-condition
(
condition
)
(
defun
fp-branch-condition
(
condition
)
(
or
(
position
condition
fp-
branch-conditions
)
(
or
(
position
condition
branch-
fp-
conditions
)
(
error
"Unknown fp-branch condition: ~S~%Must be one of: ~S"
(
error
"Unknown fp-branch condition: ~S~%Must be one of: ~S"
condition
fp-branch-conditions
)))
condition
branch-fp-conditions
)))
;;;; dissassem:define-instruction-formats
(
disassem:define-instruction-format
(
format-1
32
:default-printer
'
(
:name
:tab
disp
))
(
op
:field
(
byte
2
30
)
:value
1
)
(
disp
:field
(
byte
30
0
)))
(
disassem:define-instruction-format
(
format-2-immed
32
:default-printer
'
(
:name
:tab
immed
", "
rd
))
(
op
:field
(
byte
2
30
)
:value
0
)
(
rd
:field
(
byte
5
25
)
:type
'reg
)
(
op2
:field
(
byte
3
22
))
(
immed
:field
(
byte
22
0
)))
(
defconstant
branch-printer
`
(
:name
(
:unless
(
:constant
,
branch-cond-true
)
cond
)
(
:unless
(
a
:constant
0
)
","
'A
)
:tab
disp
))
(
disassem:define-instruction-format
(
format-2-branch
32
:default-printer
branch-printer
)
(
op
:field
(
byte
2
30
)
:value
0
)
(
a
:field
(
byte
1
29
)
:value
0
)
(
cond
:field
(
byte
4
25
)
:type
'branch-condition
)
(
op2
:field
(
byte
3
22
))
(
disp
:field
(
byte
22
0
)
:type
'relative-label
))
(
disassem:define-instruction-format
(
format-2-unimp
32
:default-printer
'
(
:name
:tab
data
))
(
op
:field
(
byte
2
30
)
:value
0
)
(
ignore
:field
(
byte
5
25
)
:value
0
)
(
op2
:field
(
byte
3
22
)
:value
0
)
(
data
:field
(
byte
22
0
)))
(
defconstant
f3-printer
'
(
:name
:tab
(
:unless
(
:same-as
rd
)
rs1
", "
)
(
:choose
rs2
immed
)
", "
rd
))
(
disassem:define-instruction-format
(
format-3-reg
32
:default-printer
f3-printer
)
(
op
:field
(
byte
2
30
))
(
rd
:field
(
byte
5
25
)
:type
'reg
)
(
op3
:field
(
byte
6
19
))
(
rs1
:field
(
byte
5
14
)
:type
'reg
)
(
i
:field
(
byte
1
13
)
:value
0
)
(
asi
:field
(
byte
8
5
)
:value
0
)
(
rs2
:field
(
byte
5
0
)
:type
'reg
))
(
disassem:define-instruction-format
(
format-3-immed
32
:default-printer
f3-printer
)
(
op
:field
(
byte
2
30
))
(
rd
:field
(
byte
5
25
)
:type
'reg
)
(
op3
:field
(
byte
6
19
))
(
rs1
:field
(
byte
5
14
)
:type
'reg
)
(
i
:field
(
byte
1
13
)
:value
1
)
(
immed
:field
(
byte
13
0
)
:sign-extend
t
))
; usually sign extended
(
disassem:define-instruction-format
(
format-3-fpop
32
:default-printer
'
(
:name
:tab
(
:unless
(
:same-as
rd
)
rs1
", "
)
rs2
", "
rd
))
(
op
:field
(
byte
2
30
))
(
rd
:field
(
byte
5
25
)
:type
'fp-reg
)
(
op3
:field
(
byte
6
19
))
(
rs1
:field
(
byte
5
14
)
:type
'fp-reg
)
(
opf
:field
(
byte
9
5
))
(
rs2
:field
(
byte
5
0
)
:type
'fp-reg
))
;;;; Primitive emitters.
;;;; Primitive emitters.
...
@@ -98,37 +233,15 @@
...
@@ -98,37 +233,15 @@
(
define-emitter
emit-format-3-immed
32
(
define-emitter
emit-format-3-immed
32
(
byte
2
30
)
(
byte
5
25
)
(
byte
6
19
)
(
byte
5
14
)
(
byte
1
13
)
(
byte
13
0
))
(
byte
2
30
)
(
byte
5
25
)
(
byte
6
19
)
(
byte
5
14
)
(
byte
1
13
)
(
byte
13
0
))
(
define-emitter
emit-format-3-fpop
32
(
define-emitter
emit-format-3-fpop
32
(
byte
2
30
)
(
byte
5
25
)
(
byte
6
19
)
(
byte
5
14
)
(
byte
9
5
)
(
byte
5
0
))
(
byte
2
30
)
(
byte
5
25
)
(
byte
6
19
)
(
byte
5
14
)
(
byte
9
5
)
(
byte
5
0
))
;;;; Buncha format-3-instructions.
;;;; Most of the format-3-instructions.
(
defun
emit-format-3-inst
(
segment
op
op3
dst
src1
src2
&key
load-store
fixup
)
(
unless
src2
(
cond
((
and
(
typep
src1
'tn
)
load-store
)
(
setf
src2
0
))
(
t
(
setf
src2
src1
)
(
setf
src1
dst
))))
(
etypecase
src2
(
tn
(
emit-format-3-reg
segment
op
(
reg-tn-encoding
dst
)
op3
(
reg-tn-encoding
src1
)
0
0
(
reg-tn-encoding
src2
)))
(
integer
(
emit-format-3-immed
segment
op
(
reg-tn-encoding
dst
)
op3
(
reg-tn-encoding
src1
)
1
src2
))
(
fixup
(
unless
(
or
load-store
fixup
)
(
error
"Fixups aren't allowed."
))
(
note-fixup
segment
:add
src2
)
(
emit-format-3-immed
segment
op
(
reg-tn-encoding
dst
)
op3
(
reg-tn-encoding
src1
)
1
0
))))
(
defun
emit-
fp-
format-3-inst
(
segment
op
op3
dst
src1
src2
(
defun
emit-format-3-inst
(
segment
op
op3
dst
src1
src2
&key
load-store
fixup
odd
)
&key
load-store
fixup
dest-kind
odd
)
(
unless
src2
(
unless
src2
(
cond
((
and
(
typep
src1
'tn
)
load-store
)
(
cond
((
and
(
typep
src1
'tn
)
load-store
)
(
setf
src2
0
))
(
setf
src2
0
))
...
@@ -137,36 +250,70 @@
...
@@ -137,36 +250,70 @@
(
setf
src1
dst
))))
(
setf
src1
dst
))))
(
etypecase
src2
(
etypecase
src2
(
tn
(
tn
(
emit-format-3-reg
segment
op
(
fp-reg-tn-encoding
dst
odd
)
op3
(
emit-format-3-reg
segment
op
(
reg-tn-encoding
src1
)
0
0
(
if
dest-kind
(
reg-tn-encoding
src2
)))
(
fp-reg-tn-encoding
dst
odd
)
(
reg-tn-encoding
dst
))
op3
(
reg-tn-encoding
src1
)
0
0
(
reg-tn-encoding
src2
)))
(
integer
(
integer
(
emit-format-3-immed
segment
op
(
fp-reg-tn-encoding
dst
odd
)
op3
(
emit-format-3-immed
segment
op
(
reg-tn-encoding
src1
)
1
src2
))
(
if
dest-kind
(
fp-reg-tn-encoding
dst
odd
)
(
reg-tn-encoding
dst
))
op3
(
reg-tn-encoding
src1
)
1
src2
))
(
fixup
(
fixup
(
unless
(
or
load-store
fixup
)
(
unless
(
or
load-store
fixup
)
(
error
"Fixups aren't allowed."
))
(
error
"Fixups aren't allowed."
))
(
note-fixup
segment
:add
src2
)
(
note-fixup
segment
:add
src2
)
(
emit-format-3-immed
segment
op
(
fp-reg-tn-encoding
dst
odd
)
op3
(
emit-format-3-immed
segment
op
(
reg-tn-encoding
src1
)
1
0
))))
(
if
dest-kind
(
fp-reg-tn-encoding
dst
odd
)
(
reg-tn-encoding
dst
))
op3
(
reg-tn-encoding
src1
)
1
0
))))
(
eval-when
(
compile
eval
)
(
eval-when
(
compile
eval
)
(
defmacro
define-f3-inst
(
name
op
op3
&key
fixup
load-store
dest-kind
)
;;; have to do this because defconstant is evalutated in the null lex env.
`
(
define-instruction
,
name
(
segment
dst
src1
&optional
src2
)
(
defmacro
with-ref-format
(
printer
)
(
:declare
(
type
tn
dst
)
`
(
let*
((
addend
,
(
if
(
or
fixup
load-store
)
'
(
:choose
(
:plus-integer
immed
)
(
"+"
rs2
)))
'
(
type
(
or
tn
(
signed-byte
13
)
null
fixup
)
src1
src2
)
(
ref-format
'
(
type
(
or
tn
(
signed-byte
13
)
null
)
src1
src2
)))
`
(
"["
rs1
(
:unless
(
:constant
0
)
,
addend
)
"]"
,
(
if
dest-kind
(
:choose
(
:unless
(
:constant
0
)
asi
)
nil
))))
`
(
:emitter
(
emit-fp-format-3-inst
segment
,
op
,
op3
dst
src1
src2
,
printer
))
:load-store
,
load-store
:fixup
,
fixup
(
defconstant
load-printer
:odd
(
eq
',dest-kind
'odd-fp-reg
)))
(
with-ref-format
`
(
:NAME
:TAB
,
ref-format
", "
rd
)))
`
(
:emitter
(
emit-format-3-inst
segment
,
op
,
op3
dst
src1
src2
:load-store
,
load-store
(
defconstant
store-printer
:fixup
,
fixup
)))))
(
with-ref-format
`
(
:NAME
:TAB
rd
", "
,
ref-format
)))
(
defmacro
define-f3-inst
(
name
op
op3
&key
fixup
load-store
(
dest-kind
'reg
)
(
printer
:default
))
(
let
((
printer
(
if
(
eq
printer
:default
)
(
case
load-store
((
nil
)
:default
)
((
:load
t
)
'load-printer
)
(
:store
'store-printer
))
printer
)))
`
(
define-instruction
,
name
(
segment
dst
src1
&optional
src2
)
(
:declare
(
type
tn
dst
)
,
(
if
(
or
fixup
load-store
)
'
(
type
(
or
tn
(
signed-byte
13
)
null
fixup
)
src1
src2
)
'
(
type
(
or
tn
(
signed-byte
13
)
null
)
src1
src2
)))
,@
(
unless
(
eq
dest-kind
'odd-fp-reg
)
`
((
:printer
format-3-reg
((
op
,
op
)
(
op3
,
op3
)
(
rd
nil
:type
',dest-kind
))
,
printer
)
(
:printer
format-3-immed
((
op
,
op
)
(
op3
,
op3
)
(
rd
nil
:type
',dest-kind
))
,
printer
)))
(
:emitter
(
emit-format-3-inst
segment
,
op
,
op3
dst
src1
src2
:load-store
,
load-store
:fixup
,
fixup
:dest-kind
(
not
(
eq
',dest-kind
'reg
))
:odd
(
eq
',dest-kind
'odd-fp-reg
))))))
)
; eval-when (compile eval)
)
; eval-when (compile eval)
...
@@ -184,7 +331,8 @@
...
@@ -184,7 +331,8 @@
(
define-f3-inst
st
#b11
#b000100
:load-store
:store
)
(
define-f3-inst
st
#b11
#b000100
:load-store
:store
)
(
define-f3-inst
std
#b11
#b000111
:load-store
:store
)
(
define-f3-inst
std
#b11
#b000111
:load-store
:store
)
(
define-f3-inst
stf
#b11
#b100100
:dest-kind
fp-reg
:load-store
:store
)
(
define-f3-inst
stf
#b11
#b100100
:dest-kind
fp-reg
:load-store
:store
)
(
define-f3-inst
stf-odd
#b11
#b100100
:dest-kind
odd-fp-reg
:load-store
:store
)(
define-f3-inst
stdf
#b11
#b100111
:dest-kind
fp-reg
:load-store
:store
)
(
define-f3-inst
stf-odd
#b11
#b100100
:dest-kind
odd-fp-reg
:load-store
:store
)
(
define-f3-inst
stdf
#b11
#b100111
:dest-kind
fp-reg
:load-store
:store
)
(
define-f3-inst
ldstub
#b11
#b001101
:load-store
t
)
(
define-f3-inst
ldstub
#b11
#b001101
:load-store
t
)
(
define-f3-inst
swap
#b11
#b001111
:load-store
t
)
(
define-f3-inst
swap
#b11
#b001111
:load-store
t
)
(
define-f3-inst
add
#b10
#b000000
:fixup
t
)
(
define-f3-inst
add
#b10
#b000000
:fixup
t
)
...
@@ -218,22 +366,38 @@
...
@@ -218,22 +366,38 @@
(
define-f3-inst
save
#b10
#b111100
)
(
define-f3-inst
save
#b10
#b111100
)
(
define-f3-inst
restore
#b10
#b111101
)
(
define-f3-inst
restore
#b10
#b111101
)
;;;; Random instructions.
;;;; Random instructions.
(
define-instruction
ldfsr
(
segment
src1
src2
)
(
define-instruction
ldfsr
(
segment
src1
src2
)
(
:declare
(
type
tn
src1
)
(
type
(
signed-byte
13
)
src2
))
(
:declare
(
type
tn
src1
)
(
type
(
signed-byte
13
)
src2
))
(
:printer
format-3-immed
((
op
#b11
)
(
op3
#b100001
)))
(
:reads
(
list
src1
:memory
))
(
:writes
:float-status
)
(
:emitter
(
emit-format-3-immed
segment
#b11
0
#b100001
(
:emitter
(
emit-format-3-immed
segment
#b11
0
#b100001
(
reg-tn-encoding
src1
)
1
src2
)))
(
reg-tn-encoding
src1
)
1
src2
)))
(
define-instruction
stfsr
(
segment
src1
src2
)
(
define-instruction
stfsr
(
segment
src1
src2
)
(
:declare
(
type
tn
src1
)
(
type
(
signed-byte
13
)
src2
))
(
:declare
(
type
tn
src1
)
(
type
(
signed-byte
13
)
src2
))
(
:printer
format-3-immed
((
op
#b11
)
(
op3
#b100101
)))
(
:reads
(
list
src1
:float-status
))
(
:writes
:memory
)
(
:emitter
(
emit-format-3-immed
segment
#b11
0
#b100101
(
:emitter
(
emit-format-3-immed
segment
#b11
0
#b100101
(
reg-tn-encoding
src1
)
1
src2
)))
(
reg-tn-encoding
src1
)
1
src2
)))
(
eval-when
(
compile
load
eval
)
(
defun
sethi-arg-printer
(
value
stream
dstate
)
(
declare
(
ignore
dstate
))
(
format
stream
"%hi(#x~8,'0x)"
(
ash
value
10
)))
)
; eval-when (compile load eval)
(
define-instruction
sethi
(
segment
dst
src1
)
(
define-instruction
sethi
(
segment
dst
src1
)
(
:declare
(
type
tn
dst
)
(
:declare
(
type
tn
dst
)
(
type
(
or
(
signed-byte
22
)
(
unsigned-byte
22
)
fixup
)
src1
))
(
type
(
or
(
signed-byte
22
)
(
unsigned-byte
22
)
fixup
)
src1
))
(
:printer
format-2-immed
((
op2
#b100
)
(
immed
nil
:printer
#'
sethi-arg-printer
)))
(
:writes
dst
)
(
:emitter
(
:emitter
(
etypecase
src1
(
etypecase
src1
(
integer
(
integer
...
@@ -243,14 +407,23 @@
...
@@ -243,14 +407,23 @@
(
note-fixup
segment
:sethi
src1
)
(
note-fixup
segment
:sethi
src1
)
(
emit-format-2-immed
segment
#b00
(
reg-tn-encoding
dst
)
#b100
0
)))))
(
emit-format-2-immed
segment
#b00
(
reg-tn-encoding
dst
)
#b100
0
)))))
(
define-instruction
rdy
(
segment
dst
)
(
define-instruction
rdy
(
segment
dst
)
(
:declare
(
type
tn
dst
))
(
:declare
(
type
tn
dst
))
(
:printer
format-3-immed
((
op
#b10
)
(
op3
#b101000
)
(
rs1
0
)
(
immed
0
))
'
(
'RD
:tab
'%Y
", "
rd
))
(
:reads
dst
)
(
:emitter
(
emit-format-3-immed
segment
#b10
(
reg-tn-encoding
dst
)
#b101000
(
:emitter
(
emit-format-3-immed
segment
#b10
(
reg-tn-encoding
dst
)
#b101000
0
1
0
)))
0
1
0
)))
(
defconstant
wry-printer
'
(
'WR
:tab
rs1
(
:unless
(
:constant
0
)
", "
(
:choose
immed
rs2
))
", "
'%Y
))
(
define-instruction
wry
(
segment
src1
&optional
src2
)
(
define-instruction
wry
(
segment
src1
&optional
src2
)
(
:declare
(
type
tn
src1
)
(
type
(
or
(
signed-byte
13
)
tn
null
)
src2
))
(
:declare
(
type
tn
src1
)
(
type
(
or
(
signed-byte
13
)
tn
null
)
src2
))
(
:printer
format-3-reg
((
op
#b10
)
(
op3
#b110000
)
(
rd
0
))
wry-printer
)
(
:printer
format-3-immed
((
op
#b10
)
(
op3
#b110000
)
(
rd
0
))
wry-printer
)
(
:writes
(
if
src2
(
list
src1
src2
)
src1
))
(
:delay
3
)
(
:emitter
(
:emitter
(
etypecase
src2
(
etypecase
src2
(
null
(
null
...
@@ -262,8 +435,63 @@
...
@@ -262,8 +435,63 @@
(
emit-format-3-immed
segment
#b10
0
#b110000
(
reg-tn-encoding
src1
)
1
(
emit-format-3-immed
segment
#b10
0
#b110000
(
reg-tn-encoding
src1
)
1
src2
)))))
src2
)))))
(
defun
snarf-error-junk
(
sap
offset
&optional
length-only
)
(
let*
((
length
(
system:sap-ref-8
sap
offset
))
(
vector
(
make-array
length
:element-type
'
(
unsigned-byte
8
))))
(
declare
(
type
system:system-area-pointer
sap
)
(
type
(
unsigned-byte
8
)
length
)
(
type
(
simple-array
(
unsigned-byte
8
)
(
*
))
vector
))
(
cond
(
length-only
(
values
0
(
1+
length
)
nil
nil
))
(
t
(
kernel:copy-from-system-area
sap
(
*
sparc:byte-bits
(
1+
offset
))
vector
(
*
sparc:word-bits
sparc:vector-data-offset
)
(
*
length
sparc:byte-bits
))
(
collect
((
sc-offsets
)
(
lengths
))
(
lengths
1
)
; the length byte
(
let*
((
index
0
)
(
error-number
(
c::read-var-integer
vector
index
)))
(
lengths
index
)
(
loop
(
when
(
>=
index
length
)
(
return
))
(
let
((
old-index
index
))
(
sc-offsets
(
c::read-var-integer
vector
index
))
(
lengths
(
-
index
old-index
))))
(
values
error-number
(
1+
length
)
(
sc-offsets
)
(
lengths
))))))))
(
defun
unimp-control
(
chunk
inst
stream
dstate
)
(
declare
(
ignore
inst
))
(
flet
((
nt
(
x
)
(
if
stream
(
disassem:note
x
dstate
))))
(
case
(
format-2-unimp-data
chunk
dstate
)
(
#.
vm:error-trap
(
nt
"Error trap"
)
(
disassem:handle-break-args
#'
snarf-error-junk
stream
dstate
))
(
#.
vm:cerror-trap
(
nt
"Cerror trap"
)
(
disassem:handle-break-args
#'
snarf-error-junk
stream
dstate
))
(
#.
vm:object-not-list-trap
(
nt
"Object not list trap"
))
(
#.
vm:breakpoint-trap
(
nt
"Breakpoint trap"
))
(
#.
vm:pending-interrupt-trap
(
nt
"Pending interrupt trap"
))
(
#.
vm:halt-trap
(
nt
"Halt trap"
))
(
#.
vm:function-end-breakpoint-trap
(
nt
"Function end breakpoint trap"
))
(
#.
vm:object-not-structure-trap
(
nt
"Object not structure trap"
))
)))
(
define-instruction
unimp
(
segment
data
)
(
define-instruction
unimp
(
segment
data
)
(
:declare
(
type
(
unsigned-byte
22
)
data
))
(
:declare
(
type
(
unsigned-byte
22
)
data
))
(
:printer
format-2-unimp
()
:default
:control
#'
unimp-control
)
(
:emitter
(
emit-format-2-unimp
segment
0
0
0
data
)))
(
:emitter
(
emit-format-2-unimp
segment
0
0
0
data
)))
...
@@ -287,30 +515,52 @@
...
@@ -287,30 +515,52 @@
(
define-instruction
b
(
segment
cond-or-target
&optional
target
)
(
define-instruction
b
(
segment
cond-or-target
&optional
target
)
(
:declare
(
type
(
or
label
branch-condition
)
cond-or-target
)
(
:declare
(
type
(
or
label
branch-condition
)
cond-or-target
)
(
type
(
or
label
null
)
target
))
(
type
(
or
label
null
)
target
))
(
:printer
format-2-branch
((
op
#b00
)
(
op2
#b010
)))
(
:emitter
(
:emitter
(
emit-relative-branch
segment
0
#b010
cond-or-target
target
)))
(
emit-relative-branch
segment
0
#b010
cond-or-target
target
)))
(
define-instruction
ba
(
segment
cond-or-target
&optional
target
)
(
define-instruction
ba
(
segment
cond-or-target
&optional
target
)
(
:declare
(
type
(
or
label
branch-condition
)
cond-or-target
)
(
:declare
(
type
(
or
label
branch-condition
)
cond-or-target
)
(
type
(
or
label
null
)
target
))
(
type
(
or
label
null
)
target
))
(
:printer
format-2-branch
((
op
#b00
)
(
op2
#b010
)
(
a
1
))
nil
:print-name
'b
)
(
:emitter
(
:emitter
(
emit-relative-branch
segment
1
#b010
cond-or-target
target
)))
(
emit-relative-branch
segment
1
#b010
cond-or-target
target
)))
(
define-instruction
t
(
segment
condition
target
)
(
define-instruction
t
(
segment
condition
target
)
(
:declare
(
type
branch-condition
condition
)
(
:declare
(
type
branch-condition
condition
)
(
type
(
or
(
signed-byte
13
)
(
unsigned-byte
13
))
target
))
(
type
(
or
(
signed-byte
13
)
(
unsigned-byte
13
))
target
))
(
:printer
format-3-immed
((
op
#b10
)
(
rd
nil
:type
'branch-condition
)
(
op3
#b111010
)
(
rs1
0
))
'
(
:name
rd
:tab
immed
))
(
:emitter
(
emit-format-3-immed
segment
#b10
(
branch-condition
condition
)
(
:emitter
(
emit-format-3-immed
segment
#b10
(
branch-condition
condition
)
#b111010
0
1
target
)))
#b111010
0
1
target
)))
(
define-instruction
fb
(
segment
condition
target
)
(
define-instruction
fb
(
segment
condition
target
)
(
:declare
(
type
fp-branch-condition
condition
)
(
type
label
target
))
(
:declare
(
type
fp-branch-condition
condition
)
(
type
label
target
))
(
:printer
format-2-branch
((
Op
#B00
)
(
cond
nil
:type
'branch-fp-condition
)
(
op2
#b110
)))
(
:emitter
(
:emitter
(
emit-relative-branch
segment
0
#b110
condition
target
t
)))
(
emit-relative-branch
segment
0
#b110
condition
target
t
)))
(
defconstant
jal-printer
'
(
:name
:tab
(
:choose
(
rs1
(
:unless
(
:constant
0
)
(
:plus-integer
immed
)))
(
:cond
((
rs2
:constant
0
)
rs1
)
((
rs1
:constant
0
)
rs2
)
(
t
rs1
"+"
rs2
)))
(
:unless
(
:constant
0
)
", "
rd
)))
(
define-instruction
jal
(
segment
dst
src1
&optional
src2
)
(
define-instruction
jal
(
segment
dst
src1
&optional
src2
)
(
:declare
(
type
tn
dst
)
(
:declare
(
type
tn
dst
)
(
type
(
or
tn
integer
)
src1
)
(
type
(
or
tn
integer
)
src1
)
(
type
(
or
null
fixup
tn
(
signed-byte
13
))
src2
))
(
type
(
or
null
fixup
tn
(
signed-byte
13
))
src2
))
(
:printer
format-3-reg
((
op
#b10
)
(
op3
#b111000
))
jal-printer
)
(
:printer
format-3-immed
((
op
#b10
)
(
op3
#b111000
))
jal-printer
)
(
:emitter
(
:emitter
(
unless
src2
(
unless
src2
(
setf
src2
src1
)
(
setf
src2
src1
)
...
@@ -330,9 +580,10 @@
...
@@ -330,9 +580,10 @@
(
emit-format-3-immed
segment
#b10
(
reg-tn-encoding
dst
)
(
emit-format-3-immed
segment
#b10
(
reg-tn-encoding
dst
)
#b111000
(
reg-tn-encoding
src1
)
1
0
)))))
#b111000
(
reg-tn-encoding
src1
)
1
0
)))))
(
define-instruction
j
(
segment
src1
&optional
src2
)
(
define-instruction
j
(
segment
src1
&optional
src2
)
(
:declare
(
type
tn
src1
)
(
type
(
or
tn
(
signed-byte
13
)
fixup
null
)
src2
))
(
:declare
(
type
tn
src1
)
(
type
(
or
tn
(
signed-byte
13
)
fixup
null
)
src2
))
(
:printer
format-3-reg
((
op
#b10
)
(
op3
#b111000
)
(
rd
0
))
jal-printer
)
(
:printer
format-3-immed
((
op
#b10
)
(
op3
#b111000
)
(
rd
0
))
jal-printer
)
(
:emitter
(
:emitter
(
etypecase
src2
(
etypecase
src2
(
null
(
null
...
@@ -364,11 +615,13 @@
...
@@ -364,11 +615,13 @@
(
defmacro
define-unary-fp-inst
(
name
opf
)
(
defmacro
define-unary-fp-inst
(
name
opf
)
`
(
define-instruction
,
name
(
segment
dst
src1
&optional
src2
)
`
(
define-instruction
,
name
(
segment
dst
src1
&optional
src2
)
(
:declare
(
type
tn
dst
src1
)
(
type
(
or
null
tn
)
src2
))
(
:declare
(
type
tn
dst
src1
)
(
type
(
or
null
tn
)
src2
))
(
:printer
format-3-fpop
((
op
#b10
)
(
op3
#b110100
)
(
opf
,
opf
)))
(
:emitter
(
emit-fp-inst
segment
,
opf
#b110100
dst
src1
src2
))))
(
:emitter
(
emit-fp-inst
segment
,
opf
#b110100
dst
src1
src2
))))
(
defmacro
define-binary-fp-inst
(
name
opf
&optional
(
op3
#b110100
))
(
defmacro
define-binary-fp-inst
(
name
opf
&optional
(
op3
#b110100
))
`
(
define-instruction
,
name
(
segment
dst
src1
&optional
src2
)
`
(
define-instruction
,
name
(
segment
dst
src1
&optional
src2
)
(
:declare
(
type
tn
dst
src1
)
(
type
(
or
null
tn
)
src2
))
(
:declare
(
type
tn
dst
src1
)
(
type
(
or
null
tn
)
src2
))
(
:printer
format-3-fpop
((
op
#b10
)
(
op3
,
op3
)
(
opf
,
opf
)))
(
:emitter
(
emit-fp-inst
segment
,
opf
,
op3
dst
src1
src2
))))
(
:emitter
(
emit-fp-inst
segment
,
opf
,
op3
dst
src1
src2
))))
)
; eval-when (compile eval)
)
; eval-when (compile eval)
...
@@ -394,7 +647,9 @@
...
@@ -394,7 +647,9 @@
(
define-unary-fp-inst
fxtod
#b011001011
)
(
define-unary-fp-inst
fxtod
#b011001011
)
(
define-unary-fp-inst
fmovs
#b000000001
)
(
define-unary-fp-inst
fmovs
#b000000001
)
(
define-unary-fp-inst
fmovs-odd
#b000000001
)
(
define-instruction
fmovs-odd
(
segment
dst
src1
&optional
src2
)
(
:declare
(
type
tn
dst
src1
)
(
type
(
or
null
tn
)
src2
))
(
:emitter
(
emit-fp-inst
segment
#b000000001
#b110100
dst
src1
src2
)))
(
define-unary-fp-inst
fnegs
#b000000101
)
(
define-unary-fp-inst
fnegs
#b000000101
)
(
define-unary-fp-inst
fabss
#b000001001
)
(
define-unary-fp-inst
fabss
#b000001001
)
...
@@ -480,10 +735,15 @@
...
@@ -480,10 +735,15 @@
(
inst
jali
zero-tn
tmpreg
value
))))
(
inst
jali
zero-tn
tmpreg
value
))))
(
define-instruction
nop
(
segment
)
(
define-instruction
nop
(
segment
)
(
:printer
format-2-immed
((
rd
0
)
(
op2
#b100
)
(
immed
0
))
'
(
:name
))
(
:emitter
(
emit-format-2-immed
segment
0
0
#b100
0
)))
(
:emitter
(
emit-format-2-immed
segment
0
0
#b100
0
)))
(
define-instruction
cmp
(
segment
src1
&optional
src2
)
(
define-instruction
cmp
(
segment
src1
&optional
src2
)
(
:declare
(
type
tn
src1
)
(
type
(
or
null
tn
(
signed-byte
13
))
src2
))
(
:declare
(
type
tn
src1
)
(
type
(
or
null
tn
(
signed-byte
13
))
src2
))
(
:printer
format-3-reg
((
op
#b10
)
(
op3
#b010100
)
(
rd
0
))
'
(
:name
:tab
rs1
", "
rs2
))
(
:printer
format-3-immed
((
op
#b10
)
(
op3
#b010100
)
(
rd
0
))
'
(
:name
:tab
rs1
", "
immed
))
(
:emitter
(
:emitter
(
etypecase
src2
(
etypecase
src2
(
null
(
null
...
@@ -497,6 +757,8 @@
...
@@ -497,6 +757,8 @@
(
define-instruction
not
(
segment
dst
&optional
src1
)
(
define-instruction
not
(
segment
dst
&optional
src1
)
(
:declare
(
type
tn
dst
)
(
type
(
or
tn
null
)
src1
))
(
:declare
(
type
tn
dst
)
(
type
(
or
tn
null
)
src1
))
(
:printer
format-3-reg
((
op
#b10
)
(
op3
#b000111
)
(
rs2
0
))
'
(
:name
:tab
(
:unless
(
:same-as
rd
)
rs1
", "
)
rd
))
(
:emitter
(
:emitter
(
unless
src1
(
unless
src1
(
setf
src1
dst
))
(
setf
src1
dst
))
...
@@ -505,6 +767,8 @@
...
@@ -505,6 +767,8 @@
(
define-instruction
neg
(
segment
dst
&optional
src1
)
(
define-instruction
neg
(
segment
dst
&optional
src1
)
(
:declare
(
type
tn
dst
)
(
type
(
or
tn
null
)
src1
))
(
:declare
(
type
tn
dst
)
(
type
(
or
tn
null
)
src1
))
(
:printer
format-3-reg
((
op
#b10
)
(
op3
#b000100
)
(
rs1
0
))
'
(
:name
:tab
(
:unless
(
:same-as
rd
)
rs2
", "
)
rd
))
(
:emitter
(
:emitter
(
unless
src1
(
unless
src1
(
setf
src1
dst
))
(
setf
src1
dst
))
...
@@ -513,9 +777,12 @@
...
@@ -513,9 +777,12 @@
(
define-instruction
move
(
segment
dst
src1
)
(
define-instruction
move
(
segment
dst
src1
)
(
:declare
(
type
tn
dst
src1
))
(
:declare
(
type
tn
dst
src1
))
(
:printer
format-3-reg
((
op
#b10
)
(
op3
#b000010
)
(
rs1
0
))
'
(
:name
:tab
rs2
", "
rd
))
(
:emitter
(
emit-format-3-reg
segment
#b10
(
reg-tn-encoding
dst
)
#b000010
(
:emitter
(
emit-format-3-reg
segment
#b10
(
reg-tn-encoding
dst
)
#b000010
0
0
0
(
reg-tn-encoding
src1
))))
0
0
0
(
reg-tn-encoding
src1
))))
;;;; Instructions for dumping data and header objects.
;;;; Instructions for dumping data and header objects.
...
@@ -564,7 +831,6 @@
...
@@ -564,7 +831,6 @@
;;;; Instructions for converting between code objects, functions, and lras.
;;;; Instructions for converting between code objects, functions, and lras.
(
defun
emit-compute-inst
(
segment
vop
dst
src
label
temp
calc
)
(
defun
emit-compute-inst
(
segment
vop
dst
src
label
temp
calc
)
(
emit-chooser
(
emit-chooser
;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment