Tasks

Difference between version 65 and 140 - Previous - Next
[ET] 2021-09-29 - (1.5)
[ET] 2021-10-16 - (1.6)
**** Introduction to Tcl Tasks ****
**** '''Introduction to Tcl Tasks''' ****
Tasks are an extension to tcl threads that are designed for ease of use. They implement the familiar call/return framework (or a client/server). Tasks are threads that are called with a standard proc arglist either synchronously, or asynchronously with a corresponding wait (like a join, but the thread need not exit).
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 '''synchronously '''or '''asynchronously '''.
===tcl
'''Task''' taskname ?options? ?list of imports? {
'''twait''' - > varname1 varname2 ...
# do something with the args $varname1 $varname2 ...
'''treturn''' result
}
A task is created using the '''Task''' procedure, as shown below. The '''taskname''' is used as a thread identifier, and becomes the name of a variable to be assigned the thread id. The tasks::* procedures and optionally additional proc's defined in the program can be imported (loaded) into the thread's interpreter. The script argument, if used only once, can be supplied directly in braces, or be a variable - useful when multiple tasks run the same script, such as helpers that provide for multiple servers running concurrently.
The script will typically contain 2 task procedures, '''twait ''' and '''treturn'''. Here is the typical layout of a Task.
'''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 easily creating a set of tasks to run in parallel with multiple cpu cores.
<<discussion>>tgroup example
This sample computes the number of digits in 4 Fibonacci numbers, each in it's own thread. If there are enough cpu cores (or hyperthreads) this will run (much) faster than if computed sequentially.
======
Task taskname ?options? ?list of imports? {
twait -> varname1 varname2 ...
# do something with the args $varname1 $varname2 ...
treturn result
namespace import tasks::*
set script { package require math
twait -> num
treturn "$num -> [string length [math::fibonacci $num]]"
}
======
set nums {200000 200010 200020 200030 }
'''twait''' waits until a job is requested using the '''tcall''' command which like calling a procedure, can optionally supply input parameters. twait takes a variable argument list. The first argument receives the full arglist similar to the args argument in a proc call (or argv to a process). The remaining variable names, if any, are then lassign-ed the values of the first argument. '''treturn''' returns a value to a calling task (or the main thread).
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
Note: '''treturn''' does not end the task, after the treturn, data is '''returned''' to the caller, and the code continues on. It might loop back to another twait, or go into some other loop, as in the example producer consumer code. The next twait can have different arguments.
# results:
# fib(rvar,0) = 200000 -> 41798
# fib(rvar,1) = 200010 -> 41800
# fib(rvar,2) = 200020 -> 41802
# fib(rvar,3) = 200030 -> 41804
The '''->''' used here is just a variable name and as the first argument receives the full arglist. This name was chosen for its syntactic expressiveness, when the full args are not of interest, and only the individual variables that follow are used. Another suitable choice might be '''argv''' or even '''args'''. All the arguments of twait are optional.
Synchronous calls mimic a procedure call, but the procedure in this case is running concurrently in its own thread, so does not affect the event queue of the caller thread. This returns, usually with a value, after the task issues it's treturn statement.
======
<<enddiscussion>>
----
tcall $taskname resultvar arg1 arg2 ...
<<discussion>>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.
======
Asynchronous calls mimic a concurrent procedure or function call, that also runs in it's own thread.
======
'''treturn''' returns a value to a calling task (or the main thread).
tcall $taskname -async resultvar arg1 arg2 ...
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.
===tcl
'''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.
===tcl
'''tcall''' $taskname -async resultvar arg1 arg2 ...
# ... do something else ...
tvwait resultvar
'''tvwait''' resultvar
======
'''tcall''' uses the taskname as a variable (Task sets this variable to the thread id). The taskname is also used to create tsv shared variables that the Task uses, such as the mutex and queue etc. tcall includes a variable name to receive the result, and it is also used with an async call to signal the caller that the job is done. The '''tvwait''' is a vwait but also checks for the variable's existence. This is similar to thread::send with a variable. If the task completes first '''tvwait''' will return immediately.
===
'''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.
**** Tasks can process one job or loop back for more work ****
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'''.
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 ****
<<enddiscussion>>
**** '''Task Properties''' ****
<<discussion>>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, see the 2 examples. Helper tasks are created with a simple taskname convention of '''worker/boss'''. All work is sent to the boss.
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 .... ======
**** Tasks are compatible with other Thread functions ****
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.
Tasks were designed for the simpler cases, and with the beginner in mind. More complex situations like producer consumer problems with their own queues can still be done with tasks, but will need to do their own queue-ing. See the example below.
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''' ****
A task can be a one shot, that is initialized by the arglist, and then does a thread::wait. In this case, tasks can help with some of the simple debugging and error handling, plus the importing of procedures written outside of threads. They come in handy when a proc already exists to do some job, and the programmer wants to quickly transform it into a concurrent procedure with 1 or more threads to divide up the work.
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.
Tasks are a handy tool to simplify some of the tricky code needed for threads, especially with shared job processing.
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.
**** Tasks are compatible with the event queue ****
- - -
During the wait for work, the event queue will be 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. However, once the thread receives some work to do, it's just like a normal single threaded tcl program that does some heavy compute. In this case, updates can be sprinkled in long running code loops just as in a normal single threaded program. Or, a task can create another task, and so on. However, tasks calling itself are unlikely to work without a deadlock.
<<enddiscussion>>
**** Tasks include puts like debugging and an error handler ****
**** '''Task Procedures''' ****
Tasks comes with some utility procedures for debugging such as a puts like statement that creates a Tk text widget (one per task) and a built in error catcher that will display a tk_messageBox. A task can create a gui, which is one of the unique selling points of tcl threads over the competition. 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.
<<discussion>>Primary 6
----
**** Create a Task ****
* '''Task taskname ?-once? ?-import ? ?import list? script '''
**** Try out the examples ****
'''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''' 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 written as '''-import_tasks''' which is possibly less confusing, since this option does not have a parameter following it, rather, the next arg is the import list, which is not a part of this option, although it might appear to be so.
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 have an initializer and an explicit while loop around the script, like so:
===tcl
package require math ;# and other init stuff here
while 1 {
... the actual 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.
- - -
<<enddiscussion>>
<<discussion>>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.
----
**** 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.
- - -
<<enddiscussion>>
----
**** '''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 for more info.
----
Open the code discussion which has a large comment block with more details.
<<discussion>>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 is created.
# 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
# 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}
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]
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
puts "\n------ Task(s) dump -----------------------------------------"
puts "tsv::names = |[tsv::names *]|"
# puts "tsv::tvar = |[tsv::array names tvar *]|"
puts "tsv::tids = |[tsv::array names tids *]|"
puts "---------------------------------------------------------------"
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]]
puts "tid/names = |$tvarnames|"
puts "---------------------------------------------------------------"
set io stdout
if { $::tcl_platform(platform) eq "windows" && 0} {
set io stderr
if { $all } {
putz "tid/names = |$tvarnames|"
putz "---------------------------------------------------------------"
} foreach {var val} [lsort -dictionary -stride 2 -index 1 $tvarnames ] {
puts $io "[format %-10s $val] tid: $var exists: [thread::exists $var]"
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 { [string match *${pat}* $tname] } {
puts " [format %-20s ($tname)] = |[string range $val 0 $max]| "
if { [regexp .*${pat}.* $tname[string range $val 0 $max]] } {
putz " [format %-20s ($tname)] = |[string range $val 0 $max]| "
} } }
puts "---------------------------------------------------------------"
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" } {
} 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"
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] 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 {
set found 0
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
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 " "
}
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"
# 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"
}
}
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 {! [thread::exists $taskid] } {
error "Thread does not exist"
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 $works]| work= |$work| parentid= $pid globalvar= $gvar " yellowonblack debug}
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 "i= |$i| item= |$item| data= |$data| " normal debug}
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 tname and uses it for a
# group of tasks. The names will be tname0, tname1, .... tname(N-1)
# where tname0 is the boss and the rest will be boss/helper with
# names like tname1/tname0, tname2/tname0, ... tname(N-1)/tname0
# 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
#
# tname is also the name of a global array that will be
# 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
#
# where n is the number 0..N-1 for N tasks
#
# 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
# tasks one only, the number of tasks or jobs depending on -call or -foreach
#
# The tasks are all linked to the first one, tname0, and they may exit, but
# tname0 should not exit. If the script is the same for each, they can tell
# 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.
#
# always set to the task's name and will have a number at the end.
#
# usage: #
# tgroup group -tasks N .... args to a task beginning with the options
# tgroup group -call {arglist 1} {arglist 2} ...
# tgroup group -wait all
# 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 {tname option args} {
proc tgroup {gname option args} {
if { $option eq "-tasks" } {
uplevel array unset $tname
upvar 1 $tname name
uplevel array unset $gname
upvar 1 $gname name
set argss [lassign $args num]
# puts "num=$num argss= |$argss| "
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
# uplevel [list set $tname\(tasks2\) $num ]
set name(threads) $num
for {set n 0} {$n < $num } {incr n} { if { $n == 0 } {
set t ${tname}0
set t ${gname}0
} else {
set t ${tname}${n}/${tname}0
set t ${gname}${n}/${gname}0
}
set tid [uplevel [list Task $t {*}$argss]]
# puts "n= |$n| tid= |$tid| "
# uplevel [list set $tname\(id,$n\) $tid ]
set tid [uplevel [list tasks::Task $t {*}$argss]]
set name(tid,$n) $tid }
} elseif { $option eq "-call" } {
upvar 1 $tname name
} 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]
# puts "numarglists= |$numarglists| numtasks= |$numtasks| "
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 $tname : too many arglists, $numarglists with only $numtasks tasks"
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 ]
# puts "job= |$job| index= |$index| numarglists= |$numarglists| numtasks= |$numtasks| args($index)= |$theargs| "
set name(args,$job) $theargs
set tid [tset ${tname}0 tid]
set tid [tset ${gname}0 tid]
set tn [tname $tid]
# puts stderr "calling: tid= |$tid| tn= |$tn| job = |$job| resvar = |::${tname}(rvar,$job)| args= |{*}$theargs|"
set c [uplevel [list tcall $tid -async ::${tname}(rvar,$job) {*}$theargs]]
# wait 2200
set c [uplevel [list tasks::tcall $tid -async ::${gname}(rvar,$job) {*}$theargs]]
if { $name(trace) } {
if {! [info exist ::${tname}(rvar,$job)] } {
# puts "set trace on ::${tname}(rvar,$job) to $tname" ;update
trace add variable ::${tname}(rvar,$job) write $tname
# puts "trace info = [trace info variable ::${tname}(rvar,$job)]"
if {! [info exist ::${gname}(rvar,$job)] } {
trace add variable ::${gname}(rvar,$job) write $gname
} else {
# puts "call $tname direct"
$tname ::$tname rvar,$job Write
$gname ::$gname rvar,$job Write
} }
# vwait ffff
if { $c != 1 } { error "error calling tgroup -call on job $job" } incr index }
} elseif { $option eq "-wait" } {
upvar 1 $tname name
} 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} {
# puts "-wait on job= |$job| numtasks= |$numtasks| rvar= ::${tname}(rvar,$job)"
tvwait ::${tname}(rvar,$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, or -wait"
error "Invalid option to tgroup: $option, must be -tasks, -call, -foreach, or -wait"
} } namespace export {*}[info proc] } # end of tasks namespace eval
# this was the polling method first used, kept here for reference only
#proc tvwait {var {tid {}}} { ;# wait till an async Task call, with Task id tid, completes and sets the variable - polling method
# if { [string range $var 0 1] ne "::" } {
# set var "::$var"
# }
#
# while {1 } {
# incr n
# if { ![info exist $var] } {
# if {$tid != {} && ![thread::exists $tid] } {
# 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
# }
# wait 1
# continue
# }
# puts "$n times wait"
# return 1
# }
#}
====== <<enddiscussion>> <<discussion>>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 ====== <<enddiscussion>> <<discussion>>Example using trace **** Example with 8 Parallel Fibonacci computations **** This example, derived from '''Ashok's''' web page on '''Promises''' [https://www.magicsplat.com/blog/promises-by-example/index.html], 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. A trace callback would send a lower case '''write''' whereas we call it with '''Write''' to distinguish between them, although it would appear that is not needed since trace added some colons.
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 ====== <<enddiscussion>> <<discussion>>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.
A word on the '''syntactic sugar''' (something added to the program code that serves no computational use, but just looks pretty). In several places, a <- or -> is used for variable names where the value is not needed. This trick is found in the regexp manual for a value needing a placeholder argument.
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 -> zz number ;# wait for a call and the argument
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 ;# syntactic sugar zz ignored in task
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 # --------------------------------------------------------------- # ====== <<enddiscussion>> <<discussion>>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 ====== <<enddiscussion>> <<discussion>>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| > ====== <<enddiscussion>> <<discussion>>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| --------------------------------------------------------------- ====== <<enddiscussion>> <<discussion>>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 ====== <<enddiscussion>> <<discussion>>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 '''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:
This example starts 4 tasks/threads that compute the sum of their arglist's plus a busy wait we can monitor for cpu time. 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. The arguments that follow this option are identical to those in the Task procedure which follow the taskname argument.
===
to start a new group
The '''-call''' option calls the tasks 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. They are all run -async. If the trace flag was set, a trace is put on each one, using the group name as a callback procedure. See the 3rd example below that uses the trace option.
tgroup groupname '''-tasks''' ?-?N .... args to a task beginning with the options
The '''-wait all''' option will wait for all the work to complete. There is an option in the works, '''-wait one''' but it is a TBD.
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.
===tcl
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.
===tcl
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
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 -call {1 2 3} {4 5 6} {7 8 9} ;# when fewer arglists, repeat at front
tgroup summer -wait all
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(args,3) = 1 2 3
summer(rvar,0) = 6 summer(rvar,1) = 15 summer(rvar,2) = 24
summer(rvar,3) = 6
======
The above example is handy when you have N jobs and want to run exactly N tasks.
However, suppose you have more jobs than tasks and you only want to run 1 task per cpu core (or cpu thread with hyperthreading).
In this example, we use the tgroup -tasks 4 command to setup 4 tasks. Then we tcall each of the 10 jobs -async so they will be placed on the single queue. We tcall the '''boss''' (first one) task, which was named summer0 and so is used as $summer0. Then we wait on all of them.
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} {
xwait 2000 ;# simulate 2 seconds of heavy compute
return [tcl::mathop::+ {*}$args] ;# use the multi arg add operator
}
tgroup summer -tasks 4 -import {sum} { ;# generate 1 per core
twait argv
treturn [sum {*}$argv]
}
set njobs 10
for {set m 0} {$m < $njobs} {incr m} {
tcall $summer0 -async rvar($m) $m 1 2 3 ;# add up m + 1 + 2 +3, result to rvar($m)
}
for {set m 0} {$m < $njobs} {incr m} {
tvwait rvar($m)
}
parray rvar
======
And here are the results, with the index to rvar being the value computed (m + 6 for each m 0..9) and a trimmed tdump showing the count.
======
rvar(0) = 6
rvar(1) = 7
rvar(2) = 8
rvar(3) = 9
rvar(4) = 10
rvar(5) = 11
rvar(6) = 12
rvar(7) = 13
rvar(8) = 14
rvar(9) = 15
------ Task(s) dump -----------------------------------------
mainthread tid: tid00002B14 exists: 1
summer0 tid: tid00002DE8 exists: 1
(summer0,count) = |3|
summer1 tid: tid000014B8 exists: 1
(summer1,count) = |3|
summer2 tid: tid00002FF4 exists: 1
(summer2,count) = |2|
summer3 tid: tid000023C8 exists: 1
(summer3,count) = |2|
---------------------------------------------------------------
======
Here's an example where we use the trace, by using a -N for 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|
======
<<enddiscussion>> <<discussion>> Please place any user comments here. <<enddiscussion>> <<categories>> Concept | Threads