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