Diffs between last version checked in and current workfile(s): Index: runtime/parrot/library/Parrot/Coroutine.pir =================================================================== --- runtime/parrot/library/Parrot/Coroutine.pir (revision 0) +++ runtime/parrot/library/Parrot/Coroutine.pir (revision 0) @@ -0,0 +1,266 @@ +=head1 TITLE + +Parrot::Coroutine - A pure PIR implementation of coroutines + +=head1 VERSION + + $Id:$ + +=head1 SYNOPSIS + + .sub __onload :load + load_bytecode 'Parrot/Coroutine.pir' + .end + + ## Recursive coroutine to enumerate tree elements. Each element that is + ## not a FixedPMCArray is yielded in turn. + .sub enumerate_tree + .param pmc coro + .param pmc tree_node + .param int depth :optional + .param int depth_p :opt_flag + + if depth_p goto have_depth + depth = 0 + have_depth: + inc depth + + $I0 = isa tree_node, 'FixedPMCArray' + if $I0 goto recur + print "[leaf " + print tree_node + print "]\n" + coro.'yield'(tree_node) + .return () + + recur: + ## Loop through array elements, recurring on each. + .local int size, i + i = 0 + size = tree_node + again: + if i >= size goto done + print "[recur: depth " + print depth + print ' elt ' + print i + print "]\n" + $P1 = tree_node[i] + enumerate_tree(coro, $P1, depth) + inc i + goto again + done: + .return () + .end + + .sub print_tree + .param pmc tree + + .local int coro_class, idx + coro_class = find_type 'Parrot::Coroutine' + .local pmc coro + .const .Sub coro_sub = "enumerate_tree" + coro = new coro_class, coro_sub + ($P0 :optional, $I0 :opt_flag) = coro.'resume'(coro, tree) + idx = 0 + + loop: + unless $I0 goto done + print 'print_tree: ' + print idx + print ' => ' + print $P0 + print "\n" + ($P0 :optional, $I0 :opt_flag) = coro.'resume'() + goto loop + done: + .end + +=head1 DESCRIPTION + +This object class provides an implementation of coroutines that is written +in pure PIR using continuations. + +=cut + +.const int slot_state = 0 ## State: 1 is new/valid, 0 is dead. +.const int slot_initial_sub = 1 ## Initial sub. +.const int slot_yield_cont = 2 ## Continuation to for yielding. +.const int slot_resume_cont = 3 ## Continuation from which to resume. + +.sub __loadtime_create_class :load + find_type $I0, "Parrot::Coroutine" + if $I0 > 1 goto END + newclass $P0, "Parrot::Coroutine" + addattribute $P0, "state" + addattribute $P0, "initial_sub" + addattribute $P0, "yield_cont" + addattribute $P0, "resume_cont" +END: + .return () +.end + +.namespace ["Parrot::Coroutine"] + +.include "interpinfo.pasm" + +=head2 METHODS + +=head3 B<__init(sub)> + +This method is normally called via the C op: + + .local int coro_class + coro_class = find_type 'Parrot::Coroutine' + .local pmc coro + .const .Sub coro_sub = "enumerate_tree" + coro = new coro_class, coro_sub + +Given a sub, it initializes a new C object. + +=cut + +.sub __init :method + .param pmc sub + + ## [should complain if sub is not a sub or closure. -- rgr, 8-Oct-06.] + .local pmc state + state = new .Undef + state = 1 + setattribute self, slot_state, state + setattribute self, slot_initial_sub, sub +.end + +## [it would be nice to include a pointer value. -- rgr, 8-Oct-06.] +.sub __get_string :method + $S0 = '' + .return ($S0) +.end + +=head3 B + +Invoke the coroutine. The first time this is called on a new coroutine, +the initial sub is invoked with the passed arguments. The second and +subsequent times, the args are delivered as the result of the previous +C operation. + +If the coroutine subsequently yields, the values passed to the C +method are returned as the values from C. + +If the coroutine returns normally (i.e. from the original sub), then those +values are passed returned from the C method, and the coroutine is +marked as dead, in which case it is an error to attempt to resume it again. + +=cut + +.sub resume :method + .param pmc args :slurpy + + ## Decide whether we're dead. + .local pmc state + state = getattribute self, slot_state + unless state goto dead + + ## Decide where to go. If we've never been invoked before, we need to + ## call the sub. + .local pmc entry + entry = getattribute self, slot_resume_cont + unless null entry goto doit + entry = getattribute self, slot_initial_sub + +doit: + ## Remember where to return when we yield. + .local pmc cc + cc = interpinfo .INTERPINFO_CURRENT_CONT + setattribute self, slot_yield_cont, cc + + ## Call the entry with our args. Most of the time, it will yield (by + ## calling our continuation for us) instead of returning directly. + .local pmc result + (result :slurpy) = entry(args :flat) + ## If we returned normally, then the coroutine is dead. + state = 0 + ## Note that the value of the yield_cont slot will normally have been + ## changed magically behind our backs by a subsequent yield/resume, so + ## we can't just return directly. + cc = getattribute self, slot_yield_cont + .return cc(result :flat) + +dead: + ## Complain about attempted zombie creation. + .local pmc error + error = new .Exception + error['_message'] = "Can't reanimate a dead coroutine.\n" + throw error +.end + +=head3 B + +Within the coroutine, C returns arbitrary values back to the +caller, making it look like the values came from the last C call. + +The next time the caller decides to resume the coroutine, the arguments +passed to C are returned as the values from C. + +=cut + +## Return values to the calling thread. +.sub yield :method + .param pmc args :slurpy + + ## Remember where to go when we are resumed. + .local pmc cc + cc = interpinfo .INTERPINFO_CURRENT_CONT + setattribute self, slot_resume_cont, cc + + ## Return to the coro caller. + cc = getattribute self, slot_yield_cont + .return cc(args :flat) +.end + +=head1 BUGS + +=over 4 + +=item 1. + +We should really keep more state details. The only legal state +transitions should be 'new' to 'resumed' to 'yielded' to 'resumed' +to 'yielded' ..., except that one might at any time transition to +'dead', which is (not surprisingly) the terminal state. + +=back + +Please report any others you find to Cparrot-porters@perl.orgE>. + +=head1 SEE ALSO + +L -- coroutines defined. + +C -- "same fringe" test case. + +C -- the C implementation. + +L -- definition of the +coroutine API for the Lua programming language, upon which the +C API is based. + +L +-- Scheme tutorial chapter that introduces call/cc and uses it to solve +"same fringe" via coroutines. + +=head1 AUTHOR + +Bob Rogers Crogers-perl6@rgrjr.dyndns.orgE> + +=head1 COPYRIGHT + +Copyright (C) 2006, The Perl Foundation. +This program is free software. It is subject to the same +license as The Parrot Interpreter. + +=for vim + +" vim: ts=8 expandtab + +=cut Index: MANIFEST =================================================================== --- MANIFEST (revision 14921) +++ MANIFEST (working copy) @@ -2128,6 +2128,7 @@ runtime/parrot/library/HTTP/Daemon.pir [library] runtime/parrot/library/JSON.pir [library] runtime/parrot/library/MIME/Base64.pir [library] +runtime/parrot/library/Parrot/Coroutine.pir [library] runtime/parrot/library/PGE/Dumper.pir [library] runtime/parrot/library/PGE/Glob.pir [library] runtime/parrot/library/PGE/Hs.pir [library] @@ -2550,6 +2551,7 @@ t/examples/subs.t [] t/harness [] t/library/File_Spec.t [] +t/library/coroutine.t [] t/library/data_escape.t [] t/library/dumper.t [] t/library/getopt_obj.t [] Index: t/library/coroutine.t =================================================================== --- t/library/coroutine.t (revision 0) +++ t/library/coroutine.t (revision 0) @@ -0,0 +1,219 @@ +#!./parrot +# Copyright (C) 2006, The Perl Foundation. +# $Id:$ + +=head1 NAME + +t/library/coroutine.t -- Test the Parrot::Coroutine class + +=head1 SYNOPSIS + + ./parrot t/library/coroutine.t + +=head1 DESCRIPTION + +This script tests the C class using an implementation of the +"same fringe" problem. + +=head1 SEE ALSO + +L +-- a collection of "same fringe" implementations in Scheme. + +=cut + +.const int N_TESTS = 6 + +## Build an N-ary tree (where N is passed as node_width) of the specified depth, +## with the leaves being consecutive integer PMCs from start but less than N. +## The tree will be complete iff end-start+1 == node_width^depth. +.sub make_nary_tree + .param int start + .param int end + .param int node_width + .param int depth + + .local pmc result + if depth goto deeper + result = new .Undef + result = start + inc start + goto done +deeper: + result = new .ResizablePMCArray + dec depth + .local int i + i = 0 +next: + if i >= node_width goto done + if start > end goto done + ($P0, start) = make_nary_tree(start, end, node_width, depth) + push result, $P0 + inc i + goto next +done: + .return (result, start) +.end + +## non-coroutine traversal, for debugging. +.sub enumerate_tree + .param pmc tree_node + .param int depth :optional + .param int depth_p :opt_flag + + if depth_p goto have_depth + depth = 0 +have_depth: + inc depth + + $I0 = isa tree_node, 'ResizablePMCArray' + if $I0 goto recur + print "[leaf " + print tree_node + print "]\n" +done: + .return () + +recur: + ## Loop through array elements, recurring on each. + .local int size, i + i = 0 + size = tree_node +again: + if i >= size goto done + print "[recur: depth " + print depth + print ' elt ' + print i + print "]\n" + $P1 = tree_node[i] + enumerate_tree($P1, depth) + inc i + goto again +.end + +## Recursive coroutine to enumerate tree elements. Each element that is not a +## FixedPMCArray is yielded in turn. +.sub coro_enumerate_tree + .param pmc coro + .param pmc tree_node + .param int depth :optional + .param int depth_p :opt_flag + + if depth_p goto have_depth + depth = 0 +have_depth: + inc depth + + $I0 = isa tree_node, 'FixedPMCArray' + if $I0 goto recur + ## print "[leaf " + ## print tree_node + ## print "]\n" + coro.'yield'(tree_node) + .return () + +recur: + ## Loop through array elements, recurring on each. + .local int size, i + i = 0 + size = tree_node +again: + if i >= size goto done + ## print "[coro recur: depth " + ## print depth + ## print ' elt ' + ## print i + ## print "]\n" + $P1 = tree_node[i] + coro_enumerate_tree(coro, $P1, depth) + inc i + goto again +done: + .return () +.end + +## Solution to the "same fringe" problem that uses coroutines to enumerate each +## of two passed trees of numbers. Returns 1 if the trees have the same fringe, +## else 0. +.sub same_fringe + .param pmc tree1 + .param pmc tree2 + + .local int coro_class + coro_class = find_type 'Parrot::Coroutine' + if coro_class goto found + printerr "Bug: Can't find 'Parrot::Coroutine' class.\n" + die 5, 1 +found: + .local pmc coro1, coro2 + .const .Sub coro_sub = "coro_enumerate_tree" + coro1 = new coro_class, coro_sub + coro2 = new coro_class, coro_sub + ($P0 :optional, $I0 :opt_flag) = coro1.'resume'(coro1, tree1) + ($P1 :optional, $I1 :opt_flag) = coro2.'resume'(coro2, tree2) + +loop: + if $I0 goto got_first + if $I1 goto not_equal + goto equal +got_first: + unless $I1 goto not_equal + + ## now have results from both. + ## print "[got " + ## print $P0 + ## print ' and ' + ## print $P1 + ## print "]\n" + if $P0 != $P1 goto not_equal + ## set up for the next iteration. + ($P0 :optional, $I0 :opt_flag) = coro1.'resume'() + ($P1 :optional, $I1 :opt_flag) = coro2.'resume'() + goto loop +not_equal: + .return (0) +equal: + .return (1) +.end + +.sub main :main + load_bytecode 'Test/Builder.pir' + .local pmc test + test = new 'Test::Builder' + test.'plan'(N_TESTS) + + push_eh cant_load + load_bytecode 'Parrot/Coroutine.pir' + clear_eh + test.'ok'(1, 'loaded bytecode') + + ## grow some trees for traversal. + .local pmc binary, binary_4, ternary, ternary_2 + binary = make_nary_tree(1, 8, 2, 3) + ternary = make_nary_tree(1, 8, 3, 2) + binary_4 = make_nary_tree(1, 16, 2, 4) + ## now make a "damaged" one that will be different. + ternary_2 = make_nary_tree(1, 8, 3, 2) + $P0 = ternary_2[1] + $P0 = $P0[0] + ternary_2[1] = $P0 + ## enumerate_tree(ternary_2) + test.'ok'(1, 'made test trees.') + + $I0 = same_fringe(binary, binary) + test.'ok'($I0, 'binary [[[1,2],[3,4]],[[5,6],[7,8]]] vs. itself') + $I0 = same_fringe(binary, binary_4) + $I0 = 1 - $I0 + test.'ok'($I0, 'binary 1..8 vs. binary 1..16') + $I0 = same_fringe(binary, ternary) + test.'ok'($I0, 'binary 1..8 vs. ternary [[1,2,3],[4,5,6],[7,8]]') + $I0 = same_fringe(binary, ternary_2) + $I0 = 1 - $I0 + test.'ok'($I0, 'binary 1..8 vs. ternary [[1,2,3],4,[7,8]]') + test.'finish'() + end +cant_load: + test.'ok'(0, 'Load failed') + test.'finish'() +.end Property changes on: t/library/coroutine.t ___________________________________________________________________ Name: svn:mime-type + text/plain End of diffs.