rewrite generators in assembly

This commit is contained in:
Jeremy Penner 2023-10-10 22:11:56 -04:00
parent c0dec444a4
commit 45f7c01b2d
7 changed files with 128 additions and 24 deletions

Binary file not shown.

View file

@ -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 ; : connect ( st -- ) call noisy 200 sleep-csec handshake ;
import embed.jrt 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 : xmit-screen ( rle -- ) 0 0 textxy! rle-decode each
i 8 >> textpen ! i emit i 8 >> textpen ! i emit

View file

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

144
iter.jrt
View file

@ -57,6 +57,24 @@ nexttop :drop nextdrop
itop :push >i itop :push >i
nexttop :push >next 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 ; : <i 0 ipeek idrop ;
: <next 0 nextpeek nextdrop ; : <next 0 nextpeek nextdrop ;
: i 0 ipeek ; : j 1 ipeek ; : 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. ) always more convenient to check the flag first when consuming the result. )
: get-next ( -- c f ) 0 nextpeek execute swap ; : get-next ( -- c f ) 0 nextpeek execute swap ;
: n-nextdrop ( c -- ) dup if begin nextdrop 1- dup not until then drop ; : n-nextdrop ( c -- ) dup if begin nextdrop 1- dup not until then drop ;
: iteration get-next if drop 1 else n-nextdrop 0 then ; : iterate get-next if drop 1 else n-nextdrop 0 then ;
: EACH_ <r iteration if cell + else @ then >r ; : EACH_ <r iterate if cell + else @ then >r ;
{ ( Because we dereference pointers on the return stack, we must run this { ( Because we dereference pointers on the return stack, we must run this
from the caller's segment. Copy the definition into the host segment. ) 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 : each ' EACH_ , here >i 0 , ; immediate
: continue ' GOTO_ , i cell - , ; immediate : continue ' GOTO_ , i cell - , ; immediate
: next ['] continue here <i ! ; immediate : next ['] continue here <i ! ; immediate
@ -111,6 +129,7 @@ nexttop :push >next
0 cancelled ! 0 swap |; >next ; 0 cancelled ! 0 swap |; >next ;
{ : break ' >cancel , ['] continue ; immediate { : break ' >cancel , ['] continue ; immediate
:timm break t, >cancel CONTINUE ; } :timm break t, >cancel CONTINUE ; }
: cancel >cancel iterate drop ;
: nothing :| 0 1 |; >next ; : nothing :| 0 1 |; >next ;
: single >i :| nextdrop :| idrop 0 1 |; >next 1 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 ; >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 ; : pchars ( st -- ) 1- >i :| <i 1+ dup b@ if >i 1 else drop 0 then 1 |; >next ;
:asm tail ( TODO: support CREATE words ) (
LODSW : gen-save-args [ extra-args... extra-arg-count -- ]
MOV BX AX
INC BX INC BX
MOV SI BX
NEXT
: gen-save-args ( extra-args... extra-arg-count -- )
begin dup while swap >next 1- repeat drop ; 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 ; >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 ; begin dup while <next swap 1- repeat drop ;
)
: cancel >cancel iteration drop ; :asm _resume ( cpcancel -- 0 0 args... )
: _resume ( cpcancel -- c f 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 nextdrop 0 0 <rot
cancelled @ if <next ub@ n-nextdrop execute rdrop return then cancelled @ if <next ub@ n-nextdrop execute rdrop return then
drop <next dup 1+ >r rswap ub@ gen-restore ; drop <next dup 1+ >r rswap ub@ gen-restore ; )
: _suspend ( cpresume -- )
rswap r@ ub@ swap >r gen-save <r <r >next >next ;
: 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 { var gen-arg-count
:timm (( t:| t, GENSTART_ gen-arg-count @ >t ; :timm (( t:| t, GENSTART_ gen-arg-count @ >t ;
@ -162,7 +261,10 @@ nexttop :push >next
:yield map <i >next >i :| :| idrop <next >i cancel |; :yield map <i >next >i :| :| idrop <next >i cancel |;
_resume idrop <next >i |; _suspend 1+ ; _resume idrop <next >i |; _suspend 1+ ;
: _pass-suspend rdrop :| ' cancel _resume |; _suspend ; : _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 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 ;

BIN
swine.com

Binary file not shown.

Binary file not shown.

Binary file not shown.