Under construction

A simple cooperative multitasker for use in Forth systems.
For the purpose of defining multiple independently running background program(s).

Characteristics of such a cooperative multitasker:

• Simple
• Compact
• Fast
• Tasks in a circular list
• You determine the task change with PAUSE
• The basic word set: TASK TASK: START-TASK WAKE SLEEP STOP PAUSE

A picture of three installed tasks, task3 is asleep.
All the tasks link to each other so they form a circular list.
Note that the number of task variables may vary for an other implementation.
The clue is to find out what's the most efficient method is for a given CPU & Forth implementation.

0 value TP   \ Task Pointer, points to the current active task control block

Define: TVARIABLE
    Define: ,        \ TCB offset
    Action: @ tp + ; \ Calculate TCB address

\ The main Task Control Block at creation this task links to itself
\ Note: When the main task is put asleep we no longer have the interpreter available
Define: MAIN      \ Pointer to the main tasks control block

0 cells tvariable TLINK   \ A data cell, it links to the next task in the list
1 cells tvariable TSTATE  \ A data cell with this tasks state
2 cells tvariable TERR?   \ Tasks error code
3 cells tvariable TRP     \ Return stack pointer at the time of the task switch
4 cells tvariable TR0     \ Bottom of return stack
5 cells tvariable TS0     \ Bottom of data stack
6 cells constant #CONTROL \ Size of task control block

Function: PAUSE  ( -- )
    Save current tasks the TOS register (if any), stack pointer (SP), 
    instruction pointer (IP) and finally return stack pointer (RP)
    Replace to the task pointer TP with the address of the next active task
    Restore this tasks RP, SP, & TOS if any

Function: WAKE  ( task -- )
    Change the state of 'task' to active, making the task run

Function: SLEEP  ( task -- )
    Change the state of 'task' to inactive, preventing a task to run

Function: STOP  ( -- )
    Put current task in sleep mode and give control to next active task

Function: >TASK ( ip xt task -- )       \ Set task ready on it's R-stack
    Setup 'xt' as the background 'task' on the return stack for this task
    'ip' is the address of the tasks safe execution environment
    The return stack is filled like this: xt ip tos sp
    Where 'sp' is on top of this stack, the stack pointer

Function: TASK  ( +d +r "name" -- )
    Define a new task with "name" and +d cells of data stack space
    and +r cells of return stack space. Also define & initialize a 
    task control block and install a default task on the tasks return stack

Function: TASK:  ( "name" -- )
    Perform the function of TASK creating a task "name" with a data stack
    of 16 cells and a return stack of 32 cells

Function: RUN-TASK    ( -- )
    Build a safe execution environment where a tasks XT is executed
    When an error occurred the task is stopped and the error is noted in tasks TERR?

Function: START-TASK  ( xt task -- )
    Make task run the token xt by placing it in a return stack frame 
    with >TASK it is setup with the correct parameters for PAUSE
    Reset it's error flag and make the task active with WAKE

Function: TASKS  ( -- )
    Show the state of all the tasks in the task list
    For example showing it's name, status, stacks usage, 
    error state and the attached action

Function: RDEPTH  ( task -- +n )
    Calculate the tasks return stack usage in cells '+n'

Function: TDEPTH  ( task -- +n )
    Calculate the tasks data stack usage in cells '+n'

Function:  .STK  ( task -- )
    Calculate & show the tasks data stack usage, like .S

Function: PASS  ( x0 .. xn +n task -- )
    Move the stack items x0 to xn to tasks 'task' data stack

Function: LOCK  ( sema -- )
   Do nothing when the current task already owns the semaphore
   Wait until the task is unlocked while giving control to the next task
   When the task is unlocked grab it by storing my tasks id in it

Function: UNLOCK  ( sema -- )
   Perform the function of UNLOCK and when i own it,
   free the semaphore by storing zero in it

Non standard but commonly used words: SP@ SP!  RP@ RP!
0 value TP   \ Task pointer

: TVARIABLE  \ Leave active tasks variable address
    create ,       ( offset "name" -- )
    does> @ tp + ; ( -- addr )

: HIS  ( task addr1 -- -- addr2 )  tp -  + ; \ Convert addr1 to variable address for task = addr2

\ The task variables in the task control block (TCB)
0 cells tvariable TLINK     \ Task-link chain
1 cells tvariable TSTATE    \ Task awake or not
2 cells tvariable TERR?     \ Error condition 0 = non
3 cells tvariable TRP       \ Return stack pointer
4 cells tvariable TR0       \ Return stack bottom
5 cells tvariable TS0       \ Data stack bottom
6 cells  constant #CONTROL  \ Size of task control block

create MAIN  \ Define main task control block
    main ,  true ,  false ,  0 ,  0 ,  0 ,

main    to tp \ Init task pointer

\ Note this sample code uses the return stack to save the tasks environment
\ It is also possible to do this on the data stack
: PAUSE  ( -- )
    false >r  sp@ >r  rp@ trp !          \ Save Forth environment
    begin  tlink @ to tp  tstate @ until \ Find active task
    trp @ rp!  r> sp!  r> drop ;         \ Restore next tasks environment

: WAKE   ( task -- )    true   swap tstate his ! ;
: SLEEP  ( task -- )    false  swap tstate his ! ;
: STOP   ( -- )         tp sleep  pause ;

: >TASK         ( ip xt task -- )       \ Set task ready on it's R-stack
    >r  r@ tr0 his @ cell-  tuck !      \ Setup task
    cell-  tuck !                       \ Setup IP
    0  swap cell-  tuck !               \ Setup TOS
    r@ ts0 his @  swap cell-  tuck !    \ Setup SP
    r> trp his ! ;                      \ Set tasks RP

create RUN-TASK   ( -- )
    ]  begin  r@ catch terr? !  stop  again  [

: START-TASK      ( xt task -- )       \ Install & start 'task' with 'xt'
    >r  false r@ terr? his !           \ Reset tasks error flag
    run-task swap r@ >task  r> wake ;  \ Set task ready and start it

\ TCB: tlink, tstate, terr?, trp, tr0, ts0.
\ R-stack: sp tos ip xt
: TASK     ( +d +r "name" -- )      \ Build new named task
    here >r  #control allot         \ Allocate TCB
    align  r@ #control 0 fill       \ TCB starts with all zeros
    tlink @  r@ !   r@ tlink !      \ Extend the task link
    cells allot  here r@ tr0 his !  \ Save R0
    cells allot  here r@ ts0 his !  \ Save S0
    run-task  ['] noop  r@ >task    \ Set tasks RP
    r> constant ;                   \ Task name

hex
\ Basic task with 20 cells return stack & 10 cells data stack
: TASK:    ( "name" -- )    20 10 task ;

This part is system specific (noForth t) and it's just an sample implementation:

\ Redefine teminal I/O and MS to include multitasker
: T-KEY?    ( -- f )    key?) dup ?exit  pause ;
: T-KEY     ( -- c )    begin  t-key? until  key) ;
: T-EMIT    ( c -- )    emit)  pause ;
 
: MS        ( u -- )
    3E8 *  40054028 @ >r ( ticker ) \ 1000 us for each step
    begin   pause  40054028 @ r@ -  \ us diff
    over u< 0= until  r> 2drop ;    \ Done when diff U>= us
 
\ Multitasker on/off
: MULTI     ( -- )          \ Start multitasker
    main to tp  false terr? ! \ Initialise main task to TP, no errors yet
    ['] t-emit to 'emit  ['] t-key?  to 'key?  ['] t-key to 'key ;
 
: SINGLE    ( -- )          \ Leave multitasker
   ['] emit) to 'emit  ['] key?) to 'key?  ['] key) to 'key ;

Now a simple example, a counter as background task:

task: one
0 value CNT  decimal
: COUNTER  1 2 3  begin  1 +to cnt  50 ms  again ;
' counter  one start-task  
multi

Final example a very simple tool to view the tasks.
You could make it much more fancy by decoding the data to a more usefull form:

Uses: @+
 
: .WORD     ( u -- ) \ Type the word 'u' with 8-digits
    0 <# # # # # # # # # #> type space ;
 
: TASKS     ( -- )  \ Show all eight data cells from the TCB
    main
    begin
        cr dup .word  space dup @+ .word  @+ .word  @+ .word  @+ .word  @ .word
    @ dup main = until  drop ;

When a Forth system has a DOES> that can be used interactive, the words RUN-TASK and START-TASK can be written as one word like this:

create START-TASK   ( xt task -- )  \ Install & start 'task' with 'xt'
    ]  begin  r@ catch terr? !  stop  again  [
DOES>      ( xt task ip -- )
    swap >r  false r@ terr? his !   \ Reset tasks error flag
    swap r@ >task  r> wake ;        \ Set task ready and start it

Semaphores are a way to make part of the processor (temporary) your own. When several tasks need the same device it is not very handy that they access this device at about the same time. That's where semaphores can be used.

: LOCK      ( sema -- )
    dup @ TP = IF  drop exit  THEN  \ Do nothing when i own it
    BEGIN  dup @ WHILE pause REPEAT \ Semaphore not mine, to next task
    TP swap ! ;                     \ Semaphore free, grab it!
 
: UNLOCK    ( sema -- )     dup lock  false swap ! ; \ Free semaphore

Implementations