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, 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 $avflags = $av->AvFLAGS;
1186     $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
1187                             $avflags));
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     warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
1194         if $debug_av;
1195     # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
1196     #if ($fill > -1 && ($avflags & AVf_REAL)) {
1197     if ($fill > -1) {
1198         my @array = $av->ARRAY;
1199         if ($debug_av) {
1200             my $el;
1201             my $i = 0;
1202             foreach $el (@array) {
1203                 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
1204                              $$av, $i++, class($el), $$el);
1205             }
1206         }
1207 #       my @names = map($_->save, @array);
1208         # XXX Better ways to write loop?
1209         # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
1210         # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
1211
1212         # micro optimization: op/pat.t ( and other code probably )
1213         # has very large pads ( 20k/30k elements ) passing them to
1214         # ->add is a performance bottleneck: passing them as a
1215         # single string cuts runtime from 6min20sec to 40sec
1216
1217         # you want to keep this out of the no_split/split
1218         # map("\t*svp++ = (SV*)$_;", @names),
1219         my $acc = '';
1220         foreach my $i ( 0..$#array ) {
1221               $acc .= "\t*svp++ = (SV*)" . $array[$i]->save . ";\n\t";
1222         }
1223         $acc .= "\n";
1224
1225         $init->no_split;
1226         $init->add("{",
1227                    "\tSV **svp;",
1228                    "\tAV *av = (AV*)&sv_list[$sv_list_index];",
1229                    "\tav_extend(av, $fill);",
1230                    "\tsvp = AvARRAY(av);" );
1231         $init->add($acc);
1232         $init->add("\tAvFILLp(av) = $fill;",
1233                    "}");
1234         $init->split;
1235         # we really added a lot of lines ( B::C::InitSection->add
1236         # should really scan for \n, but that would slow
1237         # it down
1238         $init->inc_count( $#array );
1239     } else {
1240         my $max = $av->MAX;
1241         $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
1242             if $max > -1;
1243     }
1244     return savesym($av, "(AV*)&sv_list[$sv_list_index]");
1245 }
1246
1247 sub B::HV::save {
1248     my ($hv) = @_;
1249     my $sym = objsym($hv);
1250     return $sym if defined $sym;
1251     my $name = $hv->NAME;
1252     if ($name) {
1253         # It's a stash
1254
1255         # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
1256         # the only symptom is that sv_reset tries to reset the PMf_USED flag of
1257         # a trashed op but we look at the trashed op_type and segfault.
1258         #my $adpmroot = ${$hv->PMROOT};
1259         my $adpmroot = 0;
1260         $decl->add("static HV *hv$hv_index;");
1261         # XXX Beware of weird package names containing double-quotes, \n, ...?
1262         $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
1263         if ($adpmroot) {
1264             $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
1265                                $adpmroot));
1266         }
1267         $sym = savesym($hv, "hv$hv_index");
1268         $hv_index++;
1269         return $sym;
1270     }
1271     # It's just an ordinary HV
1272     $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
1273                             $hv->MAX, $hv->RITER));
1274     $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
1275                          $xpvhvsect->index, $hv->REFCNT  , $hv->FLAGS));
1276     my $sv_list_index = $svsect->index;
1277     my @contents = $hv->ARRAY;
1278     if (@contents) {
1279         my $i;
1280         for ($i = 1; $i < @contents; $i += 2) {
1281             $contents[$i] = $contents[$i]->save;
1282         }
1283         $init->no_split;
1284         $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
1285         while (@contents) {
1286             my ($key, $value) = splice(@contents, 0, 2);
1287             $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
1288                                cstring($key),length(pack "a*",$key),
1289                                $value, hash($key)));
1290 #           $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
1291 #                              cstring($key),length($key),$value, 0));
1292         }
1293         $init->add("}");
1294         $init->split;
1295     }
1296     $hv->save_magic();
1297     return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
1298 }
1299
1300 sub B::IO::save_data {
1301     my( $io, $globname, @data ) = @_;
1302     my $data = join '', @data;
1303
1304     # XXX using $DATA might clobber it!
1305     my $sym = svref_2object( \\$data )->save;
1306     $init->add( split /\n/, <<CODE );
1307     {
1308         GV* gv = (GV*)gv_fetchpv( "$globname", TRUE, SVt_PV );
1309         SV* sv = $sym;
1310         GvSV( gv ) = sv;
1311     }
1312 CODE
1313     # for PerlIO::scalar
1314     $use_xsloader = 1;
1315     $init->add_eval( sprintf 'open(%s, "<", $%s)', $globname, $globname );
1316 }
1317
1318 sub B::IO::save {
1319     my ($io) = @_;
1320     my $sym = objsym($io);
1321     return $sym if defined $sym;
1322     my $pv = $io->PV;
1323     $pv = '' unless defined $pv;
1324     my $len = length($pv);
1325     $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",
1326                             $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
1327                             $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
1328                             cstring($io->TOP_NAME), cstring($io->FMT_NAME),
1329                             cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
1330                             cchar($io->IoTYPE), $io->IoFLAGS));
1331     $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
1332                          $xpviosect->index, $io->REFCNT , $io->FLAGS));
1333     $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
1334     # deal with $x = *STDIN/STDOUT/STDERR{IO}
1335     my $perlio_func;
1336     foreach ( qw(stdin stdout stderr) ) {
1337         $io->IsSTD($_) and $perlio_func = $_;
1338     }
1339     if( $perlio_func ) {
1340         $init->add( "IoIFP(${sym})=PerlIO_${perlio_func}();" );
1341         $init->add( "IoOFP(${sym})=PerlIO_${perlio_func}();" );
1342     }
1343
1344     my ($field, $fsym);
1345     foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
1346         $fsym = $io->$field();
1347         if ($$fsym) {
1348             $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
1349             $fsym->save;
1350         }
1351     }
1352     $io->save_magic;
1353     return $sym;
1354 }
1355
1356 sub B::SV::save {
1357     my $sv = shift;
1358     # This is where we catch an honest-to-goodness Nullsv (which gets
1359     # blessed into B::SV explicitly) and any stray erroneous SVs.
1360     return 0 unless $$sv;
1361     confess sprintf("cannot save that type of SV: %s (0x%x)\n",
1362                     class($sv), $$sv);
1363 }
1364
1365 sub output_all {
1366     my $init_name = shift;
1367     my $section;
1368     my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
1369                     $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect,
1370                     $loopsect, $copsect, $svsect, $xpvsect,
1371                     $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
1372                     $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
1373     $symsect->output(\*STDOUT, "#define %s\n");
1374     print "\n";
1375     output_declarations();
1376     foreach $section (@sections) {
1377         my $lines = $section->index + 1;
1378         if ($lines) {
1379             my $name = $section->name;
1380             my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
1381             print "Static $typename ${name}_list[$lines];\n";
1382         }
1383     }
1384     # XXX hack for when Perl accesses PVX of GVs
1385     print 'Static char emptystring[] = "\0";';
1386
1387     $decl->output(\*STDOUT, "%s\n");
1388     print "\n";
1389     foreach $section (@sections) {
1390         my $lines = $section->index + 1;
1391         if ($lines) {
1392             my $name = $section->name;
1393             my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
1394             printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
1395             $section->output(\*STDOUT, "\t{ %s }, /* %d */\n");
1396             print "};\n\n";
1397         }
1398     }
1399
1400     $init->output(\*STDOUT, "\t%s\n", $init_name );
1401     if ($verbose) {
1402         warn compile_stats();
1403         warn "NULLOP count: $nullop_count\n";
1404     }
1405 }
1406
1407 sub output_declarations {
1408     print <<'EOT';
1409 #ifdef BROKEN_STATIC_REDECL
1410 #define Static extern
1411 #else
1412 #define Static static
1413 #endif /* BROKEN_STATIC_REDECL */
1414
1415 #ifdef BROKEN_UNION_INIT
1416 /*
1417  * Cribbed from cv.h with ANY (a union) replaced by void*.
1418  * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
1419  */
1420 typedef struct {
1421     char *      xpv_pv;         /* pointer to malloced string */
1422     STRLEN      xpv_cur;        /* length of xp_pv as a C string */
1423     STRLEN      xpv_len;        /* allocated size */
1424     IV          xof_off;        /* integer value */
1425     NV          xnv_nv;         /* numeric value, if any */
1426     MAGIC*      xmg_magic;      /* magic for scalar array */
1427     HV*         xmg_stash;      /* class package */
1428
1429     HV *        xcv_stash;
1430     OP *        xcv_start;
1431     OP *        xcv_root;
1432     void      (*xcv_xsub) (pTHX_ CV*);
1433     ANY         xcv_xsubany;
1434     GV *        xcv_gv;
1435     char *      xcv_file;
1436     long        xcv_depth;      /* >= 2 indicates recursive call */
1437     AV *        xcv_padlist;
1438     CV *        xcv_outside;
1439     cv_flags_t  xcv_flags;
1440     U32         xcv_outside_seq; /* the COP sequence (at the point of our
1441                                   * compilation) in the lexically enclosing
1442                                   * sub */
1443 } XPVCV_or_similar;
1444 #define ANYINIT(i) i
1445 #else
1446 #define XPVCV_or_similar XPVCV
1447 #define ANYINIT(i) {i}
1448 #endif /* BROKEN_UNION_INIT */
1449 #define Nullany ANYINIT(0)
1450
1451 #define UNUSED 0
1452 #define sym_0 0
1453 EOT
1454     print "static GV *gv_list[$gv_index];\n" if $gv_index;
1455     print "\n";
1456 }
1457
1458
1459 sub output_boilerplate {
1460     print <<'EOT';
1461 #include "EXTERN.h"
1462 #include "perl.h"
1463 #include "XSUB.h"
1464
1465 /* Workaround for mapstart: the only op which needs a different ppaddr */
1466 #undef Perl_pp_mapstart
1467 #define Perl_pp_mapstart Perl_pp_grepstart
1468 #undef OP_MAPSTART
1469 #define OP_MAPSTART OP_GREPSTART
1470 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1471 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
1472
1473 static void xs_init (pTHX);
1474 static void dl_init (pTHX);
1475 static PerlInterpreter *my_perl;
1476 EOT
1477 }
1478
1479 sub init_op_addr {
1480     my( $op_type, $num ) = @_;
1481     my $op_list = $op_type."_list";
1482
1483     $init->add( split /\n/, <<EOT );
1484     {
1485         int i;
1486
1487         for( i = 0; i < ${num}; ++i )
1488         {
1489             ${op_list}\[i].op_ppaddr = PL_ppaddr[INT2PTR(int,${op_list}\[i].op_ppaddr)];
1490         }
1491     }
1492 EOT
1493 }
1494
1495 sub init_op_warn {
1496     my( $op_type, $num ) = @_;
1497     my $op_list = $op_type."_list";
1498
1499     # for resons beyond imagination, MSVC5 considers pWARN_ALL non-const
1500     $init->add( split /\n/, <<EOT );
1501     {
1502         int i;
1503
1504         for( i = 0; i < ${num}; ++i )
1505         {
1506             switch( (int)(${op_list}\[i].cop_warnings) )
1507             {
1508             case 1:
1509                 ${op_list}\[i].cop_warnings = pWARN_ALL;
1510                 break;
1511             case 2:
1512                 ${op_list}\[i].cop_warnings = pWARN_NONE;
1513                 break;
1514             case 3:
1515                 ${op_list}\[i].cop_warnings = pWARN_STD;
1516                 break;
1517             default:
1518                 break;
1519             }
1520         }
1521     }
1522 EOT
1523 }
1524
1525 sub output_main {
1526     print <<'EOT';
1527 /* if USE_IMPLICIT_SYS, we need a 'real' exit */
1528 #if defined(exit)
1529 #undef exit
1530 #endif
1531
1532 int
1533 main(int argc, char **argv, char **env)
1534 {
1535     int exitstatus;
1536     int i;
1537     char **fakeargv;
1538     GV* tmpgv;
1539     SV* tmpsv;
1540     int options_count;
1541
1542     PERL_SYS_INIT3(&argc,&argv,&env);
1543
1544     if (!PL_do_undump) {
1545         my_perl = perl_alloc();
1546         if (!my_perl)
1547             exit(1);
1548         perl_construct( my_perl );
1549         PL_perl_destruct_level = 0;
1550     }
1551 EOT
1552     if( $ithreads ) {
1553         # XXX init free elems!
1554         my $pad_len = regex_padav->FILL + 1 - 1; # first is an avref
1555
1556         print <<EOT;
1557 #ifdef USE_ITHREADS
1558     for( i = 0; i < $pad_len; ++i ) {
1559         av_push( PL_regex_padav, newSViv(0) );
1560     }
1561     PL_regex_pad = AvARRAY( PL_regex_padav );
1562 #endif
1563 EOT
1564     }
1565
1566     print <<'EOT';
1567 #ifdef CSH
1568     if (!PL_cshlen)
1569       PL_cshlen = strlen(PL_cshname);
1570 #endif
1571
1572 #ifdef ALLOW_PERL_OPTIONS
1573 #define EXTRA_OPTIONS 3
1574 #else
1575 #define EXTRA_OPTIONS 4
1576 #endif /* ALLOW_PERL_OPTIONS */
1577     New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1578
1579     fakeargv[0] = argv[0];
1580     fakeargv[1] = "-e";
1581     fakeargv[2] = "";
1582     options_count = 3;
1583 EOT
1584     # honour -T
1585     print <<EOT;
1586     if( ${^TAINT} ) {
1587         fakeargv[options_count] = "-T";
1588         ++options_count;
1589     }
1590 EOT
1591     print <<'EOT';
1592 #ifndef ALLOW_PERL_OPTIONS
1593     fakeargv[options_count] = "--";
1594     ++options_count;
1595 #endif /* ALLOW_PERL_OPTIONS */
1596     for (i = 1; i < argc; i++)
1597         fakeargv[i + options_count - 1] = argv[i];
1598     fakeargv[argc + options_count - 1] = 0;
1599
1600     exitstatus = perl_parse(my_perl, xs_init, argc + options_count - 1,
1601                             fakeargv, NULL);
1602
1603     if (exitstatus)
1604         exit( exitstatus );
1605
1606     TAINT;
1607 EOT
1608
1609     if( $use_perl_script_name ) {
1610         my $dollar_0 = $0;
1611         $dollar_0 =~ s/\\/\\\\/g;
1612         $dollar_0 = '"' . $dollar_0 . '"';
1613
1614         print <<EOT;
1615     if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */
1616         tmpsv = GvSV(tmpgv);
1617         sv_setpv(tmpsv, ${dollar_0});
1618         SvSETMAGIC(tmpsv);
1619     }
1620 EOT
1621     }
1622     else {
1623         print <<EOT;
1624     if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */
1625         tmpsv = GvSV(tmpgv);
1626         sv_setpv(tmpsv, argv[0]);
1627         SvSETMAGIC(tmpsv);
1628     }
1629 EOT
1630     }
1631
1632     print <<'EOT';
1633     if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
1634         tmpsv = GvSV(tmpgv);
1635 #ifdef WIN32
1636         sv_setpv(tmpsv,"perl.exe");
1637 #else
1638         sv_setpv(tmpsv,"perl");
1639 #endif
1640         SvSETMAGIC(tmpsv);
1641     }
1642
1643     TAINT_NOT;
1644
1645     /* PL_main_cv = PL_compcv; */
1646     PL_compcv = 0;
1647
1648     exitstatus = perl_init();
1649     if (exitstatus)
1650         exit( exitstatus );
1651     dl_init(aTHX);
1652
1653     exitstatus = perl_run( my_perl );
1654
1655     perl_destruct( my_perl );
1656     perl_free( my_perl );
1657
1658     PERL_SYS_TERM();
1659
1660     exit( exitstatus );
1661 }
1662
1663 /* yanked from perl.c */
1664 static void
1665 xs_init(pTHX)
1666 {
1667     char *file = __FILE__;
1668     dTARG;
1669     dSP;
1670 EOT
1671     print "\n#ifdef USE_DYNAMIC_LOADING";
1672     print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1673     print "\n#endif\n" ;
1674     # delete $xsub{'DynaLoader'};
1675     delete $xsub{'UNIVERSAL'};
1676     print("/* bootstrapping code*/\n\tSAVETMPS;\n");
1677     print("\ttarg=sv_newmortal();\n");
1678     print "#ifdef USE_DYNAMIC_LOADING\n";
1679     print "\tPUSHMARK(sp);\n";
1680     print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
1681     print qq/\tPUTBACK;\n/;
1682     print "\tboot_DynaLoader(aTHX_ NULL);\n";
1683     print qq/\tSPAGAIN;\n/;
1684     print "#endif\n";
1685     foreach my $stashname (keys %xsub){
1686         if ($xsub{$stashname} !~ m/Dynamic/ ) {
1687            my $stashxsub=$stashname;
1688            $stashxsub  =~ s/::/__/g;
1689            print "\tPUSHMARK(sp);\n";
1690            print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
1691            print qq/\tPUTBACK;\n/;
1692            print "\tboot_$stashxsub(aTHX_ NULL);\n";
1693            print qq/\tSPAGAIN;\n/;
1694         }
1695     }
1696     print("\tFREETMPS;\n/* end bootstrapping code */\n");
1697     print "}\n";
1698
1699 print <<'EOT';
1700 static void
1701 dl_init(pTHX)
1702 {
1703     char *file = __FILE__;
1704     dTARG;
1705     dSP;
1706 EOT
1707     print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
1708     print("\ttarg=sv_newmortal();\n");
1709     foreach my $stashname (@DynaLoader::dl_modules) {
1710         warn "Loaded $stashname\n";
1711         if (exists($xsub{$stashname}) && $xsub{$stashname} =~ m/Dynamic/) {
1712            my $stashxsub=$stashname;
1713            $stashxsub  =~ s/::/__/g;
1714            print "\tPUSHMARK(sp);\n";
1715            print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
1716            print qq/\tPUTBACK;\n/;
1717            print "#ifdef USE_DYNAMIC_LOADING\n";
1718            warn "bootstrapping $stashname added to xs_init\n";
1719            if( $xsub{$stashname} eq 'Dynamic' ) {
1720               print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
1721            }
1722            else {
1723               print qq/\tperl_call_pv("XSLoader::load",G_DISCARD);\n/;
1724            }
1725            print "#else\n";
1726            print "\tboot_$stashxsub(aTHX_ NULL);\n";
1727            print "#endif\n";
1728            print qq/\tSPAGAIN;\n/;
1729         }
1730     }
1731     print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
1732     print "}\n";
1733 }
1734 sub dump_symtable {
1735     # For debugging
1736     my ($sym, $val);
1737     warn "----Symbol table:\n";
1738     while (($sym, $val) = each %symtable) {
1739         warn "$sym => $val\n";
1740     }
1741     warn "---End of symbol table\n";
1742 }
1743
1744 sub save_object {
1745     my $sv;
1746     foreach $sv (@_) {
1747         svref_2object($sv)->save;
1748     }
1749 }
1750
1751 sub Dummy_BootStrap { }
1752
1753 sub B::GV::savecv
1754 {
1755  my $gv = shift;
1756  my $package=$gv->STASH->NAME;
1757  my $name = $gv->NAME;
1758  my $cv = $gv->CV;
1759  my $sv = $gv->SV;
1760  my $av = $gv->AV;
1761  my $hv = $gv->HV;
1762
1763  my $fullname = $gv->STASH->NAME . "::" . $gv->NAME;
1764
1765  # We may be looking at this package just because it is a branch in the
1766  # symbol table which is on the path to a package which we need to save
1767  # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1768  #
1769  return unless ($unused_sub_packages{$package});
1770  return unless ($$cv || $$av || $$sv || $$hv);
1771  $gv->save;
1772 }
1773
1774 sub mark_package
1775 {
1776  my $package = shift;
1777  unless ($unused_sub_packages{$package})
1778   {
1779    no strict 'refs';
1780    $unused_sub_packages{$package} = 1;
1781    if (defined @{$package.'::ISA'})
1782     {
1783      foreach my $isa (@{$package.'::ISA'})
1784       {
1785        if ($isa eq 'DynaLoader')
1786         {
1787          unless (defined(&{$package.'::bootstrap'}))
1788           {
1789            warn "Forcing bootstrap of $package\n";
1790            eval { $package->bootstrap };
1791           }
1792         }
1793 #      else
1794         {
1795          unless ($unused_sub_packages{$isa})
1796           {
1797            warn "$isa saved (it is in $package\'s \@ISA)\n";
1798            mark_package($isa);
1799           }
1800         }
1801       }
1802     }
1803   }
1804  return 1;
1805 }
1806
1807 sub should_save
1808 {
1809  no strict qw(vars refs);
1810  my $package = shift;
1811  $package =~ s/::$//;
1812  return $unused_sub_packages{$package} = 0 if ($package =~ /::::/);  # skip ::::ISA::CACHE etc.
1813  # warn "Considering $package\n";#debug
1814  foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1815   {
1816    # If this package is a prefix to something we are saving, traverse it
1817    # but do not mark it for saving if it is not already
1818    # e.g. to get to Getopt::Long we need to traverse Getopt but need
1819    # not save Getopt
1820    return 1 if ($u =~ /^$package\:\:/);
1821   }
1822  if (exists $unused_sub_packages{$package})
1823   {
1824    # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1825    delete_unsaved_hashINC($package) unless  $unused_sub_packages{$package} ;
1826    return $unused_sub_packages{$package};
1827   }
1828  # Omit the packages which we use (and which cause grief
1829  # because of fancy "goto &$AUTOLOAD" stuff).
1830  # XXX Surely there must be a nicer way to do this.
1831  if ($package eq "FileHandle" || $package eq "Config" ||
1832      $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1833   {
1834    delete_unsaved_hashINC($package);
1835    return $unused_sub_packages{$package} = 0;
1836   }
1837  # Now see if current package looks like an OO class this is probably too strong.
1838  foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1839   {
1840    if (UNIVERSAL::can($package, $m))
1841     {
1842      warn "$package has method $m: saving package\n";#debug
1843      return mark_package($package);
1844     }
1845   }
1846  delete_unsaved_hashINC($package);
1847  return $unused_sub_packages{$package} = 0;
1848 }
1849 sub delete_unsaved_hashINC{
1850         my $packname=shift;
1851         $packname =~ s/\:\:/\//g;
1852         $packname .= '.pm';
1853 #       warn "deleting $packname" if $INC{$packname} ;# debug
1854         delete $INC{$packname};
1855 }
1856 sub walkpackages
1857 {
1858  my ($symref, $recurse, $prefix) = @_;
1859  my $sym;
1860  my $ref;
1861  no strict 'vars';
1862  local(*glob);
1863  $prefix = '' unless defined $prefix;
1864  while (($sym, $ref) = each %$symref)
1865   {
1866    *glob = $ref;
1867    if ($sym =~ /::$/)
1868     {
1869      $sym = $prefix . $sym;
1870      if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym))
1871       {
1872        walkpackages(\%glob, $recurse, $sym);
1873       }
1874     }
1875   }
1876 }
1877
1878
1879 sub save_unused_subs
1880 {
1881  no strict qw(refs);
1882  &descend_marked_unused;
1883  warn "Prescan\n";
1884  walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1885  warn "Saving methods\n";
1886  walksymtable(\%{"main::"}, "savecv", \&should_save);
1887 }
1888
1889 sub save_context
1890 {
1891  my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1892  my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1893  my $inc_hv     = svref_2object(\%INC)->save;
1894  my $inc_av     = svref_2object(\@INC)->save;
1895  my $amagic_generate= amagic_generation;
1896  $init->add(   "PL_curpad = AvARRAY($curpad_sym);",
1897                "GvHV(PL_incgv) = $inc_hv;",
1898                "GvAV(PL_incgv) = $inc_av;",
1899                "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1900                "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1901                 "PL_amagic_generation= $amagic_generate;" );
1902 }
1903
1904 sub descend_marked_unused {
1905     foreach my $pack (keys %unused_sub_packages)
1906     {
1907         mark_package($pack);
1908     }
1909 }
1910
1911 sub save_main {
1912     # this is mainly for the test suite
1913     my $warner = $SIG{__WARN__};
1914     local $SIG{__WARN__} = sub { print STDERR @_ };
1915
1916     warn "Starting compile\n";
1917     warn "Walking tree\n";
1918     seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1919     walkoptree(main_root, "save");
1920     warn "done main optree, walking symtable for extras\n" if $debug_cv;
1921     save_unused_subs();
1922     # XSLoader was used, force saving of XSLoader::load
1923     if( $use_xsloader ) {
1924         my $cv = svref_2object( \&XSLoader::load );
1925         $cv->save;
1926     }
1927     # save %SIG ( in case it was set in a BEGIN block )
1928     if( $save_sig ) {
1929         local $SIG{__WARN__} = $warner;
1930         $init->no_split;
1931         $init->add("{", "\tHV* hv = get_hv(\"main::SIG\",1);" );
1932         foreach my $k ( keys %SIG ) {
1933             next unless ref $SIG{$k};
1934             my $cv = svref_2object( \$SIG{$k} );
1935             my $sv = $cv->save;
1936             $init->add('{',sprintf 'SV* sv = (SV*)%s;', $sv );
1937             $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
1938                                cstring($k),length(pack "a*",$k),
1939                                'sv', hash($k)));
1940             $init->add('mg_set(sv);','}');
1941         }
1942         $init->add('}');
1943         $init->split;
1944     }
1945     # honour -w
1946     $init->add( sprintf "    PL_dowarn = ( %s ) ? G_WARN_ON : G_WARN_OFF;", $^W );
1947     #
1948     my $init_av = init_av->save;
1949     my $end_av = end_av->save;
1950     $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1951                sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1952               "PL_initav = (AV *) $init_av;",
1953               "PL_endav = (AV*) $end_av;");
1954     save_context();
1955     # init op addrs ( must be the last action, otherwise
1956     # some ops might not be initialized
1957     if( $optimize_ppaddr ) {
1958         foreach my $i ( @op_sections ) {
1959             my $section = $$i;
1960             next unless $section->index >= 0;
1961             init_op_addr( $section->name, $section->index + 1);
1962         }
1963     }
1964     init_op_warn( $copsect->name, $copsect->index + 1)
1965       if $optimize_warn_sv && $copsect->index >= 0;
1966
1967     warn "Writing output\n";
1968     output_boilerplate();
1969     print "\n";
1970     output_all("perl_init");
1971     print "\n";
1972     output_main();
1973 }
1974
1975 sub init_sections {
1976     my @sections = (decl => \$decl, sym => \$symsect,
1977                     binop => \$binopsect, condop => \$condopsect,
1978                     cop => \$copsect, padop => \$padopsect,
1979                     listop => \$listopsect, logop => \$logopsect,
1980                     loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1981                     pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1982                     sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1983                     xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1984                     xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1985                     xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1986                     xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1987                     xpvio => \$xpviosect);
1988     my ($name, $sectref);
1989     while (($name, $sectref) = splice(@sections, 0, 2)) {
1990         $$sectref = new B::C::Section $name, \%symtable, 0;
1991     }
1992     $init = new B::C::InitSection 'init', \%symtable, 0;
1993 }
1994
1995 sub mark_unused
1996 {
1997  my ($arg,$val) = @_;
1998  $unused_sub_packages{$arg} = $val;
1999 }
2000
2001 sub compile {
2002     my @options = @_;
2003     my ($option, $opt, $arg);
2004     my @eval_at_startup;
2005     my %option_map = ( 'cog' => \$pv_copy_on_grow,
2006                        'save-data' => \$save_data_fh,
2007                        'ppaddr' => \$optimize_ppaddr,
2008                        'warn-sv' => \$optimize_warn_sv,
2009                        'use-script-name' => \$use_perl_script_name,
2010                        'save-sig-hash' => \$save_sig,
2011                      );
2012     my %optimization_map = ( 0 => [ qw() ], # special case
2013                              1 => [ qw(-fcog) ],
2014                              2 => [ qw(-fwarn-sv -fppaddr) ],
2015                            );
2016   OPTION:
2017     while ($option = shift @options) {
2018         if ($option =~ /^-(.)(.*)/) {
2019             $opt = $1;
2020             $arg = $2;
2021         } else {
2022             unshift @options, $option;
2023             last OPTION;
2024         }
2025         if ($opt eq "-" && $arg eq "-") {
2026             shift @options;
2027             last OPTION;
2028         }
2029         if ($opt eq "w") {
2030             $warn_undefined_syms = 1;
2031         } elsif ($opt eq "D") {
2032             $arg ||= shift @options;
2033             foreach $arg (split(//, $arg)) {
2034                 if ($arg eq "o") {
2035                     B->debug(1);
2036                 } elsif ($arg eq "c") {
2037                     $debug_cops = 1;
2038                 } elsif ($arg eq "A") {
2039                     $debug_av = 1;
2040                 } elsif ($arg eq "C") {
2041                     $debug_cv = 1;
2042                 } elsif ($arg eq "M") {
2043                     $debug_mg = 1;
2044                 } else {
2045                     warn "ignoring unknown debug option: $arg\n";
2046                 }
2047             }
2048         } elsif ($opt eq "o") {
2049             $arg ||= shift @options;
2050             open(STDOUT, ">$arg") or return "$arg: $!\n";
2051         } elsif ($opt eq "v") {
2052             $verbose = 1;
2053         } elsif ($opt eq "u") {
2054             $arg ||= shift @options;
2055             mark_unused($arg,undef);
2056         } elsif ($opt eq "f") {
2057             $arg ||= shift @options;
2058             $arg =~ m/(no-)?(.*)/;
2059             my $no = defined($1) && $1 eq 'no-';
2060             $arg = $no ? $2 : $arg;
2061             if( exists $option_map{$arg} ) {
2062                 ${$option_map{$arg}} = !$no;
2063             } else {
2064                 die "Invalid optimization '$arg'";
2065             }
2066         } elsif ($opt eq "O") {
2067             $arg = 1 if $arg eq "";
2068             my @opt;
2069             foreach my $i ( 1 .. $arg ) {
2070                 push @opt, @{$optimization_map{$i}}
2071                     if exists $optimization_map{$i};
2072             }
2073             unshift @options, @opt;
2074         } elsif ($opt eq "e") {
2075             push @eval_at_startup, $arg;
2076         } elsif ($opt eq "l") {
2077             $max_string_len = $arg;
2078         }
2079     }
2080     init_sections();
2081     foreach my $i ( @eval_at_startup ) {
2082         $init->add_eval( $i );
2083     }
2084     if (@options) {
2085         return sub {
2086             my $objname;
2087             foreach $objname (@options) {
2088                 eval "save_object(\\$objname)";
2089             }
2090             output_all();
2091         }
2092     } else {
2093         return sub { save_main() };
2094     }
2095 }
2096
2097 1;
2098
2099 __END__
2100
2101 =head1 NAME
2102
2103 B::C - Perl compiler's C backend
2104
2105 =head1 SYNOPSIS
2106
2107         perl -MO=C[,OPTIONS] foo.pl
2108
2109 =head1 DESCRIPTION
2110
2111 This compiler backend takes Perl source and generates C source code
2112 corresponding to the internal structures that perl uses to run
2113 your program. When the generated C source is compiled and run, it
2114 cuts out the time which perl would have taken to load and parse
2115 your program into its internal semi-compiled form. That means that
2116 compiling with this backend will not help improve the runtime
2117 execution speed of your program but may improve the start-up time.
2118 Depending on the environment in which your program runs this may be
2119 either a help or a hindrance.
2120
2121 =head1 OPTIONS
2122
2123 If there are any non-option arguments, they are taken to be
2124 names of objects to be saved (probably doesn't work properly yet).
2125 Without extra arguments, it saves the main program.
2126
2127 =over 4
2128
2129 =item B<-ofilename>
2130
2131 Output to filename instead of STDOUT
2132
2133 =item B<-v>
2134
2135 Verbose compilation (currently gives a few compilation statistics).
2136
2137 =item B<-->
2138
2139 Force end of options
2140
2141 =item B<-uPackname>
2142
2143 Force apparently unused subs from package Packname to be compiled.
2144 This allows programs to use eval "foo()" even when sub foo is never
2145 seen to be used at compile time. The down side is that any subs which
2146 really are never used also have code generated. This option is
2147 necessary, for example, if you have a signal handler foo which you
2148 initialise with C<$SIG{BAR} = "foo">.  A better fix, though, is just
2149 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
2150 options. The compiler tries to figure out which packages may possibly
2151 have subs in which need compiling but the current version doesn't do
2152 it very well. In particular, it is confused by nested packages (i.e.
2153 of the form C<A::B>) where package C<A> does not contain any subs.
2154
2155 =item B<-D>
2156
2157 Debug options (concatenated or separate flags like C<perl -D>).
2158
2159 =item B<-Do>
2160
2161 OPs, prints each OP as it's processed
2162
2163 =item B<-Dc>
2164
2165 COPs, prints COPs as processed (incl. file & line num)
2166
2167 =item B<-DA>
2168
2169 prints AV information on saving
2170
2171 =item B<-DC>
2172
2173 prints CV information on saving
2174
2175 =item B<-DM>
2176
2177 prints MAGIC information on saving
2178
2179 =item B<-f>
2180
2181 Force options/optimisations on or off one at a time. You can explicitly
2182 disable an option using B<-fno-option>. All options default to
2183 B<disabled>.
2184
2185 =over 4
2186
2187 =item B<-fcog>
2188
2189 Copy-on-grow: PVs declared and initialised statically.
2190
2191 =item B<-fsave-data>
2192
2193 Save package::DATA filehandles ( only available with PerlIO ).
2194
2195 =item B<-fppaddr>
2196
2197 Optimize the initialization of op_ppaddr.
2198
2199 =item B<-fwarn-sv>
2200
2201 Optimize the initialization of cop_warnings.
2202
2203 =item B<-fuse-script-name>
2204
2205 Use the script name instead of the program name as $0.
2206
2207 =item B<-fsave-sig-hash>
2208
2209 Save compile-time modifications to the %SIG hash.
2210
2211 =back
2212
2213 =item B<-On>
2214
2215 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
2216
2217 =over 4
2218
2219 =item B<-O0>
2220
2221 Disable all optimizations.
2222
2223 =item B<-O1>
2224
2225 Enable B<-fcog>.
2226
2227 =item B<-O2>
2228
2229 Enable B<-fppaddr>, B<-fwarn-sv>.
2230
2231 =back
2232
2233 =item B<-llimit>
2234
2235 Some C compilers impose an arbitrary limit on the length of string
2236 constants (e.g. 2048 characters for Microsoft Visual C++).  The
2237 B<-llimit> options tells the C backend not to generate string literals
2238 exceeding that limit.
2239
2240 =back
2241
2242 =head1 EXAMPLES
2243
2244     perl -MO=C,-ofoo.c foo.pl
2245     perl cc_harness -o foo foo.c
2246
2247 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
2248 library directory. The utility called C<perlcc> may also be used to
2249 help make use of this compiler.
2250
2251     perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null
2252
2253 =head1 BUGS
2254
2255 Plenty. Current status: experimental.
2256
2257 =head1 AUTHOR
2258
2259 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
2260
2261 =cut