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);
  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, 0",
 600                           $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
 601                           $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
 602                           $$padlist, ${$cv->OUTSIDE}));
 603     if ($$gv) {
 604         $gv->save;
 605         $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
 606         warn sprintf("done saving GV 0x%x for CV 0x%x\n",
 607                      $$gv, $$cv) if $debug_cv;
 608     }
 609     my $filegv = $cv->FILEGV;
 610     if ($$filegv) {
 611         $filegv->save;
 612         $init->add(sprintf("CvFILEGV(s\\_%x) = s\\_%x;", $$cv, $$filegv));
 613         warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n",
 614                      $$filegv, $$cv) if $debug_cv;
 615     }
 616     my $stash = $cv->STASH;
 617     if ($$stash) {
 618         $stash->save;
 619         $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
 620         warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
 621                      $$stash, $$cv) if $debug_cv;
 622     }
 623     $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
 624                           $sv_ix, $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS));
 625     return $sym;
 626 }
 627
 628 sub B::GV::save {
 629     my ($gv) = @_;
 630     my $sym = objsym($gv);
 631     if (defined($sym)) {
 632         #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
 633         return $sym;
 634     } else {
 635         my $ix = $gv_index++;
 636         $sym = savesym($gv, "gv_list[$ix]");
 637         #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
 638     }
 639     my $gvname = $gv->NAME;
 640     my $name = cstring($gv->STASH->NAME . "::" . $gvname);
 641     #warn "GV name is $name\n"; # debug
 642     my $egv = $gv->EGV;
 643     my $egvsym;
 644     if ($$gv != $$egv) {
 645         #warn(sprintf("EGV name is %s, saving it now\n",
 646         #            $egv->STASH->NAME . "::" . $egv->NAME)); # debug
 647         $egvsym = $egv->save;
 648     }
 649     $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
 650                sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
 651                sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS),
 652                sprintf("GvLINE($sym) = %u;", $gv->LINE));
 653     # Shouldn't need to do save_magic since gv_fetchpv handles that
 654     #$gv->save_magic;
 655     my $refcnt = $gv->REFCNT + 1;
 656     $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
 657     my $gvrefcnt = $gv->GvREFCNT;
 658     if ($gvrefcnt > 1) {
 659         $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
 660     }
 661     if (defined($egvsym)) {
 662         # Shared glob *foo = *bar
 663         $init->add("gp_free($sym);",
 664                    "GvGP($sym) = GvGP($egvsym);");
 665     } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
 666         # Don't save subfields of special GVs (*_, *1, *# and so on)
 667 #       warn "GV::save saving subfields\n"; # debug
 668         my $gvsv = $gv->SV;
 669         if ($$gvsv) {
 670             $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
 671 #           warn "GV::save \$$name\n"; # debug
 672             $gvsv->save;
 673         }
 674         my $gvav = $gv->AV;
 675         if ($$gvav) {
 676             $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
 677 #           warn "GV::save \@$name\n"; # debug
 678             $gvav->save;
 679         }
 680         my $gvhv = $gv->HV;
 681         if ($$gvhv) {
 682             $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
 683 #           warn "GV::save \%$name\n"; # debug
 684             $gvhv->save;
 685         }
 686         my $gvcv = $gv->CV;
 687         if ($$gvcv) {
 688             $init->add(sprintf("GvCV($sym) = (CV*)s\\_%x;", $$gvcv));
 689 #           warn "GV::save &$name\n"; # debug
 690             $gvcv->save;
 691         }
 692         my $gvfilegv = $gv->FILEGV;
 693         if ($$gvfilegv) {
 694             $init->add(sprintf("GvFILEGV($sym) = s\\_%x;",$$gvfilegv));
 695 #           warn "GV::save GvFILEGV(*$name)\n"; # debug
 696             $gvfilegv->save;
 697         }
 698         my $gvform = $gv->FORM;
 699         if ($$gvform) {
 700             $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
 701 #           warn "GV::save GvFORM(*$name)\n"; # debug
 702             $gvform->save;
 703         }
 704         my $gvio = $gv->IO;
 705         if ($$gvio) {
 706             $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
 707 #           warn "GV::save GvIO(*$name)\n"; # debug
 708             $gvio->save;
 709         }
 710     }
 711     return $sym;
 712 }
 713 sub B::AV::save {
 714     my ($av) = @_;
 715     my $sym = objsym($av);
 716     return $sym if defined $sym;
 717     my $avflags = $av->AvFLAGS;
 718     $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
 719                             $avflags));
 720     $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
 721                          $xpvavsect->index, $av->REFCNT + 1, $av->FLAGS));
 722     my $sv_list_index = $svsect->index;
 723     my $fill = $av->FILL;
 724     $av->save_magic;
 725     warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
 726         if $debug_av;
 727     # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
 728     #if ($fill > -1 && ($avflags & AVf_REAL)) {
 729     if ($fill > -1) {
 730         my @array = $av->ARRAY;
 731         if ($debug_av) {
 732             my $el;
 733             my $i = 0;
 734             foreach $el (@array) {
 735                 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
 736                              $$av, $i++, class($el), $$el);
 737             }
 738         }
 739         my @names = map($_->save, @array);
 740         # XXX Better ways to write loop?
 741         # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
 742         # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
 743         $init->add("{",
 744                    "\tSV **svp;",
 745                    "\tAV *av = (AV*)&sv_list[$sv_list_index];",
 746                    "\tav_extend(av, $fill);",
 747                    "\tsvp = AvARRAY(av);",
 748                map("\t*svp++ = (SV*)$_;", @names),
 749                    "\tAvFILLp(av) = $fill;",
 750                    "}");
 751     } else {
 752         my $max = $av->MAX;
 753         $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
 754             if $max > -1;
 755     }
 756     return savesym($av, "(AV*)&sv_list[$sv_list_index]");
 757 }
 758
 759 sub B::HV::save {
 760     my ($hv) = @_;
 761     my $sym = objsym($hv);
 762     return $sym if defined $sym;
 763     my $name = $hv->NAME;
 764     if ($name) {
 765         # It's a stash
 766
 767         # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
 768         # the only symptom is that sv_reset tries to reset the PMf_USED flag of
 769         # a trashed op but we look at the trashed op_type and segfault.
 770         #my $adpmroot = ${$hv->PMROOT};
 771         my $adpmroot = 0;
 772         $decl->add("static HV *hv$hv_index;");
 773         # XXX Beware of weird package names containing double-quotes, \n, ...?
 774         $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
 775         if ($adpmroot) {
 776             $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
 777                                $adpmroot));
 778         }
 779         $sym = savesym($hv, "hv$hv_index");
 780         $hv_index++;
 781         return $sym;
 782     }
 783     # It's just an ordinary HV
 784     $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
 785                             $hv->MAX, $hv->RITER));
 786     $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
 787                          $xpvhvsect->index, $hv->REFCNT + 1, $hv->FLAGS));
 788     my $sv_list_index = $svsect->index;
 789     my @contents = $hv->ARRAY;
 790     if (@contents) {
 791         my $i;
 792         for ($i = 1; $i < @contents; $i += 2) {
 793             $contents[$i] = $contents[$i]->save;
 794         }
 795         $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
 796         while (@contents) {
 797             my ($key, $value) = splice(@contents, 0, 2);
 798             $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
 799                                cstring($key),length($key),$value, hash($key)));
 800         }
 801         $init->add("}");
 802     }
 803     return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
 804 }
 805
 806 sub B::IO::save {
 807     my ($io) = @_;
 808     my $sym = objsym($io);
 809     return $sym if defined $sym;
 810     my $pv = $io->PV;
 811     my $len = length($pv);
 812     $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",
 813                             $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
 814                             $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
 815                             cstring($io->TOP_NAME), cstring($io->FMT_NAME),
 816                             cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
 817                             cchar($io->IoTYPE), $io->IoFLAGS));
 818     $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
 819                          $xpviosect->index, $io->REFCNT + 1, $io->FLAGS));
 820     $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
 821     my ($field, $fsym);
 822     foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
 823         $fsym = $io->$field();
 824         if ($$fsym) {
 825             $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
 826             $fsym->save;
 827         }
 828     }
 829     $io->save_magic;
 830     return $sym;
 831 }
 832
 833 sub B::SV::save {
 834     my $sv = shift;
 835     # This is where we catch an honest-to-goodness Nullsv (which gets
 836     # blessed into B::SV explicitly) and any stray erroneous SVs.
 837     return 0 unless $$sv;
 838     confess sprintf("cannot save that type of SV: %s (0x%x)\n",
 839                     class($sv), $$sv);
 840 }
 841
 842 sub output_all {
 843     my $init_name = shift;
 844     my $section;
 845     my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
 846                     $listopsect, $pmopsect, $svopsect, $gvopsect, $pvopsect,
 847                     $cvopsect, $loopsect, $copsect, $svsect, $xpvsect,
 848                     $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
 849                     $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
 850     $symsect->output(\*STDOUT, "#define %s\n");
 851     print "\n";
 852     output_declarations();
 853     foreach $section (@sections) {
 854         my $lines = $section->index + 1;
 855         if ($lines) {
 856             my $name = $section->name;
 857             my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
 858             print "Static $typename ${name}_list[$lines];\n";
 859         }
 860     }
 861     $decl->output(\*STDOUT, "%s\n");
 862     print "\n";
 863     foreach $section (@sections) {
 864         my $lines = $section->index + 1;
 865         if ($lines) {
 866             my $name = $section->name;
 867             my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
 868             printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
 869             $section->output(\*STDOUT, "\t{ %s },\n");
 870             print "};\n\n";
 871         }
 872     }
 873
 874     print <<"EOT";
 875 static int $init_name()
 876 {
 877         dTHR;
 878 EOT
 879     $init->output(\*STDOUT, "\t%s\n");
 880     print "\treturn 0;\n}\n";
 881     if ($verbose) {
 882         warn compile_stats();
 883         warn "NULLOP count: $nullop_count\n";
 884     }
 885 }
 886
 887 sub output_declarations {
 888     print <<'EOT';
 889 #ifdef BROKEN_STATIC_REDECL
 890 #define Static extern
 891 #else
 892 #define Static static
 893 #endif /* BROKEN_STATIC_REDECL */
 894
 895 #ifdef BROKEN_UNION_INIT
 896 /*
 897  * Cribbed from cv.h with ANY (a union) replaced by void*.
 898  * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
 899  */
 900 typedef struct {
 901     char *      xpv_pv;         /* pointer to malloced string */
 902     STRLEN      xpv_cur;        /* length of xp_pv as a C string */
 903     STRLEN      xpv_len;        /* allocated size */
 904     IV          xof_off;        /* integer value */
 905     double      xnv_nv;         /* numeric value, if any */
 906     MAGIC*      xmg_magic;      /* magic for scalar array */
 907     HV*         xmg_stash;      /* class package */
 908
 909     HV *        xcv_stash;
 910     OP *        xcv_start;
 911     OP *        xcv_root;
 912     void      (*xcv_xsub) _((CV*));
 913     void *      xcv_xsubany;
 914     GV *        xcv_gv;
 915     GV *        xcv_filegv;
 916     long        xcv_depth;              /* >= 2 indicates recursive call */
 917     AV *        xcv_padlist;
 918     CV *        xcv_outside;
 919 #ifdef USE_THREADS
 920     perl_mutex *xcv_mutexp;
 921     struct perl_thread *xcv_owner;      /* current owner thread */
 922 #endif /* USE_THREADS */
 923     U8          xcv_flags;
 924 } XPVCV_or_similar;
 925 #define ANYINIT(i) i
 926 #else
 927 #define XPVCV_or_similar XPVCV
 928 #define ANYINIT(i) {i}
 929 #endif /* BROKEN_UNION_INIT */
 930 #define Nullany ANYINIT(0)
 931
 932 #define UNUSED 0
 933 #define sym_0 0
 934
 935 EOT
 936     print "static GV *gv_list[$gv_index];\n" if $gv_index;
 937     print "\n";
 938 }
 939
 940
 941 sub output_boilerplate {
 942     print <<'EOT';
 943 #include "EXTERN.h"
 944 #include "perl.h"
 945 #ifndef PATCHLEVEL
 946 #include "patchlevel.h"
 947 #endif
 948
 949 /* Workaround for mapstart: the only op which needs a different ppaddr */
 950 #undef pp_mapstart
 951 #define pp_mapstart pp_grepstart
 952
 953 static void xs_init _((void));
 954 static PerlInterpreter *my_perl;
 955 EOT
 956 }
 957
 958 sub output_main {
 959     print <<'EOT';
 960 int
 961 #ifndef CAN_PROTOTYPE
 962 main(argc, argv, env)
 963 int argc;
 964 char **argv;
 965 char **env;
 966 #else  /* def(CAN_PROTOTYPE) */
 967 main(int argc, char **argv, char **env)
 968 #endif  /* def(CAN_PROTOTYPE) */
 969 {
 970     int exitstatus;
 971     int i;
 972     char **fakeargv;
 973
 974     PERL_SYS_INIT(&argc,&argv);
 975
 976     perl_init_i18nl10n(1);
 977
 978     if (!PL_do_undump) {
 979         my_perl = perl_alloc();
 980         if (!my_perl)
 981             exit(1);
 982         perl_construct( my_perl );
 983     }
 984
 985 #ifdef CSH
 986     if (!PL_cshlen)
 987       PL_cshlen = strlen(PL_cshname);
 988 #endif
 989
 990 #ifdef ALLOW_PERL_OPTIONS
 991 #define EXTRA_OPTIONS 2
 992 #else
 993 #define EXTRA_OPTIONS 3
 994 #endif /* ALLOW_PERL_OPTIONS */
 995     New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
 996     fakeargv[0] = argv[0];
 997     fakeargv[1] = "-e";
 998     fakeargv[2] = "";
 999 #ifndef ALLOW_PERL_OPTIONS
1000     fakeargv[3] = "--";
1001 #endif /* ALLOW_PERL_OPTIONS */
1002     for (i = 1; i < argc; i++)
1003         fakeargv[i + EXTRA_OPTIONS] = argv[i];
1004     fakeargv[argc + EXTRA_OPTIONS] = 0;
1005
1006     exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1007                             fakeargv, NULL);
1008     if (exitstatus)
1009         exit( exitstatus );
1010
1011     sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1012     PL_main_cv = PL_compcv;
1013     PL_compcv = 0;
1014
1015     exitstatus = perl_init();
1016     if (exitstatus)
1017         exit( exitstatus );
1018
1019     exitstatus = perl_run( my_perl );
1020
1021     perl_destruct( my_perl );
1022     perl_free( my_perl );
1023
1024     exit( exitstatus );
1025 }
1026
1027 static void
1028 xs_init()
1029 {
1030 }
1031 EOT
1032 }
1033
1034 sub dump_symtable {
1035     # For debugging
1036     my ($sym, $val);
1037     warn "----Symbol table:\n";
1038     while (($sym, $val) = each %symtable) {
1039         warn "$sym => $val\n";
1040     }
1041     warn "---End of symbol table\n";
1042 }
1043
1044 sub save_object {
1045     my $sv;
1046     foreach $sv (@_) {
1047         svref_2object($sv)->save;
1048     }
1049 }
1050
1051 sub B::GV::savecv {
1052     my $gv = shift;
1053     my $cv = $gv->CV;
1054     my $name = $gv->NAME;
1055     if ($$cv && !objsym($cv) && !($name eq "bootstrap" && $cv->XSUB)) {
1056         if ($debug_cv) {
1057             warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
1058                          $gv->STASH->NAME, $name, $$cv, $$gv);
1059         }
1060         $gv->save;
1061     }
1062 }
1063
1064 sub save_unused_subs {
1065     my %search_pack;
1066     map { $search_pack{$_} = 1 } @_;
1067     no strict qw(vars refs);
1068     walksymtable(\%{"main::"}, "savecv", sub {
1069         my $package = shift;
1070         $package =~ s/::$//;
1071         #warn "Considering $package\n";#debug
1072         return 1 if exists $search_pack{$package};
1073         #warn "    (nothing explicit)\n";#debug
1074         # Omit the packages which we use (and which cause grief
1075         # because of fancy "goto &$AUTOLOAD" stuff).
1076         # XXX Surely there must be a nicer way to do this.
1077         if ($package eq "FileHandle"
1078             || $package eq "Config"
1079             || $package eq "SelectSaver") {
1080             return 0;
1081         }
1082         my $m;
1083         foreach $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) {
1084             if (defined(&{$package."::$m"})) {
1085                 warn "$package has method $m: -u$package assumed\n";#debug
1086                 return 1;
1087             }
1088         }
1089         return 0;
1090     });
1091 }
1092
1093 sub save_main {
1094     my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1095     walkoptree(main_root, "save");
1096     warn "done main optree, walking symtable for extras\n" if $debug_cv;
1097     save_unused_subs(@unused_sub_packages);
1098
1099     $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1100                sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1101                "PL_curpad = AvARRAY($curpad_sym);");
1102     output_boilerplate();
1103     print "\n";
1104     output_all("perl_init");
1105     print "\n";
1106     output_main();
1107 }
1108
1109 sub init_sections {
1110     my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1111                     binop => \$binopsect, condop => \$condopsect,
1112                     cop => \$copsect, cvop => \$cvopsect, gvop => \$gvopsect,
1113                     listop => \$listopsect, logop => \$logopsect,
1114                     loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1115                     pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1116                     sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1117                     xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1118                     xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1119                     xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1120                     xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1121                     xpvio => \$xpviosect);
1122     my ($name, $sectref);
1123     while (($name, $sectref) = splice(@sections, 0, 2)) {
1124         $$sectref = new B::Section $name, \%symtable, 0;
1125     }
1126 }
1127
1128 sub compile {
1129     my @options = @_;
1130     my ($option, $opt, $arg);
1131   OPTION:
1132     while ($option = shift @options) {
1133         if ($option =~ /^-(.)(.*)/) {
1134             $opt = $1;
1135             $arg = $2;
1136         } else {
1137             unshift @options, $option;
1138             last OPTION;
1139         }
1140         if ($opt eq "-" && $arg eq "-") {
1141             shift @options;
1142             last OPTION;
1143         }
1144         if ($opt eq "w") {
1145             $warn_undefined_syms = 1;
1146         } elsif ($opt eq "D") {
1147             $arg ||= shift @options;
1148             foreach $arg (split(//, $arg)) {
1149                 if ($arg eq "o") {
1150                     B->debug(1);
1151                 } elsif ($arg eq "c") {
1152                     $debug_cops = 1;
1153                 } elsif ($arg eq "A") {
1154                     $debug_av = 1;
1155                 } elsif ($arg eq "C") {
1156                     $debug_cv = 1;
1157                 } elsif ($arg eq "M") {
1158                     $debug_mg = 1;
1159                 } else {
1160                     warn "ignoring unknown debug option: $arg\n";
1161                 }
1162             }
1163         } elsif ($opt eq "o") {
1164             $arg ||= shift @options;
1165             open(STDOUT, ">$arg") or return "$arg: $!\n";
1166         } elsif ($opt eq "v") {
1167             $verbose = 1;
1168         } elsif ($opt eq "u") {
1169             $arg ||= shift @options;
1170             push(@unused_sub_packages, $arg);
1171         } elsif ($opt eq "f") {
1172             $arg ||= shift @options;
1173             if ($arg eq "cog") {
1174                 $pv_copy_on_grow = 1;
1175             } elsif ($arg eq "no-cog") {
1176                 $pv_copy_on_grow = 0;
1177             }
1178         } elsif ($opt eq "O") {
1179             $arg = 1 if $arg eq "";
1180             $pv_copy_on_grow = 0;
1181             if ($arg >= 1) {
1182                 # Optimisations for -O1
1183                 $pv_copy_on_grow = 1;
1184             }
1185         }
1186     }
1187     init_sections();
1188     if (@options) {
1189         return sub {
1190             my $objname;
1191             foreach $objname (@options) {
1192                 eval "save_object(\\$objname)";
1193             }
1194             output_all();
1195         }
1196     } else {
1197         return sub { save_main() };
1198     }
1199 }
1200
1201 1;
1202
1203 __END__
1204
1205 =head1 NAME
1206
1207 B::C - Perl compiler's C backend
1208
1209 =head1 SYNOPSIS
1210
1211         perl -MO=C[,OPTIONS] foo.pl
1212
1213 =head1 DESCRIPTION
1214
1215 This compiler backend takes Perl source and generates C source code
1216 corresponding to the internal structures that perl uses to run
1217 your program. When the generated C source is compiled and run, it
1218 cuts out the time which perl would have taken to load and parse
1219 your program into its internal semi-compiled form. That means that
1220 compiling with this backend will not help improve the runtime
1221 execution speed of your program but may improve the start-up time.
1222 Depending on the environment in which your program runs this may be
1223 either a help or a hindrance.
1224
1225 =head1 OPTIONS
1226
1227 If there are any non-option arguments, they are taken to be
1228 names of objects to be saved (probably doesn't work properly yet).
1229 Without extra arguments, it saves the main program.
1230
1231 =over 4
1232
1233 =item B<-ofilename>
1234
1235 Output to filename instead of STDOUT
1236
1237 =item B<-v>
1238
1239 Verbose compilation (currently gives a few compilation statistics).
1240
1241 =item B<-->
1242
1243 Force end of options
1244
1245 =item B<-uPackname>
1246
1247 Force apparently unused subs from package Packname to be compiled.
1248 This allows programs to use eval "foo()" even when sub foo is never
1249 seen to be used at compile time. The down side is that any subs which
1250 really are never used also have code generated. This option is
1251 necessary, for example, if you have a signal handler foo which you
1252 initialise with C<$SIG{BAR} = "foo">.  A better fix, though, is just
1253 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1254 options. The compiler tries to figure out which packages may possibly
1255 have subs in which need compiling but the current version doesn't do
1256 it very well. In particular, it is confused by nested packages (i.e.
1257 of the form C<A::B>) where package C<A> does not contain any subs.
1258
1259 =item B<-D>
1260
1261 Debug options (concatenated or separate flags like C<perl -D>).
1262
1263 =item B<-Do>
1264
1265 OPs, prints each OP as it's processed
1266
1267 =item B<-Dc>
1268
1269 COPs, prints COPs as processed (incl. file & line num)
1270
1271 =item B<-DA>
1272
1273 prints AV information on saving
1274
1275 =item B<-DC>
1276
1277 prints CV information on saving
1278
1279 =item B<-DM>
1280
1281 prints MAGIC information on saving
1282
1283 =item B<-f>
1284
1285 Force optimisations on or off one at a time.
1286
1287 =item B<-fcog>
1288
1289 Copy-on-grow: PVs declared and initialised statically.
1290
1291 =item B<-fno-cog>
1292
1293 No copy-on-grow.
1294
1295 =item B<-On>
1296
1297 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.  Currently,
1298 B<-O1> and higher set B<-fcog>.
1299
1300 =head1 EXAMPLES
1301
1302     perl -MO=C,-ofoo.c foo.pl
1303     perl cc_harness -o foo foo.c
1304
1305 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1306 library directory. The utility called C<perlcc> may also be used to
1307 help make use of this compiler.
1308
1309     perl -MO=C,-v,-DcA bar.pl > /dev/null
1310
1311 =head1 BUGS
1312
1313 Plenty. Current status: experimental.
1314
1315 =head1 AUTHOR
1316
1317 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
1318
1319 =cut