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