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
  48                 init_sections set_callback save_unused_subs objsym);
  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);
  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 # XXX This shouldn't really be hardcoded here but it saves
 109 # looking up the name of every BASEOP in B::OP
 110 sub OP_THREADSV () { 345 }
 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         }
 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  return unless ($$cv || $name eq 'ISA');
1113  # We may be looking at this package just because it is a branch in the
1114  # symbol table which is on the path to a package which we need to save
1115  # e.g. this is 'Getopt' and wee need to save 'Getopt::Long'
1116  #
1117  if ($$cv && $name eq "bootstrap" && $cv->XSUB)
1118   {
1119    my $file = $cv->FILEGV->SV->PV;
1120    $bootstrap->add($file);
1121   }
1122  unless ($unused_sub_packages{$package})
1123   {
1124    warn sprintf("omitting cv $name in %s\n", $package) if $$cv; # if $debug_cv;
1125    return ;
1126   }
1127  if ($$cv)
1128   {
1129    if ($name eq "bootstrap" && $cv->XSUB)
1130     {
1131      my $name = $gv->STASH->NAME.'::'.$name;
1132      no strict 'refs';
1133      *{$name} = \&Dummy_BootStrap;
1134      $cv = $gv->CV;
1135     }
1136    warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
1137                   $package, $name, $$cv, $$gv) if ($debug_cv);
1138    $gv->save;
1139   }
1140  elsif ($name eq 'ISA')
1141   {
1142    $gv->save;
1143   }
1144 }
1145
1146 sub mark_package
1147 {
1148  my $package = shift;
1149  unless ($unused_sub_packages{$package})
1150   {
1151    no strict 'refs';
1152    $unused_sub_packages{$package} = 1;
1153    if (defined(@{$package.'::ISA'}))
1154     {
1155      foreach my $isa (@{$package.'::ISA'})
1156       {
1157        if ($isa eq 'DynaLoader')
1158         {
1159          unless (defined(&{$package.'::bootstrap'}))
1160           {
1161            warn "Forcing bootstrap of $package\n";
1162            eval { $package->bootstrap };
1163           }
1164         }
1165        else
1166         {
1167          unless ($unused_sub_packages{$isa})
1168           {
1169            warn "$isa saved (it is in $package\'s \@ISA)\n";
1170            mark_package($isa);
1171           }
1172         }
1173       }
1174     }
1175   }
1176  return 1;
1177 }
1178
1179 sub should_save
1180 {
1181  no strict qw(vars refs);
1182  my $package = shift;
1183  $package =~ s/::$//;
1184  return $unused_sub_packages{$package} = 0 if ($package =~ /::::/);  # skip ::::ISA::CACHE etc.
1185  warn "Considering $package\n";#debug
1186  foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1187   {
1188    # If this package is a prefix to something we are saving, traverse it
1189    # but do not mark it for saving if it is not already
1190    # e.g. to get to Getopt::Long we need to traverse Getopt but need
1191    # not save Getopt
1192    return 1 if ($u =~ /^$package\:\:/);
1193   }
1194  if (exists $unused_sub_packages{$package})
1195   {
1196    warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1197    return $unused_sub_packages{$package}
1198   }
1199  # Omit the packages which we use (and which cause grief
1200  # because of fancy "goto &$AUTOLOAD" stuff).
1201  # XXX Surely there must be a nicer way to do this.
1202  if ($package eq "FileHandle" || $package eq "Config" ||
1203      $package eq "SelectSaver" || $package =~/^B::/)
1204   {
1205    return $unused_sub_packages{$package} = 0;
1206   }
1207  # Now see if current package looks like an OO class this is probably too strong.
1208  foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1209   {
1210    if ($package->can($m))
1211     {
1212      warn "$package has method $m: saving package\n";#debug
1213      return mark_package($package);
1214     }
1215   }
1216  return $unused_sub_packages{$package} = 0;
1217 }
1218
1219 sub walkpackages
1220 {
1221  my ($symref, $recurse, $prefix) = @_;
1222  my $sym;
1223  my $ref;
1224  no strict 'vars';
1225  local(*glob);
1226  $prefix = '' unless defined $prefix;
1227  while (($sym, $ref) = each %$symref)
1228   {
1229    *glob = $ref;
1230    if ($sym =~ /::$/)
1231     {
1232      $sym = $prefix . $sym;
1233      if ($sym ne "main::" && &$recurse($sym))
1234       {
1235        walkpackages(\%glob, $recurse, $sym);
1236       }
1237     }
1238   }
1239 }
1240
1241
1242 sub save_unused_subs
1243 {
1244  no strict qw(refs);
1245  warn "Prescan\n";
1246  walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1247  warn "Saving methods\n";
1248  walksymtable(\%{"main::"}, "savecv", \&should_save);
1249 }
1250
1251 sub save_main {
1252     warn "Starting compile\n";
1253     foreach my $pack (keys %unused_sub_packages)
1254      {
1255       mark_package($pack);
1256      }
1257     my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1258     my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1259     my $init_av    = init_av->save;
1260     my $inc_hv     = svref_2object(\%INC)->save;
1261     my $inc_av     = svref_2object(\@INC)->save;
1262     warn "Walking tree\n";
1263     walkoptree(main_root, "save");
1264     warn "done main optree, walking symtable for extras\n" if $debug_cv;
1265     save_unused_subs();
1266
1267     $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1268                sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1269                "PL_curpad = AvARRAY($curpad_sym);",
1270                "PL_initav = $init_av;",
1271                "GvHV(PL_incgv) = $inc_hv;",
1272                "GvAV(PL_incgv) = $inc_av;",
1273                "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1274                "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));");
1275     warn "Writing output\n";
1276     output_boilerplate();
1277     print "\n";
1278     output_all("perl_init");
1279     print "\n";
1280     output_main();
1281 }
1282
1283 sub init_sections {
1284     my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1285                     binop => \$binopsect, condop => \$condopsect,
1286                     cop => \$copsect, gvop => \$gvopsect,
1287                     listop => \$listopsect, logop => \$logopsect,
1288                     loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1289                     pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1290                     sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1291                     xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1292                     xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1293                     xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1294                     xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1295                     xpvio => \$xpviosect, bootstrap => \$bootstrap);
1296     my ($name, $sectref);
1297     while (($name, $sectref) = splice(@sections, 0, 2)) {
1298         $$sectref = new B::C::Section $name, \%symtable, 0;
1299     }
1300 }
1301
1302 sub compile {
1303     my @options = @_;
1304     my ($option, $opt, $arg);
1305   OPTION:
1306     while ($option = shift @options) {
1307         if ($option =~ /^-(.)(.*)/) {
1308             $opt = $1;
1309             $arg = $2;
1310         } else {
1311             unshift @options, $option;
1312             last OPTION;
1313         }
1314         if ($opt eq "-" && $arg eq "-") {
1315             shift @options;
1316             last OPTION;
1317         }
1318         if ($opt eq "w") {
1319             $warn_undefined_syms = 1;
1320         } elsif ($opt eq "D") {
1321             $arg ||= shift @options;
1322             foreach $arg (split(//, $arg)) {
1323                 if ($arg eq "o") {
1324                     B->debug(1);
1325                 } elsif ($arg eq "c") {
1326                     $debug_cops = 1;
1327                 } elsif ($arg eq "A") {
1328                     $debug_av = 1;
1329                 } elsif ($arg eq "C") {
1330                     $debug_cv = 1;
1331                 } elsif ($arg eq "M") {
1332                     $debug_mg = 1;
1333                 } else {
1334                     warn "ignoring unknown debug option: $arg\n";
1335                 }
1336             }
1337         } elsif ($opt eq "o") {
1338             $arg ||= shift @options;
1339             open(STDOUT, ">$arg") or return "$arg: $!\n";
1340         } elsif ($opt eq "v") {
1341             $verbose = 1;
1342         } elsif ($opt eq "u") {
1343             $arg ||= shift @options;
1344             $unused_sub_packages{$arg} = undef;
1345         } elsif ($opt eq "f") {
1346             $arg ||= shift @options;
1347             if ($arg eq "cog") {
1348                 $pv_copy_on_grow = 1;
1349             } elsif ($arg eq "no-cog") {
1350                 $pv_copy_on_grow = 0;
1351             }
1352         } elsif ($opt eq "O") {
1353             $arg = 1 if $arg eq "";
1354             $pv_copy_on_grow = 0;
1355             if ($arg >= 1) {
1356                 # Optimisations for -O1
1357                 $pv_copy_on_grow = 1;
1358             }
1359         }
1360     }
1361     init_sections();
1362     if (@options) {
1363         return sub {
1364             my $objname;
1365             foreach $objname (@options) {
1366                 eval "save_object(\\$objname)";
1367             }
1368             output_all();
1369         }
1370     } else {
1371         return sub { save_main() };
1372     }
1373 }
1374
1375 1;
1376
1377 __END__
1378
1379 =head1 NAME
1380
1381 B::C - Perl compiler's C backend
1382
1383 =head1 SYNOPSIS
1384
1385         perl -MO=C[,OPTIONS] foo.pl
1386
1387 =head1 DESCRIPTION
1388
1389 This compiler backend takes Perl source and generates C source code
1390 corresponding to the internal structures that perl uses to run
1391 your program. When the generated C source is compiled and run, it
1392 cuts out the time which perl would have taken to load and parse
1393 your program into its internal semi-compiled form. That means that
1394 compiling with this backend will not help improve the runtime
1395 execution speed of your program but may improve the start-up time.
1396 Depending on the environment in which your program runs this may be
1397 either a help or a hindrance.
1398
1399 =head1 OPTIONS
1400
1401 If there are any non-option arguments, they are taken to be
1402 names of objects to be saved (probably doesn't work properly yet).
1403 Without extra arguments, it saves the main program.
1404
1405 =over 4
1406
1407 =item B<-ofilename>
1408
1409 Output to filename instead of STDOUT
1410
1411 =item B<-v>
1412
1413 Verbose compilation (currently gives a few compilation statistics).
1414
1415 =item B<-->
1416
1417 Force end of options
1418
1419 =item B<-uPackname>
1420
1421 Force apparently unused subs from package Packname to be compiled.
1422 This allows programs to use eval "foo()" even when sub foo is never
1423 seen to be used at compile time. The down side is that any subs which
1424 really are never used also have code generated. This option is
1425 necessary, for example, if you have a signal handler foo which you
1426 initialise with C<$SIG{BAR} = "foo">.  A better fix, though, is just
1427 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1428 options. The compiler tries to figure out which packages may possibly
1429 have subs in which need compiling but the current version doesn't do
1430 it very well. In particular, it is confused by nested packages (i.e.
1431 of the form C<A::B>) where package C<A> does not contain any subs.
1432
1433 =item B<-D>
1434
1435 Debug options (concatenated or separate flags like C<perl -D>).
1436
1437 =item B<-Do>
1438
1439 OPs, prints each OP as it's processed
1440
1441 =item B<-Dc>
1442
1443 COPs, prints COPs as processed (incl. file & line num)
1444
1445 =item B<-DA>
1446
1447 prints AV information on saving
1448
1449 =item B<-DC>
1450
1451 prints CV information on saving
1452
1453 =item B<-DM>
1454
1455 prints MAGIC information on saving
1456
1457 =item B<-f>
1458
1459 Force optimisations on or off one at a time.
1460
1461 =item B<-fcog>
1462
1463 Copy-on-grow: PVs declared and initialised statically.
1464
1465 =item B<-fno-cog>
1466
1467 No copy-on-grow.
1468
1469 =item B<-On>
1470
1471 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.  Currently,
1472 B<-O1> and higher set B<-fcog>.
1473
1474 =head1 EXAMPLES
1475
1476     perl -MO=C,-ofoo.c foo.pl
1477     perl cc_harness -o foo foo.c
1478
1479 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1480 library directory. The utility called C<perlcc> may also be used to
1481 help make use of this compiler.
1482
1483     perl -MO=C,-v,-DcA bar.pl > /dev/null
1484
1485 =head1 BUGS
1486
1487 Plenty. Current status: experimental.
1488
1489 =head1 AUTHOR
1490
1491 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
1492
1493 =cut