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