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