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