SpindleyQ/dialer
1
1
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

refactor iterators to supply an explicit cancel xt, rather than mixing

Browse source 
refactor yielders to be defined with explicit suspend, resume, and cancel xts,
and not require explicit calls to _resume / _suspend
This commit is contained in:
Jeremy Penner 2023-10-18 19:39:36 -04:00
parent 6c97377f2f
commit 6c31f368c3
1 changed files with 120 additions and 154 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

274
iter.jrt
View file

@ -39,10 +39,23 @@ nexttop :peek nextpeek
MOV BX @[ SS: r@ @] MOV BX @[ SS: r@ @]
INC BX INC BX INC BX INC BX
MOV @[ SS: <r @] BX MOV @[ SS: <r @] BX
NEXT ;
: :ndrop ( pixp -- )
:ASM >r ( c -- )
MOV BX @[ SS: r@ @]
POP CX
ADD BX CX
MOV @[ SS: <r @] BX
NEXT ; } NEXT ; }
itop :drop idrop itop :drop idrop
itop :ndrop n-idrop
nexttop :drop nextdrop nexttop :drop nextdrop
nexttop :ndrop n-nextdrop
: iterdrop ( ci cnext -- ) n-nextdrop n-idrop ;
: finished ( -- 0 ) cancel 0 ;
: finish? ( f -- f ) if 1 else finished then ;
{ : :push ( pixp -- ) { : :push ( pixp -- )
:ASM >r :ASM >r
@ -57,60 +70,66 @@ 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 ;
:asm n-<next ( n |n| args... -- args... |n| )
POP CX
JCXZ 2 @>
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 )
1 :>
POP AX
STOSW
LOOP 1 <@
( fix SP - DI is one word past the end of the stack )
CLD SCASW XCHG SP DI
( update nexttop )
MOV @[ SS: nexttop @] DI
2 <:
NEXT
:asm n->next ( args... n |n| -- |n| args... )
POP CX
JCXZ 1 @>
MOV DI @[ SS: nexttop @]
STD ( next-stack grows down )
SCASW ( pre-decrement )
0 :>
POP AX
STOSW
LOOP 0 <@
CLD SCASW ( correct DI - off by one word )
MOV @[ SS: nexttop @] DI
1 <:
NEXT
( iterator words must have the following shape: ) ( iterator words must have the following shape: )
( -- more nextcount ) ( -- xt-iter xt-cancel )
( It must take care of updating the i-stack directly. if there are ( The xt-iter word must take care of updating the stacks directly. If
no more values, it must remove the values from the i-stack and return there are no more values, it must remove the values from the i-stack,
0 in the "more" place. drop itself from the next-stack, and return 0. "finished" and "finish?"
are useful words to help with this.
"nextcount" must be the number of items that are being taken up on the next The xt-cancel word should remove all of the iterator's state from the
stack by this word. For simple iterators this will be 1, for the space iteration stacks and return nothing. "iterdrop" is a useful word to help
the iterator word takes. If "more" is 0, this number of items will be with this. If the iterator is itself making use of an iterator below it
dropped. This is always returned even if there are more items to iterate on the stack, the xt-cancel word should call "cancel" to recursively clean
over, in order to support efficient cancellation. ">cancel" will push a word that up once it's done.
onto the next-stack that will query the iterator below it to determine how
many items need to be dropped. It will drop one item from the i-stack if the
iterator indicates that there are more items.
If an iterator requires any more complex cleanup to happen as the result
of a cancellation, such as dropping multiple items off the i-stack, or
aborting a task, it should check the "cancelled" flag to determine whether
to perform it. An iterator that returns 0 0 will not cause any further
changes to occur to the iteration stacks, which allows it to be in complete
control of this scenario if needed.
Note that all "next" words _must_ be defined in the target Forth! Note that all "next" words _must_ be defined in the target Forth!
This means that any iterator that dereferences near memory, such as "links", This means that any iterator that dereferences near memory, such as "links",
WILL NOT WORK on the host Forth! ) WILL NOT WORK on the host Forth! )
( get-next returns the result of the iterator in swapped order - it is usually : call-next ( -- xt-iter xt-cancel ) 0 nextpeek execute ;
more convenient to specify the count last when writing iterators, but it's : iterate call-next drop execute ;
always more convenient to check the flag first when consuming the result. ) : cancel call-next swap drop execute ;
: get-next ( -- c f ) 0 nextpeek execute swap ;
: n-nextdrop ( c -- ) dup if begin nextdrop 1- dup not until then drop ;
: iterate get-next if drop 1 else n-nextdrop 0 then ;
: EACH_ <r iterate 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
@ -124,138 +143,85 @@ nexttop :push >next
:timm continue CONTINUE ; :timm continue CONTINUE ;
:timm next CONTINUE <i patch!t ; } :timm next CONTINUE <i patch!t ; }
0 var, cancelled : >cancel :| ' finished :| nextdrop cancel |; |; >next ;
: >cancel :| 1 cancelled ! nextdrop get-next if idrop then { : break ' >cancel , ['] continue ; immediate
0 cancelled ! 0 swap |; >next ;
{ : break ' >cancel , ['] continue ; immediate
:timm break t, >cancel CONTINUE ; } :timm break t, >cancel CONTINUE ; }
: cancel >cancel iterate drop ;
: nothing :| 0 1 |; >next ; : nothing :| ' 0 ' nextdrop |; >next ;
: single >i :| nextdrop :| idrop 0 1 |; >next 1 1 |; >next ; : 1cancel 1 1 iterdrop ;
: times ( n -- ) >i :| <i dup if 1- >i 1 then 1 |; >next ; : single >i :| nextdrop :| ' finished ' 1cancel |; >next 1 |;
: links ( p -- ) ' 1cancel |; >next ;
dup if >i :| <i @ dup if >i 1 then 1 |; >next else nothing then ; : times ( n -- ) >i :| :| <i dup 1- >i finish? |; ' 1cancel |; >next ;
: +for? ( n -- f ) <i + dup 1 nextpeek = if drop 0 else >i 1 then ; : links ( p -- ) dup
: for ( start lim -- ) >next 1- >i :| 1 +for? 2 |; >next ; if >i :| :| <i @ dup >i finish? |; ' 1cancel |; >next else nothing then ;
: +for? ( n -- f ) <i + dup >i 1 nextpeek = finish? ;
: for ( start lim -- )
>next 1- >i :| :| 1 +for? |; :| 1 2 iterdrop |; |; >next ;
: for+ ( start lim inc -- ) : for+ ( start lim inc -- )
>next >next 1 nextpeek - >i :| 2 nextpeek +for? 3 |; >next ; >next >next 1 nextpeek - >i
: pchars ( st -- ) 1- >i :| <i 1+ dup b@ if >i 1 else drop 0 then 1 |; >next ; :| :| 2 nextpeek +for? |; :| 1 3 iterdrop |; |; >next ;
: pchars ( st -- ) 1- >i
:| :| <i 1+ dup >i b@ finished? |; ' 1cancel |; >next ;
: nth ( i -- v ) 0 each 2dup = if drop i break then 1+ next swap drop ; : nth ( i -- v ) 0 each 2dup = if drop i break then 1+ next swap drop ;
: count 0 each 1+ next ; : count 0 each 1+ next ;
:asm _resume ( cpcancel -- 0 0 args... ) :asm _suspend>args ( |n| |r| yieldpoint -- argcount |n| yieldpoint |r| )
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
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 )
( PUSH decrements and then stores; STOSW stores then decrements. )
SCASW ( pre-decrement )
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 XCHG SP DI
( throw away next values )
SHL CX 1 #
ADD DI CX
( update nexttop )
MOV @[ SS: nexttop @] DI
( abort the current word )
DEC BP DEC BP DEC BP DEC BP
MOV SI @[ BP] MOV DI @[ BP]
XOR AH AH
( run the "cancel" xt in DX ) MOV AL @[ SS: DI]
MOV BX DX
JMP @[ BX]
: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 PUSH AX
MOV CL @[ BX] MOV BX @[ SS: nexttop @]
INC CX INC CX DEC BX DEC BX
PUSH CX MOV @[ SS: BX] DI
MOV @[ SS: nexttop @] BX
NEXT NEXT
: GENSTART_ r>next :| ' noop _resume |; >next ; :asm _resume>args ( |n| yieldpoint xt-next -- argcount |n| |r| resumepoint )
MOV BX @[ SS: nexttop @]
MOV DI @[ SS: 2 @+ BX]
ADD BX 4 #
MOV @[ SS: nexttop @] BX
XOR AH AH
MOV AL @[ DS: DI]
INC DI
PUSH AX ( argcount )
MOV DI @[ BP]
INC BP INC BP
NEXT
: _resume _resume>args n-<next rswap ;
: _suspend rswap _suspend>args swap >r n->next <r >next ;
: _cancel _resume>args n-nextdrop rdrop ;
: GENSTART_ <r >next :| :| _resume |; ' _cancel |; >next ;
( yielding from a generator has three moving parts:
)
{ var gen-arg-count { var gen-arg-count
:timm (( t:| t, GENSTART_ gen-arg-count @ >t ; :timm (( t:| t, GENSTART_ gen-arg-count @ >t ;
:timm )) t|; t, execute 0 gen-arg-count ! ; :timm )) t|; t, execute 0 gen-arg-count ! ;
: +arg 1 gen-arg-count !+ ; :timm +arg +arg ; : +arg 1 gen-arg-count !+ ; :timm +arg +arg ;
: -arg -1 gen-arg-count !+ ; :timm -arg -arg ; : -arg -1 gen-arg-count !+ ; :timm -arg -arg ;
:timm >arg t, >next +arg ; :timm >arg t, >next +arg ;
( TODO: totally wrong now )
: :yield } create immediate target , startcolon : :yield } create immediate target , startcolon
does> @ w>t gen-arg-count @ >t ; } does> @ w>t gen-arg-count @ >t ; }
:yield yield0 :| ' noop _resume |; _suspend ; : i>next <i >next >i ; : 2>i >i >i ; : 2idrop idrop idrop ;
:yield yield >i :| ' idrop _resume idrop |; _suspend ; : unmap idrop <next >i ; : mapcancel unmap cancel ;
:yield yield> >i :| ' idrop _resume <i |; _suspend ; : unsuspend rdrop <r 1+ >r ; ( don't yield at all, skip past the yielder )
:yield yield2 >i >i :| idrop idrop ' noop _resume |; _suspend ; : suspend? not if unsuspend then ;
:yield map <i >next >i :| :| idrop <next >i cancel |;
_resume idrop <next >i |; _suspend 1+ ; ( suspend resume cancel )
: _pass-suspend rdrop :| ' cancel _resume |; _suspend ; ' noop ' noop ' noop :yield yield0
: _return rdrop <r 1+ >r ; ( don't yield at all, skip past the yielder ) ' >i ' idrop ' idrop :yield yield
:yield pass _pass-suspend ; ' >i ' <i ' idrop :yield yield>
:yield filter if _pass-suspend then _return ; ' 2>i ' 2idrop dup :yield yield2
' i>next ' unmap ' mapcancel :yield map
' noop ' noop ' cancel :yield pass
' suspend? ' noop ' cancel :yield filter
: take ( n -- ) >arg (( each dup if pass else break then 1- next drop )) ; : take ( n -- ) >arg (( each dup if pass else break then 1- next drop )) ;
: readbytes ( -- ) (( each i b@ map next )) ; : readbytes ( -- ) (( each i b@ map next )) ;