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