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 $gvsym = $op->filegv->save;
 297     my $stashsym = $op->stash->save;
 298     warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV)
 299         if $debug_cops;
 300     $copsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u",
 301                           ${$op->next}, ${$op->sibling}, $op->ppaddr,
 302                           $op->targ, $op->type, $op_seq, $op->flags,
 303                           $op->private, cstring($op->label), $op->cop_seq,
 304                           $op->arybase, $op->line));
 305     my $copix = $copsect->index;
 306     $init->add(sprintf("cop_list[%d].cop_filegv = %s;", $copix, $gvsym),
 307                sprintf("cop_list[%d].cop_stash = %s;", $copix, $stashsym));
 308     savesym($op, "(OP*)&cop_list[$copix]");
 309 }
 310
 311 sub B::PMOP::save {
 312     my ($op, $level) = @_;
 313     my $sym = objsym($op);
 314     return $sym if defined $sym;
 315     my $replroot = $op->pmreplroot;
 316     my $replstart = $op->pmreplstart;
 317     my $replrootfield = sprintf("s\\_%x", $$replroot);
 318     my $replstartfield = sprintf("s\\_%x", $$replstart);
 319     my $gvsym;
 320     my $ppaddr = $op->ppaddr;
 321     if ($$replroot) {
 322         # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
 323         # argument to a split) stores a GV in op_pmreplroot instead
 324         # of a substitution syntax tree. We don't want to walk that...
 325         if ($op->name eq "pushre") {
 326             $gvsym = $replroot->save;
 327 #           warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
 328             $replrootfield = 0;
 329         } else {
 330             $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
 331         }
 332     }
 333     # pmnext handling is broken in perl itself, I think. Bad op_pmnext
 334     # fields aren't noticed in perl's runtime (unless you try reset) but we
 335     # segfault when trying to dereference it to find op->op_pmnext->op_type
 336     $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",
 337                            ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ,
 338                            $op->type, $op_seq, $op->flags, $op->private,
 339                            ${$op->first}, ${$op->last}, $op->children,
 340                            $replrootfield, $replstartfield,
 341                            $op->pmflags, $op->pmpermflags,));
 342     my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
 343     my $re = $op->precomp;
 344     if (defined($re)) {
 345         my $resym = sprintf("re%d", $re_index++);
 346         $decl->add(sprintf("static char *$resym = %s;", cstring($re)));
 347         $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
 348                            length($re)));
 349     }
 350     if ($gvsym) {
 351         $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
 352     }
 353     savesym($op, sprintf("(OP*)&pmop_list[%d]", $pmopsect->index));
 354 }
 355
 356 sub B::SPECIAL::save {
 357     my ($sv) = @_;
 358     # special case: $$sv is not the address but an index into specialsv_list
 359 #   warn "SPECIAL::save specialsv $$sv\n"; # debug
 360     my $sym = $specialsv_name[$$sv];
 361     if (!defined($sym)) {
 362         confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
 363     }
 364     return $sym;
 365 }
 366
 367 sub B::OBJECT::save {}
 368
 369 sub B::NULL::save {
 370     my ($sv) = @_;
 371     my $sym = objsym($sv);
 372     return $sym if defined $sym;
 373 #   warn "Saving SVt_NULL SV\n"; # debug
 374     # debug
 375     #if ($$sv == 0) {
 376     #   warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
 377     #}
 378     $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS));
 379     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 380 }
 381
 382 sub B::IV::save {
 383     my ($sv) = @_;
 384     my $sym = objsym($sv);
 385     return $sym if defined $sym;
 386     $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
 387     $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
 388                          $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
 389     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 390 }
 391
 392 sub B::NV::save {
 393     my ($sv) = @_;
 394     my $sym = objsym($sv);
 395     return $sym if defined $sym;
 396     my $val= $sv->NVX;
 397     $val .= '.00' if $val =~ /^-?\d+$/;
 398     $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
 399     $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
 400                          $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
 401     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 402 }
 403
 404 sub B::PVLV::save {
 405     my ($sv) = @_;
 406     my $sym = objsym($sv);
 407     return $sym if defined $sym;
 408     my $pv = $sv->PV;
 409     my $len = length($pv);
 410     my ($pvsym, $pvmax) = savepv($pv);
 411     my ($lvtarg, $lvtarg_sym);
 412     $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
 413                             $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
 414                             $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
 415     $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
 416                          $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS));
 417     if (!$pv_copy_on_grow) {
 418         $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);",
 419                            $xpvlvsect->index, cstring($pv), $len));
 420     }
 421     $sv->save_magic;
 422     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 423 }
 424
 425 sub B::PVIV::save {
 426     my ($sv) = @_;
 427     my $sym = objsym($sv);
 428     return $sym if defined $sym;
 429     my $pv = $sv->PV;
 430     my $len = length($pv);
 431     my ($pvsym, $pvmax) = savepv($pv);
 432     $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
 433     $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
 434                          $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
 435     if (!$pv_copy_on_grow) {
 436         $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);",
 437                            $xpvivsect->index, cstring($pv), $len));
 438     }
 439     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 440 }
 441
 442 sub B::PVNV::save {
 443     my ($sv) = @_;
 444     my $sym = objsym($sv);
 445     return $sym if defined $sym;
 446     my $pv = $sv->PV;
 447     $pv = '' unless defined $pv;
 448     my $len = length($pv);
 449     my ($pvsym, $pvmax) = savepv($pv);
 450     my $val= $sv->NVX;
 451     $val .= '.00' if $val =~ /^-?\d+$/;
 452     $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
 453                             $pvsym, $len, $pvmax, $sv->IVX, $val));
 454     $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
 455                          $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
 456     if (!$pv_copy_on_grow) {
 457         $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);",
 458                            $xpvnvsect->index, cstring($pv), $len));
 459     }
 460     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 461 }
 462
 463 sub B::BM::save {
 464     my ($sv) = @_;
 465     my $sym = objsym($sv);
 466     return $sym if defined $sym;
 467     my $pv = $sv->PV . "\0" . $sv->TABLE;
 468     my $len = length($pv);
 469     $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
 470                             $len, $len + 258, $sv->IVX, $sv->NVX,
 471                             $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
 472     $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
 473                          $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS));
 474     $sv->save_magic;
 475     $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);",
 476                        $xpvbmsect->index, cstring($pv), $len),
 477                sprintf("xpvbm_list[%d].xpv_cur = %u;",
 478                        $xpvbmsect->index, $len - 257));
 479     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 480 }
 481
 482 sub B::PV::save {
 483     my ($sv) = @_;
 484     my $sym = objsym($sv);
 485     return $sym if defined $sym;
 486     my $pv = $sv->PV;
 487     my $len = length($pv);
 488     my ($pvsym, $pvmax) = savepv($pv);
 489     $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
 490     $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
 491                          $xpvsect->index, $sv->REFCNT , $sv->FLAGS));
 492     if (!$pv_copy_on_grow) {
 493         $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);",
 494                            $xpvsect->index, cstring($pv), $len));
 495     }
 496     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 497 }
 498
 499 sub B::PVMG::save {
 500     my ($sv) = @_;
 501     my $sym = objsym($sv);
 502     return $sym if defined $sym;
 503     my $pv = $sv->PV;
 504     my $len = length($pv);
 505     my ($pvsym, $pvmax) = savepv($pv);
 506     $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
 507                             $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
 508     $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
 509                          $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS));
 510     if (!$pv_copy_on_grow) {
 511         $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);",
 512                            $xpvmgsect->index, cstring($pv), $len));
 513     }
 514     $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 515     $sv->save_magic;
 516     return $sym;
 517 }
 518
 519 sub B::PVMG::save_magic {
 520     my ($sv) = @_;
 521     #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
 522     my $stash = $sv->SvSTASH;
 523     $stash->save;
 524     if ($$stash) {
 525         warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
 526             if $debug_mg;
 527         # XXX Hope stash is already going to be saved.
 528         $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
 529     }
 530     my @mgchain = $sv->MAGIC;
 531     my ($mg, $type, $obj, $ptr,$len,$ptrsv);
 532     foreach $mg (@mgchain) {
 533         $type = $mg->TYPE;
 534         $obj = $mg->OBJ;
 535         $ptr = $mg->PTR;
 536         $len=$mg->LENGTH;
 537         if ($debug_mg) {
 538             warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
 539                          class($sv), $$sv, class($obj), $$obj,
 540                          cchar($type), cstring($ptr));
 541         }
 542         $obj->save;
 543         if ($len == HEf_SVKEY){
 544                 #The pointer is an SV*
 545                 $ptrsv=svref_2object($ptr)->save;
 546                 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
 547                            $$sv, $$obj, cchar($type),$ptrsv,$len));
 548         }else{
 549                 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
 550                            $$sv, $$obj, cchar($type),cstring($ptr),$len));
 551         }
 552     }
 553 }
 554
 555 sub B::RV::save {
 556     my ($sv) = @_;
 557     my $sym = objsym($sv);
 558     return $sym if defined $sym;
 559     my $rv = $sv->RV->save;
 560     $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/;
 561     $xrvsect->add($rv);
 562     $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
 563                          $xrvsect->index, $sv->REFCNT , $sv->FLAGS));
 564     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 565 }
 566
 567 sub try_autoload {
 568     my ($cvstashname, $cvname) = @_;
 569     warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
 570     # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
 571     # use should be handled by the class itself.
 572     no strict 'refs';
 573     my $isa = \@{"$cvstashname\::ISA"};
 574     if (grep($_ eq "AutoLoader", @$isa)) {
 575         warn "Forcing immediate load of sub derived from AutoLoader\n";
 576         # Tweaked version of AutoLoader::AUTOLOAD
 577         my $dir = $cvstashname;
 578         $dir =~ s(::)(/)g;
 579         eval { require "auto/$dir/$cvname.al" };
 580         if ($@) {
 581             warn qq(failed require "auto/$dir/$cvname.al": $@\n);
 582             return 0;
 583         } else {
 584             return 1;
 585         }
 586     }
 587 }
 588 sub Dummy_initxs{};
 589 sub B::CV::save {
 590     my ($cv) = @_;
 591     my $sym = objsym($cv);
 592     if (defined($sym)) {
 593 #       warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
 594         return $sym;
 595     }
 596     # Reserve a place in svsect and xpvcvsect and record indices
 597     my $gv = $cv->GV;
 598     my ($cvname, $cvstashname);
 599     if ($$gv){
 600         $cvname = $gv->NAME;
 601         $cvstashname = $gv->STASH->NAME;
 602     }
 603     my $root = $cv->ROOT;
 604     my $cvxsub = $cv->XSUB;
 605     #INIT is removed from the symbol table, so this call must come
 606     # from PL_initav->save. Re-bootstrapping  will push INIT back in
 607     # so nullop should be sent.
 608     if ($cvxsub && ($cvname ne "INIT")) {
 609         my $egv = $gv->EGV;
 610         my $stashname = $egv->STASH->NAME;
 611          if ($cvname eq "bootstrap")
 612           {
 613            my $file = $gv->FILE;
 614            $decl->add("/* bootstrap $file */");
 615            warn "Bootstrap $stashname $file\n";
 616            $xsub{$stashname}='Dynamic';
 617            # $xsub{$stashname}='Static' unless  $xsub{$stashname};
 618            return qq/NULL/;
 619           }
 620         warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv;
 621         return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/;
 622     }
 623     if ($cvxsub && $cvname eq "INIT") {
 624          no strict 'refs';
 625          return svref_2object(\&Dummy_initxs)->save;
 626     }
 627     my $sv_ix = $svsect->index + 1;
 628     $svsect->add("svix$sv_ix");
 629     my $xpvcv_ix = $xpvcvsect->index + 1;
 630     $xpvcvsect->add("xpvcvix$xpvcv_ix");
 631     # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
 632     $sym = savesym($cv, "&sv_list[$sv_ix]");
 633     warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv;
 634     if (!$$root && !$cvxsub) {
 635         if (try_autoload($cvstashname, $cvname)) {
 636             # Recalculate root and xsub
 637             $root = $cv->ROOT;
 638             $cvxsub = $cv->XSUB;
 639             if ($$root || $cvxsub) {
 640                 warn "Successful forced autoload\n";
 641             }
 642         }
 643     }
 644     my $startfield = 0;
 645     my $padlist = $cv->PADLIST;
 646     my $pv = $cv->PV;
 647     my $xsub = 0;
 648     my $xsubany = "Nullany";
 649     if ($$root) {
 650         warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
 651                      $$cv, $$root) if $debug_cv;
 652         my $ppname = "";
 653         if ($$gv) {
 654             my $stashname = $gv->STASH->NAME;
 655             my $gvname = $gv->NAME;
 656             if ($gvname ne "__ANON__") {
 657                 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
 658                 $ppname .= ($stashname eq "main") ?
 659                             $gvname : "$stashname\::$gvname";
 660                 $ppname =~ s/::/__/g;
 661                 if ($gvname eq "INIT"){
 662                        $ppname .= "_$initsub_index";
 663                        $initsub_index++;
 664                     }
 665             }
 666         }
 667         if (!$ppname) {
 668             $ppname = "pp_anonsub_$anonsub_index";
 669             $anonsub_index++;
 670         }
 671         $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
 672         warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
 673                      $$cv, $ppname, $$root) if $debug_cv;
 674         if ($$padlist) {
 675             warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
 676                          $$padlist, $$cv) if $debug_cv;
 677             $padlist->save;
 678             warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
 679                          $$padlist, $$cv) if $debug_cv;
 680         }
 681     }
 682     else {
 683         warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
 684                      $cvstashname, $cvname); # debug
 685     }
 686     $pv = '' unless defined $pv; # Avoid use of undef warnings
 687     $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",
 688                           $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
 689                           $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
 690                         $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
 691
 692     if (${$cv->OUTSIDE} == ${main_cv()}){
 693         $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
 694         $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
 695     }
 696
 697     if ($$gv) {
 698         $gv->save;
 699         $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
 700         warn sprintf("done saving GV 0x%x for CV 0x%x\n",
 701                      $$gv, $$cv) if $debug_cv;
 702     }
 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 #if defined(PERL_BINCOMPAT_5005)
1015     GV *        xcv_filegv;     /* XXX unused (and deprecated) */
1016 #endif
1017     long        xcv_depth;      /* >= 2 indicates recursive call */
1018     AV *        xcv_padlist;
1019     CV *        xcv_outside;
1020 #ifdef USE_THREADS
1021     perl_mutex *xcv_mutexp;
1022     struct perl_thread *xcv_owner;      /* current owner thread */
1023 #endif /* USE_THREADS */
1024     U8          xcv_flags;
1025 } XPVCV_or_similar;
1026 #define ANYINIT(i) i
1027 #else
1028 #define XPVCV_or_similar XPVCV
1029 #define ANYINIT(i) {i}
1030 #endif /* BROKEN_UNION_INIT */
1031 #define Nullany ANYINIT(0)
1032
1033 #define UNUSED 0
1034 #define sym_0 0
1035
1036 EOT
1037     print "static GV *gv_list[$gv_index];\n" if $gv_index;
1038     print "\n";
1039 }
1040
1041
1042 sub output_boilerplate {
1043     print <<'EOT';
1044 #include "EXTERN.h"
1045 #include "perl.h"
1046
1047 /* Workaround for mapstart: the only op which needs a different ppaddr */
1048 #undef Perl_pp_mapstart
1049 #define Perl_pp_mapstart Perl_pp_grepstart
1050 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1051 EXTERN_C void boot_DynaLoader (CV* cv);
1052
1053 static void xs_init (void);
1054 static void dl_init (void);
1055 static PerlInterpreter *my_perl;
1056 EOT
1057 }
1058
1059 sub output_main {
1060     print <<'EOT';
1061 int
1062 #ifndef CAN_PROTOTYPE
1063 main(argc, argv, env)
1064 int argc;
1065 char **argv;
1066 char **env;
1067 #else  /* def(CAN_PROTOTYPE) */
1068 main(int argc, char **argv, char **env)
1069 #endif  /* def(CAN_PROTOTYPE) */
1070 {
1071     int exitstatus;
1072     int i;
1073     char **fakeargv;
1074
1075     PERL_SYS_INIT(&argc,&argv);
1076
1077     perl_init_i18nl10n(1);
1078
1079     if (!PL_do_undump) {
1080         my_perl = perl_alloc();
1081         if (!my_perl)
1082             exit(1);
1083         perl_construct( my_perl );
1084     }
1085
1086 #ifdef CSH
1087     if (!PL_cshlen)
1088       PL_cshlen = strlen(PL_cshname);
1089 #endif
1090
1091 #ifdef ALLOW_PERL_OPTIONS
1092 #define EXTRA_OPTIONS 2
1093 #else
1094 #define EXTRA_OPTIONS 3
1095 #endif /* ALLOW_PERL_OPTIONS */
1096     New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1097     fakeargv[0] = argv[0];
1098     fakeargv[1] = "-e";
1099     fakeargv[2] = "";
1100 #ifndef ALLOW_PERL_OPTIONS
1101     fakeargv[3] = "--";
1102 #endif /* ALLOW_PERL_OPTIONS */
1103     for (i = 1; i < argc; i++)
1104         fakeargv[i + EXTRA_OPTIONS] = argv[i];
1105     fakeargv[argc + EXTRA_OPTIONS] = 0;
1106
1107     exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1108                             fakeargv, NULL);
1109     if (exitstatus)
1110         exit( exitstatus );
1111
1112     sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1113     PL_main_cv = PL_compcv;
1114     PL_compcv = 0;
1115
1116     exitstatus = perl_init();
1117     if (exitstatus)
1118         exit( exitstatus );
1119     dl_init();
1120
1121     exitstatus = perl_run( my_perl );
1122
1123     perl_destruct( my_perl );
1124     perl_free( my_perl );
1125
1126     exit( exitstatus );
1127 }
1128
1129 /* yanked from perl.c */
1130 static void
1131 xs_init()
1132 {
1133     char *file = __FILE__;
1134     dTARG;
1135     djSP;
1136 EOT
1137     print "\n#ifdef USE_DYNAMIC_LOADING";
1138     print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1139     print "\n#endif\n" ;
1140     # delete $xsub{'DynaLoader'};
1141     delete $xsub{'UNIVERSAL'};
1142     print("/* bootstrapping code*/\n\tSAVETMPS;\n");
1143     print("\ttarg=sv_newmortal();\n");
1144     print "#ifdef DYNALOADER_BOOTSTRAP\n";
1145     print "\tPUSHMARK(sp);\n";
1146     print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
1147     print qq/\tPUTBACK;\n/;
1148     print "\tboot_DynaLoader(NULL);\n";
1149     print qq/\tSPAGAIN;\n/;
1150     print "#endif\n";
1151     foreach my $stashname (keys %xsub){
1152         if ($xsub{$stashname} ne 'Dynamic') {
1153            my $stashxsub=$stashname;
1154            $stashxsub  =~ s/::/__/g;
1155            print "\tPUSHMARK(sp);\n";
1156            print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
1157            print qq/\tPUTBACK;\n/;
1158            print "\tboot_$stashxsub(NULL);\n";
1159            print qq/\tSPAGAIN;\n/;
1160         }
1161     }
1162     print("\tFREETMPS;\n/* end bootstrapping code */\n");
1163     print "}\n";
1164
1165 print <<'EOT';
1166 static void
1167 dl_init()
1168 {
1169     char *file = __FILE__;
1170     dTARG;
1171     djSP;
1172 EOT
1173     print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
1174     print("\ttarg=sv_newmortal();\n");
1175     foreach my $stashname (@DynaLoader::dl_modules) {
1176         warn "Loaded $stashname\n";
1177         if (exists($xsub{$stashname}) && $xsub{$stashname} eq 'Dynamic') {
1178            my $stashxsub=$stashname;
1179            $stashxsub  =~ s/::/__/g;
1180            print "\tPUSHMARK(sp);\n";
1181            print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
1182            print qq/\tPUTBACK;\n/;
1183            print "#ifdef DYNALOADER_BOOTSTRAP\n";
1184            warn "bootstrapping $stashname added to xs_init\n";
1185            print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
1186            print "\n#else\n";
1187            print "\tboot_$stashxsub(NULL);\n";
1188            print "#endif\n";
1189            print qq/\tSPAGAIN;\n/;
1190         }
1191     }
1192     print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
1193     print "}\n";
1194 }
1195 sub dump_symtable {
1196     # For debugging
1197     my ($sym, $val);
1198     warn "----Symbol table:\n";
1199     while (($sym, $val) = each %symtable) {
1200         warn "$sym => $val\n";
1201     }
1202     warn "---End of symbol table\n";
1203 }
1204
1205 sub save_object {
1206     my $sv;
1207     foreach $sv (@_) {
1208         svref_2object($sv)->save;
1209     }
1210 }
1211
1212 sub Dummy_BootStrap { }
1213
1214 sub B::GV::savecv
1215 {
1216  my $gv = shift;
1217  my $package=$gv->STASH->NAME;
1218  my $name = $gv->NAME;
1219  my $cv = $gv->CV;
1220  my $sv = $gv->SV;
1221  my $av = $gv->AV;
1222  my $hv = $gv->HV;
1223
1224  # We may be looking at this package just because it is a branch in the
1225  # symbol table which is on the path to a package which we need to save
1226  # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1227  #
1228  return unless ($unused_sub_packages{$package});
1229  return unless ($$cv || $$av || $$sv || $$hv);
1230  $gv->save;
1231 }
1232
1233 sub mark_package
1234 {
1235  my $package = shift;
1236  unless ($unused_sub_packages{$package})
1237   {
1238    no strict 'refs';
1239    $unused_sub_packages{$package} = 1;
1240    if (defined @{$package.'::ISA'})
1241     {
1242      foreach my $isa (@{$package.'::ISA'})
1243       {
1244        if ($isa eq 'DynaLoader')
1245         {
1246          unless (defined(&{$package.'::bootstrap'}))
1247           {
1248            warn "Forcing bootstrap of $package\n";
1249            eval { $package->bootstrap };
1250           }
1251         }
1252 #      else
1253         {
1254          unless ($unused_sub_packages{$isa})
1255           {
1256            warn "$isa saved (it is in $package\'s \@ISA)\n";
1257            mark_package($isa);
1258           }
1259         }
1260       }
1261     }
1262   }
1263  return 1;
1264 }
1265
1266 sub should_save
1267 {
1268  no strict qw(vars refs);
1269  my $package = shift;
1270  $package =~ s/::$//;
1271  return $unused_sub_packages{$package} = 0 if ($package =~ /::::/);  # skip ::::ISA::CACHE etc.
1272  # warn "Considering $package\n";#debug
1273  foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1274   {
1275    # If this package is a prefix to something we are saving, traverse it
1276    # but do not mark it for saving if it is not already
1277    # e.g. to get to Getopt::Long we need to traverse Getopt but need
1278    # not save Getopt
1279    return 1 if ($u =~ /^$package\:\:/);
1280   }
1281  if (exists $unused_sub_packages{$package})
1282   {
1283    # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1284    delete_unsaved_hashINC($package) unless  $unused_sub_packages{$package} ;
1285    return $unused_sub_packages{$package};
1286   }
1287  # Omit the packages which we use (and which cause grief
1288  # because of fancy "goto &$AUTOLOAD" stuff).
1289  # XXX Surely there must be a nicer way to do this.
1290  if ($package eq "FileHandle" || $package eq "Config" ||
1291      $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1292   {
1293    delete_unsaved_hashINC($package);
1294    return $unused_sub_packages{$package} = 0;
1295   }
1296  # Now see if current package looks like an OO class this is probably too strong.
1297  foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1298   {
1299    if ($package->can($m))
1300     {
1301      warn "$package has method $m: saving package\n";#debug
1302      return mark_package($package);
1303     }
1304   }
1305  delete_unsaved_hashINC($package);
1306  return $unused_sub_packages{$package} = 0;
1307 }
1308 sub delete_unsaved_hashINC{
1309         my $packname=shift;
1310         $packname =~ s/\:\:/\//g;
1311         $packname .= '.pm';
1312 #       warn "deleting $packname" if $INC{$packname} ;# debug
1313         delete $INC{$packname};
1314 }
1315 sub walkpackages
1316 {
1317  my ($symref, $recurse, $prefix) = @_;
1318  my $sym;
1319  my $ref;
1320  no strict 'vars';
1321  local(*glob);
1322  $prefix = '' unless defined $prefix;
1323  while (($sym, $ref) = each %$symref)
1324   {
1325    *glob = $ref;
1326    if ($sym =~ /::$/)
1327     {
1328      $sym = $prefix . $sym;
1329      if ($sym ne "main::" && &$recurse($sym))
1330       {
1331        walkpackages(\%glob, $recurse, $sym);
1332       }
1333     }
1334   }
1335 }
1336
1337
1338 sub save_unused_subs
1339 {
1340  no strict qw(refs);
1341  &descend_marked_unused;
1342  warn "Prescan\n";
1343  walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1344  warn "Saving methods\n";
1345  walksymtable(\%{"main::"}, "savecv", \&should_save);
1346 }
1347
1348 sub save_context
1349 {
1350  my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1351  my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1352  my $inc_hv     = svref_2object(\%INC)->save;
1353  my $inc_av     = svref_2object(\@INC)->save;
1354  my $amagic_generate= amagic_generation;
1355  $init->add(   "PL_curpad = AvARRAY($curpad_sym);",
1356                "GvHV(PL_incgv) = $inc_hv;",
1357                "GvAV(PL_incgv) = $inc_av;",
1358                "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1359                "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1360                 "PL_amagic_generation= $amagic_generate;" );
1361 }
1362
1363 sub descend_marked_unused {
1364     foreach my $pack (keys %unused_sub_packages)
1365     {
1366         mark_package($pack);
1367     }
1368 }
1369
1370 sub save_main {
1371     warn "Starting compile\n";
1372     warn "Walking tree\n";
1373     seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1374     walkoptree(main_root, "save");
1375     warn "done main optree, walking symtable for extras\n" if $debug_cv;
1376     save_unused_subs();
1377     my $init_av = init_av->save;
1378     $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1379                sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1380               "PL_initav = (AV *) $init_av;");
1381     save_context();
1382     warn "Writing output\n";
1383     output_boilerplate();
1384     print "\n";
1385     output_all("perl_init");
1386     print "\n";
1387     output_main();
1388 }
1389
1390 sub init_sections {
1391     my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1392                     binop => \$binopsect, condop => \$condopsect,
1393                     cop => \$copsect, padop => \$padopsect,
1394                     listop => \$listopsect, logop => \$logopsect,
1395                     loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1396                     pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1397                     sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1398                     xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1399                     xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1400                     xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1401                     xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1402                     xpvio => \$xpviosect);
1403     my ($name, $sectref);
1404     while (($name, $sectref) = splice(@sections, 0, 2)) {
1405         $$sectref = new B::C::Section $name, \%symtable, 0;
1406     }
1407 }
1408
1409 sub mark_unused
1410 {
1411  my ($arg,$val) = @_;
1412  $unused_sub_packages{$arg} = $val;
1413 }
1414
1415 sub compile {
1416     my @options = @_;
1417     my ($option, $opt, $arg);
1418   OPTION:
1419     while ($option = shift @options) {
1420         if ($option =~ /^-(.)(.*)/) {
1421             $opt = $1;
1422             $arg = $2;
1423         } else {
1424             unshift @options, $option;
1425             last OPTION;
1426         }
1427         if ($opt eq "-" && $arg eq "-") {
1428             shift @options;
1429             last OPTION;
1430         }
1431         if ($opt eq "w") {
1432             $warn_undefined_syms = 1;
1433         } elsif ($opt eq "D") {
1434             $arg ||= shift @options;
1435             foreach $arg (split(//, $arg)) {
1436                 if ($arg eq "o") {
1437                     B->debug(1);
1438                 } elsif ($arg eq "c") {
1439                     $debug_cops = 1;
1440                 } elsif ($arg eq "A") {
1441                     $debug_av = 1;
1442                 } elsif ($arg eq "C") {
1443                     $debug_cv = 1;
1444                 } elsif ($arg eq "M") {
1445                     $debug_mg = 1;
1446                 } else {
1447                     warn "ignoring unknown debug option: $arg\n";
1448                 }
1449             }
1450         } elsif ($opt eq "o") {
1451             $arg ||= shift @options;
1452             open(STDOUT, ">$arg") or return "$arg: $!\n";
1453         } elsif ($opt eq "v") {
1454             $verbose = 1;
1455         } elsif ($opt eq "u") {
1456             $arg ||= shift @options;
1457             mark_unused($arg,undef);
1458         } elsif ($opt eq "f") {
1459             $arg ||= shift @options;
1460             if ($arg eq "cog") {
1461                 $pv_copy_on_grow = 1;
1462             } elsif ($arg eq "no-cog") {
1463                 $pv_copy_on_grow = 0;
1464             }
1465         } elsif ($opt eq "O") {
1466             $arg = 1 if $arg eq "";
1467             $pv_copy_on_grow = 0;
1468             if ($arg >= 1) {
1469                 # Optimisations for -O1
1470                 $pv_copy_on_grow = 1;
1471             }
1472         }
1473     }
1474     init_sections();
1475     if (@options) {
1476         return sub {
1477             my $objname;
1478             foreach $objname (@options) {
1479                 eval "save_object(\\$objname)";
1480             }
1481             output_all();
1482         }
1483     } else {
1484         return sub { save_main() };
1485     }
1486 }
1487
1488 1;
1489
1490 __END__
1491
1492 =head1 NAME
1493
1494 B::C - Perl compiler's C backend
1495
1496 =head1 SYNOPSIS
1497
1498         perl -MO=C[,OPTIONS] foo.pl
1499
1500 =head1 DESCRIPTION
1501
1502 This compiler backend takes Perl source and generates C source code
1503 corresponding to the internal structures that perl uses to run
1504 your program. When the generated C source is compiled and run, it
1505 cuts out the time which perl would have taken to load and parse
1506 your program into its internal semi-compiled form. That means that
1507 compiling with this backend will not help improve the runtime
1508 execution speed of your program but may improve the start-up time.
1509 Depending on the environment in which your program runs this may be
1510 either a help or a hindrance.
1511
1512 =head1 OPTIONS
1513
1514 If there are any non-option arguments, they are taken to be
1515 names of objects to be saved (probably doesn't work properly yet).
1516 Without extra arguments, it saves the main program.
1517
1518 =over 4
1519
1520 =item B<-ofilename>
1521
1522 Output to filename instead of STDOUT
1523
1524 =item B<-v>
1525
1526 Verbose compilation (currently gives a few compilation statistics).
1527
1528 =item B<-->
1529
1530 Force end of options
1531
1532 =item B<-uPackname>
1533
1534 Force apparently unused subs from package Packname to be compiled.
1535 This allows programs to use eval "foo()" even when sub foo is never
1536 seen to be used at compile time. The down side is that any subs which
1537 really are never used also have code generated. This option is
1538 necessary, for example, if you have a signal handler foo which you
1539 initialise with C<$SIG{BAR} = "foo">.  A better fix, though, is just
1540 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1541 options. The compiler tries to figure out which packages may possibly
1542 have subs in which need compiling but the current version doesn't do
1543 it very well. In particular, it is confused by nested packages (i.e.
1544 of the form C<A::B>) where package C<A> does not contain any subs.
1545
1546 =item B<-D>
1547
1548 Debug options (concatenated or separate flags like C<perl -D>).
1549
1550 =item B<-Do>
1551
1552 OPs, prints each OP as it's processed
1553
1554 =item B<-Dc>
1555
1556 COPs, prints COPs as processed (incl. file & line num)
1557
1558 =item B<-DA>
1559
1560 prints AV information on saving
1561
1562 =item B<-DC>
1563
1564 prints CV information on saving
1565
1566 =item B<-DM>
1567
1568 prints MAGIC information on saving
1569
1570 =item B<-f>
1571
1572 Force optimisations on or off one at a time.
1573
1574 =item B<-fcog>
1575
1576 Copy-on-grow: PVs declared and initialised statically.
1577
1578 =item B<-fno-cog>
1579
1580 No copy-on-grow.
1581
1582 =item B<-On>
1583
1584 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.  Currently,
1585 B<-O1> and higher set B<-fcog>.
1586
1587 =head1 EXAMPLES
1588
1589     perl -MO=C,-ofoo.c foo.pl
1590     perl cc_harness -o foo foo.c
1591
1592 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1593 library directory. The utility called C<perlcc> may also be used to
1594 help make use of this compiler.
1595
1596     perl -MO=C,-v,-DcA bar.pl > /dev/null
1597
1598 =head1 BUGS
1599
1600 Plenty. Current status: experimental.
1601
1602 =head1 AUTHOR
1603
1604 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
1605
1606 =cut