ext/B/B/C.pm

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