I'm running simultaneously thoses 2 counters:
package require Thread
set TID1 [thread::create -joinable {
proc DATE {} {clock format [clock scan [exec date]] -format {%m%b%y-%H:%M:%S}}
puts "start T1-: [DATE]"
for {set i 0} {$i < 3} {incr i} {
exec sleep 1
puts "run T1 $i"
}
puts "end T1---: [DATE]"
}]
set TID2 [thread::create -joinable {
proc DATE {} {clock format [clock scan [exec date]] -format {%m%b%y-%H:%M:%S}}
puts "start T2-: [DATE]"
for {set j 0} {$j < 5} {incr j} {
exec sleep 1
puts "run T2 $j"
}
puts "end T2---: [DATE]"
}]
The results are:
% tid0x2aeab8e06700
% tid0x2aeab8c05700
% % % % start T2-: 09Sep21-16:03:27
start T1-: 09Sep21-16:03:27
run T2 0
run T1 0
run T2 1
run T1 1
run T2 2
run T1 2
end T1---: 09Sep21-16:03:30
run T2 3
run T2 4
end T2---: 09Sep21-16:03:32
How to catch the first finished run (which is T2) and to display it ?,
it doesnt work using the following code:
foreach TID {$TID1 $TID2} {
set FID [thread::join $TID]
puts "treads finished => $FID"
}
Remember that Rule 8 says in part
Variable substitution is not performed on words enclosed in braces.
You need something that will do variable substitution when creating the list that foreach iterates over, like
foreach TID [list $TID1 $TID2] {
set FID [thread::join $TID]
puts "thread finished => $FID"
}
Related
Below is the example script written for implementing multi threading for my existing single (main thread) threaded scripts.
# Wrapper proc for executing passed procedure list
proc eval_procs {dut_no procList} {
telnet_dut $dut_no ;# proc to change telnet id to $dut_no
puts "thread id: [thread::id]"
foreach procedure [join [list $procList]] {
eval [join $procedure]
}
}
for {set i 0} {$i <= 1} {incr i} {
lappend jointhreadIds [thread::create]
}
set dutList [list 1 2]
set dutConfigList [list [list "get_port_statistics_mt 1"] [list "c_get_port_statistics_mt 2"]] ;#proc for getting port statistics from switch 1 and 2
for {set i 0} {$i <= 1} {incr i} {
thread::send -async [lindex $jointhreadIds $i] [eval_procs [lindex $dutList $i] [lindex $dutConfigList $i]]
}
Two threads are created for calling the same proc (eval_procs) for each switch. But, when the proc is called using the thread::send -async, this proc is called sequentially for switch1 and later for switch2. After printing thread::id in eval_procs, I found that these procs are running in main thread, which is the reason for sequential run.
Any one to help me here, what mistake I am doing here or any other procedure to follow ?
The below post mentions to define the procs in the script while creating thread, but for me I have so many already developed libraries (procs) which are working fine with main thread. So, I can not move all the libraries under the thread::create.
https://stackoverflow.com/a/32154589/13100284
In general, any custom procedures (or C commands) you create in your master interpreter are not also created in the interpreters of other threads. You can use the ttrace system of the Thread package to do the replication, but you'll need to explicitly load any extra C commands you need. (I prefer to just put everything required in packages and then just package require in every worker thread as required, but that's more complex.)
package require Ttrace
# Procedures created in here get replicated to current and future threads
ttrace::eval {
# Wrapper proc for executing passed procedure list
proc eval_procs {dut_no procList} {
telnet_dut $dut_no ;# proc to change telnet id to $dut_no
puts "thread id: [thread::id]"
foreach procedure [join [list $procList]] {
eval [join $procedure]
}
}
# You probably need to create the other commands here; I don't know your code, but you can source them just fine
}
# Now, the rest of your code as normal.
for {set i 0} {$i <= 1} {incr i} {
lappend jointhreadIds [thread::create]
}
set dutList [list 1 2]
set dutConfigList [list [list "get_port_statistics_mt 1"] [list "c_get_port_statistics_mt 2"]]; #proc for getting port statistics from switch 1 and 2
for {set i 0} {$i <= 1} {incr i} {
thread::send -async [lindex $jointhreadIds $i] [eval_procs [lindex $dutList $i] [lindex $dutConfigList $i]]
}
Note that you probably have other bugs too. And that last command offends me, as it should be using a multi-list foreach and building the command to go to to the other thread with list. Here, I mean it should be something like this:
foreach t_id $joinThreadIds dut_no $dutList dut_config $dutConfigList {
# I've split the next line in two for even more clarity
thread::send -async $t_id [list \
eval_procs $dut_no $dut_config]
}
You are executing eval_procs in the current thread and sending the result to the threads to execute. Since eval_procs returns the empty string, the threads effectively do nothing.
You probably want an additional list in there:
thread::send -async [lindex $jointhreadIds $i] \
[list eval_procs [lindex $dutList $i] [lindex $dutConfigList $i]]
But that will fail, because the eval_procs command is not known in the worker threads. You will have to define that proc in each of the subthreads, rather than in the current one.
So I have the following code -
#!/usr/bin/env tclsh
package require Thread
thread::create {
for {set i 0} {$i < 1000} {incr i} {
puts "hello T1 $i"
}
thread::wait
}
thread::create {
for {set j 0} {$j < 1000} {incr j} {
puts "hello T2 $j"
}
thread::wait
}
It runs, but the first thread run more iterations than the loop count (1000) and the second thread has far fewer iterations than its loop count (1000 ). Can someone point out what's wrong with this code? Many thanks for your help.
My scenario is: using tcl, I am writing a file. then I am sourcing that file and want to keep a watch on log file that the file will generate during its execution. If the size of log file does not change after 2 hours then I need to stop the execution of file and rerun tcl script which will regenerate the file and then source it(generate-source cycle continue till file execution done completely)
Here is psedo code of my scenario :
set root /home/nikhil/
set group {all}
set TopScript [open $root/TopScript.tcl w]
puts $TopScript "[exec perl $root/extract_excel.pl $group] \n}"
Puts $TopScript "set logfilename $root/logfile"
puts $TopScript "source $root/main_1.tcl"
puts $TopScript "source $root/main_2.tcl"
close $TopScript
#Pseudo code for scenario what I want is:
thread::create {
exec tclsh /home/nikhil/TopScript.tcl
thread::wait
}
thread::create {
set flag_for_interupt 0
while{!flag_for_interupt} {
set old_log_size [file size $root/logfile]
after [expr {int(1000* 60* 60* 2)}]
set new_log_size [file size $root/logfile]
if{$old_log_size == $new_log_size} {
puts "I suspect Test is in hung state.... checking again after 2 hours.....\n"
after [expr {int(1000* 60* 60* 2)}]
set $new_log_size [file size $root/logfile]
if{$old_log_size == $new_log_size} {
puts "\n\n Test is in hung state.... log has not updated since last 4 hours........\n\n"
}
########## enter code to interupt main thread and execute again
set flag_for_inturept 1
}
}
}
Tcl does not share (normal) variables between threads. Instead, you need to work by sending messages between threads. A message is just a (usually short) script that you ask the other thread to run (the result of the script can be handled in a few ways, including a synchronous wait or by running the script disconnected). Most of the time, you set up a procedure in the receiving thread to actually do the work.
Let's restructure your waiting thread to operate that way:
set waiter [thread::create {
proc do {filename targetThread returnMessage} {
set delay [expr {int(1000* 60* 60* 2)}]
while true {
# This would be really a do-while loop, but we don't have those
while true {
set old_log_size [file size $filename]
after $delay
set new_log_size [file size $filename]
if {$old_log_size == $new_log_size} break
}
puts "I suspect Test is in hung state... checking again after 2 hours...\n"
after $delay
set new_log_size [file size $filename]
if {$old_log_size == $new_log_size} break
}
puts "\n\n Test is in hung state... log has not updated since last 4 hours...\n\n"
# Send message to main thread to do something about the hung test
thread::send -async $targetThread $returnMessage
}
thread::wait
}]
We'd set that thread actually working like this:
thread::send -async $waiter [list do $root/logfile [thread::current] {set test_hung 1}]
However, the only long operations in there are the calls to after. (Well, unless you're fantastically unlucky with the OS calls to get the log file size.) That means we can convert to using an asynchronous form in the thread, leaving the thread open to being accessed while it is working.
set waiter [thread::create {
proc do {filename targetThread returnMessage} {
set delay [expr {int(1000* 60* 60* 2)}]
set old_log_size [file size $filename]
# Schedule the run of do2 in two hours
after $delay [list do2 $filename $targetThread $returnMessage $delay $filename $old_log_size]
}
proc do2 {filename targetThread returnMessage delay filename old_log_size} {
set new_log_size [file size $filename]
if {$old_log_size == $new_log_size} {
puts "I suspect Test is in hung state... checking again after 2 hours...\n"
# Schedule the run of do3 in another two hours
after $delay [list do3 $filename $targetThread $returnMessage $delay $filename $old_log_size]
} else {
# An update did happen; run ourselves again in two hours to compare to the new size
after $delay [list do2 $filename $targetThread $returnMessage $delay $filename $new_log_size]
}
}
proc do3 {filename targetThread returnMessage delay filename old_log_size} {
set new_log_size [file size $filename]
if {$old_log_size == $new_log_size} {
puts "\n\n Test is in hung state... log has not updated since last 4 hours...\n\n"
# Send message to main thread to do something about the hung test
thread::send -async $targetThread $returnMessage
} else {
# An update did happen; run ourselves again in two hours to compare to the new size
after $delay [list do2 $filename $targetThread $returnMessage $delay $filename $new_log_size]
}
}
thread::wait
}]
So… we've got manageability but lost readability (the API for use is identical). Not bad but not great! (This sort of restructuring is known as conversion to Continuation-Passing Form, and it tends to destroy code readablity.) In 8.6 we can do better because we have coroutines that can yield to the thread's event loop.
set waiter [thread::create {
proc do {filename targetThread returnMessage} {
coroutine Coro[incr ::Coro] doBody $filename $targetThread $returnMessage
}
proc delayForTwoHours {} {
set delay [expr {int(1000* 60* 60* 2)}]
after $delay [info coroutine]
yield
}
proc doBody {filename targetThread returnMessage} {
while true {
while true {
set old_log_size [file size $filename]
delayForTwoHours
set new_log_size [file size $filename]
if {$old_log_size == $new_log_size} break
}
puts "I suspect Test is in hung state... checking again after 2 hours...\n"
delayForTwoHours
set new_log_size [file size $filename]
if {$old_log_size == $new_log_size} break
}
puts "\n\n Test is in hung state... log has not updated since last 4 hours...\n\n"
# Send message to main thread to do something about the hung test
thread::send -async $targetThread $returnMessage
}
thread::wait
}]
That (which still has the same API calling convention) gives manageability yet keeps virtually all the code (especially apart from the short bits in their own procedures) looking the same as the first version I wrote. Under the covers, the coroutine does the rewriting to continuation-passing form, but that's now handled by the Tcl runtime instead of needing to be done explicitly in your code. (Also, Tcl uses explicit coroutine launching, but that in turn means that it can yield across multiple stack levels without the complex yield chains of some other languages.)
I leave it as an exercise to use the second or third version as the basis for a version of the code which doesn't need extra threads at all. Running processes in the background also doesn't need threads; this whole management process can work with just a single (user-visible) thread.
I want to get 200 files using multithread, so I modify a TCL example as below.
But the result is strange, the total number of output files is random, about 135. I was confused that how the thread started change the value of variable $thread.
package require Thread
puts "*** I'm thread [thread::id]"
for {set thread 1} {$thread <= 200} {incr thread} {
set thread_ida $thread
tsv::set app global_thread_num $thread_ida
set id [thread::create -joinable {
puts [ tsv::get app global_thread_num ]
set thread_id [ tsv::get app global_thread_num ]
puts "${thread_id}thread_id"
set outFile "./test/${thread_id}"
append outFile ".tmd"
puts $outFile
set FileOut [open $outFile w+]
puts $FileOut "${thread_id}thread_id"
}] ;# thread::create
puts "*** Started thread $id"
lappend threadIds $id
} ;# for
puts "*** Existing threads: [thread::names]"
# Wait until all other threads are finished
foreach id $threadIds {
thread::join $id
}
puts "*** That's all, folks!"
The problem you've got is that these two lines:
puts [ tsv::get app global_thread_num ]
set thread_id [ tsv::get app global_thread_num ]
are not guaranteed to get the same value at all, nor are they at all likely to synchronise with the setting of the shared variable in the outer loop. Threads in Tcl have a reasonable amount of overhead during launch.
Instead, what you should do is make threads with the description of work inside a procedure and then send a simple message to them with the ID to start the real processing; that's much easier to make work.
package require Thread
puts "*** I'm thread [thread::id]"
for {set thread 1} {$thread <= 200} {incr thread} {
set id [thread::create -joinable {
proc DoWork {thread_id} {
# Only one puts here
puts "${thread_id}thread_id"
set outFile "./test/${thread_id}"
append outFile ".tmd"
puts $outFile
set FileOut [open $outFile w+]
puts $FileOut "${thread_id}thread_id"
# Close the channel, please...
close $FileOut
# Thread done, and since we're using joinable threads it should die now
thread::release
}
thread::wait
}] ;# thread::create
puts "*** Started thread $id"
lappend threadIds $id
# Start the work going, passing over the numeric ID in the "message"
thread::send -async $id [list DoWork $thread]
} ;# for
puts "*** Existing threads: [thread::names]"
# Wait until all other threads are finished
foreach id $threadIds {
thread::join $id
}
puts "*** That's all, folks!"
The key things here are that we create a procedure in each thread (DoWork) to receive the message, get the thread to wait for messages with thread::wait, and then launch the work by sending a message in with thread::send -async. The work destroys the thread with thread::release; it needs to do so explicitly otherwise it'll end up back in thread::wait waiting for the next message.
I'd probably use a thread pool in production code, as they're easier to scale to the hardware available in a particular deployment. The DoWork procedure — without the thread::release — would be defined in the pool's -initcmd option. The thread::send -async would be replaced by posting work to the pool, and you'd be waiting for the jobs instead of the threads.
package require Thread
puts "*** I'm thread [thread::id]"
set pool [tpool::create -maxworkers 48 -initcmd {
proc DoWork {thread_id} {
# Only one puts here
puts "${thread_id}thread_id"
set outFile "./test/${thread_id}"
append outFile ".tmd"
puts $outFile
set FileOut [open $outFile w+]
puts $FileOut "${thread_id}thread_id"
# Close the channel, please...
close $FileOut
}
}]
for {set thread 1} {$thread <= 200} {incr thread} {
lappend work [tpool::post -nowait $pool [list DoWork $thread]]
}
# Wait until all work is finished
foreach id $work {
tpool::wait $pool $id
}
puts "*** That's all, folks!"
tpool::release $pool
Consider the following example, test.pl:
#!/usr/bin/env perl
use 5.10.1;
use warnings;
use strict;
$SIG{'INT'} = sub {print "Caught Ctrl-C - Exit!\n"; exit 1;};
$| = 1; # turn off output line buffering
use Getopt::Long;
my $doSystemLoop = 0;
GetOptions( "dosysloop"=>\$doSystemLoop );
print("$0: doSystemLoop is:$doSystemLoop (use " . (($doSystemLoop)?"system":"Perl") . " loop); starting...\n");
my $i=0;
if (not($doSystemLoop)) { # do Perl loop
while ($i < 1e6) {
print("\tTest value is $i");
$i++;
sleep 1;
print(" ... ");
sleep 1;
print(" ... \n");
}
} else { # do system call loop
while ($i < 1e6) {
system("echo","-ne","\tTest value is $i");
$i++;
system("sleep 1");
system("echo","-ne"," ... ");
system("sleep 1");
system("echo","-e"," ... ");
}
}
So, if I call this program, so it uses a usual Perl loop, everything is as expected:
$ perl test.pl
test.pl: doSystemLoop is:0 (use Perl loop); starting...
Test value is 0 ... ...
Test value is 1 ... ...
Test value is 2 ... ^CCaught Ctrl-C - Exit!
$
... that is, I hit Ctrl-C, program exits instantly.
However, if the while loop's commands consist mostly of system calls, then it becomes nearly impossible to exit with Ctrl-C:
$ perl test.pl --dosysloop
test.pl: doSystemLoop is:1 (use system loop); starting...
Test value is 0 ... ...
Test value is 1 ... ...
Test value is 2 ... ^C ...
Test value is 3 ... ^C ...
Test value is 4 ... ^C ...
Test value is 5^C ... ^C ...
Test value is 6^C ... ^C ...
Test value is 7^C ... ^C ...
Test value is 8^C ... ^C ...
Test value is 9^C ... ^C ...
Test value is 10 ... ^C ...
Test value is 11^C ... ^C ...
Test value is 12^C ... ...
Test value is 13^Z
[1]+ Stopped perl test.pl --dosysloop
$ killall perl
$ fg
perl test.pl --dosysloop
Terminated
$
So in the snippet above, I'm hitting Ctrl-C (the ^C) like mad, and the program ignores me completely :/ Then I cheat by hitting Ctrl-Z (the ^Z), which stops the process and sets in the background; then in the resulting shell I do killall perl, and after that I execute the fg command, which places the Perl job back in the foreground - where it finally terminates due to the killall.
What I would like to have, is run a system loop like this, with the possibility to break out of it/exit it with the usual Ctrl-C. Is this possible to do, and how do I do that?
Perl's signal handling mechanism defers the handling of signals until a safe point. Deferred signals are checked between Opcodes of the perl VM. As system and friends count as a single opcode, signals are only checked once the exec'd command has terminated.
This can be circumvented by forking, and then waiting in a loop for the child process to terminate. The child can also be terminated early via a signal handler.
sub launch_and_wait {
my $wait = 1;
my $child;
local $SIG{CHLD} = sub {
$wait = 0;
};
local $SIG{INT} = sub {
$wait = 0;
kill KILL => $child if defined $child;
};
if ($child = fork()) {
# parent
while ($wait) {
print "zzz\n";
sleep 1;
}
wait; # try to join the child
} else {
# child
exec {$_[0]} #_;
}
}
launch_and_wait sleep => 60;
print "Done\n";
There are probably lots of ways this can go wrong (getting a SIGINT before the child was spawned…). I also omitted any error handling.
Check the exit status of the system() command for any signals. An external command interrupted with SIGINT will get a "2" here:
while () {
system("sleep", 1);
if ($? & 127) {
my $sig = $? & 127;
die "Caught signal INT" if $sig == 2; # you may also abort on other signals if you like
}
}