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