Add a new tree-based IR between Op and CodeGen

The goal is to eventually deduplicate Op/Decl/Body logic, create a nicer
syntax for low-level code, and allow more CodeGen refactoring.

Body.pm

@@ -23,7 +23,7 @@ use CodeGen ();
         $self->codegen(CodeGen->new(name => $self->name, body => $self));
         my $cg = $self->codegen;
         $self->do_enter($cg);
-        $self->do->cg($cg, $self);
+        $self->do->code($self)->var_cg($cg);
         # TODO: Bind a return value here to catch non-ro sub use
         $cg->return(1) unless $cg->unreach;
         return $cg;
@@ -35,8 +35,7 @@ use CodeGen ();
         $_->do_enter($cg, $self) for @{ $self->decls };
         $self->signature->gen_binder($cg) if $self->signature;
         for (@{ $self->enter }) {
-            $_->cg($cg, $self);
-            $cg->drop;
+            CgOp::sink($_->code($self))->var_cg($cg);
         }
     }
 

CgOp.pm

@@ -0,0 +1,182 @@
+use 5.010;
+use strict;
+use warnings;
+
+
+# for transition only!
+{
+    package CgOp::NIL;
+    use Moose;
+
+    has ops => (isa => 'ArrayRef', is => 'ro');
+
+    sub var_cg {
+        my ($self, $cg) = @_;
+        for (@{ $self->ops }) {
+            if (blessed $_) {
+                $_->var_cg($cg);
+            } else {
+                my ($c, @o) = @$_;
+                $cg->$c(@o);
+            }
+        }
+    }
+
+    no Moose;
+    __PACKAGE__->meta->make_immutable;
+}
+
+{
+    package CgOp::Ternary;
+    use Moose;
+
+    has check => (is => 'ro');
+    has true  => (is => 'ro');
+    has false => (is => 'ro');
+
+    sub var_cg {
+        my ($self, $cg) = @_;
+        my $l1 = $cg->label;
+        my $l2 = $cg->label;
+
+        $self->check->var_cg($cg);
+        $cg->ncgoto($l1);
+        $self->true->var_cg($cg);
+        $cg->goto($l2);
+        $cg->labelhere($l1);
+        $self->false->var_cg($cg);
+        $cg->labelhere($l2);
+    }
+
+    no Moose;
+    __PACKAGE__->meta->make_immutable;
+}
+
+{
+    package CgOp::While;
+    use Moose;
+
+    has check => (is => 'ro');
+    has body  => (is => 'ro');
+    has once  => (is => 'ro', isa => 'Bool');
+    has until => (is => 'ro', isa => 'Bool');
+
+    sub var_cg {
+        my ($self, $cg) = @_;
+        my $lagain = $cg->label;
+        my $lcheck = $self->once ? 0 : $cg->label;
+
+        $cg->goto($lcheck) unless $self->once;
+
+        $cg->labelhere($lagain);
+        $self->body->var_cg($cg);
+
+        $cg->labelhere($lcheck) unless $self->once;
+        $self->check->var_cg($cg);
+        if ($self->until) {
+            $cg->ncgoto($lagain);
+        } else {
+            $cg->cgoto($lagain);
+        }
+    }
+
+    no Moose;
+    __PACKAGE__->meta->make_immutable;
+}
+
+# just a bunch of smart constructors
+{
+    package CgOp;
+
+    sub nil {
+        CgOp::NIL->new(ops => [ @_ ]);
+    }
+
+    sub null {
+        CgOp::NIL->new(ops => [[ push_null => $_[0] ]]);
+    }
+
+    sub prog {
+        CgOp::NIL->new(ops => [ @_ ]);
+    }
+
+    sub wrap {
+        CgOp::NIL->new(ops => [ $_[0], [ 'clr_wrap' ] ]);
+    }
+
+    sub sink {
+        CgOp::NIL->new(ops => [ $_[0], [ 'drop' ] ]);
+    }
+
+    sub fetch {
+        CgOp::NIL->new(ops => [ $_[0], [ 'fetch' ] ]);
+    }
+
+    sub how {
+        CgOp::NIL->new(ops => [ $_[0], [ 'how' ] ]);
+    }
+
+    sub getfield {
+        CgOp::NIL->new(ops => [ $_[1], [ 'clr_field_get', $_[0] ] ]);
+    }
+
+    sub cast {
+        CgOp::NIL->new(ops => [ $_[1], [ 'cast', $_[0] ] ]);
+    }
+
+    sub newscalar {
+        CgOp::NIL->new(ops => [ $_[0], [ 'newscalar' ] ]);
+    }
+
+    sub string_var {
+        CgOp::NIL->new(ops => [ [ 'string_var', $_[0] ] ]);
+    }
+
+    sub double {
+        CgOp::NIL->new(ops => [ [ 'clr_double', $_[0] ] ]);
+    }
+
+    sub unbox {
+        CgOp::NIL->new(ops => [ $_[1], [ 'unbox', $_[0] ] ]);
+    }
+
+    sub box {
+        CgOp::NIL->new(ops => [ $_[1], [ 'box', $_[0] ] ]);
+    }
+
+    sub bind {
+        CgOp::NIL->new(ops => [ $_[1], $_[2], [ 'bind', $_[0] ] ]);
+    }
+
+    sub scopedlex {
+        CgOp::NIL->new(ops => [[ scopelexget => $_[0] ]]);
+    }
+
+    sub subcall {
+        my ($sub, @args) = @_;
+        CgOp::NIL->new(ops => [ $sub, @args, [ 'call_sub', 1, scalar @args ] ]);
+    }
+
+    sub methodcall {
+        my ($obj, $name, @args) = @_;
+        CgOp::NIL->new(ops => [ $obj, [ 'dup_fetch' ], @args,
+                [ 'call_method', 1, $name, scalar @args ] ]);
+    }
+
+    sub ternary {
+        CgOp::Ternary->new(
+            check => $_[0],
+            true  => $_[1],
+            false => $_[2]);
+    }
+
+    sub whileloop {
+        CgOp::While->new(
+            until => $_[0],
+            once  => $_[1],
+            check => $_[2],
+            body  => $_[3]);
+    }
+}
+
+1;

Makefile

@@ -11,6 +11,8 @@ test: $(COMPILER) test.pl Setting.dll
 	gmcs /r:Setting.dll Program.cs
 	prove -e 'mono --debug=casts' Program.exe
 
+.DELETE_ON_ERROR:
+
 Setting.cs: $(COMPILER) setting
 	perl -MCompilerDriver=:all -e 'header; setting' > Setting.cs
 

Niecza/Actions.pm

@@ -150,7 +150,7 @@ sub nibbler { my ($cl, $M) = @_;
     if ($M->isa('STD::Regex')) {
         $M->{_ast} = $M->{EXPR}{_ast};
     } elsif ($M->isa('Niecza::Grammar::NIL')) {
-        $M->{_ast} = Op::NIL->new(code => [map { @{$_->{_ast}} } @{$M->{insn}}]);
+        $M->{_ast} = Op::NIL->new(ops => [map { @{$_->{_ast}} } @{$M->{insn}}]);
     } else {
         # garden variety nibbler
         my $str = "";