1# You may distribute under the terms of either the GNU General Public License 2# or the Artistic License (the same terms as Perl itself) 3# 4# (C) Paul Evans, 2008-2010 -- leonerd@leonerd.org.uk 5 6package CPS; 7 8use strict; 9use warnings; 10 11our $VERSION = '0.19'; 12 13use Carp; 14 15our @CPS_PRIMS = qw( 16 kloop 17 kwhile 18 kforeach 19 kdescendd kdescendb 20 21 kpar 22 kpareach 23 24 kseq 25); 26 27our @EXPORT_OK = ( 28 @CPS_PRIMS, 29 map( "g$_", @CPS_PRIMS ), 30 31qw( 32 liftk 33 dropk 34), 35); 36 37use Exporter 'import'; 38 39use CPS::Governor::Simple; 40 41# Don't hard-depend on Sub::Name since it's only a niceness for stack traces 42BEGIN { 43 if( eval { require Sub::Name } ) { 44 *subname = \&Sub::Name::subname; 45 } 46 else { 47 # Ignore the name, return the CODEref 48 *subname = sub { return $_[1] }; 49 } 50} 51 52=head1 NAME 53 54C<CPS> - manage flow of control in Continuation-Passing Style 55 56=head1 OVERVIEW 57 58=over 4 59 60B<Note>: This module is entirely deprecated now. It is maintained for 61compatibility for any code still using it, but please consider rewriting to 62use L<Future> instead, which offers a far neater method of representing 63asynchronous program and data flow. In addition, L<Future::AsyncAwait> can 64further improve readability of C<Future>-based code by letting it use the 65familiar kinds of Perl control structure while still being asynchronous. 66 67At some later date this entire C<CPS> module distribution may be deleted. 68 69=back 70 71The functions in this module implement or assist the writing of programs, or 72parts of them, in Continuation Passing Style (CPS). Briefly, CPS is a style 73of writing code where the normal call/return mechanism is replaced by explicit 74"continuations", values passed in to functions which they should invoke, to 75implement return behaviour. For more detail on CPS, see the SEE ALSO section. 76 77What this module implements is not in fact true CPS, as Perl does not natively 78support the idea of a real continuation (such as is created by a co-routine). 79Furthermore, for CPS to be efficient in languages that natively support it, 80their runtimes typically implement a lot of optimisation of CPS code, which 81the Perl interpreter would be unable to perform. Instead, CODE references are 82passed around to stand in their place. While not particularly useful for most 83regular cases, this becomes very useful whenever some form of asynchronous or 84event-based programming is being used. Continuations passed in to the body 85function of a control structure can be stored in the event handlers of the 86asynchronous or event-driven framework, so that when they are invoked later, 87the code continues, eventually arriving at its final answer at some point in 88the future. 89 90In order for these examples to make sense, a fictional and simple 91asynchronisation framework has been invented. The exact details of operation 92should not be important, as it simply stands to illustrate the point. I hope 93its general intention should be obvious. :) 94 95 read_stdin_line( \&on_line ); # wait on a line from STDIN, then pass it 96 # to the handler function 97 98This module itself provides functions that manage the flow of control through 99a continuation passing program. They do not directly facilitate the flow of 100data through a program. That can be managed by lexical variables captured by 101the closures passed around. See the EXAMPLES section. 102 103For CPS versions of data-flow functionals, such as C<map> and C<grep>, see 104also L<CPS::Functional>. 105 106=head1 SYNOPSIS 107 108 use CPS qw( kloop ); 109 110 kloop( sub { 111 my ( $knext, $klast ) = @_; 112 113 print "Enter a number, or q to quit: "; 114 115 read_stdin_line( sub { 116 my ( $first ) = @_; 117 chomp $first; 118 119 return $klast->() if $first eq "q"; 120 121 print "Enter a second number: "; 122 123 read_stdin_line( sub { 124 my ( $second ) = @_; 125 126 print "The sum is " . ( $first + $second ) . "\n"; 127 128 $knext->(); 129 } ); 130 } ); 131 }, 132 sub { exit } 133 ); 134 135=cut 136 137=head1 FUNCTIONS 138 139In all of the following functions, the C<\&body> function can provide results 140by invoking its continuation / one of its continuations, either synchronously 141or asynchronously at some point later (via some event handling or other 142mechanism); the next invocation of C<\&body> will not take place until the 143previous one exits if it is done synchronously. 144 145They all take the prefix C<k> before the name of the regular perl keyword or 146function they aim to replace. It is common in CPS code in other languages, 147such as Scheme or Haskell, to store a continuation in a variable called C<k>. 148This convention is followed here. 149 150=cut 151 152=head2 kloop( \&body, $k ) 153 154CPS version of perl's C<while(true)> loop. Repeatedly calls the C<body> code 155until it indicates the end of the loop, then invoke C<$k>. 156 157 $body->( $knext, $klast ) 158 $knext->() 159 $klast->() 160 161 $k->() 162 163If C<$knext> is invoked, the body will be called again. If C<$klast> is 164invoked, the continuation C<$k> is invoked. 165 166=head2 kwhile( \&body, $k ) 167 168Compatibility synonym for C<kloop>; it was renamed after version 0.10. New 169code should use C<kloop> instead. 170 171=cut 172 173sub _fix 174{ 175 my ( $func ) = @_; 176 sub { 177 unshift @_, _fix( $func ); 178 goto &$func; 179 }; 180} 181 182sub gkloop 183{ 184 my ( $gov, $body, $k ) = @_; 185 186 # We can't just call this as a method because we need to tailcall it 187 # Instead, keep a reference to the actual method so we can goto &$enter 188 my $enter = $gov->can('enter') or croak "Governor cannot ->enter"; 189 190 my $kfirst = _fix subname gkloop => sub { 191 my $knext = shift; 192 193 my $sync = 1; 194 my $do_again; 195 $enter->( $gov, $body, 196 sub { 197 if( $sync ) { $do_again=1 } 198 else { goto &$knext; } 199 }, 200 sub { @_ = (); goto &$k }, 201 ); 202 $sync = 0; 203 204 if( $do_again ) { 205 $do_again = 0; 206 goto &$knext; 207 } 208 }; 209 210 goto &$kfirst; 211} 212 213*gkwhile = \&gkloop; 214 215=head2 kforeach( \@items, \&body, $k ) 216 217CPS version of perl's C<foreach> loop. Calls the C<body> code once for each 218element in C<@items>, until either the items are exhausted or the C<body> 219invokes its C<$klast> continuation, then invoke C<$k>. 220 221 $body->( $item, $knext, $klast ) 222 $knext->() 223 $klast->() 224 225 $k->() 226 227=cut 228 229sub gkforeach 230{ 231 my ( $gov, $items, $body, $k ) = @_; 232 233 my $idx = 0; 234 235 gkloop( $gov, 236 sub { 237 my ( $knext, $klast ) = @_; 238 goto &$klast unless $idx < scalar @$items; 239 @_ =( 240 $items->[$idx++], 241 $knext, 242 $klast 243 ); 244 goto &$body; 245 }, 246 $k, 247 ); 248} 249 250=head2 kdescendd( $root, \&body, $k ) 251 252CPS version of recursive descent on a tree-like structure, defined by a 253function, C<body>, which when given a node in the tree, yields a list of 254child nodes. 255 256 $body->( $node, $kmore ) 257 $kmore->( @child_nodes ) 258 259 $k->() 260 261The first value to be passed into C<body> is C<$root>. 262 263At each iteration, a node is given to the C<body> function, and it is expected 264to pass a list of child nodes into its C<$kmore> continuation. These will then 265be iterated over, in the order given. The tree-like structure is visited 266depth-first, descending fully into one subtree of a node before moving on to 267the next. 268 269This function does not provide a way for the body to accumulate a resultant 270data structure to pass into its own continuation. The body is executed simply 271for its side-effects and its continuation is invoked with no arguments. A 272variable of some sort should be shared between the body and the continuation 273if this is required. 274 275=cut 276 277sub gkdescendd 278{ 279 my ( $gov, $root, $body, $k ) = @_; 280 281 my @stack = ( $root ); 282 283 gkloop( $gov, 284 sub { 285 my ( $knext, $klast ) = @_; 286 @_ = ( 287 shift @stack, 288 sub { 289 unshift @stack, @_; 290 291 goto &$knext if @stack; 292 goto &$klast; 293 }, 294 ); 295 goto &$body; 296 }, 297 $k, 298 ); 299} 300 301=head2 kdescendb( $root, \&body, $k ) 302 303A breadth-first variation of C<kdescendd>. This function visits each child 304node of the parent, before iterating over all of these nodes's children, 305recursively until the bottom of the tree. 306 307=cut 308 309sub gkdescendb 310{ 311 my ( $gov, $root, $body, $k ) = @_; 312 313 my @queue = ( $root ); 314 315 gkloop( $gov, 316 sub { 317 my ( $knext, $klast ) = @_; 318 @_ = ( 319 shift @queue, 320 sub { 321 push @queue, @_; 322 323 goto &$knext if @queue; 324 goto &$klast; 325 }, 326 ); 327 goto &$body; 328 }, 329 $k, 330 ); 331} 332 333=head2 kpar( @bodies, $k ) 334 335This CPS function takes a list of function bodies and calls them all 336immediately. Each is given its own continuation. Once every body has invoked 337its continuation, the main continuation C<$k> is invoked. 338 339 $body->( $kdone ) 340 $kdone->() 341 342 $k->() 343 344This allows running multiple operations in parallel, and waiting for them all 345to complete before continuing. It provides in a CPS form functionality 346similar to that provided in a more object-oriented fashion by modules such as 347L<Async::MergePoint> or L<Event::Join>. 348 349=cut 350 351sub gkpar 352{ 353 my ( $gov, @bodies ) = @_; 354 my $k = pop @bodies; 355 356 $gov->can('enter') or croak "Governor cannot ->enter"; 357 358 my $sync = 1; 359 my @outstanding; 360 my $kdone = sub { 361 return if $sync; 362 $_ and return for @outstanding; 363 goto &$k; 364 }; 365 366 gkforeach( $gov, [ 0 .. $#bodies ], 367 sub { 368 my ( $idx, $knext ) = @_; 369 $outstanding[$idx]++; 370 $gov->enter( $bodies[$idx], sub { 371 $outstanding[$idx]--; 372 @_ = (); 373 goto &$kdone; 374 } ); 375 goto &$knext; 376 }, 377 sub { 378 $sync = 0; 379 @_ = (); 380 goto &$kdone; 381 } 382 ); 383} 384 385=head2 kpareach( \@items, \&body, $k ) 386 387This CPS function takes a list of items and a function body, and calls the 388body immediately once for each item in the list. Each invocation is given its 389own continuation. Once every body has invoked its continuation, the main 390continuation C<$k> is invoked. 391 392 $body->( $item, $kdone ) 393 $kdone->() 394 395 $k->() 396 397This is similar to C<kforeach>, except that the body is started concurrently 398for all items in the list list, rather than each item waiting for the previous 399to finish. 400 401=cut 402 403sub gkpareach 404{ 405 my ( $gov, $items, $body, $k ) = @_; 406 407 gkpar( $gov, 408 (map { 409 my $item = $_; 410 sub { 411 unshift @_, $item; 412 goto &$body 413 } 414 } @$items), 415 $k 416 ); 417} 418 419=head2 kseq( @bodies, $k ) 420 421This CPS function takes a list of function bodies and calls them each, one at 422a time in sequence. Each is given a continuation to invoke, which will cause 423the next body to be invoked. When the last body has invoked its continuation, 424the main continuation C<$k> is invoked. 425 426 $body->( $kdone ) 427 $kdone->() 428 429 $k->() 430 431A benefit of this is that it allows a long operation that uses many 432continuation "pauses", to be written without code indenting further and 433further to the right. Another is that it allows easy skipping of conditional 434parts of a computation, which would otherwise be tricky to write in a CPS 435form. See the EXAMPLES section. 436 437=cut 438 439sub gkseq 440{ 441 my ( $gov, @bodies ) = @_; 442 my $k = pop @bodies; 443 444 my $enter = $gov->can('enter') or croak "Governor cannot ->enter"; 445 446 while( @bodies ) { 447 my $nextk = $k; 448 my $b = pop @bodies; 449 $k = sub { 450 @_ = ( $gov, $b, $nextk ); 451 goto &$enter; 452 }; 453 } 454 455 @_ = (); 456 goto &$k; 457} 458 459=head1 GOVERNORS 460 461All of the above functions are implemented using a loop which repeatedly calls 462the body function until some terminating condition. By controlling the way 463this loop re-invokes itself, a program can control the behaviour of the 464functions. 465 466For every one of the above functions, there also exists a variant which takes 467a L<CPS::Governor> object as its first argument. These functions use the 468governor object to control their iteration. 469 470 kloop( \&body, $k ) 471 gkloop( $gov, \&body, $k ) 472 473 kforeach( \@items, \&body, $k ) 474 gkforeach( $gov, \@items, \&body, $k ) 475 476 etc... 477 478In this way, other governor objects can be constructed which have different 479running properties; such as interleaving iterations of their loop with other 480IO activity in an event-driven framework, or giving rate-limitation control on 481the speed of iteration of the loop. 482 483=cut 484 485# The above is a lie. The basic functions provided are actually the gk* 486# versions; we wrap these to make the normal k* functions by passing a simple 487# governor. 488sub _governate 489{ 490 my $pkg = caller; 491 my ( $func, $name ) = @_; 492 493 my $default_gov = CPS::Governor::Simple->new; 494 495 no strict 'refs'; 496 497 my $code = $pkg->can( $func ) or croak "$pkg cannot $func()"; 498 *{$pkg."::$name"} = subname $name => sub { 499 unshift @_, $default_gov; 500 goto &$code; 501 }; 502} 503 504_governate "g$_" => $_ for @CPS_PRIMS; 505 506=head1 CPS UTILITIES 507 508These function names do not begin with C<k> because they are not themselves 509CPS primatives, but may be useful in CPS-oriented code. 510 511=cut 512 513=head2 $kfunc = liftk { BLOCK } 514 515=head2 $kfunc = liftk( \&func ) 516 517Returns a new CODE reference to a CPS-wrapped version of the code block or 518passed CODE reference. When C<$kfunc> is invoked, the function C<&func> is 519called in list context, being passed all the arguments given to C<$kfunc> 520apart from the last, expected to be its continuation. When C<&func> returns, 521the result is passed into the continuation. 522 523 $kfunc->( @func_args, $k ) 524 $k->( @func_ret ) 525 526The following are equivalent 527 528 print func( 1, 2, 3 ); 529 530 my $kfunc = liftk( \&func ); 531 $kfunc->( 1, 2, 3, sub { print @_ } ); 532 533Note that the returned wrapper function only has one continuation slot in its 534arguments. It therefore cannot be used as the body for C<kloop()>, 535C<kforeach()> or C<kgenerate()>, because these pass two continuations. There 536does not exist a "natural" way to lift a normal call/return function into a 537CPS function which requires more than one continuation, because there is no 538way to distinguish the different named returns. 539 540=cut 541 542sub liftk(&) 543{ 544 my ( $code ) = @_; 545 546 return sub { 547 my $k = pop; 548 @_ = $code->( @_ ); 549 goto &$k; 550 }; 551} 552 553=head2 $func = dropk { BLOCK } $kfunc 554 555=head2 $func = dropk $waitfunc, $kfunc 556 557Returns a new CODE reference to a plain call/return version of the passed 558CPS-style CODE reference. When the returned ("dropped") function is called, 559it invokes the passed CPS function, then waits for it to invoke its 560continuation. When it does, the list that was passed to the continuation is 561returned by the dropped function. If called in scalar context, only the first 562value in the list is returned. 563 564 $kfunc->( @func_args, $k ) 565 $k->( @func_ret ) 566 567 $waitfunc->() 568 569 @func_ret = $func->( @func_args ) 570 571Given the following trivial CPS function: 572 573 $kadd = sub { $_[2]->( $_[0] + $_[1] ) }; 574 575The following are equivalent 576 577 $kadd->( 10, 20, sub { print "The total is $_[0]\n" } ); 578 579 $add = dropk { } $kadd; 580 print "The total is ".$add->( 10, 20 )."\n"; 581 582In the general case the CPS function hasn't yet invoked its continuation by 583the time it returns (such as would be the case when using any sort of 584asynchronisation or event-driven framework). For C<dropk> to actually work in 585this situation, it requires a way to run the event framework, to cause it to 586process events until the continuation has been invoked. 587 588This is provided by the block, or the first passed CODE reference. When the 589returned function is invoked, it repeatedly calls the block or wait function, 590until the CPS function has invoked its continuation. 591 592=cut 593 594sub dropk(&$) 595{ 596 my ( $waitfunc, $kfunc ) = @_; 597 598 return sub { 599 my @result; 600 my $done; 601 602 $kfunc->( @_, sub { @result = @_; $done = 1 } ); 603 604 while( !$done ) { 605 $waitfunc->(); 606 } 607 608 return wantarray ? @result : $result[0]; 609 } 610} 611 612=head1 EXAMPLES 613 614=head2 Returning Data From Functions 615 616No facilities are provided directly to return data from CPS body functions in 617C<kloop>, C<kpar> and C<kseq>. Instead, normal lexical variable capture may 618be used here. 619 620 my $bat; 621 my $ball; 622 623 kpar( 624 sub { 625 my ( $k ) = @_; 626 get_bat( on_bat => sub { $bat = shift; goto &$k } ); 627 }, 628 sub { 629 my ( $k ) = @_; 630 serve_ball( on_ball => sub { $ball = shift; goto &$k } ); 631 }, 632 633 sub { 634 $bat->hit( $ball ); 635 }, 636 ); 637 638The body function can set the value of a variable that it and its final 639continuation both capture. 640 641=head2 Using C<kseq> For Conditionals 642 643Consider the call/return style of code 644 645 A(); 646 if( $maybe ) { 647 B(); 648 } 649 C(); 650 651We cannot easily write this in CPS form without naming C twice 652 653 kA( sub { 654 $maybe ? 655 kB( sub { kC() } ) : 656 kC(); 657 } ); 658 659While not so problematic here, it could get awkward if C were in fact a large 660code block, or if more than a single conditional were employed in the logic; a 661likely scenario. A further issue is that the logical structure becomes much 662harder to read. 663 664Using C<kseq> allows us to name the continuation so each arm of C<kmaybe> can 665invoke it indirectly. 666 667 kseq( 668 \&kA, 669 sub { my $k = shift; $maybe ? kB( $k ) : goto &$k; }, 670 \&kC 671 ); 672 673=head1 SEE ALSO 674 675=over 4 676 677=item * 678 679L<Future> - represent an operation awaiting completion 680 681=item * 682 683L<Future::AsyncAwait> - deferred subroutine syntax for futures 684 685=item * 686 687L<CPS::Functional> - functional utilities in Continuation-Passing Style 688 689=item * 690 691L<http://en.wikipedia.org/wiki/Continuation-passing_style> on wikipedia 692 693=back 694 695=head1 ACKNOWLEDGEMENTS 696 697Matt S. Trout (mst) <mst@shadowcat.co.uk> - for the inspiration of C<kpareach> 698and with apologies to for naming of the said. ;) 699 700=head1 AUTHOR 701 702Paul Evans <leonerd@leonerd.org.uk> 703 704=cut 705 7060x55AA; 707