\ Multitasking vandys
os definitions
NPRIO constant NPRIO \ # distinct task priorities (0..NPRIO-1)
create runqs \ Lists of tasks which may want to run
NPRIO 2 cells * allot
#codes constant #codes \ ...private code space
variable UROOT \ Base user pointer, the one with all
\ the system memory.
\ Get pointers to process fields in USER
: >next ( 0 + ) ; \ Linked lists of tasks
: >'event cell+ ; \ Vector to poll for edisms()
: >evarg cell+ cell+ ; \ ...argument to to pass
: >ctx 3 cells + ; \ Saved RP to restore context
\ vandys
\ Calculate offsets to other user fields
\ TBD... the "<field> up @ -" part is invariant... get
\ it flattened to a constant in the target.
: >rp0 rp0 up @ - + ;
: >sp0 sp0 up @ - + ;
: >prio prio up @ - + ;
: >tib tib up @ - + ; : >tib0 tib0 up @ - + ;
: >cp cp up @ - + ;
\ Return pointer to appropriate run queue slot given USER pointer
: i>runq 2 cells * runqs + ;
: >runq ( ua -- q ) >prio @ i>runq ;
\ Restore SP and then return to existing return stack
: (resume) ( -- ) r> sp! ;
\ A literal of the address of (resume)'s high-level body
meta-' (resume) cell+ cell+ constant (call-resume)
\ vandys
\ Switch to new user area, saving state in old one
: (swtch) ( unew -- ) up @ over <> if
sp@ cell+ >r (call-resume) >r
rp@ up @ >ctx ! dup up ! >ctx @ rp!
else drop then ;
\ Remove task from FIFO queue
: fifo-rem ( q prev -- )
2dup <> if \ Not removing head...
2dup dup @ rot cell+ \ Move tail to prev if was last
dup @ rot = if ! else 2drop then
then
nip dup @ @ swap ! \ Point prev to next node
;
\ vandys
: fifo-queue ( q n -- )
0 over !
over @ if
over cell+ @ over swap !
else
2dup swap !
then
swap cell+ ! ;
: (runit) ( q prev node -- )
-rot fifo-rem \ Save node and remove from queue
(swtch) true ;
\ vandys
\ For a given priority slot, scan across for something runnable.
\ This may be a task ready to run, or a task waiting for an event
\ (and we will invoke a poll of that event here).
\ Returns true if something was found & run.
: (scan) ( queue -- )
\ Walk the linked list of tasks
dup begin dup @ ?dup while
\ An edisms task
dup >'event @ if
dup >evarg @ over >'event @execute if
(runit) exit then
\ Not ready to run, drop node pointer
drop
\ Simply ready to run
else (runit) exit then
>next @ repeat 2drop false
;
\ vandys
\ Find something to run
: (sched)
\ Endlessly scan the priority queues in order
begin NPRIO 0 do
i 2 cells * runqs + \ Point to i'th prio queue
(scan) \ Look for a task to run
if unloop exit then \ ...leave if it happened
loop again
;
\ Set passed task runnable
: setrun ( a -- ) dup >runq swap fifo-queue ;
\ 'pause hook to access scheduler
: (mpause) ( -- ) up @ 0 over >'event ! setrun (sched) ;
\ vandys
\ edisms
\ Block until event
: edisms ( 'fn a -- )
\ Record our event dismiss parameters
up @ tuck >evarg ! tuck >'event !
\ Put us on the event queue and drop into scheduler
dup >runq swap fifo-queue (sched)
;
\ Clone existing stack into appropriately allocated new stack
\ We duplicate eforth.asm's behavior of padding the top of the stack
\ by 8 cells--there's no indication of why this is needed or desired.
: (newstack) ( s s0 u -- a )
\ Stack memory pointer, save as pointer to top
here over 8 cells + allot + >r
\ Count of amount of memory to clone
over -
\ Copy it
r@ over - swap cmove
\ Return pointer to top
r> ;
\ fork--create new task vandys
\ The operand and return stacks are cloned from the caller. The return
\ value is 0 in the new task, and the USER pointer in the original caller.
\ The new task will not run until it is passed to setrun.
TIBS constant TIBS
#stack constant #stack
#rstack constant #rstack
: fork ( -- u | 0 )
up @ UROOT @ - abort" Only task 0 can fork"
up @ here #user dup allot over >r cmove r>
rp@ rp0 @ #rstack (newstack) over >rp0 !
sp@ sp0 @ #stack (newstack) over >sp0 !
\ ...fork, continued vandys
here TIBS allot dup TIBS erase
2dup swap >tib ! over >tib0 !
here #codes allot over >cp !
rp@ rp0 @ - over >rp0 @ + >r
sp@ sp0 @ - over >sp0 @ + 0 over !
r> cell- dup -rot ! cell- (call-resume) over !
over >ctx ! ;
\ vandys
\ Display tasks active in system.
: (.proc) ( up -- ) base @ swap dup hex 8 u.r 3 spaces
dup >prio @ 3 u.r 3 spaces
up @ over = if ." O" else
dup >'event @ ?dup if ." E " 1 u.r else ." R" then then
drop
cr base ! ;
: .procs
cr ." Proc ptr Prio State Event" cr
up @ (.proc)
NPRIO 0 do i i>runq @ begin ?dup while
dup (.proc) >next @
repeat loop ;
\ Connect and disconnect scheduler hooks
: multi ['] (mpause) 'pause ! ;
: single 0 'pause ! ;
\ vandys
\ Bootup actions; record base user pointer and initialize to single
\ tasking.
also initialize definitions
: boot-os ( bool -- n | )
if
cold? if
runqs NPRIO 2 cells * erase
up @ UROOT !
then
( single ) multi
else 300 then ;
only
: fifo-queue Put task on a FIFO queue
Next pointer is always null
If there's a head...
Point tail next at our node
Else head is our node
Tail is now our node
: (runit) The task is ready to run, so remove from queue and run it
Save node and remove from queue
Run it, and flag that we ran it
Intern TIBS, #stack, #rstack constants from metacompiler
: fork Create new task
Fork'ed tasks do not have heaps big enough to fork again
Allocate a new user area, and clone ours
Clone stacks
Allocate private TIB space
Point new user area into this TIB
Create private memory for code dictionary
Calculate rsp and sp in new task
Put 0 on top of new task's stack
Put sp and 'resume on return stack
Put updated RP into saved state