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     $gvopsect, $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::GVOP::save {
 280     my ($op, $level) = @_;
 281     my $sym = objsym($op);
 282     return $sym if defined $sym;
 283     my $gvsym = $op->gv->save;
 284     $gvopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, Nullgv",
 285                            ${$op->next}, ${$op->sibling}, $op->ppaddr,
 286                            $op->targ, $op->type, $op_seq, $op->flags,
 287                            $op->private));
 288     $init->add(sprintf("gvop_list[%d].op_gv = %s;", $gvopsect->index, $gvsym));
 289     savesym($op, sprintf("(OP*)&gvop_list[%d]", $gvopsect->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 $cvstashname = $gv->STASH->NAME;
 599     my $cvname = $gv->NAME;
 600     my $root = $cv->ROOT;
 601     my $cvxsub = $cv->XSUB;
 602     #INIT is removed from the symbol table, so this call must come
 603     # from PL_initav->save. Re-bootstrapping  will push INIT back in
 604     # so nullop should be sent.
 605     if ($cvxsub && ($cvname ne "INIT")) {
 606         my $egv = $gv->EGV;
 607         my $stashname = $egv->STASH->NAME;
 608          if ($cvname eq "bootstrap")
 609           {
 610            my $file = $cv->FILEGV->SV->PV;
 611            $decl->add("/* bootstrap $file */");
 612            warn "Bootstrap $stashname $file\n";
 613            $xsub{$stashname}='Dynamic';
 614            # $xsub{$stashname}='Static' unless  $xsub{$stashname};
 615            return qq/NULL/;
 616           }
 617         warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv;
 618         return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/;
 619     }
 620     if ($cvxsub && $cvname eq "INIT") {
 621          no strict 'refs';
 622          return svref_2object(\&Dummy_initxs)->save;
 623     }
 624     my $sv_ix = $svsect->index + 1;
 625     $svsect->add("svix$sv_ix");
 626     my $xpvcv_ix = $xpvcvsect->index + 1;
 627     $xpvcvsect->add("xpvcvix$xpvcv_ix");
 628     # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
 629     $sym = savesym($cv, "&sv_list[$sv_ix]");
 630     warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv;
 631     if (!$$root && !$cvxsub) {
 632         if (try_autoload($cvstashname, $cvname)) {
 633             # Recalculate root and xsub
 634             $root = $cv->ROOT;
 635             $cvxsub = $cv->XSUB;
 636             if ($$root || $cvxsub) {
 637                 warn "Successful forced autoload\n";
 638             }
 639         }
 640     }
 641     my $startfield = 0;
 642     my $padlist = $cv->PADLIST;
 643     my $pv = $cv->PV;
 644     my $xsub = 0;
 645     my $xsubany = "Nullany";
 646     if ($$root) {
 647         warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
 648                      $$cv, $$root) if $debug_cv;
 649         my $ppname = "";
 650         if ($$gv) {
 651             my $stashname = $gv->STASH->NAME;
 652             my $gvname = $gv->NAME;
 653             if ($gvname ne "__ANON__") {
 654                 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
 655                 $ppname .= ($stashname eq "main") ?
 656                             $gvname : "$stashname\::$gvname";
 657                 $ppname =~ s/::/__/g;
 658                 if ($gvname eq "INIT"){
 659                        $ppname .= "_$initsub_index";
 660                        $initsub_index++;
 661                     }
 662             }
 663         }
 664         if (!$ppname) {
 665             $ppname = "pp_anonsub_$anonsub_index";
 666             $anonsub_index++;
 667         }
 668         $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
 669         warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
 670                      $$cv, $ppname, $$root) if $debug_cv;
 671         if ($$padlist) {
 672             warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
 673                          $$padlist, $$cv) if $debug_cv;
 674             $padlist->save;
 675             warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
 676                          $$padlist, $$cv) if $debug_cv;
 677         }
 678     }
 679     else {
 680         warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
 681                      $cvstashname, $cvname); # debug
 682     }
 683     $pv = '' unless defined $pv; # Avoid use of undef warnings
 684     $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",
 685                           $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
 686                           $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
 687                         $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
 688
 689     if (${$cv->OUTSIDE} == ${main_cv()}){
 690         $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
 691         $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
 692     }
 693
 694     if ($$gv) {
 695         $gv->save;
 696         $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
 697         warn sprintf("done saving GV 0x%x for CV 0x%x\n",
 698                      $$gv, $$cv) if $debug_cv;
 699     }
 700     my $filegv = $cv->FILEGV;
 701     if ($$filegv) {
 702         $filegv->save;
 703         $init->add(sprintf("CvFILEGV(s\\_%x) = s\\_%x;", $$cv, $$filegv));
 704         warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n",
 705                      $$filegv, $$cv) if $debug_cv;
 706     }
 707     my $stash = $cv->STASH;
 708     if ($$stash) {
 709         $stash->save;
 710         $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
 711         warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
 712                      $$stash, $$cv) if $debug_cv;
 713     }
 714     $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
 715                           $sv_ix, $xpvcv_ix, $cv->REFCNT +1 , $cv->FLAGS));
 716     return $sym;
 717 }
 718
 719 sub B::GV::save {
 720     my ($gv) = @_;
 721     my $sym = objsym($gv);
 722     if (defined($sym)) {
 723         #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
 724         return $sym;
 725     } else {
 726         my $ix = $gv_index++;
 727         $sym = savesym($gv, "gv_list[$ix]");
 728         #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
 729     }
 730     my $gvname = $gv->NAME;
 731     my $name = cstring($gv->STASH->NAME . "::" . $gvname);
 732     #warn "GV name is $name\n"; # debug
 733     my $egv = $gv->EGV;
 734     my $egvsym;
 735     if ($$gv != $$egv) {
 736         #warn(sprintf("EGV name is %s, saving it now\n",
 737         #            $egv->STASH->NAME . "::" . $egv->NAME)); # debug
 738         $egvsym = $egv->save;
 739     }
 740     $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
 741                sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
 742                sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS),
 743                sprintf("GvLINE($sym) = %u;", $gv->LINE));
 744     # Shouldn't need to do save_magic since gv_fetchpv handles that
 745     #$gv->save_magic;
 746     my $refcnt = $gv->REFCNT + 1;
 747     $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
 748     my $gvrefcnt = $gv->GvREFCNT;
 749     if ($gvrefcnt > 1) {
 750         $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
 751     }
 752     if (defined($egvsym)) {
 753         # Shared glob *foo = *bar
 754         $init->add("gp_free($sym);",
 755                    "GvGP($sym) = GvGP($egvsym);");
 756     } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
 757         # Don't save subfields of special GVs (*_, *1, *# and so on)
 758 #       warn "GV::save saving subfields\n"; # debug
 759         my $gvsv = $gv->SV;
 760         if ($$gvsv) {
 761             $gvsv->save;
 762             $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
 763 #           warn "GV::save \$$name\n"; # debug
 764         }
 765         my $gvav = $gv->AV;
 766         if ($$gvav) {
 767             $gvav->save;
 768             $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
 769 #           warn "GV::save \@$name\n"; # debug
 770         }
 771         my $gvhv = $gv->HV;
 772         if ($$gvhv) {
 773             $gvhv->save;
 774             $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
 775 #           warn "GV::save \%$name\n"; # debug
 776         }
 777         my $gvcv = $gv->CV;
 778         if ($$gvcv) {
 779             my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
 780                  "::" . $gvcv->GV->EGV->NAME);
 781             if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias
 782                 # must save as a 'stub' so newXS() has a CV to populate
 783                 $init->add("{ CV *cv;");
 784                 $init->add("\tcv=perl_get_cv($origname,TRUE);");
 785                 $init->add("\tGvCV($sym)=cv;");
 786                 $init->add("\tSvREFCNT_inc((SV *)cv);");
 787                 $init->add("}");
 788             } else {
 789                $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
 790 #              warn "GV::save &$name\n"; # debug
 791             }
 792         }
 793         my $gvfilegv = $gv->FILEGV;
 794         if ($$gvfilegv) {
 795             $gvfilegv->save;
 796             $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv));
 797 #           warn "GV::save GvFILEGV(*$name)\n"; # debug
 798         }
 799         my $gvform = $gv->FORM;
 800         if ($$gvform) {
 801             $gvform->save;
 802             $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
 803 #           warn "GV::save GvFORM(*$name)\n"; # debug
 804         }
 805         my $gvio = $gv->IO;
 806         if ($$gvio) {
 807             $gvio->save;
 808             $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
 809 #           warn "GV::save GvIO(*$name)\n"; # debug
 810         }
 811     }
 812     return $sym;
 813 }
 814 sub B::AV::save {
 815     my ($av) = @_;
 816     my $sym = objsym($av);
 817     return $sym if defined $sym;
 818     my $avflags = $av->AvFLAGS;
 819     $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
 820                             $avflags));
 821     $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
 822                          $xpvavsect->index, $av->REFCNT  , $av->FLAGS));
 823     my $sv_list_index = $svsect->index;
 824     my $fill = $av->FILL;
 825     $av->save_magic;
 826     warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
 827         if $debug_av;
 828     # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
 829     #if ($fill > -1 && ($avflags & AVf_REAL)) {
 830     if ($fill > -1) {
 831         my @array = $av->ARRAY;
 832         if ($debug_av) {
 833             my $el;
 834             my $i = 0;
 835             foreach $el (@array) {
 836                 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
 837                              $$av, $i++, class($el), $$el);
 838             }
 839         }
 840         my @names = map($_->save, @array);
 841         # XXX Better ways to write loop?
 842         # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
 843         # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
 844         $init->add("{",
 845                    "\tSV **svp;",
 846                    "\tAV *av = (AV*)&sv_list[$sv_list_index];",
 847                    "\tav_extend(av, $fill);",
 848                    "\tsvp = AvARRAY(av);",
 849                map("\t*svp++ = (SV*)$_;", @names),
 850                    "\tAvFILLp(av) = $fill;",
 851                    "}");
 852     } else {
 853         my $max = $av->MAX;
 854         $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
 855             if $max > -1;
 856     }
 857     return savesym($av, "(AV*)&sv_list[$sv_list_index]");
 858 }
 859
 860 sub B::HV::save {
 861     my ($hv) = @_;
 862     my $sym = objsym($hv);
 863     return $sym if defined $sym;
 864     my $name = $hv->NAME;
 865     if ($name) {
 866         # It's a stash
 867
 868         # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
 869         # the only symptom is that sv_reset tries to reset the PMf_USED flag of
 870         # a trashed op but we look at the trashed op_type and segfault.
 871         #my $adpmroot = ${$hv->PMROOT};
 872         my $adpmroot = 0;
 873         $decl->add("static HV *hv$hv_index;");
 874         # XXX Beware of weird package names containing double-quotes, \n, ...?
 875         $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
 876         if ($adpmroot) {
 877             $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
 878                                $adpmroot));
 879         }
 880         $sym = savesym($hv, "hv$hv_index");
 881         $hv_index++;
 882         return $sym;
 883     }
 884     # It's just an ordinary HV
 885     $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
 886                             $hv->MAX, $hv->RITER));
 887     $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
 888                          $xpvhvsect->index, $hv->REFCNT  , $hv->FLAGS));
 889     my $sv_list_index = $svsect->index;
 890     my @contents = $hv->ARRAY;
 891     if (@contents) {
 892         my $i;
 893         for ($i = 1; $i < @contents; $i += 2) {
 894             $contents[$i] = $contents[$i]->save;
 895         }
 896         $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
 897         while (@contents) {
 898             my ($key, $value) = splice(@contents, 0, 2);
 899             $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
 900                                cstring($key),length($key),$value, hash($key)));
 901 #           $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
 902 #                              cstring($key),length($key),$value, 0));
 903         }
 904         $init->add("}");
 905     }
 906     $hv->save_magic();
 907     return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
 908 }
 909
 910 sub B::IO::save {
 911     my ($io) = @_;
 912     my $sym = objsym($io);
 913     return $sym if defined $sym;
 914     my $pv = $io->PV;
 915     $pv = '' unless defined $pv;
 916     my $len = length($pv);
 917     $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",
 918                             $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
 919                             $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
 920                             cstring($io->TOP_NAME), cstring($io->FMT_NAME),
 921                             cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
 922                             cchar($io->IoTYPE), $io->IoFLAGS));
 923     $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
 924                          $xpviosect->index, $io->REFCNT , $io->FLAGS));
 925     $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
 926     my ($field, $fsym);
 927     foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
 928         $fsym = $io->$field();
 929         if ($$fsym) {
 930             $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
 931             $fsym->save;
 932         }
 933     }
 934     $io->save_magic;
 935     return $sym;
 936 }
 937
 938 sub B::SV::save {
 939     my $sv = shift;
 940     # This is where we catch an honest-to-goodness Nullsv (which gets
 941     # blessed into B::SV explicitly) and any stray erroneous SVs.
 942     return 0 unless $$sv;
 943     confess sprintf("cannot save that type of SV: %s (0x%x)\n",
 944                     class($sv), $$sv);
 945 }
 946
 947 sub output_all {
 948     my $init_name = shift;
 949     my $section;
 950     my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
 951                     $listopsect, $pmopsect, $svopsect, $gvopsect, $pvopsect,
 952                     $loopsect, $copsect, $svsect, $xpvsect,
 953                     $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
 954                     $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
 955     $symsect->output(\*STDOUT, "#define %s\n");
 956     print "\n";
 957     output_declarations();
 958     foreach $section (@sections) {
 959         my $lines = $section->index + 1;
 960         if ($lines) {
 961             my $name = $section->name;
 962             my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
 963             print "Static $typename ${name}_list[$lines];\n";
 964         }
 965     }
 966     $decl->output(\*STDOUT, "%s\n");
 967     print "\n";
 968     foreach $section (@sections) {
 969         my $lines = $section->index + 1;
 970         if ($lines) {
 971             my $name = $section->name;
 972             my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
 973             printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
 974             $section->output(\*STDOUT, "\t{ %s },\n");
 975             print "};\n\n";
 976         }
 977     }
 978
 979     print <<"EOT";
 980 static int $init_name()
 981 {
 982         dTHR;
 983         dTARG;
 984         djSP;
 985 EOT
 986     $init->output(\*STDOUT, "\t%s\n");
 987     print "\treturn 0;\n}\n";
 988     if ($verbose) {
 989         warn compile_stats();
 990         warn "NULLOP count: $nullop_count\n";
 991     }
 992 }
 993
 994 sub output_declarations {
 995     print <<'EOT';
 996 #ifdef BROKEN_STATIC_REDECL
 997 #define Static extern
 998 #else
 999 #define Static static
1000 #endif /* BROKEN_STATIC_REDECL */
1001
1002 #ifdef BROKEN_UNION_INIT
1003 /*
1004  * Cribbed from cv.h with ANY (a union) replaced by void*.
1005  * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
1006  */
1007 typedef struct {
1008     char *      xpv_pv;         /* pointer to malloced string */
1009     STRLEN      xpv_cur;        /* length of xp_pv as a C string */
1010     STRLEN      xpv_len;        /* allocated size */
1011     IV          xof_off;        /* integer value */
1012     double      xnv_nv;         /* numeric value, if any */
1013     MAGIC*      xmg_magic;      /* magic for scalar array */
1014     HV*         xmg_stash;      /* class package */
1015
1016     HV *        xcv_stash;
1017     OP *        xcv_start;
1018     OP *        xcv_root;
1019     void      (*xcv_xsub) (CV*);
1020     void *      xcv_xsubany;
1021     GV *        xcv_gv;
1022     GV *        xcv_filegv;
1023     long        xcv_depth;              /* >= 2 indicates recursive call */
1024     AV *        xcv_padlist;
1025     CV *        xcv_outside;
1026 #ifdef USE_THREADS
1027     perl_mutex *xcv_mutexp;
1028     struct perl_thread *xcv_owner;      /* current owner thread */
1029 #endif /* USE_THREADS */
1030     U8          xcv_flags;
1031 } XPVCV_or_similar;
1032 #define ANYINIT(i) i
1033 #else
1034 #define XPVCV_or_similar XPVCV
1035 #define ANYINIT(i) {i}
1036 #endif /* BROKEN_UNION_INIT */
1037 #define Nullany ANYINIT(0)
1038
1039 #define UNUSED 0
1040 #define sym_0 0
1041
1042 EOT
1043     print "static GV *gv_list[$gv_index];\n" if $gv_index;
1044     print "\n";
1045 }
1046
1047
1048 sub output_boilerplate {
1049     print <<'EOT';
1050 #include "EXTERN.h"
1051 #include "perl.h"
1052
1053 /* Workaround for mapstart: the only op which needs a different ppaddr */
1054 #undef Perl_pp_mapstart
1055 #define Perl_pp_mapstart Perl_pp_grepstart
1056 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1057 EXTERN_C void boot_DynaLoader (CV* cv);
1058
1059 static void xs_init (void);
1060 static void dl_init (void);
1061 static PerlInterpreter *my_perl;
1062 EOT
1063 }
1064
1065 sub output_main {
1066     print <<'EOT';
1067 int
1068 #ifndef CAN_PROTOTYPE
1069 main(argc, argv, env)
1070 int argc;
1071 char **argv;
1072 char **env;
1073 #else  /* def(CAN_PROTOTYPE) */
1074 main(int argc, char **argv, char **env)
1075 #endif  /* def(CAN_PROTOTYPE) */
1076 {
1077     int exitstatus;
1078     int i;
1079     char **fakeargv;
1080
1081     PERL_SYS_INIT(&argc,&argv);
1082
1083     perl_init_i18nl10n(1);
1084
1085     if (!PL_do_undump) {
1086         my_perl = perl_alloc();
1087         if (!my_perl)
1088             exit(1);
1089         perl_construct( my_perl );
1090     }
1091
1092 #ifdef CSH
1093     if (!PL_cshlen)
1094       PL_cshlen = strlen(PL_cshname);
1095 #endif
1096
1097 #ifdef ALLOW_PERL_OPTIONS
1098 #define EXTRA_OPTIONS 2
1099 #else
1100 #define EXTRA_OPTIONS 3
1101 #endif /* ALLOW_PERL_OPTIONS */
1102     New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1103     fakeargv[0] = argv[0];
1104     fakeargv[1] = "-e";
1105     fakeargv[2] = "";
1106 #ifndef ALLOW_PERL_OPTIONS
1107     fakeargv[3] = "--";
1108 #endif /* ALLOW_PERL_OPTIONS */
1109     for (i = 1; i < argc; i++)
1110         fakeargv[i + EXTRA_OPTIONS] = argv[i];
1111     fakeargv[argc + EXTRA_OPTIONS] = 0;
1112
1113     exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1114                             fakeargv, NULL);
1115     if (exitstatus)
1116         exit( exitstatus );
1117
1118     sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1119     PL_main_cv = PL_compcv;
1120     PL_compcv = 0;
1121
1122     exitstatus = perl_init();
1123     if (exitstatus)
1124         exit( exitstatus );
1125     dl_init();
1126
1127     exitstatus = perl_run( my_perl );
1128
1129     perl_destruct( my_perl );
1130     perl_free( my_perl );
1131
1132     exit( exitstatus );
1133 }
1134
1135 /* yanked from perl.c */
1136 static void
1137 xs_init()
1138 {
1139     char *file = __FILE__;
1140     dTARG;
1141     djSP;
1142 EOT
1143     print "\n#ifdef USE_DYNAMIC_LOADING";
1144     print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1145     print "\n#endif\n" ;
1146     # delete $xsub{'DynaLoader'};
1147     delete $xsub{'UNIVERSAL'};
1148     print("/* bootstrapping code*/\n\tSAVETMPS;\n");
1149     print("\ttarg=sv_newmortal();\n");
1150     print "#ifdef DYNALOADER_BOOTSTRAP\n";
1151     print "\tPUSHMARK(sp);\n";
1152     print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
1153     print qq/\tPUTBACK;\n/;
1154     print "\tboot_DynaLoader(NULL);\n";
1155     print qq/\tSPAGAIN;\n/;
1156     print "#endif\n";
1157     foreach my $stashname (keys %xsub){
1158         if ($xsub{$stashname} ne 'Dynamic') {
1159            my $stashxsub=$stashname;
1160            $stashxsub  =~ s/::/__/g;
1161            print "\tPUSHMARK(sp);\n";
1162            print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
1163            print qq/\tPUTBACK;\n/;
1164            print "\tboot_$stashxsub(NULL);\n";
1165            print qq/\tSPAGAIN;\n/;
1166         }
1167     }
1168     print("\tFREETMPS;\n/* end bootstrapping code */\n");
1169     print "}\n";
1170
1171 print <<'EOT';
1172 static void
1173 dl_init()
1174 {
1175     char *file = __FILE__;
1176     dTARG;
1177     djSP;
1178 EOT
1179     print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
1180     print("\ttarg=sv_newmortal();\n");
1181     foreach my $stashname (@DynaLoader::dl_modules) {
1182         warn "Loaded $stashname\n";
1183         if (exists($xsub{$stashname}) && $xsub{$stashname} eq 'Dynamic') {
1184            my $stashxsub=$stashname;
1185            $stashxsub  =~ s/::/__/g;
1186            print "\tPUSHMARK(sp);\n";
1187            print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
1188            print qq/\tPUTBACK;\n/;
1189            print "#ifdef DYNALOADER_BOOTSTRAP\n";
1190            warn "bootstrapping $stashname added to xs_init\n";
1191            print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
1192            print "\n#else\n";
1193            print "\tboot_$stashxsub(NULL);\n";
1194            print "#endif\n";
1195            print qq/\tSPAGAIN;\n/;
1196         }
1197     }
1198     print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
1199     print "}\n";
1200 }
1201 sub dump_symtable {
1202     # For debugging
1203     my ($sym, $val);
1204     warn "----Symbol table:\n";
1205     while (($sym, $val) = each %symtable) {
1206         warn "$sym => $val\n";
1207     }
1208     warn "---End of symbol table\n";
1209 }
1210
1211 sub save_object {
1212     my $sv;
1213     foreach $sv (@_) {
1214         svref_2object($sv)->save;
1215     }
1216 }
1217
1218 sub Dummy_BootStrap { }
1219
1220 sub B::GV::savecv
1221 {
1222  my $gv = shift;
1223  my $package=$gv->STASH->NAME;
1224  my $name = $gv->NAME;
1225  my $cv = $gv->CV;
1226  my $sv = $gv->SV;
1227  my $av = $gv->AV;
1228  my $hv = $gv->HV;
1229
1230  # We may be looking at this package just because it is a branch in the
1231  # symbol table which is on the path to a package which we need to save
1232  # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1233  #
1234  return unless ($unused_sub_packages{$package});
1235  return unless ($$cv || $$av || $$sv || $$hv);
1236  $gv->save;
1237 }
1238
1239 sub mark_package
1240 {
1241  my $package = shift;
1242  unless ($unused_sub_packages{$package})
1243   {
1244    no strict 'refs';
1245    $unused_sub_packages{$package} = 1;
1246    if (@{$package.'::ISA'})
1247     {
1248      foreach my $isa (@{$package.'::ISA'})
1249       {
1250        if ($isa eq 'DynaLoader')
1251         {
1252          unless (defined(&{$package.'::bootstrap'}))
1253           {
1254            warn "Forcing bootstrap of $package\n";
1255            eval { $package->bootstrap };
1256           }
1257         }
1258 #      else
1259         {
1260          unless ($unused_sub_packages{$isa})
1261           {
1262            warn "$isa saved (it is in $package\'s \@ISA)\n";
1263            mark_package($isa);
1264           }
1265         }
1266       }
1267     }
1268   }
1269  return 1;
1270 }
1271
1272 sub should_save
1273 {
1274  no strict qw(vars refs);
1275  my $package = shift;
1276  $package =~ s/::$//;
1277  return $unused_sub_packages{$package} = 0 if ($package =~ /::::/);  # skip ::::ISA::CACHE etc.
1278  # warn "Considering $package\n";#debug
1279  foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1280   {
1281    # If this package is a prefix to something we are saving, traverse it
1282    # but do not mark it for saving if it is not already
1283    # e.g. to get to Getopt::Long we need to traverse Getopt but need
1284    # not save Getopt
1285    return 1 if ($u =~ /^$package\:\:/);
1286   }
1287  if (exists $unused_sub_packages{$package})
1288   {
1289    # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1290    delete_unsaved_hashINC($package) unless  $unused_sub_packages{$package} ;
1291    return $unused_sub_packages{$package};
1292   }
1293  # Omit the packages which we use (and which cause grief
1294  # because of fancy "goto &$AUTOLOAD" stuff).
1295  # XXX Surely there must be a nicer way to do this.
1296  if ($package eq "FileHandle" || $package eq "Config" ||
1297      $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1298   {
1299    delete_unsaved_hashINC($package);
1300    return $unused_sub_packages{$package} = 0;
1301   }
1302  # Now see if current package looks like an OO class this is probably too strong.
1303  foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1304   {
1305    if ($package->can($m))
1306     {
1307      warn "$package has method $m: saving package\n";#debug
1308      return mark_package($package);
1309     }
1310   }
1311  delete_unsaved_hashINC($package);
1312  return $unused_sub_packages{$package} = 0;
1313 }
1314 sub delete_unsaved_hashINC{
1315         my $packname=shift;
1316         $packname =~ s/\:\:/\//g;
1317         $packname .= '.pm';
1318 #       warn "deleting $packname" if $INC{$packname} ;# debug
1319         delete $INC{$packname};
1320 }
1321 sub walkpackages
1322 {
1323  my ($symref, $recurse, $prefix) = @_;
1324  my $sym;
1325  my $ref;
1326  no strict 'vars';
1327  local(*glob);
1328  $prefix = '' unless defined $prefix;
1329  while (($sym, $ref) = each %$symref)
1330   {
1331    *glob = $ref;
1332    if ($sym =~ /::$/)
1333     {
1334      $sym = $prefix . $sym;
1335      if ($sym ne "main::" && &$recurse($sym))
1336       {
1337        walkpackages(\%glob, $recurse, $sym);
1338       }
1339     }
1340   }
1341 }
1342
1343
1344 sub save_unused_subs
1345 {
1346  no strict qw(refs);
1347  &descend_marked_unused;
1348  warn "Prescan\n";
1349  walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1350  warn "Saving methods\n";
1351  walksymtable(\%{"main::"}, "savecv", \&should_save);
1352 }
1353
1354 sub save_context
1355 {
1356  my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1357  my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1358  my $inc_hv     = svref_2object(\%INC)->save;
1359  my $inc_av     = svref_2object(\@INC)->save;
1360  my $amagic_generate= amagic_generation;
1361  $init->add(   "PL_curpad = AvARRAY($curpad_sym);",
1362                "GvHV(PL_incgv) = $inc_hv;",
1363                "GvAV(PL_incgv) = $inc_av;",
1364                "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1365                "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1366                 "PL_amagic_generation= $amagic_generate;" );
1367 }
1368
1369 sub descend_marked_unused {
1370     foreach my $pack (keys %unused_sub_packages)
1371     {
1372         mark_package($pack);
1373     }
1374 }
1375
1376 sub save_main {
1377     warn "Starting compile\n";
1378     warn "Walking tree\n";
1379     seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1380     walkoptree(main_root, "save");
1381     warn "done main optree, walking symtable for extras\n" if $debug_cv;
1382     save_unused_subs();
1383     my $init_av = init_av->save;
1384     $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1385                sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1386               "PL_initav = (AV *) $init_av;");
1387     save_context();
1388     warn "Writing output\n";
1389     output_boilerplate();
1390     print "\n";
1391     output_all("perl_init");
1392     print "\n";
1393     output_main();
1394 }
1395
1396 sub init_sections {
1397     my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1398                     binop => \$binopsect, condop => \$condopsect,
1399                     cop => \$copsect, gvop => \$gvopsect,
1400                     listop => \$listopsect, logop => \$logopsect,
1401                     loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1402                     pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1403                     sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1404                     xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1405                     xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1406                     xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1407                     xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1408                     xpvio => \$xpviosect);
1409     my ($name, $sectref);
1410     while (($name, $sectref) = splice(@sections, 0, 2)) {
1411         $$sectref = new B::C::Section $name, \%symtable, 0;
1412     }
1413 }
1414
1415 sub mark_unused
1416 {
1417  my ($arg,$val) = @_;
1418  $unused_sub_packages{$arg} = $val;
1419 }
1420
1421 sub compile {
1422     my @options = @_;
1423     my ($option, $opt, $arg);
1424   OPTION:
1425     while ($option = shift @options) {
1426         if ($option =~ /^-(.)(.*)/) {
1427             $opt = $1;
1428             $arg = $2;
1429         } else {
1430             unshift @options, $option;
1431             last OPTION;
1432         }
1433         if ($opt eq "-" && $arg eq "-") {
1434             shift @options;
1435             last OPTION;
1436         }
1437         if ($opt eq "w") {
1438             $warn_undefined_syms = 1;
1439         } elsif ($opt eq "D") {
1440             $arg ||= shift @options;
1441             foreach $arg (split(//, $arg)) {
1442                 if ($arg eq "o") {
1443                     B->debug(1);
1444                 } elsif ($arg eq "c") {
1445                     $debug_cops = 1;
1446                 } elsif ($arg eq "A") {
1447                     $debug_av = 1;
1448                 } elsif ($arg eq "C") {
1449                     $debug_cv = 1;
1450                 } elsif ($arg eq "M") {
1451                     $debug_mg = 1;
1452                 } else {
1453                     warn "ignoring unknown debug option: $arg\n";
1454                 }
1455             }
1456         } elsif ($opt eq "o") {
1457             $arg ||= shift @options;
1458             open(STDOUT, ">$arg") or return "$arg: $!\n";
1459         } elsif ($opt eq "v") {
1460             $verbose = 1;
1461         } elsif ($opt eq "u") {
1462             $arg ||= shift @options;
1463             mark_unused($arg,undef);
1464         } elsif ($opt eq "f") {
1465             $arg ||= shift @options;
1466             if ($arg eq "cog") {
1467                 $pv_copy_on_grow = 1;
1468             } elsif ($arg eq "no-cog") {
1469                 $pv_copy_on_grow = 0;
1470             }
1471         } elsif ($opt eq "O") {
1472             $arg = 1 if $arg eq "";
1473             $pv_copy_on_grow = 0;
1474             if ($arg >= 1) {
1475                 # Optimisations for -O1
1476                 $pv_copy_on_grow = 1;
1477             }
1478         }
1479     }
1480     init_sections();
1481     if (@options) {
1482         return sub {
1483             my $objname;
1484             foreach $objname (@options) {
1485                 eval "save_object(\\$objname)";
1486             }
1487             output_all();
1488         }
1489     } else {
1490         return sub { save_main() };
1491     }
1492 }
1493
1494 1;
1495
1496 __END__
1497
1498 =head1 NAME
1499
1500 B::C - Perl compiler's C backend
1501
1502 =head1 SYNOPSIS
1503
1504         perl -MO=C[,OPTIONS] foo.pl
1505
1506 =head1 DESCRIPTION
1507
1508 This compiler backend takes Perl source and generates C source code
1509 corresponding to the internal structures that perl uses to run
1510 your program. When the generated C source is compiled and run, it
1511 cuts out the time which perl would have taken to load and parse
1512 your program into its internal semi-compiled form. That means that
1513 compiling with this backend will not help improve the runtime
1514 execution speed of your program but may improve the start-up time.
1515 Depending on the environment in which your program runs this may be
1516 either a help or a hindrance.
1517
1518 =head1 OPTIONS
1519
1520 If there are any non-option arguments, they are taken to be
1521 names of objects to be saved (probably doesn't work properly yet).
1522 Without extra arguments, it saves the main program.
1523
1524 =over 4
1525
1526 =item B<-ofilename>
1527
1528 Output to filename instead of STDOUT
1529
1530 =item B<-v>
1531
1532 Verbose compilation (currently gives a few compilation statistics).
1533
1534 =item B<-->
1535
1536 Force end of options
1537
1538 =item B<-uPackname>
1539
1540 Force apparently unused subs from package Packname to be compiled.
1541 This allows programs to use eval "foo()" even when sub foo is never
1542 seen to be used at compile time. The down side is that any subs which
1543 really are never used also have code generated. This option is
1544 necessary, for example, if you have a signal handler foo which you
1545 initialise with C<$SIG{BAR} = "foo">.  A better fix, though, is just
1546 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1547 options. The compiler tries to figure out which packages may possibly
1548 have subs in which need compiling but the current version doesn't do
1549 it very well. In particular, it is confused by nested packages (i.e.
1550 of the form C<A::B>) where package C<A> does not contain any subs.
1551
1552 =item B<-D>
1553
1554 Debug options (concatenated or separate flags like C<perl -D>).
1555
1556 =item B<-Do>
1557
1558 OPs, prints each OP as it's processed
1559
1560 =item B<-Dc>
1561
1562 COPs, prints COPs as processed (incl. file & line num)
1563
1564 =item B<-DA>
1565
1566 prints AV information on saving
1567
1568 =item B<-DC>
1569
1570 prints CV information on saving
1571
1572 =item B<-DM>
1573
1574 prints MAGIC information on saving
1575
1576 =item B<-f>
1577
1578 Force optimisations on or off one at a time.
1579
1580 =item B<-fcog>
1581
1582 Copy-on-grow: PVs declared and initialised statically.
1583
1584 =item B<-fno-cog>
1585
1586 No copy-on-grow.
1587
1588 =item B<-On>
1589
1590 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.  Currently,
1591 B<-O1> and higher set B<-fcog>.
1592
1593 =head1 EXAMPLES
1594
1595     perl -MO=C,-ofoo.c foo.pl
1596     perl cc_harness -o foo foo.c
1597
1598 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1599 library directory. The utility called C<perlcc> may also be used to
1600 help make use of this compiler.
1601
1602     perl -MO=C,-v,-DcA bar.pl > /dev/null
1603
1604 =head1 BUGS
1605
1606 Plenty. Current status: experimental.
1607
1608 =head1 AUTHOR
1609
1610 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
1611
1612 =cut