duskos

commit 99ca86001dfc3b35f911a973405d1c4ca065f920
parent a6638b867a5c796dc1487e4bf9fcedbf2a5646fe
Author: Virgil Dupras <hsoft@hardcoded.net>
Date:   Thu,  8 Jun 2023 14:58:25 -0400

rpi: iterators!!!

Diffstat:
M
fs/xcomp/arm/rpi/kernel.fs
 | 
38
+++++++++++++++-----------------------
M
fs/xcomp/rpiboot.fs
 | 
51
+++++++++++++++++++++++++++++++++++++++++++++++++--

2 files changed, 64 insertions(+), 25 deletions(-)
diff --git a/fs/xcomp/arm/rpi/kernel.fs b/fs/xcomp/arm/rpi/kernel.fs
@@ -504,7 +504,7 @@ pc
   orr) rTOP rd) r3 rn) r2 rm) 7 lsl) ,) \ rTOP=rotate+imm
   exit,
 
-pc add) 0 i) ,)
+pc add) 0 i) f) ,)
 pc to lbladdnwr ( n -- ) \ r1=Rd/Rn
   cmp) rTOP rn) 0 i) ,) \ if n=0, don't write anything
   ldr) z) rTOP rd) rPSP rn) CELLSZ +i) post) ,)
@@ -518,10 +518,13 @@ pc to lbladdnwr ( n -- ) \ r1=Rd/Rn
   pushret,
 pc
   lblimmsplit abs>rel bl) ,)
+  r0 push,
   orr) r0 rdn) rTOP rm) ,)
-  lbldwrite abs>rel bl) ,) \ still have flags from immsplit
   mov) rTOP rd) r1 rm) ,)
-  ( pc ) b) nz) ,)
+  lbldwrite abs>rel bl) ,)
+  r0 pop,
+  cmp) rTOP rn) 0 i) ,)
+  ( pc ) abs>rel b) nz) ,)
   xdrop, popret, exit,
 
 xcode rs+, ( n -- )
@@ -746,6 +749,15 @@ xcode branch! ( tgt a -- )
   str) r0 rd) rTOP rn) ,)
   xdrop, exit,
 
+\ a simple SWP pc, [sp] would be nice, right? but we can't...
+\ In this sequence below, remember that PC is 8 bytes ahead.
+pc mov) rLR rd) rPC rm) ,) add) rLR rdn) 8 i) ,)
+   swp) rLR rd) rSP rn) rLR rm) ,) return) ,)
+xcode yield ximm
+  ( pc ) r0 pc>reg,
+  mov) r1 rd) 16 i) ,)
+  lblwriterange abs>rel b) ,)
+
 pc cmp) rTOP rn) 0 i) ,)
 xcode W=0>Z,
   ( pc ) r0 pc@>reg, lbldwrite abs>rel b) ,)
@@ -871,26 +883,6 @@ xcode runword ( str -- )
   pushret, L1 execute, popret,
   L2 abs>rel b) ,)
 
-pc to L1 ( halfbyte -- )
-  cmp) rTOP rn) 10 i) ,)
-  add) lo) rTOP rdn) '0' i) ,)
-  add) hs) rTOP rdn) 'a' 10 - i) ,)
-  wjmp, emit
-
-\ Temporary debug tool
-xcode dump ( a u -- )
-  pushret,
-  r0 ppop, \ r0=a
-  mov) r1 rd) rTOP rm) ,) \ r1=u
-  xdrop,
-pc
-  ldr) r2 rd) r0 rn) 8b) 1 +i) post) ,)
-  xdup, mov) rTOP rd) r2 rm) 4 lsr) ,) L1 abs>rel bl) ,)
-  xdup, and) rTOP rd) r2 rn) $f i) ,) L1 abs>rel bl) ,)
-  sub) r1 rdn) 1 i) f) ,)
-  ( pc ) abs>rel b) nz) ,)
-  popret, exit,
-
 xcode main pc w>e lblsysdict pc>addr le!
 lblmain forward!
 pc
diff --git a/fs/xcomp/rpiboot.fs b/fs/xcomp/rpiboot.fs
@@ -182,9 +182,55 @@ _to to' noop _addr,
 : here HERE _toexec ; immediate
 : alias ' code branch, drop ;
 
-: test ( n ) dup 1+ >r >r V1 emit V2 emit to1+ V2 V2 emit 2rdrop ;
-: test2 doer , does> @ emit ;
+alias @ llnext
+: llend ( ll -- lastll ) begin dup llnext ?dup while nip repeat ( ll ) ;
+: llappend ( elem ll -- ) llend ! ;
+: lladd ( ll -- newll ) here swap llappend here 0 , ;
 
+\ Entry metadata
+: &+ ( n -- ) code W+n, exit, ;
+: &+@ ( n -- ) code W+n, W) @, exit, ;
+-4 &+@ emeta
+-4 &+  'emeta
+: metaadd ( id entry -- ) 'emeta lladd drop , ;
+
+: realias ( 'new 'tgt -- ) to@! here swap branch, drop to here ;
+: :realias ' sysdict curword entry here swap realias ] ;
+: _ ( w -- w-or-0 ) dup ['] noop = if drop 0 then ;
+: chain ( w1 w2 -- w )
+  _ swap _ tuck over and? if
+    here rot execute, swap branch, drop else ?swap nip then ;
+alias noop idle
+
+alias execute | immediate
+: bi dup, ['] swap, ; immediate
+: bi+ dup, ['] over, ; immediate
+: tri dup, ['] rot, ['] over, ; immediate
+: _ [compile] r> ;
+: dip [compile] >r ['] _ ; immediate
+
+\ Iteration
+: xtcomp [compile] ] begin word runword compiling not until ;
+: ivar, ( off -- ) RSP) swap +) toptr@ execute ;
+: i 4 ivar, ; immediate : j 8 ivar, ; immediate : k 12 ivar, ; immediate
+: :iterator doer immediate xtcomp does> ( w -- yieldjmp loopaddr )
+  -16 rs+, RSP) !, LIT>W, RSP) @!,
+  [compile] ahead \ jump to yield
+  [compile] begin ( loop ) ;
+0 value _breaklbl
+: next ( yieldjmp loopaddr -- )
+  swap [compile] then [compile] yield [compile] again
+  12 rs+, 4 [rcnt] +! 0 to@! _breaklbl ?dup drop ; immediate
+: unyield BRSZ RSP) [+n], ; immediate
+: break 16 rs+, [compile] ahead to _breaklbl ; immediate
+
+:iterator for ( n -- ) [
+  1 W+n, RSP) 4 +) !, drop, ahead
+  begin yield swap then -1 RSP) 4 +) [+n], NZ) branchC, drop
+  unyield popret, exit,
+
+:iterator for2 ( lo hi -- )
+  to j to i i j < if begin yield to1+ i i j >= until then unyield ;
 
 \ For RPI model 1
 $20000000 const MMIO_BASE
@@ -221,4 +267,5 @@ UART0_BASE $44 + const UART0_ICR
   $7f2 UART0_IMSC ! \ Mask all interrupts
   $301 UART0_CR ! ; \ Enable UART0, receive & transfer part of UART.
 
+: test for i '0' + emit next ;
 uartinit prompt interactive!