ext/B/B/C.pm

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