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 );
  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);
  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) = 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     $symsect->output(\*STDOUT, "#define %s\n");
 856     print "\n";
 857     output_declarations();
 858     foreach $section (@sections) {
 859         my $lines = $section->index + 1;
 860         if ($lines) {
 861             my $name = $section->name;
 862             my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
 863             print "Static $typename ${name}_list[$lines];\n";
 864         }
 865     }
 866     $decl->output(\*STDOUT, "%s\n");
 867     print "\n";
 868     foreach $section (@sections) {
 869         my $lines = $section->index + 1;
 870         if ($lines) {
 871             my $name = $section->name;
 872             my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
 873             printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
 874             $section->output(\*STDOUT, "\t{ %s },\n");
 875             print "};\n\n";
 876         }
 877     }
 878
 879     print <<"EOT";
 880 static int $init_name()
 881 {
 882         dTHR;
 883 EOT
 884     $init->output(\*STDOUT, "\t%s\n");
 885     print "\treturn 0;\n}\n";
 886     if ($verbose) {
 887         warn compile_stats();
 888         warn "NULLOP count: $nullop_count\n";
 889     }
 890 }
 891
 892 sub output_declarations {
 893     print <<'EOT';
 894 #ifdef BROKEN_STATIC_REDECL
 895 #define Static extern
 896 #else
 897 #define Static static
 898 #endif /* BROKEN_STATIC_REDECL */
 899
 900 #ifdef BROKEN_UNION_INIT
 901 /*
 902  * Cribbed from cv.h with ANY (a union) replaced by void*.
 903  * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
 904  */
 905 typedef struct {
 906     char *      xpv_pv;         /* pointer to malloced string */
 907     STRLEN      xpv_cur;        /* length of xp_pv as a C string */
 908     STRLEN      xpv_len;        /* allocated size */
 909     IV          xof_off;        /* integer value */
 910     double      xnv_nv;         /* numeric value, if any */
 911     MAGIC*      xmg_magic;      /* magic for scalar array */
 912     HV*         xmg_stash;      /* class package */
 913
 914     HV *        xcv_stash;
 915     OP *        xcv_start;
 916     OP *        xcv_root;
 917     void      (*xcv_xsub) _((CV*));
 918     void *      xcv_xsubany;
 919     GV *        xcv_gv;
 920     GV *        xcv_filegv;
 921     long        xcv_depth;              /* >= 2 indicates recursive call */
 922     AV *        xcv_padlist;
 923     CV *        xcv_outside;
 924 #ifdef USE_THREADS
 925     perl_mutex *xcv_mutexp;
 926     struct perl_thread *xcv_owner;      /* current owner thread */
 927 #endif /* USE_THREADS */
 928     U8          xcv_flags;
 929 } XPVCV_or_similar;
 930 #define ANYINIT(i) i
 931 #else
 932 #define XPVCV_or_similar XPVCV
 933 #define ANYINIT(i) {i}
 934 #endif /* BROKEN_UNION_INIT */
 935 #define Nullany ANYINIT(0)
 936
 937 #define UNUSED 0
 938 #define sym_0 0
 939
 940 EOT
 941     print "static GV *gv_list[$gv_index];\n" if $gv_index;
 942     print "\n";
 943 }
 944
 945
 946 sub output_boilerplate {
 947     print <<'EOT';
 948 #include "EXTERN.h"
 949 #include "perl.h"
 950 #ifndef PATCHLEVEL
 951 #include "patchlevel.h"
 952 #endif
 953
 954 /* Workaround for mapstart: the only op which needs a different ppaddr */
 955 #undef pp_mapstart
 956 #define pp_mapstart pp_grepstart
 957
 958 static void xs_init _((void));
 959 static PerlInterpreter *my_perl;
 960 EOT
 961 }
 962
 963 sub output_main {
 964     print <<'EOT';
 965 int
 966 #ifndef CAN_PROTOTYPE
 967 main(argc, argv, env)
 968 int argc;
 969 char **argv;
 970 char **env;
 971 #else  /* def(CAN_PROTOTYPE) */
 972 main(int argc, char **argv, char **env)
 973 #endif  /* def(CAN_PROTOTYPE) */
 974 {
 975     int exitstatus;
 976     int i;
 977     char **fakeargv;
 978
 979     PERL_SYS_INIT(&argc,&argv);
 980
 981     perl_init_i18nl10n(1);
 982
 983     if (!PL_do_undump) {
 984         my_perl = perl_alloc();
 985         if (!my_perl)
 986             exit(1);
 987         perl_construct( my_perl );
 988     }
 989
 990 #ifdef CSH
 991     if (!PL_cshlen)
 992       PL_cshlen = strlen(PL_cshname);
 993 #endif
 994
 995 #ifdef ALLOW_PERL_OPTIONS
 996 #define EXTRA_OPTIONS 2
 997 #else
 998 #define EXTRA_OPTIONS 3
 999 #endif /* ALLOW_PERL_OPTIONS */
1000     New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1001     fakeargv[0] = argv[0];
1002     fakeargv[1] = "-e";
1003     fakeargv[2] = "";
1004 #ifndef ALLOW_PERL_OPTIONS
1005     fakeargv[3] = "--";
1006 #endif /* ALLOW_PERL_OPTIONS */
1007     for (i = 1; i < argc; i++)
1008         fakeargv[i + EXTRA_OPTIONS] = argv[i];
1009     fakeargv[argc + EXTRA_OPTIONS] = 0;
1010
1011     exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1012                             fakeargv, NULL);
1013     if (exitstatus)
1014         exit( exitstatus );
1015
1016     sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1017     PL_main_cv = PL_compcv;
1018     PL_compcv = 0;
1019
1020     exitstatus = perl_init();
1021     if (exitstatus)
1022         exit( exitstatus );
1023
1024     exitstatus = perl_run( my_perl );
1025
1026     perl_destruct( my_perl );
1027     perl_free( my_perl );
1028
1029     exit( exitstatus );
1030 }
1031
1032 static void
1033 xs_init()
1034 {
1035 }
1036 EOT
1037 }
1038
1039 sub dump_symtable {
1040     # For debugging
1041     my ($sym, $val);
1042     warn "----Symbol table:\n";
1043     while (($sym, $val) = each %symtable) {
1044         warn "$sym => $val\n";
1045     }
1046     warn "---End of symbol table\n";
1047 }
1048
1049 sub save_object {
1050     my $sv;
1051     foreach $sv (@_) {
1052         svref_2object($sv)->save;
1053     }
1054 }
1055
1056 sub B::GV::savecv {
1057     my $gv = shift;
1058     my $cv = $gv->CV;
1059     my $name = $gv->NAME;
1060     if ($$cv && !objsym($cv) && !($name eq "bootstrap" && $cv->XSUB)) {
1061         if ($debug_cv) {
1062             warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
1063                          $gv->STASH->NAME, $name, $$cv, $$gv);
1064         }
1065         $gv->save;
1066     }
1067 }
1068
1069 sub save_unused_subs {
1070     my %search_pack;
1071     map { $search_pack{$_} = 1 } @_;
1072     no strict qw(vars refs);
1073     walksymtable(\%{"main::"}, "savecv", sub {
1074         my $package = shift;
1075         $package =~ s/::$//;
1076         #warn "Considering $package\n";#debug
1077         return 1 if exists $search_pack{$package};
1078         #warn "    (nothing explicit)\n";#debug
1079         # Omit the packages which we use (and which cause grief
1080         # because of fancy "goto &$AUTOLOAD" stuff).
1081         # XXX Surely there must be a nicer way to do this.
1082         if ($package eq "FileHandle"
1083             || $package eq "Config"
1084             || $package eq "SelectSaver") {
1085             return 0;
1086         }
1087         my $m;
1088         foreach $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) {
1089             if (defined(&{$package."::$m"})) {
1090                 warn "$package has method $m: -u$package assumed\n";#debug
1091                 return 1;
1092             }
1093         }
1094         return 0;
1095     });
1096 }
1097
1098 sub save_main {
1099     my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1100     my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1101     walkoptree(main_root, "save");
1102     warn "done main optree, walking symtable for extras\n" if $debug_cv;
1103     save_unused_subs(@unused_sub_packages);
1104
1105     $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1106                sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1107                "PL_curpad = AvARRAY($curpad_sym);",
1108                "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1109                "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));");
1110
1111     output_boilerplate();
1112     print "\n";
1113     output_all("perl_init");
1114     print "\n";
1115     output_main();
1116 }
1117
1118 sub init_sections {
1119     my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1120                     binop => \$binopsect, condop => \$condopsect,
1121                     cop => \$copsect, cvop => \$cvopsect, gvop => \$gvopsect,
1122                     listop => \$listopsect, logop => \$logopsect,
1123                     loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1124                     pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1125                     sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1126                     xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1127                     xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1128                     xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1129                     xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1130                     xpvio => \$xpviosect);
1131     my ($name, $sectref);
1132     while (($name, $sectref) = splice(@sections, 0, 2)) {
1133         $$sectref = new B::Section $name, \%symtable, 0;
1134     }
1135 }
1136
1137 sub compile {
1138     my @options = @_;
1139     my ($option, $opt, $arg);
1140   OPTION:
1141     while ($option = shift @options) {
1142         if ($option =~ /^-(.)(.*)/) {
1143             $opt = $1;
1144             $arg = $2;
1145         } else {
1146             unshift @options, $option;
1147             last OPTION;
1148         }
1149         if ($opt eq "-" && $arg eq "-") {
1150             shift @options;
1151             last OPTION;
1152         }
1153         if ($opt eq "w") {
1154             $warn_undefined_syms = 1;
1155         } elsif ($opt eq "D") {
1156             $arg ||= shift @options;
1157             foreach $arg (split(//, $arg)) {
1158                 if ($arg eq "o") {
1159                     B->debug(1);
1160                 } elsif ($arg eq "c") {
1161                     $debug_cops = 1;
1162                 } elsif ($arg eq "A") {
1163                     $debug_av = 1;
1164                 } elsif ($arg eq "C") {
1165                     $debug_cv = 1;
1166                 } elsif ($arg eq "M") {
1167                     $debug_mg = 1;
1168                 } else {
1169                     warn "ignoring unknown debug option: $arg\n";
1170                 }
1171             }
1172         } elsif ($opt eq "o") {
1173             $arg ||= shift @options;
1174             open(STDOUT, ">$arg") or return "$arg: $!\n";
1175         } elsif ($opt eq "v") {
1176             $verbose = 1;
1177         } elsif ($opt eq "u") {
1178             $arg ||= shift @options;
1179             push(@unused_sub_packages, $arg);
1180         } elsif ($opt eq "f") {
1181             $arg ||= shift @options;
1182             if ($arg eq "cog") {
1183                 $pv_copy_on_grow = 1;
1184             } elsif ($arg eq "no-cog") {
1185                 $pv_copy_on_grow = 0;
1186             }
1187         } elsif ($opt eq "O") {
1188             $arg = 1 if $arg eq "";
1189             $pv_copy_on_grow = 0;
1190             if ($arg >= 1) {
1191                 # Optimisations for -O1
1192                 $pv_copy_on_grow = 1;
1193             }
1194         }
1195     }
1196     init_sections();
1197     if (@options) {
1198         return sub {
1199             my $objname;
1200             foreach $objname (@options) {
1201                 eval "save_object(\\$objname)";
1202             }
1203             output_all();
1204         }
1205     } else {
1206         return sub { save_main() };
1207     }
1208 }
1209
1210 1;
1211
1212 __END__
1213
1214 =head1 NAME
1215
1216 B::C - Perl compiler's C backend
1217
1218 =head1 SYNOPSIS
1219
1220         perl -MO=C[,OPTIONS] foo.pl
1221
1222 =head1 DESCRIPTION
1223
1224 This compiler backend takes Perl source and generates C source code
1225 corresponding to the internal structures that perl uses to run
1226 your program. When the generated C source is compiled and run, it
1227 cuts out the time which perl would have taken to load and parse
1228 your program into its internal semi-compiled form. That means that
1229 compiling with this backend will not help improve the runtime
1230 execution speed of your program but may improve the start-up time.
1231 Depending on the environment in which your program runs this may be
1232 either a help or a hindrance.
1233
1234 =head1 OPTIONS
1235
1236 If there are any non-option arguments, they are taken to be
1237 names of objects to be saved (probably doesn't work properly yet).
1238 Without extra arguments, it saves the main program.
1239
1240 =over 4
1241
1242 =item B<-ofilename>
1243
1244 Output to filename instead of STDOUT
1245
1246 =item B<-v>
1247
1248 Verbose compilation (currently gives a few compilation statistics).
1249
1250 =item B<-->
1251
1252 Force end of options
1253
1254 =item B<-uPackname>
1255
1256 Force apparently unused subs from package Packname to be compiled.
1257 This allows programs to use eval "foo()" even when sub foo is never
1258 seen to be used at compile time. The down side is that any subs which
1259 really are never used also have code generated. This option is
1260 necessary, for example, if you have a signal handler foo which you
1261 initialise with C<$SIG{BAR} = "foo">.  A better fix, though, is just
1262 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1263 options. The compiler tries to figure out which packages may possibly
1264 have subs in which need compiling but the current version doesn't do
1265 it very well. In particular, it is confused by nested packages (i.e.
1266 of the form C<A::B>) where package C<A> does not contain any subs.
1267
1268 =item B<-D>
1269
1270 Debug options (concatenated or separate flags like C<perl -D>).
1271
1272 =item B<-Do>
1273
1274 OPs, prints each OP as it's processed
1275
1276 =item B<-Dc>
1277
1278 COPs, prints COPs as processed (incl. file & line num)
1279
1280 =item B<-DA>
1281
1282 prints AV information on saving
1283
1284 =item B<-DC>
1285
1286 prints CV information on saving
1287
1288 =item B<-DM>
1289
1290 prints MAGIC information on saving
1291
1292 =item B<-f>
1293
1294 Force optimisations on or off one at a time.
1295
1296 =item B<-fcog>
1297
1298 Copy-on-grow: PVs declared and initialised statically.
1299
1300 =item B<-fno-cog>
1301
1302 No copy-on-grow.
1303
1304 =item B<-On>
1305
1306 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.  Currently,
1307 B<-O1> and higher set B<-fcog>.
1308
1309 =head1 EXAMPLES
1310
1311     perl -MO=C,-ofoo.c foo.pl
1312     perl cc_harness -o foo foo.c
1313
1314 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1315 library directory. The utility called C<perlcc> may also be used to
1316 help make use of this compiler.
1317
1318     perl -MO=C,-v,-DcA bar.pl > /dev/null
1319
1320 =head1 BUGS
1321
1322 Plenty. Current status: experimental.
1323
1324 =head1 AUTHOR
1325
1326 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
1327
1328 =cut