ext/B/B/C.pm

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