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