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