: .system_name ( --) $HEADING $type ;
zero
| DUP CONSTANT _#task_table_level 2+
| DUP CONSTANT _#task_table_name CELL+
| DUP CONSTANT _#task_table_activation CELL+
| CONSTANT _#task_table_length
HOST
-1 CONSTANT _#activate_in_user
\ task_table variables, this table can be prommed
??HEX
forth : _task_table_entry
HOST
CREATE tw,
DOES>
W@ _%task_table @ +
;
HOST
| _#task_table_level _task_table_entry _task_table_level
| _#task_table_name _task_table_entry _task_table_name
| _#task_table_activation _task_table_entry _task_table_activation
: task_abort user_base xoff ; RECOVER
| : task_underrun ( --)
TRUE ABORT" R stack underrun." ;
' task_underrun (return_error) t!
\ default task resources.
400 _#sys_buffer_user - CONSTANT Smax
400 _#sys_buffer_user - CONSTANT Rmax
400 _#sys_buffer_user - CONSTANT Umax
??HEX
\ Given a user_variable reference to the current running task
\ convert to a reference in the other task.
: other_task ( user_variable user_area -- user_new)
SWAP user_base - +
;
\ Given the user area of another task ( that is not running)
\ push a value onto the new tasks stack.
: push_other_task ( value user_area --)
TUCK \ user_area value user_area(--
(S) SWAP other_task @ \ user_area value addr(--
cell- TUCK \ user_area addr- value addr-(--
! \ user_area addr-(--
SWAP \ addr- user_area(--
(S) SWAP other_task ! \ (--
;
Given a few stack parameters make a task out of thin air well from free buffers anyway. This version is used on startup, the task loops isn't claimed. And the task created is owned by no one.
: _make_new_task { variable _%user_size
variable _%return_size
variable _%data_size
variable _%new_task_name>
variable _%new_task_name_count
variable _%new_task_level
variable _%activation_area
-- variable _%new_user }
\ Get a buffer to use as the User area
_%user_size @ get_free_buffer _%new_user !
\ Indicate that the buffer belongs to us
_%new_user @ _%new_user @ buffer_save_task
\ Clear the user area
_%new_user @ _%user_size @ ERASE \ (--
\ Set the activate pointers.
\ after this is set the activation words such as activation_base
\ could be used.
_%activation_area @ _#activate_in_user = IF
\ start of the user area
_%new_user @ DUP #activation_task> + !
_%new_user @ _activation> _%new_user @ other_task !
_%new_user @ _%activation_area !
ELSE
\ address provided
_%activation_area @ _activation> _%new_user @ other_task !
_%new_user @ _%activation_area @ #activation_task> + !
THEN
\ Put the first task in the task loop into the link of the new task
_%new_task_level @ CELLS _xheads + @ \ level_base(--
#activation_task_link + \ link(--
DUP @ ( following task) \ link (link)(--
_%activation_area @ #activation_task_link + ! \ link(--
\ Set the trap instruction of the new task
4E42 \ ##code 2 # TRAP
_%activation_area @ #activation_trap + W!
cache_flush
\ Set the tasks status to sleep
sleep _%activation_area @ #activation_status + W!
\ set the task level in the tasks user area
_%new_task_level @ _%task_level _%new_user @ other_task !
\ set up stack memory areas
\ The end address only is set if the stacks were not
\ created from free buffers
\ Set up data stack
_%data_size @ get_free_buffer DUP DUP buffer_size + \ link beginning end (--
DUP _%data_stack_end _%new_user @ other_task !
\ Set up stack now so data can be pushed on stack with push_other_task after make_new_task and
\ before _start_new_task
(S) _%new_user @ other_task !
zero _%new_user @ push_other_task
$BACEBACE _%new_user @ push_other_task
\ save the base so buffer can be returned if task decides to use
\ faster memory.
DUP _%data_stack_base _%new_user @ other_task !
\ change set to task to the new task
_%new_user @ SWAP buffer_save_task
\ Set up return stack
_%return_size @ get_free_buffer DUP DUP buffer_size + \ link beginning end (--
_%return_stack_end _%new_user @ other_task !
\ save the base so buffer can be returned if task decides to use
\ faster memory.
DUP _%return_stack_base _%new_user @ other_task !
\ change set to task to the new task
_%new_user @ SWAP buffer_save_task
\ Vectored functions
['] task_abort 'abort _%new_user @ other_task !
['] .system_name 'HEADING _%new_user @ other_task !
['] ?CREATE 'create _%new_user @ other_task !
\ the task name to the user area
_%new_task_name> @ _%task_name> _%new_user @ other_task !
_%new_task_name_count @ _%task_name_count _%new_user @ other_task !
0A BASE _%new_user @ other_task !
\ _#initial_q_base
\ %q_base _%new_user @ other_task !
_#initial_q_digits
%fractional_digits _%new_user @ other_task !
\ The root wordlist for this task
~root _task_root_wordlist _%new_user @ other_task !
\ link into loop
\ the address was determined new the beginning of the word.
_%activation_area @ SWAP ! ( In task loop asleep) \ (--
;
\ This is for use in applications, the created task belongs to the
\ task running the word.
\ The task is created with the task loop locked so
\ this word can be used from multiple tasks.
: make_new_task { ( _%user_size _%return_size _%data_size _%new_task_name> )
( _%new_task_name_count _%new_task_level %activation_area)
( -- _%new_user )
}{ variable _%loop_head }
\ claim the task loop
OVER
CELLS _xheads + @ _%loop_head !
_%loop_head @ _#level_head_facility + grab
_make_new_task
\ add the tasks to this tasks children list
_%task_parent OVER other_task
_%task_children link_double
\ release the loop
_%loop_head @ _#level_head_facility + release
;
CREATE $not_in_loop ," Task not in loop."
\ This can only to be used if the task loop has been claimed
\ Flag is true if failure
: _remove_task_from_loop { variable _%user_addr variable _%head_loop ( --$) }
_%head_loop @
BEGIN
DUP #activation_task_link + @ \ link (link)(--
DUP _%head_loop @ <>
WHILE
\ link (link)
#activation_task> + @
_%user_addr @ \ link (user_addr) user_addr(--
= IF \ we have the link address to deal with the problem
DUP #activation_task_link + @
DUP #activation_task_link + @
\ link (link) ((link))
NIP SWAP #activation_task_link + !
FALSE
EXIT
THEN
\ link(--
#activation_task_link + @
REPEAT
\ If we get to here user_addr was not in loop
\ link (link)(--
2DROP
$not_in_loop
;
: ?child_task ( user_addr -- flag )
_%task_children @
BEGIN
DUP
WHILE
\ user_addr link (--
2DUP [ user_base _%task_parent - ]T LITERAL + = IF \ this is it
2DROP
TRUE
EXIT
THEN
REPEAT
DROP
FALSE
;
This is the only valid way to claim a task, the task loops must be claimed first and then the task. You must not search for the task in the loop until the task loop is claimed
We leave this word with the task loop claimed as the user may desire task loop alterations ( remove the task as an example).
CREATE $no_task ," task not in loop"
: claim_task { ( level ) variable %user_addr -- ( facility zero | $ ) }{
variable _%loop_head
}
CELLS _xheads + @ _%loop_head !
_%loop_head @ _#level_head_facility + grab
_%loop_head @
BEGIN
\ while there are tasks in the loop to look at.
#activation_task_link + @ DUP
_%loop_head @ <> \ task flag (--
WHILE \ task (--
DUP #activation_task> + @ %user_addr @ \ link link user_addr(--
= IF
\ Note we are claiming two facilities, as soon as you do this
\ we risk deadlock. Never Never claim a task and then the head.
\ Always claim the head first.
\ activity_area(--
#activation_task> + @
\ user_area(--
%task_facility SWAP other_task grab
_%loop_head @ _#level_head_facility +
\ Ok the task is now ours. We don't stop if from running.
\ We just stop it from being destroyed. The word that destroys
\ tasks have to execute this word.
zero
\ loop_facility zero(--
EXIT
THEN
REPEAT
DROP
\ get to here their isn't the required number of tasks in the loop.
_%loop_head @ _#level_head_facility + release
$no_task
;
A task cannot destroy itself, hard to run with no resources, the code passes it off to the kill_task to do. Don't destroy tasks on lower levels, the level could be suspended as a machine state, code passes it off to the kill_task to do. Only destroy yourself or your children is good advise.
\ we force the queuing so the queue depth is not relevent
\ we destroy in queue order so only one priority.
0 1 net_queue _kill_task_queue
: destroy_task { variable _%user_addr -- }{
variable _%task_loop
variable %facility }
\ (--
\ Claim the task loop
_%task_level _%user_addr @ other_task @ DUP
\ level level(--
\ check that we are within defined priority levels.
0 [ #clock_low 1+ ]T LITERAL WITHIN not
ABORT" Level not within range.
\ level(--
DUP CELLS _xheads + @ _%task_loop !
\ level(--
_%user_addr @ claim_task
\ loop_facility zero | $(--
$ABORT
\ loop_facility(--
%facility !
\ (--
user_base _%user_addr @ = IF
\ have to queue the task for the kill_task task.
%facility @ release
%task_facility _%user_addr @ other_task release
_%task_link _%user_addr @ other_task
_kill_task_queue zero enqueue_force
EXIT
THEN
\
\ This needs some explanation.
\ Higher level loops are run to completion before a lower level is started.
\ So if a task is on a lower level or the same level we know that there is
\ not a stack frame describing the level. If we remove a task and there
\ is a stack frame descibeing the level with the cpu executing that level
\ we will be in trouble. This can occure if we start destoying tasks that
\ run at a lower level. The kill_task runs at the lowest level so it can
\ destroy anything.
\
_%task_level _%user_addr @ other_task @ _%task_level @ > IF
\ have to have the kill_task task do it
%facility @ release
%task_facility _%user_addr @ other_task release
_%task_link _%user_addr @ other_task
_kill_task_queue zero enqueue_force
EXIT
THEN
\ have to nuke the children first
_%task_children _%user_addr @ other_task BEGIN
@ DUP
WHILE
\ link(--
DUP [ user_base _%task_parent - ]T LITERAL +
RECURSE
REPEAT
DROP
_%user_addr @ _%task_loop @ _remove_task_from_loop
\ the error is not in loop, that is not a reason to stop this task
DROP
\ The task is now out of the loop we can release
\ the loop facility no one will find us.
\ loop_facility(--
%facility @ release
%task_facility _%user_addr @ other_task release
\ Unlink from parent
\ This assumes the task lives and is not being destroyed by others.
_%task_parent _%user_addr @ other_task unlink_double
\ Return buffers
\ These values will be zero if the data stack and return stack
\ are not free buffers.
\ If the values are zero kill_free_buffer will return without action.
_%data_stack_base _%user_addr @ other_task @ kill_free_buffer
_%return_stack_base _%user_addr @ other_task @ kill_free_buffer
\ destroy free buffers
_%user_addr @ _return_ufree_buffers
_%user_addr @ kill_free_buffer
\ and that is about it gone.
;
: end_task ( --)
\ game has finished
\ don't have to tidy stack
'abort_file @ close
xsleep
@u destroy_task
xnext
;
| : abort_oh_dear
panic_cr panic" ABORT within end_task"
panic_cr panic" Data stack"
@s $20 panic_dump
panic_cr panic" return stack"
@r $40 panic_dump
\ just give up with this task.
xoff
;
| : abort_end_task ( --)
['] abort_oh_dear 'abort !
end_task
;
: _start_new_task { variable %action variable %user_base -- }{
variable %activation_area
variable %stack
variable %return_stack }
\ get and save base address of the activation area
[ _activation> user_base - ]T LITERAL %user_base @ + @
%activation_area !
\ get the top of the data stack from the user area
\ and save as %stack
[ (S) user_base - ]T LITERAL %user_base @ + @
%stack !
\ Get the top of the return stack and save
\ as %return_stack
[ _%return_stack_end user_base - ]T LITERAL %user_base @ + @
%return_stack !
\
\ It is hopped this word will get executed on return stack
\ underflow.
cell NEGATE %return_stack +!
['] (return_error) %return_stack @ !
\ save action in user area for future reference.
\ and push onto return stack
%action @ [ _'task_initial_action user_base - ]T LITERAL %user_base @ + !
cell NEGATE %return_stack +!
%action @ %return_stack @ !
\ LP onto data stack
cell NEGATE %stack +!
0 %stack @ !
\ OP onto the data staxk
cell NEGATE %stack +!
0 %stack @ !
\ push the current value of the return stack onto the data stack
cell NEGATE %stack +!
%return_stack @ %stack @ !
\ save current value of data stack into user area.
%stack @ [ (S) user_base - ]T LITERAL %user_base @ + !
\ set the current time.
xclock+ @ [ _task_restart_time user_base - ]T LITERAL
%user_base @ + !
\ wake up the task
wake #activation_status %activation_area @ + W!
;
Describe the task head. The table pointer has to be first so the code "task_name @" will return the task table.
zero
DUP CONSTANT _#task_head_table> CELL+
DUP CONSTANT _#task_head_prom> CELL+
DUP CONSTANT _#task_head_action
CONSTANT _#task_head_length
This work is used to start a task that has a task table. There is no use looking to see if a varsion of a task is running. If the code is re-enterent running multiple copies is a valid thing to do.
: taskin { ( task_base_address--) }{
variable _%new_task_table }
DUP _#task_head_table> + @ _%new_task_table !
Umax Rmax Smax
_%new_task_table @ _#task_table_name + @ name_count \ Umax Rmax Smax addr n+flags (--
_#name_count_bits AND
_%new_task_table @ _#task_table_level + W@
_%new_task_table @ _#task_table_activation + @
make_new_task
\ point back to task table
_%new_task_table @ _%task_table jump other_task !
SWAP _#task_head_action + SWAP
_start_new_task
;
: tskin ( "name" --)
BL (word) ~tasks SEARCH-WORDLIST not IF
TRUE ABORT" Not a task"
THEN
\ xt(--
EXECUTE
taskin
;
: task>user ( task_base_address -- user_address )
_#task_head_table> + @
_#task_table_activation + @
#activation_task> + @
;
: taskout ( task_base_address -- )
\ pfa(--
task>user
destroy_task
;
: tskout ( "name" --)
BL (word) ~tasks SEARCH-WORDLIST not IF
TRUE ABORT" Not a task"
THEN
\ xt(--
EXECUTE
taskout
;
Creates a child task the task will execute action with ?? values on the stack on initiation; the number pushed onto the childs stack will be given by values_to_push. It is expected child task will destroy themselves. the task kill_task does the job.
You will find child tasks used in TCP servers. You can create a child that has a higher priority.
: child_task { ( ?? values_to_push action ) variable %level variable $name -- }{
variable %new_user
}
Umax Smax Rmax
$name @ COUNT
%level @
_#activate_in_user
make_new_task %new_user !
\ ?? values_to_push action(--
>R
zero ?DO
%new_user @ push_other_task
LOOP
R> %new_user @
_start_new_task
;
: task: ( level -- activation_area level code )
ALSO &tasks
DEFINITIONS
CREATE
previous_definitions
PREVIOUS
_#task_head_length ALLOT
\ life is a lot easier for .task if
\ all named task have a known activation area.
\ It makes the finding of a tasks user area a lot simpler.
ram_here SWAP #activation_length ram_allot \ activation_area level code(--
_#comp_code_task \ activation_area level code(--
TRUE STATE !
;
#BCM550h #BCM550j + #BVP5502 + #BVP5552 + [IF]
\ task with it's activation area in dual port memory
: port_task: ( level -- activation_area level code )
ALSO &tasks
DEFINITIONS
CREATE
previous_definitions
PREVIOUS
_#task_head_length ALLOT
port_here SWAP #activation_length port_allot \ activation_area level code(--
_#comp_code_task \ activation level code(--
TRUE STATE !
;
[THEN]
( Task creation word) HEX
: ;task ( activation_area level code --)
_#comp_code_task ?pair \ activation_area level(--
last @ @ lfa>pfa \
COMPILE xtest
2D3C W, \ ##code # S -) MOV
0A ,
COMPILE xwait
6000 W, \ ##code BRA
DUP \ activation_area level pfa pfa (--
_#task_head_action + \ activation_area level pfa code (--
!back \ activation_area level pfa(--
HERE SWAP _#task_head_table> + ! \ activation_area level (--
HERE _#task_table_length ALLOT ( Allocate ram area) \ activation_area level tt(--
last @ @ lfa>nfa OVER _#task_table_name + ! \ activation_area level tt(--Point to the tasks name
SWAP 0 MAX
#clock_low MIN OVER _#task_table_level + W! \ activation_area tt(--
_#task_table_activation + !
[COMPILE] [
; IMMEDIATE
forth : task: \ compile time ( level -- activation_area level )
\ runtime ( -- addr )
HOST CREATE
_#task_head_length ALLOT
ram_here FORTH SWAP HOST #activation_length ram_allot \ activation_area level code(--
]T DOES> ( task head address) ;
\ task with activation area in dual port memeory
forth : port_task: \ compile time ( level -- activation_area level )
\ runtime ( -- addr )
HOST CREATE
_#task_head_length ALLOT
port_here FORTH SWAP HOST #activation_length port_allot \ activation_area level code(--
]T DOES> ( task head address) ;
HEX forth : ;task ( activation_area level --)
target_last @ @ _t_lfa>pfa \ activation_area level pfa(--
\ prom pointer to dictonary_data
HOST dictionary_here \ activation_area level table dthere(--
forth OVER \ activation_area level table dthere table(--
HOST _#task_head_table> forth + HOST t! \ activation_area level table(--
\ pointer to prom table, will go
forth zero
forth SWAP HOST _#task_head_prom> forth + \ activation_area level zero table+(--
HOST t! ( prom table) \ activation_area level (--
\ level
forth zero MAX HOST #clock_low forth MIN HOST dtw,
\ get address of last target words name
target_last \ in host
forth
@ \ the address of the head, at this stage this is in host
@
HOST
_t_lfa>nfa dt,
\ activation_area
dt,
forth FALSE tstate !
; TARGET
HOST
( Start user tasks) HEX
: start_tasks ( --)
ALSO &tasks
context @
[ _#voc_head> _#voc_wid - ]T LITERAL +
@ DUP
[ _#voc_heads_count _#voc_heads_base - ]T LITERAL + @ \ base count (--
SWAP
[ _#voc_heads_data _#voc_heads_base - ]T LITERAL +
SWAP \ threads count (--
zero DO
DUP \ threads list (--
BEGIN
@
DUP
\ the &tasks vocabulary is created in the kernel
\ and contains the kernel tasks as well as the
\ application tasks. This word only deals with
\ the application tasks. The ternal tasks
\ where start much earlier. The kernal task links will
\ be in the prom range.
[ _prom_kernel_start ]T LITERAL [ _prom_kernel_end ]T LITERAL WITHIN not
\ list end with zero, the prom doesn't have to include address zero
OVER 0<> AND
WHILE ( threads list (--)
DUP lfa>pfa taskin
REPEAT
DROP \ threads(--
4+ LOOP
DROP \ (--
PREVIOUS
;
Provide a forth interpreter
: prompt ( --)
DECIMAL
zero SET-ORDER
ALSO &COMMANDS
TRUE _error_pos? W! ( enable full abort function)
TRUE seal W!
\ so forms wait for a key input before next page
\ type page_free to undo this.
page_hold
CR
[ #BCM550h #BCM550j + [IF] ]T
\ if a slave processor load files from backplane.
\ If in slot 0 load from ibm
_breg_SST0 C@ _#SST0_in_slotx AND IF
user_base activation_status
_#RTI1000_dual_port_base
[ _#RTI1000_dual_port_base _#RTI1000_dual_port_size + ]T LITERAL WITHIN IF
\ Will only work if the activation area is in dual port memory
$" rti"
ELSE
$" flash"
THEN
ELSE
$" nfs"
THEN
[ [THEN] ]T
[ #BVP5502 #BVP5552 + #BVP5551 + [IF] ]T
user_base activation_status
_#RTI1000_dual_port_base
[ _#RTI1000_dual_port_base _#RTI1000_dual_port_size + ]T LITERAL WITHIN IF
\ Will only work if the activation area is in dual port memory
$" rti"
ELSE
$" flash"
THEN
[ [THEN] ]T
[ #BVP5501 [IF] ]T
$" rti"
[ [THEN] ]T
\ set working directory
$swd
['] QUIT 'abort !
ABORT
; RECOVER
The coldfire offers high speed memory. In FORTH the data stack is an obvious canidate for high speed memory use.
This word copies the current stack contents onto the new stack, returns the stack buffer. And sets up the task to use the new stack.
Obviously you are in trouble if you have referenced the stack anywhere, but then your a good FORTH programmer and never do such nonsence as the code will not work on a stack based processor.
\ flag is false if we fail.
\ We will fail if the supplied stack is way too small
\ Has to be in code as we don't have a data stack for a small while.
CODE _flip_data_stacks ( end_old end_new new_count --flag)
S )+ D0 MOV \ new_count
S )+ D1 MOV \ end_new
S )+ D2 MOV \ end_old
\ result, and at least one value on stack removing the
\ need to test for zero stack items.
FALSE # S -) MOV
D2 D4 MOV \ old stack end
S D4 SUB \ bytes on old stack
D4 D5 MOV
\ insist that there is a little extra room
$10 # D5 ADD
D5 D0 CMP LT IF \ new stack is too small
TRUE # S ) MOV
ELSE
D4 D1 SUB
D1 A1 MOV
BEGIN
S )+ A1 )+ MOV
4 # D4 SUB
EQ UNTIL
\ This is a serious operation
\ The data stack is now changed.
D1 S MOV
THEN
NEXT
\ This word can be used to alter stack size as well as change the type of memory
: new_data_stack ( base size --)
2DUP + \ base size end_new(--
_%data_stack_end @ \ base size end_new end_old(--
SWAP \ base size end_old end_new(--
jump \ base size end_new end_old size(--
_flip_data_stacks \ base size flag(--now working on new stack
ABORT" Supplied stack a little small"
_%data_stack_base @ ?buffer IF
_%data_stack_base @ kill_free_buffer
THEN
OVER _%data_stack_base !
\ This value is used by abort.
+ _%data_stack_end !
;
The coldfire offers high speed memory. In FORTH the return stack is an obvious canidate for high speed memory use.
This word copies the current return stack contents onto the new return stack, returns the stack stack buffer. And sets up the task to use the new stack.
\ flag is false if we fail.
\ We will fail if the supplied stack is way too small
\ Has to be in code as we don't have a return stack for a small while.
CODE _flip_return_stacks ( end_old end_new new_count --flag)
S )+ D0 MOV \ new_count
S )+ D1 MOV \ end_new
S )+ D2 MOV \ end_old
D2 D4 MOV \ old stack end
R D4 SUB \ bytes on old stack
D4 D5 MOV
\ insist that there is a little extra room
$10 # D5 ADD
D5 D0 CMP LT IF \ new stack is too small
TRUE # S -) MOV
ELSE
FALSE # S -) MOV
\ There will always be a value on the return stack ( our return address)
D4 D1 SUB \ from where data starts on new stack
D1 A1 MOV
BEGIN
R )+ A1 )+ MOV
4 # D4 SUB
EQ UNTIL
\ This is a serious operation
\ The return stack is now changed.
D1 R MOV
THEN
NEXT
\ This words can also be used to alter the size of stacks in real time
\ as well as change the type of memory.
: new_return_stack ( base size --)
2DUP + \ base size end_new(--
_%return_stack_end @ \ base size end_new end_old(--
SWAP \ base size end_old end_new(--
jump \ base size end_new end_old size(--
_flip_return_stacks \ base size flag(--now working on new stack
ABORT" Supplied stack a little small"
_%return_stack_base @ ?buffer IF
_%return_stack_base @ kill_free_buffer
THEN
OVER _%return_stack_base !
\ This value is used by abort.
+ _%return_stack_end !
;
: _.task { variable %user_base variable %offset -- }{
0
DUP CONSTANT _#suspend_r CELL+
DUP CONSTANT _#suspend_o CELL+
DUP CONSTANT _#suspend_l CELL+
DROP
4 CONSTANT _#recurse_offset
}
_%task_level %user_base @ other_task @ %user_base @ claim_task
\ loop_facility 0 | $(--
$ABORT
\ we only want to print the task details; after we release the task we
\ don't care what happens to it, so we can release the task loop now
\ and let other find it. If the finder is a detroyer he can destroy until
\ we relase the task.
release
\ the task itself is still claimed
CR %offset @ SPACES
." Status : " %user_base @ .h
(S) %user_base @ other_task @
\ stack(--
DUP _#suspend_o + @
." Obj pnt : " .h
DUP _#suspend_l + @
." Lcl pnt : " .h
CR %offset @ SPACES
_%data_stack_base %user_base @ other_task @
." Stk btm : " .h
DUP ." Data stk: " .h
_%data_stack_end %user_base @ other_task @
\ stack(--
OVER - 4/ 1-
." Stk dpth: " .h
CR %offset @ SPACES
_%return_stack_base %user_base @ other_task @
." Rtn btm : " .h
DUP _#suspend_r + @
." Rrn stk : " .h
_%return_stack_end %user_base @ other_task @
OVER _#suspend_r + @ - 4/ 1-
." Rtn dpth: " .h
\ are there children
\ stack(--
DROP
_%task_children %user_base @ other_task
DUP @ IF
CR %offset @ SPACES ." CHILDREN"
THEN
BEGIN
@ DUP
WHILE
DUP [ user_base _%task_parent_fwd - ]T LITERAL +
%offset @ _#recurse_offset +
\ link user_base offset(--
CR DUP SPACES
_%task_name_count jump other_task @ >R
_%task_name> jump other_task @ R> TYPE
RECURSE
REPEAT
DROP
%task_facility %user_base @ other_task release
;
: .task ( task_table -- )
\ pfa(--
_#task_head_table> + @
_#task_table_activation + @
#activation_task> + @
zero _.task send
;
: .tsk ( "name" -- )
BL (word) ~tasks SEARCH-WORDLIST not IF
TRUE ABORT" Not a task"
THEN
\ xt(--
EXECUTE
.task
;
\
\ Now you would think .tasks would be simple wouldn't you. Unfortunatly
\ the tasks loops are changing as tasks are created and destroyed. We don't
\ want to hinder this process. We claim task n within the task loop.
\ While we are looking for task n the loop head is claimed thus stopping
\ additions and subtractions to the loop.
\
\ If we exit with a task address, the task is claimed.
\
: claim_task_n { ( task_loop ) variable _%task_number -- ( user_addr true|false) }{
variable _%loop_head
}
CELLS _xheads + @ _%loop_head !
_%loop_head @ _#level_head_facility + grab
_%loop_head @
BEGIN
#activation_task_link + @ DUP
_%loop_head @ <> \ task flag (--
WHILE \ task (--
_%task_number @ not IF \ this is the one we want
\ Note we are claiming two facilities, as soon as you do this
\ we risk deadlock. Never Never claim a task and then the head.
\ Always claim the head first.
\ activity_area(--
#activation_task> + @
\ user_area(--
%task_facility OVER other_task grab
_%loop_head @ _#level_head_facility + release
\ Ok the task is now ours. We don't stop if from running.
\ We just stop it from being destroyed. The word that destroys
\ tasks has to claim it's facility first.
TRUE EXIT
THEN
-1 _%task_number +!
REPEAT
DROP
\ get to here their isn't the required number of tasks in the loop.
_%loop_head @ _#level_head_facility + release
FALSE
;
CREATE _$sleep ," sleep"
CREATE _$wake ," wake "
CREATE _$test ," test "
CREATE _status_names
_$sleep t,
_$wake t,
_$test t,
\ print out data on all tasks. Note the problems we have because tasks
\ can come and go.
: .tasks { ( --) }{
variable _%task_number
0
DUP CONSTANT _#suspend_r CELL+
DUP CONSTANT _#suspend_o CELL+
DUP CONSTANT _#suspend_l CELL+
DROP
}
CR ." List of all tasks in priority order"
CR ." Task name User S -> S Depth R -> R depth State"
_#task_level_number zero DO
0 _%task_number !
BEGIN
\ we go for task n as we don't want to tie up the loop facility
\ while we display the tasks in the loop. Better to miss some
\ if tasks come and go.
I _%task_number @ claim_task_n
WHILE
_%task_number @ 0= IF
CR I CELLS _level_names + @ name_count _#name_count_bits AND TYPE
THEN
_%task_name> OVER other_task @ \ task name(--
_%task_name_count jump other_task @ \ task name count (--
CR TYPE SPACE $10 character# - 0 MAX SPACES \ task (--
DUP .h
\ if we are displaying the running task things are differnt different
DUP @u <> IF
(S) OVER other_task @ .h
\ other_user(--
ELSE
@s .h
THEN
\ if we are displaying the running task things are differnt different
DUP @u <> IF
(S) OVER other_task @
\ other_user other_(S) (--
_%data_stack_end jump other_task @ SWAP - 4 / 1 - .h
\ other_user(--
ELSE
_%data_stack_end @ @s - 4 / 1 - .h
THEN
DUP @u <> IF
(S) OVER other_task @
_#suspend_r + @ .h
ELSE
@r .h
THEN
DUP @u <> IF
(S) OVER other_task @
_#suspend_r + @
_%return_stack_end jump other_task @ SWAP - 4 / 1 - .h
ELSE
_%return_stack_end @ @r - 4 / 1 - .h
THEN
_activation> OVER other_task @
#activation_status + W@ _status_names + @ $type SPACE
%task_facility SWAP other_task release
1 _%task_number +!
REPEAT
LOOP
send
\ (--
;
\ used by task to destroy themselves
\ used to destroy tasks running on a lower level
\ than the task that is asking for the destruction.
\ the task
: kill_task_action ( --)
BEGIN
_kill_task_queue xawait
_kill_task_queue dequeue
[ user_base _%task_link - ]T LITERAL +
\ can't destroy this task even if you want to.
DUP @u <> IF
\ user _addr(--
['] destroy_task CATCH IF
DROP
THEN
ELSE
DROP
THEN
AGAIN
;
\ belongs in tube.html but task>user isn't defined there so put it here.
\ This will only work if the task opens a tube and makes it the default
\ input output file.
\ see kernel_tasks.html for examples.
: task_logon ( task_pfa -- )
'output_file SWAP task>user other_task @ ?DUP IF
logon
THEN
;