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