Skip to content

Commit

Permalink
Start removing CPS helper function calls out of the primitive set
Browse files Browse the repository at this point in the history
  • Loading branch information
Stefan O'Rear committed Jul 16, 2010
1 parent dfbc2aa commit c2bd41b
Show file tree
Hide file tree
Showing 2 changed files with 35 additions and 71 deletions.
36 changes: 28 additions & 8 deletions CgOp.pm
View file
Expand Up @@ -109,7 +109,7 @@ use warnings;
}

sub wrap {
CgOp::NIL->new(ops => [ $_[0], [ 'clr_wrap' ] ]);
newscalar(rawnew('CLRImportObject', $_[0]));
}

sub unwrap {
Expand All @@ -121,7 +121,7 @@ use warnings;
}

sub fetch {
CgOp::NIL->new(ops => [ $_[0], [ 'fetch' ] ]);
rawscall("Kernel.Fetch", $_[0]);
}

sub how {
Expand Down Expand Up @@ -178,6 +178,10 @@ use warnings;
CgOp::NIL->new(ops => [ [ 'clr_int', $_[0] ] ]);
}

sub bool {
CgOp::NIL->new(ops => [ [ 'clr_bool', $_[0] ] ]);
}

sub unbox {
cast($_[0], rawscall('Kernel.UnboxAny', $_[1]));
}
Expand All @@ -187,11 +191,13 @@ use warnings;
}

sub bind {
CgOp::NIL->new(ops => [ $_[1], $_[2], [ 'bind', $_[0] ] ]);
rawscall('Kernel.Bind', $_[1], getfield('lv', $_[2]),
bool($_[0]), bool(0));
}

sub assign {
CgOp::NIL->new(ops => [ $_[0], $_[1], [ 'assign' ] ]);
rawscall('Kernel.Assign', getfield('lv', $_[0]),
getfield('lv', $_[1]));
}

sub compare {
Expand Down Expand Up @@ -222,7 +228,8 @@ use warnings;

sub methodcall {
my ($obj, $name, @args) = @_;
CgOp::NIL->new(ops => [ $obj, [ 'dup_fetch' ], @args,
CgOp::NIL->new(ops => [ $obj, [ 'dup' ],
[ 'clr_call_direct', 'Kernel.Fetch', 1 ], [ 'swap' ], @args,
[ 'call_method', 1, $name, scalar @args ] ]);
}

Expand All @@ -243,21 +250,34 @@ use warnings;
}

sub share_lex {
CgOp::NIL->new(ops => [[ 'share_lex', $_[0] ]]);
prog(
lextypes($_[0], 'Variable'),
lexput(0, $_[0], protolget($_[0])));
}

# this will need changing once @vars are implemented... or maybe something
# entirely different, I think cloning at all may be wrong
sub copy_lex {
CgOp::NIL->new(ops => [[ 'copy_lex', $_[0] ]]);
prog(
lextypes($_[0], 'Variable'),
lexput(0, $_[0], newrwscalar(fetch(protolget($_[0])))));
}

sub clone_lex {
CgOp::NIL->new(ops => [[ 'clone_lex', $_[0] ]]);
prog(
lextypes($_[0], 'Variable'),
lexput(0, $_[0], methodcall(protolget($_[0]), "clone",
newscalar(callframe))));
}

sub proto_var {
CgOp::NIL->new(ops => [ $_[1], [ 'proto_var', $_[0] ]]);
}

sub protolget {
CgOp::NIL->new(ops => [[ 'protolget', $_[0] ]]);
}

sub return {
$_[0] ?
CgOp::NIL->new(ops => [ $_[0], [ 'return', 1 ] ]) :
Expand Down
70 changes: 7 additions & 63 deletions CodeGen.pm
View file
Expand Up @@ -41,6 +41,9 @@ use 5.010;
'CLRImportObject' =>
{ val => [f => 'Object'] },

'Kernel.Bind' => [c => 'Void'],
'Kernel.Assign' => [c => 'Void'],
'Kernel.Fetch' => [c => 'IP6'],
'Kernel.NewROScalar' => [m => 'Variable'],
'Kernel.NewRWScalar' => [m => 'Variable'],
'Kernel.NewRWListVar' => [m => 'Variable'],
Expand Down Expand Up @@ -300,12 +303,6 @@ use 5.010;
$self->_emit($frame . ("outer." x $order) . "lex[" . qm($name) . "] = " . $self->_pop);
}

sub how {
my ($self) = @_;
my $v = $self->_pop;
$self->_cpscall("IP6", "$v.HOW(th)");
}

sub callframe {
my ($self) = @_;
my $frame = 'th';
Expand All @@ -317,12 +314,6 @@ use 5.010;
$self->_push("Frame", $frame);
}

sub fetch {
my ($self) = @_;
my $c = $self->_pop;
$self->_cpscall("IP6", "Kernel.Fetch(th, $c)");
}

sub dup {
my ($self) = @_;
my $c = $self->_peek;
Expand All @@ -334,13 +325,6 @@ use 5.010;
$self->_pop;
}

sub dup_fetch {
my ($self) = @_;
my $c = $self->_peek;
$self->_cpscall('IP6', "Kernel.Fetch(th, $c)");
$self->swap;
}

# the use of scalar here is a little bit wrong; semantically it's closer
# to the old notion of ¢foo. doesn't matter much since it's not exposed
# at the Perl 6 level.
Expand All @@ -350,32 +334,9 @@ use 5.010;
"new Variable(false, Variable.Context.Scalar, th.pos[$num])");
}

sub clone_lex {
sub protolget {
my ($self, $name) = @_;
$self->_push('Variable', "th.proto.lex[" . qm($name) . "]");
$self->dup_fetch;
$self->_push('Variable', "Kernel.NewROScalar(th)");
$self->call_method(1, "clone", 1);
$self->lextypes($name, 'Variable');
$self->lexput(0, $name);
}

# this will need changing once @vars are implemented... or maybe something
# entirely different, I think cloning at all may be wrong
sub copy_lex {
my ($self, $name) = @_;
$self->_push('Variable', "th.proto.lex[" . qm($name) . "]");
$self->fetch;
$self->_push('Variable', "Kernel.NewRWScalar(" . $self->_pop . ")");
$self->lextypes($name, 'Variable');
$self->lexput(0, $name);
}

sub share_lex {
my ($self, $name) = @_;
$self->_push('Variable', "th.proto.lex[" . qm($name) . "]");
$self->lextypes($name, 'Variable');
$self->lexput(0, $name);
}

sub call_method {
Expand All @@ -400,26 +361,9 @@ use 5.010;
$self->unreach(1);
}

sub clr_wrap {
my ($self) = @_;
my $v = $self->_pop;
$self->_push('Variable', "Kernel.NewROScalar(new CLRImportObject($v))");
}

sub bind {
my $self = shift;
my $ro = shift() ? "true" : "false";
my $rw = shift() ? "true" : "false";
my $rhs = $self->_pop;
my $lhs = $self->_pop;
$self->_cpscall(undef, "Kernel.Bind(th, $lhs, $rhs.lv, $ro, $rw)");
}

sub assign {
my $self = shift;
my $rhs = $self->_pop;
my $lhs = $self->_pop;
$self->_cpscall(undef, "Kernel.Assign(th, $lhs.lv, $rhs.lv)");
sub clr_bool {
my ($self, $v) = @_;
$self->_push('System.Boolean', $v ? 'true' : 'false');
}

sub clr_new {
Expand Down

0 comments on commit c2bd41b

Please sign in to comment.