This package provides an implementation of "fibers" for Tcl. Fibers, as the term is used in this package, are threads of execution that are co-operatively multitasked and use message passing as their primary means of communication, including channel based I/O.
Fibers are implemented using Tcl coroutines and are compatible with any Tcl application model provided it runs the Tcl event loop.
Erlang programmers may find some similarity to that language's process model. That is not just happenstance.
The package is available from the Mercurial source repository at http://sourceforge.net/projects/tclfiber.
The fiber command creates a new fiber and returns its name. This name is used when sending messages to the fiber or identifying messages received by it. The code to be run is passed as a lambda term in the same format as used by Tcl's [apply] command. The fiber terminates when the script returns.
fiber::fiber logger* {
{chan}
{
while {1} {
fiber::receive msg type {
quit {break}
default {puts $chan $msg(sender):$msg(content)}
}
}
}
}
The above creates a fiber that keeps looping and printing messages until it sees a message of type quit at which point the loop and the fiber terminate.
Fibers execute in co-operative fashion. The run command must be invoked for fibers to be dispatched. The dispatch loop will execute every fiber in turn that is not blocked. The fiber will run until it explicitly gives up control, for example waiting for a message or channel input.
A script running in a fiber will generally follow one of two patterns:
The script running in a fiber may terminate normally or abort via an uncaught exception, or be explicitly terminated with the kill command. The kill command is also delivered as an exception - refer to the command description for the exception format. It is not recommended that this exception be caught to prevent the fiber from dying. Use the mechanisms described in the next section instead.
Aborts via uncaught exceptions are notified by the fiber dispatcher as background errors through the [interp] [bgerror] mechanism.
Fibers can be linked together via the link command such that each is notified of the termination of the other. The notification is either delivered as a Tcl exception or a message. See the link command for details.
Messages passed between fibers are lists with four elements:
By default, the sender element is the name of the fiber if the message is sent by a fiber (note the sender of a message does not have to be a fiber). It can also be explicitly specified. The receiver is the name of the receiving fiber. The message type field may be any application defined string or a system message type. The latter are identified by being enclosed in <>. The content field is the actual data sent by the sender.
A fiber may receive the following system message types:
| <error> | signifies an error |
| <channel_error> | error on a registered channel |
| <line> | content is a line received on a channel in line mode |
| <stream> | content is a data block received on a channel in stream mode |
| <timeout> | a time out occured when waiting for a message |
Internally, the package uses other system message types as well. The <null> type is a special type that is never sent. It has special uses internally.
Messages are sent using the send command which places the message at the end of the receiver's message queue.
Messages can be received with either the get or the receive commands. Both behave similarly and differ mostly in syntax. The former simply retrieves a message while the latter behaves like a built-in switch statement and can run scripts based on message fields.
Both commands allow for selective receiving based on the sender and message type and can also be used with timeouts.
The fiber package also provides a means for channel input to be received in the form of messages. This has several benefits:
Only channel input is converted to messages. Channel output is not provided for and is done in the usual fashion as there is no advantage in using messages for output.
See the channel_register and channel_unregister commands for details.
Other than requiring the event loop to be running, the fiber package does not interact with Tcl or Tk events, for example, widget bindings. If an application wants to process widget interaction through the message queue, it can bind the callback to use send to send a message to the appropriate fiber using any suitable message type and content format.
The fibers command provides introspection capabilities to view the state of fibers including stack traces for suspended fibers.
Generate an error that appears to come from the caller's invocation
| errorcode | value to use for the $::errorCode in generated error |
| msg | (optional, default ) error message. If empty, the last element of errorcode is used |
Generate an error that appears to come from the caller's invocation
proc ::fiber::barf {errorcode {msg {}}} {
# Generate an error that appears to come from the caller's invocation
# errorcode - value to use for the $::errorCode in generated error
# msg - error message. If empty, the last element of $errorcode is used
if {$msg eq ""} {
set msg [lindex $errorcode end]
}
return -level 2 -code error -errorcode $errorcode $msg
}
Register a channel for receiving channel input as messages
| chan | the channel from which data is to be read |
| mode | a list the first element of which must be line or stream followed optionally by autoclose |
| args | any additional options are passed to the channel's configure command |
Register a channel for receiving channel input as messages
Registers a channel with the fiber package. The channel is configured to non-blocking mode (note this affects output also) and data read from the channel is delivered to the fiber as messages.
Registered channels are automatically unregistered when the fiber terminates either normally or because of an exception. Alternatively they can be unregistered through the channel_unregister command.
Messages from registered channels always have the channel name in the sender field of the message. The message type may be <line> and <stream> for data messages, <eof> when the channel reaches end-of-file condition, and <channel_error> in case of channel errors.
The first element of mode determines whether the channel operates in line mode or stream mode:
If the second element of mode is auto_close, the channel is closed when channel_unregister is called.
proc ::fiber::channel_register {chan mode args} {
# Register a channel for receiving channel input as messages
# chan - the channel from which data is to be read
# mode - a list the first element of which must be 'line' or 'stream'
# followed optionally by 'autoclose'
# args - any additional options are passed to the channel's
# configure command
# Registers a channel with the fiber package. The channel is configured
# to non-blocking mode (note this affects output also)
# and data read from the channel is delivered to the fiber
# as messages.
#
# Registered channels are automatically unregistered when
# the fiber terminates either normally or because of an exception.
# Alternatively they can be unregistered through the [channel_unregister]
# command.
#
# Messages from registered channels always have the channel name
# in the sender field of the message. The message type may be '<line>'
# and '<stream>' for data messages, '<eof>' when the channel
# reaches end-of-file condition, and '<channel_error>' in case
# of channel errors.
variable channels
variable fibers
set me [me]
if {[dict exists $channels $chan]} {
barf {FIBER REGISTERED {channel already registered}} "Fiber $me attempted to register channel registered by [dict get $channels $chan fiber]"
}
#ruff
# The first element of $mode determines whether the channel operates
# in line mode or stream mode:
# - in 'line' mode, complete lines are read from the channel
# and delivered to the fiber as messages of type '<line>'
# - in 'stream' mode, data is read from the channel in arbitrary
# sized block and delived as messages of type '<stream>'
switch -exact -- [lindex $mode 0] {
line { set callback [namespace current]::_channel_line_handler }
stream { set callback [namespace current]::_channel_stream_handler }
default {
barf [list FIBER BADARG "Invalid channel mode '[lindex $mode 0]'. Must be 'line' or 'stream'"]
}
}
dict set channels $chan [list fiber $me mode [lindex $mode 0] original_block_mode [chan configure $chan -blocking]]
dict set fibers($me) channels $chan {}; # Value {} not used
#ruff
# If the second element of $mode is 'auto_close', the channel is
# closed when [channel_unregister] is called.
switch [lindex $mode 1] {
"" { dict set channels $chan auto_close 0 }
auto_close { dict set channels $chan auto_close 1 }
default { barf [list FIBER BADARG "Invalid channel mode option '[lindex $mode 1]'"] }
}
if {[catch {
chan configure $chan -blocking 0 {*}$args
chan event $chan readable [list $callback $chan]
} msg options]} {
channel_unregister $chan
return -options $options $msg
}
return
}
Unregister a previously registered channel from its fiber
| chan | the channel to unregister |
Unregister a previously registered channel from its fiber
If the channel was registered with the auto_close option the channel is closed when it is unregistered.
proc ::fiber::channel_unregister {chan} {
# Unregister a previously registered channel from its fiber
# chan - the channel to unregister
variable channels
variable fibers
# Note - do not add a check here for whether we are in a fiber
# as we may be unregistering from a channel handler as well in
# case of errors
if {[dict exists $channels $chan]} {
set chaninfo [dict get $channels $chan]
dict unset fibers([dict get $channels $chan fiber]) channels $chan
dict unset channels $chan; # Get rid our bookeeping first
# The catch is in case app is already closed it behind out backs
catch {
#ruff
# If the channel was registered with the 'auto_close' option
# the channel is closed when it is unregistered.
if {[dict get $chaninfo auto_close]} {
chan close $chan
} else {
chan event $chan readable {}
chan configure $chan -blocking [dict get $chaninfo original_block_mode]
}
}
}
}
Creates a new fiber
| name | name to be assigned to the fiber |
| lambda | a lambda term to be run in the fiber. This is in the same format as used in Tcl [apply] command |
| args | arguments to pass to the lambda |
Returns the name of the fiber.
Creates a new fiber
The new fiber is created as a coroutine and lambda is executed within it with args passed as arguments.
The name assigned to the fiber should consist of only of alphanumeric characters and underscores. If the name ends in a '*', the '*' is replaced by a string that ensures uniqueness of the name.
The script should take care not to block for long periods of time as that will prevent other fibers from running. For example, I/O should be done in asynchronous mode with control yielded to the Tcl event loop. If a synchronous style I/O model is desired for ease of programming, the coroutine package from tcllib may be used which implements a synchronous I/O api on top of a asynchronous model.
A common use for fibers is in message passing mode where the script can receive messages sent to them via the receive command. This command will also yield to other fibers if no messages are currently available for the calling fiber.
The fiber is terminated when the script returns. The return value from the script is discarded. The fiber may also be terminated from other fibers or other parts of the application through the kill command. This is not a hard termination and can be caught by the script. See the kill command for more details.
proc ::fiber::fiber {name lambda args} {
# Creates a new fiber
# name - name to be assigned to the fiber
# lambda - a lambda term to be run in the fiber. This is in the
# same format as used in Tcl [apply] command
# args - arguments to pass to the lambda
#
# The new fiber is created as a coroutine and $lambda is executed
# within it with $args passed as arguments.
#
# The name assigned to the fiber should consist of only of alphanumeric
# characters and underscores. If the name ends in a '*',
# the '*' is replaced by a string that ensures uniqueness of the name.
#
# The script should take care not to block for long periods of time
# as that will prevent other fibers from running. For example, I/O should
# be done in asynchronous mode with control yielded to the Tcl event loop.
# If a synchronous style I/O model is desired for ease of programming,
# the coroutine package from tcllib may be used which
# implements a synchronous I/O api on top of a asynchronous model.
#
# A common use for fibers is in message passing mode where the script
# can receive messages sent to them via the receive command. This command
# will also yield to other fibers if no messages are currently available
# for the calling fiber.
#
# The fiber is terminated when the script returns. The return value
# from the script is discarded. The fiber may also be terminated from
# other fibers or other parts of the application through the kill command.
# This is not a hard termination and can be caught by the script.
# See the kill command for more details.
#
# Returns the name of the fiber.
variable fibers
variable ready
variable ref_ctr
# For time being, until we figure out syntax for distributed fibers
# restrict chars in the name. For some reason this regexp is marginally
# faster than [.:\\/@].
if {[regexp {\.|:|\\|/|@} $name]} {
barf [list FIBER RESERVEDNAME "Invalid fiber name '$name'"]
}
# Only replace the first *, if present, with a counter
if {[string index $name end] eq "*"} {
set new_name "[string range $name 0 end-1][incr ref_ctr]"
while {[info exists fibers($new_name)]} {
set new_name "[string range $name 0 end-1][incr ref_ctr]"
}
set name $new_name
} else {
if {[info exists fibers($name)]} {
barf [list FIBER EXISTS "There is an existing fiber with name '$name'"]
}
}
# TBD - This method is 10% faster but need to check if it will
# accept all valid code. Note putting the _init inside the try
# slows it down.
fiber::_init $name ::fiber::coros::$name
coroutine ::fiber::coros::$name try [list apply $lambda {*}$args] on error {errmsg erropts} {fiber::_set_exit_state $errmsg $erropts} finally "fiber::_cleanup $name"
return $name
}
Returns a dictionary containing information about currently running fibers
| level | (optional, default summary) |
Returns a dictionary containing information about currently running fibers
| level | controls how much information is returned |
The returned dictionary is indexed by the fiber name with the corresponding value itself being a dictionary with the following keys:
| message_count | count of messages pending for the fiber |
| state | the current state of the fiber |
If level is detail, the following additional keys are present:
| stack | a stack trace of the fiber. This will be an empty list if the stack cannot be determined. |
| messages | list of messages on the fiber's queue. |
proc ::fiber::fibers {{level summary}} {
# Returns a dictionary containing information about currently running fibers
# level - controls how much information is returned
#
# The returned dictionary is indexed by the fiber name with the
# corresponding value itself being a dictionary with the following keys:
# message_count - count of messages pending for the fiber
# state - the current state of the fiber
# If $level is 'detail', the following additional keys are present:
# stack - a stack trace of the fiber. This will be an empty
# list if the stack cannot be determined.
# messages - list of messages on the fiber's queue.
variable fibers
# TBD - add kill state and links
set result {}
foreach {name info} [array get fibers] {
set rec [list state [dict get $info state] links [dict get $info links] message_count [llength [dict get $info messages]]]
if {$level eq "detail"} {
lappend rec messages [dict get $info messages]
if {[dict get $info state] eq "WAIT"} {
lappend rec stack [[dict get $info coroutine] stack]
} else {
lappend rec stack {}
}
}
lappend result $name $rec
}
return $result
}
Gets a message from the message queue for the current fiber.
| vmessage | name of a variable in the caller's context where the message is to be stored |
| args | Additional options. |
| -preserve BOOLEAN | If BOOLEAN is false (default), the message is removed from the message queue before it is returned. If true, the retrived message is stays in the queue. |
| -sender SENDER | if specified, only messages sent from the fiber SENDER are examined and returned. |
| -types TYPELIST | if specified, only messages whose type is is one of types in TYPELIST are examined and returned. |
| -wait MS | if specified, the command returns with a value of timeout after MS milliseconds if no message is received in that time. |
Returns success when a message is retrieved, else timeout.
Gets a message from the message queue for the current fiber.
The command retrieves the first matching message from the message queue of the calling fiber. By default, all messages in the queue match. The -sender and -types options may be specified to limit matches to those from a specific sender and of a specific type.
Messages are normally removed from the queue when they are returned. The -preserve option can be used to indicate that the returned message should stay in the queue.
On a successful return, the message is stored in the variable named vmessage in the caller's context. The message is a list consisting of four elements, the sender, the target fiber name, the message type, and the message content. See the send command for more details.
The receive command offers an alternative way to retrieve messages.
proc ::fiber::get {vmessage args} {
# Gets a message from the message queue for the current fiber.
# vmessage - name of a variable in the caller's context where
# the message is to be stored
# -sender SENDER - if specified, only messages sent from the fiber
# SENDER are examined and returned.
# -types TYPELIST - if specified, only messages whose type is
# is one of types in TYPELIST are examined and returned.
# -preserve BOOLEAN - If BOOLEAN is false (default), the message is
# removed from the message queue before it is returned. If true,
# the retrived message is stays in the queue.
# -wait MS - if specified, the command returns with a
# value of 'timeout' after
# MS milliseconds if no message is received in that time.
#
# The command retrieves the first matching message from the message
# queue of the calling fiber. By default, all messages in the queue
# match. The -sender and -types options may be specified to limit
# matches to those from a specific sender and of a specific type.
#
# Messages are normally removed from the queue when they are returned.
# The -preserve option can be used to indicate that the returned message
# should stay in the queue.
#
# On a successful return, the message is stored in the variable named
# $vmessage in the caller's context.
# The message is a list consisting of four elements, the sender,
# the target fiber name, the message type, and the message content.
# See the send command for more details.
#
# The [receive] command offers an alternative way to retrieve messages.
#
# Returns 'success' when a message is retrieved, else 'timeout'.
variable fibers
variable ready
set name [me]
set opts(-preserve) 0
array set opts $args
if {[info exists opts(-wait)]} {
incr opts(-wait) 0; # Error if not integer
if {$opts(-wait)} {
# Need a timer. Note at most one active timer is outstanding.
set timer_start [clock milliseconds]
dict set fibers($name) timeout_timerid [after $opts(-wait) [namespace current]::_receive_timeout $name]
}
}
dict set fibers($name) state WAIT
# If a message is available, return it right away. Otherwise, we will
# yield to allow other fibers to run. The nested structure is because
# we want to yield even when opts(wait) is specified as 0.
if {![_receive $name message opts]} {
# No message or no matching messages. Indicate to dispatcher
# not to call us unless another message arrives for us or timeout
dict unset ready $name
# Do NOT check timer here. We want to yield first
_yield
# Do NOT check timer here as the yield might have resulted in new
# messages. Does not mean the new message will match so we loop.
while {![_receive $name message opts]} {
# No message or no matching messages. Indicate to dispatcher
# not to call us unless another message arrives
dict unset ready $name
# If timer active and timed out, indicate as such
if {[info exists opts(-wait)]} {
# Note because clock resolution is granular, but we do not have
# to worry about it because the after timer always guarantees
# at least the specified delay.
if {$opts(-wait) == 0 ||
([clock milliseconds] - $timer_start) > $opts(-wait)} {
return timeout
}
}
# Keep waiting
_yield
}
}
after cancel [dict get $fibers($name) timeout_timerid]
dict set fibers($name) state RUN
# Indicate to dispatcher not to call us until we are ready for next
# message.
dict unset ready $name
upvar 1 $vmessage result
set result $message
return success
}
Terminates the specified fiber
| receiver | name of the fiber to be terminated |
| args | Additional options. |
| -message MESSAGE | a string passed to the fiber termination handler Defaults to "Kill signal received" |
| -reason REASONCODE | the code for termination. KILL by default. |
| -sender SENDER | identifies invoker. If not specified or empty users the fiber name if called within a fiber |
Returns 1 if a kill was signalled to the fiber and 0 if the signal was not sent because the fiber did not exist or was terminating or already had a kill signal queued.
Terminates the specified fiber
Termination of the fiber is not an immediate hard termination. It is only at the point where a fiber makes a call that can context switch that a Tcl exception is thrown. If uncaught by the fiber, this will result in the fiber being terminated. The thrown exception errorCode has FIBER, EXIT as the first two elements, a kill-specific code as the third element and a reason description as the fourth element.
proc ::fiber::kill {receiver args} {
# Terminates the specified fiber
# receiver - name of the fiber to be terminated
# -sender SENDER - identifies invoker. If not specified or empty
# users the fiber name if called within a fiber
# -message MESSAGE - a string passed to the fiber termination handler
# Defaults to "Kill signal received"
# -reason REASONCODE - the code for termination. 'KILL' by default.
# Termination of the fiber is not an immediate hard termination.
# It is only at the point where a fiber makes a call that can context
# switch that a Tcl exception is thrown. If uncaught by the fiber,
# this will result in the fiber being terminated.
# The thrown exception $errorCode has 'FIBER', 'EXIT'
# as the first two elements, a kill-specific code as the third element
# and a reason description as the fourth element.
#
# Returns '1' if a kill was signalled to the fiber and '0' if
# the signal was not sent because the fiber did not exist or was
# terminating or already had a kill signal queued.
variable fibers
variable wakeup_dispatcher
variable coro_names
if {![info exists fibers($receiver)] ||
[dict exists $fibers($receiver) kill] ||
[dict get $fibers($receiver) state] eq "EXITING"} {
return 0
}
array set opts [list -sender {} -reason KILL -message "$receiver: Kill signal received"]
array set opts $args
# The -errorcode option is undocumented and used internally
# for delivering process termination notifications.
if {![info exists opts(-errorcode)]} {
set opts(-errorcode) [list FIBER EXIT $opts(-reason) $opts(-message)]
}
if {$opts(-sender) eq ""} {
set coro [info coroutine]
if {[info exists coro_names($coro)]} {
set opts(-sender) $coro_names($coro)
}
}
# We send a message if either it is NOT a hard KILL or the target is
# trapping exits.
if {$opts(-reason) ne "KILL" && [dict get $fibers($receiver) trap_exits]} {
_send $opts(-sender) $receiver <exit> [list $opts(-errorcode) $opts(-message)]
} else {
dict set fibers($receiver) kill [list sender $opts(-sender) message $opts(-message) errorcode $opts(-errorcode)]
}
wakeup $receiver
return 1
}
Links fiber target to the calling fiber so each is signalled when the other terminates
| target | name of the fiber to link to |
Links fiber target to the calling fiber so each is signalled when the other terminates
When two fibers are linked, abnormal termination of one results in the other being signalled.
By default, if a fiber ends normally, no notification is delivered to the linked fibers. If a fiber aborts, either through an error or an explicit kill, the fibers linked to it are delivered 'kill' signals. This kill signal results in an Tcl exception being generated whenever the target fiber makes a context switching call. The associated errorcode for the exception is a list with FIBER, EXIT, LINKDEAD as the first three elements followed by a string describing the reason for the signal.
Fibers that do not wish to terminate in response to this signal should not accomplish this by catching the above exception. They should instead use the trap_exits command to indicate that the signal should be delivered as a message instead. In this case, when a linked fiber dies the message type <linkdead> is delivered via the fiber's message queue. The sender field of the message is the id of the exiting fiber and the content field provides the reason for termination.
Note that if signals are not being trapped, when a fiber is terminated because a linked fiber is terminated, other fibers linked to the first fiber are in turn terminated. In other words, the abnormal termination results in cascading of the signal to all fibers that are directly or indirectly linked to the terminating fiber.
The link command establishes a two-way association. See the monitor command for a one-way alternative. If both commands are used, the last one invoked will take effect.
proc ::fiber::link {target} {
# Links fiber $target to the calling fiber so each is signalled
# when the other terminates
# target - name of the fiber to link to
# When two fibers are linked, abnormal termination of one results
# in the other being signalled.
#
# By default,
# if a fiber ends normally, no notification is delivered to the
# linked fibers. If a fiber aborts, either through an error or
# an explicit [kill], the fibers linked to it are delivered 'kill'
# signals. This kill signal results in an Tcl exception being
# generated whenever the target fiber makes a context switching
# call. The associated $errorcode for the exception is a list with
# 'FIBER', 'EXIT', 'LINKDEAD' as the first three elements followed by
# a string describing the reason for the signal.
#
# Fibers that do not wish to terminate in response to this signal
# should not accomplish this by catching the above exception.
# They should instead use the [trap_exits] command to indicate
# that the signal should be delivered as a message
# instead. In this case, when a linked fiber dies the message type
# '<linkdead>' is delivered via the fiber's message queue.
# The 'sender' field of the message is the id of the exiting
# fiber and the 'content' field provides the reason for termination.
#
# Note that if signals are not being trapped, when a fiber is
# terminated because a linked fiber is terminated, other fibers
# linked to the first fiber are in turn terminated. In other words,
# the abnormal termination results in cascading of the signal to
# all fibers that are directly or indirectly linked to the terminating
# fiber.
#
# The [link] command establishes a two-way association. See the
# [monitor] command for a one-way alternative. If both commands
# are used, the last one invoked will take effect.
variable fibers
set me [me]
if {$me eq $target} {
barf [list FIBER BADLINK "Fiber $me attempted to link to itself."]
}
if {![info exists fibers($target)]} {
barf [list FIBER NOTAFIBER "Fiber $target does not exist"]
}
dict set fibers($target) links $me link
dict set fibers($me) links $target link
return
}
Genrates a string that can be used as a unique reference within the lifetime of a node.
| prefix | (optional, default ) a prefix to use for the reference |
Returns the reference
Genrates a string that can be used as a unique reference within the lifetime of a node.
Generated references can be used to uniquely identify and match requests/responses within a node. References can also be used as handles.
The generated reference is unique only during the current process lifetime and within the process. It is NOT a UUID.
proc ::fiber::make_ref {{prefix {}}} {
# Genrates a string that can be used as a unique reference within
# the lifetime of a node.
# prefix - a prefix to use for the reference
# Generated references can be used to uniquely identify and match
# requests/responses within a node. References can also be used
# as handles.
#
# The generated reference is unique only during the current
# process lifetime and within the process. It is NOT a UUID.
#
# Returns the reference
variable ref_ctr
return ${prefix}#[incr ref_ctr]
}
Returns name of calling fiber
Returns name of calling fiber
proc ::fiber::me {} {
# Returns name of calling fiber
variable coro_names
set coro [info coroutine]
if {![info exists coro_names($coro)]} {
barf [list FIBER NOTAFIBER "[lindex [info level 1] 0] called from outside a fiber"]
}
return $coro_names($coro)
}
Starts monitoring the fiber target so that the calling fiber is notified when it is not running.
| target | name of the fiber to monitor |
Returns a reference that is included in the corresponding received messages.
Starts monitoring the fiber target so that the calling fiber is notified when it is not running.
If the fiber target does not exist, or when it terminates, either normally or through an exception, the calling fiber is sent a message. The message type is <monitor>, the sender field of the message is the id of the exiting fiber and the content field is a list of two or three elements. The first element is the reference returned by this command. This allows matching of monitor calls with corresponding messages. The second provides the reason for termination of target. If the fiber terminated normally, the reason will be NORMAL. If it is not currently running, the reason will be NOTAFIBER. Other codes depend on the specific cause of termination. The third element, if present, is a string describing the cause of termination.
The link command provides an alternative mechanism for detecting process exits. However, unlike the link command, monitor establishes a one-way association and always delivers the notification as a message, never a kill signal, irrespective of the setting of trap_exits. Also, unlike link, monitor also notifies normal fiber exits. If both commands link and monitor are used, the last one invoked will take effect.
proc ::fiber::monitor {target} {
# Starts monitoring the fiber $target so that the calling fiber is
# notified when it is not running.
# target - name of the fiber to monitor
# If the fiber $target does not exist, or when it
# terminates, either normally or through an
# exception, the calling fiber is sent a message. The message type is
# '<monitor>', the 'sender' field of the message is the id of the exiting
# fiber and the 'content' field is a list of two or three elements.
# The first element is the reference returned by this command. This
# allows matching of [monitor] calls with corresponding messages.
# The second provides the reason for termination
# of $target. If the fiber terminated normally, the reason will
# be 'NORMAL'. If it is not currently running, the reason will
# be 'NOTAFIBER'. Other codes depend on the specific cause of
# termination. The third element, if present, is a string
# describing the cause of termination.
#
# The [link] command provides an alternative mechanism for detecting
# process exits. However, unlike the [link] command, [monitor]
# establishes a one-way association and always delivers the notification
# as a message, never a kill signal, irrespective of the setting of
# [trap_exits]. Also, unlike [link], [monitor]
# also notifies normal fiber exits. If both commands [link] and [monitor]
# are used, the last one invoked will take effect.
#
# Returns a reference that is included in the corresponding received
# messages.
variable fibers
set ref [make_ref monitor]
set me [me]
if {$me eq $target} {
barf [list FIBER BADLINK "Fiber $me attempted to link to itself."]
}
if {![info exists fibers($target)]} {
_send_monitor_message $target $me $ref [list FIBER EXIT NOTAFIBER "Fiber $target does not exist"] "Fiber $target does not exist"
return $ref
}
dict set fibers($target) links $me $ref
return $ref
}
Runs a script in response to reception of a message.
| messagevar | name of array variable in the caller's context that will receive the sender, receiver, type and content fields from the received message |
| switchargs | expression based on which the appropriate branch of script is executed. |
| script | body in the same format as for a switch command. See the description for details |
| args | Additional options. |
| -preserve BOOLEAN | If BOOLEAN is false (default), the message is removed from the message queue before it is returned. If true, the retrived message is stays in the queue |
| -sender SENDER | if specified, only messages sent from the fiber SENDER are examined |
| -types TYPELIST | if specified, only messages whose type is is one of types in TYPELIST are examined |
| -wait MS | if specified, the command delivers a <timeout> system message to script after MS milliseconds if no message is received in that time. |
Returns the result of evaluation of script
Runs a script in response to reception of a message.
The command retrieves the first matching message from the message queue of the calling fiber. By default, all messages in the queue match. The -sender and -types options may be specified to limit matches to those from a specific sender and of a specific type. Use of these options will not prevent <timeout> messages from being delivered if the -wait option has been specified.
Messages are normally removed from the queue when they are returned. The -preserve option can be used to indicate that the returned message should stay in the queue.
When a message is successfully retrieved, its sender, receiver, type and content fields are stored in the corresponding elements of the messagevar array in the caller's context. The command then evaluates script as the body of a [switch] command in the caller's context. If switchargs is one of the variable names in messagevar, the value of the variable selects the branch of script to be executed. Otherwise, switchargs is interpreted as arguments to the Tcl [switch] command and a branch of script is selected accordingly.
An example of the first form is
while {1} {
fiber::receive msg type {
<line> {... Handle an input line ...}
<eof> {break}
}
}
An example of the second form is
while {1} {
fiber::receive msg {-glob -- $msg(type),$msg(content)} {
<line>,GET* {... Handle a GET command ...}
<line>,PUT* {... Handle a PUT command ...}
<eof>,* {break}
}
}
Note script may receive some system messages as well, in particular <timeout> and <error>.
The get command offers an alternative way to retrieve messages.
proc ::fiber::receive {messagevar switchargs script args} {
# Runs a script in response to reception of a message.
# messagevar - name of array variable in the caller's context that will
# receive the 'sender', 'receiver', 'type' and 'content' fields
# from the received message
# switchargs - expression based on which the appropriate
# branch of $script is executed.
# script - body in the same format as for a switch command. See
# the description for details
# -sender SENDER - if specified, only messages sent from the fiber
# SENDER are examined
# -types TYPELIST - if specified, only messages whose type is
# is one of types in TYPELIST are examined
# -preserve BOOLEAN - If BOOLEAN is false (default), the message is
# removed from the message queue before it is returned. If true,
# the retrived message is stays in the queue
# -wait MS - if specified, the command delivers a '<timeout>' system
# message to $script after MS milliseconds if no message is
# received in that time.
#
# The command retrieves the first matching message from the message
# queue of the calling fiber. By default, all messages in the queue
# match. The -sender and -types options may be specified to limit
# matches to those from a specific sender and of a specific type. Use
# of these options will not prevent '<timeout>' messages from being
# delivered if the -wait option has been specified.
#
# Messages are normally removed from the queue when they are returned.
# The -preserve option can be used to indicate that the returned message
# should stay in the queue.
#
# When a message is successfully retrieved, its 'sender', 'receiver',
# 'type' and 'content' fields are stored
# in the corresponding elements of the $messagevar array in the
# caller's context. The command then evaluates $script as the body
# of a [switch] command in the caller's context. If $switchargs
# is one of the variable names in $messagevar, the value of the
# variable selects the branch of $script to be executed.
# Otherwise, $switchargs is interpreted as arguments to the Tcl
# [switch] command and a branch of $script is selected accordingly.
#
# An example of the first form is
# while {1} {
# fiber::receive msg type {
# <line> {... Handle an input line ...}
# <eof> {break}
# }
# }
#
# An example of the second form is
# while {1} {
# fiber::receive msg {-glob -- $msg(type),$msg(content)} {
# <line>,GET* {... Handle a GET command ...}
# <line>,PUT* {... Handle a PUT command ...}
# <eof>,* {break}
# }
# }
#
# Note $script may receive some system messages as well,
# in particular '<timeout>' and '<error>'.
#
# The [get] command offers an alternative way to retrieve messages.
#
# Returns the result of evaluation of $script
variable fibers
variable ready
set name [me]
set opts(-preserve) 0
array set opts $args
if {[info exists opts(-wait)]} {
incr opts(-wait) 0; # Error if not integer
if {$opts(-wait)} {
# Need a timer. Note at most one active timer is outstanding.
set timer_start [clock milliseconds]
dict set fibers($name) timeout_timerid [after $opts(-wait) [namespace current]::_receive_timeout $name]
}
}
dict set fibers($name) state WAIT
# If a message is available, return it right away. Otherwise, we will
# yield to allow other fibers to run. The nested structure is because
# we want to yield even when opts(wait) is specified as 0.
if {![_receive $name message opts]} {
# No message or no matching messages. Indicate to dispatcher
# not to call us unless another message arrives for us or timeout
dict unset ready $name
# Do NOT check timer here. We want to yield first
_yield
# Do NOT check timer here as the yield might have resulted in new
# messages. Does not mean the new message will match so we loop.
while {![_receive $name message opts]} {
# No message or no matching messages. Indicate to dispatcher
# not to call us unless another message arrives for us or timeout
dict unset ready $name
# If timer active and timed out, indicate as such
if {[info exists opts(-wait)]} {
# Note because clock resolution is granular, but we do not have
# to worry about it because the after timer always guarantees
# at least the specified delay.
if {$opts(-wait) == 0 ||
([clock milliseconds] - $timer_start) >= $opts(-wait)} {
set message [list $name $name <timeout> "Receive timed out"]
break
}
}
# Keep waiting
_yield
}
}
after cancel [dict get $fibers($name) timeout_timerid]
dict set fibers($name) state RUN
# Indicate to dispatcher not to call us until we are ready for next
# message.
dict unset ready $name
# The tailcall try usage are attempts to get byte compilation.
# Not sure it actually helps
# The joins are needed to remove newlines etc. from $scriptexpr
# TBD - must be a better way
upvar 1 $messagevar msg
lassign $message msg(sender) msg(receiver) msg(type) msg(content)
if {$switchargs in {type sender content receiver}} {
tailcall try "switch {$msg($switchargs)} [list $script]"
} else {
tailcall try "switch [join $switchargs] [list $script]"
}
}
Run fibers in round robin fashion, dispatching messages
| runmode | Controls execution life time of the command |
Returns the current number of fibers.
Run fibers in round robin fashion, dispatching messages
The runs every fiber in turn, notifying them of pending messages if any. The fibers must be in WAIT state for notifications to be delivered, for example, blocked on a get or receive command.
To protect against reentrancy issues, the command reschedules itself to run from the Tcl event loop if called from within a fiber.
When runmode is master, fiber runtime errors are reported in the background using the [bgerror] mechanism. If runmode is slave, an exception is generated.
The command will continue running each fiber in turn until all fibers are blocked. The operation of the command in that state depends on the runmode argument. If runmode is master, the command will then block, yielding to the event loop until some other program component sends a message to one of the fibers. If runmode is slave, the command returns when all fibers are blocked. It is the caller's responsibility to invoke the command again at the appropriate time.
In all cases, the command returns if there are no fibers in the system.
proc ::fiber::run {runmode} {
# Run fibers in round robin fashion, dispatching messages
# runmode - Controls execution life time of the command
#
# The runs every fiber in turn, notifying them of pending messages if any.
# The fibers must be in WAIT state for notifications to be delivered,
# for example, blocked on a [get] or [receive] command.
#
# Returns the current number of fibers.
variable fibers
variable ready
variable wakeup_dispatcher
variable coro_names
if {$runmode ni {master slave}} {
barf [list FIBER BADARG "Invalid run mode '$runmode'. Must be 'slave' or 'master'"]
}
if {[info exists wakeup_dispatcher]} {
return; # Dispatcher is already running somewhere on stack
}
if {[info exists coro_names([info coroutine])]} {
#ruff
# To protect against reentrancy issues, the command reschedules itself
# to run from the Tcl event loop if called from within a fiber.
after 0 [namespace current]::run $runmode
}
set wakeup_dispatcher 0
try {
while {1} {
while {[dict size $ready]} {
foreach name [dict keys $ready] {
# NOTE: in the current implementation, the cleanup
# for the fiber catches errors. If there are linked
# processes, they are notified and the error
# is no propagated here. If there are no linked
# processes, the error is propagated so we need
# to handle it.
if {[catch {
if {[dict exists $fibers($name) kill]} {
[dict get $fibers($name) coroutine] kill
} else {
[dict get $fibers($name) coroutine]
}
} msg options]} {
#ruff
# When $runmode is 'master', fiber runtime errors
# are reported in the background using the [bgerror]
# mechanism. If $runmode is 'slave', an exception
# is generated.
if {$runmode eq "master"} {
catch {[interp bgerror {}] $msg $options}
} else {
return -options $options $msg
}
}
}
}
#ruff
# The command will continue running each fiber in turn until
# all fibers are blocked. The operation of the command in
# that state depends on the $runmode argument. If $runmode is
# 'master', the command will then block, yielding to the event loop
# until some other program component sends a message to one of the
# fibers. If $runmode is 'slave', the command returns when
# all fibers are blocked. It is the caller's responsibility to
# invoke the command again at the appropriate time.
#
# In all cases, the command returns if
# there are no fibers in the system.
set nfibers [array size fibers]
if {$nfibers == 0 || $runmode ne "master"} {
return $nfibers
}
vwait [namespace current]::wakeup_dispatcher
}
} finally {
unset wakeup_dispatcher
}
}
Sends a message to a fiber
| receiver | name of the fiber to which the message is to be sent |
| content | the content of the message |
| args | Additional options. |
| -sender SENDER | specifies the sender of the message |
| -type MSGTYPE | specifies the type of the message |
Returns 1 if the message was queued successfully and 0 otherwise.
Sends a message to a fiber
The command places a message on the end of the message queue for the specified fiber. It is not delivered synchronously but is rather is read by the fiber when it invokes the receive command.
A message is a list of four elements: the name of the sender, the name of the intended receiver, a message type and the content.
The message type defaults to application if the -type option is not specified. MSGTYPE may be any string denoting an application specific type except strings enclosed in <> which are reserved for internal use although this is not enforced.
If the -sender option is not specified, the sender is the name of the calling fiber or the empty string if not called from a fiber.
proc ::fiber::send {receiver content args} {
# Sends a message to a fiber
# receiver - name of the fiber to which the message is to be sent
# content - the content of the message
# -sender SENDER - specifies the sender of the message
# -type MSGTYPE - specifies the type of the message
#
# The command places a message on the end of the message queue for
# the specified fiber. It is not delivered synchronously but is rather
# is read by the fiber when it invokes the receive command.
#
# A message is a list of four elements: the name of the sender, the name of
# the intended receiver, a message type and the content.
#
# Returns 1 if the message was queued successfully and 0 otherwise.
variable fibers
variable wakeup_dispatcher
variable coro_names
if {![info exists fibers($receiver)] || [dict get $fibers($receiver) state] eq "EXITING"} {
return 0; # Return value indicates queueing, not delivery
}
#ruff
# The message type defaults to 'application' if the -type option
# is not specified. MSGTYPE may be any string denoting an
# application specific type except strings enclosed in '<>' which
# are reserved for internal use although this is not enforced.
#
set type application
if {[dict size $args]} {
if {[dict exists $args -sender]} {
set from [dict get $args -sender]
}
if {[dict exists $args -type]} {
set type [dict get $args -type]
}
if {$type eq "<null>"} {
barf [list FIBER BADARG "Message type '<null>' is not allowed."]
}
}
#ruff
# If the -sender option is not specified, the sender is the name of the
# calling fiber or the empty string if not called from a fiber.
if {![info exists from]} {
if {[info exists coro_names([info coroutine])]} {
set from $coro_names([info coroutine])
} else {
set from ""
}
}
_send $from $receiver $type $content
return 1
}
Suspends the calling fiber for a specified time
| ms | (optional, default 0) number of milliseconds to suspend |
Suspends the calling fiber for a specified time
This command is used to suspend the calling fiber for a specific amount of time while permitting other code to run. Even if ms is 0, the command will return only after giving other fibers a chance to execute.
proc ::fiber::sleep {{ms 0}} {
# Suspends the calling fiber for a specified time
# ms - number of milliseconds to suspend
# This command is used to suspend the calling fiber for a specific amount
# of time while permitting other code to run. Even if $ms is '0', the
# command will return only after giving other fibers a chance to execute.
# Message type <null> should never be sent so we will timeout
receive {} type {
default {}
} -wait $ms -from [me] -type <null>
return
}
Traps signalled exits and converts them to messages
| trap | (optional, default 1) if true, kill signals are converted to messages. If false they are delivered as Tcl exceptions |
Traps signalled exits and converts them to messages
See the link command for more information.
proc ::fiber::trap_exits {{trap 1}} {
# Traps signalled exits and converts them to messages
# trap - if true, kill signals are converted to messages. If false
# they are delivered as Tcl exceptions
# See the [link] command for more information.
variable fibers
set me [me]
dict set fibers($me) trap_exits [_boolean $trap]
return
}
Define variables local to a fiber
| args | list of variable names |
Define variables local to a fiber
The given variable names are mapped in the caller's context to fiber-specific variables of the same name.
proc ::fiber::vars {args} {
# Define variables local to a fiber
# args - list of variable names
#
# The given variable names are mapped in the caller's context
# to fiber-specific variables of the same name.
# If we are being called from the level 1 context, no need
# to do anything. The variables are in that context and in
# fact doing an upvar would raise an error
if {[info level] > 2} {
set vars {}
foreach n $args {lappend vars $n $n}
tailcall upvar #1 {*}$vars
}
}
Wakes up the specified fiber if it is currently suspended
| name |
Wakes up the specified fiber if it is currently suspended
It is an error if the fiber does not exist
proc ::fiber::wakeup {name} {
# Wakes up the specified fiber if it is currently suspended
#
# It is an error if the fiber does not exist
variable wakeup_dispatcher
variable ready
variable fibers
# If the fiber is not in a WAIT state, do not mark it as ready
# else the run dispatcher will call it when it might have actually
# done a yield to somewhere else
if {[dict get $fibers($name) state] ne "WAIT"} {
return
}
dict set ready $name 1
if {[info exists wakeup_dispatcher]} {
set wakeup_dispatcher 1; # Bring dispatcher out of vwait
} else {
# If we are not in a coroutine, run it ourselves. Otherwise schedule it
if {[info coroutine] eq ""} {
fiber::run slave
} else {
after 0 fiber::run slave
}
}
return
}