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