# New Ticket Created by Jürgen Bömmels
# Please include the string: [perl #23203]
# in the subject line of all future correspondence about this issue.
# <URL: http://rt.perl.org/rt2/Ticket/Display.html?id=23203 >
Hello,
this patch lies in my tree for month now, finally I got around to
finish it up:
Scheme is moved from the old bsr-based calles to the PMC-based
continuation passing style using invoke and invokecc. The function
objects are no longer 3-element-arrays but a standard Closure.
The write-builtin is not already ported to this new style, and i did
not use any tail-call optimization yet.
Also in this patch are: Test uses now parrot/imcc to assemble, foo.scm
is now a valid name for a scheme file, cond is implemented and the
linking of functions is moved out of the Generator.
There shouldn't be any problem with this, because the last bigger
patch in this area was also from me 7 month ago.
Hopefully it wont last 7 month till the next patch.
boe
-- attachment 1 ------------------------------------------------------
url: http://rt.perl.org/rt2/attach/62103/45778/bb0b89/scheme_cps.diff
Index: languages/scheme//Scheme.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme.pm,v
retrieving revision 1.1
diff -u -r1.1 Scheme.pm
--- languages/scheme//Scheme.pm 24 Oct 2001 19:27:20 -0000 1.1
+++ languages/scheme//Scheme.pm 1 Aug 2003 21:13:43 -0000
@@ -1,21 +1,54 @@
package Scheme;
+use strict;
+
use Data::Dumper;
use Scheme::Tokenizer qw(tokenize);
use Scheme::Parser qw(parse);
-use Scheme::Generator;
+use Scheme::Generator qw(generate);
+use Scheme::Builtins;
sub new {
my ($class,$file) = @_;
bless { file => $file },$class;
}
+sub link_functions {
+ my $main = shift;
+
+ my @function = ( $main );
+ my @missing = @{$main->{functions}};
+ my @provides = keys %{$main->{scope}};
+
+ my $code = $main->{code};
+
+ while (@missing) {
+ my $miss = shift @missing;
+
+ my $link = Scheme::Builtins->generate($miss);
+
+ push @function, $miss;
+
+ if ($link->{functions}) {
+ push @missing, $link->{functions};
+ }
+
+ # XXX: Move Generator::_format_columns to own class
+ Scheme::Generator::_format_columns($link);
+ $code .= $link->{code};
+ }
+
+ $code;
+}
+
sub compile {
my $self = shift;
$self->{tokens} = tokenize($self->{file});
$self->{tree} = parse($self->{tokens});
- Scheme::Generator->new($self->{tree})->generate();
+ $self->{code} = link_functions(generate($self->{tree}));
+
+ print $self->{code};
}
1;
Index: languages/scheme//schemec
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/schemec,v
retrieving revision 1.1
diff -u -r1.1 schemec
--- languages/scheme//schemec 24 Oct 2001 19:27:20 -0000 1.1
+++ languages/scheme//schemec 1 Aug 2003 21:13:43 -0000
@@ -12,6 +12,6 @@
}
defined $ARGV[0] or Usage();
-$ARGV[0]=~/.scheme$/i or Usage();
+$ARGV[0]=~/\.scheme$|\.scm$/i or Usage();
Scheme->new($ARGV[0])->compile();
Index: languages/scheme//Scheme/Builtins.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme/Builtins.pm,v
retrieving revision 1.2
diff -u -r1.2 Builtins.pm
--- languages/scheme//Scheme/Builtins.pm 12 Dec 2002 16:01:29 -0000 1.2
+++ languages/scheme//Scheme/Builtins.pm 1 Aug 2003 21:13:43 -0000
@@ -2,6 +2,9 @@
use strict;
+# nice for debugging
+use Data::Dumper;
+
my %built_ins =
(
write =>
@@ -33,34 +36,34 @@
['write_KET', 'print', '")"'],
['write_RET', 'ret'],
],
- apply =>
- [['# apply Function',''],
- ['apply_ENTRY', 'set', 'P7', 'P5[0]'],
- ['', 'push_pad', 'P7'],
- ['', 'new_pad', '-1'],
- ['', 'set', 'P7', 'P5[2]'],
- ['apply_NEXT', 'typeof', 'I0', 'P6'],
- ['', 'eq', 'I0', '.PerlUndef', 'apply_LAST'],
- ['', 'set', 'S0', 'P7[0]'],
- ['', 'set', 'P8', 'P6[0]'],
- ['', 'store_lex', '-1', 'S0', 'P8'],
- ['', 'set', 'P6', 'P6[1]'],
- ['', 'set', 'P7', 'P7[1]'],
- ['', 'branch', 'apply_NEXT'],
- ['apply_LAST', 'set', 'I0', 'P5[1]'],
- ['', 'jump', 'I0'],
- ]
);
+sub new {
+ my $class = shift;
+ my $self = {
+ instruction => []
+ };
+ bless $self, $class;
+}
+
+sub _add_inst {
+ my $self = shift;
+ push @{$self->{instruction}}, [EMAIL PROTECTED];
+}
+
sub generate {
- my ($self, $name) = @_;
+ my ($code, $name) = @_;
- die "$name: Unknown buildin\n" unless exists $built_ins{$name};
+ die "$name: Unknown builtin\n" unless exists $built_ins{$name};
+
+ my $self = Scheme::Builtins->new();
for (@{$built_ins{$name}}) {
my ($label, $op, @args) = @$_;
- $self->_add_inst ($label, $op, [ @args ]);
+ $self->_add_inst($label, $op, [ @args ]);
}
+
+ $self;
}
1;
Index: languages/scheme//Scheme/Generator.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme/Generator.pm,v
retrieving revision 1.4
diff -u -r1.4 Generator.pm
--- languages/scheme//Scheme/Generator.pm 12 Dec 2002 16:01:29 -0000 1.4
+++ languages/scheme//Scheme/Generator.pm 1 Aug 2003 21:13:44 -0000
@@ -1,6 +1,12 @@
package Scheme::Generator;
use strict;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+$VERSION = '0.01';
[EMAIL PROTECTED] = qw(Exporter);
[EMAIL PROTECTED] = qw(generate);
+
use Data::Dumper;
use Scheme::Builtins;
@@ -107,8 +113,7 @@
my ($node, $num) = @_;
$num = 1 unless defined $num;
- my @args = @{$node->{children}};
- splice @args, 0, $num;
+ my @args = splice @{$node->{children}}, $num;
return @args;
}
@@ -237,29 +242,31 @@
$return = $self->_save_1 ('P');
- $self->_add_inst ('', 'new',[$return,'.Array']);
- $self->_add_inst ('', 'set',[$return,3]);
-
- $temp = $self->_save_1 ('P');
- $self->_add_inst ('', 'peek_pad', [$temp]);
- $self->_add_inst ('', 'set',[$return.'[0]',$temp]);
- $self->_restore($temp);
+ $self->_add_inst ('', 'new',[$return,'.Closure']);
my $addr = $self->_save_1 ('I');
$self->_add_inst ('', 'set_addr',[$addr,"LAMBDA_$label"]);
- $self->_add_inst ('', 'set',[$return.'[1]',$addr]);
+ $self->_add_inst ('', 'set',[$return,$addr]);
$self->_restore ($addr);
- $temp = __quoted ($self,_get_arg($node,1));
- $self->_add_inst ('', 'set',[$return.'[2]',$temp]);
- $self->_restore ($temp);
-
$self->_add_inst ('', 'branch',["DONE_$label"]);
$self->_add_inst ("LAMBDA_$label");
# caller saved => start a new frame
push @{$self->{frames}}, $self->{regs};
$self->{regs} = _new_regs;
+ # P1 is the return contination
+ $self->{regs}{P}{1} = 1;
+
+ # expand the lexical scope
+ $self->_add_inst('', 'new_pad', [-1]);
+ my $num = 5;
+ my @args = @{_get_arg($node,1)->{children}};
+ for (@args) {
+ my $arg = $_->{value};
+ $self->_new_lex($arg, "P$num");
+ $num++
+ }
$temp = 'none';
for (_get_args($node,2)) {
@@ -270,9 +277,7 @@
$self->_add_inst('', 'set', ['P5', $temp]);
$self->_add_inst('', 'pop_pad');
- # XXX: new_pad is the only way to create a new scope
- $self->_add_inst('', 'pop_pad');
- $self->_add_inst('', 'ret');
+ $self->_add_inst('', 'invoke P1');
$self->_add_inst("DONE_$label");
$self->{regs} = pop @{$self->{frames}};
@@ -361,6 +366,30 @@
}
sub _op_cond {
+ my ($self, $node) = @_;
+
+ my @clauses = _get_args($node);
+
+ my $transnode;
+
+ if ($clauses[-1]->{children}->[0]->{value} eq 'else') {
+ my $elseclause = pop @clauses;
+ $transnode = { children => [ { value => 'begin'},
+ _get_args($elseclause) ] };
+ }
+ else {
+ $transnode = { value => '#f' };
+ }
+
+ for my $clause ( reverse @clauses ) {
+ $transnode = { children => [ { value => 'if' },
+ _get_arg($clause,0),
+ { children => [ { value => 'begin' },
+ _get_args($clause,1) ] },
+ $transnode ] };
+ }
+
+ $self->_generate($transnode);
}
sub _op_case {
@@ -1313,7 +1342,7 @@
_check_num_arg ($node, 1, 'procedure?');
- $return = self->_constant(0);
+ $return = $self->_constant(0);
my $temp = $self->_generate(_get_arg($node,1));
if ($temp =~ /^P/) {
@@ -1340,7 +1369,7 @@
$self->_add_inst ('','set',[$pair.'[1]',$argl]);
}
- $return = $self->_call_function ('apply');
+# $return = $self->_call_function ('apply');
return $return;
}
@@ -1419,7 +1448,12 @@
$self->_add_inst('','print',[$temp]);
}
else {
- $self->_call_function ('write',$temp);
+ push @{$self->{functions}}, 'write'
+ unless grep { $_ eq 'write' } @{$self->{functions}};
+ $self->_save_set;
+ $self->_add_inst('', 'set', ['P5', $temp]);
+ $self->_add_inst('', 'bsr', ['write_ENTRY']);
+ $self->_restore_set;
}
}
return $temp; # We need to return something
@@ -1782,20 +1816,21 @@
sub _call_function {
my $self = shift;
- my $func = shift;
-
- push @{$self->{functions}}, $func
- unless grep { $_ eq $func } @{$self->{functions}};
+ my $func_obj = shift;
my $return = $self->_save_1 ('P');
$self->_restore ($return); # dont need to save this
-
$self->_save_set;
my $count = 5;
my $empty = $return;
while (my $arg = shift) {
if ($arg ne "P$count") {
+ if ($arg =~ /^[INS]/) {
+ $self->_morph("P$count", $arg);
+ $count++;
+ next;
+ }
# Check if any later argument needs the old value of P$count
my $moved;
for (@_) {
@@ -1813,7 +1848,8 @@
$count++;
}
- $self->_add_inst ('', 'bsr', [$func.'_ENTRY']);
+ $self->_add_inst ('', 'set', ['P0', $func_obj]) unless $func_obj eq 'P0';
+ $self->_add_inst ('', 'invokecc');
$self->_add_inst ('', 'set', [$return,'P5']) unless $return eq 'P5';
$self->_restore_set;
@@ -1828,17 +1864,19 @@
my $colref = $self->{instruction};
my @max_len = __max_lengths($colref);
+ $self->{code} = '';
+
for my $row(@$colref) {
my $label;
$label = $row->[0]; $label .= ":" if $label;
- print $label . ' ' x ($max_len[0]-length($label)+2);
+ $self->{code} .= $label . ' ' x ($max_len[0]-length($label)+2);
if(defined $row->[1]) {
$label = $row->[1];
- print $label . ' ' x ($max_len[1]-length($label)+2);
+ $self->{code} .= $label . ' ' x ($max_len[1]-length($label)+2);
$label = $row->[2];
- print join ", ",@$label if $label;
+ $self->{code} .= join ", ",@$label if $label;
}
- print "\n";
+ $self->{code} .= "\n";
}
}
@@ -1880,15 +1918,14 @@
$return = $global_ops{$symbol}->($self, $node);
} else {
my $func_obj = $self->_find_lex ($symbol);
- my $argl = $self->_op_list ($node);
- $return = $self->_call_function('apply', $func_obj, $argl);
- $self->_restore ($func_obj, $argl);
+ my @args = map { $self->_generate($_); } _get_args($node);
+ $return = $self->_call_function($func_obj, @args);
+ $self->_restore($func_obj, @args);
}
} else {
- my $func_obj = $self->_generate ($func);
- my $argl = $self->_op_list ($node);
- $return = $self->_call_function('apply', $func_obj, $argl);
- $self->_restore ($func_obj, $argl);
+ my @args = map { $self->_generate($_); } _get_args($node, 0);
+ $return = $self->_call_function(@args);
+ $self->_restore(@args);
}
} else {
my $value = $node->{value};
@@ -1902,29 +1939,27 @@
return $return;
}
-sub _link_builtins {
- my ($self) = @_;
-
- for (@{$self->{functions}}) {
- Scheme::Builtins::generate ($self, $_);
- }
-}
-
sub generate {
- my $self = shift;
+ my $tree = shift;
+ my $self = Scheme::Generator->new({});
my $temp;
$self->{scope} = {};
$self->_add_inst ('', 'new_pad',[0]);
- $temp = $self->_generate($self->{tree});
+ $temp = $self->_generate($tree);
$self->_add_inst ('', 'pop_pad');
-#die Dumper($self->{tree});
$self->_restore($temp);
$self->_add_inst('',"end");
- $self->_link_builtins();
- $self->_format_columns();
+
+ $self->_format_columns;
+
+ # not need any more
+ $self->{instruction} = undef;
+ $self->{regs} = undef;
+
+ return $self;
}
1;
Index: languages/scheme//Scheme/Test.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme/Test.pm,v
retrieving revision 1.6
diff -u -r1.6 Test.pm
--- languages/scheme//Scheme/Test.pm 30 May 2003 17:17:26 -0000 1.6
+++ languages/scheme//Scheme/Test.pm 1 Aug 2003 21:13:45 -0000
@@ -60,8 +60,8 @@
close SCHEME; # JMG
_run_command("$PConfig{perl} schemec $scheme_f >$as_f"); # JMG
- _run_command("(cd ../.. ; $PConfig{perl} assemble.pl -o languages/scheme/$by_f languages/scheme/$as_f)"); # JMG
- _run_command( "(cd ../.. ; ./$PConfig{test_prog} languages/scheme/$by_f)", 'STDOUT' => $out_f, 'STDERR' => $out_f); # JMG
+ my $parrot = "../../parrot$PConfig{exe}";
+ _run_command( "${parrot} $as_f", 'STDOUT' => $out_f, 'STDERR' => $out_f);
my $prog_output;
open OUTPUT, "< $out_f";
