\ -----------------------------------------------------------
\   Cooperative Multitasking
\ -----------------------------------------------------------

#require dict.fs

\ Configuration:

128 cells constant stackspace \ 128 stack elements for every task

\ Internal stucture of task memory:
\  0: Pointer to next task
\  4: Task currently active ?
\  8: Saved stack pointer
\ 12: Handler for Catch/Throw
\  Parameter stack space
\  Return    stack space

false 0 true flashvar-here 4 cells - 4 nvariable boot-task \ Boot task is active, without handler and has no extra stackspace.
boot-task boot-task ! \ For compilation into RAM only

boot-task variable up \ User Pointer
: next-task  ( -- task )    up @ inline ;
: task-state ( -- state )   up @ 1 cells + inline ;
: save-task  ( -- save )    up @ 2 cells + inline ;
: handler    ( -- handler ) up @ 3 cells + inline ;

: (pause) ( stacks fly around )
    (do)                \ push I and I'
    rp@ sp@ save-task !  \ save return stack and stack pointer
    begin
      next-task @ up !     \ switch to next running task
    task-state @ until
    save-task @ sp! rp!  \ restore pointers
    unloop ;              \ pop the loop registers

: wake ( task -- ) 1 cells +  true swap ! ; \ Wake a random task (IRQ save)
: idle ( task -- ) 1 cells + false swap ! ;  \ Idle a random task (IRQ save)

\ -------------------------------------------------------
\  Round-robin list task handling - do not use in IRQ !
\ -------------------------------------------------------

: stop ( -- ) false task-state ! pause ; \ Stop current task
: multitask  ( -- ) ['] (pause) hook-pause ! ;
: singletask ( -- ) [']  nop    hook-pause ! ;

: task-in-list? ( task -- ? ) \ Checks if a task is currently inside of round-robin list (do not use in IRQ)
  next-task
  begin
    ( Task-Address )
    2dup = if 2drop true exit then
    @ dup next-task = \ Stop when end of circular list is reached
  until
  2drop false
;

: previous ( task -- addr-of-task-before )
  \ Find the task that has the desired one in its next field
  >r next-task begin dup @ r@ <> while @ repeat rdrop
;

: insert ( task -- ) \ Insert a task into the round-robin list
  dup task-in-list?  \ Is the desired task currently linked into ?
  if drop else next-task @ over ! next-task ! then
;

: remove ( task -- ) \ Remove a task from the round-robin list
  dup task-in-list?  \ Is the desired task currently linked into ?
  if dup @ ( task next )
     swap previous ( next previous ) !
  else drop then
;

\ -----------------------------------------
\ Create a new task - do not use in IRQ !
\ -----------------------------------------

: task: ( "name" -- )  stackspace cell+ 2*  4 cells +  buffer: ;

: preparetask ( task continue -- )
  swap >r ( continue R: task )

    \ true  r@ 1 cells + ! \ Currently running
      false r@ 3 cells + ! \ No handler

    r@ 4 cells + stackspace + ( continue start-of-parameter-stack )
      dup   r@ 2 cells + ! \ Start of parameter stack

    dup stackspace + ( continue start-of-parameter-stack start-of-return-stack )
    tuck      ( continue start-of-return-stack start-of-parameter-stack start-of-return-stack )
    2 cells - ( continue start-of-return-stack start-of-parameter-stack start-of-return-stack* ) \ Adjust for saved loop index and limit
    swap  !   ( continue start-of-return-stack ) \ Store the adjusted return stack pointer into the parameter stack
    !         \ Store the desired entry address at top of the tasks return stack

  r> insert
;

: activate ( task --   R: continue -- )
  true over 1 cells + ! \ Currently running
  r> preparetask
;

: background ( task --   R: continue -- )
  false over 1 cells + ! \ Currently idling
  r> preparetask
;

\ --------------------------------------------------
\  Multitasking insight
\ --------------------------------------------------

\ There is a more capable variant of "tasks" in multitask-debug.txt.
\ This one is smaller, uncomment if you wish to use it !

\ : tasks ( -- ) \ Show tasks currently in round-robin list
\   hook-pause @ singletask \ Stop multitasking as this list may be changed during printout.
\
\   \ Start with current task.
\   next-task cr
\
\   begin
\     ( Task-Address )
\     dup             ." Task Address: " hex.
\     dup           @ ." Next Task: " hex.
\     dup 1 cells + @ ." State: " hex.
\     dup 2 cells + @ ." Stack: " hex.
\     dup 3 cells + @ ." Handler: " hex. cr
\
\     @ dup next-task = \ Stop when end of circular list is reached
\   until
\   drop
\
\   hook-pause ! \ Restore old state of multitasking
\ ;

\ --------------------------------------------------
\  Exception handling
\ --------------------------------------------------

: catch ( x1 .. xn xt -- y1 .. yn throwcode / z1 .. zm 0 )
  (do) \ push I and I'
  sp@ >r handler @ >r rp@ handler !  execute
  r> handler !  rdrop  0 unloop ;

: throw ( throwcode -- )  dup IF
  handler @ 0= IF false task-state ! THEN \ unhandled error: stop task
  handler @ rp! r> handler ! r> swap >r sp! drop r>
  UNLOOP  EXIT
  ELSE  drop  THEN ;

\ Requires dictionary-tools.txt

\ --------------------------------------------------
\  Multitasking insight
\ --------------------------------------------------

: tasks ( -- ) \ Show tasks currently in round-robin list
  hook-pause @ singletask \ Stop multitasking as this list may be changed during printout.

  \ Start with current task.
  next-task cr

  begin
    ( Task-Address )
    dup             ." Task Address: " hex.
    dup           @ ." Next Task: " hex.
    dup 1 cells + @ ." State: " hex.
    dup 2 cells + @ ." Stack: " hex.
    dup 3 cells + @ ." Handler: " hex.
    dup             ." Name: " variable-name. cr

    @ dup next-task = \ Stop when end of circular list is reached
  until
  drop

  hook-pause ! \ Restore old state of multitasking
;

\ --------------------------------------------------
\  Multitasking debug tools
\ --------------------------------------------------

:  depth ( -- n ) up @ boot-task = if  depth    else up @ 4 cells stackspace    + + sp@ - 2 arshift then ;
: rdepth ( -- n ) up @ boot-task = if rdepth 1- else up @ 4 cells stackspace 2* + + rp@ - 2 arshift then ;

: .s ( -- )
  base @ >r decimal depth ." Stack: [ " . ." ] " r> base !
  depth >r
  begin
    r@ 0 >
  while
    r@ pick .
    r> 1- >r
  repeat
  rdrop
  ."  TOS: " dup . ."  *>" cr
;

: u.s ( -- )
  base @ >r decimal depth ." Stack: [ " . ." ] " r> base !
  depth >r
  begin
    r@ 0 >
  while
    r@ pick u.
    r> 1- >r
  repeat
  rdrop
  ."  TOS: " dup u. ."  *>" cr
;

: h.s ( -- )
  base @ >r decimal depth ." Stack: [ " . ." ] " r> base !
  depth >r
  begin
    r@ 0 >
  while
    r@ pick hex.
    r> 1- >r
  repeat
  rdrop
  ."  TOS: " dup hex. ."  *>" cr
;

: .rs ( -- )
  base @ decimal rdepth ." Returnstack: [ " . ." ] " base !
  rdepth
  begin
    dup 0 >
  while
    dup rpick hex.
    1-
  repeat
  drop
  ."  *>" cr
;
