Remember how Leo wanted an example of how continuations were used?
Well, I ported the following Scheme code to PIR. (The PIR is appended
to this message...
;;; Indicate that the computation has failed, and that the program
;;; should try another path. We rebind this variable as needed.
(define fail
(lambda () (error "Program failed")))
;;; Choose an arbitrary value and return it, with backtracking.
;;; You are not expected to understand this.
(define (choose . all-choices)
(let ((old-fail fail))
(call-with-current-continuation
(lambda (continuation)
(define (try choices)
(if (null? choices)
(begin
(set! fail old-fail)
(fail))
(begin
(set! fail
(lambda () (continuation (try (cdr choices)))))
(car choices))))
(try all-choices)))))
;;; Find two numbers with a product of 15.
(let ((x (choose 1 3 5))
(y (choose 1 5 9)))
(for-each display `("Trying " ,x " and " ,y #\newline))
(unless (= (* x y) 15)
(fail))
(for-each display `("Found " ,x " * " ,y " = 15" #\newline)))
Which (as anyone can plainly see) implements a non deterministic
search (and something like it could come in handy when implementing
Perl 6 Junctions).
I think I've tweaked a bug in the GC somewhere because 'parrot -t
choose.imc' and 'parrot -tG choose.imc' fail in different places.
Also, I thought Leo's patches to the stacks meant that RetContinuations
had been done away with, but the trace output implies otherwise, and it
may be that the code is failing because of this difference. The call to
fail *should* return to just after the second call to choose by
invoking the lexically held continuation, but this isn't what happens
Rejigging IMCC to use Continuations instead of RetContinuations (using
a simple minded search & replace) makes things fall over with a Bus
Error.
Enjoy.
.sub main
.local pmc arr1
.local pmc arr2
.local pmc x
.local pmc y
.local pmc choose
.local pmc fail
new_pad 0
$P0 = new PerlArray
store_lex 0, "*paths*", $P0
$P0 = new PerlString
$P0 = "@"
store_lex 0, "failsym", $P0
store_lex 0, "choose", $P0
store_lex 0, "fail", $P0
newsub choose, .Closure, _choose
store_lex "choose", choose
newsub fail, .Closure, _fail
store_lex "fail", fail
arr1 = new PerlArray
arr1[0] = 1
arr1[1] = 3
arr1[2] = 5
arr2 = new PerlArray
arr2[0] = 1
arr2[1] = 5
arr2[2] = 9
x = choose(arr1)
print "Chosen "
print x
print " from arr1\n"
y = choose(arr2)
print "Chosen "
print y
print " from arr2\n"
$I1 = x
$I2 = y
$I0 = $I1 * $I2
if $I0 == 15 goto success
fail = find_lex "fail"
fail()
print "Shouldn't get here without a failure report\n"
branch the_end
success:
print x
print " * "
print y
print " == 15!\n"
the_end:
end
.end
.sub _choose
.param PerlArray choices
.local pmc our_try
print "Choose: "
$S0 = typeof choices
print $S0
print "\n"
new_pad 1
find_lex $P0, "fail"
store_lex 1, "old_fail", $P0
store_lex 1, "cc", P1
newsub our_try, .Closure, _try
store_lex 1, "try", our_try
$P2 = our_try(choices)
.pcc_begin_return
.return $P2
.pcc_end_return
.end
.sub _try
.param PerlArray choices
print "In try\n"
$S0 = typeof choices
print $S0
print "\n"
new_pad 2
clone $P0, choices
store_lex 2, "choices", $P0
if choices goto have_choices
$P1 = find_lex "old_fail"
store_lex "fail", $P1
invokecc $P1
have_choices:
newsub $P2, .Closure, new_fail
store_lex "fail", $P2
$P3 = find_lex "choices"
$S0 = typeof $P3
print $S0
print "\n"
shift $P4, $P3
.pcc_begin_return
.return $P4
.pcc_end_return
new_fail:
.local pmc our_try
.local pmc our_cc
save P1
print "In new_fail\n"
our_cc = find_lex "cc"
our_try = find_lex "try"
$P2 = find_lex "choices"
$S0 = typeof $P2
print $S0
print "\n"
$P3 = our_try($P2)
restore P1
unless our_cc == P1 goto do_return
print "Something's very wrong with continuations!\n"
do_return:
our_cc($P3)
.end
.sub _fail
print "Program failed\n"
.pcc_begin_return
.pcc_end_return
.end
