SpindleyQ/dialer
1
1
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity
dialer/asm.jrt

352 lines
12 KiB
Plaintext
Executable file
Raw Blame History

( REQUIRES: defs.jrt, target.jrt )
var op-encode
var lastop var lastlabel
var op-memwidth
: BYTE 1 op-memwidth ! ; : byteptr? op-memwidth @ 1 = ;
: FAR 4 op-memwidth ! ; : farptr? op-memwidth @ 4 = ;
var current-oparg
var opargs-remaining
array oparg1 3 cells allot
array oparg2 3 cells allot
: arg1 oparg1 current-oparg ! ; arg1
: arg2 oparg2 current-oparg ! ;
: swap-args current-oparg @ oparg1 = if arg2 else arg1 then ;
: oparg-type ( -- type ) current-oparg @ ;
: oparg-val ( -- v ) current-oparg @ cell + ;
: oparg-base ( -- v ) current-oparg @ 2 cells + ;
: set-oparg! ( val type -- ) oparg-type ! oparg-val ! 0 oparg-base ! ;
: oparg-unset? ( -- f ) oparg-type @ 0 = ;
: oparg-imm! ( val -- ) 1 set-oparg! ;
: oparg-imm? ( -- f ) oparg-type @ 1 = ;
: oparg-reg! ( reg -- ) 2 set-oparg! ;
: oparg-reg? ( -- f ) oparg-type @ 2 = ;
: oparg-regflag? ( flag -- f ) oparg-val @ 0xf0 & = oparg-reg? and ;
: oparg-breg? ( -- f ) 0x10 oparg-regflag? ;
: oparg-wreg? ( -- f ) 0x00 oparg-regflag? ;
: oparg-segreg? ( -- f ) 0x20 oparg-regflag? ;
: oparg-mem! ( disp -- ) 3 set-oparg! ;
: oparg-mem? ( -- f ) oparg-type @ 0x0f & 3 = ;
: oparg-mempatch? ( -- f ) oparg-type @ 0x13 = ;
: byteop? ( -- f )
oparg-breg? swap-args oparg-breg? or swap-args byteptr? or ;
: byteval? ( v -- f ) dup 0x7f <= swap 0xff80 >= and ;
: oparg-bwreg? ( -- f ) byteop? if oparg-breg? else oparg-wreg? then ;
: operror ( err -- ) lastop @ type s" near " type lastlabel @ type s" : " type type cr ;
: encode-op ( -- ) op-encode @ execute 0 op-encode ! ;
: check-encoded ( -- )
target >r encode-op <r target =
if s" invalid argument types" operror then ;
: oparg-complete!
opargs-remaining @ dup if
1 - dup opargs-remaining !
if arg2
else arg1 check-encoded then
else s" too many arguments" operror then ;
: # oparg-imm! oparg-complete! ;
: @[ 0 oparg-mem! ;
: @] oparg-val ! -1 oparg-base ! oparg-complete! ;
: unexpected-addr ( addr -- ) drop s" unexpected address" operror ;
: @+ ( disp -- )
opargs-remaining @ if
oparg-unset? if @[ @] return then
oparg-mem? if oparg-val ! return then
then drop unexpected-addr ;
: @FAR ( offset segment -- ) 4 set-oparg! oparg-base ! oparg-complete! ;
: oparg-faraddr? oparg-type @ 4 = ;
array patchtable 10 2 cells * allot
: find-patch ( patchid -- patch ) 2 cells * patchtable + ;
: patchpoint ( type -- ) oparg-mempatch? if
oparg-val @ find-patch swap over ! cell + target swap !
else drop then ;
: patch-a16 ( tptr targ -- ) swap !t ;
: patch-r16 ( tptr targ -- ) over 2 + - swap !t ;
: patch-r8 ( tptr targ -- ) over 1 + - swap b!t ;
: apply-patch ( tptr type -- ) target swap execute ;
: @> ( patchid -- ) dup 0x13 set-oparg! @] ;
: <: ( patchid -- ) find-patch dup @ swap cell + @ swap apply-patch ;
: L: here create wordname lastlabel ! 0 , target here cell - ! does> @ @+ ;
: L@ [ ' ' , ] 2 cells + @ ;
( label redefinition - allows predefining labels when writing inline
assembly in the 'here' arena. )
: L! [ ' ' , ] 2 cells + target swap ! ;
array anonlabels 10 cells allot
: L<@ ( labelid -- addr ) cells anonlabels + @ ;
: <@ ( labelid -- ) L<@ @+ ;
: :> ( labelid -- ) cells anonlabels + target swap ! ;
: memreg create , does> @ oparg-base ! oparg-complete! ;
0 memreg BX+SI] 1 memreg BX+DI] 2 memreg BP+SI] 3 memreg BP+DI]
4 memreg SI] 5 memreg DI] 6 memreg BP] 7 memreg BX]
: reg create , does> @ oparg-reg! oparg-complete! ;
( data registers: take the bottom four bits and you have the
REG and R/M encoding for the modr/m byte )
0x00 reg AX 0x01 reg CX 0x02 reg DX 0x03 reg BX
0x04 reg SP 0x05 reg BP 0x06 reg SI 0x07 reg DI
( 8-bit data registers, same scheme )
0x10 reg AL 0x11 reg CL 0x12 reg DL 0x13 reg BL
0x14 reg AH 0x15 reg CH 0x16 reg DH 0x17 reg BH
( segment registers; same scheme, )
0x20 reg ES 0x21 reg CS 0x22 reg SS 0x23 reg DS
: start-op ( dictentry argcount -- )
0 op-memwidth ! ( start unknown )
opargs-remaining @ if s" not enough arguments" operror then
opargs-remaining ! lastop ! arg2 0 0 set-oparg! arg1 0 0 set-oparg! ;
: prefix create , does> @ >t ;
: 0op here create wordname , b, does> dup @ 0 start-op cell + b@ >t ;
0x26 prefix ES: 0x36 prefix SS: 0x2e prefix CS: 0x3e prefix DS:
0xf0 prefix LOCK 0xf2 prefix REPNZ 0xf3 prefix REPZ
0x90 0op NOP 0xa4 0op MOVSB 0xa5 0op MOVSW 0xa6 0op CMPSB
0xa7 0op CMPSW 0xc3 0op RET 0xd7 0op XLAT 0xf4 0op HLT
0x98 0op CBW 0x99 0op CWD 0x9c 0op PUSHF 0x9d 0op POPF
0x9e 0op SAHF 0x9f 0op LAHF 0xaa 0op STOSB 0xab 0op STOSW
0xac 0op LODSB 0xad 0op LODSW 0xae 0op SCASB 0xaf 0op SCASW
0xcb 0op RETF 0xce 0op INTO 0xcf 0op IRET 0xf8 0op CLC
0xf9 0op STC 0xfa 0op CLI 0xfb 0op STI 0xfc 0op CLD
0xfd 0op STD 0xf5 0op CMC
: :op ( count -- ) here create wordname , , $DOCOLON , ] does>
dup @ over cell + @ start-op 2 cells + op-encode ! ;
: memarg>case ( -- 0|1|2 )
oparg-base @ dup -1 = if drop 1 ( D16 ) else
6 = oparg-val @ 0 = and if 2 ( [bp]+0 ) else 0 ( standard ) then then ;
: memarg>dispsize ( -- 0|1|2 )
memarg>case dup 1 = if drop 2 else 2 = if 1 else
oparg-val @ dup 0 = if drop 0 else byteval? if 1 else 2
then then then then ;
: memarg>mod+rm ( -- mod rm )
memarg>case dup 1 = if drop 0 6 else 2 = if 1 6 else
memarg>dispsize oparg-base @ then then ;
: regarg>mod+rm ( -- mod rm ) 3 oparg-val @ ;
: modrm>t ( reg mod rm -- ) 0x07 & swap 0x03 & 6 << | swap 0x07 & 3 << | >t ;
: pre-disp-write memarg>case 2 = if ' patch-a16 patchpoint then ;
( convention: words ending in * mean "will return if matched" )
: disp>t pre-disp-write oparg-val @ memarg>dispsize
dup 1 = if drop >t else 2 = if w>t else drop then then ;
defer byteimm? ' byteop? ' byteimm? redefine
var ignoreimm
: imm?>t ignoreimm @ not if
oparg-imm? if oparg-val @ byteimm? if >t else w>t then then then ;
( 2ret: return immediately from this word and calling word.
equivalent to rdrop return. )
: 2ret rdrop rdrop ;
: >wreg+op* ( base -- )
oparg-wreg? if oparg-val @ | >t 2ret then drop ;
: >segreg+op* ( base -- )
oparg-segreg? if oparg-val @ 0x0f & 3 << + >t 2ret then drop ;
: >mem ( reg op -- ) >t memarg>mod+rm modrm>t disp>t swap-args imm?>t ;
: >memreg ( op -- ) swap-args oparg-val @ swap-args swap >mem ;
: >extmem* oparg-mem? byteop? not and if >mem 2ret then 2drop ;
: >extbmem* oparg-mem? byteop? and if >mem 2ret then 2drop ;
: >extreg ( reg op -- ) >t regarg>mod+rm modrm>t swap-args imm?>t ;
: >extbreg* ( ext op -- ) oparg-breg? if >extreg 2ret then 2drop ;
: >extreg* ( ext op -- ) oparg-wreg? if >extreg 2ret then 2drop ;
: *? ( cp -- f ) :| execute 0 2ret |; execute 1 ;
: >extwreg|mem* ( ext op -- )
2dup ' >extreg* *? if 2drop 2ret then
' >extmem* *? if 2ret then ;
: >extbreg|mem* ( ext op -- )
2dup ' >extbreg* *? if 2drop 2ret then
' >extbmem* *? if 2ret then ;
: >grp3* ( reg -- )
dup 0xf6 ' >extbreg|mem* *? if drop 2ret then
0xf7 ' >extwreg|mem* *? if 2ret then ;
1 :op RET- oparg-imm? if 0xc2 >t oparg-val @ w>t then ;
1 :op RETF- oparg-imm? if 0xca >t oparg-val @ w>t then ;
1 :op PUSH
0x50 >wreg+op*
0x06 >segreg+op*
6 0xff >extmem* ;
1 :op POP
0x58 >wreg+op*
0x07 >segreg+op*
0 0x8f >extmem* ;
1 :op INC
0x40 >wreg+op*
0 0xfe >extbreg|mem*
0 0xff >extwreg|mem* ;
1 :op DEC
0x48 >wreg+op*
1 0xfe >extbreg|mem*
1 0xff >extwreg|mem* ;
1 :op INT
oparg-imm? if
oparg-val @ dup 3 = if drop 0xcc >t else 0xcd >t >t then
then ;
: diffaddr ( opsize -- diff ) oparg-val @ swap target + - ;
: oparg-nearaddr? ( -- f ) oparg-mem? oparg-base @ -1 = and ;
: >short-jmp* ( op -- ) oparg-nearaddr? if
2 diffaddr dup byteval? oparg-mempatch? or
if swap >t ' patch-r8 patchpoint >t 2ret then drop
then drop ;
: >near-reljmp* ( op -- ) oparg-nearaddr? if
3 diffaddr swap >t ' patch-r16 patchpoint w>t 2ret then drop ;
: >far-jmp* ( op -- ) oparg-faraddr?
if >t oparg-base @ w>t oparg-val @ w>t 2ret then drop ;
1 :op JO 0x70 >short-jmp* ;
1 :op JNO 0x71 >short-jmp* ;
1 :op JB 0x72 >short-jmp* ;
1 :op JNB 0x73 >short-jmp* ;
1 :op JZ 0x74 >short-jmp* ;
1 :op JNZ 0x75 >short-jmp* ;
1 :op JBE 0x76 >short-jmp* ;
1 :op JA 0x77 >short-jmp* ;
1 :op JS 0x78 >short-jmp* ;
1 :op JNS 0x79 >short-jmp* ;
1 :op JPE 0x7a >short-jmp* ;
1 :op JPO 0x7b >short-jmp* ;
1 :op JL 0x7c >short-jmp* ;
1 :op JGE 0x7d >short-jmp* ;
1 :op JLE 0x7e >short-jmp* ;
1 :op JG 0x7f >short-jmp* ;
1 :op LOOPNZ 0xe0 >short-jmp* ;
1 :op LOOPZ 0xe1 >short-jmp* ;
1 :op LOOP 0xe2 >short-jmp* ;
1 :op JCXZ 0xe3 >short-jmp* ;
1 :op JMP
farptr? if 0x05 0xff >extmem* then
0xe9 >near-reljmp*
0xeb >short-jmp*
0xea >far-jmp*
0x04 0xff >extwreg|mem* ;
1 :op CALL
farptr? if 0x03 0xff >extmem* then
0xe8 >near-reljmp*
0x02 0xff >extwreg|mem* ;
( four opcodes laid out next to each other:
byte mem, reg | word mem, reg | byte reg, mem | word reg, mem )
: memreg? ( -- f ) oparg-mem? swap-args oparg-bwreg? swap-args and ;
: >bmr-wmr? ( base -- f )
memreg? if byteop? not if 1 + then >memreg 1 else drop 0 then ;
: regreg? oparg-wreg? swap-args oparg-wreg? swap-args and ;
: bregbreg? oparg-breg? swap-args oparg-breg? swap-args and ;
: >regreg ( op -- f ) swap-args oparg-val @ swap swap-args >extreg ;
: >brr-wrr? ( base -- f )
regreg? if 1 + else bregbreg? not if drop 0 return then then >regreg 1 ;
( byte any, reg | word any, reg )
: >bar-war* ( base -- )
dup >brr-wrr? if drop 2ret then
>bmr-wmr? if 2ret then ;
: >bmr-wmr-brm-wrm* ( base -- )
dup >bmr-wmr? if drop 2ret then
dup >brr-wrr? if drop 2ret then
2 + swap-args >bmr-wmr? swap-args if 2ret then ;
: >bmr-wmr-brm-wrm? ( base -- f )
1 swap >bmr-wmr-brm-wrm* drop 0 ;
: >6group-math* ( base -- )
dup >bmr-wmr-brm-wrm? if drop 2ret then 4 +
swap-args oparg-imm? swap-args not if drop return then
oparg-reg? not if drop return then
oparg-val @ dup
0x10 = if drop >t swap-args imm?>t swap-args 2ret then
0x00 = if 1 + >t swap-args imm?>t swap-args 2ret then drop ;
: 'extregmem ( op -- op )
byteop? if ' >extbreg|mem* else 1 + ' >extwreg|mem* then ;
: >grp1* ( ext -- )
arg2 oparg-imm? if
oparg-val @ byteval? arg1 byteop? not and
if ' 1 ' byteimm? redefine 0x82 else 0x80 then
'extregmem *? ' byteop? ' byteimm? redefine if 2ret then
else arg1 drop then ;
: >grp2* ( ext -- )
0xd0 swap-args
oparg-imm? oparg-val @ 1 = and not if ( 1, d0/d1 )
oparg-reg? oparg-val @ 0x11 = and
if 2 + ( CL, d2/d3 ) else swap-args 2drop return then
then swap-args
oparg-wreg? if 1 + ' >extreg* else
oparg-breg? if ' >extbreg* else
oparg-mem? if byteptr? not if 1 + then :| >mem 2ret |; else
2drop then then then
1 ignoreimm ! *? 0 ignoreimm ! if 2ret then ;
2 :op XCHG
arg2 oparg-reg? oparg-val @ 0x00 = and arg1 oparg-wreg? and
if 0x90 >wreg+op* then
0x86 >bar-war* ;
2 :op MOV
0x88 >bmr-wmr-brm-wrm*
arg2 oparg-imm? arg1 if
oparg-wreg? if oparg-val @ 0xb8 | >t arg2 oparg-val @ w>t return then
oparg-breg? if oparg-val @ 0x0f & 0xb0 | >t arg2 oparg-val @ >t return then
0 0xc6 >extbmem*
0 0xc7 >extmem*
then
oparg-segreg? if oparg-val @ 0x8e arg2 >extwreg|mem* arg1 then
arg2 oparg-segreg? if oparg-val @ 0x8c arg1 >extwreg|mem* then ;
2 :op ADD 0x00 >6group-math* 0 >grp1* ;
2 :op ADC 0x10 >6group-math* 2 >grp1* ;
2 :op AND 0x20 >6group-math* 4 >grp1* ;
2 :op XOR 0x30 >6group-math* 6 >grp1* ;
2 :op OR 0x08 >6group-math* 1 >grp1* ;
2 :op SBB 0x18 >6group-math* 3 >grp1* ;
2 :op SUB 0x28 >6group-math* 5 >grp1* ;
2 :op CMP 0x38 >6group-math* 7 >grp1* ;
2 :op ROL 0 >grp2* ; 2 :op ROR 1 >grp2* ; 2 :op RCL 2 >grp2* ;
2 :op RCR 3 >grp2* ; 2 :op SHL 4 >grp2* ; 2 :op SHR 5 >grp2* ;
2 :op SAR 7 >grp2* ;
2 :op TEST 0x84 >bar-war* 0 >grp3* ;
1 :op NOT 2 >grp3* ; 1 :op NEG 3 >grp3* ; 1 :op MUL 4 >grp3* ;
1 :op IMUL 5 >grp3* ; 1 :op DIV 6 >grp3* ; 1 :op IDIV 7 >grp3* ;
2 :op LEA oparg-wreg? arg2 oparg-mem? and if 0x8d >memreg then ;
: AL? oparg-reg? oparg-val @ 0x10 = and ;
: AX? oparg-reg? oparg-val @ 0x00 = and ;
: >inout* ( base )
oparg-reg? oparg-val @ 0x03 ( DX ) = and swap-args if
AL? if 8 + >t 2ret then
AX? if 9 + >t 2ret then
then
swap-args oparg-imm? swap-args if
AL? if swap-args >t oparg-val @ >t 2ret then
AX? if swap-args 1+ >t oparg-val @ >t 2ret then
then ;
2 :op IN arg2 0xe4 >inout* ;
2 :op OUT 0xe6 >inout* ;
Reference in a new issue View git blame Copy permalink