From 6c31f368c3ab9dcf3b81862c10a70e451f6ead47 Mon Sep 17 00:00:00 2001 From: Jeremy Penner Date: Wed, 18 Oct 2023 19:39:36 -0400 Subject: [PATCH] refactor iterators to supply an explicit cancel xt, rather than mixing refactor yielders to be defined with explicit suspend, resume, and cancel xts, and not require explicit calls to _resume / _suspend --- iter.jrt | 274 ++++++++++++++++++++++++------------------------------- 1 file changed, 120 insertions(+), 154 deletions(-) diff --git a/iter.jrt b/iter.jrt index d28e572..9a5d972 100755 --- a/iter.jrt +++ b/iter.jrt @@ -39,10 +39,23 @@ nexttop :peek nextpeek MOV BX @[ SS: r@ @] INC BX INC BX MOV @[ SS: r ( c -- ) + MOV BX @[ SS: r@ @] + POP CX + ADD BX CX + MOV @[ SS: r @@ -57,60 +70,66 @@ 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 - : + 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: ) -( -- more nextcount ) -( It must take care of updating the i-stack directly. if there are - no more values, it must remove the values from the i-stack and return - 0 in the "more" place. +( -- xt-iter xt-cancel ) +( The xt-iter word must take care of updating the stacks directly. If + there are no more values, it must remove the values from the i-stack, + 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 - stack by this word. For simple iterators this will be 1, for the space - the iterator word takes. If "more" is 0, this number of items will be - dropped. This is always returned even if there are more items to iterate - over, in order to support efficient cancellation. ">cancel" will push a word - 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. + The xt-cancel word should remove all of the iterator's state from the + iteration stacks and return nothing. "iterdrop" is a useful word to help + with this. If the iterator is itself making use of an iterator below it + on the stack, the xt-cancel word should call "cancel" to recursively clean + that up once it's done. Note that all "next" words _must_ be defined in the target Forth! This means that any iterator that dereferences near memory, such as "links", WILL NOT WORK on the host Forth! ) -( get-next returns the result of the iterator in swapped order - it is usually - more convenient to specify the count last when writing iterators, but it's - 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 ; -: iterate get-next if drop 1 else n-nextdrop 0 then ; +: call-next ( -- xt-iter xt-cancel ) 0 nextpeek execute ; +: iterate call-next drop execute ; +: cancel call-next swap drop execute ; + : EACH_ r ; { ( Because we dereference pointers on the return stack, we must run this @@ -124,138 +143,85 @@ nexttop :push >next :timm continue CONTINUE ; :timm next CONTINUE cancel :| 1 cancelled ! nextdrop get-next if idrop then - 0 cancelled ! 0 swap |; >next ; -{ : break ' >cancel , ['] continue ; immediate +: >cancel :| ' finished :| nextdrop cancel |; |; >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 ; -: times ( n -- ) >i :| i 1 then 1 |; >next ; -: links ( p -- ) - dup if >i :| i 1 then 1 |; >next else nothing then ; -: +for? ( n -- f ) i 1 then ; -: for ( start lim -- ) >next 1- >i :| 1 +for? 2 |; >next ; +: nothing :| ' 0 ' nextdrop |; >next ; +: 1cancel 1 1 iterdrop ; +: single >i :| nextdrop :| ' finished ' 1cancel |; >next 1 |; + ' 1cancel |; >next ; +: times ( n -- ) >i :| :| i finish? |; ' 1cancel |; >next ; +: links ( p -- ) dup + if >i :| :| i finish? |; ' 1cancel |; >next else nothing then ; +: +for? ( n -- f ) i 1 nextpeek = finish? ; +: for ( start lim -- ) + >next 1- >i :| :| 1 +for? |; :| 1 2 iterdrop |; |; >next ; : for+ ( start lim inc -- ) - >next >next 1 nextpeek - >i :| 2 nextpeek +for? 3 |; >next ; -: pchars ( st -- ) 1- >i :| i 1 else drop 0 then 1 |; >next ; + >next >next 1 nextpeek - >i + :| :| 2 nextpeek +for? |; :| 1 3 iterdrop |; |; >next ; +: pchars ( st -- ) 1- >i + :| :| i b@ finished? |; ' 1cancel |; >next ; : nth ( i -- v ) 0 each 2dup = if drop i break then 1+ next swap drop ; : count 0 each 1+ next ; -: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 - - 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 ) +:asm _suspend>args ( |n| |r| yieldpoint -- argcount |n| yieldpoint |r| ) DEC BP DEC BP - MOV SI @[ BP] - - ( run the "cancel" xt in DX ) - 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 # + MOV DI @[ BP] + XOR AH AH + MOV AL @[ SS: DI] PUSH AX - MOV CL @[ BX] - INC CX INC CX - PUSH CX + MOV BX @[ SS: nexttop @] + DEC BX DEC BX + MOV @[ SS: BX] DI + MOV @[ SS: nexttop @] BX 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-args swap >r n->next next ; +: _cancel _resume>args n-nextdrop rdrop ; + +: GENSTART_ next :| :| _resume |; ' _cancel |; >next ; + +( yielding from a generator has three moving parts: + ) { var gen-arg-count :timm (( t:| t, GENSTART_ gen-arg-count @ >t ; :timm )) t|; t, execute 0 gen-arg-count ! ; : +arg 1 gen-arg-count !+ ; :timm +arg +arg ; : -arg -1 gen-arg-count !+ ; :timm -arg -arg ; :timm >arg t, >next +arg ; + ( TODO: totally wrong now ) : :yield } create immediate target , startcolon does> @ w>t gen-arg-count @ >t ; } -:yield yield0 :| ' noop _resume |; _suspend ; -:yield yield >i :| ' idrop _resume idrop |; _suspend ; -:yield yield> >i :| ' idrop _resume i >i :| idrop idrop ' noop _resume |; _suspend ; -:yield map next >i :| :| idrop i cancel |; - _resume idrop i |; _suspend 1+ ; -: _pass-suspend rdrop :| ' cancel _resume |; _suspend ; -: _return rdrop r ; ( don't yield at all, skip past the yielder ) -:yield pass _pass-suspend ; -:yield filter if _pass-suspend then _return ; +: i>next next >i ; : 2>i >i >i ; : 2idrop idrop idrop ; +: unmap idrop i ; : mapcancel unmap cancel ; +: unsuspend rdrop r ; ( don't yield at all, skip past the yielder ) +: suspend? not if unsuspend then ; + +( suspend resume cancel ) + ' noop ' noop ' noop :yield yield0 + ' >i ' idrop ' idrop :yield yield + ' >i ' + ' 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 )) ; : readbytes ( -- ) (( each i b@ map next )) ;