Hi,
this is my first patch ever (not just p6i: ever). So do tell me
what I have done wrong.
This is a patch for one of the ToDo items in languages/perl6/Todo. I have
updated the calling conventions in a bunch of places, but may have missed
some.
One more subtest is failing because of my changes , but I believe it just
happened to be succeding so far. I think this is the case because the
place where things differ in the generated t/compiler/call_13.imc, in the
unpatched version the line is:
.arg $P37 # dummy value for unpassed param $a (FIXME)
BTW, should I keep working on P6C? As A12 has just come out P6C may be
heavily under construction, and I don't want to be in the way...
--Abhijit
Abhijit A. Mahabal http://www.cs.indiana.edu/~amahabal/
Index: languages/perl6/P6C/Builtins.pm
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/P6C/Builtins.pm,v
retrieving revision 1.22
diff -u -r1.22 Builtins.pm
--- languages/perl6/P6C/Builtins.pm 29 Jan 2004 06:18:27 -0000 1.22
+++ languages/perl6/P6C/Builtins.pm 5 May 2004 19:39:14 -0000
@@ -98,7 +98,7 @@
print <<'END';
-.pcc_sub _substr non_prototyped
+.sub _substr non_prototyped
.param pmc params
$P0 = params
# n paras
@@ -142,17 +142,12 @@
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
+ _die($P0)
goto substr_ret
end
.end
-.pcc_sub _length non_prototyped
+.sub _length non_prototyped
.param pmc s
$S0 = s
length $I0, $S0
@@ -164,7 +159,7 @@
end
.end
-.pcc_sub _reverse non_prototyped
+.sub _reverse non_prototyped
.param pmc orig_array
$I0 = orig_array
dec $I0
@@ -182,7 +177,7 @@
end
.end
-.pcc_sub _join non_prototyped
+.sub _join non_prototyped
.param pmc params
.local int num_params
num_params = params
@@ -214,7 +209,7 @@
end
.end
-.pcc_sub _index non_prototyped
+.sub _index non_prototyped
.param pmc params
$I2 = params
if $I2 < 2 goto index_numarg_error
@@ -240,44 +235,32 @@
$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
+ _die($P0)
goto index_end
.end
-.pcc_sub _time non_prototyped
+.sub _time non_prototyped
$P1 = new PerlNum
time $N1
set $P1, $N1
.pcc_begin_return
.return $P1
.pcc_end_return
- end
.end
-.pcc_sub _sleep non_prototyped
+.sub _sleep non_prototyped
.param pmc wait
$I0 = wait
sleep $I0
- .pcc_begin_return
- .pcc_end_return
- end
.end
-.pcc_sub _print1 non_prototyped
+.sub _print1 non_prototyped
.param object p
print p
print "\n"
- .pcc_begin_return
- .pcc_end_return
- end
.end
-.pcc_sub _print non_prototyped
+.sub _print non_prototyped
.param pmc params
.local int num_elem
.local int counter
@@ -290,19 +273,16 @@
inc counter
goto print_loopstart
print_loopend:
- .pcc_begin_return
- .pcc_end_return
- end
.end
-.pcc_sub _exit non_prototyped
+.sub _exit non_prototyped
.param object message
print message
print "\n"
end
.end
-.pcc_sub _die non_prototyped
+.sub _die non_prototyped
.param object params
# setup $!: ####################
@@ -344,21 +324,15 @@
end
.end
-.pcc_sub _warn non_prototyped
+.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
+ $P1 = _print(params)
.pcc_begin_return
.return $P1
.pcc_end_return
.end
-.pcc_sub _grep non_prototyped
+.sub _grep non_prototyped
.param Sub condition
.param pmc params
.local int tmp
@@ -377,12 +351,7 @@
tmp = params
ge ii, tmp, __grep_loop_end
element = params[ii]
- .pcc_begin non_prototyped
- .arg element
- .pcc_call condition
-__grep_closure_return:
- .result comparison_result
- .pcc_end
+ comparison_result = condition(element)
unless comparison_result, __grep_next
push result_list, element
__grep_next:
@@ -396,19 +365,17 @@
set S0, "wrong number of args for grep"
condition = new PerlArray
set condition[0], S0
- save condition
- bsr _die
+ _die(condition)
branch __grep_loop_end
__grep_die_arg1:
set S0, "First argument to grep must be a closure"
condition = new PerlArray
set condition[0], S0
- save condition
- bsr _die
+ _die(condition)
branch __grep_loop_end
.end
-.pcc_sub _map non_prototyped
+.sub _map non_prototyped
.param pmc params
$P2 = new PerlArray
set $I3, params
@@ -426,8 +393,7 @@
$P5 = new PerlArray
set $P5, 1
set $P5[0], $P3
- save $P5
- bsr __map_closure
+ __map_closure($P5)
### restore $P4
set $I3, $P4
lt $I3, 1, __map_check_end
@@ -451,15 +417,13 @@
set S0, "wrong number of args for map"
$P0 = new PerlArray
set $P0[0], S0
- save $P0
- bsr _die
+ _die($P0)
branch __map_loop_end
__map_die_arg1:
set S0, "First argument to map must be a closure"
$P0 = new PerlArray
set $P0[0], S0
- save $P0
- bsr _die
+ _die($P0)
branch __map_loop_end
__map_closure:
pushp
@@ -507,31 +471,26 @@
ret # Only called from top level
.end
-.pcc_sub _install_catch non_prototyped
+.sub _install_catch non_prototyped
.param pmc continuation
.local pmc 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
-.pcc_sub _pop_catch non_prototyped
+.sub _pop_catch non_prototyped
.local pmc 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
}
1;
+
Index: languages/perl6/P6C/IMCC.pm
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/P6C/IMCC.pm,v
retrieving revision 1.34
diff -u -r1.34 IMCC.pm
--- languages/perl6/P6C/IMCC.pm 29 Apr 2004 07:00:58 -0000 1.34
+++ languages/perl6/P6C/IMCC.pm 5 May 2004 19:39:15 -0000
@@ -192,11 +192,7 @@
END
}
print <<'END';
- .pcc_begin prototyped # Was non_prototyped
- .arg P5
- .pcc_call main_sub
-main_ret_label:
- .pcc_end
+ main_sub(P5)
pop_pad
end
.end
@@ -209,7 +205,7 @@
next;
}
$name = mangled_name($name);
- print ".pcc_sub $name prototyped\n";
+ print ".sub $name prototyped\n";
$sub->emit;
print ".end\n";
}
@@ -1035,13 +1031,7 @@
my $ret_label = genlabel 'ret_label';
my $ret = gentmp 'pmc';
code(<<END);
- .pcc_begin non_prototyped # closure
- .arg $dummy_named
- .arg $argval
- .pcc_call $func
-$ret_label:
- .result $ret
- .pcc_end
+ $ret = $func($dummy_named, $argval)
END
return $ret;
}
Index: languages/perl6/P6C/IMCC/prefix.pm
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/P6C/IMCC/prefix.pm,v
retrieving revision 1.21
diff -u -r1.21 prefix.pm
--- languages/perl6/P6C/IMCC/prefix.pm 5 Feb 2004 15:32:20 -0000 1.21
+++ languages/perl6/P6C/IMCC/prefix.pm 5 May 2004 19:39:15 -0000
@@ -197,6 +197,7 @@
sub gen_sub_call {
my ($x, %options) = @_;
my $ctx_of_call = $x->{ctx};
+ my $call_string;
my $func = $P6C::IMCC::funcs{$x->name}; # May not be found
if (!defined($func)) {
@@ -291,12 +292,12 @@
if ($am_flattening) {
die "ERROR: found non-flattened param after a flattened
param\n";
}
- push @positional_stmts, "\t.arg $val # param ($desc)";
+ push @positional_stmts, $val; # param ($desc)
}
} else {
# Push some sentinel value
# FIXME: What if we are flattening?
- push @positional_stmts, "\t.arg 0 # unfilled (FIXME) param = $desc";
+ push @positional_stmts, 0; # unfilled (FIXME) param = $desc
}
} continue {
$i++;
@@ -306,7 +307,7 @@
while ($i < $params->max_nonslurpy_positional) {
my $param = $params->indexed_param($i++);
my $desc = $param->var->name;
- push(@positional_stmts, "\t.arg $undef # dummy value for unpassed param
$desc (FIXME)");
+ push(@positional_stmts, $undef); # dummy value for unpassed param $desc
(FIXME)
# FIXME: At the moment, we only search through the named
# argument list if we call without a prototype. When the
# calling code is changed so that it *does* pass through
@@ -344,22 +345,20 @@
my $mname = P6C::IMCC::mangled_name($x->name);
my $call_return = genlabel 'after_call';
+ $call_string = $subpmc;
if ($cannot_prototype) {
- code("\t.pcc_begin non_prototyped # IMCC::prefix cannot proto");
- code("\t.arg $nu_var # named args")
- unless $params->{no_named};
- code(@positional_stmts) if @positional_stmts;
- code("\t.arg $slurpy_array # slurpy array") if $slurpy_array;
+ my (@args);
+ push (@args, $nu_var) unless $params->{no_named};
+ push(@args, @positional_stmts) if @positional_stmts;
+ push (@args, $slurpy_array) if $slurpy_array;
+ $call_string .= "(" . join(", ", @args) .")";
} else {
- code("\t.pcc_begin prototyped # IMCC::prefix prototyped");
- code("\t.arg $nu_var # named args")
- unless $params->{no_named};
- code(@positional_stmts) if @positional_stmts;
-# code("\t.arg $nk_var");
- code("\t.arg $slurpy_array # slurpy array") if $slurpy_array;
+ my (@args);
+ push(@args, $nu_var) unless $params->{no_named};
+ push(@args, @positional_stmts) if @positional_stmts;
+ push(@args, $slurpy_array) if $slurpy_array;
+ $call_string .= "(" . join(", ", @args) .")";
}
- code("\t.pcc_call $subpmc");
- code("$call_return:");
} else {
code("\t.pcc_begin non_prototyped # IMCC::prefix nonprototyped");
use Carp; Carp::cluck "unimplemented";
@@ -374,22 +373,26 @@
}
if (ref($rettype) eq 'ARRAY') {
my @results = map { gentmp $_ } @$rettype;
- for my $i (0 .. $#results) {
- code("\t.result $results[$i]");
+ my $return_string = join(", ", @results);
+ $return_string = "(". $return_string. ")";
+ if (@results) {
+ code("\t$return_string = $call_string", "");
+ } else {
+ code("\t$call_string", "");
}
- code("\t.pcc_end # list return", "");
return tuple_in_context([EMAIL PROTECTED], $ctx_of_call);
} elsif ($rettype eq 'PerlArray') {
- my $ret = gentmp 'pmc';
- code("\t.result $ret");
- # XXX: this is not nice, but it's more useful than returning
- # array-lengths.
- if ($ctx_of_call->is_scalar) {
+ my $ret = gentmp 'pmc';
+ my $return_string = $ret;
+ # XXX: this is not nice, but it's more useful than returning
+ # array-lengths.
+ if ($ctx_of_call->is_scalar) {
my $itmp = gentmp 'int';
my $blech = genlabel;
my $end = genlabel;
code(<<END);
+ $ret = $call_string
$itmp = $ret
if $itmp == 0 goto $blech
dec $itmp
@@ -398,19 +401,18 @@
$blech:
$ret = new PerlUndef
$end:
- .pcc_end # array return in scalar context
+ # .pcc_end # array return in scalar context
END
return $ret;
} else {
- code("\t.pcc_end # array return in list context", "");
- return array_in_context($ret, $ctx_of_call);
+ code("\t$return_string = $call_string", "");
+ return array_in_context($ret, $ctx_of_call);
}
} elsif (is_scalar($rettype)) {
my $ret = gentmp 'pmc';
- code("\t.result $ret");
- code("\t.pcc_end # scalar return", "");
+ code("\t$ret = $call_string", "");
return scalar_in_context($ret, $ctx_of_call);
} else {
