Tasks

ET 2021-10-16 - (1.6)

Introduction to Tcl Tasks

Tasks are an extension to tcl threads that are designed for ease of use. Tasks implement a familiar call/return or client/server like framework. Tasks primarily use just 5 primitives plus a few for debugging and a task group builder. Tasks can call other tasks as easily as calling a local procedure which it can do synchronously or asynchronously .

    Task taskname ?options? ?list of imports? {
         twait - > varname1 varname2 ...   
         # do something with the args $varname1 $varname2 ...
         treturn result
    }


    tcall $taskname ?-async? returnvar <- arg1 arg2 ...
    tvwait returnvar

A task is created using the Task proc, as shown above. The taskname is the name of a variable assigned the thread id and also used for creating some Task shared variables. All the tasks::* procedures and optionally other proc's defined in the program can be imported into the thread's interpreter.

The last arg to the Task proc is the script. Task creates a new thread, supplements the script with a loop and error catcher, and starts the task running. The script will usually begin (after some possible inits) with a twait call that returns with the first job and it's arglist. treturn sends a result back to the client caller.

On the other side of the transaction, there is the tcall that sends an arglist to the task, and if it was used with the option -async can wait with tvwait until the returnvar is set. If it is called without the -async, then it will synchronously wait for returnvar to be set. Using the pair allows one to do other things between the call and the wait.

Tasks manage their own job queues and this permits easy sharing between tasks (threads). With a task grouping utility, submitting a set of parallel jobs to run on a multi-core processor, is like calling a procedure with multiple arglists.

New in 1.6 - tgroup a utility for creating a group of tasks to run in parallel on multiple cpu cores. Included with tgroup is Tproc which can convert an existing proc procedure to a group of Tasks that the tgroup -run command can run in parallel.

 tgroup and Tproc examples

This first example uses tgroup to compute the number of digits in 4 Fibonacci numbers, each in it's own thread. Each thread runs the same script, which first loads the math package, then waits for an arglist (here an arglist is just 1 number) which is used to computes a result which it formats into a text string to return to the caller.

tgroup (with the option -tasks) creates the set of tasks that each run the script concurrently. Then tgroup with the option -run sends each task it's input (a single number) and then waits for all tasks to return a value, which is saved in an array fib. The name fib is also used to create the task names (fib0, fib1, ... fibN) and groups them all to share fib0's queue. There could have been more or less tasks than jobs, and the shared queue would divy up the jobs to whichever tasks were available. However, in this example, we explicity created 1 task per number using the length of the nums list which ran in parallel on a 4 core intel chip.

    namespace import tasks::* 
      
    set script { package require math
        twait -> num 
        treturn  "$num -> [string length [math::fibonacci $num]]"
    }
    
    set nums {200000 200010 200020 200030 }

    tgroup fib -tasks [llength $nums] -import $script ;# 1 task/num
    tgroup fib -run {*}$nums   ;# run all 4 and wait for all done
    
    parray fib rvar*  ;# results go in an array

# results:  
# fib(rvar,0) = 200000 -> 41798
# fib(rvar,1) = 200010 -> 41800
# fib(rvar,2) = 200020 -> 41802
# fib(rvar,3) = 200030 -> 41804

This next example demonstrates transforming a regular proc to a Tproc. One does so by placing a T in front of proc and adding tgroup arguments following the proc body. Tproc creates both the proc and 8 tasks that each import the fiblen proc into a thread. Then one can use the tgroup -run option to compute a set of answers. The running and waiting can also be separated using tgroup's other options (-foreach and -wait).

In the below code, the proc fiblen is first used to sequentially (time and) compute the number of digits for 8 Fibonacci numbers. Then the fiblen proc is turned into a Tproc as described above and finally uses tgroup to -run the calculation on the 8 numbers. The output shows the results and the timing for both sequential and a Tproc group of tasks.

    set nums {100000 100010 100020 100030 100040 100050 100060 100070 }
    
#   --------------------- sequentially ------------------
    set tm [time {
        
        proc fiblen {num} {
            package require math
            return  "$num -> [string length [math::fibonacci $num] ]"
        }
        
        foreach num $nums {
            set answers($num) [fiblen $num]
        }
        
    }] 
    parray answers
    puts "sequential tm = [format %35s $tm ]"    

#   --------------------- Tproc ------------------
    
    namespace import tasks::*
    set tm [time {
        
        Tproc fiblen {num} {
            package require math
            return  "$num -> [string length [math::fibonacci $num] ]"
        } -tasks [llength $nums] 
        
        tgroup fiblen -run {*}$nums
        
    }] ; puts "Tproc      tm = [format %35s $tm ]"
    parray fiblen rvar*
    
#   --------------------- results ------------------
#   answers(100000) = 100000 -> 20899
#   answers(100010) = 100010 -> 20901
#   answers(100020) = 100020 -> 20903
#   answers(100030) = 100030 -> 20905
#   answers(100040) = 100040 -> 20907
#   answers(100050) = 100050 -> 20909
#   answers(100060) = 100060 -> 20911
#   answers(100070) = 100070 -> 20914
#   sequential tm = 10125127 microseconds per iteration
#   Tproc      tm =  1900964 microseconds per iteration
#   fiblen(rvar,0) = 100000 -> 20899
#   fiblen(rvar,1) = 100010 -> 20901
#   fiblen(rvar,2) = 100020 -> 20903
#   fiblen(rvar,3) = 100030 -> 20905
#   fiblen(rvar,4) = 100040 -> 20907
#   fiblen(rvar,5) = 100050 -> 20909
#   fiblen(rvar,6) = 100060 -> 20911
#   fiblen(rvar,7) = 100070 -> 20914    

 More Details

twait waits until a job is requested from another task or the main thread which uses the tcall command which like calling a procedure, can optionally supply input parameters. The parameters to twait are variable names of where to store the arglist and individual args.

treturn returns a value to a calling task (or the main thread).

Note: treturn does not end the task and return like a procedure. It returns a result to the caller task (or main) and the code continues on with any statement following the treturn. It might loop back to another twait, or go into some other loop or just straight line code. The next twait can have a different number and type of arguments.

  • comparing Tasks to co-routines

Tasks are a bit like co-routines but they run in their own thread and thus also in their own interpreter. Unlike calling a co-routine, the caller can do so asynchronously, The treturn acts a bit like a yield in this regard, but doesn't suspend the task.

Unlike a yield which both returns a value to the caller and gets the next arg when awake again, a task can have activity between these two events, since it is not suspended. So, the task has 2 primitves for this, twait and treturn.

  • Tasks by default are enclosed in a forever loop

By default, the script is enclosed in a while 1 loop unless the -once option to the Task command is used. Then the task will exit if it reaches the end of the script. If the -once is not specified, then a break can be used to exit the Task supplied forever loop, and a thread exit will occur. There is no added thread::wait since the thread script is not empty.

  • Arguments are arglists which can also be lassigned to variables

Note: the - > used in the above twait is actually 2 variable names. The first, the dash, receives the full arglist (like args to a proc). These extra visual cues are optional, but do provide some eye relief when used. When only the args are needed in a single variable, argv or args is a good choice.

Callers send arglists, which are saved in a sharable queue until the Task attempts to retrieve a job using twait. If the queue is shared with other tasks, then whichever task can get to the queue first, will get the next request. If nothing is queued, the task will block until a job request arrives (but uses a timeout to re-enter the event loop every 50 ms).

A task can have its first twait accept an arglist with initialization data, do a treturn and then drop into a loop calling twait/treturn for a different set of args to receive for the subsequent job requests.


Synchronous calls use tcall to mimic a procedure call, but the procedure in this case is running concurrently in its own thread. This returns, with a value, after the task issues it's treturn statement.

    tcall $taskname resultvar   arg1 arg2 ...

Asynchronous calls also use tcall to mimic a concurrent procedure or function call, that also runs in it's own thread.

    tcall $taskname -async resultvar   arg1 arg2 ...
# ... do something else ...
    tvwait resultvar 
   

tcall calls (sends an arglist to) a task by referencing the taskname, which is a variable created in the callers frame by the Task command and set to the thread id. tcall requires a variable name to receive the result which is the signal back to the caller that the job is done.

tvwait is a vwait that first checks for the variable's existence. tcall unsets that variable before inserting the arglist into the tasks queue. This 2-prong approach avoids a possible race condition that could occur if the do something else were to use an update or vwait and enter the event loop.

Without this extra unset, a task that treturn's a value before the caller does the tvwait, could cause the tvwait to wait forever, rather than an immediate return, since a normal vwait would wait for the variable to be set again.

                                                   - - -

Task Properties

 Features

Tasks are easy to add to a program

Tasks are programmed in pure TCL code. No other packages are required other than Threads and Tk. They are currently just a code block that can be included in a program or placed in a file and sourced.


Tasks vs. tcl threads

Tasks differ from simply using thread::create and thread::send in several ways.

  • Tasks use a share-able queuing method

Tasks implement a work queue using mutexes and condition variables. These are easy to synchronize and share across several threads (tasks). By having several tasks share the same queue, it is easier to provide single-queue multiple-server functionality where jobs can run in parallel on a multi-core processor.

To get this with just the Threads package, one would have to use the threadpool package, which is more complex than tasks and relies on the event loop for it's queue.

  • Each task is called with an argument list

Rather than always receiving a snippet of tcl code, tasks use the more familiar method of passing data in an arglist, that all procs, methods, commands, and processes (argc/argv) use for their inputs.

  • Tasks are sequential code

Event driven programs are more complex to understand than code which uses a more conventional sequential model. Tasks are designed to do simple, but sometimes cpu intensive jobs rather than an interactive gui, which is best done with events. However, thread::send can still be used and if the task is waiting for work, it can receive a command.

  • Tasks include proc importing

When a task starts up, it can import into its interpreter procedures (either global or in a namespace) from the calling task (or the main thread). This makes it easy to initialize a Task with all the code it needs to do simple jobs. The main thread can do the bulk of the program calling on a few tasks running in parallel to do some processing that can utilize modern multi-core cpus.


Tasks can process one job or loop back for more work

After processing an arglist and returning a value, the task can then simply exit, or remain running in a loop waiting for the next arglist to process, similar to a client/server arrangement.

By default, a loop surrounds the script, unless the -once option is specified in the Task command. Each task has a queue, so pending asynchronous calls will be queued fifo in an orderly fashion.


Helper tasks are simple to add

One or more tasks can be helpers, (with the same or different scripts) and will all share the main task's queue implementing a single queue multiple server organization. Callers can be from the main thread or any task (except itself). This is a key feature of Tasks.

Adding helpers is quite easy. Helper tasks are created with a simple taskname convention of worker/boss. All work is sent to the boss.

    Task boss ... $script
    Task worker1/boss ... $script
    Task worker2/boss ... $script
    ...

    tcall $boss ....

For example, here's a program that will create 4 tasks for 5 jobs. Note: the task name is available to each task using the global variable t_name, created by the Task command.

Because the computation takes a second or two, 4 will be run concurrently, and which ever one finishes first will snag the 5th one which was waiting in the job queue of tBoss. Due to scheduling of threads, there's no guarantee of which task that will be. Each task returns a list of 2 items, a text message and the result of the computation.

    namespace import tasks::*
    set script {
        package require math
        twait   ->  i  number
        treturn  [list                                          \
                   "$i courtesy of $::t_name : $number"         \
                   [string length [math::fibonacci $number]]    \
                 ]
    }
    set jobs {100 200 300 400 500}

    foreach   taskname {tBoss help1/tBoss help2/tBoss help3/tBoss } {
        Task $taskname  -import  $script      ;# create the 4 tasks
    }
    foreach i $jobs {                         ;# run the 5 jobs
        tcall $tBoss -async   rvar($i)    $i  [expr { $i + 100000 }]
    }
    foreach i $jobs {tvwait rvar($i)}         ;# wait for all jobs
    
    parray rvar

#   
#   Each run could assign different tasks to each job, here's 2 results
#   Since there are only 4 tasks for 5 jobs, someone has to do 2 jobs:
#   
#    
#   rvar(100) = {100 courtesy of help1 : 100100} 20920
#   rvar(200) = {200 courtesy of tBoss : 100200} 20941
#   rvar(300) = {300 courtesy of help2 : 100300} 20962
#   rvar(400) = {400 courtesy of help3 : 100400} 20983
#   rvar(500) = {500 courtesy of help1 : 100500} 21003
#   
#   rvar(100) = {100 courtesy of help1 : 100100} 20920
#   rvar(200) = {200 courtesy of help2 : 100200} 20941
#   rvar(300) = {300 courtesy of tBoss : 100300} 20962
#   rvar(400) = {400 courtesy of help3 : 100400} 20983
#   rvar(500) = {500 courtesy of tBoss : 100500} 21003
    

Tasks are compatible with other Thread functions and the event queue

The tsv shared variables are easily incorporated. Mutexes can also be used. Even a thread::send or thread::cancel can still be used. The taskid used in tcall is just the thread id.

During the wait for work, the event queue is checked every 50 ms by doing an update, so any pending events, such as a thread::send or updating of any gui widgets will have time to be serviced.


Tasks include puts like debugging and an error handler

Tasks comes with utility procedures for debugging such as a puts like statement that can create a Tk text widget (one per task) and a built in error catcher that will display a tk_messageBox.

Note, due to a Tk bug on linux, putz will not create Tk windows, but rather will output to stdout using puts, but with the taskname prepended. This mode can also be used on windows to output to the console if desired.

                                                        - - -

Task Procedures

 Primary 6

Create a Task

  • Task taskname ?-once? ?-import_tasks ? ?import list? script

taskname is the name of a variable that will be assigned the thread id (also called the task id). It is also the name used for some tsv shared variables that the Task system uses internally. This taskname can also be namespace qualified, e.g. ns::taskname, where a prior namespace eval ns {...} was used in the program.

The -once option suppresses the forever while loop normally around the script.

The -import_tasks option is used when the parent Task (or main thread) imports all the tasks::* procedure names. Then this option will also import them unqualified into the thread's interpreter. This way the task won't need to qualify the tasks::* procedure names either. If preferred however, one can fully qualify them in all cases. This option can be abreviated to -import.

The import list is a list of proc's that can be imported into the task's interpreter. Each list element can be a pattern as described in the [info procs] command. This can include a namspace qualifier, e.g. starkit::* which would include all the procs from the starkit namespace. When an item includes a namespace, that namespace is eval'd e.g. namespace eval starkit {namespace export *} which will define the namespace and also export all the procs defined in that namespace (even if they haven't yet been defined).

Additionally, each item in the list can be of the form {-tcl command} where the - is removed and the remaining item is inserted as a command at the point of the imported list procedures. These commands are inserted before the script (and not inside the added forever loop), but after all the tasks::* procedures. The order of insertion is left to right. For example, suppose you need to include a package command, but don't want to place it inside the added forever loop:

Task taskname -import_tasks {{-package require math} mystuff::* someproc} $script

An alternative would be to have an initializer and an explicit while loop around the script, like so:

    package require math ;# and other init stuff here
    while 1 {
       ... the script ...
    }

In this case, one might choose to use -once as well, since there's no need for an extra forever loop if one supplies one explicity. Then a break inside the while loop would cause the task/thread to exit.

The script can be supplied in braces or with a $script variable, depending on preference. A variable is normally used with helper tasks when each uses the same script.

Task returns the newly created task's thread id (taskid).


Call a Task and Wait till Done

  • tcall $taskname ?-async? rGlobal ?arg ...?
  • tvwait rGlobal ?taskid?

tcall sends a message to the task id specified by the contents of $taskname and uses the provided rGlobal variable name to set on completion and also provides an argument list. rGlobal can also be an array element, e.g. rGlobal($element), and optionally include a namespace qualifier. tcall will add :: in front of rGlobal if not specified in the tcall.

tvwait will wait for the completion, of the task and receive the return value.


Wait for a Call and Return a Value

  • twait ?argv? ?varname1 varname2 ..?
  • treturn result

twait waits for work to do and get args and optionally lassign them to the variables varname1 varname2 ...

treturn signals the caller and returns a result. If the caller is waiting with a tvwait, it will resume.


Debug output

  • putz "text" ?color?

On windows, this will create a Tk window for debug output, one per Task. There are a few buttons and checkboxes, for turning on/off the output, clearing the text, and pausing the task. The large button is a quick exit of the program along with some Task info.

On Linux, this will go to stdout using a puts. If called from the main thread, this will translate to a puts call.

See the tag's in the code for the current set of colors. Add additional ones for your own use. The t_debug global variable control's putz output with an option for a debug trace.

                                              - - -

 Utilities and Misc.

Utilities

  • tset taskname element ?val?

Set a Task shared variable value, or get it if no ?val?

  • tdump ?pat? ?max-width?

Debug dump of shared variable data used by tasks. pat is an regex that defaults to .* and max width def=90. If the pattern starts with a -pat the - is removed, but then only the matched lines (i.e. not the extra task info) will be output. This can be used from the main, but also from a task since it uses putz for its output.

  • tname taskid

taskid (which is the thread id also) will lookup and return the taskname.

  • tpause_check

This is checked in twait, but can be used also by the task code. It checks for the t_task_pause global, which is initialized to 0, and does a non-busy wait for the global to change back to 1. It is connected to the pause checkbox in the Tk window that putz creates.

  • tgroup name ?-option?

This is a task builder which can create a group of tasks sharing the same queue. see the discussion in the comments before that proc for more information and some examples.

  • Tproc name args body ?-options?

This transforms a regular proc to a set of tasks that share a queue. It uses tgroup to create the tasks and the options are the same as for Task (but no script at the end). This also creates a regular proc using the name, args, and body of a proc. The first 2 options default to -tasks 4. After a Tproc is created, one can use the tgroup commands as though a tgroup -tasks command had been issued (because internally, that's what is done).


Misc

  • comma number

comifies a positive integer, only used in testing

  • wait ms

A non busy wait using vwait and a global variable.

  • xwait ms

A busy wait, for easily testing compute bound threads. The time is approximate.

                                                    - - -

Try out the examples

To test the examples, copy the code block followed by an example to a file and run it with tclsh or wish. It requires the Threads package and Tk, which it will (attempt to) load.


Open the code discussion which has a large comment block with more details.

 Code
# proc intro
# tasks
################################################################################################
#
#   Tasks are an extension of threads. A Task is a thread that includes:
#
#       A high level call/return interface (or client/server)
#       A job input queue optionally shared among tasks   
#       An exclusive mutex and associated condition variable
#       An error handler
#       A forever while loop around the script (optional)
#       Text widget (optionally) - one per Task
#       putz output to the text widget (similar to puts) plus colors
#       A parent thread proc importer
#       package require Tk if needed
#       Debug on/off to include tracing
#
#   Summary of Task command set:
#   ----------------------------
#
# From a parent thread - the name tname will be used for tsv shared variables and a variable to save the thread id.
# The Task proc create a variable tname and assigns it the id.
#
#   Task  tname  ?-once? ?-import ? ?prefixlist? script      ;# prefixlist is imported procs, tname can be tname/tname2 
#   tcall $tname ?-async? rglobal ?arg ...?]                    ;# if called with -async, use tvwait, rglobal is the return value
#                                                               ;# if called sync (no -async) it returns the value also, if -async
#                                                               ;# returns a 0/1 as to the success of operation
#                                                               ;# for -import, see below on Namespace
#
#   tvwait rglobal ?taskid? ;# wait till variable set: if taskid given, checks if Task exists to avoid waiting
#                           ;# forever on task crash
#   
# inside a Task
#
#   twait ?argv? ?arg1 arg2 ..? ;# waits for work to do and get args and optionally lassign them to variables
#   treturn  result             ;# if the last statement (e.g. no loop), it will drop through after and exit thread 
#
# Utilities
#
#   tset taskname element ?val? ;# quick way to set a Task shared variable value, or get it if no ?val?
#   tget                        ;# alias for tset (for readability, so can still set the var if val is given) from main only
#   tdump ?pat? ?max-width?     ;# debug dump of shared variable data used by tasks, pat=* max width def=90 
#   tname taskid                ;# taskid (which is the thread id also) will lookup and return the taskname
#   tpause_check                ;# this is checked in twait, but can be used also by the task code, if it doesn't twait
#                               ;# for example, a task that only gets 1 tcall and then loops doing something, like producing for a consumer
#                               ;# this checks for the t_task_pause global, which is initialized to 0
#   tgroup name  ?-option?      ;# this is a task builder, see the discussion in the comments before that proc
#
# Misc
#
#   putz "text" ?color?         ;# debug output for a Task, with separate window with a text widget
#   comma number                ;# comifies a positive integer, only used in testing, probabaly can just remove it
#   wait ms                     ;# a non busy wait using vwait and a global variable
#   xwait ms                    ;# a busy wait, for easily testing compute bound threads
#
#
#
#   In a minimal case, a Task can be written like so to call someproc with 2 args
#   where someproc will run in a different thread from the caller thread:
#
#   ;   proc someproc {a1 a2} {                 ;# this is outside the Task definition, but is imported
#            ...do something...
#           return $something
#       }
#
#
#       Task mytask {someproc other-procs} {    ;# create new thread, assign thread id to mytask, import someproc
#           twait -> a1 a2 ...                  ;# wait for work and then lassign the args to a1 a2 ...
#           set result [someproc $a1 $a2 ]      ;# call someproc with the input args 
#           treturn $result                     ;# send back the results, sets a variable with the result
#       }
#
#
#   And it might be called like this synchronously:
#   
#       tcall $mytask resultvar 100 200 ;# the mytask variable was created in the Task call above
#   
#   or asynchronously with some compute followed by a wait for completion:
#   
#       tcall $mytask -async resultvar 100 200
#       ... do something else ...
#       tvwait resultvar
#
#   A Task works similar to a procedure using [tcall]/[treturn] with args and a result.
#   Each task creates it's own tcl thread. It can be [tcall]ed by another Task, but
#   should not tcall itself or deadlock will occur. 
#   
#   It's input is an argv (or args) like list of arguments. The [twait] command
#   is used to wait for work to be sent in, and can optionally assign values to locals.
#   The caller issues a [tcall] that mimics a procedure call. [Task] returns a 
#   taskid (which is a true thread id) which can be used with other thread package 
#   commands.  All the tsv:: shared variable package can also be used.
#   
#   A [tcall] can be synchronous or asynchronous. Included in the tcall is a 
#   global variable name (scalar or array, with a namespace or not) that will 
#   receive the results when the call is done. The Task issues a [treturn] 
#   statement with a result value, similar to a proc return. A pair of :: will be
#   prefixed to the name automatically if needed.
#   
#   A Task is created with a Task name, and an optional import list (of procs from 
#   the parent thread) and a script. Task returns the taskid and also creates a
#   variable of the same name in the local address space also storing the taskid.
#
#
#   By being a Task (running in its own thread) the main thread can 
#   be responsive to events, even if the Task is a very heavy compute process. If
#   the Task breaks from the loop (or there's no loop at all) the task will exit
#   if it drops off the bottom.
#   
#   The first argument to [twait], is assigned the entire argument list, while
#   the arguments that follow are names of variables to be assigned values from the arglist.
#   It resembles the lassign command, except the first arg (often called argv)  
#   was written by [twait] first, then used. 
#   
#   If the first variable is not needed, as might be the case with a fixed set of actual args,
#   then a nice syntactic trick is to use -> for that. Regexp often does this.
#
#       twait -> arg1 arg2
#   
#   Note that like regexp, a variable -> is created but was chosen to "look nice" given we
#   are not really interested in it's contents. When it's needed, argv is a suitable choice.
#
#
# Some random notes:
#
#   The Task create imports procs that the parent thread has defined. A Task can also call 
#   other Tasks, and so the parent thread is not always the main thread. These procs are a list
#   of args that can be given to the [info procs] command and so can be glob type patterns as
#   documented in the [string match] command. Each proc is reconstructed using info body/args/default.
#
#   In addition, the body is modified to replace full line comments (begin with #) to be just the
#   # alone, to save space, but not change line numbering.
#
#   There is now code to allow importing of namespaced'd procs. In order to do this, there needs to
#   be a namespace eval xxxxx {namespace export *} added and we will generate it ahead of the proc defs.
#
#   And also, we now have an option with the import lists: 
#   if an item in the list begins with a - then - is stripped off but the remaining text is then
#   placed in the output. For example, we might not want to export everything, so we could clear it. 
#
#   Task testing -import {foobar::* {-namespace eval foobar {namespace export -clear} } } $script
#
#
#   These imported procs are prepended to the script parameter. All of the required procs, like twait
#   and treturn are automatically prepended first. Also there are 3 global variables that are defined
#   for the Task (i.e. the thread and it's interpreter), These are the parent thread id
#   (the caller of Task) and the name of the Task. For example, they might look like this:
#   
#       set ::t_pid tid00002F40
#       set ::t_name helper1
#       set ::t_debug 0         ;# this controls putz output
#   
#   If the putz output command is used, it will create the text widget on first call. It
#   no longer creates a variable to indicate the text widget was created, but rather tests
#   for the existance of the text widget, using info command. But...
#
#   There are now 2 checkboxes on the Tk putz window which have 2 globals (but only if the
#   windows are created by a putz call from a task).
#
#   t_putz_output              ;# a toggle to turn putz output on/off
#   t_task_pause               ;# a toggle to pause the task, see tpause_check
#
#
#   
#   Three tsv:: shared variables are used
#   
#   main    Stores the thread id of the main thread
#   tvar    all the shared variables about a task, currently 12 items
#   tids    all the task ids with their task names
#   
#   
#   For each task threre are 12 items, made up of the taskname and one of the following
#   
#   taskname,cond           the conditional variable handle
#           ,count          count of times that twait returned a job 
#           ,error          the text of a caught error 
#           ,gvar           the global return variable name
#           ,mutex          the mutex handle
#           ,pid            the parent thread id, of the caller  
#           ,queue          the job queue 
#           ,result         the result of the last treturn
#           ,script         the modified actual script being used by the task
#           ,share          the name of the task that is the main task in a shared group (or null) 
#           ,tid            the thread id of this task 
#           ,user           a user available item which has no current use 
#   
#   [putz] also defines a series of tags for colors. They are easily modified. If
#   the t_debug flag is set, then a log of various internal debugging will be output to
#   to the text widget. 
#
#   When waiting for work in it's queue, it will update the text widget every 50 ms, 
#   so it should remain responsive. If in a heavy loop however, the widget will freeze.
#   
#   The script can easily be listed out as it is stored in the shared variable tname,script. The command:
#   
#       tget taskname script
#   
#   will list the script as the thread will have seen it. This can be run from a console.
#   
#   There is a catch wrapper and while loop around the script and if an error occurs which is caught
#   will use tk_messageBox to display it. Thus tk is required for Tasks. The other use is the putz
#   command. It looks like this (but check the actual code in Task for lastest):
#   
#       if [catch { 
#           while 1 {
#               ... script ...
#           }
#       } thread_err_code thread_err_dict] {
#           tsv::set tvar helper1,error $thread_err_dict  
#           tk_messageBox -message "Name = $::t_name Parent = $::t_pid\n$thread_err_code\n\n$thread_err_dict" -title "tid [thread::id]"
#       }
#
#
#
#   There is also now another catch around the entire suplemented script, to catch missing namespace eval errors.
#
#
#   If there is a need to do something with an initialization and then the loop, one can simply write code:
#
#       initial
#       while 1 {
#          script
#       }
#       
#   Since there's always one outer while loop, if one wants to exit a task, then using a [break] will do that, since
#   unlike threads, there is no need for a thread::wait call. A one shot would look like this:
#   
#       twait -> arg1 arg2 ...
#       treturn result
#       break
#       
#   Note that the automatic while loop is placed on the same line with the catch, (just to remove 1 newline) which
#   results in a better line number being reported in the message box when an error occurs.
#
#   And finally, there's a -once option on the Task call to suppress this. To check the actual code that
#   is generated, one can use the [tget] command to retreive the actual script code which is generated.
#   
#       puts [tget taskname script]
#       
#   Notice that there are 2 variables here that all Task's will be using: thread_err_code thread_err_dict
#   
#   The script is at the global level, so these variables will also be global (in the threads's interpreter). 
#   To make them local, one can use this for a script instead:
#   
#   ;   proc doit {} {
#           while 1 {
#          .... script ...
#       }
#       }
#       doit
#   
#   Here we should code the while loop ourselves, however, since this whole script is enclosed in
#   a while 1 loop itself. Or, there is the -once option to Task which can be used to suppress that loop.
#   It is best to check the script using the above tget, to be sure you are getting the code you really want.
#       
#   (that ; in front of the proc is just to keep my editor from doing an auto fold on procs)
#
#   The [tdump] command will dump all the Task associated shared variables. For example, 
#   
#       helper1    tid: tid000026E0  exists: 1
#                    (helper1,cond)       = |cid1| 
#                    (helper1,count)      = |3| 
#                    (helper1,error)      = || 
#                    (helper1,gvar)       = |::foobarvar3(6)| 
#                    (helper1,mutex)      = |mid0| 
#                    (helper1,pid)        = |tid00002F40| 
#                    (helper1,queue)      = || 
#                    (helper1,result)     = |{6 helper-one-}| 
#                    (helper1,script)     = |#Preamble??set ::t_pid tid00002F40?set ....
#                    (helper1,share)      = |int_sum| 
#                    (helper1,tid)        = |tid000026E0| 
#                    (helper1,user)       = || 
#   
#   The [tdump] command will replace newlines and tabs with unicode characters to keep the output 
#   from getting ugly by the script. It also dumps additional information about the shared
#   variables. It limits the size of each line, and takes an optional arg to set the max width.
#
#   tdump takes a regex pattern to limit the output, so tdump count|result will limit the output to 2 items.
#   if the first char in the regex pattern is a -, it is removed from the pattern, but only the share items
#   are output (not the extra info about tids etc.)
#
#   The global variable that is used in a [tcall] to return the results can be a namespace'd variable
#   array or scalar. If it begins with :: it will be used as entered, but will have :: prepended if not. 
#
#   Each Task normally has it's own set of mutex, condition variables, and a queue. However, 
#   if the Task name is of the form 
#
#       tname/taskmain 
#
#   then the task name will be the first part (tname) but it will share the use of the
#   shared variables from the 2nd Task's (taskmain) set. This implements a single queue multi server 
#   setup. See the example in Ashok's book "The tcl programming language" which was heavily used in
#   creating this module.
#
#   
#   An example, 
# ---------------------------------------------------------
#   ;   proc someproc {arg1 arg2} {     ;# this could also be in the task script, but we'll import it
#           ...
#           return $result
#       }                               ;# being imported means it's not inside the catch of the script
#       
#       set script {                    ;# when multiple tasks use the same script this technique is best
#           while 1 {
#               twait -> arg1 arg2
#               set result [someproc $arg1 $arg2]
#               treturn $result
#           }
#       }
#   
#   This will start 4 Tasks (so 4 cpu threads). They all specify the task main, but
#   whichever thread is not busy and wakes up to take a work item from the queue
#   will be the one that runs.
#   
#       Task main   {someproc otherimports} $script         ;# create main and 3 helper Tasks
#       Task helper1/main {someproc otherimports} $script   ;# notice that we import someproc since we don't
#       Task helper2/main {someproc otherimports} $script   ;# load it directly inside the script variable
#       Task helper3/main {someproc otherimports} $script
#
#   The tasks (and threads) will be created by the Task call, and will likely be waiting for input, so
#   this will call them with their first arglist. The res array elements should be distinct as so:
#   
#       tcall $main -async res(1) 100 200 ;# res(1) will be set when this completes, 100 200 are the 2 args.
#       tcall $main -async res(2) 200 200
#       tcall $main -async res(3) 300 200
#       tcall $main -async res(4) 400 200
#       
#       .... do something ...
#       
#       tvwait res(1)
#       tvwait res(2)
#       tvwait res(3)
#       tvwait res(4)   ;# wait for all 4 to finish (in any order, but we wait on all 4)
#                       ;# if the first one takes the longest, the others will already be done
#                       ;# by the time that one finishes, but that's ok, other tvwait's will return immediately.
#                       ;# In order to do a vwait on that variable (tvwait does that) the variable is unset in
#                       ;# the [tcall], and set by a thread::send back to the caller thread where it's set
#   
#   
#
#
#
#   Note, a bug has surfaced in tcl/tk on linux when using putz. It causes a crash. So this
#   version includes a test for the platform and rather than a separate tk text window per
#   task, sends the output to stdout using a puts. This will not work on windows, which will
#   still use the separate windows. However, there is now an option with the t_debug global
#   that will have the windows version output to the console by using a thread::send -async
#   back to the main thread, with a puts of the text. If color is red, it will also output
#   to stderr. There has been added another tsv:: shared variable with the main threads id.
#
#   See the comments in putz for the different values of t_debug. When all are output to
#   the single stream, either stdout or the windows console, the task name will be prefixed
#   plus a ! (easy to use with grep). 
#
#   
#   The taskid is a thread id and so can also be used with various lower level 
#   thread calls. A thread::send could be used to interrupt the thread (assuming it 
#   is waiting and not doing solid compute). The Task works off of a queue and that 
#   queue will be checked with a 50 ms timeout timer. When the timer goes off, an update 
#   is issued and it loops back. This will allow for any widgets created by the Task 
#   (including the putz window) to update. Also the thread::send script will have 
#   time to be run from the event queue.
#
#
#   A [tvwait] is like a regular vwait, except it first checks for the existance of
#   the rglobal. It was designed so that [update] or [vwait] calls could occur between
#   the [tcall] and the [tvwait].
#   
#   However, this could lead to a race condition. The solution is to unset the rglobal
#   in tcall before placing work in the tasks queue. 
#   
#   This has a side effect. If you set a trace on the variable, before a tcall, 
#   your trace will be deleted (unseting a traced variable also deletes the trace). 
#   So, you need to setup the trace after the tcall like this:
#   
#       tcall $tname -async rglobal ?arg ...?
#        ...
#       if { ! [info exist rglobal] } {
#           trace add variable rglobal {write} {notify }
#       } else {
#           notify ...  ;# here if it already exists, just call notify immediately
#       }
#   
#   This could be useful if one wants to [tcall] the task, but does not want to [tvwait] for
#   it later (tvwait is a blocking wait). Say instead, it just wants an event to trigger 
#   when the variable is set. In this method, we call notify when the variable is written
#   to (i.e. is set).
#   
#   But we should only setup the trace if the variable doesn't yet exist, and if it does
#   exist, then we will call notify directly. Thus notify won't miss being called if the
#   variable has already been set to a value.
#   
#   If the task is tcall'ed again, the trace would have to be issued once again. 
#
#   
#   Namespace tasks
#   
#   This namespace is used to enclose the procs for this package. A program can use the
#   namespace import feature like so 
#
#       namespace import tasks::*
#
#   to avoid needing to fully qualify the names. 
#
#   However, the Tasks themselves each import all the tasks procs and also create a tasks
#   namespace. If this option is used, then each task definition should include the -import
#   option. Then the tasks will not need to fully qualify their names either.
#
#   When -import is used, then the imported (i.e. not tasks:: qualified) names are used and the
#   task need not qualify each task::* call.
#    
################################################################################################


#################################################

package require Thread
    
tsv::set  tids [thread::id] mainthread  ;# for reverse lookup 
tsv::set  main mainthread [thread::id]  ;# for reverse lookup 
#################################################
namespace eval tasks {        
proc putz {arg {color normal} {debug no}} { ;# debugging put using a text widget from a Task (a thread)
##########################################
#   t_debug 0  means we use the tk, but no  debug output - the default if < we use 0
#   t_debug 1  means we use the tk  and yes debug stuff
#
#   t_debug 2  means we don't use the tk, and also no  debug
#   t_debug 3  means we don't use the tk, and also yes debug output debug
#
#   platform is windows     ok
#   platform is not windows then we add 2 to the value of t_debug
##########################################
    set dodebugging     0
    set dotk        0
    if { ! [info exist ::t_debug] } {
        set io stdout
        if { $color ne "normal" && $::tcl_platform(platform) eq "windows"} {
            set io stderr
        }
        puts $io $arg
        return
    }
    set tdebug $::t_debug
    if       { $tdebug < 0 || $::t_putz_output == 0} {
        return
    } elseif { $tdebug > 3 } {
        error "t_debug set to > 3 an invalid setting"
    }
    if { $::tcl_platform(platform) ne "windows"  } { ;# hack: change windows to windowsx to force it to use stdout/stderr and a puts
        if { $tdebug < 2 } {
            incr tdebug 2
        }
    }
    
    if       { $tdebug == 0} {
        set  dotk 1
    } elseif { $tdebug  == 1} {
        set  dotk 1
        set  dodebugging 1
    } elseif { $tdebug  == 2} {
        # ok as is, both 0
    } elseif { $tdebug  == 3 } {
        set dodebugging 1
    } else {
        error "bad value for tdebug"
    }
#   error "dotk= |$dotk| dodebugging= |$dodebugging| tdebug= |$tdebug| color= |$color| debug= |$debug| ::t_debug= |$::t_debug| "
#   return  ;# to turn off debugging putz calls always
    if { $debug  eq "debug" && $dodebugging == 0} {
#       puts "we are returning with     $arg"
        return  
    }
    if { $dotk == 0 } {
        set mid [tsv::get main mainthread]
        set argg "[format %-10s  $::t_name] ! $arg"
        set io stdout
        if { $color ne "normal" && $::tcl_platform(platform) eq "windows"} {
            set io stderr
        }
#       puts "trying to send it"
        if { $::tcl_platform(platform) eq "windows" } {
            thread::send -async $mid [list puts $io $argg]
        } else {
            puts $io $argg
        }
        return
    }
    if { [info command .ttttt] eq "" } {                    ;# ![info exist ::t_putz] 
#        set ::t_putz 1
        package require Tk
        if [catch {
            set tname [tsv::get tids [thread::id]]
        } err_code] {
            set tname "No Task" 
        }
        catch {wm title . $tname}
        frame  .fffff
        button .fffff.bbbbb -text "Program exit      [thread::id] $tname"   -command exit
        button .fffff.ccccc -text "Clear text"                              -command {.ttttt delete 1.0 end}
        
        set ::t_task_pause 0
        checkbutton .fffff.cbcbcb1 -variable ::t_task_pause -text "pause"
        
        text      .ttttt    -yscrollcommand     {.sssss set}    -tabs {32 left} -tabstyle wordprocessor
        scrollbar .sssss    -command            {.ttttt yview}
        
        pack .fffff -side top -fill x
        pack .fffff.ccccc .fffff.bbbbb -side left -expand 1 -fill x
        pack .sssss -side right -fill y
        pack .ttttt -side left -fill both -expand 1
        pack .fffff.cbcbcb1 -side right -fill y
        
        set ::t_putz_output 1
        checkbutton .fffff.cbcbcb2 -variable ::t_putz_output -text "putz output" 
        pack .fffff.cbcbcb2 -side right -fill y
        .ttttt tag configure debug              -foreground black
        .ttttt tag configure normal             -foreground black
        .ttttt tag configure green              -foreground \#408f40 -background \#e8e8e8 -font {courier 10 bold}
        .ttttt tag configure white              -foreground white -background black  -font {courier 10 bold}
        .ttttt tag configure yellowonblack      -foreground yellow -background black -font {courier 10 bold}
        .ttttt tag configure yellow             -foreground yellow -background red
        .ttttt tag configure whiteonred         -foreground white -background red -font {courier 10 bold}
        .ttttt tag configure red                -foreground red -font {courier 10}
    }
    if [catch {
        .ttttt insert end $arg\n $color
        .ttttt see end
        update
    } err_code] {
#       puts $err_code 
    }
}

proc wait { ms } {              ;# non busy wait
    set uniq [incr ::__sleep__tmp__counter]
    set ::__sleep__tmp__$uniq 0
    after $ms set ::__sleep__tmp__$uniq 1
    vwait ::__sleep__tmp__$uniq
    unset ::__sleep__tmp__$uniq
}
#wait 1
#puts "__sleep__tmp__counter= |$__sleep__tmp__counter| "
    
#################################################
    
proc xwait {arg {doupdate 1} {doputz 0}} {              ;# a busy wait version of wait, to test compute bound
    set max [expr {   $arg * 12000   }]
    for {set m 0} {$m < $max} {incr m} {
        incr mm 
        if { ($m % 100000) == 0 } {
            if { $doupdate } {
            update
        }
    }
    }
    if { $doputz } {
    putz "xwait max= |$max|" normal debug
    }
}


#################################################

proc comma {num {sep ,}} { ;    ;# commify a positive number
    while {[regsub {^([-+]?\d+)(\d\d\d)} $num "\\1$sep\\2" num]} {}
    return $num
}

#proc Task package code         -----------------------------------------------------------
################################################# return a name from a tid
proc tname {tid} {              ;# shorthand to get the taskname given a Task id
    return [tsv::get tids $tid]
}
################################################# get or set by taskname and parm
proc tset {name parm args} {    ;# shorthand to get or set a shared variable given a Task name and element (optional value)
#   puts "name= |$name| parm= |$parm| "
    set items [list tid pid result script mutex gvar cond queue count error user]
    
    if { $args != {} } {
#       puts "set $name($parm) with args = $args"
        foreach item $items {
            if { $parm eq $item } {
                return [tsv::set tvar $name,$item $args]
            }   
        }
    } else {
        foreach item $items {
            if { $parm eq $item } {
                return [tsv::set tvar $name,$item]
            }   
        }
    }
#   puts  "unknown item $parm"
}
#proc tget/tset alias           -----------------------------------------------------------
interp alias {} tget {} tset
################################################# dump all shared variables
proc tdump {{pat .*} {max 90}} {         ;# dump all the shared Task variables
    set all 1
    if { [string index $pat 0] eq "-" } { ;# a leading - reduces output to just the variables
        set all 0
        set pat [string range $pat 1 end]
    }
    if { $all } {
        putz "\n------ Task(s) dump -----------------------------------------"
        putz "tsv::names  = |[tsv::names *]|"
#       putz "tsv::tvar   = |[tsv::array names tvar *]|"
        putz "tsv::tids   = |[tsv::array names tids *]|"
        putz "---------------------------------------------------------------"
    }
    set tvarnames [lsort -stride 2 -index 1 [tsv::array get tids]]
    
    if { $all } {
        putz "tid/names   = |$tvarnames|"
        putz "---------------------------------------------------------------"
    }
    foreach {var val}  [lsort -dictionary -stride 2 -index 1 $tvarnames ] {
        if { $all } {
            putz "[format %-10s $val] tid: $var  exists: [thread::exists $var]"
        }
        
        set tidnames [tsv::array names tvar $val,*]
        foreach tname [lsort $tidnames] {
            set val [tsv::get tvar $tname]
            set val [string map {\n \u2936 \t \u02eb} $val]
            if { [regexp .*${pat}.* $tname[string range $val 0 $max]] } {
                putz "                 [format %-20s ($tname)] = |[string range $val 0 $max]| "
            }
        }
    }
    if { $all } {
        
        putz "---------------------------------------------------------------"
    }
}
#proc - main Task procs         -----------------------------------------------------------
#################################################
proc Task {name0 args} {        ;# create a Task
    set dowhile 1               ;# assume we want the automatic while loop, but if -once is the first arg in args, we suppress it
    set donamespace 1           ;# assume we want to use namespaces, so we import by namespace
    foreach option {1 2} {
#       puts "$option - args= |$args| "
        if {        [lindex $args 0] eq "-once" } {
            set dowhile 0
            set args [lrange $args 1 end]   ;# shift over the first item in args if -once is the next one
        } elseif {  [lindex $args 0] eq "-import" || [lindex $args 0] eq "-import_tasks"} {
            set donamespace 0
            set args [lrange $args 1 end]   ;# shift over the first item in args if -import is the next one
        }
    }
    set len [llength $args]
    if       { $len == 0 || $len > 2 } {
        error "too few or too many args to Task = $len (or possibly a mispelled option)"
    } elseif { $len == 1 } {
        set args [list {} [lindex $args 0 ]]
    }
#   puts "dowhile= |$dowhile|  "
#   puts "import = |$donamespace|  "
    set names [split $name0 /]
    if { [llength $names] == 1 } {
        set name $name0
        set share no
        set sname {}
    } elseif { [llength $names] == 2 } {
        lassign $names name sname           ;# my name plus which shared queue do we use
        set share yes
    } else {
        error "Invalid Task name |$name0|"
    }
    if { [info exist ::t_debug] && $::t_debug } {
        if [catch {
            puts "Task: name= |$name| sname= |$sname| name0= |$name0| names= |$names| share= |$share| args(end-1)= |[lrange $args end-1 end-1]|"
        } err_code] {
            catch {putz "Task: name= |$name| sname= |$sname| name0= |$name0| names= |$names| share= |$share| args(end-1)= |[lrange $args end-1 end-1]|"}
        }
    }
    
    if { [tsv::exists tvar $name,pid] } {
        error "Task $name already in use, only one task per taskname"
    }
    set me [thread::id]
    tsv::set tvar $name,pid $me             ;# save current parent pid
    tsv::set tvar $name,gvar {}             ;# used by tresult and tcall for a global to wait on
    tsv::set tvar $name,result {}           ;# the result
    tsv::set tvar $name,count 0             ;# the number of times waked up
    tsv::set tvar $name,error {}            ;# the last error if any
    tsv::set tvar $name,share {}            ;# the shared queue if any
    tsv::set tvar $name,user {}             ;# an extra shared variable the user can use
    
    if { $share } {
        set mutex   [tsv::get   tvar    $sname,mutex]
        set cond    [tsv::get   tvar    $sname,cond]
        tsv::set    tvar    $name,share     $sname
        
    } else {
        set mutex   [thread::mutex create]
        set cond    [thread::cond create]
    }
    tsv::set    tvar    $name,queue     {}              ;# setup the cond/mutex and the queue
    tsv::set    tvar    $name,mutex     $mutex
    tsv::set    tvar    $name,cond      $cond
    
    set dw1 "while 1 \{"        ;# also enclose our script in a while 1 loop unless the option -once is used
    set dw2 "\}"
    if { ! $dowhile } {
        set dw1 ""
        set dw2 ""
    }
#   puts "dw1= |$dw1| dw2= |$dw2| "
    set e1 "if \[catch \{$dw1"  ;# enclose script in a catch, and a while (unless suppressed with the option)
    set e2a "\n\}$dw2 thread_err_code thread_err_dict\] \{\n    tsv::set tvar $name,error \$thread_err_dict  \n"
    set e2b {package require Tk; tk_messageBox -message "Name = $::t_name Parent = $::t_pid\n$thread_err_code\n\n$thread_err_dict" -title "tid [thread::id]"}
    set e2c "\n\}\n"
    
    set e2 ""
    append e2 $e2a $e2b $e2c
    
#   puts "$e1----\n----$e2"
    set autoimport [list ::tasks::tproc ::tasks::tdump ::tasks::putz ::tasks::treturn \
                        ::tasks::wait ::tasks::tset ::tasks::tcall ::tasks::twait ::tasks::Task ::tasks::tgroup \
                        ::tasks::xwait ::tasks::comma ::tasks::tname ::tasks::tvwait ::tasks::tpause_check ::tasks::Tproc ]
    if { ! $donamespace } {
        set autoimport [string map {::tasks {}} $autoimport]
    }
    set preamble "#Preamble\n\nnamespace eval tasks {}\nset ::t_pid $me\nset ::t_name $name\nset ::t_putz_output 1\nset ::t_task_pause 0\nset ::t_debug 0\n[tproc {*}$autoimport]\n"
    if       { [llength $args] == 2 } {
        lassign $args prefix script00
        append script0 $e1 $script00 $e2
        append script $preamble  "\n#end preamble\n" "\n#included procs: importing: $prefix\n\n" [tproc {*}$prefix] $script0
#       puts "2 args with prefix $prefix --------------------------------"
    } elseif { [llength $args] == 1 } {
        lassign $args script0
        append script $preamble  "\n#end preamble\n" "\n#included procs: none\n\n"  $script0
#       puts "1 args ----------------------------------------"
    } else {
#       dothis
    }
#   puts stderr "script= \n|\n$script| the parent me= |$me| "

    set script0 "" ;# place another if/catch around the entire script, to catch things like namespace eval missing
    append script0 "if \[catch \{\n" $script "\n" "\} err_code_Task_Create\] \{ " "\n" "    package require Tk; tk_messageBox -title {Task create error} -message \$err_code_Task_Create\n\}"  
    set script $script0
    set tid [thread::create $script]
    
    tsv::set  tvar $name,tid        $tid
    tsv::set  tvar $name,script     $script
    tsv::set  tids $tid             $name       ;# for reverse lookup
    if { $share } {
#       tdump
#       vwait ffff
    }
    uplevel set $name $tid
    return $tid
}
proc tproc {args} {             ;# get procedure(s) and return results, internal use by [Task]
    set output {}
    foreach arg $args {
        if { [string index $arg 0] eq "-" } {
            append output [string range $arg 1 end] "\n"
        } else {
            set found 0
            
            set nq [namespace qualifiers ::$arg]
            set nqe [namespace exist ::$nq]
            if { $nq ne "" && $nqe } {
                append output "namespace eval $nq {namespace export *}\n" ;# we export everything, user can import if desired
#               puts "$arg is a namespace nq= |$nq| nqe= |$nqe| arg= |$arg| "
            } else {
#               puts "$arg is NOT a namespace nq= |$nq| nqe= |$nqe| arg= |$arg| "
            }
            foreach proc [info procs ::$arg] {
                set found 1
                set space ""
                append output  "proc $proc {"
                    foreach arg [info args $proc] {
                        if [info default $proc $arg value] {
                            append output  "$space{$arg \{$value\}}"
                        } else {
                            append output  $space$arg
                        }
                        set space " "
                    }
#                   No newline needed because info body may return a
#                   value that starts with a newline
                    append output  "} {"
                    append output   [info body $proc]
                append output "}\n"
            }
            if { $found == 0 } {
                error "No imports found for $arg\n"
            }
        }
    }
    set lines [split $output \n]
    set out {}
    foreach line $lines {
        if { [string index $line 0] eq "#" } { ;# don't import comment lines, just a blank line instead (so line numbers don't change)
            set line "#"
        }
        append out $line \n 
    }
    return $out
}
proc treturn {args} {           ;# return the value from a Task
#   putz "treturn args= |$args| "
    set exiting no
    if { [llength $args ] > 0} {
        if       { [lindex $args 0] eq "-exit"} {
            set exiting yes
            set args [lrange $args 1 end]
        }
    }
    if [catch {
        set rvalue $args
        set me      [thread::id]
        set name    [tsv::get   tids            $me]
        set pid     [tsv::get   tvar            $name,pid]
        tsv::set    tvar        $name,result    $args
        set gvar    [tsv::get   tvar            $name,gvar]
        
#       putz "+++rvalue= |$rvalue| exiting= |$exiting| me= |$me| name= |$name| pid= |$pid| gvar= |$gvar| "
        if { $args == {} } {
            thread::send $pid [list set ::$gvar $rvalue]    ;# to allow for an empty return value
        } else {
            thread::send $pid "set ::$gvar $rvalue"         ;# to allow for a simple text string or a [list]
        }
#       putz "sent the return value $rvalue to $gvar"
        
    } err_code] {
        putz $err_code
    }
}

#################################################
proc tcall {taskid args} {      ;# call a Task, sync or asyn
    if [catch {
        set exists [thread::exists $taskid] ;# this can return 0 or an error if id is not a thread id
    } err_code] {
        set exists 0
    }
    if {! $exists } {
        if [catch { ;# did the caller use the task name and not it's value?
            set tid $taskid
            set taskid [tsv::set tvar $taskid,tid] ;# try this instead
        } err_code] {
            putz $err_code 
            error "Thread '$taskid' does not exist"
        }
        error "Task id $tid does not exist, likely forgot to use \$$tid"
    }
    set name [tsv::get tids $taskid]
#   puts "args= |$args| taskid= |$taskid| name= |$name| "
    set async no
    if { [llength $args ] > 0} {
        if       { [lindex $args 0] eq "-async"} {
            set async yes
            set args [lrange $args 1 end]
        }
    }
    if { [llength $args ] > 0} {
        set theglobal   [lindex $args 0]
        set args        [lrange $args 1 end]
    } else {
        error "tcall missing the argument for global variable"
    }
    if { [string range $theglobal 0 1] ne "::" } {
#       puts stderr "added :: to $theglobal"
        set theglobal "::$theglobal"
    }
#   global $theglobal
    unset -nocomplain $theglobal
#   puts "$theglobal exists [info exists $theglobal]"
    
#   thread::send ?-async? ?-head? id script ?varname?
#   return
    
    set mutex   [tsv::set tvar $name,mutex]
    set cond    [tsv::set tvar $name,cond]
    set argsx   [list]
    lappend     argsx   [thread::id]    $theglobal $args
    
#   tsv::set tvar $name,gvar $theglobal ;################## the problem
    
#   puts "send args = |$argsx|  mutex= |$mutex| cond= |$cond| "
    
    thread::mutex   lock    $mutex
    tsv::lpush      tvar    $name,queue $argsx end
    thread::cond    notify  $cond
    thread::mutex   unlock  $mutex
    
    if { $async } {
        if [catch {
#           puts "send  $name  $taskid   args -async = |$args|" ;# this will fail if we were not called by the main thread
        } err_code] {
            putz "async cannot use puts here $err_code" green debug
            catch {putz "send  $name  $taskid   args -async = |$args|"} ;# try again but to the thread instead
        }
        return 1
    } else {
        if { ![tvwait $theglobal $taskid] } {
            return {}
        }
        return [set $theglobal]
#       return [tsv::set tvar $name,result] ;# note, if we are using a shared queue, this will not be right, must use global var instead
    }
    
    
}
#################################################
proc tpause_check {args} {
    set twcount 0
    if { $::t_task_pause } {
        while { $::t_task_pause } {
            if { [incr twcount] == 1 } {
                putz "Pausing  task: $twcount"
            }
            wait 1000
        }
        putz "Resuming task after:  $twcount seconds"
        wait 1000
    }
    
}

proc twait {args} {             ;# wait for something in the Task queue
#   putz "   inside twait for $::t_name"
#   wait 2000
    tpause_check
    if [catch {
        set mutex [tsv::get tvar $::t_name,mutex]
        set cond  [tsv::get tvar $::t_name,cond]
#       putz "twait:    mutex= |$mutex| cond= |$cond| " normal debug
    } err_code] {
        catch {putz $err_code}
    }
#   putz "good"
    if [catch {
        
#       putz "about to lock $mutex"; update
#       wait 2000
        thread::mutex lock $mutex
#       putz "after lock"; update
        set count 0
        set sname [tsv::get  tvar $::t_name,share]
        if { $sname != {} } {
            set tname $sname
        } else {
            set tname $::t_name
        }
        catch {putz "" normal debug}
        catch {putz "sname(share name) = |$sname| tname(use)= |$tname| ::t_name(me)= |$::t_name| "  normal debug}
        set count -1
        while {[tsv::llength tvar $tname,queue] == 0} {
            incr count
            if { $count % 50 == 0 && $count <= 100} { ;# output 3 times only each idle period
                catch {putz "queue is empty, so wait $count" red debug}
            }
            thread::cond wait $cond $mutex 50
            update
        }
        catch {putz "queue not empty len= [tsv::llength tvar $tname,queue] contents: [tsv::get tvar $tname,queue]" green debug}
        set works [tsv::lpop tvar $tname,queue]
        thread::mutex unlock $mutex
        
        lassign $works pid gvar work ;# got these from the queue, now set gvar, so the return can use it, also the parent thread to return to
        tsv::set tvar   $::t_name,gvar  $gvar 
        tsv::set tvar   $::t_name,pid   $pid 
        
        set ms [clock milliseconds]
        set secs [expr {   $ms / 1000   }]
        set ms [string range $ms end-2 end]
        
        catch {putz "[string range [clock format $secs] 11 18].$ms job [expr {   [tsv::get tvar $::t_name,count]+1   }]: worklen= [llength $work] -> \{$work\} pid= $pid gvar= $gvar " yellowonblack debug}
        
        } err_code err_dict] {
                set err [lrange [dict get $err_dict -errorcode] 0 1]
                tsv::set tvar $::t_name,error [list $err_code $err]
                catch {putz "error2: |$err_code| err |$err| " normal debug}
                error  $err ;# propogate up, this could be a cancel, not sure what else to do here
    }
    tsv::incr tvar $::t_name,count

# should be able to do this with just one uplevel and lassign, but couldn't figure it out, so brute force it
    if { [llength $args] > 0 } { ;# if the call contained a variable to get the args, plus optionally variables to "lassign" them to
        set name [lindex $args 0]
        set rest [lrange $args 1 end]
        
        catch {putz  "args varname= |$name| rest of variables= |$rest|" normal debug}
        uplevel set $name [list $work]
        
        set i -1
        foreach item $rest {
            incr i
            set data [lindex $work $i ] 
            catch {putz "     arg $i: [format %-12s $item ] data= |$data| " normal debug}
            uplevel set $item [list $data]
        }
    
    }
    
    
    return $work
    
}
#################################################
proc tvwait {var {tid {}}} {    ;# wait till an async Task call, with Task id tid, completes and sets the variable
    if { [string range $var 0 1] ne "::" } {
        set var "::$var"
    }
    if { ![info exist $var] } {
        if {$tid != {} && ![thread::exists $tid] } { ;# if given a taskid, make sure it's still running or we wait forever
            set io stdout
            if { $::tcl_platform(platform) eq "windows" && 0} {
                set io stderr
            }
            if [catch {
                puts $io "Task: $tid does not exist, while waiting on $var"
            } err_code] {
                putz "error in twait: $err_code" normal debug
                catch {putz  "Task: $tid does not exist, while waiting on $var"}
            }
            return 0
        }
        vwait $var
    }
    return 1    
}
############ tgroup ##########################################################
#   
#   Multiple task builder. This takes gname and uses it for a
#   group of tasks. The names will be gname0, gname1, .... gname(N-1)
#   where gname0 is the boss and the rest will be helper/boss with
#   names like gname1/gname0, gname2/gname0, ... gname(N-1)/gname0
#   
#   If the number of tasks is negative, e.g. -4, then the abs(number) will
#   be used, but the -N also will then create traces on each of the tasks
#   assigned result variables (rvar,n). in the -call code, after the tcall's
#
#
#   To create the tasks, one uses the -tasks N or -N option
#   
#       tgroup groupname -tasks N ....  args in Task starting with options
#       tgroup groupname -tasks -N .... this one creates a trace
#       
#   
#   
#   There are 2 ways to process, using -call or -foreach
#   
#       tgroup groupname -call args...
#       tgroup groupname -foreach args...
#       
#       -call
#    
#           can only have as many items as tasks, and if items are less
#           than the number of tasks, it will recycle from the beginning of
#           the arglist until it has run exactly N jobs for -tasks N
#           it is an error to have more args than tasks
#           
#       -foreach
#   
#           This can take any number of args 1..M and each will be run
#           regardless of how many tasks are created. if more jobs than
#           tasks, some tasks will run more than one job in sequence. This
#           option can be used more than once.
#
#   A trace, using -tasks -N can be applied to either -call or -foreach
#
#   To wait for these to be done
#       
#       tgroup groupname -wait all
#       
#           This will wait on all the tasks to complete.
#           
#   The groupname is also the name of a global array that will be
#   first unset on the -tasks option, and then the following elements are
#   generated:
#
#   where n is the number 0..N-1 for N jobs
#   
#   rvar,n     the result value element the calls use
#   args,n     the arguments passed to the n'th task
#   tid,n      the task id's
#   
#   tasks      one only, the number of tasks or jobs depending on -call or -foreach
#   
#   The tasks are all linked to the first one, gname0, and they may exit, but
#   gname0 should not exit. If the script is the same for each, they can tell
#   if they are the boss task by testing for the number in ::t_name which is
#   always set to the task's name and will have a number at the end.
#   
#   usage:
#   
#   tgroup groupname -tasks ?-?N .... args to a task beginning with the options
#
#   tgroup groupname -call    {arglist 1} {arglist 2} ... (only 1 of these)
#   tgroup groupname -foreach {arglist 1} {arglist 2} ... (can be repeated)
#
#   tgroup groupname -wait all 
#   
# or to comine -foreach and -wait all to reduce to just 2 calls:
#
#   tgroup groupname -tasks ?-?N .... args to a task beginning with the options
#   tgroup groupname -run  {arglist 1} {arglist 2} ...    (only 1 of these)
#   tgroup groupname -run                                 (with no args, reset counts to same as just after -tasks) 
############
        
proc tgroup {gname option args} {

    if       { $option eq "-tasks" } {
        uplevel array unset $gname
        upvar 1 $gname name
        
        set argss [lassign $args num]
        set name(trace) 0
        set name(job)   0  ;# so we can have multiple -foreach's (only 1 -call however)
        if { $num < 0 } {
            set num [expr {   0 - $num   }]
            set name(trace) 1
        }
        set name(tasks) $num
        set name(threads) $num
        for {set n 0} {$n < $num } {incr n} {
            if { $n == 0 } {
                set t ${gname}0
            } else {
                set t   ${gname}${n}/${gname}0
            }   
            set tid [uplevel [list tasks::Task $t {*}$argss]]
            set name(tid,$n) $tid
        }
        
    } elseif {  $option eq "-run"  } {
        upvar 1 $gname name
        set name(job)   0                                              ;# reset this so we can do another -run
        set undef {}
        lappend undef  {*}[array names name rvar,*] {*}[array names name args,*]
        foreach und $undef {
            unset name($und)    
        }
        set name(tasks) $name(threads)
        if { [llength $args] != 0 } {
            tgroup $gname -foreachup2 {*}$args
            tgroup $gname -waitup2 all
        }
    } elseif {  $option eq "-foreach" || $option eq "-foreachup2"  } { ;# it's ugly but we allow multiple -foreach's in separate tgroup calls, so we must accumulate jobs
        if { $option eq "-foreach" } {
            upvar 1 $gname name
        } else {
            upvar 2 $gname name
        }
        set numtasks $name(tasks)
        set numarglists [llength $args]
        set name(tasks) [expr {   $numarglists + $name(job)   }] ;# this is ugly, we change meaning of tasks to jobs, since -wait will still work on number of tasks
        if { $name(job) < 0} {
            error "Cannot mix -foreach and -call current job =  $name(job)"
        }
        set jj -1
        for {set job $name(job)} {$job < $name(tasks) } {incr job} {
            set theargs [lindex $args [incr jj] ]
            set name(args,$job) $theargs
            set tid [tset  ${gname}0 tid]
            set tn  [tname $tid]
            set c [uplevel [list tasks::tcall $tid -async ::${gname}(rvar,$job) {*}$theargs]]
            if { $name(trace) } {
                if {! [info exist  ::${gname}(rvar,$job)] } {
                    trace add variable ::${gname}(rvar,$job) write $gname
                } else {
                    $gname  ::$gname rvar,$job Write
                }
            }
            
            if { $c != 1 } {
                error "error calling tgroup -call on job $job"
            }
            
        }
        set name(job) $job

    } elseif {  $option eq "-call"  } { ;# only one -call allowed
        upvar 1 $gname name
        if { $name(job) != 0 } {
            error "Cannot mix -foreach and -call or more than one -call: current job =  $name(job)"
        }
        set name(job) -1   ;# in case we try to do this again
        set numtasks $name(tasks)
        set numarglists [llength $args]
        if { $numarglists >  $numtasks} {
            error "tgroup $gname : too many arglists, $numarglists with only $numtasks tasks"
        }
        set index 0
        for {set job 0} {$job < $numtasks } {incr job} {
            if { ($job % $numarglists) == 0} {
                set index 0
            }
            set theargs [lindex $args $index ]
            set name(args,$job) $theargs
            set tid [tset  ${gname}0 tid]
            set tn  [tname $tid]
            set c [uplevel [list tasks::tcall $tid -async ::${gname}(rvar,$job) {*}$theargs]]
            if { $name(trace) } {
                if {! [info exist  ::${gname}(rvar,$job)] } {
                    trace add variable ::${gname}(rvar,$job) write $gname
                } else {
                    $gname  ::$gname rvar,$job Write
                }
            }
            
            if { $c != 1 } {
                error "error calling tgroup -call on job $job"
            }
            
            incr index
        }
        
    } elseif {  $option eq "-wait" || $option eq "-waitup2" } {
        if { $option eq "-wait" } {
            upvar 1 $gname name
        } else {
            upvar 2 $gname name
        }
        lassign $args type
        if       { $type eq "all" } {
            set numtasks $name(tasks)
            for {set job 0} {$job < $numtasks } {incr job} {
                tvwait ::${gname}(rvar,$job)
            }
        } elseif { $type eq "one"  } {
            error "not implemented in tgroup yet $type"
        } else {
            error "Invalid tgroup call -wait $type must be all or one"
        }
    } else {
        error "Invalid option to tgroup: $option, must be -tasks, -call, -foreach, or -wait"
    }
}
#   Notes on Tproc. 
#   The user can specify a -num for -tasks, just like in Task, however, this
#   means that the traceback proc will have to be after Tproc is called to overide 
#   the proc name, since tracebacks also use the task name. We have to create the proc using
#   the same name, so we can import it. Maybe we should do ${name}_orig for the proc name
#   
#   The user can also do -import or -import_tasks, and also -once, but if -once is used, then
#   the proc will exit after 1 call. 

proc Tproc {name arguments body {option -tasks} {num 4} args} {
    uplevel [list proc $name $arguments $body]

    if { $option ne "-tasks" } {
        error "Tproc option $option invalid, should be -tasks"
    }
    set qual "tasks::"
    set opts {}
    set ar $args
    while { 1 } {
        set ar [lassign $ar option]
        if { $option eq "-import_tasks"  || $option eq "-import"} {
            lappend opts "-import_tasks"
            set qual ""
        } elseif { $option eq "-once" } {
            lappend opts "-once"
        } else {
            set ar [list $name {*}$option]
            break
        }
    }
    set targs {}
    lappend targs {*}$opts $ar
    uplevel "tasks::tgroup $name -tasks $num $targs  \{
        ${qual}twait argv
        ${qual}treturn \[$name \{*\}\$argv\]
    \}
    "
}
namespace export {*}[info proc]
}
# end of tasks namespace eval


 Example

Small example

This example runs the proc sum in a separate thread, perhaps to keep the GUI responsive. It is called first synchronously, and then a second time asynchronously.

    namespace import tasks::*                ;# easiest to just import them all, but could limit to tasks::\[Ttp]* etc.

    proc sum args {foreach arg $args {incr s $arg} ;return $s} ;# sum the arglist items
   
    Task sumserver  -import {sum} {         ;# import all the tasks::* and also sum, this is a repeating task
            set t_debug 1                   ;# turn on debug tracing
            twait argv                      ;# wait for work and get the args
                set result [sum {*}$argv]   ;# call sum with the input args (note imported proc)
                putz "result= |$result| "   ;# output some debug info
            treturn $result                 ;# send back the results, sets a variable with the result, then repeat from top
    }
    
#   call synchronously:
    
    tcall $sumserver resultvar 100 200 300
    puts "resultvar= |$resultvar| " 
    
#   call asynchronously, then wait for it after doing something else 
  
    tcall $sumserver -async resultvar 1 2 3 4 5 6 7
#      ... can do something else while it crunches in the background ...
    tvwait resultvar

    puts "resultvar= |$resultvar| " 
    tdump                                   ;#some debug info about the task(s)

Here's the output on a linux system with the debug turned on, but where the tk window cannot (currently) be used:

$ tclsh wiki-example.tcl
sumserver  ! sname(share name) = || tname(use)= |sumserver| ::t_name(me)= |sumserver| 
sumserver  ! queue not empty len= 1 contents: {tid0x7feb1e590740 ::resultvar {100 200 300}}
sumserver  ! 10:48:03.079 job 1: worklen= |3|     work= |100 200 300| parentid= tid0x7feb1e590740 globalvar= ::resultvar 
sumserver  ! args varname= |argv| rest of variables= ||
sumserver  ! result= |600| 
resultvar= |600| 
sumserver  ! sname(share name) = || tname(use)= |sumserver| ::t_name(me)= |sumserver| 
sumserver  ! queue not empty len= 1 contents: {tid0x7feb1e590740 ::resultvar {1 2 3 4 5 6 7}}
sumserver  ! 10:48:09.153 job 2: worklen= |3|     work= |1 2 3 4 5 6 7| parentid= tid0x7feb1e590740 globalvar= ::resultvar 
sumserver  ! args varname= |argv| rest of variables= ||
sumserver  ! result= |28| 
sumserver  ! sname(share name) = || tname(use)= |sumserver| ::t_name(me)= |sumserver| 
sumserver  ! queue is empty, so wait 0
resultvar= |28| 

------ Task(s) dump -----------------------------------------
tsv::names  = |main tvar tids|
tsv::tids   = |tid0x7feb1d685700 tid0x7feb1e590740|
---------------------------------------------------------------
tid/names   = |tid0x7feb1e590740 mainthread tid0x7feb1d685700 sumserver|
---------------------------------------------------------------
mainthread tid: tid0x7feb1e590740  exists: 1
sumserver  tid: tid0x7feb1d685700  exists: 1
                 (sumserver,cond)     = |cid1| 
                 (sumserver,count)    = |2| 
                 (sumserver,error)    = || 
                 (sumserver,gvar)     = |::resultvar| 
                 (sumserver,mutex)    = |mid0| 
                 (sumserver,pid)      = |tid0x7feb1e590740| 
                 (sumserver,queue)    = || 
                 (sumserver,result)   = |28| 
                 (sumserver,script)   = |#Preamble??namespace eval tasks {}?set ::t_pid tid0x7feb1e590740?set ::t_name sumserver?set| 
                 (sumserver,share)    = || 
                 (sumserver,tid)      = |tid0x7feb1d685700| 
---------------------------------------------------------------
sumserver  ! queue is empty, so wait 50
sumserver  ! queue is empty, so wait 100


 Example using trace

Example with 8 Parallel Fibonacci computations

This example, derived from Ashok's web page on Promises [L1 ], computes the number of digits of 8 fibonacci numbers. Each task is a one shot and quits. The main thread uses a trace on each task call's variable so it can report each computed value as they are finished through the trace event call. It then also waits with tvwait for all 8 tasks to complete (the bigger the number the longer each takes).

It uses a non-busy wait so that one of the tasks finishes before the trace can be applied, and uses the technique mentioned where if the job is done, it just calls the trace notifier with similar arguments.

Followng that is a time comparison with running all 8 sequentially.

    package require math

    namespace import tasks::* 
                
    proc Time {} {
        set ms [clock milliseconds]
        set secs [expr {   $ms / 1000   }]
        set ms [string range $ms end-2 end]
        return [string range [clock format $secs] 11 18].$ms 
    }

# this example uses a trace to report results as they happen
# in this trace event: 

    proc notify {var index operation} {
        puts "[Time] [format %15s $var] ($index) $operation complete result = [set ::$var\($index\)]"
        update
    }

# list of pairs { job, fib number } using 8 jobs on I7: 4 core 8 threads

    set jobs {1 300000   2 310000   3 320000   4 330000 \
              5 300500   6 310500   7 320500   8 330500} 

##################################################  
#   create tasks and start a fibonacci on a number
##################################################
#   
    foreach {task number} $jobs {
        Task fibber$task -once -import { 
            package require math
            twait -> number
            treturn [string length [math::fibonacci $number]]
        }
        tcall [set fibber$task] -async result($task) $number
        puts "[Time] started task= $task with number= $number"
    }
#
##################################################

    puts "\n[Time] ----- all [expr {   [llength $jobs] / 2   }] started    ----" ; update
    tasks::wait 15000
    puts "[Time] ----- 15 sec wait done ----" ; update

############################################################    
#   create N traces on the tasks, Note cap W if already done 

    foreach task {1 2 3 4 5 6 7 8} {
       if { ! [info exist result($task)] } {
           trace add variable result($task) {write} {notify }
       } else {
           notify result $task Write   ;# here if it already exists, just call notify now with W so we know
       }
    }
#
####################################################### 
# now wait for all to have completed in different order 
#
    foreach task {6 3 2 4 8 1 7 5} {    
        puts "[Time] waiting on task $task" ; update
        tvwait result($task)
    }
#   
#######################################################

    puts "[Time] ----- all   complete ----\n" ; update  
    parray result ; update

####################################################### 
#   compute the numbers again, but sequentially

        puts "\n[Time] start sequentially"
        foreach {task number} $jobs {
            set tm [time {
                    set result2($task) [string length [math::fibonacci $number]]
            }]
            puts "[Time] [tasks::comma [lindex $tm 0]] [lrange $tm 1 end]  task $task = $result2($task)"; update
        }
        
    parray result2
#
#######################################################

Here is the output of one of those runs. Each will be slightly different. The processor used was an i7-4790k @ 4 gHz running windows 10. Running as tasks takes 18 seconds vs. 92 seconds sequentially.

15:49:22.795 started task= 1 with number= 300000
15:49:22.822 started task= 2 with number= 310000
15:49:22.844 started task= 3 with number= 320000
15:49:22.869 started task= 4 with number= 330000
15:49:22.895 started task= 5 with number= 300500
15:49:22.927 started task= 6 with number= 310500
15:49:22.955 started task= 7 with number= 320500
15:49:22.988 started task= 8 with number= 330500

15:49:23.003 ----- all 8 started    ----
15:49:38.219 ----- 15 sec wait done ----
15:49:38.220          result (1) Write complete result = 62696
15:49:38.221 waiting on task 6
15:49:38.225      ::::result (5) write complete result = 62801
15:49:39.079      ::::result (2) write complete result = 64786
15:49:39.298      ::::result (6) write complete result = 64891
15:49:39.299 waiting on task 3
15:49:40.241      ::::result (3) write complete result = 66876
15:49:40.242 waiting on task 2
15:49:40.242 waiting on task 4
15:49:40.536      ::::result (7) write complete result = 66981
15:49:41.234      ::::result (4) write complete result = 68966
15:49:41.235 waiting on task 8
15:49:41.315      ::::result (8) write complete result = 69071
15:49:41.316 waiting on task 1
15:49:41.318 waiting on task 7
15:49:41.319 waiting on task 5
15:49:41.320 ----- all   complete ----

result(1) = 62696
result(2) = 64786
result(3) = 66876
result(4) = 68966
result(5) = 62801
result(6) = 64891
result(7) = 66981
result(8) = 69071

15:49:41.332 start sequentially
15:49:52.046 10,713,372 microseconds per iteration  task 1 = 62696
15:50:03.507 11,458,033 microseconds per iteration  task 2 = 64786
15:50:15.702 12,193,040 microseconds per iteration  task 3 = 66876
15:50:28.758 13,053,244 microseconds per iteration  task 4 = 68966
15:50:39.595 10,834,563 microseconds per iteration  task 5 = 62801
15:50:51.173 11,576,267 microseconds per iteration  task 6 = 64891
15:51:03.527 12,349,874 microseconds per iteration  task 7 = 66981
15:51:16.664 13,134,909 microseconds per iteration  task 8 = 69071
result2(1) = 62696
result2(2) = 64786
result2(3) = 66876
result2(4) = 68966
result2(5) = 62801
result2(6) = 64891
result2(7) = 66981
result2(8) = 69071

 Example 1 using helper tasks

This example computes the length of 3 fibonacci numbers. First using just one thread, to keep any Tk gui responsive, the second method to run 3 in parallel to increase performance.

To create a helper task, that shares a queue with a previously created boss task, one specifies the two names as helper/boss. This will cause the helper to share the work on the boss's queue. This provides for a multi-server single queue. All requests still go to the boss, but the boss and all the workers have equal opportunity to grab a job off the queue.

In the results, notice the output of tdump which includes the count of times the task was called and the result of the last job it did. Also notice the mutex and cond variables were shared.

In several places, a <- or -> or even "- >" is used for variable names where the value is not needed. This is used to add a visual aid to separate arguments and indicate the semantics.

    namespace import tasks::*

    set script {
        package require math
        twait - >  number ;# wait for a call and the argument
        treturn  [string length [math::fibonacci $number]]
    }
    set jobs {100000 100005 100009} 

   
# each should take roughly the same time or the timing test
# could be dominated by the one that could take much longer
# this way we have a better idea of the speed up using 3 threads

##############################################################  
    
    set tm [time { ;# one thread 3 jobs
        
        Task fibber1  -import $script  ;# import tasks::*
        foreach num $jobs {
            tcall $fibber1 answer1($num) <- $num 
        }
        
    }]
    
    parray answer1
    puts $tm
    
##############################################################  
#   
#   extend this to compute all 3 in separate threads and wait till all are done
#   
##############################################################  

    set tm [time { ;# 3 threads 3 jobs
        
        foreach taskname {fibber3 helper31/fibber3 helper32/fibber3} {
            Task $taskname  -import  $script  ;# import tasks::*
        }

        foreach num $jobs { ;# call the 3 tasks w/o waiting
            tcall $fibber3 -async answer3($num) <- $num
        }
        
        foreach num $jobs { ;# wait for all 3 to be done
            tvwait answer3($num)
        }
        
    }]
    
    parray answer3
    puts $tm
    tdump
    
##############################################################  
    
# results:
#   answer1(100000) = 20899
#   answer1(100005) = 20900
#   answer1(100009) = 20901
#   3802318 microseconds per iteration
#   answer3(100000) = 20899
#   answer3(100005) = 20900
#   answer3(100009) = 20901
#   1342338 microseconds per iteration
#   
#   ------ Task(s) dump -----------------------------------------
#   tsv::names  = |main tvar tids|
#   tsv::tids   = |tid000008C4 tid000028A8 tid00003260 tid00001ADC tid000034B8|
#   ---------------------------------------------------------------
#   tid/names   = |tid00003260 fibber1 tid00001ADC fibber3 tid000028A8 helper31 tid000008C4 helper32 tid000034B8 mainthread|
#   ---------------------------------------------------------------
#   fibber1    tid: tid00003260  exists: 1
#                    (fibber1,cond)       = |cid1| 
#                    (fibber1,count)      = |3| 
#                    (fibber1,error)      = || 
#                    (fibber1,gvar)       = |::answer1(100009)| 
#                    (fibber1,mutex)      = |mid0| 
#                    (fibber1,pid)        = |tid000034B8| 
#                    (fibber1,queue)      = || 
#                    (fibber1,result)     = |20901| 
#                    (fibber1,script)     = |#Preamble??namespace eval tasks {}?set ::t_pid tid000034B8?set ::t_name fibber1?set ::t_deb| 
#                    (fibber1,share)      = || 
#                    (fibber1,tid)        = |tid00003260| 
#   fibber3    tid: tid00001ADC  exists: 1
#                    (fibber3,cond)       = |cid3| 
#                    (fibber3,count)      = |1| 
#                    (fibber3,error)      = || 
#                    (fibber3,gvar)       = |::answer3(100000)| 
#                    (fibber3,mutex)      = |mid2| 
#                    (fibber3,pid)        = |tid000034B8| 
#                    (fibber3,queue)      = || 
#                    (fibber3,result)     = |20899| 
#                    (fibber3,script)     = |#Preamble??namespace eval tasks {}?set ::t_pid tid000034B8?set ::t_name fibber3?set ::t_deb| 
#                    (fibber3,share)      = || 
#                    (fibber3,tid)        = |tid00001ADC| 
#   helper31   tid: tid000028A8  exists: 1
#                    (helper31,cond)      = |cid3| 
#                    (helper31,count)     = |1| 
#                    (helper31,error)     = || 
#                    (helper31,gvar)      = |::answer3(100005)| 
#                    (helper31,mutex)     = |mid2| 
#                    (helper31,pid)       = |tid000034B8| 
#                    (helper31,queue)     = || 
#                    (helper31,result)    = |20900| 
#                    (helper31,script)    = |#Preamble??namespace eval tasks {}?set ::t_pid tid000034B8?set ::t_name helper31?set ::t_de| 
#                    (helper31,share)     = |fibber3| 
#                    (helper31,tid)       = |tid000028A8| 
#   helper32   tid: tid000008C4  exists: 1
#                    (helper32,cond)      = |cid3| 
#                    (helper32,count)     = |1| 
#                    (helper32,error)     = || 
#                    (helper32,gvar)      = |::answer3(100009)| 
#                    (helper32,mutex)     = |mid2| 
#                    (helper32,pid)       = |tid000034B8| 
#                    (helper32,queue)     = || 
#                    (helper32,result)    = |20901| 
#                    (helper32,script)    = |#Preamble??namespace eval tasks {}?set ::t_pid tid000034B8?set ::t_name helper32?set ::t_de| 
#                    (helper32,share)     = |fibber3| 
#                    (helper32,tid)       = |tid000008C4| 
#   mainthread tid: tid000034B8  exists: 1
#   ---------------------------------------------------------------
#    

 Example 2 using helper tasks

Example helper tasks: 2 tasks 8 jobs

In this example, we again compute the same fibonacci numbers as the previous example (8 numbers so 8 jobs), but we don't run 1 task per number; rather, we setup only 2 tasks, a main task fibber which has the queue, and one helper task helper2 that shares the queue from fibber. The number of tasks is assigned to the variable ntasks and for this demo was set to just 2. This results in the two tasks sharing the load and each ends up working 4 jobs.

With some changes to the number of tasks, the load will be distributed differently. If more tasks exist than there are jobs, e.g. 10 tasks, you will see that some do no work at all.

Each task sets the t_debug global variable to 1, and so each task will create it's own toplevel window with a text widget on the first output from the debugging log. Debugging uses the putz command with different colors for various items, but that cannot be copy/pasted here, only the text, not the attributes. Note that if there were in fact 10 tasks, you'd see 10 windows.

    package require math

    namespace import tasks::* 
                
    proc Time {} {
        set ms [clock milliseconds]
        set secs [expr {   $ms / 1000   }]
        set ms [string range $ms end-2 end]
        return [string range [clock format $secs] 11 18].$ms 
    }


# list of pairs { job, fib number } using 8 jobs on I7: 4 core 8 threads

    set jobs {1 300000   2 310000   3 320000   4 330000 \
              5 300500   6 310500   7 320500   8 330500} 

##################################################
# 
    set taskname fibber
    set ntasks 2
    for {set tasknum 1} {$tasknum <= $ntasks } {incr tasknum} {
        if { $tasknum > 1 } { ;# first one fibber, others helper#/fibber
            set taskname helper$tasknum/fibber
        }
        puts "[Time] creating task $taskname"
        Task $taskname  -once -import {
            set t_debug 1           ;#  set this once
            package require math    ;#  and do this once only
            while 1 {               ;#  but repeat this forever
                twait -> number
                treturn [string length [math::fibonacci $number]]
            }
        }
    }
#
##################################################  
#   start a fibonacci on a number

    foreach {job number} $jobs {
        puts "[Time] starting job= $job with number= $number"
        tcall $fibber -async result($job) $number
        update
    }
#
# now wait for all jobs to have completed 
#
    set njobs [expr {   [llength $jobs] / 2   }]
    puts "[Time] wait for $njobs jobs"
    for {set job 1} {$job <= $njobs } {incr job} {
        puts "[Time] waiting on job $job" ; update
        tvwait result($job)
    }
#   
#######################################################

    puts "[Time] ----- all   complete ----\n" ; update  
    parray result ; update
    tdump

Here is the output to stdout from puts. The tdump command output is shown as well. You can see that they use the same mutex and conditional, and the helper2 task has the share attribute set to fibber.

11:38:24.005 creating task fibber
11:38:24.035 creating task helper2/fibber
11:38:24.055 starting job= 1 with number= 300000
11:38:24.184 starting job= 2 with number= 310000
11:38:24.255 starting job= 3 with number= 320000
11:38:24.257 starting job= 4 with number= 330000
11:38:24.257 starting job= 5 with number= 300500
11:38:24.258 starting job= 6 with number= 310500
11:38:24.259 starting job= 7 with number= 320500
11:38:24.259 starting job= 8 with number= 330500
11:38:24.260 wait for 8 jobs
11:38:24.260 waiting on job 1
11:38:35.159 waiting on job 2
11:38:35.969 waiting on job 3
11:38:47.728 waiting on job 4
11:38:49.336 waiting on job 5
11:38:58.812 waiting on job 6
11:39:01.173 waiting on job 7
11:39:11.385 waiting on job 8
11:39:14.522 ----- all   complete ----

result(1) = 62696
result(2) = 64786
result(3) = 66876
result(4) = 68966
result(5) = 62801
result(6) = 64891
result(7) = 66981
result(8) = 69071

------ Task(s) dump -----------------------------------------
tid/names   = |tid00002CC0 fibber tid00000818 helper2|
---------------------------------------------------------------
fibber     tid: tid00002CC0  exists: 1
                 (fibber,cond)        = |cid1| 
                 (fibber,count)       = |4| 
                 (fibber,error)       = || 
                 (fibber,gvar)        = |::result(7)| 
                 (fibber,mutex)       = |mid0| 
                 (fibber,pid)         = |tid00003210| 
                 (fibber,queue)       = || 
                 (fibber,result)      = |66981| 
                 (fibber,script)      = |#Preamble??namespace eval tasks {}?set ::t_pid tid00003210?set ::t_name fibber?set ::t_debu| 
                 (fibber,share)       = || 
                 (fibber,tid)         = |tid00002CC0| 
helper2    tid: tid00000818  exists: 1
                 (helper2,cond)       = |cid1| 
                 (helper2,count)      = |4| 
                 (helper2,error)      = || 
                 (helper2,gvar)       = |::result(8)| 
                 (helper2,mutex)      = |mid0| 
                 (helper2,pid)        = |tid00003210| 
                 (helper2,queue)      = || 
                 (helper2,result)     = |69071| 
                 (helper2,script)     = |#Preamble??namespace eval tasks {}?set ::t_pid tid00003210?set ::t_name helper2?set ::t_deb| 
                 (helper2,share)      = |fibber| 
                 (helper2,tid)        = |tid00000818| 
---------------------------------------------------------------

Here is the debug log output from task fibber that used putz.

sname(share name) = || tname(use)= |fibber| ::t_name(me)= |fibber| 
queue not empty len= 1 contents: {tid00003210 ::result(1) 300000}
11:38:24.177 job 1: worklen= |3|     work= |300000| parentid= tid00003210 globalvar= ::result(1) 
args varname= |->| rest of variables= |number|
i= |0| item= |number| data= |300000| 

sname(share name) = || tname(use)= |fibber| ::t_name(me)= |fibber| 
queue not empty len= 6 contents: {tid00003210 ::result(3) 320000} {tid00003210 ::result(4) 330000} {tid00003210 ::result(5) 300500} {tid00003210 ::result(6) 310500} {tid00003210 ::result(7) 320500} {tid00003210 ::result(8) 330500}
11:38:35.162 job 2: worklen= |3|     work= |320000| parentid= tid00003210 globalvar= ::result(3) 
args varname= |->| rest of variables= |number|
i= |0| item= |number| data= |320000| 

sname(share name) = || tname(use)= |fibber| ::t_name(me)= |fibber| 
queue not empty len= 4 contents: {tid00003210 ::result(5) 300500} {tid00003210 ::result(6) 310500} {tid00003210 ::result(7) 320500} {tid00003210 ::result(8) 330500}
11:38:47.737 job 3: worklen= |3|     work= |300500| parentid= tid00003210 globalvar= ::result(5) 
args varname= |->| rest of variables= |number|
i= |0| item= |number| data= |300500| 

sname(share name) = || tname(use)= |fibber| ::t_name(me)= |fibber| 
queue not empty len= 2 contents: {tid00003210 ::result(7) 320500} {tid00003210 ::result(8) 330500}
11:38:58.816 job 4: worklen= |3|     work= |320500| parentid= tid00003210 globalvar= ::result(7) 
args varname= |->| rest of variables= |number|
i= |0| item= |number| data= |320500| 

sname(share name) = || tname(use)= |fibber| ::t_name(me)= |fibber| 
queue is empty, so wait 0


Here is the output from task helper2.

sname(share name) = |fibber| tname(use)= |fibber| ::t_name(me)= |helper2| 
queue is empty, so wait 0
queue not empty len= 1 contents: {tid00003210 ::result(2) 310000}
11:38:24.249 job 1: worklen= |3|     work= |310000| parentid= tid00003210 globalvar= ::result(2) 
args varname= |->| rest of variables= |number|
i= |0| item= |number| data= |310000| 

sname(share name) = |fibber| tname(use)= |fibber| ::t_name(me)= |helper2| 
queue not empty len= 5 contents: {tid00003210 ::result(4) 330000} {tid00003210 ::result(5) 300500} {tid00003210 ::result(6) 310500} {tid00003210 ::result(7) 320500} {tid00003210 ::result(8) 330500}
11:38:35.973 job 2: worklen= |3|     work= |330000| parentid= tid00003210 globalvar= ::result(4) 
args varname= |->| rest of variables= |number|
i= |0| item= |number| data= |330000| 

sname(share name) = |fibber| tname(use)= |fibber| ::t_name(me)= |helper2| 
queue not empty len= 3 contents: {tid00003210 ::result(6) 310500} {tid00003210 ::result(7) 320500} {tid00003210 ::result(8) 330500}
11:38:49.359 job 3: worklen= |3|     work= |310500| parentid= tid00003210 globalvar= ::result(6) 
args varname= |->| rest of variables= |number|
i= |0| item= |number| data= |310500| 

sname(share name) = |fibber| tname(use)= |fibber| ::t_name(me)= |helper2| 
queue not empty len= 1 contents: {tid00003210 ::result(8) 330500}
11:39:01.199 job 4: worklen= |3|     work= |330500| parentid= tid00003210 globalvar= ::result(8) 
args varname= |->| rest of variables= |number|
i= |0| item= |number| data= |330500| 

sname(share name) = |fibber| tname(use)= |fibber| ::t_name(me)= |helper2| 
queue is empty, so wait 0

 Example to combine with thread::send

This example demonstrates how one can combine lower level thread::send calls with Tasks. The task waits for input, but does not block the event queue forever (it issues an update every 50 ms while waiting for tcall input).

    namespace import tasks::*
    
    Task test -import  {
        twait argv a1 a2
        putz "argv= |$argv| a1= |$a1| a2= |$a2| "
        treturn   " this is a string with a1= |$a1| a2= |$a2| "
    }
    
    wait 1000
    
    thread::send -async $test [list putz "this should open a tk window on windows (or output to stdout on linux)"]
    
    wait 1000
    
    tcall   $test result some input
    puts "result= <$result> "

Here's the output (on windows)

The Tk window has this:

this should open a tk window on windows (or output to stdout on linux)
argv= |some input| a1= |some| a2= |input| 

And the console will have this:

result= < this is a string with a1= |some| a2= |input| >  

 Example to combine with thread::cancel

This example demonstrates using thread::cancel calls with Tasks.

When a cancel arrives as an event, it throws a cancel error. If you intend to use a cancel, you can catch it, or any thing else that does a return to the event loop, such as the wait call in this code. If it cancels before the treturn, the result-var will still be unset. Here's some test code.

    namespace import tasks::*
    ;   proc sum {args} {
        putz "sum up: $args"
        return [tcl::mathop::+ {*}$args]    ;# use the multi arg add operator
    }
    Task test  -import {sum} {
        set t_debug 2                       ;# putz (no debug) sent back to console or stdout
        if [catch {
            twait argv                      ;# wait for work and get the args
            putz "started the job"
            wait 2000                       ;# this is a non-busy wait that can get canceled too
            putz "after the wait 2000 in the task"
        } err_code] {
            putz "task got an error = $err_code"
            break     ;# out of our hidden while loop, to exit the task/thread
        }
        set result [sum {*}$argv]   ;# call sum with the input args (note imported proc)
        putz "result= |$result| "
        treturn $result                 ;# send back the results, sets a variable with the result
    }
    
    tcall $test result 5 10 15          ;# show that it works
    puts "result= |$result| "
    
    tcall $test -async result 10 20 30  ;# but this one will end up being cancelled
    wait 1000
    thread::cancel $test
    wait 1000
    tvwait result $test                 ;# since the task may have exited, use this
    
    if [catch {
        puts "result= |$result| "
    } err_code] {
        puts "error outputing the result: $err_code"
    }
    
    wait 5000
    tdump

Here's the output to a windows console:

test       ! started the job
test       ! after the wait 2000 in the task
test       ! sum up: 5 10 15
test       ! result= |30| 
result= |30| 
test       ! started the job
test       ! task got an error = eval canceled
Task: tid0000358C does not exist, while waiting on ::result
error outputing the result: can't read "result": no such variable

------ Task(s) dump -----------------------------------------
tsv::names  = |main tvar tids|
tsv::tids   = |tid0000358C tid00002CE0|
---------------------------------------------------------------
tid/names   = |tid00002CE0 mainthread tid0000358C test|
---------------------------------------------------------------
mainthread tid: tid00002CE0  exists: 1
test       tid: tid0000358C  exists: 0
                 (test,cond)          = |cid1| 
                 (test,count)         = |2| 
                 (test,error)         = || 
                 (test,gvar)          = |::result| 
                 (test,mutex)         = |mid0| 
                 (test,pid)           = |tid00002CE0| 
                 (test,queue)         = || 
                 (test,result)        = |30| 
                 (test,script)        = |#Preamble??namespace eval tasks {}?set ::t_pid tid00002CE0?set ::t_name test?set ::t_debug | 
                 (test,share)         = || 
                 (test,tid)           = |tid0000358C| 
---------------------------------------------------------------

 Example producer/consumer with a buffer task

Using tasks with the N-producer/N-consumer single queue problem.

Here we have several producer and consumer tasks which communicate through the intermediary of a buffer task.

The bounded buffer size queue is in buffer's local (global) memory. All of the prod/cons tasks calls the buffer task requesting some data off the queue, or to put some data on the queue (fifo). These requests are also queued fifo, as with any task.

Buffer returns 0/1 as to the success of a request, which depends on the state of the queue, full, empty, or in between, and which operation (prod or cons) is desired.

The included variable name, is used to signal back to the caller task when the queue status has changed. All waiting tasks are signaled and they will then resume from waiting for the signal.

This example runs best on windows, where all the tasks have a window where one can pause any or all of them. On linux, there will still be a bit of a gui, but most of the output will be to stdout. You can pipe through grep however.

    package require Tk
    namespace import tasks::*
    
    proc addwaiter {id type var } {
        lappend ::waiters($type) [list $id $var]
    }
    
    proc signalwaiters {type} {
        while { [llength $::waiters($type)] > 0 } {                  ;# signal all waiters of same "type"
            lassign [lindex $::waiters($type) 0] id varname          ;# task id an the varname to wait on
            putz "signal $type id= |$id| [format %-13s [tname $id]] varname= |$varname| "
            thread::send -async $id [list set ::$varname $type/666]  ;# set the waiters wait var, that resumes him
            set ::waiters($type) [lrange $::waiters($type) 1 end]    ;# remove the first waiter from queue
        }
    }
    
    proc dumpq {} {
        putz ""
        foreach type {produce consume} {
            putz "--- $type --- <$::waiters($type)>" green
            foreach item $::waiters($type) {
                lassign $item id var
                putz "id= |$id| [format %-15s [tname $id] ] var= |$var| "
            }
        }
        putz "--- queue   --- <$::queue>\n" green
    }
    
    
#   
#   ########################## buffer ###############################################
    
    Task buffer -import {addwaiter signalwaiters dumpq} {
        
        twait -> qsize          ;# first time called, we just get our max queue size
        treturn ok              ;#
        
        putz "Buffer Queue max size= |$qsize| "
        catch {wm geom . 1109x495+-5+6}
        
        set queue {}            ;# this is our queue of data produced and consumed
        
        set waiters(consume) {} ;# these are the lists of consumers who are blocked
        set waiters(produce) {} ;# and the producers
        
        package require Tk
        toplevel .top           ;# our queue text entry with the items and the length
        entry   .top.queue    -text "queue"   -textvariable ::queue        -font {courier 18} -width 60
        entry   .top.queue2   -text "length"  -textvariable ::queuesize    -font {courier 18} -width 3
        
        ttk::labelframe .top.delay    -text "Delay"
        ttk::spinbox .top.delay.sb    -from 0 -to 1000 -increment 25    -textvariable ::delay_buffer -width 5 -font {courier 18}
        
        pack    .top.delay                    -side right
        pack    .top.queue      -expand true  -side right -fill both
        pack    .top.queue2     -expand true  -side left  -fill both
        pack    .top.delay.sb   -expand true              -fill both
        
        wm geom .top 1255x62+374+859
        
        wm attributes .top  -topmost 1
        set ::delay_buffer 0
        while { 1 } {
            wait $::delay_buffer
            twait -> type data var                      ;# called with real requests, if type is consume, data is just a place holder
            
            set pid [tset buffer pid]                   ;# get our parent (caller) id so we can signal if needed
            putz "$pid [format %-14s [tname $pid] ] type= |$type| data= |$data| var= |$var| " green
            set ::queuesize [llength $queue]            ;# for our queue size text entry
            
            if       { $type eq "produce" } {
                
                putz "   produce:  len/max= [llength $queue] / $qsize   <$queue> before insert" red
                
                if { [llength $queue] >= $qsize } {     ;# is there room for another
                    addwaiter $pid produce $var         ;# no put this guy on our producer waiting list
                    treturn 0                           ;# return 0 if the queue is full
                } else {
                    lappend queue $data                 ;# add data to the end of the queue (fifo)
                    signalwaiters consume               ;# signal all waiting consumers that there's new data available
                    treturn 1                           ;# return 1 when data added to queue sucessfully
                }
                
            } elseif { $type eq "consume" } {
                
                putz "   consume:  len/max= [llength $queue] / $qsize   <$queue> before consume" red
                
                if { [llength $queue]  == 0} {          ;# is there anything to consume
                    addwaiter $pid consume $var         ;# no put this guy on our consumer waiting list
                    treturn [list 0 0]                  ;# {code data} - data is just a place holder here
                } else {
                    set data    [lindex $queue 0]       ;# get the next one off the data queue
                    set queue   [lrange $queue 1 end]   ;# now remove that one
                    putz "   remove <$data> queue now:    <$queue> "
                    signalwaiters produce               ;# signal all producers there's room now
                    treturn [list 1 $data]              ;# return code 1, and some data
                }
                
            } elseif { $type eq "dump" } {
                
                dumpq
                wait 3000 ;# time to look at the dump
                
            } else {
                error "bad type"
            }
        }
    }
    
#   ########################### producer ####################################
    set pscript {
        twait -> bid delay geom first   ;# one time we get called with the buffer task id
        treturn ok
        
        putz "producer init"
        catch {wm geom . $geom}
        set data [expr {   $first - 1   }]
        while { 1 } {
            putz "produce during [comma $delay] miliseconds" green
            wait $delay ;#simulate time to produce
            tpause_check
            incr data   ;# this is what we produce, just keep incr'ing it
            set try 0   ;# how many tries before we can give this successfully to the buffer task
            while { 1 } {
                unset -nocomplain                   ::prod_full_var ;# in order to wait on a var, we must unset it first
                tcall $bid rvar       produce $data ::prod_full_var ;# sync call to the buffer, with our signal var as a parm
                incr try                                            ;# with multiple producers, we all get a shot at the queue
                if { $rvar } {                                      ;# rvar is 1/0 for sucess or no room in buffer
                    putz "fits   on try number: $try    data we inserted = |$data|" red
                    break                                           ;# leave this loop and go back to producing a new data item
                } else {
                    putz "no-fit on try number: $try    try again, tvwait on ::prod_full_var"
                    tvwait ::prod_full_var      ;# the buffer task will save prod_full_var and signal us when room in queue
                }
            }
        }
        
    }
    Task producer  -import $pscript
    Task producer2 -import $pscript
    
#   ################################# consumer ####################################################
    
    set cscript {
        twait -> bid delay1 modulo delay2  geom ;# buffer task/thread id, 2 delays with a modulo on delay2
        treturn ok                              ;# we return only to resume the callback that started us going
        
        putz "consumer init"
        catch {wm geom . $geom}
        while { 1 } {
            set try 0
            while { 1 } {
                tpause_check
                
                unset -nocomplain                         ::cons_empty_var
                tcall   $bid            rvar  consume 0   ::cons_empty_var   ;# returns list of {code data} code 0/1
                
                lassign $::rvar   code        data
                if { $code  } {
                    break           ;# the data was returned from the queue
                } else {            ;# the queue was empty, so we need to wait for a signal after a producer queues some data
                    putz  "Queue empty, wait for a signal try: [incr try]" red
                    tvwait ::cons_empty_var
                }
            }
            
            putz "Got one $data" red
            wait $delay1
            if { [incr counter] % $modulo == 0 } {
                catch {wm title . "delaying $delay2"}
                wait $delay2
                catch {wm title . "continue"}
            }
        }
    }
    Task consumer  -import  $cscript
    Task consumer2 -import  $cscript
    Task consumer3 -import  $cscript
#    Task consumer4 -import  $cscript
    
    
#   ################################# consume 1 button callback ####################################################
    
    proc consume1 {args} {
        incr ::level
        if { $::level > 1 } {
#           putz "busy in the last one, level = $::level so ignoring this one"
        } else {
            while { 1 } {
                unset -nocomplain                        ::cons_empty_var
                tcall $::buffer rvar     consume 0 ::cons_empty_var
                lassign $::rvar code data
                putz "consume reequest [format %-15s |$::rvar| ] code= |$code| data= |$data| "
                if { $code  } {
                    break
                } else {
                    tvwait cons_empty_var
                }
            }
            putz "Got one $data" red
        }
        incr ::level -1
        
    }
    
#   ##################################### some gui buttons #######################################################
    
    button  .consume    -text "consume" -command    consume1             ;# do just 1 consume, report to console
    button  .dump       -text "dump"    -command    dump                 ;# dump the queues in the buffer task
    
    pack    .consume    -fill both      -expand     true
    pack    .dump       -fill both      -expand     true
    
    wm geom . 369x105+1+857
    
#   ###################################### start up our tasks ####################################################
    
    tcall $::buffer    <-   10                                       ;# send buffer his max size
    
    tcall $::producer  <-  $::buffer 199  792x222+1112+7   0         ;# buffer id, delay to produce, window geom, starting data value
    tcall $::producer2 <-  $::buffer 100  792x229+1119+272 10000     ;# buffer id, delay to produce, window geom start at 10k
    
    after 5000  {tcall  $::consumer   <- $::buffer 300 10 2000 517x220+-6+543}    ;# delay starting our consumers
    after 15000 {tcall  $::consumer2  <- $::buffer 25  30 3000 531x221+517+544}   ;# delay, modulo, delay2, geom
    after 17000 {tcall  $::consumer3  <- $::buffer 300 10 2000 521x220+1055+545}
    
    tdump                                                                ;# threads dump to console
    
    proc dump {} {
        tcall $::buffer -async xxxx dump                                 ;# send to buffer ask for a queue dump
    }
    
    wait 2000
    dump

 using tgroup the task builder

The tgroup procedure is a quick way to launch a group of tasks, sharing a single queue, that can be run given a set of arglists. They will run in parallel if possible. The general form is:

 to start a new group

     tgroup groupname -tasks ?-?N .... args to a task beginning with the options

 to process arglists

     tgroup groupname -call    {arglist 1} {arglist 2} ... (only 1 of these per -wait)
     tgroup groupname -foreach {arglist 1} {arglist 2} ... (can be repeated)

 to wait for all jobs to be done

     tgroup groupname -wait all 
   
 to combine -foreach and -wait all

     tgroup groupname -run  {arglist 1} {arglist 2} ...    (can have multiple times witn one -tasks)

 resets the counts to state just after using -tasks

     tgroup groupname -run                                 (with no args, reset counts) 

The first argument to each tgroup call is the tasks group name which is used to create task names: group0, group1/group0, group2/group0, .... for a total of N tasks, as given by the -tasks N option. If it's negative, then use abs(N) and set a flag for traces. This group of command options need to be in the order below.

The group name can also be a qualified namespace name, e.g. ns::groupname. The namespace must have been created earlier in the program, e.g. namespace eval ns {}.


  • -tasks

The -tasks N option starts N tasks/threads. The arguments that follow this option are identical to those in the Task procedure which follow the taskname argument. This option calls the Task procedure to create the task.


  • -foreach and -call

The -foreach option calls the tasks -async for each arglist that follows. There can be fewer or more jobs than tasks. If there are more jobs than tasks, some tasks will do more than 1 job, and if less jobs than tasks, some tasks will not do any jobs. This option can be used more than once if preferred.

or (but not both option types)

The -call option also calls the tasks -async for each arglist that follows. If there are fewer arglists than tasks, the list of arglists will repeat at the first one until all N of the tasks are given work. See the 2nd example below that uses the trace option. This option can be used only once, as it will always call all tasks.

With each of these 2 options If the trace flag was set, a trace is put on each one, using the group name as a callback procedure.


  • -wait

The -wait all option will wait for all the work to complete. It is used once after the previous options have been run.


  • -run

The option -run (when supplied with args) combines a -foreach arg arg... and -wait all. All the jobs are run -async. It first clears any args and results from the group array. It can be run multiple times for a single -tasks setup. Each run will produce results for the args given to the -run option.

    tgroup fibonacci -tasks 4 $script      ;# create 4 tasks

    tgroup fibonacci -run 10 20 30 40      ;# run 4 jobs and wait
#        ... do somethine with the 4 results ...
    tgroup fibonacci -run 20 20 30         ;# run 3 more jobs and wait 
#        ... do somethine with the 3 results ...
    tgroup fibonacci -run 30 20            ;# run 2 more jobs and wait 
#        ... do somethine with the 2 results ...

The -run option can also be used with no args and will just clear out any previous results and args, and resets the job count to zero.

This can be used with the -foreach option above, which can be run multiple times, and then use the -wait all option to wait for all the previous jobs started by a -foreach to be done. It will also reset after a -call and -wait all pairs and so another pair can be run on the same tasks created by the -tasks option.

For example the following will run 3 sets of 2 jobs. It uses the one -tasks setup, then clears any previous results from -foreach and -wait all's and runs 2 jobs. It then loops back 2 more times to clear the results first, and and then another set of 2 jobs.

    tgroup fibonacci -tasks 4 $script      ;# create 4 tasks

# Run 3 sets of 2 jobs each using above 4 tasks

    for {set m 1} {$m <= 3} {incr m} {

        tgroup fibonacci -run                     ;# reset all counts, args, and results
        tgroup fibonacci -foreach [list 1 $m]     ;# run 1 job that gets sent 2 args
        tgroup fibonacci -foreach [list 2 $m]     ;# another one with 2 args
        tgroup fibonacci -wait all                ;# this waits for the 2 -foreach jobs

        # use results for the above 2 -foreach's

    }

The group name is also used to create a global array with the args and results, plus other info.

In the example script below, this will compute the sum of their arglist's plus a busy wait we can monitor for cpu time. It uses the composite -run option since it does not need to do anything before waiting for the completion of all the jobs, but on a multi-core system can run in parallel to improve performance.

    namespace import tasks::*
;   proc sum {args} {
        xwait 2000                          ;# simulate 2 seconds of heavy compute
        return [tcl::mathop::+ {*}$args]    ;# use the multi arg add operator
    }
    
    tgroup summer -tasks 4  -import {sum} {   ;# create 4 tasks using the same script
            twait argv
            treturn [sum {*}$argv]
    }
    
    tgroup summer -run {1 2 3} {4 5 6} {7 8 9} ;# run 3 jobs and wait for them 
    
    parray summer args*
    puts ""
    parray summer rvar*

The result is:

summer(args,0) = 1 2 3
summer(args,1) = 4 5 6
summer(args,2) = 7 8 9

summer(rvar,0) = 6
summer(rvar,1) = 15
summer(rvar,2) = 24

Here's an example where we use the trace, by using a -N for number of tasks. The traces use the group name as a proc to be the callback of the trace, which sends 3 args, varname, element, operation. This example uses -call and so the arglist is repeated to fill out the number of tasks.

    namespace import tasks::*
;   proc sum {args} {
        lassign $args first
        xwait [expr {   200 * $first   }]   ;# use first number to determine busy wait time
        return [tcl::mathop::+ {*}$args]    ;# use the multi arg add operator
    }
;   proc Time {} {
        set ms [clock milliseconds]
        set secs [expr {   $ms / 1000   }]
        set ms [string range $ms end-2 end]
        return [string range [clock format $secs] 11 18].$ms
    }
    puts "[Time] starting"
#####################################################################

    tgroup summer -tasks -8  -import {sum} { ;# setup 8 tasks, set trace flag 
        twait argv
        treturn [sum {*}$argv]
    }
        
;   proc summer {args} {                     ;# trace callback at each task completion
        lassign $args aname element op
        set value [set ${aname}($element)]
        puts "[Time] [format %-26s |$args| ] aname= |$aname| element= [format %-10s |$element| ] op= |$op| value= |$value| "
    }
    
    tgroup summer -call {1 2 3} {4 5 6} {7 8 9} {10 11 12} ;# when fewer arglists, repeat at front
    tgroup summer -wait all
    
    puts ""
    parray summer args*
    puts ""
    parray summer rvar*

# output:    
#    16:33:02.303 starting
#    16:33:03.006 |::::summer rvar,4 write|  aname= |::::summer| element= |rvar,4|   op= |write| value= |6| 
#    16:33:03.042 |::::summer rvar,0 write|  aname= |::::summer| element= |rvar,0|   op= |write| value= |6| 
#    16:33:04.186 |::::summer rvar,5 write|  aname= |::::summer| element= |rvar,5|   op= |write| value= |15| 
#    16:33:04.226 |::::summer rvar,1 write|  aname= |::::summer| element= |rvar,1|   op= |write| value= |15| 
#    16:33:05.033 |::::summer rvar,2 write|  aname= |::::summer| element= |rvar,2|   op= |write| value= |24| 
#    16:33:05.172 |::::summer rvar,6 write|  aname= |::::summer| element= |rvar,6|   op= |write| value= |24| 
#    16:33:05.520 |::::summer rvar,7 write|  aname= |::::summer| element= |rvar,7|   op= |write| value= |33| 
#    16:33:05.824 |::::summer rvar,3 write|  aname= |::::summer| element= |rvar,3|   op= |write| value= |33| 
#    
#    summer(args,0) = 1 2 3
#    summer(args,1) = 4 5 6
#    summer(args,2) = 7 8 9
#    summer(args,3) = 10 11 12
#    summer(args,4) = 1 2 3
#    summer(args,5) = 4 5 6
#    summer(args,6) = 7 8 9
#    summer(args,7) = 10 11 12
#    
#    summer(rvar,0) = 6
#    summer(rvar,1) = 15
#    summer(rvar,2) = 24
#    summer(rvar,3) = 33
#    summer(rvar,4) = 6
#    summer(rvar,5) = 15
#    summer(rvar,6) = 24
#    summer(rvar,7) = 33

This next example compares a sequential vs. a task compute of the total number of digits of 100 fibonacci numbers. The task method is more code, but it also computes the numbers twice, once using a trace callback. Then it traverses the output array of answers. Both the array and the callback have the same name: fibonacci since tgroup uses the group name for the array with the output, and also the trace callback.

This example runs on windows only (or just set the number nCPUs by hand), since it is using the twapi module to get the number of cpu processors (actually hyperthreads). That number of tasks, an optimal use of the cores/threads on the cpu, gain about a 5x speed up over the sequential method. Each task does 12 or 13 jobs (100 / 8) on a 4 core 8 hyperthread intel chip. When run with 10 threads each task did just 10 jobs, however, the time was 4% longer due to more thread scheduling.

    namespace import tasks::*
    
    package require twapi
    set nCPUs  [twapi::get_processor_count]

    set first 20001
    set last  20100
    set tm [time { ;# one thread last-first+1 jobs
################################################################### sequentially
        package require math
        proc fibonacci_len {n} {
            return [string length [math::fibonacci $n]]
        }
        
        for {set n $first} {$n <= $last } {incr n} {
            incr total1 [fibonacci_len $n]
        }
###################################################################
    }]
    puts "total1= |[comma $total1]| $tm"
 
 
    
    set tm [time { ;# one thread per cpu, last-first+1 jobs
################################################################### using tasks
        proc fibonacci {arr element op} {               ;# trace callback
            incr ::total3 [set ${arr}($element)]        ;# sum up each as they finish
        }
        tgroup fibonacci -tasks -$nCPUs -import {fibonacci_len} { ;# set up 1 task per cpu hyperthread
            package require math
            twait ->  n
            treturn [fibonacci_len $n]
        }
        for {set n $first} {$n <= $last } {incr n} {    ;# run the task last-first+1 times
            tgroup fibonacci -foreach $n
        }
        tgroup fibonacci -wait all
        
        set m -1
        for {set n $first} {$n <= $last } {incr n} {    ;# sum up the answers from the array
            incr total2 $fibonacci(rvar,[incr m])
        }
###################################################################       
    }]
    puts "total2= |[comma $total2]| $tm"    
    puts "total3= |[comma $total3]| $tm"    
    tdump -count
    
#   total1= |419,047| 5426745 microseconds per iteration
#   total2= |419,047| 1163442 microseconds per iteration
#   total3= |419,047| 1163442 microseconds per iteration
#                    (fibonacci0,count)   = |13| 
#                    (fibonacci1,count)   = |13| 
#                    (fibonacci2,count)   = |13| 
#                    (fibonacci3,count)   = |13| 
#                    (fibonacci4,count)   = |12| 
#                    (fibonacci5,count)   = |12| 
#                    (fibonacci6,count)   = |12| 
#                    (fibonacci7,count)   = |12| 

This final example demonstrates that the taskname can be a namespace qualified name, for those averse to using the global namespace. Note also that only 3 jobs ran and so the counts were 1 for 3 tasks and 0 for others.

    namespace import tasks::*
    proc fibonacci_len {n} {
        return [string length [math::fibonacci $n]]
    }
    namespace eval fib {}
    tgroup fib::fibonacci -tasks 8 -import {fibonacci_len} { ;# set up 1 task per cpu hyperthread
        package require math
        twait ->  n
        treturn [fibonacci_len $n]
    }
    tgroup fib::fibonacci -run 10 20 30

    parray fib::fibonacci rvar*
    tdump -count
    
#   fib::fibonacci(rvar,0) = 2
#   fib::fibonacci(rvar,1) = 4
#   fib::fibonacci(rvar,2) = 6
#                 (fib::fibonacci0,count) = |1| 
#                 (fib::fibonacci1,count) = |1| 
#                 (fib::fibonacci2,count) = |1| 
#                 (fib::fibonacci3,count) = |0| 
#                 (fib::fibonacci4,count) = |0| 
#                 (fib::fibonacci5,count) = |0| 
#                 (fib::fibonacci6,count) = |0| 
#                 (fib::fibonacci7,count) = |0| 

Please place any user comments here.