# New Ticket Created by Allison Randal
# Please include the string: [perl #23368]
# in the subject line of all future correspondence about this issue.
# <URL: http://rt.perl.org/rt2/Ticket/Display.html?id=23368 >
This patch switches languages/perl6 over to using CPS. It isn't a
complete and final solution, just a step in the right direction. My goal
was to make the smallest number of code changes possible to get it to
work.
Switching to the current calling conventions fixed 4 out of 5 failing
tests with calls to closures and rules (t/compiler/2.t 3-5, and
t/rx/basic.t 6). The remaining test (t/compiler/1.t 15) fails because
some architectures return "inf" instead of "Inf" when dividing by zero.
Eventually, division by zero should probably throw an exception, so I'm
ignoring this for now.
Allison
-- attachment 1 ------------------------------------------------------
url: http://rt.perl.org/rt2/attach/62986/46376/feb335/p6c_calling_conventions.patch
Index: languages/perl6/P6C/Builtins.pm
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/P6C/Builtins.pm,v
retrieving revision 1.16
diff -u -r1.16 Builtins.pm
--- languages/perl6/P6C/Builtins.pm 9 Sep 2002 05:11:58 -0000 1.16
+++ languages/perl6/P6C/Builtins.pm 19 Aug 2003 01:27:40 -0000
@@ -17,7 +17,8 @@
use vars '%builtin_names';
BEGIN {
my @names = qw(print1 exit warn die print sleep time substr length
- index map grep join reverse defined);
+ index map grep join reverse defined install_catch
+ pop_catch);
@[EMAIL PROTECTED] = (1) x @names;
}
@@ -27,7 +28,7 @@
sub declare {
my $hash = shift;
- for (qw(print1 exit sleep)) {
+ for (qw(print1 exit sleep install_catch pop_catch)) {
$hash->{$_} = new P6C::IMCC::Sub args => [['PerlUndef', 'a']],
rettype => [];
$P6C::Context::CONTEXT{$_} = new P6C::Context type => 'PerlUndef';
@@ -92,122 +93,123 @@
print <<'END';
-.emit
-
-_substr:
- pushp
- pushi
- pushs
-# get arr
- restore P0
+.pcc_sub _substr non_prototyped
+ .param object params
+ $P0 = params
# n paras
- set I0, P0
- set S0, P0[0]
- set I1, P0[1]
- eq I0, 2, __substr_2
- set I2, P0[2]
- gt I0, 4, __substr_die
- lt I0, 2, __substr_die
- length I3, S0
- set I4, I3
- ge I2, 0, __substr_34
+ $I0 = params
+ $S0 = params[0]
+ $I1 = params[1]
+ if $I0 == 2 goto substr_2
+ $I2 = params[2]
+ if $I0 > 4 goto substr_die
+ if $I0 < 2 goto substr_die
+ length $I3, $S0
+ $I4 = $I3
+ if $I2 >= 0 goto substr_34
# len negative, leave -len of string
- sub I3, I3, I1
- add I3, I3, I2
- set I2, I3
-__substr_34:
- set S1, ""
+ $I3 = $I3 - $I1
+ $I3 = $I3 + $I2
+ $I2 = $I3
+substr_34:
+ $S1 = ""
# # offset >= len?
- ge I1, I4, __substr_ret
- eq I0, 4, __substr_4
-__substr_3:
- substr S1, S0, I1, I2
-__substr_ret:
- new P1, .PerlString
- set P1, S1
- save P1
- pops
- popi
- popp
- ret
-__substr_4:
- set S2, P0[3]
- substr S1, S0, I1, I2, S2
- set P0[2], S1
- branch __substr_ret
-__substr_2:
- length I2, S0
- sub I2, I2, I1
- branch __substr_3
-__substr_die:
- set S0, "wrong number of args for substr"
- new P0, .PerlArray
- set P0[0], S0
- save P0
- bsr _die
- branch __substr_ret
+ if $I1 >= $I4 goto substr_ret
+ if $I0 == 4 goto substr_4
+substr_3:
+ substr $S1, $S0, $I1, $I2
+substr_ret:
+ $P1 = new PerlString
+ $P1 = $S1
+ .pcc_begin_return
+ .return $P1
+ .pcc_end_return
+substr_4:
+ $S2 = params[3]
+ substr $S1, $S0, $I1, $I2, $S2
+ params[2] = $S1
+ goto substr_ret
+substr_2:
+ length $I2, $S0
+ sub $I2, $I2, $I1
+ goto substr_3
+substr_die:
+ set $S0, "wrong number of args for substr"
+ $P0 = new PerlArray
+ $P0[0] = $S0
+ find_lex $P2, "&die"
+ .pcc_begin non_prototyped
+ .arg $P0
+ .pcc_call $P2
+substr_ret_label:
+ .pcc_end
+ goto substr_ret
+ end
+.end
-_length:
- pushp
- pushs
- pushi
- restore P0
- set S0, P0
- length I0, S0
- new P1, .PerlInt
- set P1, I0
- save P1
- popi
- pops
- popp
- ret
+.pcc_sub _length non_prototyped
+ .param object s
+ $S0 = s
+ length $I0, $S0
+ $P1 = new PerlInt
+ set $P1, $I0
+ .pcc_begin_return
+ .return $P1
+ .pcc_end_return
+ end
+.end
-_reverse:
- pushp
- pushi
- restore P0
- set I0, P0
- dec I0
- set I1, 0
- new P1, .PerlArray
-__reverse_loopstart:
- set P2, P0[I0]
- set P1[I1], P2
- inc I1
- dec I0
- le 0, I0, __reverse_loopstart
- save P1
- popi
- popp
- ret
+.pcc_sub _reverse non_prototyped
+ .param object orig_array
+ $I0 = orig_array
+ dec $I0
+ $I1 = 0
+ $P1 = new PerlArray
+reverse_loopstart:
+ $P2 = orig_array[$I0]
+ $P1[$I1] = $P2
+ inc $I1
+ dec $I0
+ if 0 <= $I0 goto reverse_loopstart
+ .pcc_begin_return
+ .return $P1
+ .pcc_end_return
+ end
+.end
-_join:
- saveall
- restore P3
- set I1, P3
- gt I1, 1, __join_next
+.pcc_sub _join non_prototyped
+ .param object params
+ .local int num_params
+ num_params = params
+ if num_params > 1 goto join_next
# Empty args:
- set S0, ""
- branch __join_ret
+ $S0 = ""
+ goto join_ret
# At least one arg:
-__join_next:
- set S1, P3[0] # separator
- set S0, P3[1] # accumulated string
- set I0, 2 # arg number
- branch __join_test
-__join_loopstart:
- set S2, P3[I0]
- concat S0, S1
- concat S0, S2
- inc I0
-__join_test:
- ne I1, I0, __join_loopstart
-__join_ret:
- new P2, .PerlString
- set P2, S0
- save P2
- restoreall
- ret
+join_next:
+ .local string separator
+ separator = params[0] # separator
+ $S0 = params[1] # accumulated string
+ .local int counter
+ counter = 2 # arg number
+ goto join_test
+join_loopstart:
+ $S2 = params[counter]
+ concat $S0, separator
+ concat $S0, $S2
+ inc counter
+join_test:
+ if num_params != counter goto join_loopstart
+join_ret:
+ $P2 = new PerlString
+ $P2 = $S0
+ .pcc_begin_return
+ .return $P2
+ .pcc_end_return
+ end
+.end
+
+.emit
_grep:
pushp
@@ -346,146 +348,153 @@
popp
ret
-_index:
- pushp
- pushs
- pushi
- restore P0
- set I2, P0
- lt I2, 2, __index_numarg_error
- set S0, P0[0]
- set S1, P0[1]
- set I0, 0
- new P1, .PerlInt
- set P1, I0
- lt I3, 3, __index_2_arg
- index I0, S0, S1
- set P1, I0
- branch __index_end
-__index_2_arg:
- set I1, P0[2]
- index I0, S0, S1, I1
- set P1, I0
-__index_end:
- save P1
- popi
- pops
- popp
- ret
-__index_numarg_error:
- set S0, "wrong number of args for index"
- new P0, .PerlArray
- set P0[0], S0
- save P0
- bsr _die
- branch __index_end
+.eom
-_time:
- pushn
- pushp
- new P1, .PerlNum
- time N1
- set P1, N1
- save P1
- popp
- popn
- ret
+.pcc_sub _index non_prototyped
+ .param object params
+ $I2 = params
+ if $I2 < 2 goto index_numarg_error
+ $S0 = params[0]
+ $S1 = params[1]
+ $I0 = 0
+ $P1 = new PerlInt
+ $P1 = $I0
+ if $I3 < 3 goto index_2_arg
+ index $I0, $S0, $S1
+ $P1 = $I0
+ goto index_end
+index_2_arg:
+ $I1 = params[2]
+ index $I0, $S0, $S1, $I1
+ $P1 = $I0
+index_end:
+ .pcc_begin_return
+ .return $P1
+ .pcc_end_return
+ end
+index_numarg_error:
+ $S0 = "wrong number of args for index"
+ $P0 = new PerlArray
+ $P0[0] = $S0
+ find_lex $P2, "&die"
+ .pcc_begin non_prototyped
+ .arg $P0
+ .pcc_call $P2
+pcc_ret_label:
+ .pcc_end
+ goto index_end
+.end
+
+.pcc_sub _time non_prototyped
+ $P1 = new PerlNum
+ time $N1
+ set $P1, $N1
+ .pcc_begin_return
+ .return $P1
+ .pcc_end_return
+ end
+.end
-_sleep:
- pushp
- pushi
- restore P0
- set I0, P0
- sleep I0
- popi
- popp
- ret
+.pcc_sub _sleep non_prototyped
+ .param object wait
+ $I0 = wait
+ sleep $I0
+ .pcc_begin_return
+ .pcc_end_return
+ end
+.end
-_print1:
- pushp
- restore P31
- print P31
+.pcc_sub _print1 non_prototyped
+ .param object p
+ print p
print "\n"
- popp
- ret
+ .pcc_begin_return
+ .pcc_end_return
+ end
+.end
-_print:
- pushi
- pushp
- restore P3
- set I0, P3
- set I1, 0
-_print_loopstart:
- eq I0, I1, _print_loopend
- set P0, P3[I1]
- print P0
- inc I1
- branch _print_loopstart
-_print_loopend:
- popp
- popi
- ret
+.pcc_sub _print non_prototyped
+ .param object params
+ .local int num_elem
+ .local int counter
+ num_elem = params
+ counter = 0
+print_loopstart:
+ if counter == num_elem goto print_loopend
+ $P0 = params[counter]
+ print $P0
+ inc counter
+ goto print_loopstart
+print_loopend:
+ .pcc_begin_return
+ .pcc_end_return
+ end
+.end
-_exit:
- pushp
- restore P0
- print P0
+.pcc_sub _exit non_prototyped
+ .param object message
+ print message
print "\n"
end
- ret
+.end
-_die:
- pushp
- pushi
+.pcc_sub _die non_prototyped
+ .param object params
# setup $!: ####################
- new P0, .PerlString
- restore P3
- set I0, P3
- eq I0, 0, _die_unknown
- new P1, .PerlString
- set I1, 0
-_die_loopstart:
- eq I0, I1, _die_loopend
- set P1, P3[I1]
- concat P0, P0, P1
- inc I1
- branch _die_loopstart
-_die_unknown:
- set P0, "Unknown error."
-_die_loopend:
- store_global "_SV__BANG_", P0
+ .local object dollar_bang
+ dollar_bang = new PerlString
+ .local int num_params
+ num_params = params
+ if num_params == 0 goto die_unknown
+ $P1 = new PerlString
+ .local int counter
+ counter = 0
+die_loopstart:
+ if num_params == counter goto die_loopend
+ $P1 = params[counter]
+ dollar_bang = dollar_bang . $P1
+ inc counter
+ goto die_loopstart
+die_unknown:
+ dollar_bang = "Unknown error."
+die_loopend:
+ store_global "_SV__BANG_", dollar_bang
# Look for a CATCH handler: ###
- find_global P1, "_AV_catchers"
- set I0, P1
- eq I0, 0, _die_nohandler
+ .local object try_stack
+ find_global try_stack, "_AV_catchers"
+ $I0 = try_stack
+ if $I0 == 0 goto die_nohandler
# Remove top catch handler
- dec I0
- set P0, P1[I0]
- set P1, I0
- store_global "_AV_catchers", P1
-# Implicitly refers to continuation in P0
- invoke
-_die_nohandler:
- print P0
+ dec $I0
+ $P0 = try_stack[$I0]
+ try_stack = $I0
+ store_global "_AV_catchers", try_stack
+ invoke $P0
+
+die_nohandler:
+ print dollar_bang
print "\nDied (no handler).\n"
end
- ret
+.end
-_warn:
- bsr _print
- ret
+.pcc_sub _warn non_prototyped
+ .param object params
+ find_lex $P0, "&print"
+ .pcc_begin non_prototyped
+ .arg params
+ .pcc_call $P0
+warn_ret_label:
+ .result $P1
+ .pcc_end
+ .pcc_begin_return
+ .return $P1
+ .pcc_end_return
+.end
-__CALL_CLOSURE:
- pushp
- restore P0
- restore P1
- save P1
- invoke
- popp
- ret
+.emit
__setup:
save P0 # == argv
@@ -526,32 +535,31 @@
popp
ret
-__install_catch:
- pushp
- pushi
- # gross continuation-creating sequence:
- restore P0
- find_global P2, "_AV_catchers"
- set I1, P2
- set P2[I1], P0
- store_global "_AV_catchers", P2
- popi
- popp
- ret
+.eom
-__pop_catch:
- pushp
- pushi
- find_global P2, "_AV_catchers"
- set I1, P2
- dec I1
- set P2, I1
- store_global "_AV_catchers", P2
- popi
- popp
- ret
+.pcc_sub _install_catch non_prototyped
+ .param object continuation
+ .local object try_stack
+ find_global try_stack, "_AV_catchers"
+ $I1 = try_stack
+ try_stack[$I1] = continuation
+ store_global "_AV_catchers", try_stack
+ .pcc_begin_return
+ .pcc_end_return
+ end
+.end
-.eom
+.pcc_sub _pop_catch non_prototyped
+ .local object try_stack
+ find_global try_stack, "_AV_catchers"
+ $I1 = try_stack
+ dec $I1
+ try_stack = $I1
+ store_global "_AV_catchers", try_stack
+ .pcc_begin_return
+ .pcc_end_return
+ end
+.end
END
Index: languages/perl6/P6C/IMCC.pm
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/P6C/IMCC.pm,v
retrieving revision 1.26
diff -u -r1.26 IMCC.pm
--- languages/perl6/P6C/IMCC.pm 22 May 2003 10:51:21 -0000 1.26
+++ languages/perl6/P6C/IMCC.pm 19 Aug 2003 01:27:43 -0000
@@ -162,8 +162,30 @@
die "Must define main" unless $funcs{main};
print <<'END';
.sub __main
+ new_pad 0
call __setup
- call _main
+END
+ # XXX: This is hackish. The builtins should really be global multimethods,
+ # and closures shouldn't be excluded by name. This'll do until it can be
+ # refactored to use imcc lexicals and globals everywhere.
+
+ foreach my $name (keys %funcs) {
+ next if $name =~ /closure/;
+ my $mangled_name = mangled_name($name);
+ my $local_name = $name . "_sub";
+ my $lexical_name = "&" . $name;
+ print <<END;
+ .local Sub $local_name
+ newsub $local_name, .Sub, $mangled_name
+ store_lex -1, "$lexical_name", $local_name
+END
+ }
+ print <<'END';
+ .pcc_begin non_prototyped
+ .pcc_call main_sub
+main_ret_label:
+ .pcc_end
+ pop_pad
end
.end
END
@@ -175,7 +197,7 @@
next;
}
$name = mangled_name($name);
- print ".sub $name\n";
+ print ".pcc_sub $name non_prototyped\n";
$sub->emit;
print ".end\n";
}
@@ -839,13 +861,15 @@
my ($thing, $args) = @_;
my $argval = $args ? $args->val : newtmp('PerlArray');
my $func = $thing->val;
+ my $ret_label = genlabel 'ret_label';
my $ret = gentmp 'pmc';
code(<<END);
+ .pcc_begin non_prototyped
.arg $argval
- # .arg $func
- # call __CALL_CLOSURE
- invoke $func
+ .pcc_call $func
+$ret_label:
.result $ret
+ .pcc_end
END
return $ret;
}
@@ -985,10 +1009,6 @@
sub emit {
my $x = shift;
- print <<END;
- saveall
-# Parameters:
-END
foreach (@{$x->args}) {
my ($t, $pname) = @$_;
my $ptype = P6C::IMCC::paramtype($t);
@@ -1017,8 +1037,7 @@
}
print $x->{code};
print <<END;
- restoreall
- ret
+ end
END
}
@@ -1592,7 +1611,9 @@
$ret = $x->block->val;
unless ($ctx->{noreturn}) {
code(<<END);
+ .pcc_begin_return
.return $ret
+ .pcc_end_return
END
emit_label type => 'return';
}
@@ -1621,7 +1642,9 @@
unless ($ctx->{noreturn}) {
code(<<END);
+ .pcc_begin_return
.return $ret
+ .pcc_end_return
END
emit_label type => 'return' unless $ctx->{noreturn};
}
Index: languages/perl6/P6C/IMCC/prefix.pm
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/P6C/IMCC/prefix.pm,v
retrieving revision 1.15
diff -u -r1.15 prefix.pm
--- languages/perl6/P6C/IMCC/prefix.pm 25 Jun 2003 13:05:46 -0000 1.15
+++ languages/perl6/P6C/IMCC/prefix.pm 19 Aug 2003 01:27:44 -0000
@@ -189,6 +189,12 @@
my ($x) = @_;
my $func = $P6C::IMCC::funcs{$x->name};
my $ctx = $x->{ctx};
+
+ my $subname = "&" . $x->name;
+ my $subtmp = gentmp 'pmc';
+ code(<<END);
+ find_lex $subtmp, "$subname"
+END
if ($x->args) {
my $args = $x->args->val;
@@ -203,13 +209,24 @@
.", expected "[EMAIL PROTECTED]>args};
}
- foreach (reverse @$args) {
+ code(<<END);
+ .pcc_begin non_prototyped
+END
+ foreach (@$args) {
code("\t.arg $_\n");
}
+ } else {
+ code(<<END);
+ .pcc_begin non_prototyped
+END
}
- my $mname = P6C::IMCC::mangled_name($x->name);
- code("\tcall $mname\n");
+
+ my $ret_label = genlabel 'ret_label';
+ code(<<END);
+ .pcc_call $subtmp
+$ret_label:
+END
# Now handle return value.
@@ -225,12 +242,16 @@
.result $results[$i]
END
}
+ code(<<END);
+ .pcc_end
+END
return tuple_in_context([EMAIL PROTECTED], $ctx);
} elsif ($rettype eq 'PerlArray') {
my $ret = gentmp 'pmc';
code(<<END);
.result $ret
+ .pcc_end
END
# XXX: this is not nice, but it's more useful than returning
# array-lengths.
@@ -257,6 +278,7 @@
my $ret = gentmp 'pmc';
code(<<END);
.result $ret
+ .pcc_end
END
return scalar_in_context($ret, $ctx);
@@ -550,6 +572,9 @@
my $try = genlabel 'try';
my $cont = newtmp 'Continuation';
my $label = $endblock;
+ my $subtmp = gentmp 'pmc';
+ my $startcatch = genlabel 'ret_label';
+ my $endcatch = genlabel 'ret_label';
my $catch;
my $result;
my $ret = gentmp 'pmc';
@@ -561,8 +586,12 @@
code(<<END);
$addr = addr $label
$cont = $addr
+ find_lex $subtmp, "&install_catch"
+ .pcc_begin non_prototyped
.arg $cont
- call __install_catch
+ .pcc_call $subtmp
+$startcatch:
+ .pcc_end
goto $try
END
if ($catcher) {
@@ -616,7 +645,11 @@
}
# Reached end of block => no exception. Pop the continuation.
code(<<END);
- call __pop_catch
+ find_lex $subtmp, "&pop_catch"
+ .pcc_begin non_prototyped
+ .pcc_call $subtmp
+$endcatch:
+ .pcc_end
$endblock:
END
return $ret;
@@ -717,6 +750,7 @@
emit_label name => $label, type => 'break';
pop_scope;
+ return undef_in_context($x->{ctx});
}
sub prefix_defined {
