[Arjen Markus] (26 august 2008) Multithreading may be a popular programming
model, at least for some types of applications, it has a few properties which
make it very difficult to use properly. First and foremost the possibility
to get into shared data - not creating the right locks and releasing them
in the right order. A second problem is that program execution is subject 
to truly random influences: if you run into a particular race condition,
it may be very difficult if not impossible to reproduce it in a debugger.

The code below is a very modest attempt to model the running of a multithreaded
program. It does not do classical synchronisation constructs (yet), such as
mutexes and barriers, but it does detect the incorrect use of shared variables
(if you indicate their use properly with "begin/end" statement).

It also does not transform the program code in a way that is necessary to
make it model the behaviour of true multithreaded programs better: it
should transform ''if {}, for {}'' etc. along these lines:

======
if { $cond } {
    set var "new value""
    set var2 "another value"
}
======

into:
======
set _private_if_line_10 [expr {$cond}]
if { $_private_if_line_10 } { set var "new value" }
if { $_private_if_line_10 } { set var2 "another value" } 
======

That way commands in another thread can be run, possibly causing confusion - 
the sort of thing one wants to detect.

Anyway here is what it does do:

   * Run commands from two or more threads (considered to be procedures in an endless loop)
   * The commands are picked at random from these threads 
   * The random number generator is reseeded with every run, so that the runs are repeatable - you can examine the sequence of commands that led to problems
   * Detect violations of the constraints imposed by "begin/end" construct, that is sections where only one thread can write (and none can read) or where multiple threads can read (but none can write)

For all intents and purposes, it is primarily a proof of concept.

----
A simple example:

======
# sample_read_write.tcl
#     Example of the use of "simulate_threads":
#     We have two threads, one writing the numbers 1 to 10
#     to shared memory, the other picking it up again.
#     The correctness of the program is determined by:
#     - Each thread can do its job (write ten numbers or
#       read ten numbers).
#     - The numbers that are read are the numbers 1 to 10.
#     - No reading takes place while there is a write
#       action
#     The last condition is checked automatically, the
#     first two are program-specific, so we check these
#     manually.
#
#     Note:
#     We use simplified code and the critical sections
#     are started and ended with the begin and end commands.
#

#
# Global parameters
#
set max_steps_per_run 1000
set number_runs       10
set random_seed       [clock clicks] ;# Can be used to restart a particular run
set verbose           0              ;# If true, print the sequence of commands

initial {
    set reader 0 ;# Nothing has been written so far, so the writer must go ahead
    set value_expected 1
    set value_to_store 1
}
thread Reader {
    #
    # Wait until the writer has finished
    #
    sleep {$reader == 0}
    #
    # We can go ahead
    #
    begin read
    set value_read $value_stored
    end read
    set reader 0
    puts "Read: $value_read"
    assert {$value_read == $value_expected}
    incr value_expected
}

thread Writer {
    #
    # Wait until the reader has finished
    #
    sleep {$reader == 1}
    #
    # We can go ahead
    #
    begin write
    set value_stored $value_to_store
    puts "Written: $value_stored"
    end write
    set reader 1
    stop {$value_to_store == 10}
    incr value_to_store
} 
======
And the simulation program itself:

======
# simulate_threads.tcl
#     Program to simulate synchronisation mechanisms in threads:
#     Do we use correct locks? Is starvation possible?
#     By using a controlled environment it is much easier to
#     examine the consequences of the choices we make.
#
#     For an explanation of the program: see the example
#

# global variables --
#
set _simulation_(initial) {}

set max_steps_per_run 100
set number_runs       10
set random_seed       [clock clicks] ;# Can be used to restart a particular run
set verbose           0              ;# If true, print the sequence of commands
set _number_threads_  0
set _error_           0
set _error_count_     0

# initial --
#     Define the initial condition - fragment executed before each run
#
# Arguments:
#     script     Script defining the initial conditions
#
# Result:
#     None
#
# Side effects:
#     Script stored for later use
#
proc initial {script} {
    global _simulation_

    set _simulation_(initial) $script
}

# thread --
#     Define the thread and the code run by the thread
#
# Arguments:
#     name       Name of the thread
#     script     Code that should be run
#
# Result:
#     None
#
# Side effects:
#     Script and name stored for later use
#
proc thread {name script} {
    global _simulation_

    lappend _simulation_(threads)  $name
    set _simulation_($::_number_threads_)   [Stripped $script]
    incr ::_number_threads_
}

# Stripped --
#     Strip empty lines and comments from the code
#
# Arguments:
#     script     Code to be stripped
#
# Result:
#     Stripped code
#
proc Stripped {script} {

    set stripped {}
    foreach line [split $script \n] {
        if { [string trim $line] != "" &&
             ![regexp {^ *#} $line] } {
            lappend stripped $line
        }
    }
    return $stripped
}

# begin, end --
#     Commands to start and stop a critical section
#
# Arguments:
#     type         Type of action within the section (read or write)
#
# Result:
#     None
#
# Side effects:
#     Checks to see if the thread can enter the critical section or not
#
proc begin {type} {

    switch -- $type {
        "read" {
            if { $::_write_in_progress_ } {
                puts "    Error in thread $::_thread_: write in progress!"
                set ::_error_ 1
            } else {
                incr ::read_in_progress_
            }
        }
        "write" {
            if { $::_read_in_progress_ } {
                puts "    Error in thread $::_thread_: read in progress!"
                set ::_error_ 1
            } else {
                incr ::write_in_progress_
            }
        }
    }
}

proc end {type} {

    switch -- $type {
        "read" {
            if { $::_write_in_progress_ } {
                puts "    Error in thread $::_thread_: write in progress!"
                set ::_error_ 1
            } else {
                incr ::read_in_progress_ -1
            }
        }
        "write" {
            if { $::_read_in_progress_ } {
                puts "    Error in thread $::_thread_: read in progress!"
                set ::_error_ 1
            } elseif { $::_write_in_progress_ } {
                puts "    Error in thread $::_thread_: already a write in progress!"
                set ::_error_ 1
            } else {
                incr ::write_in_progress_ -1
            }
        }
    }
}

# assert, stop --
#     Check a condition or stop a thread
#
# Arguments:
#     condition        Condition to be checked
#
proc assert {condition} {
    if { ![uplevel [list expr $condition]]} {
        puts "    Error: assertion failed in thread [lindex $::_simulation_(active_threads) $::_t_] - $condition"
        set ::_error_ 1
    }
}

proc stop {condition} {
    if { [uplevel [list expr $condition]]} {
        puts "    Thread [lindex $::_simulation_(active_threads) $::_t_] stopped - $condition"
        set ::_simulation_(active_threads) [lreplace $::_simulation_(active_threads) $::_t_ $::_t_]
    }
}

# sleep --
#     Sleep if a condition is true
#
# Arguments:
#     condition        Condition to be checked
#
proc sleep {condition} {
    if { [uplevel [list expr $condition]]} {
        set ::_simulation_($::_t_,delta) 0
    } else {
        set ::_simulation_($::_t_,delta) 1
    }
}

# runall --
#     Run all runs
#
# Arguments:
#     None
#
proc runall {} {

    for {set i 0} {$i < $::number_runs} {incr i} {
        puts "Run $i - random seed: $::random_seed"
        expr {srand($::random_seed)}

        set ::_read_in_progress_  0
        set ::_write_in_progress_ 0

        ClearThreadAdmin

        run

        set ::random_seed [clock clicks]
    }

    puts "Number of runs with errors: $::_error_count_"
}

# ClearThreadAdmin --
#     Prepare the thread administration for a new run
#
# Arguments:
#     None
#
# Result:
#     None
#
proc ClearThreadAdmin {} {
    global _simulation_

    for { set i 0 } { $i < $::_number_threads_ } { incr i } {
        set _simulation_($i,cmd)   0
        set _simulation_($i,delta) 1
    }

    set _simulation_(active_threads) $_simulation_(threads)
}

# run --
#     Run the commands in the threads and check for correctness
#
# Arguments:
#     None
#
# Result:
#     None
#
# Side effects:
#     A lot
#
proc run {} {
    global _simulation_

    eval $_simulation_(initial)

    for {set _i_ 0} {$_i_ < $::max_steps_per_run} {incr _i_} {
        #
        # Select which thread to run now
        #
        if { [llength $_simulation_(active_threads)] == 0 } {
            break
        }
        set ::_t_ [expr {int(rand()*[llength $_simulation_(active_threads)])}]

        set cmd [lindex $_simulation_($::_t_) $_simulation_($::_t_,cmd)]

        if { $::verbose } {
#           puts "   [lindex $_simulation_(threads) $::_t_]: $cmd"
            puts "   [lindex $_simulation_(threads) $::_t_]: $cmd -- $_simulation_($::_t_,cmd)"
        }

        eval $cmd

        if { $::_error_ } {
            incr ::_error_count_
            break
        }

        incr _simulation_($::_t_,cmd) $_simulation_($::_t_,delta)
        if { $_simulation_($::_t_,cmd) >= [llength $_simulation_($::_t_)] } {
            set _simulation_($::_t_,cmd) 0
        }
    }

    puts "    Threads alive: $_simulation_(active_threads)"
}

# main --
#     Run the simulation
#
source [lindex $argv 0]

runall 
======

----
!!!!!!
%| [Category Debugging] |%
!!!!!!