commit da0bcf59c9e610e904d456c3269e8411ce0fd734
parent be090135d4ffeadc250faa2e104a97ea524ca28d
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Thu, 29 Jun 2023 14:15:34 -0400
hal: re-add <>)
Diffstat:
3 files changed, 108 insertions(+), 64 deletions(-)
diff --git a/fs/xcomp/arm/rpi/kernel.fs b/fs/xcomp/arm/rpi/kernel.fs
@@ -26,7 +26,8 @@
: popret, rLR pop, ;
: ret, rLR bx) ,) ;
: absbl, abs>rel bl) ,) ;
-: wcall, xwordlbl absbl, ;
+: abscall, pushret, absbl, popret, ;
+: wcall, xwordlbl abscall, ;
: wjmp, xwordlbl abs>rel b) ,) ; \ only for leaf words!
: pc>reg, ( pc r -- )
@@ -47,11 +48,12 @@
: return) ( -- operand ) mov) rPC rd) rLR rm) ;
: setrd0) ( -- operand ) bic) $f000 imm) ;
: setrn0) ( -- operand ) bic) $f0000 imm) ;
+: setimm0) ( -- operand ) bic) $3f imm) ;
: values ( n -- ) for 0 value next ;
-15 values lblimmsplit lbladdnwr lbllitwr lblimmwr
+16 values lblimmsplit lbladdnwr lbllitwr lblimmwr
lblrn>rm lblrdn lblrd<>rn lblmov lblswp
- lblcwrite lbldwrite lblmoverange lblwriterange
+ lblcwrite lbldwrite lblmoverange lblwriterange lblopwr
lblerrmsg lblmain
$8000 to binstart
binstart const RSTOP
@@ -75,6 +77,7 @@ $e4009000 const HALBASE
$07800000 const HALMASK
$01000000 const HALDEREF
$02000000 const HALIMM
+$00800000 const HALINV
\ ARM immediate system makes it difficult to place sysvars at arbitrary places
\ in the code and they need to be neatly arranged in an easy to refer
@@ -112,6 +115,7 @@ RSTOP xconst RSTOP
4 xconst BRSZ
xcode bye 0 b) ,)
+xcode dbg 0 b) ,)
pc to L1 \ fail
mov) rTOP rd) 0 imm) ,)
@@ -227,7 +231,7 @@ xcode abort
( pc ) r0 pc>reg,
r0 ppush,
mov) rTOP rd) 12 imm) ,)
- pushret, wcall, rtype popret,
+ wcall, rtype
0 b) ,)
xcode findmeta ( id ll -- ll-or-0 ) \ preserves r6
@@ -287,21 +291,17 @@ pc \ we have a nonzero lblnextword. r0=src
mov) rTOP rd) r2 rm) ,)
lblmoverange abs>rel b) ,)
-pc to L1 \ EOF
- mov) rTOP rd) 0 imm) ,)
- popret, ret,
-
xcode maybeword ( -- str-or-0 )
xdup,
r0 binstart NEXTWORD movi2, ldr) r0 rdn) ,)
cmp) r0 rn) 0 imm) ,)
( pc ) abs>rel b) ne) ,)
- pushret,
pc
wcall, in<
xnip,
cmp) rTOP rn) 0 imm) ,)
- L1 abs>rel b) le) ,) \ EOF
+ mov) le) rTOP rd) 0 imm) ,)
+ return) le) ,) \ EOF
cmp) rTOP rn) SPC imm) ,)
( pc ) abs>rel b) le) ,) \ rTOP=first non-ws
mov) r6 rd) 0 imm) ,)
@@ -315,11 +315,11 @@ xcode maybeword ( -- str-or-0 )
( pc ) abs>rel b) gt) ,)
rTOP binstart CURWORD movi2,
str) r6 rd) rTOP rn) 8b) ,)
- popret, ret,
+ ret,
pc ," word expected" alignhere
xcode word
- pushret, wcall, maybeword popret,
+ wcall, maybeword
( pc ) r0 pc>reg,
mov) r1 rd) 13 imm) ,)
cmp) rTOP rn) 0 imm) ,)
@@ -422,10 +422,10 @@ xcode entry pushret, ( 'dict s -- )
popret,
lbldwrite abs>rel b) ,)
-xcode code pushret,
+xcode code
wcall, sysdict
wcall, word
- popret, wjmp, entry
+ wjmp, entry
pc to L1 \ r3=meta-id
r2 binstart SYSDICT movi2, ldr) r2 rdn) ,)
@@ -502,6 +502,10 @@ xcode A>) ( operand -- operand )
orr) rTOP rdn) rA 12 lshift imm) ,)
ret,
+xcode <>) ( operand -- operand )
+ orr) rTOP rdn) HALINV imm) ,)
+ ret,
+
xcode &) ( operand -- operand )
orr) rTOP rdn) HALDEREF imm) ,)
ret,
@@ -511,7 +515,7 @@ xcode &) ( operand -- operand )
\ TODO: add out-of-range error for offsets not fitting 12 bits
\ merge operand with instr and write
-pc to L1 ( operand -- ) \ r0=base instr. Preserves r3
+pc to lblopwr ( operand -- ) \ r0=base instr. Preserves r3
bic) rTOP rdn) HALMASK imm) ,)
orr) r0 rdn) rTOP rm) ,)
xdrop,
@@ -581,7 +585,7 @@ pc to lbllitwr ( n -- ) \ r0=Rd
r1 ppush, ( rest imm+rotate )
( pc ) r3 pc@>reg,
orr) r0 rd) r3 rn) r0 rm) 12 lsl) ,) \ merge Rd in instr
- L1 abs>rel bl) ,)
+ lblopwr abs>rel bl) ,)
r1 pop, popret, \ r1=Rd
lbladdnwr abs>rel b) ,)
@@ -611,10 +615,10 @@ pc to lblrn>rm \ rTOP=operand
ret,
\ Copy Rd to Rn in operand.
-pc to lblrdn \ rTOP=operand
+pc to lblrdn \ rTOP=operand. preserves r0
bic) rTOP rdn) $f0000 imm) ,) \ clear Rn
- and) r0 rd) rTOP rn) $f000 imm) ,)
- orr) rTOP rdn) r0 rm) 4 lsl) ,)
+ and) r1 rd) rTOP rn) $f000 imm) ,)
+ orr) rTOP rdn) r1 rm) 4 lsl) ,)
ret,
\ Swap Rd and Rn in operand
@@ -632,7 +636,7 @@ pc mov) ,)
pc to lblmov ( operand -- )
pushret, lblrn>rm abs>rel bl) ,) popret,
( pc ) r0 pc@>reg,
- L1 abs>rel b) ,)
+ lblopwr abs>rel b) ,)
\ Write an eor between operand's src and dereferenced dst.
pc eor) ,)
@@ -642,7 +646,7 @@ pc to L2
lblrdn abs>rel bl) ,)
( pc ) r0 pc@>reg,
popret,
- L1 abs>rel b) ,)
+ lblopwr abs>rel b) ,)
\ Write a swap between operand's src to operand *dereferenced* dst. Offsets are
\ ignored. Registers only
@@ -666,7 +670,7 @@ pc to L2 ( operand -- ) \ r0=instr
bic) rTOP rdn) $3f imm) ,)
r1 binstart HBANK movi2, ldr) r1 rdn) ,)
orr) nz) rTOP rdn) r1 rm) ,)
- L1 abs>rel b) ,)
+ lblopwr abs>rel b) ,)
\ operand is 16b
pc to L3 ( operand -- ) \ r0=base instr
@@ -681,7 +685,7 @@ pc to L3 ( operand -- ) \ r0=base instr
and) nz) r2 rdn) $f00 imm) ,)
orr) nz) r0 rdn) r1 rm) ,) \ apply low nibble
orr) nz) r0 rdn) r2 rm) ,) \ apply high nibble
- L1 abs>rel b) ,)
+ lblopwr abs>rel b) ,)
\ Write a ldr) or str), depending on instr
pc to L4 ( operand -- ) \ r0=instr
@@ -722,10 +726,9 @@ xcode addr, ( operand -- )
\ operand is 16b and ARM doesn't have a 16b SWP! LDR+STR+MOV...
pc mov) rTOP rd) r0 rm) ,)
pc to L3 ( operand -- )
- pushret, xdup,
+ xdup,
setrd0) rTOP rdn) ,)
wcall, @, wcall, !,
- popret,
( pc ) r0 pc@>reg,
lbldwrite abs>rel b) ,)
@@ -739,41 +742,71 @@ xcode @!, ( operand -- )
tst) rTOP rn) $10 imm) ,) \ has offset?
forward b) z) ,)
xdup, setrd0) rTOP rdn) ,)
- pushret, wcall, addr, popret,
+ wcall, addr,
setrn0) rTOP rdn) ,)
forward!
( pc ) r0 pc@>reg,
- L1 abs>rel b) ,)
+ lblopwr abs>rel b) ,)
-pc to L1 ( operand -- )
- pushret, lblimmwr abs>rel bl) ,) popret,
+\ Write inverted arithmetic operation, that is:
+\ 1. Load operand's src in r0
+\ 2. Apply instr with r0 as Rd and Rn and operand's dst as Rm.
+\ 3. Store r0 in operand's src
+pc to L2 ( operand -- ) \ r0=instr
+ bic) rTOP rdn) HALINV imm) ,)
+ r0 push,
+ lblimmwr abscall,
+ xdup, ( op op )
+ setrd0) rTOP rdn) ,)
+ wcall, @, ( op )
+ xdup, ( op op )
+ setimm0) rTOP rdn) ,)
+ lblrd<>rn abscall,
+ setrd0) rTOP rdn) ,)
+ lblrn>rm abscall,
+ r0 pop, \ r0=instr
+ lblopwr abscall, ( op )
+ setrd0) rTOP rdn) ,)
+ wjmp, !, ( )
+
+\ Write arithmetic operation, that is:
+\ 1. Load operand's src in r0
+\ 2. Apply instr with operand's dst as Rd and Rn and r0 as Rm.
+pc to L1 ( operand -- ) \ r0=instr
+ tst) rTOP rn) HALINV imm) ,)
+ L2 abs>rel b) nz) ,)
+ r0 push,
+ lblimmwr abscall,
+ xdup, ( op op )
setrd0) rTOP rdn) ,)
- wjmp, @,
+ wcall, @, ( op )
+ r0 pop, \ r0=instr
+ setimm0) rTOP rdn) ,)
+ lblrdn abscall,
+ lblopwr abs>rel b) ,) ( )
-pc add) rTOP rdn) r0 rm) f) ,)
xcode +, ( operand -- )
- pushret, L1 abs>rel bl) ,) popret,
- ( pc ) r0 pc@>reg,
- lbldwrite abs>rel b) ,)
+ mov) r0 rd) $00900000 imm) ,) ( add+s ) L1 abs>rel b) ,)
-pc cmp) rTOP rn) r0 rm) ,)
+\ This can't join the arithmetic instr party because Rn has to stay zero.
+pc cmp) rTOP rn) ,) \ TODO: support A>)
xcode compare, ( operand -- )
- pushret, L1 abs>rel bl) ,) popret,
+ lblimmwr abscall,
+ setrd0) rTOP rdn) ,)
+ wcall, @,
( pc ) r0 pc@>reg,
lbldwrite abs>rel b) ,)
xcode +n, ( n operand -- )
- pushret,
- lblimmwr abs>rel bl) ,)
+ lblimmwr abscall,
setrd0) rTOP rdn) ,)
xdup, wcall, @,
swp) rTOP rd) rPSP rn) rTOP rm) ,) ( operand n )
- mov) r1 rd) r0 imm) ,) lbladdnwr abs>rel bl) ,)
- popret, wjmp, !,
+ mov) r1 rd) r0 imm) ,) lbladdnwr abscall,
+ wjmp, !,
pc to L1 ( operand -- ) \ r0=base instr
- pushret,
- lblimmwr abs>rel bl) ,)
+ lblimmwr abscall,
xdup, setrd0) rTOP rdn) ,)
wcall, 32b) rTOP push, r0 push, wcall, @,
setrn0) rTOP rdn) ,)
@@ -786,9 +819,9 @@ pc to L1 ( operand -- ) \ r0=base instr
mov) nz) r1 rd) 1 imm) ,)
r0 pop,
orr) r0 rdn) r1 rm) ,)
- L4 abs>rel bl) ,)
+ L4 abscall,
xdup, rTOP pop,
- popret, wjmp, !,
+ wjmp, !,
pc ldr) 0 +i) post) ,)
xcode [@+], ( operand -- )
@@ -885,7 +918,7 @@ xcode dup,
( pc ) r0 pc@>reg, lbldwrite abs>rel b) ,)
xcode litn
- pushret, wcall, dup, popret,
+ wcall, dup,
mov) r0 rd) rTOP imm) ,) lbllitwr abs>rel b) ,)
\ Arithmetics
@@ -992,10 +1025,10 @@ pc
ret,
\ Interpret loop
-xcode ; ximm pushret,
+xcode ; ximm
wcall, popret,
wcall, exit,
- popret, wjmp, [
+ wjmp, [
\ TODO: fix PS stack at boot, it has spurious elements
pc ," stack underflow" alignhere
@@ -1006,36 +1039,33 @@ xcode stack?
mov) r1 rd) 15 imm) ,)
lblerrmsg abs>rel b) ,)
-pc to L1 pushret, ( str -- w ) \ find in sys dict
+pc to L1 ( str -- w ) \ find in sys dict
wcall, curword
wcall, sysdict
wcall, find
teq) rTOP rn) 0 imm) ,)
xwordlbl (wnf) abs>rel b) eq) ,)
- popret, ret,
+ ret,
pc to L2 ( w -- ) \ findmod+execute
- pushret,
wcall, findmod
wcall, execute
- popret,
wjmp, stack?
xcode compword ( str -- )
- pushret, wcall, parse popret,
+ wcall, parse
cmp) rTOP rn) 0 imm) ,)
xdrop,
xwordlbl litn abs>rel b) ne) ,) \ literal: jump to litn
- pushret, L1 absbl, popret,
+ L1 abscall,
ldr) r0 rd) rTOP rn) 8b) 9 -i) ,)
tst) r0 rn) $80 imm) ,)
L2 abs>rel b) ne) ,) \ immediate? execute
\ compile word
- pushret, wcall, findmod popret,
+ wcall, findmod
wjmp, branchR,
xcode ]
- pushret,
r1 binstart COMPILING movi2,
mov) r0 rd) 1 imm) ,)
str) r0 rd) r1 rn) ,)
@@ -1046,18 +1076,18 @@ pc
cmp) rTOP rn) 0 imm) ,)
xdrop,
( pc ) abs>rel b) nz) ,)
- popret, ret,
+ ret,
xcode runword ( str -- )
r0 binstart COMPILING movi2,
ldr) r0 rdn) ,)
cmp) r0 rn) 0 imm) ,)
xwordlbl compword abs>rel b) ne) ,)
- pushret, wcall, parse popret,
+ wcall, parse
cmp) rTOP rn) 0 imm) ,)
xdrop,
return) ne) ,) \ literal: nothing to do
- pushret, L1 absbl, popret,
+ L1 abscall,
L2 abs>rel b) ,)
xcode main pc w>e org SYSDICT + le!
diff --git a/fs/xcomp/bootlo.fs b/fs/xcomp/bootlo.fs
@@ -23,9 +23,9 @@ code8b HERE @ PSP) A>) @, W) A>) 8b) !, 2drop, exit,
code c! branch, drop
code w! branch, drop
-code +! A) &) !, drop, A) +, A) !, drop, exit,
-code16b A) &) !, drop, A) 16b) +, A) 16b) !, drop, exit,
-code8b A) &) !, drop, A) 8b) +, A) 8b) !, drop, exit,
+code +! PSP) A>) @, W) A>) <>) +, 2drop, exit,
+code16b PSP) A>) @, W) A>) <>) 16b) +, 2drop, exit,
+code8b PSP) A>) @, W) A>) <>) 8b) +, 2drop, exit,
code 1+! 1 W) +n, drop, exit,
code16b 1 W) 16b) +n, drop, exit,
code8b 1 W) 8b) +n, drop, exit,
diff --git a/fs/xcomp/i386/kernel.fs b/fs/xcomp/i386/kernel.fs
@@ -59,6 +59,7 @@ $100 const HAL8B
$20000 const HAL16B
$8000 const HALIMM
$10000 const HALDEREF
+$80000 const HALINV
: _ dx lblhere m) mov, dx 0 d) swap mov, ;
: cwrite, ( opmod -- ) _ lblhere m) inc, ; \ Destroys dx
@@ -171,6 +172,9 @@ xcode A>) ( operand -- operand )
xcode &) ( operand -- operand )
ax HALDEREF i) or, ret,
+xcode <>) ( operand -- operand )
+ ax HALINV i) or, ret,
+
\ Write routines
xcode pushret, ret,
xcode popret, ret,
@@ -231,9 +235,17 @@ pc to L2 ( operand -- ) \ disp8
ax lblhbank m) mov,
al cwrite,
xdrop, ret,
+
+\ Write operand and code which have already been merged together.
+\ Opcode is in b15:8 and modrm in b7:0.
+\ Add 16b prefix when 16b flag is set.
+\ When targeting ESP, mangle op appropriately to add SIB byte.
+\ When modrm indicate there's a displacement, add it from bank.
+\ If the HALINV flag is set, invert direction bit from instruction.
pc to L1 ( operand -- )
lblderef abscall,
- ax HAL16B i) test, forward8 jz, $66 i) cwrite, forward! \ 16b?
+ ax HAL16B i) test, forward8 jz, $66 i) cwrite, forward!
+ ax HALINV i) test, forward8 jz, ax $0200 i) xor, forward! \ inv dir bit
al ah xchg,
ax wwrite,
al ah xchg,
@@ -253,14 +265,16 @@ pc to L3 ( operand -- ) \ immediate
ax lblhbank m) mov,
ax dwrite,
xdrop, ret,
-pc to L2 ( operand -- ) \ 16b or 8b
- ax HAL16B ^ i) and,
+pc to L2 ( operand -- ) \ 16b or 8b, movzx
+ ax HAL16B ^ i) and, \ don't put 16b prefix with movzx
$0f i) cwrite,
ax $b600 i) or, L1 absjmp,
xcode @, ( operand -- ) \ ax operand mov,
ax HALIMM i) test, L3 abs>rel jnz,
+ ax HALINV i) test, forward8 jnz, \ inverted? no movzx!
ax HAL16B i) test, L2 abs>rel jnz,
ax HAL8B i) test, L2 abs>rel jz,
+ forward!
ax $8a00 i) or, L1 absjmp,
xcode @!, ( operand -- ) \ operand ax xchg,
