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