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