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