Move Decl to CgOp

sorear · Jul 15, 2010 · 4fcb9ab · 4fcb9ab
1 parent 040a58b
commit 4fcb9ab
Show file tree

Hide file tree

Showing 4 changed files with 192 additions and 133 deletions.
diff --git 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<DynMetaObject>');
-        $cg->clr_new('List<DynMetaObject>', 0);
-        $cg->lexput(0, '!plist');
+        my ($self) = @_;
+        my @p;
+        push @p, CgOp::lextypes('!plist', 'List<DynMetaObject>');
+        push @p, CgOp::lexput(0, '!plist',
+            CgOp::rawnew('List<DynMetaObject>'));
 
         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
@@ -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],