From 4fcb9abfa0eb1adac3daa1bddbb74a4ec9626253 Mon Sep 17 00:00:00 2001 From: Stefan O'Rear Date: Thu, 15 Jul 2010 04:28:38 -0700 Subject: [PATCH] Move Decl to CgOp --- Body.pm | 53 ++++++++-------- CgOp.pm | 79 +++++++++++++++++++++++ Decl.pm | 189 +++++++++++++++++++++++++------------------------------- Unit.pm | 4 +- 4 files changed, 192 insertions(+), 133 deletions(-) diff --git a/Body.pm b/Body.pm index d5be864c..cf78f975 100644 --- a/Body.pm +++ b/Body.pm @@ -2,6 +2,7 @@ use strict; use warnings; use 5.010; use CodeGen (); +use CgOp (); { package Body; @@ -32,7 +33,7 @@ use CodeGen (); sub do_enter { my ($self, $cg) = @_; $cg->lextypes($_, 'Variable') for keys %{ $self->lexical }; - $_->do_enter($cg, $self) for @{ $self->decls }; + $_->enter_code($self)->var_cg($cg) for @{ $self->decls }; $self->signature->gen_binder($cg) if $self->signature; for (@{ $self->enter }) { CgOp::sink($_->code($self))->var_cg($cg); @@ -45,9 +46,9 @@ use CodeGen (); $_->write($self) for (@{ $self->decls }); } - sub do_preinit { - my ($self, $cg) = @_; - $_->do_preinit($cg, $self) for @{ $self->decls }; + sub preinit_code { + my ($self) = @_; + CgOp::prog(map { $_->preinit_code($self) } @{ $self->decls }); } __PACKAGE__->meta->make_immutable; @@ -65,40 +66,38 @@ use CodeGen (); has 'augmenting' => (is => 'ro', isa => 'Bool', default => 0); sub makeproto { - my ($self, $cg) = @_; - $cg->lextypes('!plist', 'List'); - $cg->clr_new('List', 0); - $cg->lexput(0, '!plist'); + my ($self) = @_; + my @p; + push @p, CgOp::lextypes('!plist', 'List'); + push @p, CgOp::lexput(0, '!plist', + CgOp::rawnew('List')); for my $super (@{ $self->super }) { - $cg->lexget(0, '!plist'); - $cg->scopelexget($super, $self); - $cg->fetch; - $cg->cast('DynObject'); - $cg->clr_field_get('klass'); - $cg->clr_call_virt('Add', 1); + push @p, CgOp::rawcall(CgOp::lexget(0, '!plist'), 'Add', + CgOp::getfield('klass', + CgOp::cast('DynObject', + CgOp::fetch(CgOp::scopedlex($super))))); } - $cg->lexget(1, $self->var . '!HOW'); - $cg->dup_fetch; - $cg->callframe; - $cg->clr_wrap; - $cg->lexget(0, '!plist'); - $cg->clr_wrap; - $cg->call_method(1, "create-protoobject", 2); - $cg->lexput(1, $self->var); + push @p, CgOp::lexput(1, $self->var, + CgOp::methodcall( + CgOp::lexget(1, $self->var . '!HOW'), 'create-protoobject', + CgOp::wrap(CgOp::callframe), + CgOp::wrap(CgOp::lexget(0, '!plist')))); + CgOp::prog(@p); } before do_enter => sub { my ($self, $cg) = @_; $cg->share_lex('!scopenum'); - $self->makeproto($cg); + $self->makeproto->var_cg($cg); }; - around do_preinit => sub { - my ($o, $self, $cg) = @_; + around preinit_code => sub { + my ($o, $self) = @_; $self->lexical->{'!scopenum'} = 1; - $o->($self, $cg); - $self->makeproto($cg); + CgOp::prog( + $o->($self), + $self->makeproto); }; __PACKAGE__->meta->make_immutable; diff --git a/CgOp.pm b/CgOp.pm index 7749fe07..9761a543 100644 --- a/CgOp.pm +++ b/CgOp.pm @@ -92,6 +92,10 @@ use warnings; CgOp::NIL->new(ops => [ @_ ]); } + sub noop { + CgOp::NIL->new(ops => []); + } + sub null { CgOp::NIL->new(ops => [[ push_null => $_[0] ]]); } @@ -128,6 +132,10 @@ use warnings; CgOp::NIL->new(ops => [ $_[0], [ 'newscalar' ] ]); } + sub newrwscalar { + CgOp::NIL->new(ops => [ $_[0], [ 'newrwscalar' ] ]); + } + sub string_var { CgOp::NIL->new(ops => [ [ 'string_var', $_[0] ] ]); } @@ -152,6 +160,14 @@ use warnings; CgOp::NIL->new(ops => [[ scopelexget => $_[0] ]]); } + sub lexput { + CgOp::NIL->new(ops => [ $_[2], [ lexput => $_[0], $_[1] ]]); + } + + sub lexget { + CgOp::NIL->new(ops => [[ lexget => $_[0], $_[1] ]]); + } + sub subcall { my ($sub, @args) = @_; CgOp::NIL->new(ops => [ $sub, @args, [ 'call_sub', 1, scalar @args ] ]); @@ -163,6 +179,69 @@ use warnings; [ 'call_method', 1, $name, scalar @args ] ]); } + sub callframe { + CgOp::NIL->new(ops => [[ 'callframe' ]]); + } + + sub aux { + CgOp::NIL->new(ops => [[ 'peek_aux', $_[0] ]]); + } + + sub clr_string { + CgOp::NIL->new(ops => [[ 'clr_string', $_[0] ]]); + } + + sub lextypes { + CgOp::NIL->new(ops => [[ 'lextypes', @_ ]]); + } + + sub share_lex { + CgOp::NIL->new(ops => [[ 'share_lex', $_[0] ]]); + } + + sub copy_lex { + CgOp::NIL->new(ops => [[ 'copy_lex', $_[0] ]]); + } + + sub clone_lex { + CgOp::NIL->new(ops => [[ 'clone_lex', $_[0] ]]); + } + + sub proto_var { + CgOp::NIL->new(ops => [ $_[1], [ 'proto_var', $_[0] ]]); + } + + sub rawscall { + my ($name, @args) = @_; + CgOp::NIL->new(ops => [ @args, [ 'clr_call_direct', $name, scalar @args ] ]); + } + + sub rawcall { + my ($inv, $name, @args) = @_; + CgOp::NIL->new(ops => [ $inv, @args, [ 'clr_call_virt', $name, scalar @args ] ]); + } + + sub rawsget { + CgOp::NIL->new(ops => [[ 'clr_sfield_get', $_[0] ]]); + } + + sub rawnew { + my ($name, @args) = @_; + CgOp::NIL->new(ops => [ @args, [ 'clr_new', $name, scalar @args ] ]); + } + + sub protosub { + my ($body, @extra) = @_; + CgOp::NIL->new(ops => [ [ 'open_protopad', $body ], @extra, + $body->preinit_code, [ 'close_sub', $body->code ] ]); + } + + sub with_aux { + my ($name, $value, @stuff) = @_; + CgOp::NIL->new(ops => [ $value, [ 'push_aux', $name ], @stuff, + [ 'pop_aux', $name ], [ 'drop' ] ]); + } + sub ternary { CgOp::Ternary->new( check => $_[0], diff --git a/Decl.pm b/Decl.pm index c817430d..b34dcdf3 100644 --- a/Decl.pm +++ b/Decl.pm @@ -2,13 +2,15 @@ use strict; use warnings; use 5.010; +use CgOp; + { package Decl; use Moose; - sub do_preinit {} - sub do_enter {} - sub write {} + sub preinit_code { CgOp::noop } + sub enter_code { CgOp::noop } + sub write {} __PACKAGE__->meta->make_immutable; no Moose; @@ -23,24 +25,18 @@ use 5.010; has code => (isa => 'Body', is => 'ro', required => 1); has shared => (isa => 'Bool', is => 'ro', default => 0); - sub do_preinit { - my ($self, $cg, $body) = @_; + sub preinit_code { + my ($self, $body) = @_; $self->code->outer($body); - $cg->open_protopad($self->code); - $self->code->do_preinit($cg); - $cg->close_sub($self->code->code); - $cg->call_sub($self->has_var, 0); - $cg->proto_var($self->var) if $self->has_var; + my $c = CgOp::subcall(CgOp::protosub($self->code)); + $self->has_var ? CgOp::proto_var($self->var, $c) : CgOp::sink($c); } - sub do_enter { - my ($self, $cg, $body) = @_; - return unless $self->has_var; - if ($self->shared) { - $cg->share_lex($self->var); - } else { - $cg->copy_lex($self->var); - } + sub enter_code { + my ($self, $body) = @_; + !$self->has_var ? CgOp::noop : + $self->shared ? CgOp::share_lex($self->var) : + CgOp::copy_lex($self->var); } sub write { @@ -61,19 +57,17 @@ use 5.010; has var => (isa => 'Str', is => 'ro', required => 1); has code => (isa => 'Body', is => 'ro', required => 1); - sub do_preinit { - my ($self, $cg, $body) = @_; + sub preinit_code { + my ($self, $body) = @_; $self->code->outer($body); - $cg->open_protopad($self->code); - $self->code->do_preinit($cg); - $cg->close_sub($self->code->code); - $cg->newscalar; - $cg->proto_var($self->var); + + CgOp::proto_var($self->var, CgOp::newscalar( + CgOp::protosub($self->code))); } - sub do_enter { + sub enter_code { my ($self, $cg, $body) = @_; - $cg->clone_lex($self->var); + CgOp::clone_lex($self->var); } sub write { @@ -93,17 +87,17 @@ use 5.010; has slot => (isa => 'Str', is => 'ro', required => 1); - sub do_preinit { - my ($self, $cg, $body) = @_; - $cg->scopelexget('Any'); - $cg->fetch; - $cg->newrwscalar; - $cg->proto_var($self->slot); + sub preinit_code { + my ($self, $body) = @_; + + CgOp::proto_var($self->slot, + CgOp::newrwscalar(CgOp::fetch(CgOp::scopedlex('Any')))); } - sub do_enter { - my ($self, $cg, $body) = @_; - $cg->copy_lex($self->slot); + sub enter_code { + my ($self, $body) = @_; + + CgOp::copy_lex($self->slot); } sub write { @@ -119,32 +113,29 @@ use 5.010; use Moose; extends 'Decl'; - sub do_preinit { - my ($self, $cg, $body) = @_; - $cg->clr_sfield_get('Kernel.MainlineContinuation'); - $cg->push_null('Frame'); - $cg->push_null('Frame'); - $cg->clr_call_direct('Kernel.MakeSub', 3); - - $cg->peek_aux('protopad'); - $cg->newscalar; - $cg->call_sub(1, 1); - $cg->proto_var('!mainline'); + sub preinit_code { + my ($self, $body) = @_; + # XXX ought not to have side effects here. $::SETTING_RESUME = $body; + + CgOp::proto_var('!mainline', + CgOp::subcall( + CgOp::rawscall('Kernel.MakeSub', + CgOp::rawsget('Kernel.MainlineContinuation'), + CgOp::null('Frame'), CgOp::null('Frame')), + CgOp::newscalar(CgOp::aux('protopad')))); } - sub do_enter { + sub enter_code { my ($self, $cg, $body) = @_; - $cg->clone_lex('!mainline'); + CgOp::clone_lex('!mainline'); } __PACKAGE__->meta->make_immutable; no Moose; } -# XXX I hate this code. It's seriously ugly. Maybe decls should generate ops, -# instead of needing to use the codegen directly. { package Decl::Class; use Moose; @@ -159,56 +150,47 @@ use 5.010; # preinit has body => (is => 'ro', isa => 'Body::Class'); - sub do_preinit { - my ($self, $cg, $body) = @_; + sub preinit_code { + my ($self, $body) = @_; + if ($self->stub) { - $cg->push_null('Variable'); - $cg->proto_var($self->var); - $cg->push_null('Variable'); - $cg->proto_var($self->var . '!HOW'); - return; + return CgOp::prog( + CgOp::proto_var($self->var . '!HOW', CgOp::null('Variable')), + CgOp::proto_var($self->var, CgOp::null('Variable'))); } - $cg->scopelexget("ClassHOW", $body); - $cg->dup_fetch; - $cg->clr_string($self->name // 'ANON'); - $cg->clr_wrap; - $cg->call_method(1, "new", 1); - $cg->push_aux('how'); - $cg->peek_aux('how'); - $cg->proto_var($self->var . '!HOW'); - - # TODO: Initialize the protoobject to a failure here so an awesome error - # is produced if someone tries to use an incomplete class in a BEGIN. - $cg->push_null('Variable'); - $cg->proto_var($self->var); $self->body->outer($body); $self->body->var($self->var); - $cg->open_protopad($self->body); + CgOp::with_aux("how", + CgOp::methodcall(CgOp::scopedlex("ClassHOW"), "new", + CgOp::wrap(CgOp::clr_string($self->name // 'ANON'))), - $cg->peek_aux('how'); - $cg->dup_fetch; - $cg->callframe; - $cg->clr_wrap; - $cg->call_method(1, "push-scope", 1); - $cg->proto_var('!scopenum'); + CgOp::proto_var($self->var . '!HOW', CgOp::aux("how")), - $self->body->do_preinit($cg); - $cg->close_sub($self->body->code); - $cg->newscalar; - $cg->proto_var($self->var . '!BODY'); + # TODO: Initialize the protoobject to a failure here so an awesome + # error is produced if someone tries to use an incomplete class in + # a BEGIN. + CgOp::proto_var($self->var, CgOp::null('Variable')), + + CgOp::proto_var($self->var . '!BODY', + CgOp::newscalar( + CgOp::protosub($self->body, + CgOp::proto_var('!scopenum', + CgOp::methodcall(CgOp::aux('how'), + "push-scope", + CgOp::wrap(CgOp::callframe))))))); } - sub do_enter { - my ($self, $cg, $body) = @_; - $cg->share_lex($self->var . '!HOW'); - if ($self->stub) { - $cg->share_lex($self->var); - } else { - $cg->clone_lex($self->var . '!BODY'); - } + sub enter_code { + my ($self, $body) = @_; + CgOp::prog( + CgOp::share_lex($self->var . '!HOW'), + ($self->stub ? + CgOp::share_lex($self->var) : + CgOp::clone_lex($self->var . '!BODY'))); } + sub write { my ($self, $body) = @_; return unless $self->body; @@ -229,19 +211,17 @@ use 5.010; has name => (is => 'ro', isa => 'Str', required => 1); has var => (is => 'ro', isa => 'Str', required => 1); - sub do_preinit { - my ($self, $cg, $body) = @_; + sub preinit_code { + my ($self, $body) = @_; if (!$body->isa('Body::Class')) { #TODO: Make this a sorry. die "Tried to set a method outside a class!"; } - $cg->peek_aux('how'); - $cg->dup_fetch; - $cg->clr_string($self->name); - $cg->clr_wrap; - $cg->scopelexget('!scopenum'); - $cg->scopelexget($self->var); - $cg->call_method(0, "add-scoped-method", 3); + CgOp::sink( + CgOp::methodcall(CgOp::aux("how"), "add-scoped-method", + CgOp::wrap(CgOp::clr_string($self->name)), + CgOp::scopedlex('!scopenum'), + CgOp::scopedlex($self->var))); } __PACKAGE__->meta->make_immutable; @@ -255,8 +235,8 @@ use 5.010; has name => (is => 'ro', isa => 'Str', required => 1); - sub do_preinit { - my ($self, $cg, $body) = @_; + sub preinit_code { + my ($self, $body) = @_; if (!$body->isa('Body::Class')) { #TODO: Make this a sorry. die "Tried to set a superclass outside a class!"; @@ -266,10 +246,9 @@ use 5.010; } push @{ $body->super }, $self->name; - $cg->peek_aux('how'); - $cg->dup_fetch; - $cg->scopelexget($self->name . "!HOW", $body); - $cg->call_method(0, "add-super", 1); + CgOp::sink( + CgOp::methodcall(CgOp::aux('how'), "add-super", + CgOp::scopedlex($self->name . "!HOW", $body))); } __PACKAGE__->meta->make_immutable; diff --git a/Unit.pm b/Unit.pm index e12557d3..022499fb 100644 --- a/Unit.pm +++ b/Unit.pm @@ -30,7 +30,9 @@ use 5.010; $cg->push_aux('protopad'); $cg->open_protopad($self->mainline); $self->mainline->outer($self->setting) if $self->setting; - $self->mainline->do_preinit($cg); + my $c = $self->mainline->preinit_code; + #say STDERR YAML::XS::Dump($c); + $c->var_cg($cg); $cg->close_sub($self->mainline->code); $cg->newscalar; $cg->return(1);