ext/B/B/C.pm

   1 #      C.pm
   2 #
   3 #      Copyright (c) 1996, 1997, 1998 Malcolm Beattie
   4 #
   5 #      You may distribute under the terms of either the GNU General Public
   6 #      License or the Artistic License, as specified in the README file.
   7 #
   8 package B::C;
   9 use Exporter ();
  10 @ISA = qw(Exporter);
  11 @EXPORT_OK = qw(output_all output_boilerplate output_main
  12                 init_sections set_callback save_unused_subs objsym);
  13
  14 use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop
  15          class cstring cchar svref_2object compile_stats comppadlist hash
  16          threadsv_names main_cv init_av);
  17 use B::Asmdata qw(@specialsv_name);
  18
  19 use FileHandle;
  20 use Carp;
  21 use strict;
  22
  23 my $hv_index = 0;
  24 my $gv_index = 0;
  25 my $re_index = 0;
  26 my $pv_index = 0;
  27 my $anonsub_index = 0;
  28
  29 my %symtable;
  30 my $warn_undefined_syms;
  31 my $verbose;
  32 my @unused_sub_packages;
  33 my $nullop_count;
  34 my $pv_copy_on_grow;
  35 my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
  36
  37 my @threadsv_names;
  38 BEGIN {
  39     @threadsv_names = threadsv_names();
  40 }
  41
  42 # Code sections
  43 my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, $cvopsect,
  44     $gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
  45     $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
  46     $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
  47     $xrvsect, $xpvbmsect, $xpviosect, $bootstrap);
  48
  49 sub walk_and_save_optree;
  50 my $saveoptree_callback = \&walk_and_save_optree;
  51 sub set_callback { $saveoptree_callback = shift }
  52 sub saveoptree { &$saveoptree_callback(@_) }
  53
  54 sub walk_and_save_optree {
  55     my ($name, $root, $start) = @_;
  56     walkoptree($root, "save");
  57     return objsym($start);
  58 }
  59
  60 # Current workaround/fix for op_free() trying to free statically
  61 # defined OPs is to set op_seq = -1 and check for that in op_free().
  62 # Instead of hardwiring -1 in place of $op->seq, we use $op_seq
  63 # so that it can be changed back easily if necessary. In fact, to
  64 # stop compilers from moaning about a U16 being initialised with an
  65 # uncast -1 (the printf format is %d so we can't tweak it), we have
  66 # to "know" that op_seq is a U16 and use 65535. Ugh.
  67 my $op_seq = 65535;
  68
  69 sub AVf_REAL () { 1 }
  70
  71 # XXX This shouldn't really be hardcoded here but it saves
  72 # looking up the name of every BASEOP in B::OP
  73 sub OP_THREADSV () { 345 }
  74
  75 sub savesym {
  76     my ($obj, $value) = @_;
  77     my $sym = sprintf("s\\_%x", $$obj);
  78     $symtable{$sym} = $value;
  79 }
  80
  81 sub objsym {
  82     my $obj = shift;
  83     return $symtable{sprintf("s\\_%x", $$obj)};
  84 }
  85
  86 sub getsym {
  87     my $sym = shift;
  88     my $value;
  89
  90     return 0 if $sym eq "sym_0";        # special case
  91     $value = $symtable{$sym};
  92     if (defined($value)) {
  93         return $value;
  94     } else {
  95         warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
  96         return "UNUSED";
  97     }
  98 }
  99
 100 sub savepv {
 101     my $pv = shift;
 102     my $pvsym = 0;
 103     my $pvmax = 0;
 104     if ($pv_copy_on_grow) {
 105         my $cstring = cstring($pv);
 106         if ($cstring ne "0") { # sic
 107             $pvsym = sprintf("pv%d", $pv_index++);
 108             $decl->add(sprintf("static char %s[] = %s;", $pvsym, $cstring));
 109         }
 110     } else {
 111         $pvmax = length($pv) + 1;
 112     }
 113     return ($pvsym, $pvmax);
 114 }
 115
 116 sub B::OP::save {
 117     my ($op, $level) = @_;
 118     my $type = $op->type;
 119     $nullop_count++ unless $type;
 120     if ($type == OP_THREADSV) {
 121         # saves looking up ppaddr but it's a bit naughty to hard code this
 122         $init->add(sprintf("(void)find_threadsv(%s);",
 123                            cstring($threadsv_names[$op->targ])));
 124     }
 125     $opsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x",
 126                          ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
 127                          $type, $op_seq, $op->flags, $op->private));
 128     savesym($op, sprintf("&op_list[%d]", $opsect->index));
 129 }
 130
 131 sub B::FAKEOP::new {
 132     my ($class, %objdata) = @_;
 133     bless \%objdata, $class;
 134 }
 135
 136 sub B::FAKEOP::save {
 137     my ($op, $level) = @_;
 138     $opsect->add(sprintf("%s, %s, %s, %u, %u, %u, 0x%x, 0x%x",
 139                          $op->next, $op->sibling, $op->ppaddr, $op->targ,
 140                          $op->type, $op_seq, $op->flags, $op->private));
 141     return sprintf("&op_list[%d]", $opsect->index);
 142 }
 143
 144 sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
 145 sub B::FAKEOP::type { $_[0]->{type} || 0}
 146 sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
 147 sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
 148 sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
 149 sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
 150 sub B::FAKEOP::private { $_[0]->{private} || 0 }
 151
 152 sub B::UNOP::save {
 153     my ($op, $level) = @_;
 154     $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x",
 155                            ${$op->next}, ${$op->sibling}, $op->ppaddr,
 156                            $op->targ, $op->type, $op_seq, $op->flags,
 157                            $op->private, ${$op->first}));
 158     savesym($op, sprintf("(OP*)&unop_list[%d]", $unopsect->index));
 159 }
 160
 161 sub B::BINOP::save {
 162     my ($op, $level) = @_;
 163     $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
 164                             ${$op->next}, ${$op->sibling}, $op->ppaddr,
 165                             $op->targ, $op->type, $op_seq, $op->flags,
 166                             $op->private, ${$op->first}, ${$op->last}));
 167     savesym($op, sprintf("(OP*)&binop_list[%d]", $binopsect->index));
 168 }
 169
 170 sub B::LISTOP::save {
 171     my ($op, $level) = @_;
 172     $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u",
 173                              ${$op->next}, ${$op->sibling}, $op->ppaddr,
 174                              $op->targ, $op->type, $op_seq, $op->flags,
 175                              $op->private, ${$op->first}, ${$op->last},
 176                              $op->children));
 177     savesym($op, sprintf("(OP*)&listop_list[%d]", $listopsect->index));
 178 }
 179
 180 sub B::LOGOP::save {
 181     my ($op, $level) = @_;
 182     $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
 183                             ${$op->next}, ${$op->sibling}, $op->ppaddr,
 184                             $op->targ, $op->type, $op_seq, $op->flags,
 185                             $op->private, ${$op->first}, ${$op->other}));
 186     savesym($op, sprintf("(OP*)&logop_list[%d]", $logopsect->index));
 187 }
 188
 189 sub B::CONDOP::save {
 190     my ($op, $level) = @_;
 191     $condopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x",
 192                              ${$op->next}, ${$op->sibling}, $op->ppaddr,
 193                              $op->targ, $op->type, $op_seq, $op->flags,
 194                              $op->private, ${$op->first}, ${$op->true},
 195                              ${$op->false}));
 196     savesym($op, sprintf("(OP*)&condop_list[%d]", $condopsect->index));
 197 }
 198
 199 sub B::LOOP::save {
 200     my ($op, $level) = @_;
 201     #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
 202     #            peekop($op->redoop), peekop($op->nextop),
 203     #            peekop($op->lastop)); # debug
 204     $loopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, s\\_%x, s\\_%x, s\\_%x",
 205                            ${$op->next}, ${$op->sibling}, $op->ppaddr,
 206                            $op->targ, $op->type, $op_seq, $op->flags,
 207                            $op->private, ${$op->first}, ${$op->last},
 208                            $op->children, ${$op->redoop}, ${$op->nextop},
 209                            ${$op->lastop}));
 210     savesym($op, sprintf("(OP*)&loop_list[%d]", $loopsect->index));
 211 }
 212
 213 sub B::PVOP::save {
 214     my ($op, $level) = @_;
 215     $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
 216                            ${$op->next}, ${$op->sibling}, $op->ppaddr,
 217                            $op->targ, $op->type, $op_seq, $op->flags,
 218                            $op->private, cstring($op->pv)));
 219     savesym($op, sprintf("(OP*)&pvop_list[%d]", $pvopsect->index));
 220 }
 221
 222 sub B::SVOP::save {
 223     my ($op, $level) = @_;
 224     my $svsym = $op->sv->save;
 225     $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
 226                            ${$op->next}, ${$op->sibling}, $op->ppaddr,
 227                            $op->targ, $op->type, $op_seq, $op->flags,
 228                            $op->private, "(SV*)$svsym"));
 229     savesym($op, sprintf("(OP*)&svop_list[%d]", $svopsect->index));
 230 }
 231
 232 sub B::GVOP::save {
 233     my ($op, $level) = @_;
 234     my $gvsym = $op->gv->save;
 235     $gvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullgv",
 236                            ${$op->next}, ${$op->sibling}, $op->ppaddr,
 237                            $op->targ, $op->type, $op_seq, $op->flags,
 238                            $op->private));
 239     $init->add(sprintf("gvop_list[%d].op_gv = %s;", $gvopsect->index, $gvsym));
 240     savesym($op, sprintf("(OP*)&gvop_list[%d]", $gvopsect->index));
 241 }
 242
 243 sub B::COP::save {
 244     my ($op, $level) = @_;
 245     my $gvsym = $op->filegv->save;
 246     my $stashsym = $op->stash->save;
 247     warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV)
 248         if $debug_cops;
 249     $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u",
 250                           ${$op->next}, ${$op->sibling}, $op->ppaddr,
 251                           $op->targ, $op->type, $op_seq, $op->flags,
 252                           $op->private, cstring($op->label), $op->cop_seq,
 253                           $op->arybase, $op->line));
 254     my $copix = $copsect->index;
 255     $init->add(sprintf("cop_list[%d].cop_filegv = %s;", $copix, $gvsym),
 256                sprintf("cop_list[%d].cop_stash = %s;", $copix, $stashsym));
 257     savesym($op, "(OP*)&cop_list[$copix]");
 258 }
 259
 260 sub B::PMOP::save {
 261     my ($op, $level) = @_;
 262     my $replroot = $op->pmreplroot;
 263     my $replstart = $op->pmreplstart;
 264     my $replrootfield = sprintf("s\\_%x", $$replroot);
 265     my $replstartfield = sprintf("s\\_%x", $$replstart);
 266     my $gvsym;
 267     my $ppaddr = $op->ppaddr;
 268     if ($$replroot) {
 269         # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
 270         # argument to a split) stores a GV in op_pmreplroot instead
 271         # of a substitution syntax tree. We don't want to walk that...
 272         if ($ppaddr eq "pp_pushre") {
 273             $gvsym = $replroot->save;
 274 #           warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
 275             $replrootfield = 0;
 276         } else {
 277             $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
 278         }
 279     }
 280     # pmnext handling is broken in perl itself, I think. Bad op_pmnext
 281     # fields aren't noticed in perl's runtime (unless you try reset) but we
 282     # segfault when trying to dereference it to find op->op_pmnext->op_type
 283     $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, %s, %s, 0, 0, 0x%x, 0x%x",
 284                            ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ,
 285                            $op->type, $op_seq, $op->flags, $op->private,
 286                            ${$op->first}, ${$op->last}, $op->children,
 287                            $replrootfield, $replstartfield,
 288                            $op->pmflags, $op->pmpermflags,));
 289     my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
 290     my $re = $op->precomp;
 291     if (defined($re)) {
 292         my $resym = sprintf("re%d", $re_index++);
 293         $decl->add(sprintf("static char *$resym = %s;", cstring($re)));
 294         $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
 295                            length($re)));
 296     }
 297     if ($gvsym) {
 298         $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
 299     }
 300     savesym($op, sprintf("(OP*)&pmop_list[%d]", $pmopsect->index));
 301 }
 302
 303 sub B::SPECIAL::save {
 304     my ($sv) = @_;
 305     # special case: $$sv is not the address but an index into specialsv_list
 306 #   warn "SPECIAL::save specialsv $$sv\n"; # debug
 307     my $sym = $specialsv_name[$$sv];
 308     if (!defined($sym)) {
 309         confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
 310     }
 311     return $sym;
 312 }
 313
 314 sub B::OBJECT::save {}
 315
 316 sub B::NULL::save {
 317     my ($sv) = @_;
 318     my $sym = objsym($sv);
 319     return $sym if defined $sym;
 320 #   warn "Saving SVt_NULL SV\n"; # debug
 321     # debug
 322     #if ($$sv == 0) {
 323     #   warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
 324     #}
 325     $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT + 1, $sv->FLAGS));
 326     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 327 }
 328
 329 sub B::IV::save {
 330     my ($sv) = @_;
 331     my $sym = objsym($sv);
 332     return $sym if defined $sym;
 333     $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
 334     $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
 335                          $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
 336     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 337 }
 338
 339 sub B::NV::save {
 340     my ($sv) = @_;
 341     my $sym = objsym($sv);
 342     return $sym if defined $sym;
 343     $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $sv->NVX));
 344     $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
 345                          $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
 346     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 347 }
 348
 349 sub B::PVLV::save {
 350     my ($sv) = @_;
 351     my $sym = objsym($sv);
 352     return $sym if defined $sym;
 353     my $pv = $sv->PV;
 354     my $len = length($pv);
 355     my ($pvsym, $pvmax) = savepv($pv);
 356     my ($lvtarg, $lvtarg_sym);
 357     $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
 358                             $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
 359                             $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
 360     $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
 361                          $xpvlvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
 362     if (!$pv_copy_on_grow) {
 363         $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);",
 364                            $xpvlvsect->index, cstring($pv), $len));
 365     }
 366     $sv->save_magic;
 367     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 368 }
 369
 370 sub B::PVIV::save {
 371     my ($sv) = @_;
 372     my $sym = objsym($sv);
 373     return $sym if defined $sym;
 374     my $pv = $sv->PV;
 375     my $len = length($pv);
 376     my ($pvsym, $pvmax) = savepv($pv);
 377     $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
 378     $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
 379                          $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
 380     if (!$pv_copy_on_grow) {
 381         $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);",
 382                            $xpvivsect->index, cstring($pv), $len));
 383     }
 384     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 385 }
 386
 387 sub B::PVNV::save {
 388     my ($sv) = @_;
 389     my $sym = objsym($sv);
 390     return $sym if defined $sym;
 391     my $pv = $sv->PV;
 392     my $len = length($pv);
 393     my ($pvsym, $pvmax) = savepv($pv);
 394     $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
 395                             $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
 396     $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
 397                          $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
 398     if (!$pv_copy_on_grow) {
 399         $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);",
 400                            $xpvnvsect->index, cstring($pv), $len));
 401     }
 402     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 403 }
 404
 405 sub B::BM::save {
 406     my ($sv) = @_;
 407     my $sym = objsym($sv);
 408     return $sym if defined $sym;
 409     my $pv = $sv->PV . "\0" . $sv->TABLE;
 410     my $len = length($pv);
 411     $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
 412                             $len, $len + 258, $sv->IVX, $sv->NVX,
 413                             $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
 414     $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
 415                          $xpvbmsect->index, $sv->REFCNT + 1, $sv->FLAGS));
 416     $sv->save_magic;
 417     $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);",
 418                        $xpvbmsect->index, cstring($pv), $len),
 419                sprintf("xpvbm_list[%d].xpv_cur = %u;",
 420                        $xpvbmsect->index, $len - 257));
 421     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 422 }
 423
 424 sub B::PV::save {
 425     my ($sv) = @_;
 426     my $sym = objsym($sv);
 427     return $sym if defined $sym;
 428     my $pv = $sv->PV;
 429     my $len = length($pv);
 430     my ($pvsym, $pvmax) = savepv($pv);
 431     $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
 432     $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
 433                          $xpvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
 434     if (!$pv_copy_on_grow) {
 435         $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);",
 436                            $xpvsect->index, cstring($pv), $len));
 437     }
 438     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 439 }
 440
 441 sub B::PVMG::save {
 442     my ($sv) = @_;
 443     my $sym = objsym($sv);
 444     return $sym if defined $sym;
 445     my $pv = $sv->PV;
 446     my $len = length($pv);
 447     my ($pvsym, $pvmax) = savepv($pv);
 448     $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
 449                             $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
 450     $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
 451                          $xpvmgsect->index, $sv->REFCNT + 1, $sv->FLAGS));
 452     if (!$pv_copy_on_grow) {
 453         $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);",
 454                            $xpvmgsect->index, cstring($pv), $len));
 455     }
 456     $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 457     $sv->save_magic;
 458     return $sym;
 459 }
 460
 461 sub B::PVMG::save_magic {
 462     my ($sv) = @_;
 463     #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
 464     my $stash = $sv->SvSTASH;
 465     if ($$stash) {
 466         warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
 467             if $debug_mg;
 468         # XXX Hope stash is already going to be saved.
 469         $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
 470     }
 471     my @mgchain = $sv->MAGIC;
 472     my ($mg, $type, $obj, $ptr);
 473     foreach $mg (@mgchain) {
 474         $type = $mg->TYPE;
 475         $obj = $mg->OBJ;
 476         $ptr = $mg->PTR;
 477         my $len = defined($ptr) ? length($ptr) : 0;
 478         if ($debug_mg) {
 479             warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
 480                          class($sv), $$sv, class($obj), $$obj,
 481                          cchar($type), cstring($ptr));
 482         }
 483         $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
 484                            $$sv, $$obj, cchar($type),cstring($ptr),$len));
 485     }
 486 }
 487
 488 sub B::RV::save {
 489     my ($sv) = @_;
 490     my $sym = objsym($sv);
 491     return $sym if defined $sym;
 492     $xrvsect->add($sv->RV->save);
 493     $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
 494                          $xrvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
 495     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 496 }
 497
 498 sub try_autoload {
 499     my ($cvstashname, $cvname) = @_;
 500     warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
 501     # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
 502     # use should be handled by the class itself.
 503     no strict 'refs';
 504     my $isa = \@{"$cvstashname\::ISA"};
 505     if (grep($_ eq "AutoLoader", @$isa)) {
 506         warn "Forcing immediate load of sub derived from AutoLoader\n";
 507         # Tweaked version of AutoLoader::AUTOLOAD
 508         my $dir = $cvstashname;
 509         $dir =~ s(::)(/)g;
 510         eval { require "auto/$dir/$cvname.al" };
 511         if ($@) {
 512             warn qq(failed require "auto/$dir/$cvname.al": $@\n);
 513             return 0;
 514         } else {
 515             return 1;
 516         }
 517     }
 518 }
 519
 520 sub B::CV::save {
 521     my ($cv) = @_;
 522     my $sym = objsym($cv);
 523     if (defined($sym)) {
 524 #       warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
 525         return $sym;
 526     }
 527     # Reserve a place in svsect and xpvcvsect and record indices
 528     my $sv_ix = $svsect->index + 1;
 529     $svsect->add("svix$sv_ix");
 530     my $xpvcv_ix = $xpvcvsect->index + 1;
 531     $xpvcvsect->add("xpvcvix$xpvcv_ix");
 532     # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
 533     $sym = savesym($cv, "&sv_list[$sv_ix]");
 534     warn sprintf("saving CV 0x%x as $sym\n", $$cv) if $debug_cv;
 535     my $gv = $cv->GV;
 536     my $cvstashname = $gv->STASH->NAME;
 537     my $cvname = $gv->NAME;
 538     my $root = $cv->ROOT;
 539     my $cvxsub = $cv->XSUB;
 540     if (!$$root && !$cvxsub) {
 541         if (try_autoload($cvstashname, $cvname)) {
 542             # Recalculate root and xsub
 543             $root = $cv->ROOT;
 544             $cvxsub = $cv->XSUB;
 545             if ($$root || $cvxsub) {
 546                 warn "Successful forced autoload\n";
 547             }
 548         }
 549     }
 550     my $startfield = 0;
 551     my $padlist = $cv->PADLIST;
 552     my $pv = $cv->PV;
 553     my $xsub = 0;
 554     my $xsubany = "Nullany";
 555     if ($$root) {
 556         warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
 557                      $$cv, $$root) if $debug_cv;
 558         my $ppname = "";
 559         if ($$gv) {
 560             my $stashname = $gv->STASH->NAME;
 561             my $gvname = $gv->NAME;
 562             if ($gvname ne "__ANON__") {
 563                 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
 564                 $ppname .= ($stashname eq "main") ?
 565                             $gvname : "$stashname\::$gvname";
 566                 $ppname =~ s/::/__/g;
 567             }
 568         }
 569         if (!$ppname) {
 570             $ppname = "pp_anonsub_$anonsub_index";
 571             $anonsub_index++;
 572         }
 573         $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
 574         warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
 575                      $$cv, $ppname, $$root) if $debug_cv;
 576         if ($$padlist) {
 577             warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
 578                          $$padlist, $$cv) if $debug_cv;
 579             $padlist->save;
 580             warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
 581                          $$padlist, $$cv) if $debug_cv;
 582         }
 583     }
 584     elsif ($cvxsub) {
 585         $xsubany = sprintf("ANYINIT((void*)0x%x)", $cv->XSUBANY);
 586         # Try to find out canonical name of XSUB function from EGV.
 587         # XXX Doesn't work for XSUBs with PREFIX set (or anyone who
 588         # calls newXS() manually with weird arguments).
 589         my $egv = $gv->EGV;
 590         my $stashname = $egv->STASH->NAME;
 591         $stashname =~ s/::/__/g;
 592         $xsub = sprintf("XS_%s_%s", $stashname, $egv->NAME);
 593         $decl->add("void $xsub _((CV*));");
 594     }
 595     else {
 596         warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
 597                      $cvstashname, $cvname); # debug
 598     }
 599     $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, Nullgv, %d, s\\_%x, (CV*)s\\_%x, 0x%x",
 600                           $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
 601                           $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
 602                         $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
 603
 604     if (${$cv->OUTSIDE} == ${main_cv()}){
 605         $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
 606     }
 607
 608     if ($$gv) {
 609         $gv->save;
 610         $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
 611         warn sprintf("done saving GV 0x%x for CV 0x%x\n",
 612                      $$gv, $$cv) if $debug_cv;
 613     }
 614     my $filegv = $cv->FILEGV;
 615     if ($$filegv) {
 616         $filegv->save;
 617         $init->add(sprintf("CvFILEGV(s\\_%x) = s\\_%x;", $$cv, $$filegv));
 618         warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n",
 619                      $$filegv, $$cv) if $debug_cv;
 620     }
 621     my $stash = $cv->STASH;
 622     if ($$stash) {
 623         $stash->save;
 624         $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
 625         warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
 626                      $$stash, $$cv) if $debug_cv;
 627     }
 628     $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
 629                           $sv_ix, $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS));
 630     return $sym;
 631 }
 632
 633 sub B::GV::save {
 634     my ($gv) = @_;
 635     my $sym = objsym($gv);
 636     if (defined($sym)) {
 637         #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
 638         return $sym;
 639     } else {
 640         my $ix = $gv_index++;
 641         $sym = savesym($gv, "gv_list[$ix]");
 642         #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
 643     }
 644     my $gvname = $gv->NAME;
 645     my $name = cstring($gv->STASH->NAME . "::" . $gvname);
 646     #warn "GV name is $name\n"; # debug
 647     my $egv = $gv->EGV;
 648     my $egvsym;
 649     if ($$gv != $$egv) {
 650         #warn(sprintf("EGV name is %s, saving it now\n",
 651         #            $egv->STASH->NAME . "::" . $egv->NAME)); # debug
 652         $egvsym = $egv->save;
 653     }
 654     $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
 655                sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
 656                sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS),
 657                sprintf("GvLINE($sym) = %u;", $gv->LINE));
 658     # Shouldn't need to do save_magic since gv_fetchpv handles that
 659     #$gv->save_magic;
 660     my $refcnt = $gv->REFCNT + 1;
 661     $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
 662     my $gvrefcnt = $gv->GvREFCNT;
 663     if ($gvrefcnt > 1) {
 664         $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
 665     }
 666     if (defined($egvsym)) {
 667         # Shared glob *foo = *bar
 668         $init->add("gp_free($sym);",
 669                    "GvGP($sym) = GvGP($egvsym);");
 670     } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
 671         # Don't save subfields of special GVs (*_, *1, *# and so on)
 672 #       warn "GV::save saving subfields\n"; # debug
 673         my $gvsv = $gv->SV;
 674         if ($$gvsv) {
 675             $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
 676 #           warn "GV::save \$$name\n"; # debug
 677             $gvsv->save;
 678         }
 679         my $gvav = $gv->AV;
 680         if ($$gvav) {
 681             $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
 682 #           warn "GV::save \@$name\n"; # debug
 683             $gvav->save;
 684         }
 685         my $gvhv = $gv->HV;
 686         if ($$gvhv) {
 687             $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
 688 #           warn "GV::save \%$name\n"; # debug
 689             $gvhv->save;
 690         }
 691         my $gvcv = $gv->CV;
 692         if ($$gvcv) {
 693             $init->add(sprintf("GvCV($sym) = (CV*)s\\_%x;", $$gvcv));
 694 #           warn "GV::save &$name\n"; # debug
 695             $gvcv->save;
 696         }
 697         my $gvfilegv = $gv->FILEGV;
 698         if ($$gvfilegv) {
 699             $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv));
 700 #           warn "GV::save GvFILEGV(*$name)\n"; # debug
 701             $gvfilegv->save;
 702         }
 703         my $gvform = $gv->FORM;
 704         if ($$gvform) {
 705             $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
 706 #           warn "GV::save GvFORM(*$name)\n"; # debug
 707             $gvform->save;
 708         }
 709         my $gvio = $gv->IO;
 710         if ($$gvio) {
 711             $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
 712 #           warn "GV::save GvIO(*$name)\n"; # debug
 713             $gvio->save;
 714         }
 715     }
 716     return $sym;
 717 }
 718 sub B::AV::save {
 719     my ($av) = @_;
 720     my $sym = objsym($av);
 721     return $sym if defined $sym;
 722     my $avflags = $av->AvFLAGS;
 723     $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
 724                             $avflags));
 725     $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
 726                          $xpvavsect->index, $av->REFCNT + 1, $av->FLAGS));
 727     my $sv_list_index = $svsect->index;
 728     my $fill = $av->FILL;
 729     $av->save_magic;
 730     warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
 731         if $debug_av;
 732     # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
 733     #if ($fill > -1 && ($avflags & AVf_REAL)) {
 734     if ($fill > -1) {
 735         my @array = $av->ARRAY;
 736         if ($debug_av) {
 737             my $el;
 738             my $i = 0;
 739             foreach $el (@array) {
 740                 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
 741                              $$av, $i++, class($el), $$el);
 742             }
 743         }
 744         my @names = map($_->save, @array);
 745         # XXX Better ways to write loop?
 746         # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
 747         # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
 748         $init->add("{",
 749                    "\tSV **svp;",
 750                    "\tAV *av = (AV*)&sv_list[$sv_list_index];",
 751                    "\tav_extend(av, $fill);",
 752                    "\tsvp = AvARRAY(av);",
 753                map("\t*svp++ = (SV*)$_;", @names),
 754                    "\tAvFILLp(av) = $fill;",
 755                    "}");
 756     } else {
 757         my $max = $av->MAX;
 758         $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
 759             if $max > -1;
 760     }
 761     return savesym($av, "(AV*)&sv_list[$sv_list_index]");
 762 }
 763
 764 sub B::HV::save {
 765     my ($hv) = @_;
 766     my $sym = objsym($hv);
 767     return $sym if defined $sym;
 768     my $name = $hv->NAME;
 769     if ($name) {
 770         # It's a stash
 771
 772         # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
 773         # the only symptom is that sv_reset tries to reset the PMf_USED flag of
 774         # a trashed op but we look at the trashed op_type and segfault.
 775         #my $adpmroot = ${$hv->PMROOT};
 776         my $adpmroot = 0;
 777         $decl->add("static HV *hv$hv_index;");
 778         # XXX Beware of weird package names containing double-quotes, \n, ...?
 779         $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
 780         if ($adpmroot) {
 781             $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
 782                                $adpmroot));
 783         }
 784         $sym = savesym($hv, "hv$hv_index");
 785         $hv_index++;
 786         return $sym;
 787     }
 788     # It's just an ordinary HV
 789     $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
 790                             $hv->MAX, $hv->RITER));
 791     $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
 792                          $xpvhvsect->index, $hv->REFCNT + 1, $hv->FLAGS));
 793     my $sv_list_index = $svsect->index;
 794     my @contents = $hv->ARRAY;
 795     if (@contents) {
 796         my $i;
 797         for ($i = 1; $i < @contents; $i += 2) {
 798             $contents[$i] = $contents[$i]->save;
 799         }
 800         $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
 801         while (@contents) {
 802             my ($key, $value) = splice(@contents, 0, 2);
 803             $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
 804                                cstring($key),length($key),$value, hash($key)));
 805         }
 806         $init->add("}");
 807     }
 808     return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
 809 }
 810
 811 sub B::IO::save {
 812     my ($io) = @_;
 813     my $sym = objsym($io);
 814     return $sym if defined $sym;
 815     my $pv = $io->PV;
 816     my $len = length($pv);
 817     $xpviosect->add(sprintf("0, %u, %u, %d, %s, 0, 0, 0, 0, 0, %d, %d, %d, %d, %s, Nullgv, %s, Nullgv, %s, Nullgv, %d, %s, 0x%x",
 818                             $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
 819                             $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
 820                             cstring($io->TOP_NAME), cstring($io->FMT_NAME),
 821                             cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
 822                             cchar($io->IoTYPE), $io->IoFLAGS));
 823     $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
 824                          $xpviosect->index, $io->REFCNT + 1, $io->FLAGS));
 825     $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
 826     my ($field, $fsym);
 827     foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
 828         $fsym = $io->$field();
 829         if ($$fsym) {
 830             $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
 831             $fsym->save;
 832         }
 833     }
 834     $io->save_magic;
 835     return $sym;
 836 }
 837
 838 sub B::SV::save {
 839     my $sv = shift;
 840     # This is where we catch an honest-to-goodness Nullsv (which gets
 841     # blessed into B::SV explicitly) and any stray erroneous SVs.
 842     return 0 unless $$sv;
 843     confess sprintf("cannot save that type of SV: %s (0x%x)\n",
 844                     class($sv), $$sv);
 845 }
 846
 847 sub output_all {
 848     my $init_name = shift;
 849     my $section;
 850     my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
 851                     $listopsect, $pmopsect, $svopsect, $gvopsect, $pvopsect,
 852                     $cvopsect, $loopsect, $copsect, $svsect, $xpvsect,
 853                     $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
 854                     $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
 855     $bootstrap->output(\*STDOUT, "/* bootstrap %s */\n");
 856     $symsect->output(\*STDOUT, "#define %s\n");
 857     print "\n";
 858     output_declarations();
 859     foreach $section (@sections) {
 860         my $lines = $section->index + 1;
 861         if ($lines) {
 862             my $name = $section->name;
 863             my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
 864             print "Static $typename ${name}_list[$lines];\n";
 865         }
 866     }
 867     $decl->output(\*STDOUT, "%s\n");
 868     print "\n";
 869     foreach $section (@sections) {
 870         my $lines = $section->index + 1;
 871         if ($lines) {
 872             my $name = $section->name;
 873             my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
 874             printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
 875             $section->output(\*STDOUT, "\t{ %s },\n");
 876             print "};\n\n";
 877         }
 878     }
 879
 880     print <<"EOT";
 881 static int $init_name()
 882 {
 883         dTHR;
 884 EOT
 885     $init->output(\*STDOUT, "\t%s\n");
 886     print "\treturn 0;\n}\n";
 887     if ($verbose) {
 888         warn compile_stats();
 889         warn "NULLOP count: $nullop_count\n";
 890     }
 891 }
 892
 893 sub output_declarations {
 894     print <<'EOT';
 895 #ifdef BROKEN_STATIC_REDECL
 896 #define Static extern
 897 #else
 898 #define Static static
 899 #endif /* BROKEN_STATIC_REDECL */
 900
 901 #ifdef BROKEN_UNION_INIT
 902 /*
 903  * Cribbed from cv.h with ANY (a union) replaced by void*.
 904  * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
 905  */
 906 typedef struct {
 907     char *      xpv_pv;         /* pointer to malloced string */
 908     STRLEN      xpv_cur;        /* length of xp_pv as a C string */
 909     STRLEN      xpv_len;        /* allocated size */
 910     IV          xof_off;        /* integer value */
 911     double      xnv_nv;         /* numeric value, if any */
 912     MAGIC*      xmg_magic;      /* magic for scalar array */
 913     HV*         xmg_stash;      /* class package */
 914
 915     HV *        xcv_stash;
 916     OP *        xcv_start;
 917     OP *        xcv_root;
 918     void      (*xcv_xsub) _((CV*));
 919     void *      xcv_xsubany;
 920     GV *        xcv_gv;
 921     GV *        xcv_filegv;
 922     long        xcv_depth;              /* >= 2 indicates recursive call */
 923     AV *        xcv_padlist;
 924     CV *        xcv_outside;
 925 #ifdef USE_THREADS
 926     perl_mutex *xcv_mutexp;
 927     struct perl_thread *xcv_owner;      /* current owner thread */
 928 #endif /* USE_THREADS */
 929     U8          xcv_flags;
 930 } XPVCV_or_similar;
 931 #define ANYINIT(i) i
 932 #else
 933 #define XPVCV_or_similar XPVCV
 934 #define ANYINIT(i) {i}
 935 #endif /* BROKEN_UNION_INIT */
 936 #define Nullany ANYINIT(0)
 937
 938 #define UNUSED 0
 939 #define sym_0 0
 940
 941 EOT
 942     print "static GV *gv_list[$gv_index];\n" if $gv_index;
 943     print "\n";
 944 }
 945
 946
 947 sub output_boilerplate {
 948     print <<'EOT';
 949 #include "EXTERN.h"
 950 #include "perl.h"
 951 #ifndef PATCHLEVEL
 952 #include "patchlevel.h"
 953 #endif
 954
 955 /* Workaround for mapstart: the only op which needs a different ppaddr */
 956 #undef pp_mapstart
 957 #define pp_mapstart pp_grepstart
 958
 959 static void xs_init _((void));
 960 static PerlInterpreter *my_perl;
 961 EOT
 962 }
 963
 964 sub output_main {
 965     print <<'EOT';
 966 int
 967 #ifndef CAN_PROTOTYPE
 968 main(argc, argv, env)
 969 int argc;
 970 char **argv;
 971 char **env;
 972 #else  /* def(CAN_PROTOTYPE) */
 973 main(int argc, char **argv, char **env)
 974 #endif  /* def(CAN_PROTOTYPE) */
 975 {
 976     int exitstatus;
 977     int i;
 978     char **fakeargv;
 979
 980     PERL_SYS_INIT(&argc,&argv);
 981
 982     perl_init_i18nl10n(1);
 983
 984     if (!PL_do_undump) {
 985         my_perl = perl_alloc();
 986         if (!my_perl)
 987             exit(1);
 988         perl_construct( my_perl );
 989     }
 990
 991 #ifdef CSH
 992     if (!PL_cshlen)
 993       PL_cshlen = strlen(PL_cshname);
 994 #endif
 995
 996 #ifdef ALLOW_PERL_OPTIONS
 997 #define EXTRA_OPTIONS 2
 998 #else
 999 #define EXTRA_OPTIONS 3
1000 #endif /* ALLOW_PERL_OPTIONS */
1001     New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1002     fakeargv[0] = argv[0];
1003     fakeargv[1] = "-e";
1004     fakeargv[2] = "";
1005 #ifndef ALLOW_PERL_OPTIONS
1006     fakeargv[3] = "--";
1007 #endif /* ALLOW_PERL_OPTIONS */
1008     for (i = 1; i < argc; i++)
1009         fakeargv[i + EXTRA_OPTIONS] = argv[i];
1010     fakeargv[argc + EXTRA_OPTIONS] = 0;
1011
1012     exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1013                             fakeargv, NULL);
1014     if (exitstatus)
1015         exit( exitstatus );
1016
1017     sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1018     PL_main_cv = PL_compcv;
1019     PL_compcv = 0;
1020
1021     exitstatus = perl_init();
1022     if (exitstatus)
1023         exit( exitstatus );
1024
1025     exitstatus = perl_run( my_perl );
1026
1027     perl_destruct( my_perl );
1028     perl_free( my_perl );
1029
1030     exit( exitstatus );
1031 }
1032
1033 static void
1034 xs_init()
1035 {
1036 }
1037 EOT
1038 }
1039
1040 sub dump_symtable {
1041     # For debugging
1042     my ($sym, $val);
1043     warn "----Symbol table:\n";
1044     while (($sym, $val) = each %symtable) {
1045         warn "$sym => $val\n";
1046     }
1047     warn "---End of symbol table\n";
1048 }
1049
1050 sub save_object {
1051     my $sv;
1052     foreach $sv (@_) {
1053         svref_2object($sv)->save;
1054     }
1055 }
1056
1057 sub B::GV::savecv {
1058     my $gv = shift;
1059     my $cv = $gv->CV;
1060     my $name = $gv->NAME;
1061     if ($$cv && !objsym($cv)) {
1062         if ($name eq "bootstrap" && $cv->XSUB) {
1063             my $file = $cv->FILEGV->SV->PV;
1064             $bootstrap->add($file);
1065             return;
1066         }
1067         if ($debug_cv) {
1068             warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
1069                          $gv->STASH->NAME, $name, $$cv, $$gv);
1070         }
1071       my $package=$gv->STASH->NAME;
1072       # This seems to undo all the ->isa and prefix stuff we do below
1073       # so disable again for now
1074       if (0 && ! grep(/^$package$/,@unused_sub_packages)){
1075           warn sprintf("omitting cv in superclass %s", $gv->STASH->NAME)
1076               if $debug_cv;
1077           return ;
1078       }
1079         $gv->save;
1080     }
1081     elsif ($name eq 'ISA')
1082      {
1083       $gv->save;
1084      }
1085
1086 }
1087
1088 sub save_unused_subs {
1089     my %search_pack;
1090     map { $search_pack{$_} = 1 } @_;
1091     @unused_sub_packages=@_;
1092     no strict qw(vars refs);
1093     walksymtable(\%{"main::"}, "savecv", sub {
1094         my $package = shift;
1095         $package =~ s/::$//;
1096         return 0 if ($package =~ /::::/);  # skip ::::ISA::CACHE etc.
1097         #warn "Considering $package\n";#debug
1098         return 1 if exists $search_pack{$package};
1099       #sub try for a partial match
1100       if (grep(/^$package\:\:/,@unused_sub_packages)){
1101           return 1;
1102       }
1103         #warn "    (nothing explicit)\n";#debug
1104         # Omit the packages which we use (and which cause grief
1105         # because of fancy "goto &$AUTOLOAD" stuff).
1106         # XXX Surely there must be a nicer way to do this.
1107         if ($package eq "FileHandle"
1108             || $package eq "Config"
1109             || $package eq "SelectSaver") {
1110             return 0;
1111         }
1112         foreach my $u (keys %search_pack) {
1113             if ($package =~ /^${u}::/) {
1114                 warn "$package starts with $u\n";
1115                 return 1
1116             }
1117             if ($package->isa($u)) {
1118                 warn "$package isa $u\n";
1119                 return 1
1120             }
1121             return 1 if $package->isa($u);
1122         }
1123         foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) {
1124             if (defined(&{$package."::$m"})) {
1125                 warn "$package has method $m: -u$package assumed\n";#debug
1126               push @unused_sub_package, $package;
1127                 return 1;
1128             }
1129         }
1130         return 0;
1131     });
1132 }
1133
1134 sub save_main {
1135     my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1136     my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1137     my $init_av    = init_av->save;
1138     walkoptree(main_root, "save");
1139     warn "done main optree, walking symtable for extras\n" if $debug_cv;
1140     save_unused_subs(@unused_sub_packages);
1141
1142     $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1143                sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1144                "PL_curpad = AvARRAY($curpad_sym);",
1145                "PL_initav = $init_av;",
1146                "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1147                "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));");
1148     warn "Writing output\n";
1149     output_boilerplate();
1150     print "\n";
1151     output_all("perl_init");
1152     print "\n";
1153     output_main();
1154 }
1155
1156 sub init_sections {
1157     my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1158                     binop => \$binopsect, condop => \$condopsect,
1159                     cop => \$copsect, cvop => \$cvopsect, gvop => \$gvopsect,
1160                     listop => \$listopsect, logop => \$logopsect,
1161                     loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1162                     pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1163                     sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1164                     xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1165                     xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1166                     xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1167                     xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1168                     xpvio => \$xpviosect, bootstrap => \$bootstrap);
1169     my ($name, $sectref);
1170     while (($name, $sectref) = splice(@sections, 0, 2)) {
1171         $$sectref = new B::Section $name, \%symtable, 0;
1172     }
1173 }
1174
1175 sub compile {
1176     my @options = @_;
1177     my ($option, $opt, $arg);
1178   OPTION:
1179     while ($option = shift @options) {
1180         if ($option =~ /^-(.)(.*)/) {
1181             $opt = $1;
1182             $arg = $2;
1183         } else {
1184             unshift @options, $option;
1185             last OPTION;
1186         }
1187         if ($opt eq "-" && $arg eq "-") {
1188             shift @options;
1189             last OPTION;
1190         }
1191         if ($opt eq "w") {
1192             $warn_undefined_syms = 1;
1193         } elsif ($opt eq "D") {
1194             $arg ||= shift @options;
1195             foreach $arg (split(//, $arg)) {
1196                 if ($arg eq "o") {
1197                     B->debug(1);
1198                 } elsif ($arg eq "c") {
1199                     $debug_cops = 1;
1200                 } elsif ($arg eq "A") {
1201                     $debug_av = 1;
1202                 } elsif ($arg eq "C") {
1203                     $debug_cv = 1;
1204                 } elsif ($arg eq "M") {
1205                     $debug_mg = 1;
1206                 } else {
1207                     warn "ignoring unknown debug option: $arg\n";
1208                 }
1209             }
1210         } elsif ($opt eq "o") {
1211             $arg ||= shift @options;
1212             open(STDOUT, ">$arg") or return "$arg: $!\n";
1213         } elsif ($opt eq "v") {
1214             $verbose = 1;
1215         } elsif ($opt eq "u") {
1216             $arg ||= shift @options;
1217             push(@unused_sub_packages, $arg);
1218         } elsif ($opt eq "f") {
1219             $arg ||= shift @options;
1220             if ($arg eq "cog") {
1221                 $pv_copy_on_grow = 1;
1222             } elsif ($arg eq "no-cog") {
1223                 $pv_copy_on_grow = 0;
1224             }
1225         } elsif ($opt eq "O") {
1226             $arg = 1 if $arg eq "";
1227             $pv_copy_on_grow = 0;
1228             if ($arg >= 1) {
1229                 # Optimisations for -O1
1230                 $pv_copy_on_grow = 1;
1231             }
1232         }
1233     }
1234     init_sections();
1235     if (@options) {
1236         return sub {
1237             my $objname;
1238             foreach $objname (@options) {
1239                 eval "save_object(\\$objname)";
1240             }
1241             output_all();
1242         }
1243     } else {
1244         return sub { save_main() };
1245     }
1246 }
1247
1248 1;
1249
1250 __END__
1251
1252 =head1 NAME
1253
1254 B::C - Perl compiler's C backend
1255
1256 =head1 SYNOPSIS
1257
1258         perl -MO=C[,OPTIONS] foo.pl
1259
1260 =head1 DESCRIPTION
1261
1262 This compiler backend takes Perl source and generates C source code
1263 corresponding to the internal structures that perl uses to run
1264 your program. When the generated C source is compiled and run, it
1265 cuts out the time which perl would have taken to load and parse
1266 your program into its internal semi-compiled form. That means that
1267 compiling with this backend will not help improve the runtime
1268 execution speed of your program but may improve the start-up time.
1269 Depending on the environment in which your program runs this may be
1270 either a help or a hindrance.
1271
1272 =head1 OPTIONS
1273
1274 If there are any non-option arguments, they are taken to be
1275 names of objects to be saved (probably doesn't work properly yet).
1276 Without extra arguments, it saves the main program.
1277
1278 =over 4
1279
1280 =item B<-ofilename>
1281
1282 Output to filename instead of STDOUT
1283
1284 =item B<-v>
1285
1286 Verbose compilation (currently gives a few compilation statistics).
1287
1288 =item B<-->
1289
1290 Force end of options
1291
1292 =item B<-uPackname>
1293
1294 Force apparently unused subs from package Packname to be compiled.
1295 This allows programs to use eval "foo()" even when sub foo is never
1296 seen to be used at compile time. The down side is that any subs which
1297 really are never used also have code generated. This option is
1298 necessary, for example, if you have a signal handler foo which you
1299 initialise with C<$SIG{BAR} = "foo">.  A better fix, though, is just
1300 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1301 options. The compiler tries to figure out which packages may possibly
1302 have subs in which need compiling but the current version doesn't do
1303 it very well. In particular, it is confused by nested packages (i.e.
1304 of the form C<A::B>) where package C<A> does not contain any subs.
1305
1306 =item B<-D>
1307
1308 Debug options (concatenated or separate flags like C<perl -D>).
1309
1310 =item B<-Do>
1311
1312 OPs, prints each OP as it's processed
1313
1314 =item B<-Dc>
1315
1316 COPs, prints COPs as processed (incl. file & line num)
1317
1318 =item B<-DA>
1319
1320 prints AV information on saving
1321
1322 =item B<-DC>
1323
1324 prints CV information on saving
1325
1326 =item B<-DM>
1327
1328 prints MAGIC information on saving
1329
1330 =item B<-f>
1331
1332 Force optimisations on or off one at a time.
1333
1334 =item B<-fcog>
1335
1336 Copy-on-grow: PVs declared and initialised statically.
1337
1338 =item B<-fno-cog>
1339
1340 No copy-on-grow.
1341
1342 =item B<-On>
1343
1344 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.  Currently,
1345 B<-O1> and higher set B<-fcog>.
1346
1347 =head1 EXAMPLES
1348
1349     perl -MO=C,-ofoo.c foo.pl
1350     perl cc_harness -o foo foo.c
1351
1352 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1353 library directory. The utility called C<perlcc> may also be used to
1354 help make use of this compiler.
1355
1356     perl -MO=C,-v,-DcA bar.pl > /dev/null
1357
1358 =head1 BUGS
1359
1360 Plenty. Current status: experimental.
1361
1362 =head1 AUTHOR
1363
1364 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
1365
1366 =cut