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