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