First cut at an 8086 assembler vocabulary

This commit is contained in:
Jeremy Penner 2023-09-01 19:10:52 -04:00
parent 791e4644aa
commit 102751b342
4 changed files with 331 additions and 3 deletions

169
asm.jrt Executable file
View file

@ -0,0 +1,169 @@
var target
0x100 target !
: >t b, 1 target +! ; ( todo: write to target segment )
: w>t , 2 target +! ;
var op-encode
var lastop
var current-oparg
var opargs-remaining
array oparg1 3 cells allot
array oparg2 3 cells allot
: arg1 oparg1 current-oparg ! ;
: arg2 oparg2 current-oparg ! ;
arg1
: 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-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 @ 3 = ;
( TODO: support explicit byte ptr word )
( ie. inc [bx] vs inc byte [bx]?? )
( or do we just say incb? )
: bytearg? ( -- f )
current-oparg @
arg1 oparg-reg? oparg-breg? and
arg2 oparg-reg? oparg-breg? and or
swap current-oparg ! ;
: byteval? ( v -- f ) 0xff00 & dup 0xff00 = swap 0= or ;
: operror ( err -- ) lastop @ wordname type s": " type type cr ;
: oparg-complete!
opargs-remaining @ dup if
1 - dup opargs-remaining !
if arg2
else arg1 op-encode @ execute 0 op-encode ! then
else s" too many arguments" operror then ;
: # oparg-imm! oparg-complete! ;
: @[ 0 oparg-mem! ;
: @] -1 oparg-base ! oparg-complete ! ;
: unexpected-addr ( addr -- ) drop s" unexpected address" operror ;
: @+ ( disp -- )
opargs-remaining @ if
oparg-type @ dup 0= if drop oparg-mem! oparg-complete!
else 3 = if oparg-val !
else unexpected-addr then then
else unexpected-addr then ;
: l: create target @ , does> @ @+ ;
: 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: take the bottom four bits, left shift 1,
and you have the PUSH instruction byte. bitwise or 0x01 and
you have POP.)
0x25 reg es 0x27 reg ss 0x2d reg cs 0x2f reg ds
: start-op ( does-ptr argcount -- )
opargs-remaining @ if s" not enough arguments" operror then
opargs-remaining ! cell - lastop ! arg1 ;
: prefix create , does> @ >t ;
: 0op create , does> dup 0 start-op @ >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 -- ) , $DOCOLON , does>
dup @ dup start-op cell + op-encode ! ;
: memarg>case ( -- 0|1|2 )
oparg-base @ dup -1 = if drop 1 ( D16 ) else
6 = oparg-val @ 0= 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 2 6 else
memarg>dispsize oparg-base @ then then ;
: regarg>mod+rm ( -- mod rm ) 3 oparg-val @ ;
: modrm>t ( reg mod rm -- ) 0x03 & swap 0x02 & 6 << | swap 0x03 & 3 << | >t ;
: invalid-args s" invalid argument types" operror ;
( convention: words ending in * mean "will return if matched" )
: disp>t memarg>dispsize dup 1= if drop >t else 2 = if w>t else drop then then ;
: imm?>t oparg-imm? if oparg-val @ dup byteval? if >t else w>t then then ;
: >wreg+op* ( base -- )
oparg-wreg? if oparg-val @ | >t rdrop else drop then ;
: >segreg+op* ( off -- )
oparg-segreg? if oparg-val @ 0x0f & 1 << + >t rdrop else drop then ;
: >mem* ( reg op -- )
oparg-mem? if
>t memarg>mod+rm modrm>t disp>t swap-args imm?>t rdrop
else 2drop then ;
: >regreg ( reg op -- ) >t regarg>mod+rm modrm>t ;
: >byte-regreg* ( reg op -- ) oparg-breg? if >regreg rdrop else 2drop then ;
: >regreg* ( reg op -- ) oparg-wreg? if >regreg rdrop else 2drop then ;
1 :op ret- oparg-imm? if oparg-val @ w>t else invalid-args then ;
1 :op push
0x50 >wreg+op*
0 >segreg+op*
6 0xff >mem*
invalid-args ;
1 :op pop
0x58 >wreg+op*
1 >segreg+op*
0 0x8f >mem*
invalid-args ;
1 :op inc
0x40 >wreg+op*
0 0xfe >byte-regreg*
0 0xff >regreg*
0 0xff >mem*
invalid-args ;
1 :op incb
0 0xfe >byte-regreg*
0 0xfe >mem*
invalid-args ;
1 :op dec
0x48 >wreg+op*
1 0xfe >byte-regreg*
1 0xff >regreg*
0 0xff >mem*
invalid-args ;
1 :op decb
1 0xfe >byte-regreg*
1 0xfe >mem*
invalid-args ;

View file

@ -31,7 +31,7 @@ key const sp
' cells @ const $DOCOLON ( get the colon execution token ) ' cells @ const $DOCOLON ( get the colon execution token )
: :| inline| $DOCOLON , ; immediate : :| inline| $DOCOLON , ; immediate
: |; ' ret , |inline ; immediate : |; ' return , |inline ; immediate
: s" state if inline| else here then : s" state if inline| else here then
begin key dup [ key " lit ] != over 0 != and while b, repeat drop 0 b, begin key dup [ key " lit ] != over 0 != and while b, repeat drop 0 b,

159
defs.jrt Executable file
View file

@ -0,0 +1,159 @@
: >rot <rot <rot ;
: 2dup over over ;
: 3dup >r 2dup r@ >rot <r ;
: 4dup >r >r 2dup r@ >rot rswap r@ >rot <r <r swap ;
: nip swap drop ;
: 2= ( a b c d -- a=c&b=d )
>r <rot = swap <r = and ;
: 2swap ( a b c d -- c d a b )
>r >rot <r >rot ;
: negate 0 swap - ;
: abs dup 0 < if negate then ;
: ~ -1 ^ ;
: f! ( b v flag -- )
>rot >r r@ @ >rot ( val flag b r: v )
if | else ~ & then <r ! ;
: f@ ( v flag -- b ) swap @ & ;
: fnot! ( v flag -- ) over @ ^ swap ! ;
: @! ( newval v -- oldval ) dup @ >rot ! ;
: expile state if , else execute then ;
: :noname here $DOCOLON , ] ;
: array word new-word $DOVAR , ;
: create word new-word $DOCREATE , 0 , ;
: finishcreate ( ipfirst -- )
( set cell after codepointer to first instruction of does> )
latest codepointer cell + ! ;
: does> here 4 cells + lit ' finishcreate , ' return , ] ; immediate
: +towards ( from to -- from+-1 )
over > if 1 + else 1 - then ;
: for ( from to -- )
' >r , [ ' begin , ] ( from r: to )
' dup , ' r@ , ' != , [ ' while , ]
' >r , ; immediate ( r: to from )
: i ' r@ , ; immediate
: next
' <r , ' r@ , ' +towards , ( from+1 r: to )
[ ' repeat , ] ' drop , ' rdrop , ; immediate
: breakfor
' rdrop , ' rdrop , 0 lit ' >r , 1 lit ' >r , ; immediate
: yield rswap ;
: done rdrop 0 >r rswap ;
: ;done ' done , ] ; immediate
: each [ ' begin , ] ' r@ , [ ' while , ] ; immediate
: more ' yield , [ ' repeat , ] ' rdrop , ; immediate
: break rswap rdrop :| yield done |; execute rswap ;
: links begin yield @ dup not until drop ;done
: files findfile begin dup while yield nextfile repeat drop ;done
: .files files each type s" " type more ;
: min ( x y -- x|y ) 2dup > if swap then drop ;
: max ( x y -- x|y ) 2dup < if swap then drop ;
: +!pos ( n var -- ) dup @ <rot + 0 max swap ! ;
: cycle! ( var lim -- )
over @ dup 0 < if drop 1 - swap !
else <= if 0 swap !
else drop then then ;
: +!cycle ( n var lim -- ) >r >r r@ +! <r <r cycle! ;
: intern create latest wordname , does> @ ;
: preserving ( cp 0 vars... -- )
0 >r begin dup while dup @ >r >r repeat drop
execute
begin r@ while <r <r swap ! repeat rdrop ;
: preserve ( cp var -- ) 0 swap preserves ;
: decompile-from ( ip -- )
begin dup @ ' return != while
dup @ dup ` dup if type drop else drop . then bl
cell +
repeat drop ;
: decompile word lookup if cell + decompile-from else drop then ; userword
: words
latest links each
dup wordflags F_USERWORD f@ if
dup wordname type bl
then
more ;
: lazy here $DODEFERRED , ' noop , ;
: >lazy! latest codepointer swap redefine ;
: dbg" [ ' s" , ] :| type bl .s cr |; expile ; immediate
( tasks )
: mailbox 2 cells + ;
: task-ip task-user-size cells + ;
: task-sp task-user-size 1 + cells + ;
: task-rsp task-user-size 2 + cells + ;
: task-stack task-user-size 3 + cells + ;
: task-rstack task-stack stacksize cells + ;
: .wordin ( ptr -- )
latest links each
2dup > if wordname type drop 0 break then
more dup if . else drop then ; userword
: tasks.s
tasks links each
dup dup . .wordin s" : " type
dup task-sp @ over task-stack ( task stackLim stack )
2dup . . s" : " type
begin 2dup > while dup @ . cell + repeat
cr drop drop more ; userword
: task.bt ( task -- )
dup task-rsp @ swap task-rstack ( rstackLim rstack )
begin 2dup > while dup @ dup . .wordin cr cell + repeat
drop drop ; userword
: doactivate ( task ip -- )
over task-ip !
dup task-stack over task-sp !
dup task-rstack over task-rsp !
drop
;
: activate
here 4 cells + lit
' doactivate ,
' return ,
; immediate
: >task ( val task -- )
task-sp >r r@ @ ! r@ @ cell + r> ! ;
: try-send ( val task -- b )
mailbox dup @ if drop drop 0 else ! 1 then ;
: wait-send ( val task -- )
mailbox
begin dup @ while suspend repeat ( wait for empty mailbox )
! ;
: send ( val task -- ) try-send drop ;
: receive ( -- val )
running mailbox
begin dup @ not while suspend repeat ( wait for mail )
dup @ 0 <rot ! ;

View file

@ -563,7 +563,7 @@ void f_immediate() {
void f_compileword(); void f_compileword();
void f_semicolon() { void f_semicolon() {
PUSHS("ret"); PUSHS("return");
f_compileword(); f_compileword();
f_compileoff(); f_compileoff();
} }
@ -872,7 +872,7 @@ void f_init() {
CDEF("BZ_", f_bz_); CDEF("BZ_", f_bz_);
CDEF("BNZ_", f_bnz_); CDEF("BNZ_", f_bnz_);
CDEF("INLINEDATA_", f_inline_data_); CDEF("INLINEDATA_", f_inline_data_);
CDEF("ret", f_ret); CDEF("return", f_ret);
CDEF(".", f_dot); CDEF(".", f_dot);
CDEF("u.", f_udot); CDEF("u.", f_udot);
CDEF("type", f_puts); CDEF("type", f_puts);