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