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
7e23dc2a
Commit
7e23dc2a
authored
33 years ago
by
ram
Browse files
Options
Downloads
Patches
Plain Diff
Added Miles's disassembler annotations.
parent
9c8d5a2e
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
+350
-97
350 additions, 97 deletions
compiler/sparc/insts.lisp
with
350 additions
and
97 deletions
compiler/sparc/insts.lisp
+
350
−
97
View file @
7e23dc2a
...
@@ -7,7 +7,7 @@
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;; **********************************************************************
;;;
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/insts.lisp,v 1.
4
1991/
03/19 22:59:26 wlott
Exp $
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/insts.lisp,v 1.
5
1991/
11/15 15:29:08 ram
Exp $
;;;
;;;
;;; Description of the SPARC architecture.
;;; Description of the SPARC architecture.
;;;
;;;
...
@@ -19,64 +19,13 @@
...
@@ -19,64 +19,13 @@
(
use-package
"EXT"
)
(
use-package
"EXT"
)
(
use-package
"C"
)
(
use-package
"C"
)
(
disassem:set-disassem-params
:instruction-alignment
32
)
;;;; Formats:
(
define-format
(
format-1
32
)
(
op
(
byte
2
30
)
:default
1
)
(
disp
(
byte
30
0
)))
(
define-format
(
format-2-immed
32
)
(
op
(
byte
2
30
)
:default
0
)
(
rd
(
byte
5
25
))
(
op2
(
byte
3
22
))
(
immed
(
byte
22
0
)))
(
define-format
(
format-2-branch
32
)
(
op
(
byte
2
30
)
:default
0
)
(
a
(
byte
1
29
))
(
cond
(
byte
4
25
))
(
op2
(
byte
3
22
))
(
disp
(
byte
22
0
)))
(
define-format
(
format-2-unimp
32
)
(
op
(
byte
2
30
)
:default
0
)
(
ignore
(
byte
5
25
)
:default
0
)
(
op2
(
byte
3
22
)
:default
0
)
(
data
(
byte
22
0
)))
(
define-format
(
format-3-reg
32
)
(
op
(
byte
2
30
))
(
rd
(
byte
5
25
))
(
op3
(
byte
6
19
))
(
rs1
(
byte
5
14
))
(
i
(
byte
1
13
)
:default
0
)
(
asi
(
byte
8
5
)
:default
0
)
(
rs2
(
byte
5
0
)))
(
define-format
(
format-3-immed
32
)
(
op
(
byte
2
30
))
(
rd
(
byte
5
25
))
(
op3
(
byte
6
19
))
(
rs1
(
byte
5
14
))
(
i
(
byte
1
13
)
:default
1
)
(
immed
(
byte
13
0
)))
(
define-format
(
format-3-fpop
32
)
(
op
(
byte
2
30
))
(
rd
(
byte
5
25
))
(
op3
(
byte
6
19
))
(
rs1
(
byte
5
14
))
(
opf
(
byte
9
5
))
(
rs2
(
byte
5
0
)))
;;;; Special argument types and fixups.
;;;; Special argument types and fixups.
(
defvar
*disassem-use-lisp-reg-names*
t
)
(
define-argument-type
reg
(
define-argument-type
reg
:type
'
(
and
tn
:type
'
(
and
tn
(
satisfies
(
lambda
(
object
)
(
satisfies
(
lambda
(
object
)
...
@@ -88,7 +37,19 @@
...
@@ -88,7 +37,19 @@
(
case
(
sc-name
(
tn-sc
tn
))
(
case
(
sc-name
(
tn-sc
tn
))
(
null
null-offset
)
(
null
null-offset
)
(
zero
0
)
(
zero
0
)
(
t
(
tn-offset
tn
)))))
(
t
(
tn-offset
tn
))))
:disassem-printer
#'
(
lambda
(
value
stream
)
(
declare
(
stream
stream
)
(
fixnum
value
))
(
cond
(
*disassem-use-lisp-reg-names*
(
write-char
#\%
stream
)
(
princ
(
aref
*register-names*
value
)
stream
))
(
t
(
multiple-value-bind
(
set
num
)
(
truncate
value
8
)
(
format
stream
"%~a~d"
(
aref
#(
"g"
"o"
"l"
"i"
)
set
)
num
)))))
)
(
define-argument-type
fp-reg
(
define-argument-type
fp-reg
...
@@ -96,7 +57,9 @@
...
@@ -96,7 +57,9 @@
(
satisfies
(
lambda
(
object
)
(
satisfies
(
lambda
(
object
)
(
eq
(
sb-name
(
sc-sb
(
tn-sc
object
)))
(
eq
(
sb-name
(
sc-sb
(
tn-sc
object
)))
'float-registers
))))
'float-registers
))))
:function
tn-offset
)
:function
tn-offset
:disassem-printer
"%f~d"
)
(
define-argument-type
odd-fp-reg
(
define-argument-type
odd-fp-reg
:type
'
(
and
tn
:type
'
(
and
tn
...
@@ -109,33 +72,120 @@
...
@@ -109,33 +72,120 @@
(
define-argument-type
relative-label
(
define-argument-type
relative-label
:type
'label
:type
'label
:function
(
lambda
(
label
)
:function
(
lambda
(
label
)
(
ash
(
-
(
label-position
label
)
*current-position*
)
-2
)))
(
ash
(
-
(
label-position
label
)
*current-position*
)
-2
))
:sign-extend
t
:disassem-use-label
#'
(
lambda
(
value
dstate
)
(
declare
(
type
disassem:disassem-state
dstate
))
(
+
(
ash
value
2
)
(
disassem:dstate-curpos
dstate
)))
)
(
eval-when
(
compile
eval
load
)
(
eval-when
(
compile
eval
load
)
(
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
#.
(
map
'vector
#'
symbol-name
branch-conditions
))
(
define-argument-type
branch-condition
(
define-argument-type
branch-condition
:type
'
(
member
.
#.
branch-conditions
)
:type
'
(
member
.
#.
branch-conditions
)
:function
(
lambda
(
cond
)
(
position
cond
branch-conditions
)))
:function
(
lambda
(
cond
)
(
position
cond
branch-conditions
))
:disassem-printer
branch-cond-name-vec
)
(
defconstant
branch-cond-true
#b1000
)
(
eval-when
(
compile
eval
load
)
(
eval-when
(
compile
eval
load
)
(
defconstant
branch-fp-conditions
(
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
#.
(
map
'vector
#'
symbol-name
branch-fp-conditions
))
(
define-argument-type
branch-fp-condition
(
define-argument-type
branch-fp-condition
:type
'
(
member
.
#.
branch-fp-conditions
)
:type
'
(
member
.
#.
branch-fp-conditions
)
:function
(
lambda
(
fp-cond
)
(
position
fp-cond
branch-fp-conditions
)))
:function
(
lambda
(
fp-cond
)
(
position
fp-cond
branch-fp-conditions
))
:disassem-printer
branch-fp-cond-name-vec
)
(
define-fixup-type
:call
)
(
define-fixup-type
:call
:disassem-use-label
t
)
(
define-fixup-type
:sethi
)
(
define-fixup-type
:sethi
:disassem-printer
#'
(
lambda
(
value
stream
)
(
format
stream
"%hi(#x~8,'0x)"
(
ash
value
10
))))
(
define-fixup-type
:add
)
(
define-fixup-type
:add
)
;;;; Formats:
(
define-format
(
format-1
32
:disassem-printer
'
(
:name
:tab
disp
))
(
op
(
byte
2
30
)
:default
1
)
(
disp
(
byte
30
0
)
:default-type
(
unsigned-byte
30
)))
(
define-format
(
format-2-immed
32
:disassem-printer
'
(
:name
:tab
immed
", "
rd
))
(
op
(
byte
2
30
)
:default
0
)
(
rd
(
byte
5
25
)
:default-type
reg
)
(
op2
(
byte
3
22
))
(
immed
(
byte
22
0
)
:default-type
(
signed-byte
22
)))
(
define-format
(
format-2-branch
32
:disassem-printer
`
(
:name
(
:unless
(
:constant
,
branch-cond-true
)
cond
)
:tab
disp
))
(
op
(
byte
2
30
)
:default
0
)
(
a
(
byte
1
29
))
(
cond
(
byte
4
25
)
:default-type
branch-condition
)
(
op2
(
byte
3
22
))
(
disp
(
byte
22
0
)
:default-type
relative-label
))
(
define-format
(
format-2-unimp
32
:disassem-printer
'
(
:name
:tab
data
))
(
op
(
byte
2
30
)
:default
0
)
(
ignore
(
byte
5
25
)
:default
0
)
(
op2
(
byte
3
22
)
:default
0
)
(
data
(
byte
22
0
)
:default-type
(
unsigned-byte
22
)))
(
defconstant
f3-printer
'
(
:name
:tab
(
:unless
(
:same-as
rd
)
rs1
", "
)
(
:choose
rs2
immed
)
", "
rd
))
(
define-format
(
format-3-reg
32
:disassem-printer
f3-printer
)
(
op
(
byte
2
30
))
(
rd
(
byte
5
25
)
:default-type
reg
)
(
op3
(
byte
6
19
))
(
rs1
(
byte
5
14
)
:default-type
reg
)
(
i
(
byte
1
13
)
:default
0
)
(
asi
(
byte
8
5
)
:default
0
)
(
rs2
(
byte
5
0
)
:default-type
reg
))
(
define-format
(
format-3-immed
32
:disassem-printer
f3-printer
)
(
op
(
byte
2
30
))
(
rd
(
byte
5
25
)
:default-type
reg
)
(
op3
(
byte
6
19
))
(
rs1
(
byte
5
14
)
:default-type
reg
)
(
i
(
byte
1
13
)
:default
1
)
(
immed
(
byte
13
0
)
:default-type
(
signed-byte
13
)))
(
define-format
(
format-3-fpop
32
:disassem-printer
'
(
:name
:tab
(
:unless
(
:same-as
rd
)
rs1
", "
)
rs2
", "
rd
))
(
op
(
byte
2
30
))
(
rd
(
byte
5
25
)
:default-type
fp-reg
)
(
op3
(
byte
6
19
))
(
rs1
(
byte
5
14
)
:default-type
fp-reg
)
(
opf
(
byte
9
5
))
(
rs2
(
byte
5
0
)
:default-type
fp-reg
))
;;;; Instructions.
;;;; Instructions.
...
@@ -143,8 +193,31 @@
...
@@ -143,8 +193,31 @@
(
eval-when
(
compile
eval
)
(
eval-when
(
compile
eval
)
(
defmacro
define-f3-inst
(
name
op
op3
&key
(
dest-kind
'reg
)
fixup
load-store
)
;;; have to do this because defconstant is evalutated in the null lex env.
`
(
define-instruction
(
,
name
)
(
defmacro
with-ref-format
(
printer
)
`
(
let*
((
i-or-r
'
(
:choose
immed
rs2
))
(
ref-format
`
(
"["
rs1
(
:unless
(
:constant
0
)
"+"
,
i-or-r
)
"]"
(
:choose
(
:unless
(
:constant
0
)
asi
)
nil
))))
,
printer
))
(
defconstant
load-printer
(
with-ref-format
`
(
:NAME
:TAB
,
ref-format
", "
rd
)))
(
defconstant
store-printer
(
with-ref-format
`
(
:NAME
:TAB
rd
", "
,
ref-format
)))
(
defmacro
define-f3-inst
(
name
op
op3
&key
(
dest-kind
'reg
)
fixup
load-store
disassem-printer
)
`
(
define-instruction
(
,
name
,@
(
if
disassem-printer
`
(
:disassem-printer
,
disassem-printer
)
(
case
load-store
((
:load
t
)
; note that the sun notation for
; things (like swap) that do both is
; like a load
`
(
:disassem-printer
',load-printer
))
(
:store
`
(
:disassem-printer
',store-printer
)))))
(
format-3-reg
(
op
:constant
,
op
)
(
format-3-reg
(
op
:constant
,
op
)
(
rd
:argument
,
dest-kind
)
(
rd
:argument
,
dest-kind
)
(
op3
:constant
,
op3
)
(
op3
:constant
,
op3
)
...
@@ -189,25 +262,63 @@
...
@@ -189,25 +262,63 @@
)
; eval-when
)
; eval-when
(
define-f3-inst
ldsb
#b11
#b001001
:load-store
t
)
(
define-f3-inst
ldsb
#b11
#b001001
:load-store
:load
)
(
define-f3-inst
ldsh
#b11
#b001010
:load-store
t
)
(
define-f3-inst
ldsh
#b11
#b001010
:load-store
:load
)
(
define-f3-inst
ldub
#b11
#b000001
:load-store
t
)
(
define-f3-inst
ldub
#b11
#b000001
:load-store
:load
)
(
define-f3-inst
lduh
#b11
#b000010
:load-store
t
)
(
define-f3-inst
lduh
#b11
#b000010
:load-store
:load
)
(
define-f3-inst
ld
#b11
#b000000
:load-store
t
)
(
define-f3-inst
ldd
#b11
#b000011
:load-store
t
)
;;; ----------------------------------------------------------------
(
define-f3-inst
ld
#b11
#b000000
:load-store
:load
)
(
define-f3-inst
ldf
#b11
#b100000
:dest-kind
fp-reg
:load-store
t
)
(
define-f3-inst
ldf-odd
#b11
#b100000
:dest-kind
odd-fp-reg
:load-store
t
)
(
disassem:specialize
(
ld
(
define-f3-inst
lddf
#b11
#b100011
:dest-kind
fp-reg
:load-store
t
)
:disassem-control
#'
(
lambda
(
chunk
inst
stream
dstate
)
(
define-f3-inst
stb
#b11
#b000101
:load-store
t
)
(
when
stream
(
define-f3-inst
sth
#b11
#b000110
:load-store
t
)
(
disassem:note-code-constant
(
define-f3-inst
st
#b11
#b000100
:load-store
t
)
(
disassem:arg-value
'immed
chunk
inst
)
(
define-f3-inst
std
#b11
#b000111
:load-store
t
)
dstate
))))
immed
(
define-f3-inst
stf
#b11
#b100100
:dest-kind
fp-reg
:load-store
t
)
(
rs1
:constant
code-offset
))
(
define-f3-inst
stf-odd
#b11
#b100100
:dest-kind
odd-fp-reg
:load-store
t
)
(
define-f3-inst
stdf
#b11
#b100111
:dest-kind
fp-reg
:load-store
t
)
(
disassem:specialize
(
ld
:disassem-control
#'
(
lambda
(
chunk
inst
stream
dstate
)
(
when
stream
(
disassem:maybe-note-nil-indexed-symbol-slot-ref
(
disassem:arg-value
'immed
chunk
inst
)
dstate
))))
immed
(
rs1
:constant
null-offset
))
;;; ----------------------------------------------------------------
(
define-f3-inst
ldd
#b11
#b000011
:load-store
:load
)
(
define-f3-inst
ldf
#b11
#b100000
:dest-kind
fp-reg
:load-store
:load
)
(
define-f3-inst
ldf-odd
#b11
#b100000
:dest-kind
odd-fp-reg
:load-store
:load
)
(
define-f3-inst
lddf
#b11
#b100011
:dest-kind
fp-reg
:load-store
:load
)
(
define-f3-inst
stb
#b11
#b000101
:load-store
:store
)
(
define-f3-inst
sth
#b11
#b000110
:load-store
:store
)
;;; ----------------------------------------------------------------
(
define-f3-inst
st
#b11
#b000100
:load-store
:store
)
(
disassem:specialize
(
st
:disassem-control
#'
(
lambda
(
chunk
inst
stream
dstate
)
(
when
stream
(
disassem:maybe-note-nil-indexed-symbol-slot-ref
(
disassem:arg-value
'immed
chunk
inst
)
dstate
))))
immed
(
rs1
:constant
null-offset
))
;;; ----------------------------------------------------------------
(
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-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
)
...
@@ -226,7 +337,49 @@
...
@@ -226,7 +337,49 @@
(
rs1
:argument
reg
)
(
rs1
:argument
reg
)
(
immed
:argument
(
signed-byte
13
))))
(
immed
:argument
(
signed-byte
13
))))
;;; ----------------------------------------------------------------
(
define-f3-inst
add
#b10
#b000000
:fixup
t
)
(
define-f3-inst
add
#b10
#b000000
:fixup
t
)
(
defstruct
sethi-note
target-reg
high-bits
following-addr
)
(
defun
look-at-sethi-note
(
chunk
inst
stream
dstate
)
(
when
stream
(
let
((
sethi-note
(
disassem:dstate-get-prop
dstate
'sethi-note
)))
(
when
(
and
sethi-note
(
=
(
disassem:dstate-curpos
dstate
)
(
sethi-note-following-addr
sethi-note
))
(
=
(
disassem:arg-value
'rd
chunk
inst
)
(
sethi-note-target-reg
sethi-note
)))
(
let
((
value
(
+
(
sethi-note-high-bits
sethi-note
)
(
disassem:arg-value
'immed
chunk
inst
))))
(
or
(
disassem:maybe-note-assembler-routine
value
dstate
)
(
disassem:note
#'
(
lambda
(
stream
)
(
format
stream
"#x~x (~d)"
value
(
disassem:sign-extend
value
32
)))
dstate
)))))))
(
disassem:specialize
(
add
:disassem-control
#'
look-at-sethi-note
)
immed
)
;;; note: this must be after the above, because the disassem-controls
;;; are exclusive
(
disassem:specialize
(
add
:disassem-control
#'
(
lambda
(
chunk
inst
stream
dstate
)
(
when
stream
(
disassem:maybe-note-nil-indexed-object
(
disassem:arg-value
'immed
chunk
inst
)
dstate
))))
immed
(
rs1
:constant
null-offset
))
;;; ----------------------------------------------------------------
(
define-f3-inst
addcc
#b10
#b010000
)
(
define-f3-inst
addcc
#b10
#b010000
)
(
define-f3-inst
addx
#b10
#b001000
)
(
define-f3-inst
addx
#b10
#b001000
)
(
define-f3-inst
addxcc
#b10
#b011000
)
(
define-f3-inst
addxcc
#b10
#b011000
)
...
@@ -249,6 +402,7 @@
...
@@ -249,6 +402,7 @@
(
define-f3-inst
andn
#b10
#b000101
)
(
define-f3-inst
andn
#b10
#b000101
)
(
define-f3-inst
andncc
#b10
#b010101
)
(
define-f3-inst
andncc
#b10
#b010101
)
(
define-f3-inst
or
#b10
#b000010
)
(
define-f3-inst
or
#b10
#b000010
)
(
disassem:specialize
(
or
:disassem-control
#'
look-at-sethi-note
)
immed
)
(
define-f3-inst
orcc
#b10
#b010010
)
(
define-f3-inst
orcc
#b10
#b010010
)
(
define-f3-inst
orn
#b10
#b000110
)
(
define-f3-inst
orn
#b10
#b000110
)
(
define-f3-inst
orncc
#b10
#b010110
)
(
define-f3-inst
orncc
#b10
#b010110
)
...
@@ -261,7 +415,20 @@
...
@@ -261,7 +415,20 @@
(
define-f3-inst
srl
#b10
#b100110
)
(
define-f3-inst
srl
#b10
#b100110
)
(
define-f3-inst
sra
#b10
#b100111
)
(
define-f3-inst
sra
#b10
#b100111
)
(
define-instruction
(
sethi
)
(
defun
sethi-note
(
chunk
inst
stream
dstate
)
(
when
stream
(
let
((
sethi-note
(
disassem:dstate-get-prop
dstate
'sethi-note
)))
(
when
(
null
sethi-note
)
(
setf
sethi-note
(
make-sethi-note
)
(
disassem:dstate-get-prop
dstate
'sethi-note
)
sethi-note
))
(
setf
(
sethi-note-target-reg
sethi-note
)
(
disassem:arg-value
'rd
chunk
inst
))
(
setf
(
sethi-note-high-bits
sethi-note
)
(
ash
(
disassem:arg-value
'immed
chunk
inst
)
10
))
(
setf
(
sethi-note-following-addr
sethi-note
)
(
disassem:dstate-nextpos
dstate
)))))
(
define-instruction
(
sethi
:disassem-control
#'
sethi-note
)
(
format-2-immed
(
rd
:argument
reg
)
(
format-2-immed
(
rd
:argument
reg
)
(
op2
:constant
#b100
)
(
op2
:constant
#b100
)
(
immed
:argument
(
or
(
unsigned-byte
22
)
(
signed-byte
22
))))
(
immed
:argument
(
or
(
unsigned-byte
22
)
(
signed-byte
22
))))
...
@@ -280,11 +447,12 @@
...
@@ -280,11 +447,12 @@
(
disp
:argument
relative-label
))
(
disp
:argument
relative-label
))
(
format-2-branch
(
op
:constant
#b00
)
(
format-2-branch
(
op
:constant
#b00
)
(
a
:constant
0
)
(
a
:constant
0
)
(
cond
:constant
#b1000
)
(
cond
:constant
branch-cond-true
)
(
op2
:constant
#b010
)
(
op2
:constant
#b010
)
(
disp
:argument
relative-label
)))
(
disp
:argument
relative-label
)))
(
define-instruction
(
ba
)
(
define-instruction
(
ba
:disassem-printer
'
(
"B"
cond
",A"
:tab
disp
))
(
format-2-branch
(
op
:constant
#b00
)
(
format-2-branch
(
op
:constant
#b00
)
(
a
:constant
1
)
(
a
:constant
1
)
(
cond
:argument
branch-condition
)
(
cond
:argument
branch-condition
)
...
@@ -296,7 +464,8 @@
...
@@ -296,7 +464,8 @@
(
op2
:constant
#b010
)
(
op2
:constant
#b010
)
(
disp
:argument
relative-label
)))
(
disp
:argument
relative-label
)))
(
define-instruction
(
t
)
(
define-instruction
(
t
:disassem-printer
'
(
:name
rd
:tab
immed
))
(
format-3-immed
(
op
:constant
#b10
)
(
format-3-immed
(
op
:constant
#b10
)
(
rd
:argument
branch-condition
)
(
rd
:argument
branch-condition
)
(
op3
:constant
#b111010
)
(
op3
:constant
#b111010
)
...
@@ -310,8 +479,16 @@
...
@@ -310,8 +479,16 @@
(
op2
:constant
#b110
)
(
op2
:constant
#b110
)
(
disp
:argument
relative-label
)))
(
disp
:argument
relative-label
)))
;;; slightly complicated to handle both jal and j
(
defconstant
jal-printer
'
(
:name
:tab
(
:choose
(
rs1
(
:unless
(
:constant
0
)
"+"
immed
))
(
:cond
((
rs2
:constant
0
)
rs1
)
((
rs1
:constant
0
)
rs2
)
(
t
rs1
"+"
rs2
)))
(
:unless
(
:constant
0
)
", "
rd
)))
(
define-instruction
(
jal
)
(
define-instruction
(
jal
:disassem-printer
jal-printer
)
(
format-3-reg
(
op
:constant
#b10
)
(
format-3-reg
(
op
:constant
#b10
)
(
rd
:argument
reg
)
(
rd
:argument
reg
)
(
op3
:constant
#b111000
)
(
op3
:constant
#b111000
)
...
@@ -328,7 +505,7 @@
...
@@ -328,7 +505,7 @@
(
rs1
:argument
reg
)
(
rs1
:argument
reg
)
(
immed
:argument
(
signed-byte
13
))))
(
immed
:argument
(
signed-byte
13
))))
(
define-instruction
(
j
)
(
define-instruction
(
j
:disassem-printer
jal-printer
)
(
format-3-reg
(
op
:constant
#b10
)
(
format-3-reg
(
op
:constant
#b10
)
(
rd
:constant
0
)
(
rd
:constant
0
)
(
op3
:constant
#b111000
)
(
op3
:constant
#b111000
)
...
@@ -345,14 +522,19 @@
...
@@ -345,14 +522,19 @@
(
rs1
:argument
reg
)
(
rs1
:argument
reg
)
(
immed
:argument
(
signed-byte
13
))))
(
immed
:argument
(
signed-byte
13
))))
(
define-instruction
(
rdy
)
(
define-instruction
(
rdy
:disassem-printer
'
(
"RD"
:tab
"%Y, "
rd
)
)
(
format-3-immed
(
op
:constant
#b10
)
(
format-3-immed
(
op
:constant
#b10
)
(
rd
:argument
reg
)
(
rd
:argument
reg
)
(
op3
:constant
#b101000
)
(
op3
:constant
#b101000
)
(
rs1
:constant
0
)
(
rs1
:constant
0
)
(
immed
:constant
0
)))
(
immed
:constant
0
)))
(
define-instruction
(
wry
)
(
define-instruction
(
wry
:disassem-printer
'
(
"WR"
:tab
rs1
(
:unless
(
:constant
0
)
", "
(
:choose
immed
rs2
))
", %y"
))
(
format-3-reg
(
op
:constant
#b10
)
(
format-3-reg
(
op
:constant
#b10
)
(
rd
:constant
0
)
(
rd
:constant
0
)
(
op3
:constant
#b110000
)
(
op3
:constant
#b110000
)
...
@@ -369,9 +551,74 @@
...
@@ -369,9 +551,74 @@
(
rs1
:argument
reg
)
(
rs1
:argument
reg
)
(
immed
:argument
(
signed-byte
13
))))
(
immed
:argument
(
signed-byte
13
))))
(
define-instruction
(
unimp
)
;;; ----------------------------------------------------------------
(
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
))))))))
(
defmacro
break-cases
(
breaknum
&body
cases
)
(
let
((
bn-temp
(
gensym
)))
(
collect
((
clauses
))
(
dolist
(
case
cases
)
(
clauses
`
((
=
,
bn-temp
,
(
car
case
))
,@
(
cdr
case
))))
`
(
let
((
,
bn-temp
,
breaknum
))
(
cond
,@
(
clauses
))))))
(
defun
unimp-control
(
chunk
inst
stream
dstate
)
(
flet
((
nt
(
x
)
(
if
stream
(
disassem:note
x
dstate
))))
(
break-cases
(
disassem:arg-value
'data
chunk
inst
)
(
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
:disassem-control
#'
unimp-control
)
(
format-2-unimp
(
data
:argument
(
unsigned-byte
22
))))
(
format-2-unimp
(
data
:argument
(
unsigned-byte
22
))))
;;; ----------------------------------------------------------------
(
eval-when
(
compile
eval
)
(
eval-when
(
compile
eval
)
...
@@ -477,12 +724,14 @@
...
@@ -477,12 +724,14 @@
(
inst
sethi
reg
value
)
(
inst
sethi
reg
value
)
(
inst
add
reg
value
))))
(
inst
add
reg
value
))))
(
define-instruction
(
nop
)
(
define-instruction
(
nop
:disassem-printer
'
(
:name
)
)
(
format-2-immed
(
rd
:constant
0
)
(
format-2-immed
(
rd
:constant
0
)
(
op2
:constant
#b100
)
(
op2
:constant
#b100
)
(
immed
:constant
0
)))
(
immed
:constant
0
)))
(
define-instruction
(
cmp
)
(
define-instruction
(
cmp
:disassem-printer
'
(
:name
:tab
rs1
", "
(
:choose
immed
rs2
)))
(
format-3-reg
(
op
:constant
#b10
)
(
format-3-reg
(
op
:constant
#b10
)
(
rd
:constant
0
)
(
rd
:constant
0
)
(
op3
:constant
#b010100
)
(
op3
:constant
#b010100
)
...
@@ -499,7 +748,9 @@
...
@@ -499,7 +748,9 @@
(
rs1
:argument
reg
)
(
rs1
:argument
reg
)
(
immed
:argument
(
signed-byte
13
))))
(
immed
:argument
(
signed-byte
13
))))
(
define-instruction
(
not
)
(
define-instruction
(
not
:disassem-printer
'
(
:name
:tab
(
:unless
(
:same-as
rd
)
rs1
", "
)
rd
))
(
format-3-reg
(
op
:constant
#b10
)
(
format-3-reg
(
op
:constant
#b10
)
(
rd
:argument
reg
)
(
rd
:argument
reg
)
(
op3
:constant
#b000111
)
(
op3
:constant
#b000111
)
...
@@ -511,7 +762,9 @@
...
@@ -511,7 +762,9 @@
(
rs1
:same-as
rd
)
(
rs1
:same-as
rd
)
(
rs2
:constant
0
)))
(
rs2
:constant
0
)))
(
define-instruction
(
neg
)
(
define-instruction
(
neg
:disassem-printer
'
(
:name
:tab
(
:unless
(
:same-as
rd
)
rs2
", "
)
rd
))
(
format-3-reg
(
op
:constant
#b10
)
(
format-3-reg
(
op
:constant
#b10
)
(
rd
:argument
reg
)
(
rd
:argument
reg
)
(
op3
:constant
#b000100
)
(
op3
:constant
#b000100
)
...
@@ -523,7 +776,7 @@
...
@@ -523,7 +776,7 @@
(
rs1
:constant
0
)
(
rs1
:constant
0
)
(
rs2
:same-as
rd
)))
(
rs2
:same-as
rd
)))
(
define-instruction
(
move
)
(
define-instruction
(
move
:disassem-printer
'
(
:name
:tab
rs2
", "
rd
)
)
(
format-3-reg
(
op
:constant
#b10
)
(
format-3-reg
(
op
:constant
#b10
)
(
rd
:argument
reg
)
(
rd
:argument
reg
)
(
op3
:constant
#b000010
)
(
op3
:constant
#b000010
)
...
...
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