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