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