commit 5c2dba4d74464eac9d7584352e0a167e076829d7
parent 44f745a7554c6e665cc1fddfcf8632ac4c84cb31
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Thu, 25 May 2023 17:29:09 -0400
rpi: add align4 entry and code
That these new words work can't be verified from the command line, but if you
create words with "code" and then dump QEMU memory, you'll see that well-formed
entries are created.
Diffstat:
2 files changed, 87 insertions(+), 19 deletions(-)
diff --git a/fs/asm/arm.fs b/fs/asm/arm.fs
@@ -18,6 +18,7 @@
: rn) ( op r -- op ) 16 lshift or ;
: rd) ( op r -- op ) 12 lshift or ;
: rm) ( op r -- op ) or ;
+: rdn) tuck rd) swap rn) ;
\ immediate shift operations ( op n -- op )
: _ ( op n type -- op ) dip 3 lshift | << or 4 lshift or ;
diff --git a/fs/xcomp/arm/rpi/kernel.fs b/fs/xcomp/arm/rpi/kernel.fs
@@ -17,34 +17,40 @@ $38 const UART0_IMSC
$44 const UART0_ICR
\ Macros
-: xnip, add) rPSP rd) rPSP rn) CELLSZ i) ,) ;
+: xnip, add) rPSP rdn) CELLSZ i) ,) ;
: xdrop, rTOP ppop, ;
-: xnip, sub) rPSP rd) rPSP rn) CELLSZ i) ,) ;
+: xgrow, sub) rPSP rdn) CELLSZ i) ,) ;
: xdup, rTOP ppush, ;
: wcall, xwordlbl abscall, ;
: wjmp, xwordlbl abs>rel b) ,) ;
+: xconst ( n -- ) xcode xdup, mov) rTOP rd) swap i) ,) lret, ;
: delay, ( ncycles -- )
mov) r0 rd) swap ( ncycles ) i) ,)
- pc sub) r0 rd) r0 rn) 1 i) f) ,) ( pc ) abs>rel b) ne) ,) ;
+ pc sub) r0 rdn) 1 i) f) ,) ( pc ) abs>rel b) ne) ,) ;
: pc>reg, ( pc r -- )
dip pc -^ 8 + | ( off r )
mov) over rd) rPC rm) ,)
- sub) over rd) swap rn) swap i) ,) ;
+ sub) swap rdn) swap i) ,) ;
: movi2, ( r n1 n2 -- )
rot mov) over rd) rot i) ,) ( n1 r )
- add) over rd) swap rn) swap i) ,) ;
+ add) swap rdn) swap i) ,) ;
+
+: xaddr ( lbl -- ) xcode xdup, rTOP pc>reg, lret, ;
: values ( n -- ) for 0 value next ;
-2 values lblcurword lblsysdict
+7 values lblcurword lblsysdict lblhere lblnextmeta
+ lblcwrite lbldwrite lblwriterange
$8000 to binstart
binstart const RSTOP
RSTOP $1000 - const PSTOP
+$10000 const HERESTART
0 align4 here to org
forward b) ,)
+HERESTART xconst herestart
xcode emit ( c -- )
pc
ldr) r3 rd) r8 rn) UART0_FR +i) ,)
@@ -69,7 +75,7 @@ xcode rtype ( a u -- )
ldr) rTOP rd) r1 rn) 8b) 1 +i) post) ,)
xdup,
wcall, emit
- sub) r2 rd) r2 rn) 1 i) f) ,)
+ sub) r2 rdn) 1 i) f) ,)
( pc ) abs>rel b) ne) ,)
xdrop,
lret,
@@ -80,9 +86,7 @@ xcode stype ( str -- )
wjmp, rtype
pc to lblcurword $20 allot0
-xcode curword
- xdup, lblcurword rTOP pc>reg,
- lret,
+lblcurword xaddr curword
xcode word ( -- str )
xdup,
@@ -94,7 +98,7 @@ xcode word ( -- str )
mov) r2 rd) 0 i) ,)
lblcurword r1 pc>reg,
pc
- add) r2 rd) r2 rn) 1 i) ,)
+ add) r2 rdn) 1 i) ,)
str) rTOP rd) r1 rn) 8b) 1 +i) pre) !) ,)
wcall, key
xnip,
@@ -136,40 +140,103 @@ xcode bar
wjmp, stype
8 allot0 pc to lblsysdict 0 le,
-xcode sysdict pc w>e lblsysdict pc>addr le!
- xdup, lblsysdict rTOP pc>reg,
- lret,
+lblsysdict xaddr sysdict
xcode find ( name 'dict -- w-or-0 )
r2 ppop,
ldr) r1 rd) r2 rn) 8b) 1 +i) post) ,) \ r2=a r1=len
pc \ loop1
ldr) r3 rd) rTOP rn) 8b) 5 -i) ,) \ entry len
- and) r3 rd) r3 rn) $3f i) ,) \ remove flags
+ and) r3 rdn) $3f i) ,) \ remove flags
cmp) r1 rn) r3 rm) ,)
forward b) ne) ,) to L1
\ same length
sub) r4 rd) rTOP rn) 5 i) ,)
- sub) r4 rd) r4 rn) r1 rm) ,) \ beginning of name range
+ sub) r4 rdn) r1 rm) ,) \ beginning of name range
mov) r5 rd) 0 i) ,)
pc \ loop2
ldr) r6 rd) r4 rn) 8b) r5 +r) ,)
ldr) r0 rd) r2 rn) 8b) r5 +r) ,)
cmp) r6 rn) r0 rm) ,)
forward b) ne) ,) to L2
- add) r5 rd) r5 rn) 1 i) ,)
+ add) r5 rdn) 1 i) ,)
cmp) r5 rn) r1 rm) ,)
( loop2 ) abs>rel b) cs) ,)
\ same contents
- add) rTOP rd) rTOP rn) 4 i) ,) \ e>w
+ add) rTOP rdn) 4 i) ,) \ e>w
lret,
L2 forward! L1 forward! \ not matching, try next
- ldr) rTOP rd) rTOP rn) 0 +i) ,)
+ ldr) rTOP rdn) 0 +i) ,)
cmp) rTOP rn) 0 i) ,)
( loop1 ) abs>rel b) ne) ,)
\ not found
lret,
+pc to lblhere HERESTART le,
+lblhere xaddr here
+
+pc to lblcwrite \ r0=char
+ lblhere r2 pc>reg,
+ ldr) r1 rd) r2 rn) ,)
+ str) r0 rd) r1 rn) 8b) 1 +i) post) ,)
+ str) r1 rd) r2 rn) ,)
+ lret,
+
+pc to lbldwrite \ r0=n
+ lblhere r2 pc>reg,
+ ldr) r1 rd) r2 rn) ,)
+ str) r0 rd) r1 rn) 4 +i) post) ,)
+ str) r1 rd) r2 rn) ,)
+ lret,
+
+pc to lblwriterange \ r0=addr r1=len
+ lblhere r2 pc>reg,
+ ldr) r3 rd) r2 rn) ,)
+ pc
+ ldr) r4 rd) r0 rn) 1 +i) post) ,)
+ str) r4 rd) r3 rn) 1 +i) post) ,)
+ sub) r1 rdn) 1 i) f) ,)
+ ( pc ) abs>rel b) ne) ,)
+ str) r3 rd) r2 rn) ,)
+ lret,
+
+xcode align4 ( n -- )
+ lblhere r0 pc>reg,
+ ldr) r1 rd) r0 rn) ,)
+ add) r2 rd) r1 rn) rTOP rm) ,)
+ and) r2 rdn) 3 i) f) ,)
+ sub) ne) r1 rdn) r2 rm) ,)
+ add) ne) r1 rdn) 4 i) ,)
+ str) ne) r1 rd) r0 rn) ,)
+ xdrop, lret,
+
+pc to lblnextmeta 0 le,
+lblnextmeta xaddr nextmeta
+
+xcode entry ( 'dict s -- )
+ mov) r7 rd) rTOP rm) ,)
+ ldr) r6 rd) r7 rn) 8b) 1 +i) post) ,) \ r7=a r6=len
+ add) rTOP rd) r6 rn) 1 i) ,) \ rTOP=len+1
+ wcall, align4 \ rTOP='dict
+ mov) r0 rd) r7 rm) ,)
+ mov) r1 rd) r6 rm) ,)
+ lblwriterange abscall,
+ mov) r0 rd) r6 rm) ,)
+ lblcwrite abscall,
+ lblnextmeta r0 pc>reg,
+ ldr) r0 rdn) ,)
+ lbldwrite abscall,
+ ldr) r0 rd) rTOP rn) ,) \ r0=dict
+ lblhere r1 pc>reg,
+ ldr) r1 rdn) ,)
+ str) r1 rd) rTOP rn) ,) \ "here" is new sysdict
+ lbldwrite abs>rel b) ,)
+
+xcode code pc w>e lblsysdict pc>addr le!
+ wcall, sysdict
+ wcall, word
+ wjmp, entry
+
forward!
mov) rSP rd) RSTOP i) ,)
mov) rPSP rd) PSTOP i) ,)
