ext/B/B/C.pm

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