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 #ifndef PATCHLEVEL
1031 #include "patchlevel.h"
1032 #endif
1033
1034 /* Workaround for mapstart: the only op which needs a different ppaddr */
1035 #undef pp_mapstart
1036 #define pp_mapstart pp_grepstart
1037 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1038 EXTERN_C void boot_DynaLoader _((CV* cv));
1039
1040 static void xs_init _((void));
1041 static PerlInterpreter *my_perl;
1042 EOT
1043 }
1044
1045 sub output_main {
1046     print <<'EOT';
1047 int
1048 #ifndef CAN_PROTOTYPE
1049 main(argc, argv, env)
1050 int argc;
1051 char **argv;
1052 char **env;
1053 #else  /* def(CAN_PROTOTYPE) */
1054 main(int argc, char **argv, char **env)
1055 #endif  /* def(CAN_PROTOTYPE) */
1056 {
1057     int exitstatus;
1058     int i;
1059     char **fakeargv;
1060
1061     PERL_SYS_INIT(&argc,&argv);
1062
1063     perl_init_i18nl10n(1);
1064
1065     if (!PL_do_undump) {
1066         my_perl = perl_alloc();
1067         if (!my_perl)
1068             exit(1);
1069         perl_construct( my_perl );
1070     }
1071
1072 #ifdef CSH
1073     if (!PL_cshlen)
1074       PL_cshlen = strlen(PL_cshname);
1075 #endif
1076
1077 #ifdef ALLOW_PERL_OPTIONS
1078 #define EXTRA_OPTIONS 2
1079 #else
1080 #define EXTRA_OPTIONS 3
1081 #endif /* ALLOW_PERL_OPTIONS */
1082     New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1083     fakeargv[0] = argv[0];
1084     fakeargv[1] = "-e";
1085     fakeargv[2] = "";
1086 #ifndef ALLOW_PERL_OPTIONS
1087     fakeargv[3] = "--";
1088 #endif /* ALLOW_PERL_OPTIONS */
1089     for (i = 1; i < argc; i++)
1090         fakeargv[i + EXTRA_OPTIONS] = argv[i];
1091     fakeargv[argc + EXTRA_OPTIONS] = 0;
1092
1093     exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1094                             fakeargv, NULL);
1095     if (exitstatus)
1096         exit( exitstatus );
1097
1098     sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1099     PL_main_cv = PL_compcv;
1100     PL_compcv = 0;
1101
1102     exitstatus = perl_init();
1103     if (exitstatus)
1104         exit( exitstatus );
1105
1106     exitstatus = perl_run( my_perl );
1107
1108     perl_destruct( my_perl );
1109     perl_free( my_perl );
1110
1111     exit( exitstatus );
1112 }
1113
1114 /* yanked from perl.c */
1115 static void
1116 xs_init()
1117 {
1118     char *file = __FILE__;
1119     dXSUB_SYS;
1120         newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
1121 }
1122 EOT
1123 }
1124
1125 sub dump_symtable {
1126     # For debugging
1127     my ($sym, $val);
1128     warn "----Symbol table:\n";
1129     while (($sym, $val) = each %symtable) {
1130         warn "$sym => $val\n";
1131     }
1132     warn "---End of symbol table\n";
1133 }
1134
1135 sub save_object {
1136     my $sv;
1137     foreach $sv (@_) {
1138         svref_2object($sv)->save;
1139     }
1140 }
1141
1142 sub Dummy_BootStrap { }
1143
1144 sub B::GV::savecv
1145 {
1146  my $gv = shift;
1147  my $package=$gv->STASH->NAME;
1148  my $name = $gv->NAME;
1149  my $cv = $gv->CV;
1150  my $sv = $gv->SV;
1151  my $av = $gv->AV;
1152  my $hv = $gv->HV;
1153  my $skip_cv = 0;
1154
1155  # We may be looking at this package just because it is a branch in the
1156  # symbol table which is on the path to a package which we need to save
1157  # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1158  #
1159  return unless ($unused_sub_packages{$package});
1160  if ($$cv)
1161   {
1162    if ($name eq "bootstrap" && $cv->XSUB)
1163     {
1164      my $file = $cv->FILEGV->SV->PV;
1165      $bootstrap->add($file);
1166      my $name = $gv->STASH->NAME.'::'.$name;
1167      no strict 'refs';
1168      *{$name} = \&Dummy_BootStrap;
1169      $cv = $gv->CV;
1170     }
1171    warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
1172                   $package, $name, $$cv, $$gv) if ($debug_cv);
1173   }
1174  else
1175   {
1176    return unless ($$av || $$sv || $$hv)
1177   }
1178  $gv->save($skip_cv);
1179 }
1180
1181 sub mark_package
1182 {
1183  my $package = shift;
1184  unless ($unused_sub_packages{$package})
1185   {
1186    no strict 'refs';
1187    $unused_sub_packages{$package} = 1;
1188    if (defined(@{$package.'::ISA'}))
1189     {
1190      foreach my $isa (@{$package.'::ISA'})
1191       {
1192        if ($isa eq 'DynaLoader')
1193         {
1194          unless (defined(&{$package.'::bootstrap'}))
1195           {
1196            warn "Forcing bootstrap of $package\n";
1197            eval { $package->bootstrap };
1198           }
1199         }
1200        else
1201         {
1202          unless ($unused_sub_packages{$isa})
1203           {
1204            warn "$isa saved (it is in $package\'s \@ISA)\n";
1205            mark_package($isa);
1206           }
1207         }
1208       }
1209     }
1210   }
1211  return 1;
1212 }
1213
1214 sub should_save
1215 {
1216  no strict qw(vars refs);
1217  my $package = shift;
1218  $package =~ s/::$//;
1219  return $unused_sub_packages{$package} = 0 if ($package =~ /::::/);  # skip ::::ISA::CACHE etc.
1220  # warn "Considering $package\n";#debug
1221  foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1222   {
1223    # If this package is a prefix to something we are saving, traverse it
1224    # but do not mark it for saving if it is not already
1225    # e.g. to get to Getopt::Long we need to traverse Getopt but need
1226    # not save Getopt
1227    return 1 if ($u =~ /^$package\:\:/);
1228   }
1229  if (exists $unused_sub_packages{$package})
1230   {
1231    # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1232    return $unused_sub_packages{$package}
1233   }
1234  # Omit the packages which we use (and which cause grief
1235  # because of fancy "goto &$AUTOLOAD" stuff).
1236  # XXX Surely there must be a nicer way to do this.
1237  if ($package eq "FileHandle" || $package eq "Config" ||
1238      $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1239   {
1240    return $unused_sub_packages{$package} = 0;
1241   }
1242  # Now see if current package looks like an OO class this is probably too strong.
1243  foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1244   {
1245    if ($package->can($m))
1246     {
1247      warn "$package has method $m: saving package\n";#debug
1248      return mark_package($package);
1249     }
1250   }
1251  return $unused_sub_packages{$package} = 0;
1252 }
1253
1254 sub walkpackages
1255 {
1256  my ($symref, $recurse, $prefix) = @_;
1257  my $sym;
1258  my $ref;
1259  no strict 'vars';
1260  local(*glob);
1261  $prefix = '' unless defined $prefix;
1262  while (($sym, $ref) = each %$symref)
1263   {
1264    *glob = $ref;
1265    if ($sym =~ /::$/)
1266     {
1267      $sym = $prefix . $sym;
1268      if ($sym ne "main::" && &$recurse($sym))
1269       {
1270        walkpackages(\%glob, $recurse, $sym);
1271       }
1272     }
1273   }
1274 }
1275
1276
1277 sub save_unused_subs
1278 {
1279  no strict qw(refs);
1280  &descend_marked_unused;
1281  warn "Prescan\n";
1282  walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1283  warn "Saving methods\n";
1284  walksymtable(\%{"main::"}, "savecv", \&should_save);
1285 }
1286
1287 sub save_context
1288 {
1289  my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1290  my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1291  my $inc_hv     = svref_2object(\%INC)->save;
1292  my $inc_av     = svref_2object(\@INC)->save;
1293  $init->add(   "PL_curpad = AvARRAY($curpad_sym);",
1294                "GvHV(PL_incgv) = $inc_hv;",
1295                "GvAV(PL_incgv) = $inc_av;",
1296                "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1297                "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));");
1298 }
1299
1300 sub descend_marked_unused {
1301     foreach my $pack (keys %unused_sub_packages)
1302     {
1303         mark_package($pack);
1304     }
1305 }
1306
1307 sub descend_marked_unused {
1308     foreach my $pack (keys %unused_sub_packages)
1309     {
1310         mark_package($pack);
1311     }
1312 }
1313
1314 sub save_main {
1315     warn "Starting compile\n";
1316     warn "Walking tree\n";
1317     seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1318     walkoptree(main_root, "save");
1319     warn "done main optree, walking symtable for extras\n" if $debug_cv;
1320     save_unused_subs();
1321     my $init_av = init_av->save;
1322     $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1323                sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1324                "PL_initav = $init_av;");
1325     save_context();
1326     warn "Writing output\n";
1327     output_boilerplate();
1328     print "\n";
1329     output_all("perl_init");
1330     print "\n";
1331     output_main();
1332 }
1333
1334 sub init_sections {
1335     my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1336                     binop => \$binopsect, condop => \$condopsect,
1337                     cop => \$copsect, gvop => \$gvopsect,
1338                     listop => \$listopsect, logop => \$logopsect,
1339                     loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1340                     pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1341                     sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1342                     xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1343                     xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1344                     xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1345                     xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1346                     xpvio => \$xpviosect, bootstrap => \$bootstrap);
1347     my ($name, $sectref);
1348     while (($name, $sectref) = splice(@sections, 0, 2)) {
1349         $$sectref = new B::C::Section $name, \%symtable, 0;
1350     }
1351 }
1352
1353 sub mark_unused
1354 {
1355  my ($arg,$val) = @_;
1356  $unused_sub_packages{$arg} = $val;
1357 }
1358
1359 sub compile {
1360     my @options = @_;
1361     my ($option, $opt, $arg);
1362   OPTION:
1363     while ($option = shift @options) {
1364         if ($option =~ /^-(.)(.*)/) {
1365             $opt = $1;
1366             $arg = $2;
1367         } else {
1368             unshift @options, $option;
1369             last OPTION;
1370         }
1371         if ($opt eq "-" && $arg eq "-") {
1372             shift @options;
1373             last OPTION;
1374         }
1375         if ($opt eq "w") {
1376             $warn_undefined_syms = 1;
1377         } elsif ($opt eq "D") {
1378             $arg ||= shift @options;
1379             foreach $arg (split(//, $arg)) {
1380                 if ($arg eq "o") {
1381                     B->debug(1);
1382                 } elsif ($arg eq "c") {
1383                     $debug_cops = 1;
1384                 } elsif ($arg eq "A") {
1385                     $debug_av = 1;
1386                 } elsif ($arg eq "C") {
1387                     $debug_cv = 1;
1388                 } elsif ($arg eq "M") {
1389                     $debug_mg = 1;
1390                 } else {
1391                     warn "ignoring unknown debug option: $arg\n";
1392                 }
1393             }
1394         } elsif ($opt eq "o") {
1395             $arg ||= shift @options;
1396             open(STDOUT, ">$arg") or return "$arg: $!\n";
1397         } elsif ($opt eq "v") {
1398             $verbose = 1;
1399         } elsif ($opt eq "u") {
1400             $arg ||= shift @options;
1401             mark_unused($arg,undef);
1402         } elsif ($opt eq "f") {
1403             $arg ||= shift @options;
1404             if ($arg eq "cog") {
1405                 $pv_copy_on_grow = 1;
1406             } elsif ($arg eq "no-cog") {
1407                 $pv_copy_on_grow = 0;
1408             }
1409         } elsif ($opt eq "O") {
1410             $arg = 1 if $arg eq "";
1411             $pv_copy_on_grow = 0;
1412             if ($arg >= 1) {
1413                 # Optimisations for -O1
1414                 $pv_copy_on_grow = 1;
1415             }
1416         }
1417     }
1418     init_sections();
1419     if (@options) {
1420         return sub {
1421             my $objname;
1422             foreach $objname (@options) {
1423                 eval "save_object(\\$objname)";
1424             }
1425             output_all();
1426         }
1427     } else {
1428         return sub { save_main() };
1429     }
1430 }
1431
1432 1;
1433
1434 __END__
1435
1436 =head1 NAME
1437
1438 B::C - Perl compiler's C backend
1439
1440 =head1 SYNOPSIS
1441
1442         perl -MO=C[,OPTIONS] foo.pl
1443
1444 =head1 DESCRIPTION
1445
1446 This compiler backend takes Perl source and generates C source code
1447 corresponding to the internal structures that perl uses to run
1448 your program. When the generated C source is compiled and run, it
1449 cuts out the time which perl would have taken to load and parse
1450 your program into its internal semi-compiled form. That means that
1451 compiling with this backend will not help improve the runtime
1452 execution speed of your program but may improve the start-up time.
1453 Depending on the environment in which your program runs this may be
1454 either a help or a hindrance.
1455
1456 =head1 OPTIONS
1457
1458 If there are any non-option arguments, they are taken to be
1459 names of objects to be saved (probably doesn't work properly yet).
1460 Without extra arguments, it saves the main program.
1461
1462 =over 4
1463
1464 =item B<-ofilename>
1465
1466 Output to filename instead of STDOUT
1467
1468 =item B<-v>
1469
1470 Verbose compilation (currently gives a few compilation statistics).
1471
1472 =item B<-->
1473
1474 Force end of options
1475
1476 =item B<-uPackname>
1477
1478 Force apparently unused subs from package Packname to be compiled.
1479 This allows programs to use eval "foo()" even when sub foo is never
1480 seen to be used at compile time. The down side is that any subs which
1481 really are never used also have code generated. This option is
1482 necessary, for example, if you have a signal handler foo which you
1483 initialise with C<$SIG{BAR} = "foo">.  A better fix, though, is just
1484 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1485 options. The compiler tries to figure out which packages may possibly
1486 have subs in which need compiling but the current version doesn't do
1487 it very well. In particular, it is confused by nested packages (i.e.
1488 of the form C<A::B>) where package C<A> does not contain any subs.
1489
1490 =item B<-D>
1491
1492 Debug options (concatenated or separate flags like C<perl -D>).
1493
1494 =item B<-Do>
1495
1496 OPs, prints each OP as it's processed
1497
1498 =item B<-Dc>
1499
1500 COPs, prints COPs as processed (incl. file & line num)
1501
1502 =item B<-DA>
1503
1504 prints AV information on saving
1505
1506 =item B<-DC>
1507
1508 prints CV information on saving
1509
1510 =item B<-DM>
1511
1512 prints MAGIC information on saving
1513
1514 =item B<-f>
1515
1516 Force optimisations on or off one at a time.
1517
1518 =item B<-fcog>
1519
1520 Copy-on-grow: PVs declared and initialised statically.
1521
1522 =item B<-fno-cog>
1523
1524 No copy-on-grow.
1525
1526 =item B<-On>
1527
1528 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.  Currently,
1529 B<-O1> and higher set B<-fcog>.
1530
1531 =head1 EXAMPLES
1532
1533     perl -MO=C,-ofoo.c foo.pl
1534     perl cc_harness -o foo foo.c
1535
1536 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1537 library directory. The utility called C<perlcc> may also be used to
1538 help make use of this compiler.
1539
1540     perl -MO=C,-v,-DcA bar.pl > /dev/null
1541
1542 =head1 BUGS
1543
1544 Plenty. Current status: experimental.
1545
1546 =head1 AUTHOR
1547
1548 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
1549
1550 =cut