Version 5 of foreach async

Updated 2016-04-04 02:22:24 by pooryorick

NEM 2004-06-24: As a related item, here is a little toy proc for making a foreach loop run asynchronously. Needs work to be really useful, and could benefit from some form of lambda, but somebody might find it useful as a version of the pattern used above:

proc async-foreach {var list body} {
    proc async-body [list $var args] [string map [list %BODY $body] {
        %BODY
        if {[llength $args] > 0} { after idle [linsert $args 0 async-body] }
    }]
    after idle [linsert $list 0 async-body]
}

And a usage example:

async-foreach item {1 2 3 4 5} { puts "Item = $item" }
vwait forever ;# ->
# item = 1
# item = 2
# item = 3
# item = 4
# item = 5

The above implementation has the following limitations:

  • Only one loop can be active at any one time (hence the need for lambda or a unique-name scheme)
  • Only one variable and one list to iterate over

Extensions are possible, but that needs some work

Lars H: It is perfectly possible to make do without lambdas and unique-name schemes.

proc async-foreach {vars list body {final ""}} {
    if {[llength $vars] && [llength $list]} then {
        foreach $vars $list {break}
        set list [lrange $list [llength $vars] end]
        if 1 then $body
        after idle [list async-foreach $vars $list $body $final]
    } else $final
}

(The if 1 then $body rather than eval $body here is to have $body byte-compiled.) This form adds a second body, $final, which is evaluated after the last iteration. It also supports multiple loop variables. Example:

% async-foreach {item item2} {1 2 3 4 5} { puts "Items = ($item,$item2)" } {puts "That's all, folks!"}
Items = (1,2)
after#28
% Items = (3,4)
Items = (5,)
That's all, folks!

Note the slight asynchronicity that the return value from the command (after#28, after) and the following prompt are printed by the command loop between the first and second iteration of the asynch-foreach.

One problem with the above procedure is that you mustn't use the variable names vars, list, body, or final in the body. In a production environment, they should rather be given names like __vars, __list, __body, and __final to avoid unintended overwritings.

Lars H 2008-08-05:

Revisiting this page, I came up with the following braintwister of an implementation that permits arbitrary variable names by having done all substitutions of the special variables vars, list, body, and final before the foreach:

proc async-foreach {vars list body {final ""}} {
    if {[llength $vars] && [llength $list]} then {
        foreach $vars $list [
            set list [lrange $list [llength $vars] end]
            list for $body 1 return [
                list after idle [
                    list async-foreach $vars $list $body $final
                ]
            ]
        ]
    } else $final
}

(The body of foreach is a for command, and the next script of that for is a return that terminates both loops.) To demonstrate that it works:

 % async-foreach {vars list body final} {1 2 3 4 5 6 7} {puts "$vars $list $body $final"} {puts "That's all, folks!"}
 1 2 3 4
 % 5 6 7
 That's all, folks!

End update.

NEM: Nice improvement. The reason I suggested lambda was precisely to avoid having to have specially named variables. For instance, see the absurd lengths I go to to achieve this at More functional programming. I like the "final" clause - could be useful. Here's another version which handles (I think) all the forms of foreach, allows for cleanup, and allows you to cancel a loop at any time:

namespace eval async { variable id 0; variable data }

# async::foreach --
#
#   Usage: async::foreach varlist list ?varlist list...? ?-interval ms|idle? ?-finally script? body
proc async::foreach {varlist list args} {
    variable id; variable data
    set usage "async::foreach varlist list ?varlist list...? ?-interval ms|idle? ?-finally script? body"
    if {[llength $args] < 1 || ([llength $args] % 2) != 1} {
        return -code error "wrong # args: should be \"$usage\""
    }
    set curid [incr id]
    set body [lindex $args end]
    set data($curid,final) ""
    set data($curid,interval) idle
    set vars $varlist
    set data($curid,lengths) [list [llength $varlist]]
    set lists [list $list]
    ::foreach {key value} [lrange $args 0 end-1] {
        if {$key eq "-interval"} {
            set data($curid,interval) $value
        } elseif {$key eq "-finally"} {
            set data($curid,final) $value
        } else {
            eval lappend vars $key
            lappend data($curid,lengths) [llength $key]
            lappend lists $value
        }
    }
    # Create a proc for this body
    proc body$curid $vars $body
    set data($curid,event) [after $data($curid,interval) [list ::async::do $curid $lists]]
    return $curid
}
# Proc to actually run the body of the foreach
proc async::do {id lists} {
    variable data
    set call [list ::async::body$id]; set remainder [list]
    for {set i 0} {$i < [llength $data($id,lengths)]} {incr i} {
        set clist [lindex $lists $i]; set clen [lindex $data($id,lengths) $i]
        eval lappend call [lrange $clist 0 [expr {$clen -1}]]
        lappend remainder [lrange $clist $clen end]
    }
    if {[llength $call] == 1} {
        # Finished
        cancel $id
    } else {
        # Evaluate
        uplevel 1 $call
        set data($id,event) [after $data($id,interval) [list ::async::do $id $remainder]]
    }
}
# Cancel a running loop
proc async::cancel id {
    variable data
    after cancel $data($id,event)
    set final $data($id,final)
    ::foreach key [array names data $id,*] { unset data($key) }
    rename ::async::body$id {}
    # Run -finally script, if any
    uplevel 1 $final
}

And a usage example:

set id [async::foreach name {Neil Pete Jon} age {23 42 12} -interval 1000 -finally { puts "Done!" } {
    puts "Name = $name Age = $age"
}]
after 2100 [list ::async::cancel $id]
vwait async::data($id,final)
# Produces:
# Name = Neil Age = 23
# Name = Pete Age = 42
# Done!

schlenk: How about moving this async foreach into the control module of tcllib? Could help in the effort to make POP3/IMAP4/NNTP protocols in tcllib capable of async operation.

NEM: OK. I've just spotted a bug though (doesn't handle the foreach a {1 2} b {1} ... case). I'll fix it up and get someone to add it in. async versions of for and while would probably be good too.


schlenk: Here is an asynchronous for loop. It evaluates the $start, $test and $next expressions in the namespace given by the -ns option.

proc async::for {start test next args} {
   variable id; variable data
   set usage "async::for start test next ?-interval ms|idle? ?-ns namespace? ?-finally script? body"
   if {[llength $args] < 1 || ([llength $args] %2) != 1} {
       return -code error "wrong # args: should be \"$usage\""
   }
   set curid [incr id]
   set body [lindex $args end]
   set data($curid,final) ""
   set data($curid,interval) idle
   set data($curid,test) $test
   set data($curid,next) $next
   set data($curid,namespace) [uplevel 1 namespace current]
   ::foreach {key value} [lrange $args 0 end-1] {
        if {$key eq "-interval"} {
            set data($curid,interval) $value
        } elseif {$key eq "-finally"} {
            set data($curid,final) $value
        } elseif {$key eq "-ns"} {
            set data($curid,namespace) $value
        } else {
            return -code error "wrong # args: should be \"$usage\""
        }
   }

   proc body$curid {} $body
   # evaluate start code in global scope
   namespace inscope $data($curid,namespace) $start
   set data($curid,event) [after $data($curid,interval) [list ::async::dofor $curid]]
   return $curid
}

proc async::dofor id {
   variable data
   set call [list ::async::body$id]
   set test [namespace inscope $data($id,namespace) expr $data($id,test)]
   if {$test} {
       namespace inscope $data($id,namespace) $data($id,next)
       uplevel 1 $call
       set data($id,event) [after $data($id,interval) [list ::async::dofor $id]]
   } else {
       cancel $id
   }
}

proc async::wait id {
   vwait ::async::data($id,final)
}

And a usage example:

namespace eval ::scratch { variable i }
set id [async::for {set i 0} {$i < 100} {incr i} -ns ::scratch -interval 100 -finally {puts Done} \
    {upvar 0 ::scratch::i i; puts $i}]
after 2500 [list ::async::cancel $id]
async::wait $id

LV: Given the features in Tcl 8.5 and 8.6, is there a way to take the above idea and marry it with Tcl's coroutines to get a foreach that would work with generators?

NEM 2008-03-12:

proc async-foreach args {
    set body [lindex $args end]
    set id ::loop[incr ::loopid]
    set body "$body;after idle $id;yield"
    coroutine $id foreach {*}[lrange $args 0 end-1] $body
    return $id
}

LV: So, what would an example of using it look like? Trying to pattern after the examples above, I guess:

puts "example of async-foreach"
set id [async-foreach item {1 2 3 4 5 10 20 30 100} { puts "Item = $item" }]
after 2500 [list ::async::cancel $id]
  async::wait $id
puts Done!

I'm not certain about this though. The above uses a fixed list, rather than a generator. I'm uncertain how to express the generator.