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