Lars H, 2008-08-27: As the title says, this page is about giving a proof-of-concept implementation of suspend and resume commands. Amongst other things, the full primitives could be used to implement closures, coroutines, and vwaits that don't nest, but what is here is merely about demonstrating that the basic idea is sound. See suspend and resume for a description of the commands.
The first step is to select a unique code for TCL_SUSPEND. I chose to make one from the word suspend as follows:
set TCL_SUSPEND 0 foreach char [split suspend ""] { set TCL_SUSPEND [expr {$TCL_SUSPEND*29+[scan $char %c]-97}] } unset char set TCL_SUSPEND [expr {int($TCL_SUSPEND)}]
(This comes out as an integer near -1.75476e+09.)
The next step is to define the commands themselves, and the data structures they employ:
namespace eval suspendable { variable resumeIndex -1 variable resumeData {} # variable resumeStack {} } proc suspendable::suspend {args} { variable resumeData variable resumeIndex if {$resumeIndex < 0} then { return -code $::TCL_SUSPEND [list $args [info level 0]] } elseif {$resumeIndex==0} then { set resumeIndex -1 return {*}[lindex $resumeData 0] } else { error "This shouldn't happen." } } proc suspendable::resume {continuation args} { lset continuation 0 $args variable resumeIndex variable resumeData # variable resumeStack # if {$resumeIndex>=0} then { # error "Unimplemented -- can't resume something while resuming" # } set resumeData $continuation set resumeIndex [expr {[llength $resumeData]-2}] uplevel 1 [lindex $resumeData end] # That this call is *not* caught is what makes [resume] itself not # show up in continuations if resuspended. }
The resumeStack variable is reserved for future enhancements, to make resume reentrant. That's a fairly unusual need, though.
The resumeData here is as described on suspend and resume: The 0th element is used for communication between suspend and resume, the last element is the command that resume should start the resumption with, and all elements in between record the internal state of some intermediate command in the call stack.
What is tricky about this is that when resuming, we need to jump to specific commands within a sequence of commands, and to specific command substitutions within a larger command — that involves some rather tricky parsing if done with ordinary Tcl syntax. So instead it will be required that any script of the form
eval "$A\n$B\n$C\n…"
is written as
cmdseq $A $B $C …
and any script of the form
{*}$prefix [eval $A] [eval $B] [eval $C] …
is written as
gamma $prefix $A $B $C …
Concretely, instead of
set L foo lappend L [pid] [info hostname]
one would (for now) have to write
cmdseq {set L foo} {gamma {lappend L} {pid} {info hostname}}
A procedure parsetcl::cidic which does these transformations automatically can be found at code is data is code. It will be used by several commands below.
But first cmdseq and gamma. The basic (3-liner) definitions of these can be found at code is data is code, but with support for suspend and resume, these commands come out as the slightly longer:
proc suspendable::cmdseq {args} { variable resumeIndex if {$resumeIndex<0} then { # Initial case set count 0 ; # The internal state } else { # Resuming case variable resumeData set count [lindex $resumeData $resumeIndex] incr resumeIndex -1 } foreach cmd [lrange $args $count end] { set code [catch {uplevel 1 $cmd} res opt] if {$code!=0} then {break} incr count } if {$code != $::TCL_SUSPEND} then { return -options $opt -level [expr {[dict get $opt -level]+1}] $res } else { lset res end $count lappend res [info level 0] return -code $::TCL_SUSPEND $res } } proc suspendable::gamma {prefix args} { variable resumeIndex if {$resumeIndex<0} then { # Initial case set resL {} ; # The internal state } else { # Resuming case variable resumeData set resL [lindex $resumeData $resumeIndex] incr resumeIndex -1 } set code 0 foreach cmd [lrange $args [llength $resL] end] { set code [catch {uplevel 1 $cmd} res opt] if {$code!=0} then {break} lappend resL $res } if {$code==0} then { set code [catch {uplevel 1 $prefix $resL} res opt] } if {$code != $::TCL_SUSPEND} then { return -options $opt -level [expr {[dict get $opt -level]+1}] $res } else { lset res end $resL lappend res [info level 0] return -code $::TCL_SUSPEND $res } }
Basically, in order for the basic control structures (if, while, proc, uplevel, etc.) to support being suspended, they'll have to be reimplemented. Tcl is flexible enough to allow this, but in order to keep one's sanity (when distinguishing original and suspendable commands) it is much easier to give them distinct names (distinct even when removing namespace qualifiers). Therefore the reimplemented commands, which live in the suspendable namespace, will as a rule be titlecased (begin with an upper case letter).
First, there's problem of creating suspendable procedures (needed to demonstrate stackfullness). This needs two commands. First there is proccontext, which is put around the normal procedure body and whose job is to record the local context — currently just the local variable values — upon suspend and restore it upon resume.
proc suspendable::proccontext {cmd} { variable resumeIndex if {$resumeIndex>=0} then { variable resumeData foreach {scalarD arrayD} [lindex $resumeData $resumeIndex] break incr resumeIndex -1 foreach {var value} $scalarD { uplevel 1 [list ::set $var $value] } foreach {var value} $arrayD { uplevel 1 [list ::array set $var $value] } } set code [catch {uplevel 1 $cmd} res opt] if {$code != $::TCL_SUSPEND} then { return -options $opt -level [expr {[dict get $opt -level]+1}] $res } set scalarD {} set arrayD {} foreach var [uplevel 1 {::info locals}] { if {[uplevel 1 [list ::array exists $var]]} then { lappend arrayD $var [uplevel 1 [list ::array get $var]] } else { lappend scalarD $var [uplevel 1 [list ::set $var]] } } lset res end [list $scalarD $arrayD] lappend res [info level -1] return -code $::TCL_SUSPEND $res }
Then there is Proc, which is a proc-lookalike. It transforms the body and wraps it up in a proccontext:
proc suspendable::Proc {name arglist body} { uplevel 1 [list ::proc $name $arglist [ list [namespace which proccontext] [ ::parsetcl::cidic $body ] ]] }
This was the final piece for test4, below.
The trickiest thing about while here is, perhaps unexpectedly, that its condition is an expression. In order to allow suspending from within an expression it would be necessary to parse and transform that just like parsetcl::cidic does with scripts, but I don't have a suitable expression parser at hand (and besides, the syntax of expressions is significantly more complicated than that of the endekalogue), so instead I've decided to make the condition of While a script just like the body. This means
While $condition $body
is like
while {[eval $condition]} $body
(An alternative would be to keep the condition an expression and not support suspending in it, which for all examples below would work just as well, but still strikes me as less convincing.)
Another complication is that parsetcl::cidic isn't smart enough to transform the body and condition of a While command to cmdseq–gamma form, so the While command must do this for itself, at runtime. This isn't as onerous at it may seem however, since we can cache the transformed scripts between runs.
proc suspendable::While {condition body} { variable Cache if {![info exists Cache($condition)]} then { set Cache($condition) [parsetcl::cidic $condition] } if {![info exists Cache($body)]} then { set Cache($body) [parsetcl::cidic $body] } variable resumeIndex if {$resumeIndex<0} then { set state 1 } else { variable resumeData set state [lindex $resumeData $resumeIndex] incr resumeIndex -1 } # State 0: Loop terminated # State 1: About to evaluate condition # State 2: About to evaluate body while {$state} { if {$state==1} then { # Condition case set code [catch [list uplevel 1 $Cache($condition)] res opt] if {$code} then { break } else { set state [expr {$res ? 2 : 0}] } } else { # Body case set code [catch [list uplevel 1 $Cache($body)] res opt] if {$code == 0} then { set state 1 } elseif {$code == $::TCL_SUSPEND} then { break } elseif {$code == 3} then { set state 0 set code 0 } elseif {$code == 4} then { set state 1 } else { set state 0 } } } if {$code == 0} then { return } elseif {$code == $::TCL_SUSPEND} then { lset res end $state lappend res [info level 0] return -code $::TCL_SUSPEND $res } else { return -options $opt -level [expr {[dict get $opt -level]+1}] $res } }
This suffices for running also test5.
First some auxiliary commands for the test:
namespace eval test {namespace path {::suspendable ::tcl::mathop}} foreach letter {A B C D E F} { proc $letter {} "[list puts "I am $letter."]; [list return $letter]" }
The first test is a simple cmdseq, which is suspended and resumed twice:
proc test::test1 {} { list [ catch {cmdseq A {suspend 1} B {suspend 2} C} cont ] $cont [ D ] [ catch {resume $cont 3} cont ] $cont [ E ] [ catch {resume $cont 4} cont ] $cont [ F ] }
Calling join [test::test1] \n returns
-1754758493 1 1 {cmdseq A {suspend 1} B {suspend 2} C} D -1754758493 2 3 {cmdseq A {suspend 1} B {suspend 2} C} E 0 C F
and it prints
I am A. I am D. I am B. I am E. I am C. I am F.
The second test is similar, but uses gamma instead of cmdseq, so that we may see that the suspends return what is given in the resumes.
proc test::test2 {} { list [ catch {gamma list A {suspend 1} B {suspend 2} C} cont ] [ D ] [ catch {resume $cont 3} cont ] [ E ] [ resume $cont 4] }
Calling join [test::test2] \n this prints
I am A. I am D. I am B. I am E. I am C.
and returns
-1754758493 D -1754758493 E A 3 B 4 C
The third test demonstrates passing data from suspend to resume, processing it there, and passing it back. It also mixes cmdseq and gamma:
proc test::test3 {} { gamma list { catch { cmdseq A {gamma puts {suspend 1}} {gamma list B {suspend 2} C} } cont } {set cont} D { catch { resume $cont [expr {-3*[lindex $cont 0 0]}] } cont } {set cont} E { resume $cont [expr {5*[lindex $cont 0 0]}] } }
In more traditional syntax, that catch is for the script
A puts [suspend 1] list [B] [suspend 2] [C]
It prints
I am A. I am D. -3 I am B. I am E. I am C.
and join [test::test3] \n returns
-1754758493 1 {} 1 {cmdseq A {gamma puts {suspend 1}} {gamma list B {suspend 2} C}} D -1754758493 2 B 2 {cmdseq A {gamma puts {suspend 1}} {gamma list B {suspend 2} C}} E B 10 C
This test demonstrates procedure nesting and preservation of local variables.
proc whereami {label} { puts "I am $label." puts " \[info level\] == [info level]" for {set level 0} {$level+[info level]>0} {incr level -1} { puts [format { level %1d: %s} $level [info level $level]] } return $label } namespace eval test { Proc nest1 {x} { whereami A append x c append x [suspend 7] append x [whereami B] } Proc nest2 {x} {nest1 b$x} Proc nest3 {continuation} { set x [whereami C] append x [ resume $continuation [expr {3*[lindex $continuation 0 0]}] ] whereami D return $x } Proc test4 {} { whereami E if {[catch {nest2 a} res] != $::TCL_SUSPEND} then {return $res} nest3 $res } }
The real body of test::nest1 becomes
::suspendable::proccontext {cmdseq {whereami A} {append x c} {gamma {append x} {suspend 7}} {gamma {append x} {whereami B}}}
test::test4 prints
I am E. [info level] == 2 level 0: whereami E level -1: test::test4 I am A. [info level] == 4 level 0: whereami A level -1: nest1 ba level -2: nest2 a level -3: test::test4 I am C. [info level] == 3 level 0: whereami C level -1: nest3 {7 {} 2 {{x bac} {}} ba {{x a} {}} {nest2 a}} level -2: test::test4 I am B. [info level] == 5 level 0: whereami B level -1: nest1 ba level -2: nest2 a level -3: nest3 {7 {} 2 {{x bac} {}} ba {{x a} {}} {nest2 a}} level -4: test::test4 I am D. [info level] == 3 level 0: whereami D level -1: nest3 {7 {} 2 {{x bac} {}} ba {{x a} {}} {nest2 a}} level -2: test::test4
and returns
Cbac21B
This demonstrates suspending a While loop, passing data back and forth, and also running While without suspending it — typical coroutine stuff (but without creating temporary commands).
namespace eval test { Proc test5a {limit} { set res "" set n 0 While {< $n $limit} { lappend res $n [suspend $n] incr n } set res } Proc test5 {limit} { set code [catch {test5a $limit} res] set acc "" While {== $code $::TCL_SUSPEND} { append acc [lindex $res 0 0] set code [catch {resume $res $acc} res] } return $res } }
For example:
% test::test5 6 0 0 1 01 2 012 3 0123 4 01234 5 012345