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