rewrite generators in assembly

dialer.jrt

@@ -63,7 +63,9 @@ array dtmf-row 697 freq>div , 770 freq>div , 852 freq>div , 941 freq>div ,
 : connect ( st -- ) call noisy 200 sleep-csec handshake ;
 
 import embed.jrt
-array rick-welcome-rle { s" rickclub.bin" embed-rle }
+array rick-welcome-rle 
+{ : lines-of pagew 2* * take ; 
+  s" rickclub.bin" open filebytes 18 lines-of encode-rle }
 
 : xmit-screen ( rle -- ) 0 0 textxy! rle-decode each
     i 8 >> textpen ! i emit

embed.jrt

@@ -32,8 +32,8 @@ var rle-run
 
 : >rle-done 0 rle-run ! target rle-start @ !t ;
 
-: encode-rle ( -- , with iterator that returns bytes )
-  >rle-start each i iteration if i 8 << | >rle else drop then next >rle-done ;
+: encode-rle ( call with iterator that returns bytes )
+  >rle-start each i iterate if i 8 << | >rle else drop then next >rle-done ;
 : embed-rle ( host-filename -- ) open filebytes encode-rle ;
 : embed ( host-filename -- ) 
   target 0 w>t open filebytes each i >t next target swap !t ;

iter.jrt

@@ -57,6 +57,24 @@ nexttop :drop nextdrop
 itop    :push >i
 nexttop :push >next
 
+:asm r>next
+  MOV BX @[ SS: nexttop @]
+  DEC BX DEC BX
+  DEC BP DEC BP
+  MOV AX @[ BP]
+  MOV @[ SS: nexttop @] BX
+  MOV @[ SS: BX] AX
+  NEXT
+
+:asm next>r
+  MOV BX @[ SS: nexttop @]
+  MOV AX @[ SS: BX]
+  INC BX INC BX
+  MOV @[ SS: nexttop @] BX
+  MOV @[ BP] AX
+  INC BP INC BP
+  NEXT
+
 : <i    0 ipeek    idrop ;
 : <next 0 nextpeek nextdrop ;
 : i 0 ipeek ; : j 1 ipeek ;
@@ -92,12 +110,12 @@ nexttop :push >next
   always more convenient to check the flag first when consuming the result. )
 : get-next ( -- c f ) 0 nextpeek execute swap ;
 : n-nextdrop ( c -- ) dup if begin nextdrop 1- dup not until then drop ;
-: iteration get-next if drop 1 else n-nextdrop 0 then ;
-: EACH_ <r iteration if cell + else @ then >r ;
+: iterate get-next if drop 1 else n-nextdrop 0 then ;
+: EACH_ <r iterate if cell + else @ then >r ;
 
 { ( Because we dereference pointers on the return stack, we must run this 
     from the caller's segment. Copy the definition into the host segment. )
-  : EACH_ <r iteration if cell + else @ then >r ;
+  : EACH_ <r iterate if cell + else @ then >r ;
   : each ' EACH_ , here >i 0 , ; immediate
   : continue ' GOTO_ , i cell - , ; immediate
   : next ['] continue here <i ! ; immediate
@@ -111,6 +129,7 @@ nexttop :push >next
              0 cancelled ! 0 swap |; >next ;
 { : break ' >cancel , ['] continue ; immediate
   :timm break t, >cancel CONTINUE ; }
+: cancel >cancel iterate drop ;
 
 : nothing :| 0 1 |; >next ;
 : single >i :| nextdrop :| idrop 0 1 |; >next 1 1 |; >next ;
@@ -123,29 +142,109 @@ nexttop :push >next
   >next >next 1 nextpeek - >i :| 2 nextpeek +for? 3 |; >next ;
 : pchars ( st -- ) 1- >i :| <i 1+ dup b@ if >i 1 else drop 0 then 1 |; >next ;
 
-:asm tail ( TODO: support CREATE words )
-  LODSW
-  MOV BX AX
-  INC BX INC BX
-  MOV SI BX
-  NEXT
-
-: gen-save-args ( extra-args... extra-arg-count -- )
+(
+: gen-save-args [ extra-args... extra-arg-count -- ]
   begin dup while swap >next 1- repeat drop ;
-: gen-save ( 0 0 extra-args... extra-arg-count -- 1 cnext ) 
+: gen-save [ 0 0 extra-args... extra-arg-count -- 1 cnext ]
   >r r@ gen-save-args <r 2 + >rot drop drop 1 swap ;
-: gen-restore ( arg-count -- args... )
+: gen-restore [ arg-count -- args... ]
   begin dup while <next swap 1- repeat drop ;
+)
 
-: cancel >cancel iteration drop ;
-: _resume ( cpcancel -- c f args... )
+:asm _resume ( cpcancel -- 0 0 args... )
+  POP DX
+  MOV AX SS
+  MOV ES AX
+  PUSH FALSE
+  PUSH FALSE
+  MOV DI @[ SS: nexttop @]
+
+  ( make SP affect the nextstack and DI affect the data stack. )
+  STD ( data stack grows down ) 
+  XCHG DI SP 
+  ( PUSH decrements and then stores; STOSW stores then decrements. )
+  SCASW ( pre-decrement )
+   
+  POP BX ( points to xt of the girl calling this, discard )
+  POP BX ( points to the following the yield )
+  XOR CX CX
+  MOV CL @[ BX]
+  CMP @[ cancelled @] 0 #
+  JNZ 0 @>
+  ( not cancelled; move CX values from next-stack to data-stack )
+  JCXZ 2 @>
+1 :>
+  POP AX
+  STOSW
+  LOOP 1 <@
+2 <:
+  ( fix return stack to return to the yielded code )
+  INC BX 
+  MOV @[ BP] BX 
+  INC BP INC BP
+  ( fix SP - DI is one word past the end of the stack )
+  CLD SCASW XCHG SP DI
+  ( fix nexttop )
+  MOV @[ SS: nexttop @] DI
+  NEXT
+0 <:
+  ( cancelled! )
+  ( fix SP )
+  CLD SCASW XCHG SP DI
+  ( throw away next values ) 
+  SHL CX 1 #
+  ADD DI AX
+  ( update nexttop )
+  MOV @[ SS: nexttop @] DI
+  ( abort the current word )
+  DEC BP DEC BP
+  MOV SI @[ BP]
+  ( run the "cancel" xt in DX )
+  MOV BX DX
+  JMP @[ BX]
+
+( : _resume [ cpcancel -- c f args... ]
   nextdrop 0 0 <rot 
   cancelled @ if <next ub@ n-nextdrop execute rdrop return then
-  drop <next dup 1+ >r rswap ub@ gen-restore ;
-: _suspend ( cpresume -- ) 
-  rswap r@ ub@ swap >r gen-save <r <r >next >next ;
+  drop <next dup 1+ >r rswap ub@ gen-restore ; )
 
-: GENSTART_ <r >next :| ' noop _resume |; >next ;
+:asm _suspend ( 0 0 cpresume -- 1 n )
+  POP DX
+  MOV AX SS
+  MOV ES AX
+  MOV DI @[ SS: nexttop @]
+  DEC BP DEC BP ( top of return stack points to arg count )
+  MOV BX @[ BP]
+  XOR CX CX
+  MOV CL @[ BX]
+  STD ( next-stack grows down )
+  SCASW ( pre-decrement )
+  JCXZ 1 @>
+0 :>
+  POP AX
+  STOSW
+  LOOP 0 <@
+1 <:
+  MOV AX BX
+  STOSW
+  MOV AX DX
+  STOSW
+  CLD SCASW
+  MOV @[ SS: nexttop @] DI
+  ( data stack contains 0 0, must become 1 argcount+2 )
+  POP AX
+  POP AX
+  MOV AX 1 #
+  PUSH AX
+  MOV CL @[ BX]
+  INC CX INC CX
+  PUSH CX
+  NEXT
+
+( : _suspend [ cpresume -- ]
+    rswap r@ ub@ swap >r gen-save rswap r>next r>next ; )
+
+: GENSTART_ r>next :| ' noop _resume |; >next ;
 
 { var gen-arg-count 
   :timm (( t:| t, GENSTART_ gen-arg-count @ >t ;
@@ -162,7 +261,10 @@ nexttop :push >next
 :yield map    <i >next >i :| :| idrop <next >i cancel |; 
                              _resume idrop <next >i |; _suspend 1+ ;
 : _pass-suspend rdrop :| ' cancel _resume |; _suspend ;
+: _return rdrop <r 1+ >r ; ( don't yield at all, skip past the yielder )
 :yield pass _pass-suspend ;
-:yield filter if _pass-suspend else <r 1+ >r then ;
+:yield filter if _pass-suspend then _return ;
 
-: chars pchars (( each i b@ map next )) ;
+: take ( n -- ) >arg (( each dup if pass else break then 1- next drop )) ;
+: readbytes ( -- ) (( each i b@ map next )) ;
+: chars ( p -- ) pchars readbytes ;