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, %s",
 273                            ${$op->next}, ${$op->sibling}, $op->ppaddr,
 274                            $op->targ, $op->type, $op_seq, $op->flags,
 275                            $op->private, "(SV*)$svsym"));
 276     savesym($op, sprintf("(OP*)&svop_list[%d]", $svopsect->index));
 277 }
 278
 279 sub B::PADOP::save {
 280     my ($op, $level) = @_;
 281     my $sym = objsym($op);
 282     return $sym if defined $sym;
 283     $padopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, Nullgv",
 284                            ${$op->next}, ${$op->sibling}, $op->ppaddr,
 285                            $op->targ, $op->type, $op_seq, $op->flags,
 286                            $op->private));
 287     $init->add(sprintf("padop_list[%d].op_padix = %ld;",
 288                        $padopsect->index, $op->padix));
 289     savesym($op, sprintf("(OP*)&padop_list[%d]", $padopsect->index));
 290 }
 291
 292 sub B::COP::save {
 293     my ($op, $level) = @_;
 294     my $sym = objsym($op);
 295     return $sym if defined $sym;
 296     my $stashsym = $op->stash->save;
 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("cop_list[%d].cop_stash = %s;", $copix, $stashsym));
 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, 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 (CV* cv);
1050
1051 static void xs_init (void);
1052 static void dl_init (void);
1053 static PerlInterpreter *my_perl;
1054 EOT
1055 }
1056
1057 sub output_main {
1058     print <<'EOT';
1059 int
1060 #ifndef CAN_PROTOTYPE
1061 main(argc, argv, env)
1062 int argc;
1063 char **argv;
1064 char **env;
1065 #else  /* def(CAN_PROTOTYPE) */
1066 main(int argc, char **argv, char **env)
1067 #endif  /* def(CAN_PROTOTYPE) */
1068 {
1069     int exitstatus;
1070     int i;
1071     char **fakeargv;
1072
1073     PERL_SYS_INIT(&argc,&argv);
1074
1075     perl_init_i18nl10n(1);
1076
1077     if (!PL_do_undump) {
1078         my_perl = perl_alloc();
1079         if (!my_perl)
1080             exit(1);
1081         perl_construct( my_perl );
1082     }
1083
1084 #ifdef CSH
1085     if (!PL_cshlen)
1086       PL_cshlen = strlen(PL_cshname);
1087 #endif
1088
1089 #ifdef ALLOW_PERL_OPTIONS
1090 #define EXTRA_OPTIONS 2
1091 #else
1092 #define EXTRA_OPTIONS 3
1093 #endif /* ALLOW_PERL_OPTIONS */
1094     New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1095     fakeargv[0] = argv[0];
1096     fakeargv[1] = "-e";
1097     fakeargv[2] = "";
1098 #ifndef ALLOW_PERL_OPTIONS
1099     fakeargv[3] = "--";
1100 #endif /* ALLOW_PERL_OPTIONS */
1101     for (i = 1; i < argc; i++)
1102         fakeargv[i + EXTRA_OPTIONS] = argv[i];
1103     fakeargv[argc + EXTRA_OPTIONS] = 0;
1104
1105     exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1106                             fakeargv, NULL);
1107     if (exitstatus)
1108         exit( exitstatus );
1109
1110     sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1111     PL_main_cv = PL_compcv;
1112     PL_compcv = 0;
1113
1114     exitstatus = perl_init();
1115     if (exitstatus)
1116         exit( exitstatus );
1117     dl_init();
1118
1119     exitstatus = perl_run( my_perl );
1120
1121     perl_destruct( my_perl );
1122     perl_free( my_perl );
1123
1124     exit( exitstatus );
1125 }
1126
1127 /* yanked from perl.c */
1128 static void
1129 xs_init()
1130 {
1131     char *file = __FILE__;
1132     dTARG;
1133     djSP;
1134 EOT
1135     print "\n#ifdef USE_DYNAMIC_LOADING";
1136     print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1137     print "\n#endif\n" ;
1138     # delete $xsub{'DynaLoader'};
1139     delete $xsub{'UNIVERSAL'};
1140     print("/* bootstrapping code*/\n\tSAVETMPS;\n");
1141     print("\ttarg=sv_newmortal();\n");
1142     print "#ifdef DYNALOADER_BOOTSTRAP\n";
1143     print "\tPUSHMARK(sp);\n";
1144     print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
1145     print qq/\tPUTBACK;\n/;
1146     print "\tboot_DynaLoader(NULL);\n";
1147     print qq/\tSPAGAIN;\n/;
1148     print "#endif\n";
1149     foreach my $stashname (keys %xsub){
1150         if ($xsub{$stashname} ne 'Dynamic') {
1151            my $stashxsub=$stashname;
1152            $stashxsub  =~ s/::/__/g;
1153            print "\tPUSHMARK(sp);\n";
1154            print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
1155            print qq/\tPUTBACK;\n/;
1156            print "\tboot_$stashxsub(NULL);\n";
1157            print qq/\tSPAGAIN;\n/;
1158         }
1159     }
1160     print("\tFREETMPS;\n/* end bootstrapping code */\n");
1161     print "}\n";
1162
1163 print <<'EOT';
1164 static void
1165 dl_init()
1166 {
1167     char *file = __FILE__;
1168     dTARG;
1169     djSP;
1170 EOT
1171     print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
1172     print("\ttarg=sv_newmortal();\n");
1173     foreach my $stashname (@DynaLoader::dl_modules) {
1174         warn "Loaded $stashname\n";
1175         if (exists($xsub{$stashname}) && $xsub{$stashname} eq 'Dynamic') {
1176            my $stashxsub=$stashname;
1177            $stashxsub  =~ s/::/__/g;
1178            print "\tPUSHMARK(sp);\n";
1179            print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
1180            print qq/\tPUTBACK;\n/;
1181            print "#ifdef DYNALOADER_BOOTSTRAP\n";
1182            warn "bootstrapping $stashname added to xs_init\n";
1183            print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
1184            print "\n#else\n";
1185            print "\tboot_$stashxsub(NULL);\n";
1186            print "#endif\n";
1187            print qq/\tSPAGAIN;\n/;
1188         }
1189     }
1190     print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
1191     print "}\n";
1192 }
1193 sub dump_symtable {
1194     # For debugging
1195     my ($sym, $val);
1196     warn "----Symbol table:\n";
1197     while (($sym, $val) = each %symtable) {
1198         warn "$sym => $val\n";
1199     }
1200     warn "---End of symbol table\n";
1201 }
1202
1203 sub save_object {
1204     my $sv;
1205     foreach $sv (@_) {
1206         svref_2object($sv)->save;
1207     }
1208 }
1209
1210 sub Dummy_BootStrap { }
1211
1212 sub B::GV::savecv
1213 {
1214  my $gv = shift;
1215  my $package=$gv->STASH->NAME;
1216  my $name = $gv->NAME;
1217  my $cv = $gv->CV;
1218  my $sv = $gv->SV;
1219  my $av = $gv->AV;
1220  my $hv = $gv->HV;
1221
1222  # We may be looking at this package just because it is a branch in the
1223  # symbol table which is on the path to a package which we need to save
1224  # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1225  #
1226  return unless ($unused_sub_packages{$package});
1227  return unless ($$cv || $$av || $$sv || $$hv);
1228  $gv->save;
1229 }
1230
1231 sub mark_package
1232 {
1233  my $package = shift;
1234  unless ($unused_sub_packages{$package})
1235   {
1236    no strict 'refs';
1237    $unused_sub_packages{$package} = 1;
1238    if (defined @{$package.'::ISA'})
1239     {
1240      foreach my $isa (@{$package.'::ISA'})
1241       {
1242        if ($isa eq 'DynaLoader')
1243         {
1244          unless (defined(&{$package.'::bootstrap'}))
1245           {
1246            warn "Forcing bootstrap of $package\n";
1247            eval { $package->bootstrap };
1248           }
1249         }
1250 #      else
1251         {
1252          unless ($unused_sub_packages{$isa})
1253           {
1254            warn "$isa saved (it is in $package\'s \@ISA)\n";
1255            mark_package($isa);
1256           }
1257         }
1258       }
1259     }
1260   }
1261  return 1;
1262 }
1263
1264 sub should_save
1265 {
1266  no strict qw(vars refs);
1267  my $package = shift;
1268  $package =~ s/::$//;
1269  return $unused_sub_packages{$package} = 0 if ($package =~ /::::/);  # skip ::::ISA::CACHE etc.
1270  # warn "Considering $package\n";#debug
1271  foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1272   {
1273    # If this package is a prefix to something we are saving, traverse it
1274    # but do not mark it for saving if it is not already
1275    # e.g. to get to Getopt::Long we need to traverse Getopt but need
1276    # not save Getopt
1277    return 1 if ($u =~ /^$package\:\:/);
1278   }
1279  if (exists $unused_sub_packages{$package})
1280   {
1281    # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1282    delete_unsaved_hashINC($package) unless  $unused_sub_packages{$package} ;
1283    return $unused_sub_packages{$package};
1284   }
1285  # Omit the packages which we use (and which cause grief
1286  # because of fancy "goto &$AUTOLOAD" stuff).
1287  # XXX Surely there must be a nicer way to do this.
1288  if ($package eq "FileHandle" || $package eq "Config" ||
1289      $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1290   {
1291    delete_unsaved_hashINC($package);
1292    return $unused_sub_packages{$package} = 0;
1293   }
1294  # Now see if current package looks like an OO class this is probably too strong.
1295  foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1296   {
1297    if ($package->can($m))
1298     {
1299      warn "$package has method $m: saving package\n";#debug
1300      return mark_package($package);
1301     }
1302   }
1303  delete_unsaved_hashINC($package);
1304  return $unused_sub_packages{$package} = 0;
1305 }
1306 sub delete_unsaved_hashINC{
1307         my $packname=shift;
1308         $packname =~ s/\:\:/\//g;
1309         $packname .= '.pm';
1310 #       warn "deleting $packname" if $INC{$packname} ;# debug
1311         delete $INC{$packname};
1312 }
1313 sub walkpackages
1314 {
1315  my ($symref, $recurse, $prefix) = @_;
1316  my $sym;
1317  my $ref;
1318  no strict 'vars';
1319  local(*glob);
1320  $prefix = '' unless defined $prefix;
1321  while (($sym, $ref) = each %$symref)
1322   {
1323    *glob = $ref;
1324    if ($sym =~ /::$/)
1325     {
1326      $sym = $prefix . $sym;
1327      if ($sym ne "main::" && &$recurse($sym))
1328       {
1329        walkpackages(\%glob, $recurse, $sym);
1330       }
1331     }
1332   }
1333 }
1334
1335
1336 sub save_unused_subs
1337 {
1338  no strict qw(refs);
1339  &descend_marked_unused;
1340  warn "Prescan\n";
1341  walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1342  warn "Saving methods\n";
1343  walksymtable(\%{"main::"}, "savecv", \&should_save);
1344 }
1345
1346 sub save_context
1347 {
1348  my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1349  my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1350  my $inc_hv     = svref_2object(\%INC)->save;
1351  my $inc_av     = svref_2object(\@INC)->save;
1352  my $amagic_generate= amagic_generation;
1353  $init->add(   "PL_curpad = AvARRAY($curpad_sym);",
1354                "GvHV(PL_incgv) = $inc_hv;",
1355                "GvAV(PL_incgv) = $inc_av;",
1356                "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1357                "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1358                 "PL_amagic_generation= $amagic_generate;" );
1359 }
1360
1361 sub descend_marked_unused {
1362     foreach my $pack (keys %unused_sub_packages)
1363     {
1364         mark_package($pack);
1365     }
1366 }
1367
1368 sub save_main {
1369     warn "Starting compile\n";
1370     warn "Walking tree\n";
1371     seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1372     walkoptree(main_root, "save");
1373     warn "done main optree, walking symtable for extras\n" if $debug_cv;
1374     save_unused_subs();
1375     my $init_av = init_av->save;
1376     $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1377                sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1378               "PL_initav = (AV *) $init_av;");
1379     save_context();
1380     warn "Writing output\n";
1381     output_boilerplate();
1382     print "\n";
1383     output_all("perl_init");
1384     print "\n";
1385     output_main();
1386 }
1387
1388 sub init_sections {
1389     my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1390                     binop => \$binopsect, condop => \$condopsect,
1391                     cop => \$copsect, padop => \$padopsect,
1392                     listop => \$listopsect, logop => \$logopsect,
1393                     loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1394                     pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1395                     sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1396                     xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1397                     xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1398                     xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1399                     xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1400                     xpvio => \$xpviosect);
1401     my ($name, $sectref);
1402     while (($name, $sectref) = splice(@sections, 0, 2)) {
1403         $$sectref = new B::C::Section $name, \%symtable, 0;
1404     }
1405 }
1406
1407 sub mark_unused
1408 {
1409  my ($arg,$val) = @_;
1410  $unused_sub_packages{$arg} = $val;
1411 }
1412
1413 sub compile {
1414     my @options = @_;
1415     my ($option, $opt, $arg);
1416   OPTION:
1417     while ($option = shift @options) {
1418         if ($option =~ /^-(.)(.*)/) {
1419             $opt = $1;
1420             $arg = $2;
1421         } else {
1422             unshift @options, $option;
1423             last OPTION;
1424         }
1425         if ($opt eq "-" && $arg eq "-") {
1426             shift @options;
1427             last OPTION;
1428         }
1429         if ($opt eq "w") {
1430             $warn_undefined_syms = 1;
1431         } elsif ($opt eq "D") {
1432             $arg ||= shift @options;
1433             foreach $arg (split(//, $arg)) {
1434                 if ($arg eq "o") {
1435                     B->debug(1);
1436                 } elsif ($arg eq "c") {
1437                     $debug_cops = 1;
1438                 } elsif ($arg eq "A") {
1439                     $debug_av = 1;
1440                 } elsif ($arg eq "C") {
1441                     $debug_cv = 1;
1442                 } elsif ($arg eq "M") {
1443                     $debug_mg = 1;
1444                 } else {
1445                     warn "ignoring unknown debug option: $arg\n";
1446                 }
1447             }
1448         } elsif ($opt eq "o") {
1449             $arg ||= shift @options;
1450             open(STDOUT, ">$arg") or return "$arg: $!\n";
1451         } elsif ($opt eq "v") {
1452             $verbose = 1;
1453         } elsif ($opt eq "u") {
1454             $arg ||= shift @options;
1455             mark_unused($arg,undef);
1456         } elsif ($opt eq "f") {
1457             $arg ||= shift @options;
1458             if ($arg eq "cog") {
1459                 $pv_copy_on_grow = 1;
1460             } elsif ($arg eq "no-cog") {
1461                 $pv_copy_on_grow = 0;
1462             }
1463         } elsif ($opt eq "O") {
1464             $arg = 1 if $arg eq "";
1465             $pv_copy_on_grow = 0;
1466             if ($arg >= 1) {
1467                 # Optimisations for -O1
1468                 $pv_copy_on_grow = 1;
1469             }
1470         }
1471     }
1472     init_sections();
1473     if (@options) {
1474         return sub {
1475             my $objname;
1476             foreach $objname (@options) {
1477                 eval "save_object(\\$objname)";
1478             }
1479             output_all();
1480         }
1481     } else {
1482         return sub { save_main() };
1483     }
1484 }
1485
1486 1;
1487
1488 __END__
1489
1490 =head1 NAME
1491
1492 B::C - Perl compiler's C backend
1493
1494 =head1 SYNOPSIS
1495
1496         perl -MO=C[,OPTIONS] foo.pl
1497
1498 =head1 DESCRIPTION
1499
1500 This compiler backend takes Perl source and generates C source code
1501 corresponding to the internal structures that perl uses to run
1502 your program. When the generated C source is compiled and run, it
1503 cuts out the time which perl would have taken to load and parse
1504 your program into its internal semi-compiled form. That means that
1505 compiling with this backend will not help improve the runtime
1506 execution speed of your program but may improve the start-up time.
1507 Depending on the environment in which your program runs this may be
1508 either a help or a hindrance.
1509
1510 =head1 OPTIONS
1511
1512 If there are any non-option arguments, they are taken to be
1513 names of objects to be saved (probably doesn't work properly yet).
1514 Without extra arguments, it saves the main program.
1515
1516 =over 4
1517
1518 =item B<-ofilename>
1519
1520 Output to filename instead of STDOUT
1521
1522 =item B<-v>
1523
1524 Verbose compilation (currently gives a few compilation statistics).
1525
1526 =item B<-->
1527
1528 Force end of options
1529
1530 =item B<-uPackname>
1531
1532 Force apparently unused subs from package Packname to be compiled.
1533 This allows programs to use eval "foo()" even when sub foo is never
1534 seen to be used at compile time. The down side is that any subs which
1535 really are never used also have code generated. This option is
1536 necessary, for example, if you have a signal handler foo which you
1537 initialise with C<$SIG{BAR} = "foo">.  A better fix, though, is just
1538 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1539 options. The compiler tries to figure out which packages may possibly
1540 have subs in which need compiling but the current version doesn't do
1541 it very well. In particular, it is confused by nested packages (i.e.
1542 of the form C<A::B>) where package C<A> does not contain any subs.
1543
1544 =item B<-D>
1545
1546 Debug options (concatenated or separate flags like C<perl -D>).
1547
1548 =item B<-Do>
1549
1550 OPs, prints each OP as it's processed
1551
1552 =item B<-Dc>
1553
1554 COPs, prints COPs as processed (incl. file & line num)
1555
1556 =item B<-DA>
1557
1558 prints AV information on saving
1559
1560 =item B<-DC>
1561
1562 prints CV information on saving
1563
1564 =item B<-DM>
1565
1566 prints MAGIC information on saving
1567
1568 =item B<-f>
1569
1570 Force optimisations on or off one at a time.
1571
1572 =item B<-fcog>
1573
1574 Copy-on-grow: PVs declared and initialised statically.
1575
1576 =item B<-fno-cog>
1577
1578 No copy-on-grow.
1579
1580 =item B<-On>
1581
1582 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.  Currently,
1583 B<-O1> and higher set B<-fcog>.
1584
1585 =head1 EXAMPLES
1586
1587     perl -MO=C,-ofoo.c foo.pl
1588     perl cc_harness -o foo foo.c
1589
1590 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1591 library directory. The utility called C<perlcc> may also be used to
1592 help make use of this compiler.
1593
1594     perl -MO=C,-v,-DcA bar.pl > /dev/null
1595
1596 =head1 BUGS
1597
1598 Plenty. Current status: experimental.
1599
1600 =head1 AUTHOR
1601
1602 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
1603
1604 =cut