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
c9462790
Commit
c9462790
authored
32 years ago
by
hallgren
Browse files
Options
Downloads
Patches
Plain Diff
New instruction definitions for the new assembler.
parent
e5fac6e8
No related branches found
Branches containing commit
No related tags found
Tags containing commit
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
compiler/sparc/insts.lisp
+478
-848
478 additions, 848 deletions
compiler/sparc/insts.lisp
with
478 additions
and
848 deletions
compiler/sparc/insts.lisp
+
478
−
848
View file @
c9462790
;;; -*- Package: SPARC -*-
;;; -*- Package: SPARC -*-
;;;
;;;
;;; **********************************************************************
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; **********************************************************************
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/insts.lisp,v 1.9 1992/07/09 19:46:32 hallgren Exp $"
)
;;;
;;;
;;;
$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/insts.lisp,v 1.8 1992/03/06 11:01:37 wlott Exp $
;;;
**********************************************************************
;;;
;;;
;;; Description of the SPARC architecture.
;;; Description of the SPARC architecture.
;;;
;;;
;;; Written by William Lott
;;; Written by William Lott.
;;;
;;; Converted to the SPARC by Sean Hallgren.
;;;
;;;
(
in-package
"SPARC"
)
(
in-package
"SPARC"
)
(
use-package
"ASSEM"
)
(
use-package
"NEW-ASSEM"
)
(
use-package
"EXT"
)
(
use-package
"EXT"
)
(
use-package
"C"
)
(
use-package
"C"
)
(
disassem:set-disassem-params
(
def-assembler-params
:instruction-alignment
32
:scheduler-p
nil
)
:storage-class-sets
'
((
register
any-reg
descriptor-reg
base-character-reg
sap-reg
signed-reg
unsigned-reg
non-descriptor-reg
interior-reg
)
(
float-reg
single-reg
double-reg
)
(
control-stack
control-stack
)
(
number-stack
signed-stack
unsigned-stack
base-character-stack
sap-stack
single-stack
double-stack
))
)
;;;; Special argument types and fixups.
;;;; Functions to convert TN's and random symbolic things into values.
(
defvar
*disassem-use-lisp-reg-names*
t
)
(
defun
reg-tn-encoding
(
tn
)
(
declare
(
type
tn
tn
))
(
defconstant
reg-symbols
(
sc-case
tn
(
map
'vector
(
zero
zero-offset
)
#'
(
lambda
(
name
)
(
null
null-offset
)
(
cond
((
null
name
)
nil
)
(
t
(
t
(
make-symbol
(
concatenate
'string
"%"
name
)))))
(
if
(
eq
(
sb-name
(
sc-sb
(
tn-sc
tn
)))
'registers
)
*register-names*
))
(
tn-offset
tn
)
(
error
"~S isn't a register."
tn
)))))
(
define-argument-type
reg
:type
'
(
and
tn
(
defun
fp-reg-tn-encoding
(
tn
&optional
odd
)
(
satisfies
(
lambda
(
object
)
(
declare
(
type
tn
tn
))
(
or
(
eq
(
sc-name
(
tn-sc
object
))
'null
)
(
unless
(
eq
(
sb-name
(
sc-sb
(
tn-sc
tn
)))
'float-registers
)
(
eq
(
sc-name
(
tn-sc
object
))
'zero
)
(
error
"~S isn't a floating-point register."
tn
))
(
eq
(
sb-name
(
sc-sb
(
tn-sc
object
)))
(
if
odd
'registers
)))))
(
1+
(
tn-offset
tn
))
:function
(
lambda
(
tn
)
(
tn-offset
tn
)))
(
case
(
sc-name
(
tn-sc
tn
))
(
null
null-offset
)
(
defconstant
branch-conditions
(
zero
0
)
'
(
:f
:eq
:le
:lt
:leu
:ltu
:n
:vs
:t
:ne
:gt
:ge
:gtu
:geu
:p
:vc
))
(
t
(
tn-offset
tn
))))
:disassem-printer
#'
(
lambda
(
value
stream
dstate
)
(
deftype
branch-condition
()
(
declare
(
stream
stream
)
(
fixnum
value
))
`
(
member
,@
branch-conditions
))
(
let
((
regname
(
aref
reg-symbols
value
)))
(
princ
regname
stream
)
(
defun
branch-condition
(
condition
)
(
disassem:maybe-note-associated-storage-ref
(
or
(
position
condition
branch-conditions
)
value
(
error
"Unknown branch condition: ~S~%Must be one of: ~S"
'register
condition
branch-conditions
)))
regname
dstate
)))
(
defconstant
fp-branch-conditions
)
'
(
:f
:ne
:lg
:ul
:l
:ug
:g
:u
:t
:eq
:ue
:ge
:uge
:le
:ule
:o
))
(
defconstant
float-reg-symbols
(
deftype
fp-branch-condition
()
(
coerce
`
(
member
,@
fp-branch-conditions
))
(
loop
for
n
from
0
to
31
collect
(
make-symbol
(
format
nil
"%F~d"
n
)))
'vector
))
(
defun
fp-branch-condition
(
condition
)
(
or
(
position
condition
fp-branch-conditions
)
(
define-argument-type
fp-reg
(
error
"Unknown fp-branch condition: ~S~%Must be one of: ~S"
:type
'
(
and
tn
condition
fp-branch-conditions
)))
(
satisfies
(
lambda
(
object
)
(
eq
(
sb-name
(
sc-sb
(
tn-sc
object
)))
'float-registers
))))
:function
tn-offset
:disassem-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-reg
regname
dstate
)))
)
(
define-argument-type
odd-fp-reg
:type
'
(
and
tn
(
satisfies
(
lambda
(
object
)
(
eq
(
sb-name
(
sc-sb
(
tn-sc
object
)))
'float-registers
))))
:function
(
lambda
(
tn
)
(
1+
(
tn-offset
tn
))))
(
define-argument-type
relative-label
:type
'label
:function
(
lambda
(
label
)
(
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
)
(
defconstant
branch-conditions
'
(
: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
))
(
define-argument-type
branch-condition
:type
'
(
member
.
#.
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
)
(
defconstant
branch-fp-conditions
'
(
: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
))
(
define-argument-type
branch-fp-condition
:type
'
(
member
.
#.
branch-fp-conditions
)
:function
(
lambda
(
fp-cond
)
(
position
fp-cond
branch-fp-conditions
))
:disassem-printer
branch-fp-cond-name-vec
)
(
define-fixup-type
:call
:disassem-use-label
t
)
(
define-fixup-type
:sethi
:disassem-printer
#'
(
lambda
(
value
stream
dstate
)
(
declare
(
ignore
dstate
))
(
format
stream
"%hi(#x~8,'0x)"
(
ash
value
10
))))
(
define-fixup-type
:add
)
;;;; Formats:
;;;; Primitive emitters.
(
define-format
(
format-1
32
(
define-emitter
emit-word
32
:disassem-printer
'
(
:name
:tab
disp
))
(
byte
32
0
))
(
op
(
byte
2
30
)
:default
1
)
(
disp
(
byte
30
0
)
:default-type
(
unsigned-byte
30
)))
(
define-emitter
emit-short
16
(
byte
16
0
))
(
define-format
(
format-2-immed
32
(
define-emitter
emit-format-1
32
:disassem-printer
'
(
:name
:tab
immed
", "
rd
))
(
byte
2
30
)
(
byte
30
0
))
(
op
(
byte
2
30
)
:default
0
)
(
rd
(
byte
5
25
)
:default-type
reg
)
(
define-emitter
emit-format-2-immed
32
(
op2
(
byte
3
22
))
(
byte
2
30
)
(
byte
5
25
)
(
byte
3
22
)
(
byte
22
0
))
(
immed
(
byte
22
0
)
:default-type
(
signed-byte
22
)))
(
define-emitter
emit-format-2-branch
32
(
defconstant
branch-printer
(
byte
2
30
)
(
byte
1
29
)
(
byte
4
25
)
(
byte
3
22
)
(
byte
22
0
))
`
(
:name
(
:unless
(
:constant
,
branch-cond-true
)
cond
)
(
:unless
(
a
:constant
0
)
","
'A
)
(
define-emitter
emit-format-2-unimp
32
:tab
(
byte
2
30
)
(
byte
5
25
)
(
byte
3
22
)
(
byte
22
0
))
disp
))
(
define-emitter
emit-format-3-reg
32
(
define-format
(
format-2-branch
32
:disassem-printer
branch-printer
)
(
byte
2
30
)
(
byte
5
25
)
(
byte
6
19
)
(
byte
5
14
)
(
byte
1
13
)
(
byte
8
5
)
(
op
(
byte
2
30
)
:default
0
)
(
byte
5
0
))
(
a
(
byte
1
29
))
(
cond
(
byte
4
25
)
:default-type
branch-condition
)
(
define-emitter
emit-format-3-immed
32
(
op2
(
byte
3
22
))
(
byte
2
30
)
(
byte
5
25
)
(
byte
6
19
)
(
byte
5
14
)
(
byte
1
13
)
(
byte
13
0
))
(
disp
(
byte
22
0
)
:default-type
relative-label
))
(
define-format
(
format-2-unimp
32
(
define-emitter
emit-format-3-fpop
32
:disassem-printer
'
(
:name
:tab
data
))
(
byte
2
30
)
(
byte
5
25
)
(
byte
6
19
)
(
byte
5
14
)
(
byte
9
5
)
(
byte
5
0
))
(
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
))
;;;;
I
nstructions.
;;;;
Buncha format-3-i
nstructions.
(
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
&key
load-store
fixup
odd
)
(
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
(
fp-reg-tn-encoding
dst
odd
)
op3
(
reg-tn-encoding
src1
)
0
0
(
reg-tn-encoding
src2
)))
(
integer
(
emit-format-3-immed
segment
op
(
fp-reg-tn-encoding
dst
odd
)
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
(
fp-reg-tn-encoding
dst
odd
)
op3
(
reg-tn-encoding
src1
)
1
0
))))
(
eval-when
(
compile
eval
)
(
eval-when
(
compile
eval
)
;;; have to do this because defconstant is evalutated in the null lex env.
(
defmacro
define-f3-inst
(
name
op
op3
&key
fixup
load-store
dest-kind
)
(
defmacro
with-ref-format
(
printer
)
`
(
define-instruction
,
name
(
segment
dst
src1
&optional
src2
)
`
(
let*
((
i-or-r
(
:declare
(
type
tn
dst
)
'
(
:choose
immed
rs2
))
,
(
if
(
or
fixup
load-store
)
(
ref-format
'
(
type
(
or
tn
(
signed-byte
13
)
null
fixup
)
src1
src2
)
`
(
"["
rs1
(
:unless
(
:constant
0
)
"+"
,
i-or-r
)
"]"
'
(
type
(
or
tn
(
signed-byte
13
)
null
)
src1
src2
)))
(
:choose
(
:unless
(
:constant
0
)
asi
)
nil
))))
,
(
if
dest-kind
,
printer
))
`
(
:emitter
(
emit-fp-format-3-inst
segment
,
op
,
op3
dst
src1
src2
:load-store
,
load-store
(
defconstant
load-printer
:fixup
,
fixup
(
with-ref-format
`
(
:NAME
:TAB
,
ref-format
", "
rd
)))
:odd
(
eq
',dest-kind
'odd-fp-reg
)))
(
defconstant
store-printer
`
(
:emitter
(
emit-format-3-inst
segment
,
op
,
op3
dst
src1
src2
(
with-ref-format
`
(
:NAME
:TAB
rd
", "
,
ref-format
)))
:load-store
,
load-store
:fixup
,
fixup
)))))
(
defmacro
define-f3-inst
(
name
op
op3
&key
(
dest-kind
'reg
)
fixup
load-store
disassem-printer
)
`
(
define-instruction
(
,
name
)
; eval-when (compile eval)
,@
(
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
)
(
rd
:argument
,
dest-kind
)
(
op3
:constant
,
op3
)
(
rs1
:argument
reg
)
(
rs2
:argument
reg
))
,
(
if
(
not
load-store
)
`
(
format-3-reg
(
op
:constant
,
op
)
(
rd
:argument
,
dest-kind
)
(
op3
:constant
,
op3
)
(
rs1
:same-as
rd
)
(
rs2
:argument
reg
))
`
(
format-3-immed
(
op
:constant
,
op
)
(
rd
:argument
,
dest-kind
)
(
op3
:constant
,
op3
)
(
rs1
:argument
reg
)
(
immed
:constant
0
)))
(
format-3-immed
(
op
:constant
,
op
)
(
rd
:argument
,
dest-kind
)
(
op3
:constant
,
op3
)
(
rs1
:argument
reg
)
(
immed
:argument
(
signed-byte
13
)))
(
format-3-immed
(
op
:constant
,
op
)
(
rd
:argument
,
dest-kind
)
(
op3
:constant
,
op3
)
(
rs1
:same-as
rd
)
(
immed
:argument
(
signed-byte
13
)))
,@
(
when
(
or
load-store
fixup
)
`
((
format-3-immed
(
op
:constant
,
op
)
(
rd
:argument
,
dest-kind
)
(
op3
:constant
,
op3
)
(
rs1
:argument
reg
)
(
immed
:argument
add-fixup
))
(
format-3-immed
(
op
:constant
,
op
)
(
rd
:argument
,
dest-kind
)
(
op3
:constant
,
op3
)
(
rs1
:same-as
rd
)
(
immed
:argument
add-fixup
))))))
(
setf
(
macro-function
'define-f3-inst
)
(
compile
nil
(
function-lambda-expression
(
macro-function
'define-f3-inst
))))
)
; eval-when
(
define-f3-inst
ldsb
#b11
#b001001
:load-store
:load
)
(
define-f3-inst
ldsb
#b11
#b001001
:load-store
:load
)
(
define-f3-inst
ldsh
#b11
#b001010
:load-store
:load
)
(
define-f3-inst
ldsh
#b11
#b001010
:load-store
:load
)
(
define-f3-inst
ldub
#b11
#b000001
:load-store
:load
)
(
define-f3-inst
ldub
#b11
#b000001
:load-store
:load
)
(
define-f3-inst
lduh
#b11
#b000010
:load-store
:load
)
(
define-f3-inst
lduh
#b11
#b000010
:load-store
:load
)
;;; ----------------------------------------------------------------
(
define-f3-inst
ld
#b11
#b000000
:load-store
:load
)
(
define-f3-inst
ld
#b11
#b000000
:load-store
:load
)
(
defun
note-niss-ref
(
chunk
inst
stream
dstate
)
(
when
stream
(
disassem:maybe-note-nil-indexed-symbol-slot-ref
(
disassem:arg-value
'immed
chunk
inst
)
dstate
)))
(
defun
note-control-stack-var-ref
(
chunk
inst
stream
dstate
)
(
when
stream
(
disassem:maybe-note-single-storage-ref
(
/
(
disassem:arg-value
'immed
chunk
inst
)
word-bytes
)
'control-stack
dstate
))
)
(
defun
note-number-stack-var-ref
(
chunk
inst
stream
dstate
)
(
when
stream
(
disassem:maybe-note-single-storage-ref
(
/
(
disassem:arg-value
'immed
chunk
inst
)
word-bytes
)
'number-stack
dstate
))
)
(
disassem:specialize
(
ld
:disassem-control
#'
(
lambda
(
chunk
inst
stream
dstate
)
(
when
stream
(
disassem:note-code-constant
(
disassem:arg-value
'immed
chunk
inst
)
dstate
))))
immed
(
rs1
:constant
code-offset
))
(
disassem:specialize
(
ld
:disassem-control
#'
note-niss-ref
)
immed
(
rs1
:constant
null-offset
))
(
disassem:specialize
(
ld
:disassem-control
#'
note-control-stack-var-ref
)
immed
(
rs1
:constant
cfp-offset
))
(
disassem:specialize
(
ld
:disassem-control
#'
note-number-stack-var-ref
)
immed
(
rs1
:constant
nfp-offset
))
;;; ----------------------------------------------------------------
(
define-f3-inst
ldd
#b11
#b000011
:load-store
:load
)
(
define-f3-inst
ldd
#b11
#b000011
:load-store
:load
)
(
disassem:specialize
(
ldd
:disassem-control
#'
note-number-stack-var-ref
)
immed
(
rs1
:constant
nfp-offset
))
(
define-f3-inst
ldf
#b11
#b100000
:dest-kind
fp-reg
:load-store
:load
)
(
define-f3-inst
ldf
#b11
#b100000
:dest-kind
fp-reg
:load-store
:load
)
(
disassem:specialize
(
ldf
:disassem-control
#'
note-number-stack-var-ref
)
immed
(
rs1
:constant
nfp-offset
))
(
define-f3-inst
ldf-odd
#b11
#b100000
:dest-kind
odd-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
lddf
#b11
#b100011
:dest-kind
fp-reg
:load-store
:load
)
(
disassem:specialize
(
lddf
:disassem-control
#'
note-number-stack-var-ref
)
immed
(
rs1
:constant
nfp-offset
))
(
define-f3-inst
stb
#b11
#b000101
:load-store
:store
)
(
define-f3-inst
stb
#b11
#b000101
:load-store
:store
)
(
define-f3-inst
sth
#b11
#b000110
:load-store
:store
)
(
define-f3-inst
sth
#b11
#b000110
:load-store
:store
)
;;; ----------------------------------------------------------------
(
define-f3-inst
st
#b11
#b000100
:load-store
:store
)
(
define-f3-inst
st
#b11
#b000100
:load-store
:store
)
(
disassem:specialize
(
st
:disassem-control
#'
note-niss-ref
)
immed
(
rs1
:constant
null-offset
))
(
disassem:specialize
(
st
:disassem-control
#'
note-control-stack-var-ref
)
immed
(
rs1
:constant
cfp-offset
))
(
disassem:specialize
(
st
:disassem-control
#'
note-number-stack-var-ref
)
immed
(
rs1
:constant
nfp-offset
))
;;; ----------------------------------------------------------------
(
define-f3-inst
std
#b11
#b000111
:load-store
:store
)
(
define-f3-inst
std
#b11
#b000111
:load-store
:store
)
(
disassem:specialize
(
std
:disassem-control
#'
note-number-stack-var-ref
)
immed
(
rs1
:constant
nfp-offset
))
(
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
)
(
disassem:specialize
(
stf
:disassem-control
#'
note-number-stack-var-ref
)
(
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
)
immed
(
rs1
:constant
nfp-offset
))
(
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
)
(
disassem:specialize
(
stdf
:disassem-control
#'
note-number-stack-var-ref
)
immed
(
rs1
:constant
nfp-offset
))
(
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-instruction
(
ldfsr
)
(
format-3-immed
(
op
:constant
#b11
)
(
rd
:constant
0
)
(
op3
:constant
#b100001
)
(
rs1
:argument
reg
)
(
immed
:argument
(
signed-byte
13
))))
(
define-instruction
(
stfsr
)
(
format-3-immed
(
op
:constant
#b11
)
(
rd
:constant
0
)
(
op3
:constant
#b100101
)
(
rs1
:argument
reg
)
(
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
'rs1
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
)
(
define-f3-inst
taddcc
#b10
#b100000
)
(
define-f3-inst
taddcc
#b10
#b100000
)
(
define-f3-inst
taddcctv
#b10
#b100010
)
(
define-f3-inst
taddcctv
#b10
#b100010
)
(
define-f3-inst
sub
#b10
#b000100
)
(
define-f3-inst
sub
#b10
#b000100
)
(
define-f3-inst
subcc
#b10
#b010100
)
(
define-f3-inst
subcc
#b10
#b010100
)
(
define-f3-inst
subx
#b10
#b001100
)
(
define-f3-inst
subx
#b10
#b001100
)
(
define-f3-inst
subxcc
#b10
#b011100
)
(
define-f3-inst
subxcc
#b10
#b011100
)
(
define-f3-inst
tsubcc
#b10
#b100001
)
(
define-f3-inst
tsubcc
#b10
#b100001
)
(
define-f3-inst
tsubcctv
#b10
#b100011
)
(
define-f3-inst
tsubcctv
#b10
#b100011
)
(
define-f3-inst
mulscc
#b10
#b100100
)
(
define-f3-inst
mulscc
#b10
#b100100
)
(
define-f3-inst
and
#b10
#b000001
)
(
define-f3-inst
and
#b10
#b000001
)
(
define-f3-inst
andcc
#b10
#b010001
)
(
define-f3-inst
andcc
#b10
#b010001
)
(
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
)
...
@@ -486,267 +212,168 @@
...
@@ -486,267 +212,168 @@
(
define-f3-inst
xorcc
#b10
#b010011
)
(
define-f3-inst
xorcc
#b10
#b010011
)
(
define-f3-inst
xnor
#b10
#b000111
)
(
define-f3-inst
xnor
#b10
#b000111
)
(
define-f3-inst
xnorcc
#b10
#b010111
)
(
define-f3-inst
xnorcc
#b10
#b010111
)
(
define-f3-inst
sll
#b10
#b100101
)
(
define-f3-inst
sll
#b10
#b100101
)
(
define-f3-inst
srl
#b10
#b100110
)
(
define-f3-inst
srl
#b10
#b100110
)
(
define-f3-inst
sra
#b10
#b100111
)
(
define-f3-inst
sra
#b10
#b100111
)
(
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
)
(
op2
:constant
#b100
)
(
immed
:argument
(
or
(
unsigned-byte
22
)
(
signed-byte
22
))))
(
format-2-immed
(
rd
:argument
reg
)
(
op2
:constant
#b100
)
(
immed
:argument
sethi-fixup
)))
(
define-f3-inst
save
#b10
#b111100
)
(
define-f3-inst
save
#b10
#b111100
)
(
define-f3-inst
restore
#b10
#b111101
)
(
define-f3-inst
restore
#b10
#b111101
)
(
define-instruction
(
b
)
(
format-2-branch
(
op
:constant
#b00
)
;;;; Random instructions.
(
a
:constant
0
)
(
cond
:argument
branch-condition
)
(
define-instruction
ldfsr
(
segment
src1
src2
)
(
op2
:constant
#b010
)
(
:declare
(
type
tn
src1
)
(
type
(
signed-byte
13
)
src2
))
(
disp
:argument
relative-label
))
(
:emitter
(
emit-format-3-immed
segment
#b11
0
#b100001
(
format-2-branch
(
op
:constant
#b00
)
(
reg-tn-encoding
src1
)
1
src2
)))
(
a
:constant
0
)
(
cond
:constant
branch-cond-true
)
(
define-instruction
stfsr
(
segment
src1
src2
)
(
op2
:constant
#b010
)
(
:declare
(
type
tn
src1
)
(
type
(
signed-byte
13
)
src2
))
(
disp
:argument
relative-label
)))
(
:emitter
(
emit-format-3-immed
segment
#b11
0
#b100101
(
reg-tn-encoding
src1
)
1
src2
)))
(
define-instruction
(
ba
)
(
format-2-branch
(
op
:constant
#b00
)
(
define-instruction
sethi
(
segment
dst
src1
)
(
a
:constant
1
)
(
:declare
(
type
tn
dst
)
(
cond
:argument
branch-condition
)
(
type
(
or
(
signed-byte
22
)
(
unsigned-byte
22
)
fixup
)
src1
))
(
op2
:constant
#b010
)
(
:emitter
(
disp
:argument
relative-label
))
(
etypecase
src1
(
format-2-branch
(
op
:constant
#b00
)
(
integer
(
a
:constant
1
)
(
emit-format-2-immed
segment
#b00
(
reg-tn-encoding
dst
)
#b100
(
cond
:constant
#b1000
)
src1
))
(
op2
:constant
#b010
)
(
fixup
(
disp
:argument
relative-label
)))
(
note-fixup
segment
:sethi
src1
)
(
disassem:specialize
(
ba
:name
'b
))
(
emit-format-2-immed
segment
#b00
(
reg-tn-encoding
dst
)
#b100
0
)))))
(
define-instruction
(
t
:disassem-printer
'
(
:name
rd
:tab
immed
))
(
define-instruction
rdy
(
segment
dst
)
(
format-3-immed
(
op
:constant
#b10
)
(
:declare
(
type
tn
dst
))
(
rd
:argument
branch-condition
)
(
:emitter
(
emit-format-3-immed
segment
#b10
(
reg-tn-encoding
dst
)
#b101000
(
op3
:constant
#b111010
)
0
1
0
)))
(
rs1
:constant
0
)
(
immed
:argument
(
or
(
signed-byte
13
)
(
unsigned-byte
13
)))))
(
define-instruction
wry
(
segment
src1
&optional
src2
)
(
:declare
(
type
tn
src1
)
(
type
(
or
(
signed-byte
13
)
tn
null
)
src2
))
(
define-instruction
(
fb
)
(
:emitter
(
format-2-branch
(
op
:constant
#b00
)
(
etypecase
src2
(
a
:constant
0
)
(
null
(
cond
:argument
branch-fp-condition
)
(
emit-format-3-reg
segment
#b10
0
#b110000
(
reg-tn-encoding
src1
)
0
0
0
))
(
op2
:constant
#b110
)
(
tn
(
disp
:argument
relative-label
)))
(
emit-format-3-reg
segment
#b10
0
#b110000
(
reg-tn-encoding
src1
)
0
0
(
reg-tn-encoding
src2
)))
;;; slightly complicated to handle both jal and j
(
integer
(
defconstant
jal-printer
(
emit-format-3-immed
segment
#b10
0
#b110000
(
reg-tn-encoding
src1
)
1
'
(
:name
:tab
src2
)))))
(
:choose
(
rs1
(
:unless
(
:constant
0
)
"+"
immed
))
(
:cond
((
rs2
:constant
0
)
rs1
)
(
define-instruction
unimp
(
segment
data
)
((
rs1
:constant
0
)
rs2
)
(
:declare
(
type
(
unsigned-byte
22
)
data
))
(
t
rs1
"+"
rs2
)))
(
:emitter
(
emit-format-2-unimp
segment
0
0
0
data
)))
(
:unless
(
:constant
0
)
", "
rd
)))
(
define-instruction
(
jal
:disassem-printer
jal-printer
)
(
format-3-reg
(
op
:constant
#b10
)
(
rd
:argument
reg
)
(
op3
:constant
#b111000
)
(
rs1
:argument
reg
)
(
rs2
:argument
reg
))
(
format-3-reg
(
op
:constant
#b10
)
(
rd
:argument
reg
)
(
op3
:constant
#b111000
)
(
rs1
:constant
0
)
(
rs2
:argument
reg
))
(
format-3-immed
(
op
:constant
#b10
)
(
rd
:argument
reg
)
(
op3
:constant
#b111000
)
(
rs1
:argument
reg
)
(
immed
:argument
(
signed-byte
13
)))
(
format-3-immed
(
op
:constant
#b10
)
(
rd
:argument
reg
)
(
op3
:constant
#b111000
)
(
rs1
:argument
reg
)
(
immed
:argument
add-fixup
)))
(
disassem:specialize
(
jal
:disassem-control
#'
look-at-sethi-note
)
immed
)
(
define-instruction
(
j
:disassem-printer
jal-printer
)
(
format-3-reg
(
op
:constant
#b10
)
(
rd
:constant
0
)
(
op3
:constant
#b111000
)
(
rs1
:argument
reg
)
(
rs2
:argument
reg
))
(
format-3-reg
(
op
:constant
#b10
)
(
rd
:constant
0
)
(
op3
:constant
#b111000
)
(
rs1
:argument
reg
)
(
rs2
:constant
0
))
(
format-3-immed
(
op
:constant
#b10
)
(
rd
:constant
0
)
(
op3
:constant
#b111000
)
(
rs1
:argument
reg
)
(
immed
:argument
(
signed-byte
13
)))
(
format-3-immed
(
op
:constant
#b10
)
(
rd
:constant
0
)
(
op3
:constant
#b111000
)
(
rs1
:argument
reg
)
(
immed
:argument
add-fixup
)))
(
disassem:specialize
(
j
:disassem-control
#'
look-at-sethi-note
)
immed
)
(
define-instruction
(
rdy
:disassem-printer
'
(
'RD
:tab
'%Y
", "
rd
))
(
format-3-immed
(
op
:constant
#b10
)
(
rd
:argument
reg
)
(
op3
:constant
#b101000
)
(
rs1
:constant
0
)
(
immed
:constant
0
)))
(
define-instruction
(
wry
:disassem-printer
'
(
'WR
:tab
rs1
(
:unless
(
:constant
0
)
", "
(
:choose
immed
rs2
))
", "
'%Y
))
(
format-3-reg
(
op
:constant
#b10
)
(
rd
:constant
0
)
(
op3
:constant
#b110000
)
(
rs1
:argument
reg
)
(
rs2
:argument
reg
))
(
format-3-reg
(
op
:constant
#b10
)
(
rd
:constant
0
)
(
op3
:constant
#b110000
)
(
rs1
:argument
reg
)
(
rs2
:constant
0
))
(
format-3-immed
(
op
:constant
#b10
)
(
rd
:constant
0
)
(
op3
:constant
#b110000
)
(
rs1
:argument
reg
)
(
immed
:argument
(
signed-byte
13
))))
;;; ----------------------------------------------------------------
(
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
))))
;;; ----------------------------------------------------------------
;;;; Branch instructions.
(
defun
emit-relative-branch
(
segment
a
op2
cond-or-target
target
&optional
fp
)
(
emit-back-patch
segment
4
#'
(
lambda
(
segment
posn
)
(
unless
target
(
setf
target
cond-or-target
)
(
setf
cond-or-target
:t
))
(
emit-format-2-branch
segment
#b00
a
(
if
fp
(
fp-branch-condition
cond-or-target
)
(
branch-condition
cond-or-target
))
op2
(
ash
(
-
(
label-position
target
)
posn
)
-2
)))))
(
define-instruction
b
(
segment
cond-or-target
&optional
target
)
(
:declare
(
type
(
or
label
branch-condition
)
cond-or-target
)
(
type
(
or
label
null
)
target
))
(
:emitter
(
emit-relative-branch
segment
0
#b010
cond-or-target
target
)))
(
define-instruction
ba
(
segment
cond-or-target
&optional
target
)
(
:declare
(
type
(
or
label
branch-condition
)
cond-or-target
)
(
type
(
or
label
null
)
target
))
(
:emitter
(
emit-relative-branch
segment
1
#b010
cond-or-target
target
)))
(
define-instruction
t
(
segment
condition
target
)
(
:declare
(
type
branch-condition
condition
)
(
type
(
or
(
signed-byte
13
)
(
unsigned-byte
13
))
target
))
(
:emitter
(
emit-format-3-immed
segment
#b10
(
branch-condition
condition
)
#b111010
0
1
target
)))
(
define-instruction
fb
(
segment
condition
target
)
(
:declare
(
type
fp-branch-condition
condition
)
(
type
label
target
))
(
:emitter
(
emit-relative-branch
segment
0
#b110
condition
target
t
)))
(
define-instruction
jal
(
segment
dst
src1
&optional
src2
)
(
:declare
(
type
tn
dst
)
(
type
(
or
tn
integer
)
src1
)
(
type
(
or
null
fixup
tn
(
signed-byte
13
))
src2
))
(
:emitter
(
unless
src2
(
setf
src2
src1
)
(
setf
src1
0
))
(
etypecase
src2
(
tn
(
emit-format-3-reg
segment
#b10
(
reg-tn-encoding
dst
)
#b111000
(
if
(
integerp
src1
)
src1
(
reg-tn-encoding
src1
))
0
0
(
reg-tn-encoding
src2
)))
(
integer
(
emit-format-3-immed
segment
#b10
(
reg-tn-encoding
dst
)
#b111000
(
reg-tn-encoding
src1
)
1
src2
))
(
fixup
(
note-fixup
segment
:add
src2
)
(
emit-format-3-immed
segment
#b10
(
reg-tn-encoding
dst
)
#b111000
(
reg-tn-encoding
src1
)
1
0
)))))
(
define-instruction
j
(
segment
src1
&optional
src2
)
(
:declare
(
type
tn
src1
)
(
type
(
or
tn
(
signed-byte
13
)
fixup
null
)
src2
))
(
:emitter
(
etypecase
src2
(
null
(
emit-format-3-reg
segment
#b10
0
#b111000
(
reg-tn-encoding
src1
)
0
0
0
))
(
tn
(
emit-format-3-reg
segment
#b10
0
#b111000
(
reg-tn-encoding
src1
)
0
0
(
reg-tn-encoding
src2
)))
(
integer
(
emit-format-3-immed
segment
#b10
0
#b111000
(
reg-tn-encoding
src1
)
1
src2
))
(
fixup
(
note-fixup
segment
:add
src2
)
(
emit-format-3-immed
segment
#b10
0
#b111000
(
reg-tn-encoding
src1
)
1
0
)))))
;;;; Unary and binary fp insts.
(
defun
emit-fp-inst
(
segment
opf
op3
dst
src1
src2
)
(
unless
src2
(
setf
src2
src1
)
(
setf
src1
dst
))
(
emit-format-3-fpop
segment
#b10
(
fp-reg-tn-encoding
dst
)
op3
(
fp-reg-tn-encoding
src1
)
opf
(
fp-reg-tn-encoding
src2
)))
(
eval-when
(
compile
eval
)
(
eval-when
(
compile
eval
)
(
defmacro
define-unary-fp-inst
(
name
opf
&optional
odd
)
(
defmacro
define-unary-fp-inst
(
name
opf
)
(
let
((
kind
(
if
odd
'odd-fp-reg
'fp-reg
)))
`
(
define-instruction
,
name
(
segment
dst
src1
&optional
src2
)
`
(
define-instruction
(
,
name
)
(
:declare
(
type
tn
dst
src1
)
(
type
(
or
null
tn
)
src2
))
(
format-3-fpop
(
op
:constant
#b10
)
(
:emitter
(
emit-fp-inst
segment
,
opf
#b110100
dst
src1
src2
))))
(
rd
:argument
,
kind
)
(
op3
:constant
#b110100
)
(
rs1
:argument
,
kind
)
(
opf
:constant
,
opf
)
(
rs2
:argument
,
kind
))
(
format-3-fpop
(
op
:constant
#b10
)
(
rd
:argument
,
kind
)
(
op3
:constant
#b110100
)
(
rs1
:same-as
rd
)
(
opf
:constant
,
opf
)
(
rs2
:argument
,
kind
)))))
(
defmacro
define-binary-fp-inst
(
name
opf
&optional
(
op3
#b110100
))
(
defmacro
define-binary-fp-inst
(
name
opf
&optional
(
op3
#b110100
))
`
(
define-instruction
(
,
name
)
`
(
define-instruction
,
name
(
segment
dst
src1
&optional
src2
)
(
format-3-fpop
(
op
:constant
#b10
)
(
:declare
(
type
tn
dst
src1
)
(
type
(
or
null
tn
)
src2
))
(
rd
:argument
fp-reg
)
(
:emitter
(
emit-fp-inst
segment
,
opf
,
op3
dst
src1
src2
))))
(
op3
:constant
,
op3
)
(
rs1
:argument
fp-reg
)
(
opf
:constant
,
opf
)
(
rs2
:argument
fp-reg
))
(
format-3-fpop
(
op
:constant
#b10
)
(
rd
:argument
fp-reg
)
(
op3
:constant
,
op3
)
(
rs1
:same-as
rd
)
(
opf
:constant
,
opf
)
(
rs2
:argument
fp-reg
))))
)
; eval-when (compile eval)
)
; eval-when (compile eval)
(
define-unary-fp-inst
fitos
#b011000100
)
(
define-unary-fp-inst
fitos
#b011000100
)
(
define-unary-fp-inst
fitod
#b011001000
)
(
define-unary-fp-inst
fitod
#b011001000
)
(
define-unary-fp-inst
fitox
#b011001100
)
(
define-unary-fp-inst
fitox
#b011001100
)
...
@@ -767,7 +394,7 @@
...
@@ -767,7 +394,7 @@
(
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
t
)
(
define-unary-fp-inst
fmovs-odd
#b000000001
)
(
define-unary-fp-inst
fnegs
#b000000101
)
(
define-unary-fp-inst
fnegs
#b000000101
)
(
define-unary-fp-inst
fabss
#b000001001
)
(
define-unary-fp-inst
fabss
#b000001001
)
...
@@ -776,6 +403,7 @@
...
@@ -776,6 +403,7 @@
(
define-unary-fp-inst
fsqrtx
#b000101011
)
(
define-unary-fp-inst
fsqrtx
#b000101011
)
(
define-binary-fp-inst
fadds
#b001000001
)
(
define-binary-fp-inst
fadds
#b001000001
)
(
define-binary-fp-inst
faddd
#b001000010
)
(
define-binary-fp-inst
faddd
#b001000010
)
(
define-binary-fp-inst
faddx
#b001000011
)
(
define-binary-fp-inst
faddx
#b001000011
)
...
@@ -798,197 +426,199 @@
...
@@ -798,197 +426,199 @@
(
define-binary-fp-inst
fcmpex
#b001010111
#b110101
)
(
define-binary-fp-inst
fcmpex
#b001010111
#b110101
)
;;;; Pseudo-instructions, etc.
;;;; li, jali, ji, nop, cmp, not, neg, move, and more
(
define-pseudo-instruction
li
64
(
reg
value
)
(
define-instruction
li
(
segment
reg
value
)
(
etypecase
value
(
:declare
(
type
tn
reg
)
((
signed-byte
13
)
(
type
(
or
(
signed-byte
13
)
(
signed-byte
32
)
(
unsigned-byte
32
)
(
inst
add
reg
zero-tn
value
))
fixup
)
value
))
((
or
(
signed-byte
32
)
(
unsigned-byte
32
))
(
:vop-var
vop
)
(
let
((
hi
(
ldb
(
byte
22
10
)
value
))
(
:emitter
(
lo
(
ldb
(
byte
10
0
)
value
)))
(
assemble
(
segment
vop
)
(
inst
sethi
reg
hi
)
(
etypecase
value
(
unless
(
zerop
lo
)
((
signed-byte
13
)
(
inst
add
reg
lo
))))
(
inst
add
reg
zero-tn
value
))
(
fixup
((
or
(
signed-byte
32
)
(
unsigned-byte
32
))
(
inst
sethi
reg
value
)
(
let
((
hi
(
ldb
(
byte
22
10
)
value
))
(
inst
add
reg
value
))))
(
lo
(
ldb
(
byte
10
0
)
value
)))
(
inst
sethi
reg
hi
)
(
unless
(
zerop
lo
)
(
inst
add
reg
lo
))))
(
fixup
(
inst
sethi
reg
value
)
(
inst
add
reg
value
))))))
;;; Jal to a full 32-bit address. Tmpreg is trashed.
;;; Jal to a full 32-bit address. Tmpreg is trashed.
(
define-pseudo-instruction
jali
64
(
link
tmpreg
value
)
(
define-instruction
jali
(
segment
link
tmpreg
value
)
(
etypecase
value
(
:declare
(
type
tn
link
tmpreg
)
((
signed-byte
13
)
(
type
(
or
(
signed-byte
13
)
(
signed-byte
32
)
(
unsigned-byte
32
)
(
inst
jal
link
zero-tn
value
))
fixup
)
value
))
((
or
(
signed-byte
32
)
(
unsigned-byte
32
))
(
:vop-var
vop
)
(
let
((
hi
(
ldb
(
byte
22
10
)
value
))
(
:emitter
(
lo
(
ldb
(
byte
10
0
)
value
)))
(
assemble
(
segment
vop
)
(
inst
sethi
tmpreg
hi
)
(
etypecase
value
(
inst
jal
link
tmpreg
lo
)))
((
signed-byte
13
)
(
fixup
(
inst
jal
link
zero-tn
value
))
(
inst
sethi
tmpreg
value
)
((
or
(
signed-byte
32
)
(
unsigned-byte
32
))
(
inst
jal
link
tmpreg
value
))))
(
let
((
hi
(
ldb
(
byte
22
10
)
value
))
(
lo
(
ldb
(
byte
10
0
)
value
)))
(
inst
sethi
tmpreg
hi
)
(
inst
jal
link
tmpreg
lo
)))
(
fixup
(
inst
sethi
tmpreg
value
)
(
inst
jal
link
tmpreg
value
))))))
;;; Jump to a full 32-bit address. Tmpreg is trashed.
;;; Jump to a full 32-bit address. Tmpreg is trashed.
(
define-pseudo-instruction
ji
64
(
tmpreg
value
)
(
define-instruction
ji
(
segment
tmpreg
value
)
(
inst
jali
zero-tn
tmpreg
value
))
(
:declare
(
type
tn
tmpreg
)
(
type
(
or
(
signed-byte
13
)
(
signed-byte
32
)
(
unsigned-byte
32
)
(
define-instruction
(
nop
:disassem-printer
'
(
:name
))
fixup
)
value
))
(
format-2-immed
(
rd
:constant
0
)
(
:vop-var
vop
)
(
op2
:constant
#b100
)
(
:emitter
(
immed
:constant
0
)))
(
assemble
(
segment
vop
)
(
inst
jali
zero-tn
tmpreg
value
))))
(
define-instruction
(
cmp
:disassem-printer
(
define-instruction
nop
(
segment
)
'
(
:name
:tab
rs1
", "
(
:choose
immed
rs2
)))
(
:emitter
(
emit-format-2-immed
segment
0
0
#b100
0
)))
(
format-3-reg
(
op
:constant
#b10
)
(
rd
:constant
0
)
(
define-instruction
cmp
(
segment
src1
&optional
src2
)
(
op3
:constant
#b010100
)
(
:declare
(
type
tn
src1
)
(
type
(
or
null
tn
(
signed-byte
13
))
src2
))
(
rs1
:argument
reg
)
(
:emitter
(
rs2
:argument
reg
))
(
etypecase
src2
(
format-3-reg
(
op
:constant
#b10
)
(
null
(
rd
:constant
0
)
(
emit-format-3-reg
segment
#b10
0
#b010100
(
reg-tn-encoding
src1
)
0
0
0
))
(
op3
:constant
#b010100
)
(
tn
(
rs1
:argument
reg
)
(
emit-format-3-reg
segment
#b10
0
#b010100
(
reg-tn-encoding
src1
)
0
0
(
rs2
:constant
0
))
(
reg-tn-encoding
src2
)))
(
format-3-immed
(
op
:constant
#b10
)
(
integer
(
rd
:constant
0
)
(
emit-format-3-immed
segment
#b10
0
#b010100
(
reg-tn-encoding
src1
)
1
(
op3
:constant
#b010100
)
src2
)))))
(
rs1
:argument
reg
)
(
immed
:argument
(
signed-byte
13
))))
(
define-instruction
not
(
segment
dst
&optional
src1
)
(
:declare
(
type
tn
dst
)
(
type
(
or
tn
null
)
src1
))
(
define-instruction
(
not
(
:emitter
:disassem-printer
(
unless
src1
'
(
:name
:tab
(
:unless
(
:same-as
rd
)
rs1
", "
)
rd
))
(
setf
src1
dst
))
(
format-3-reg
(
op
:constant
#b10
)
(
emit-format-3-reg
segment
#b10
(
reg-tn-encoding
dst
)
#b000111
(
rd
:argument
reg
)
(
reg-tn-encoding
src1
)
0
0
0
)))
(
op3
:constant
#b000111
)
(
rs1
:argument
reg
)
(
define-instruction
neg
(
segment
dst
&optional
src1
)
(
rs2
:constant
0
))
(
:declare
(
type
tn
dst
)
(
type
(
or
tn
null
)
src1
))
(
format-3-reg
(
op
:constant
#b10
)
(
:emitter
(
rd
:argument
reg
)
(
unless
src1
(
op3
:constant
#b000111
)
(
setf
src1
dst
))
(
rs1
:same-as
rd
)
(
emit-format-3-reg
segment
#b10
(
reg-tn-encoding
dst
)
#b000100
(
rs2
:constant
0
)))
0
0
0
(
reg-tn-encoding
src1
))))
(
define-instruction
(
neg
(
define-instruction
move
(
segment
dst
src1
)
:disassem-printer
(
:declare
(
type
tn
dst
src1
))
'
(
:name
:tab
(
:unless
(
:same-as
rd
)
rs2
", "
)
rd
))
(
:emitter
(
emit-format-3-reg
segment
#b10
(
reg-tn-encoding
dst
)
#b000010
(
format-3-reg
(
op
:constant
#b10
)
0
0
0
(
reg-tn-encoding
src1
))))
(
rd
:argument
reg
)
(
op3
:constant
#b000100
)
(
rs1
:constant
0
)
(
rs2
:argument
reg
))
(
format-3-reg
(
op
:constant
#b10
)
(
rd
:argument
reg
)
(
op3
:constant
#b000100
)
(
rs1
:constant
0
)
(
rs2
:same-as
rd
)))
(
define-instruction
(
move
:disassem-printer
'
(
:name
:tab
rs2
", "
rd
))
(
format-3-reg
(
op
:constant
#b10
)
(
rd
:argument
reg
)
(
op3
:constant
#b000010
)
(
rs1
:constant
0
)
(
rs2
:argument
reg
)))
;;; Instructions for dumping data and header objects.
;;;; Instructions for dumping data and header objects.
(
define-format
(
word-format
32
)
(
define-instruction
word
(
segment
word
)
(
data
(
byte
32
0
)))
(
:declare
(
type
(
or
(
unsigned-byte
32
)
(
signed-byte
32
))
word
))
(
define-instruction
(
word
)
:pinned
(
word-format
(
data
:argument
(
or
(
unsigned-byte
32
)
(
signed-byte
32
)))))
(
:emitter
(
emit-word
segment
word
)))
(
define-format
(
short-format
16
)
(
data
(
byte
16
0
)))
(
define-instruction
short
(
segment
short
)
(
define-instruction
(
short
)
(
:declare
(
type
(
or
(
unsigned-byte
16
)
(
signed-byte
16
))
short
))
(
short-format
(
data
:argument
(
or
(
unsigned-byte
16
)
(
signed-byte
16
)))))
:pinned
(
:emitter
(
define-format
(
byte-format
8
)
(
emit-short
segment
short
)))
(
data
(
byte
8
0
)))
(
define-instruction
(
byte
)
(
define-instruction
byte
(
segment
byte
)
(
byte-format
(
data
:argument
(
or
(
unsigned-byte
8
)
(
signed-byte
8
)))))
(
:declare
(
type
(
or
(
unsigned-byte
8
)
(
signed-byte
8
))
byte
))
:pinned
(
:emitter
(
define-format
(
header-object
32
)
(
emit-byte
segment
byte
)))
(
type
(
byte
8
0
))
(
data
(
byte
24
8
)
(
define-emitter
emit-header-object
32
:default
0
(
byte
24
8
)
(
byte
8
0
))
:function
(
lambda
(
ignore
)
(
declare
(
ignore
ignore
))
(
ash
(
+
*current-position*
(
component-header-length
))
(
-
vm:word-shift
)))))
(
defun
emit-header-data
(
segment
type
)
(
emit-back-patch
(
define-instruction
(
function-header-word
)
segment
4
(
header-object
(
type
:constant
vm:function-header-type
)))
#'
(
lambda
(
segment
posn
)
(
emit-word
segment
(
define-instruction
(
lra-header-word
)
(
logior
type
(
header-object
(
type
:constant
vm:return-pc-header-type
)))
(
ash
(
+
posn
(
component-header-length
))
(
-
type-bits
word-shift
)))))))
(
define-instruction
function-header-word
(
segment
)
:pinned
(
:emitter
(
emit-header-data
segment
function-header-type
)))
(
define-instruction
lra-header-word
(
segment
)
:pinned
(
:emitter
(
emit-header-data
segment
return-pc-header-type
)))
;;;; Instructions for converting between code objects, functions, and lras
;;;; Instructions for converting between code objects, functions, and lras.
(
eval-when
(
compile
eval
)
(
defun
emit-compute-inst
(
segment
vop
dst
src
label
temp
calc
)
(
defmacro
define-compute-instruction
(
name
calculation
)
(
emit-chooser
(
let
((
add
(
symbolicate
name
"-ADD"
))
;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
(
sethi
(
symbolicate
name
"-SETHI"
))
segment
12
3
(
or
(
symbolicate
name
"-OR"
)))
#'
(
lambda
(
segment
posn
delta-if-after
)
`
(
progn
(
let
((
delta
(
funcall
calc
label
posn
delta-if-after
)))
(
define-instruction
(
,
add
)
(
when
(
<=
(
-
(
ash
1
12
))
delta
(
1-
(
ash
1
12
)))
(
format-3-immed
(
emit-back-patch
segment
4
(
op
:constant
#b10
)
#'
(
lambda
(
segment
posn
)
(
rd
:argument
reg
)
(
assemble
(
segment
vop
)
(
op3
:constant
#b000000
)
(
inst
add
dst
src
(
rs1
:argument
reg
)
(
funcall
calc
label
posn
0
)))))
(
immed
:argument
label
t
)))
:function
(
lambda
(
label
)
#'
(
lambda
(
segment
posn
)
(
let
((
result
,
calculation
))
(
let
((
delta
(
funcall
calc
label
posn
0
)))
(
assert
(
typep
result
'
(
signed-byte
13
)))
(
assemble
(
segment
vop
)
result
)))))
(
inst
sethi
temp
(
ldb
(
byte
22
10
)
delta
))
(
define-instruction
(
,
sethi
)
(
inst
or
temp
(
ldb
(
byte
10
0
)
delta
))
(
format-2-immed
(
rd
:argument
reg
)
(
inst
add
dst
src
temp
))))))
(
op2
:constant
#b100
)
(
immed
:argument
label
:function
(
lambda
(
label
)
(
ash
,
calculation
-10
)))))
(
define-instruction
(
,
or
)
(
format-3-immed
(
op
:constant
#b10
)
(
rd
:argument
reg
)
(
op3
:constant
#b000010
)
(
rs1
:same-as
rd
)
(
immed
:argument
label
:function
(
lambda
(
label
)
(
logand
,
calculation
(
1-
(
ash
1
10
)))))))
(
define-pseudo-instruction
,
name
96
(
dst
src
label
temp
)
(
cond
((
typep
,
calculation
'
(
signed-byte
13
))
(
inst
,
add
dst
src
label
))
(
t
(
inst
,
sethi
temp
label
)
(
inst
,
or
temp
label
)
(
inst
add
dst
src
temp
)))))))
)
; eval-when (compile eval)
;; code = fn - fn-ptr-type - header - label-offset + other-pointer-tag
;; code = fn - fn-ptr-type - header - label-offset + other-pointer-tag
(
define-compute-instruction
compute-code-from-fn
(
define-instruction
compute-code-from-fn
(
segment
dst
src
label
temp
)
(
-
vm:other-pointer-type
(
:declare
(
type
tn
dst
src
temp
)
(
type
label
label
))
vm:function-pointer-type
(
:reads
src
)
(
label-position
label
)
(
:writes
(
list
dst
temp
))
(
component-header-length
)))
(
:vop-var
vop
)
(
:emitter
(
emit-compute-inst
segment
vop
dst
src
label
temp
#'
(
lambda
(
label
posn
delta-if-after
)
(
-
other-pointer-type
function-pointer-type
(
label-position
label
posn
delta-if-after
)
(
component-header-length
))))))
;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
(
define-compute-instruction
compute-code-from-lra
(
define-instruction
compute-code-from-lra
(
segment
dst
src
label
temp
)
(
-
(
+
(
label-position
label
)
(
:declare
(
type
tn
dst
src
temp
)
(
type
label
label
))
(
component-header-length
))))
(
:reads
src
)
(
:writes
(
list
dst
temp
))
(
:vop-var
vop
)
(
:emitter
(
emit-compute-inst
segment
vop
dst
src
label
temp
#'
(
lambda
(
label
posn
delta-if-after
)
(
-
(
+
(
label-position
label
posn
delta-if-after
)
(
component-header-length
)))))))
;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
(
define-compute-instruction
compute-lra-from-code
(
define-instruction
compute-lra-from-code
(
segment
dst
src
label
temp
)
(
+
(
label-position
label
)
(
:declare
(
type
tn
dst
src
temp
)
(
type
label
label
))
(
component-header-length
)))
(
:reads
src
)
(
:writes
(
list
dst
temp
))
(
:vop-var
vop
)
(
:emitter
(
emit-compute-inst
segment
vop
dst
src
label
temp
#'
(
lambda
(
label
posn
delta-if-after
)
(
+
(
label-position
label
posn
delta-if-after
)
(
component-header-length
))))))
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