Powered by ViewCVS 1.0-dev
updated copyright years
\ disasm.fs disassembler file (for AMD64 64-bit mode)
\
\ Copyright (C) 2004,2005,2007,2010 Free Software Foundation, Inc.
\ This file is part of Gforth.
\ Gforth is free software; you can redistribute it and/or
\ modify it under the terms of the GNU General Public License
\ as published by the Free Software Foundation, either version 3
\ of the License, or (at your option) any later version.
\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
\ GNU General Public License for more details.
\ You should have received a copy of the GNU General Public License
\ along with this program. If not, see http://www.gnu.org/licenses/.
\ This architecture has very funny instruction encodings, all
\ documented nicely in
\ http://www.amd.com/us-en/assets/content_type/white_papers_and_tech_docs/24594.pdf
\ Here's an even more condensed version:
\ legacy-prefix* REX (Opcode1 | OF Opcode2) ( modrm sib? )? disp? imm?
\ where the legacy prefixes are:
\ 66 67 2e 3e 26 64 65 36 f0 f3 f2
\ The 66 f2 f3 prefix are also used as part of the opcode for MMX, SSE, SSE2
\ 67 changes the size of implicit operands of some instructions (e.g. LOOP)
\ see table 1-4
\ The REX prefixes supply 4 bits to the operands: WRXB; W=operand
\ width; R=ModRM reg field ext; X=SIB index field ext; B=ModRM r/m
\ field, SIB base field, or opcode reg field; also, the presence of a
\ REX prefix makes the difference between SIL/DIL/BPL/SPL (present)
\ and AH/BH/CH/DH (absent); the additional bits are ignored for the
\ special cases of ModRM and SIB bytes.
\ 3DNow instructions have opcode formed by 0F 0F and an imm byte
\ prelude
: c@+ count ;
: cell-fill ( addr u w -- )
rot rot 0 ?do
2dup i th !
loop
2drop ;
: save-mem-here ( addr1 u -- addr2 u )
here >r
dup chars allot
tuck r@ swap chars move
r> swap ;
: string-table ( n n*"string" -- addr )
here over 2* cells allot
swap 0 ?do
parse-word save-mem-here 2 pick i 2* cells + 2!
loop ;
\ : bounds over + swap ;
\ : rdrop postpone r> postpone drop ; immediate
\ state coming from prefixes:
variable operand-size \ true if prefix
variable address-size \ true if prefix
variable repeat-prefix \ 0, f2 or f3, depending on prefix
variable rex-prefix \ 0 or 40-4f, depending on prefix
: clear-prefixes ( -- )
operand-size off
address-size off
repeat-prefix off
rex-prefix off ;
create opcode1-table \ xt table for decoding first opcode byte
$100 cells allot
: def-opcode1 ( xt opcode -- )
opcode1-table swap th ! ;
: disasm-addr1 ( addr1 -- addr2 )
\ disassemble instruction with some prefixes set
opcode1-table over c@ th perform ;
: disasm-addr ( addr1 -- addr2 )
dup clear-prefixes disasm-addr1
." \ " dup rot
\ 2drop ;
?do
i c@ hex.
loop ;
: disasm ( addr u -- ) \ gforth
\G disassemble u aus starting at addr
over + >r begin
dup r@ u< while
cr ." ( " dup hex. ." ) " disasm-addr
repeat
drop rdrop ;
\ ' disasm is discode \ disable it while it's not working
: print-rep ( -- )
repeat-prefix @ case
$f2 of ." repnz " endof
$f3 of ." repz " endof
endcase ;
: illegal-inst ( addr1 -- addr2 )
print-rep dup c@ hex. 1+ ;
opcode1-table $100 ' illegal-inst cell-fill
: repeat-prefix-disasm ( addr1 -- addr2 )
dup c@ repeat-prefix !
1+ disasm-addr1 ;
' repeat-prefix-disasm $f2 def-opcode1
' repeat-prefix-disasm $f3 def-opcode1
: rex-prefix-disasm ( addr1 -- addr2 )
dup c@ rex-prefix !
1+ disasm-addr1 ;
opcode1-table $40 th $10 ' rex-prefix-disasm cell-fill
: immediate-prefix ( c "name" -- )
\ prefix that can be printed immediately and then forgotten
:noname
parse-word postpone sliteral postpone type postpone space postpone 1+
postpone disasm-addr1
postpone ;
swap def-opcode1 ;
$2e immediate-prefix cs:
$3e immediate-prefix ds:
$26 immediate-prefix es:
$64 immediate-prefix fs:
$65 immediate-prefix gs:
$36 immediate-prefix ss:
$f0 immediate-prefix lock
: operand-size-disasm ( addr1 -- addr2 )
operand-size on
1+ disasm-addr1 ;
' operand-size-disasm $66 def-opcode1
: address-size-disasm ( addr1 -- addr2 )
address-size on
1+ disasm-addr1 ;
' address-size-disasm $67 def-opcode1
create reg8-names
8 string-table al cl dl bl spl bpl sil dil drop
create reg8-names-norex
8 string-table al cl dl bl ah ch dh bh drop
create reg16-names
8 string-table ax cx dx bx sp bp si di drop
create sreg-names
8 string-table es cs ss ds fs gs reserved reserved
: dec.- ( u -- )
base @ decimal swap 0 .r base ! ;
: .regn ( u -- )
\ print r#
'r emit dec.- ;
: .reg8 ( u -- )
dup 8 < if
2* cells
rex-prefix @ if
reg8-names
else
reg8-names-norex
endif
+ 2@ type
else
.regn 'b emit
endif ;
: .reg16 ( u -- )
dup 8 < if
2* cells reg16-names + 2@ type
else
.regn 'w emit
endif ;
: .reg32 ( u -- )
dup 8 < if
'e emit 2* cells reg16-names + 2@ type
else
.regn 'd emit
endif ;
: .reg64 ( u -- )
dup 8 < if
'r emit 2* cells reg16-names + 2@ type
else
.regn
endif ;
: .sreg ( u -- )
\ segment registers
2* cells sreg-names + 2@ type ;
: .invalid ( u -- )
drop ." invalid" ;
: Gnum ( addr -- u )
\ decode modRM reg field
c@ 3 rshift 7 and rex-prefix @ 4 and 2* + ;
: Gb ( addr -- )
\ decode and print modRM reg field as reg8
Gnum .reg8 ;
: Sw ( addr -- )
\ decode and print modRM reg fueld as sreg
Gnum .sreg ;
: .regv ( u -- )
\ print register according to operand width
rex-prefix c@ 8 and if
.reg64
else
operand-size @ if
.reg16
else
.reg32
endif
endif ;
: .width ( -- )
\ print [wdq] according to operand width
rex-prefix c@ 8 and if
'q
else
operand-size @ if
'w
else
'd
endif
endif
emit ;
: .width/2 ( -- )
\ print [bwd] according to operand width/2
rex-prefix c@ 8 and if
'd
else
operand-size @ if
'b
else
'w
endif
endif
emit ;
: .width*2 ( -- )
\ print [dqo] according to operand width*2
rex-prefix c@ 8 and if
'o
else
operand-size @ if
'd
else
'q
endif
endif
emit ;
: Gv ( addr -- )
\ decode and print modRM reg field according to operand width
Gnum .regv ;
: Ox ( addr -- )
\ absolute addressing without modRM or SIB
dup @ hex. ." d[]" 8 + ; \ !! address-size override?
create displacement-info
0 0 2, 1 $ff 2, 4 $ffffffff 2, \ size mask
: masksx ( w1 mask -- w2 )
\ apply the mask of the form 0..01..1 in a sign-extending way
2dup dup 1 rshift invert and and 0<> ( w1 mask fneg )
over invert and ( w1 mask highbits )
rot rot and or ;
: base-regnum ( modRM/SIB/opcode -- u )
\ extract modRM r/m or SIB base or opcode register number
7 and rex-prefix @ 1 and 3 lshift + ;
: print-base ( sib -- )
'[ emit base-regnum .reg64 '] emit ;
: mem-SIB ( dispsize mask addr1 -- addr2 )
\ decode memory operand described by SIB (mask gives the displacement size)
\ !! change output to stuff like 5 eax edx d[r][r*8]
>r
r@ c@ 7 and 5 = over 0= and if
2drop 4 $ffff ['] drop
else
['] print-base
endif
if ( dispsize mask xt-base )
r@ 1+ @ 2 pick masksx . 'd emit
endif
r@ c@ swap execute \ print base ( dispsize mask )
r@ c@ 3 rshift 7 and rex-prefix @ 2 and 2 lshift + ( d m index-reg )
dup 4 <> if
'[ emit .reg64 '* emit
1 r@ c@ 6 rshift lshift dec.- '] emit
endif
2drop r@ 1+ + ;
: mem-modRM ( addr1 -- addr2 )
\ decode memory operand described by modRM
>r
\ get the displacement mask
displacement-info r@ c@ 6 rshift 2* th 2@ ( dispsize mask r: addr1 )
r@ c@ 7 and 4 = if
r> 1+ mem-SIB exit
endif
r@ c@ $c7 and 5 = if \ rip+disp32
2drop 4 $ffffffff r@ 1+ @ swap masksx . ." d[rip] "
else dup if
r@ 1+ @ swap masksx .
r@ c@ base-regnum .reg64 ." d[r] "
else
drop
r@ c@ base-regnum .reg64 ." [r] "
endif endif
r> 1+ + ;
: Ext ( addr1 xt -- addr2 )
\ decode and print modRM mod and r/m fields as r/m with width given by xt
>r dup c@ $c0 and $c0 = if
c@+ base-regnum r> execute exit
endif
rdrop mem-modRM ;
: Eb ( addr1 -- addr2 )
\ decode and print modRM mod and r/m fields as r/m8
['] .reg8 Ext ;
: Ed ( addr1 -- addr2 )
['] .reg32 Ext ;
: Ev ( addr1 -- addr2 )
\ decode and print modRM mod and r/m fields as r/m8
['] .regv Ext ;
: Ib ( addr1 -- addr2 )
c@+ $ff masksx . ." # " ;
: Jb ( addr1 -- addr2 )
c@+ $ff masksx over + hex. ;
: immz ( addr1 -- addr2 imm mask )
>r
rex-prefix c@ 8 and 0= operand-size @ and if
$ffff 2
else
$ffffffff 4
endif
r@ +
r> @ rot ;
: Iz ( addr1 -- addr2 )
\ print immediate operand
immz masksx . ." # " ;
: Jz ( addr1 -- addr2 )
immz masksx over + hex. ;
: Iv ( addr1 -- addr2 )
>r
rex-prefix c@ 8 and if
$ffffffffffffffff 8
else
operand-size @ if
$ffff 2
else
$ffffffff 4
endif
endif
r@ +
r> @ rot
masksx . ." # " ;
\ add-like instruction types
: Eb,Gb ( addr1 addr u -- addr2 )
2>r 1+ dup Eb space swap Gb space
2r> type ." b," ;
: Ev,Gv ( addr1 addr u -- addr2 )
2>r 1+ dup Ev space swap Gv space
2r> type .width ', emit ;
: Gb,Eb ( addr1 addr u -- addr2 )
2>r 1+ dup Gb space Eb space
2r> type ." b," ;
: Gv,Ev ( addr1 addr u -- addr2 )
2>r 1+ dup Gv space Ev space
2r> type .width ', emit ;
: AL,Ib ( addr1 addr u -- addr2 )
2>r 0 .reg8 space 1+ Ib 2r> type ." b," ;
: rAX,Iz ( addr1 addr u -- addr2 )
2>r 0 .regv space 1+ Iz 2r> type .width ', emit ;
: set-noarg ( addr u opcode -- )
>r 2>r :noname postpone 1+ 2r> postpone sliteral postpone type postpone ;
r> def-opcode1 ;
: set-add-like ( addr u type-xt opcode -- )
>r >r 2>r
:noname 2r> postpone sliteral r> compile, postpone ;
r> def-opcode1 ;
: set-add-likes ( addr u base-opcode -- )
>r
2dup ['] Eb,Gb r@ 0 + set-add-like
2dup ['] Ev,Gv r@ 1 + set-add-like
2dup ['] Gb,Eb r@ 2 + set-add-like
2dup ['] Gv,Ev r@ 3 + set-add-like
2dup ['] AL,Ib r@ 4 + set-add-like
2dup ['] rAX,Iz r@ 5 + set-add-like
2drop rdrop ;
s" add" $00 set-add-likes
s" adc" $10 set-add-likes
s" and" $20 set-add-likes
s" xor" $30 set-add-likes
s" or" $08 set-add-likes
s" sbb" $18 set-add-likes
s" sub" $28 set-add-likes
s" cmp" $38 set-add-likes
: push-reg ( addr1 -- addr2 )
c@+ base-regnum .reg64 space ." pushq," ;
opcode1-table $50 th 8 ' push-reg cell-fill
: pop-reg ( addr1 -- addr2 )
c@+ base-regnum .reg64 space ." popq," ;
opcode1-table $58 th 8 ' push-reg cell-fill
:noname \ movsxd ( addr1 -- addr2 )
1+ dup Gv space swap Ed ." movsxd," ;
$63 def-opcode1
:noname \ push-Iz ( addr1 -- addr2 )
1+ Iz ." # push" .width ', emit ;
$68 def-opcode1
:noname \ imul-Gv,Ev,Iz ( addr1 -- addr2 )
1+ dup Gv space Ev Iz ." imul" .width ', emit ;
$69 def-opcode1
:noname \ push-Ib ( addr1 -- addr2 )
1+ Ib ." # pushb," ;
$6a def-opcode1
:noname \ imul-Gb,Eb,Ib ( addr1 -- addr2 )
1+ dup Gb space Eb Ib ." imulb," ;
$6b def-opcode1
s" insb," $6c set-noarg
:noname ( addr1 -- addr2 )
." ins" .width ', emit 1+ ;
$6d def-opcode1
s" outsb," $6e set-noarg
:noname ( addr1 -- addr2 )
." outs" .width ', emit 1+ ;
$6f def-opcode1
create conditions
16 string-table o no c nc z nz na a s ns p np l ge le g
: jcc-short ( addr1 -- addr2 )
dup 1+ Jb swap
'j emit c@ $f and 2* cells conditions + 2@ type ', emit ;
opcode1-table $70 th $10 ' jcc-short cell-fill
s" test" ' Eb,Gb $84 set-add-like
s" test" ' Ev,Gv $85 set-add-like
s" xchg" ' Eb,Gb $86 set-add-like
s" xchg" ' Ev,Gv $87 set-add-like
s" mov" ' Eb,Gb $88 set-add-like
s" mov" ' Ev,Gv $89 set-add-like
s" mov" ' Gb,Eb $8a set-add-like
s" mov" ' Gv,Ev $8b set-add-like
:noname \ mov-Mw/Rv,Sw ( addr1 -- addr2 )
1+ dup Ev space swap Sw ." movw," ;
$8c def-opcode1
:noname \ lea-Gv,M ( addr1 -- addr2 )
1+ dup Gv space ['] .invalid Ext ." lea," ;
$8d def-opcode1
:noname \ mov-Sw,Ew ( addr1 -- addr2 )
1+ dup Sw space Ev ." movw," ;
$8e def-opcode1
: xchg-ax ( addr1 -- addr2 )
c@+ base-regnum dup 0= if
drop ." nop," exit
endif
.regv space 0 .regv ." xchg," ;
opcode1-table $90 th 8 ' xchg-ax cell-fill
:noname \ Cx/2-x
'c emit .width/2 .width ." e," ;
$98 def-opcode1
:noname \ Cx/2-x
." ," .width .width*2 ." ," ;
$99 def-opcode1
s" fwait," $9b set-noarg
:noname ( addr1 -- addr2 )
." pushfq," 1+ ; \ !! deal with 16-bit prefix
$9c def-opcode1
:noname ( addr1 -- addr2 )
." popfq," 1+ ; \ !! deal with 16-bit prefix
$9d def-opcode1
s" sahf," $9e set-noarg
s" lahf," $9f set-noarg
:noname \ mov-al,Ob ( addr1 -- addr2 )
0 .reg8 space 1+ Ox ." movb," ;
$a0 def-opcode1
:noname \ mov-xAx,Ov ( addr1 -- addr2 )
0 .regv space 1+ Ox ." mov" .width ', emit ;
$a1 def-opcode1
:noname \ mov-Ob,al ( addr1 -- addr2 )
1+ Ox 0 .reg8 space ." movb," ;
$a2 def-opcode1
:noname \ mov-Ov,xAx ( addr1 -- addr2 )
1+ Ox 0 .regv space ." mov" .width ', emit ;
$a3 def-opcode1
s" movsb," $a4 set-noarg
:noname ( addr1 -- addr2 )
." movs" .width ', emit 1+ ;
$a5 def-opcode1
s" cmpsb," $a6 set-noarg
:noname ( addr1 -- addr2 )
." cmps" .width ', emit 1+ ;
$a7 def-opcode1
s" test" ' Al,Ib $a8 set-add-like
s" test" ' rAX,Iz $a9 set-add-like
s" stosb," $aa set-noarg
:noname ( addr1 -- addr2 )
." stos" .width ', emit 1+ ;
$ab def-opcode1
s" lodsb," $ac set-noarg
:noname ( addr1 -- addr2 )
." lods" .width ', emit 1+ ;
$ad def-opcode1
s" scasb," $ae set-noarg
:noname ( addr1 -- addr2 )
." scas" .width ', emit 1+ ;
$af def-opcode1
: mov-reg8-Ib ( addr1 -- addr2 )
c@+ base-regnum .reg8 Ib ." movb," ;
opcode1-table $b0 th 8 ' mov-reg8-Ib cell-fill
: mov-regv-Iv ( addr1 -- addr2 )
c@+ base-regnum .regv Iv ." mov" .width ." ," ;
opcode1-table $b8 th 8 ' mov-regv-Iv cell-fill
:noname ( addr1 -- addr2 )
1+ dup @ $ffff masksx . ." ret#," 2 + ;
$c2 def-opcode1
s" ret," $c3 set-noarg
:noname ( addr1 -- addr2 )
1+ dup @ $ffff and u. 2 + c@+ . ." enter," ;
$c8 def-opcode1
s" leave," $c9 set-noarg
:noname ( addr1 -- addr2 )
1+ dup @ $ffff masksx . ." retfar#," 2 + ;
$ca def-opcode1
s" retfar," $cb set-noarg
s" int3," $cc set-noarg
:noname ( addr1 -- addr2 )
1+ Ib ." int," ;
$cd def-opcode1
s" iret," $cf set-noarg
s" xlatb," $d7 set-noarg
:noname ( addr1 -- addr2 )
1+ Jb ." loopnz," ;
$e0 def-opcode1
:noname ( addr1 -- addr2 )
1+ Jb ." loopz," ;
$e1 def-opcode1
:noname ( addr1 -- addr2 )
1+ Jb ." loop," ;
$e2 def-opcode1
:noname ( addr1 -- addr2 )
1+ Jb 'j emit 1 .regv ." z," ;
$e3 def-opcode1
:noname ( addr1 -- addr2 )
1+ c@+ hex. ." inb#," ;
$e4 def-opcode1
:noname ( addr1 -- addr2 )
1+ c@+ hex. ." in" .width ." #," ;
$e5 def-opcode1
:noname ( addr1 -- addr2 )
1+ c@+ hex. ." outb#," ;
$e6 def-opcode1
:noname ( addr1 -- addr2 )
1+ c@+ hex. ." out" .width ." #," ;
$e7 def-opcode1
:noname ( addr1 -- addr2 )
1+ Jz ." call," ;
$e8 def-opcode1
:noname ( addr1 -- addr2 )
1+ Jz ." jmp," ;
$e9 def-opcode1
:noname ( addr1 -- addr2 )
1+ Jb ." jmp," ;
$eb def-opcode1
s" inb," $ec set-noarg
:noname ( addr1 -- addr2 )
1+ ." in" .width ." ," ;
$ed def-opcode1
s" outb," $ee set-noarg
:noname ( addr1 -- addr2 )
1+ ." out" .width ." ," ;
$ef def-opcode1
s" int1," $f1 set-noarg
s" hlt," $f4 set-noarg
s" cmc," $f5 set-noarg
s" clc," $f8 set-noarg
s" stc," $f9 set-noarg
s" cli," $fa set-noarg
s" sti," $fb set-noarg
s" cld," $fc set-noarg
s" std," $fd set-noarg
\ !! 80-83: Group1
\ !! 8f: Group1a
\ !! c0,c1,d0-d3: Group2
\ !! c6,c7: Group11
\ !! d8-df: x87
\ !! f6,f7: Group3
\ !! fe: Group4
\ !! ff: Group5
\ !! 0f: 2-byte opcodes
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |