[mm] more static pad generation

sorear · Sep 25, 2010 · be34de8 · be34de8
1 parent f8d692b
commit be34de8
Show file tree

Hide file tree

Showing 2 changed files with 139 additions and 35 deletions.
diff --git a/src/CSharpBackend.pm b/src/CSharpBackend.pm
@@ -21,50 +21,142 @@ package CSharpBackend;
 our $unit;
 our %peers;
 our $nid = 0;
+our @decls;
+our @thaw;
+our @cgs;
 
 sub gsym {
     my ($type, $desc) = @_;
     $desc =~ s/(\W)/"_" . ord($1)/eg;
-    $unit->name . ".G" . ($nid++) . $desc . ':f,' . $type;
+    my $base = 'G' . ($nid++) . $desc;
+    my $full = $unit->name . "." . $base . ':f,' . $type;
+    wantarray ? ($full, $base) : $full;
 }
 
 my $st_ty = 'Dictionary<string,BValue>';
 my $cl_ty = 'DynMetaObject';
+my $si_ty = 'SubInfo';
 
 sub run {
     local $unit = shift;
     local %peers;
     local $nid = 0;
-    my @thaw;
-    my @decls;
-
-    $unit->visit_local_stashes(sub {
-        my $p = $peers{$_} = gsym($st_ty, 'STASH');
-        push @decls, $p;
-        push @thaw, CgOp::rawsset($p, CgOp::rawnew($st_ty));
-    });
-    $unit->visit_local_packages(sub {
-        return unless $_->isa('Metamodel::Class');
-        my $p = $peers{$_} = gsym($cl_ty, $_->name);
-        push @decls, $p;
-        if ($unit->is_true_setting && ($_->name eq 'Scalar' ||
-                $_->name eq 'Sub')) {
-            push @thaw, CgOp::rawsset($p,
-                CgOp::rawsget("Kernel." . $_->name . "MO:f,$cl_ty"));
-        } else {
-            push @thaw, CgOp::rawsset($p, CgOp::rawnew($cl_ty,
-                    CgOp::clr_string($_->name)));
-            for my $a (@{ $_->attributes }) {
-                push @thaw, CgOp::rawcall(CgOp::rawsget($p), 'AddAttribute',
-                    CgOp::clr_string($a));
-            }
+    local @thaw;
+    local @decls;
+    local @cgs;
+
+    # First, set up all the objects
+    # Then, fill them out
+    # this makes reference loops work.
+
+    $unit->visit_local_stashes(\&head_stash);
+    $unit->visit_local_packages(\&head_pkg);
+    $unit->visit_local_subs_preorder(\&head_sub);
+
+    +{ thaw => \@thaw, decls => \@decls, peers => \%peers };
+}
+
+sub head_stash {
+    my $p = $peers{$_} = gsym($st_ty, 'STASH');
+    push @decls, $p;
+    push @thaw, CgOp::rawsset($p, CgOp::rawnew($st_ty));
+}
+
+sub head_pkg {
+    return unless $_->isa('Metamodel::Class');
+    my $p   = $peers{$_}{mo} = gsym($cl_ty, $_->name);
+    my $whv = $peers{$_}{what_var} = gsym('Variable', $_->name . '_WHAT');
+    my $wh6 = $peers{$_}{what_ip6} = gsym('IP6', $_->name . '_WHAT');
+    push @decls, $p;
+    if ($unit->is_true_setting && ($_->name eq 'Scalar' ||
+            $_->name eq 'Sub')) {
+        push @thaw, CgOp::rawsset($p,
+            CgOp::rawsget("Kernel." . $_->name . "MO:f,$cl_ty"));
+    } else {
+        push @thaw, CgOp::rawsset($p, CgOp::rawnew($cl_ty,
+                CgOp::clr_string($_->name)));
+        for my $a (@{ $_->attributes }) {
+            push @thaw, CgOp::rawcall(CgOp::rawsget($p), 'AddAttribute',
+                CgOp::clr_string($a));
         }
-        for my $s (@{ $_->superclasses }) {
-            push @thaw, CgOp::rawcall(CgOp::rawsget($p), 'AddSuperclass',
-                CgOp::rawsget($peers{$s}));
+    }
+    for my $s (@{ $_->superclasses }) {
+        push @thaw, CgOp::rawcall(CgOp::rawsget($p), 'AddSuperclass',
+            CgOp::rawsget($peers{$s}{mo}));
+    }
+    push @thaw, CgOp::rawcall(CgOp::rawsget($p), 'Complete');
+}
+
+# lumped under a sub are all the static-y lexicals
+# protopads and proto-sub-instances need to exist early because methods, in
+# particular, bind to them
+# note: preorder
+sub head_sub {
+    my $node = ($peers{$_} = {});
+    my $si = $node->{si} = gsym($si_ty, $_->name);
+    @$node{'cref','cbase'} = gsym('DynBlockDelegate', $_->name . 'C');
+    push @decls, $si;
+
+    #my $cg = $node->{cg} = codegen_sub($_);
+
+    #push @thaw, CgOp::rawsset($si, CgOp::rawnew($si_ty,
+    #        $cg->subinfo_ctor_args));
+
+    if ($_->spad_exists) {
+        my $pp = $node->{pp} = gsym('Frame', $_->name . 'PP');
+        push @decls, $pp;
+        push @thaw, CgOp::rawsset($pp, CgOp::rawnew('Frame',
+                CgOp::null('Frame'), (!$_->outer ? CgOp::null('Frame') :
+                    CgOp::rawsget($peers{$_->outer}{pp})),
+                CgOp::null('Frame'), CgOp::rawsget($si)));
+    }
+
+    if (!$_->outer || $_->outer->spad_exists) {
+        my $ps = $node->{ps} = gsym('IP6', $_->name . 'PS');
+        push @decls, $ps;
+        push @thaw, CgOp::rawsset($ps, CgOp::rawscall('Kernel.MakeSub',
+                CgOp::rawsget($si), !$_->outer ? CgOp::null('Frame') :
+                    CgOp::rawsget($peers{$_->outer}{pp})));
+    }
+
+    for my $ln (keys %{ $_->lexicals }) {
+        my $lx = $_->lexicals->{$ln};
+
+        if ($lx->isa('Metamodel::Lexical::Common')) {
+            my $bv = $peers{$lx} = gsym('BValue', $lx->name);
+            push @decls, $bv;
+        } elsif (($lx->isa('Metamodel::Lexical::Simple') ||
+                $lx->isa('Metamodel::Lexical::SubDef')) && $_->run_once) {
+            my $sl = $peers{$lx} = gsym('Variable', $ln);
+            push @decls, $sl;
         }
-        push @thaw, CgOp::rawcall(CgOp::rawsget($p), 'Complete');
-    });
+    }
+}
 
-    +{ thaw => \@thaw, decls => \@decls, peers => \%peers };
+sub fill_sub {
+    return unless $_->spad_exists;
+    for my $ln (keys %{ $_->lexicals }) {
+        my $lx = $_->lexicals->{$ln};
+        my $frag;
+        my $forcevar;
+
+        if ($lx->isa('Metamodel::Lexical::Common')) {
+            $frag = CgOp::rawscall('Kernel.PackageLookup',
+                CgOp::rawsget($peers{$lx->stash}), CgOp::clr_string($lx->name));
+            $forcevar = 1;
+        } elsif ($lx->isa('Metamodel::Lexical::SubDef')) {
+            $frag = CgOp::rawsget($peers{$lx->body}{ps_var});
+        } elsif ($lx->isa('Metamodel::Lexical::Simple')) {
+            if ($lx->hash || $lx->list) {
+                # XXX should be SAFE::
+                my $imp = $_->find_lex($lx->hash ? 'Hash' : 'Array')->referent;
+                my $var = $peers{$imp->obj}{what_var};
+                $frag = CgOp::methodcall(CgOp::rawsget($var), 'new');
+            } else {
+                $frag = CgOp::newblankrwscalar;
+            }
+        } else {
+            next;
+        }
+    }
 }
diff --git a/src/Metamodel.pm b/src/Metamodel.pm
@@ -303,6 +303,11 @@ our $unit;
 
     has unit_closed => (isa => 'Bool', is => 'rw');
 
+    sub children {
+        map { $_->body } grep { $_->isa('Metamodel::Lexical::SubDef') }
+            values %{ $_[0]->lexicals };
+    }
+
     sub create_static_pad {
         my ($self) = @_;
 
@@ -423,12 +428,19 @@ our $unit;
     sub visit_local_subs_postorder {
         my ($self, $cb) = @_;
         our $rec; local $rec = sub {
-            for (values %{ $_->lexicals }) {
-                next unless $_->isa('Metamodel::Lexical::SubDef');
-                next if $_->body->unit_closed;
-                for ($_->body) { $rec->(); }
-            }
+            return if $_->unit_closed;
+            for ($_->children) { $rec->(); }
+            $cb->($_);
+        };
+        for ($self->mainline) { $rec->(); }
+    }
+
+    sub visit_local_subs_preorder {
+        my ($self, $cb) = @_;
+        our $rec; local $rec = sub {
+            return if $_->unit_closed;
             $cb->($_);
+            for ($_->children) { $rec->(); }
         };
         for ($self->mainline) { $rec->(); }
     }