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