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