home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _0a8d5b2f86bfb1faf9438f95daa34254 < prev    next >
Text File  |  2000-03-15  |  51KB  |  1,660 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. package B::C::Section;
  9. use B ();
  10. use base B::Section;
  11.  
  12. sub new
  13. {
  14.  my $class = shift;
  15.  my $o = $class->SUPER::new(@_);
  16.  push(@$o,[]);
  17.  return $o;
  18. }
  19.  
  20. sub add
  21. {  
  22.  my $section = shift;
  23.  push(@{$section->[-1]},@_);
  24. }
  25.  
  26. sub index
  27. {  
  28.  my $section = shift;
  29.  return scalar(@{$section->[-1]})-1;
  30. }
  31.  
  32. sub output
  33. {   
  34.  my ($section, $fh, $format) = @_;
  35.  my $sym = $section->symtable || {};
  36.  my $default = $section->default;
  37.  foreach (@{$section->[-1]})
  38.   {
  39.    s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
  40.    printf $fh $format, $_;
  41.   }
  42. }
  43.  
  44. package B::C;
  45. use Exporter ();
  46. @ISA = qw(Exporter);
  47. @EXPORT_OK = qw(output_all output_boilerplate output_main mark_unused
  48.         init_sections set_callback save_unused_subs objsym save_context);
  49.  
  50. use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop
  51.      class cstring cchar svref_2object compile_stats comppadlist hash
  52.      threadsv_names main_cv init_av opnumber amagic_generation
  53.      AVf_REAL HEf_SVKEY);
  54. use B::Asmdata qw(@specialsv_name);
  55.  
  56. use FileHandle;
  57. use Carp;
  58. use strict;
  59. use Config;
  60.  
  61. my $hv_index = 0;
  62. my $gv_index = 0;
  63. my $re_index = 0;
  64. my $pv_index = 0;
  65. my $anonsub_index = 0;
  66. my $initsub_index = 0;
  67.  
  68. my %symtable;
  69. my %xsub;
  70. my $warn_undefined_syms;
  71. my $verbose;
  72. my %unused_sub_packages;
  73. my $nullop_count;
  74. my $pv_copy_on_grow = 0;
  75. my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
  76. my $max_string_len;
  77.  
  78. my @threadsv_names;
  79. BEGIN {
  80.     @threadsv_names = threadsv_names();
  81. }
  82.  
  83. # Code sections
  84. my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, 
  85.     $padopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
  86.     $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
  87.     $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
  88.     $xrvsect, $xpvbmsect, $xpviosect );
  89.  
  90. sub walk_and_save_optree;
  91. my $saveoptree_callback = \&walk_and_save_optree;
  92. sub set_callback { $saveoptree_callback = shift }
  93. sub saveoptree { &$saveoptree_callback(@_) }
  94.  
  95. sub walk_and_save_optree {
  96.     my ($name, $root, $start) = @_;
  97.     walkoptree($root, "save");
  98.     return objsym($start);
  99. }
  100.  
  101. # Current workaround/fix for op_free() trying to free statically
  102. # defined OPs is to set op_seq = -1 and check for that in op_free().
  103. # Instead of hardwiring -1 in place of $op->seq, we use $op_seq
  104. # so that it can be changed back easily if necessary. In fact, to
  105. # stop compilers from moaning about a U16 being initialised with an
  106. # uncast -1 (the printf format is %d so we can't tweak it), we have
  107. # to "know" that op_seq is a U16 and use 65535. Ugh.
  108. my $op_seq = 65535;
  109.  
  110. # Look this up here so we can do just a number compare
  111. # rather than looking up the name of every BASEOP in B::OP
  112. my $OP_THREADSV = opnumber('threadsv');
  113.  
  114. sub savesym {
  115.     my ($obj, $value) = @_;
  116.     my $sym = sprintf("s\\_%x", $$obj);
  117.     $symtable{$sym} = $value;
  118. }
  119.  
  120. sub objsym {
  121.     my $obj = shift;
  122.     return $symtable{sprintf("s\\_%x", $$obj)};
  123. }
  124.  
  125. sub getsym {
  126.     my $sym = shift;
  127.     my $value;
  128.  
  129.     return 0 if $sym eq "sym_0";    # special case
  130.     $value = $symtable{$sym};
  131.     if (defined($value)) {
  132.     return $value;
  133.     } else {
  134.     warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
  135.     return "UNUSED";
  136.     }
  137. }
  138.  
  139. sub savepv {
  140.     my $pv = shift;         
  141.     $pv    = '' unless defined $pv;  # Is this sane ?
  142.     my $pvsym = 0;
  143.     my $pvmax = 0;
  144.     if ($pv_copy_on_grow) { 
  145.     my $cstring = cstring($pv);
  146.     if ($cstring ne "0") { # sic
  147.         $pvsym = sprintf("pv%d", $pv_index++);
  148.         $decl->add(sprintf("static char %s[] = %s;", $pvsym, $cstring));
  149.     }
  150.     } else {
  151.     $pvmax = length($pv) + 1;
  152.     }
  153.     return ($pvsym, $pvmax);
  154. }
  155.  
  156. sub B::OP::save {
  157.     my ($op, $level) = @_;
  158.     my $sym = objsym($op);
  159.     return $sym if defined $sym;
  160.     my $type = $op->type;
  161.     $nullop_count++ unless $type;
  162.     if ($type == $OP_THREADSV) {
  163.     # saves looking up ppaddr but it's a bit naughty to hard code this
  164.     $init->add(sprintf("(void)find_threadsv(%s);",
  165.                cstring($threadsv_names[$op->targ])));
  166.     }
  167.     $opsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x",
  168.              ${$op->next}, ${$op->sibling}, $op->targ,
  169.              $type, $op_seq, $op->flags, $op->private));
  170.     my $ix = $opsect->index;
  171.     $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr));
  172.     savesym($op, "&op_list[$ix]");
  173. }
  174.  
  175. sub B::FAKEOP::new {
  176.     my ($class, %objdata) = @_;
  177.     bless \%objdata, $class;
  178. }
  179.  
  180. sub B::FAKEOP::save {
  181.     my ($op, $level) = @_;
  182.     $opsect->add(sprintf("%s, %s, NULL, %u, %u, %u, 0x%x, 0x%x",
  183.              $op->next, $op->sibling, $op->targ,
  184.              $op->type, $op_seq, $op->flags, $op->private));
  185.     my $ix = $opsect->index;
  186.     $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr));
  187.     return "&op_list[$ix]";
  188. }
  189.  
  190. sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
  191. sub B::FAKEOP::type { $_[0]->{type} || 0}
  192. sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
  193. sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
  194. sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
  195. sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
  196. sub B::FAKEOP::private { $_[0]->{private} || 0 }
  197.  
  198. sub B::UNOP::save {
  199.     my ($op, $level) = @_;
  200.     my $sym = objsym($op);
  201.     return $sym if defined $sym;
  202.     $unopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x",
  203.                ${$op->next}, ${$op->sibling},
  204.                $op->targ, $op->type, $op_seq, $op->flags,
  205.                $op->private, ${$op->first}));
  206.     my $ix = $unopsect->index;
  207.     $init->add(sprintf("unop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
  208.     savesym($op, "(OP*)&unop_list[$ix]");
  209. }
  210.  
  211. sub B::BINOP::save {
  212.     my ($op, $level) = @_;
  213.     my $sym = objsym($op);
  214.     return $sym if defined $sym;
  215.     $binopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
  216.                 ${$op->next}, ${$op->sibling},
  217.                 $op->targ, $op->type, $op_seq, $op->flags,
  218.                 $op->private, ${$op->first}, ${$op->last}));
  219.     my $ix = $binopsect->index;
  220.     $init->add(sprintf("binop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
  221.     savesym($op, "(OP*)&binop_list[$ix]");
  222. }
  223.  
  224. sub B::LISTOP::save {
  225.     my ($op, $level) = @_;
  226.     my $sym = objsym($op);
  227.     return $sym if defined $sym;
  228.     $listopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u",
  229.                  ${$op->next}, ${$op->sibling},
  230.                  $op->targ, $op->type, $op_seq, $op->flags,
  231.                  $op->private, ${$op->first}, ${$op->last},
  232.                  $op->children));
  233.     my $ix = $listopsect->index;
  234.     $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
  235.     savesym($op, "(OP*)&listop_list[$ix]");
  236. }
  237.  
  238. sub B::LOGOP::save {
  239.     my ($op, $level) = @_;
  240.     my $sym = objsym($op);
  241.     return $sym if defined $sym;
  242.     $logopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
  243.                 ${$op->next}, ${$op->sibling},
  244.                 $op->targ, $op->type, $op_seq, $op->flags,
  245.                 $op->private, ${$op->first}, ${$op->other}));
  246.     my $ix = $logopsect->index;
  247.     $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
  248.     savesym($op, "(OP*)&logop_list[$ix]");
  249. }
  250.  
  251. sub B::LOOP::save {
  252.     my ($op, $level) = @_;
  253.     my $sym = objsym($op);
  254.     return $sym if defined $sym;
  255.     #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
  256.     #         peekop($op->redoop), peekop($op->nextop),
  257.     #         peekop($op->lastop)); # debug
  258.     $loopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, s\\_%x, s\\_%x, s\\_%x",
  259.                ${$op->next}, ${$op->sibling},
  260.                $op->targ, $op->type, $op_seq, $op->flags,
  261.                $op->private, ${$op->first}, ${$op->last},
  262.                $op->children, ${$op->redoop}, ${$op->nextop},
  263.                ${$op->lastop}));
  264.     my $ix = $loopsect->index;
  265.     $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
  266.     savesym($op, "(OP*)&loop_list[$ix]");
  267. }
  268.  
  269. sub B::PVOP::save {
  270.     my ($op, $level) = @_;
  271.     my $sym = objsym($op);
  272.     return $sym if defined $sym;
  273.     $pvopsect->add(sprintf("s\\_%x, s\\_%x, NULL,  %u, %u, %u, 0x%x, 0x%x, %s",
  274.                ${$op->next}, ${$op->sibling},
  275.                $op->targ, $op->type, $op_seq, $op->flags,
  276.                $op->private, cstring($op->pv)));
  277.     my $ix = $pvopsect->index;
  278.     $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
  279.     savesym($op, "(OP*)&pvop_list[$ix]");
  280. }
  281.  
  282. sub B::SVOP::save {
  283.     my ($op, $level) = @_;
  284.     my $sym = objsym($op);
  285.     return $sym if defined $sym;
  286.     my $svsym = $op->sv->save;
  287.     $svopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, Nullsv",
  288.                ${$op->next}, ${$op->sibling},
  289.                $op->targ, $op->type, $op_seq, $op->flags,
  290.                $op->private));
  291.     my $ix = $svopsect->index;
  292.     $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
  293.     $init->add("svop_list[$ix].op_sv = (SV*)$svsym;");
  294.     savesym($op, "(OP*)&svop_list[$ix]");
  295. }
  296.  
  297. sub B::PADOP::save {
  298.     my ($op, $level) = @_;
  299.     my $sym = objsym($op);
  300.     return $sym if defined $sym;
  301.     $padopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, 0",
  302.                ${$op->next}, ${$op->sibling},
  303.                $op->targ, $op->type, $op_seq, $op->flags,
  304.                $op->private));
  305.     $init->add(sprintf("padop_list[%d].op_ppaddr = %s;", $padopsect->index, $op->ppaddr));
  306.     my $ix = $padopsect->index;
  307.     $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix));
  308.     savesym($op, "(OP*)&padop_list[$ix]");
  309. }
  310.  
  311. sub B::COP::save {
  312.     my ($op, $level) = @_;
  313.     my $sym = objsym($op);
  314.     return $sym if defined $sym;
  315.     warn sprintf("COP: line %d file %s\n", $op->line, $op->file)
  316.     if $debug_cops;
  317.     $copsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, %s, NULL, NULL, %u, %d, %u",
  318.               ${$op->next}, ${$op->sibling},
  319.               $op->targ, $op->type, $op_seq, $op->flags,
  320.               $op->private, cstring($op->label), $op->cop_seq,
  321.               $op->arybase, $op->line));
  322.     my $ix = $copsect->index;
  323.     $init->add(sprintf("cop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
  324.     $init->add(sprintf("CopFILE_set(&cop_list[$ix], %s);", cstring($op->file)),
  325.            sprintf("CopSTASHPV_set(&cop_list[$ix], %s);", cstring($op->stashpv)));
  326.     savesym($op, "(OP*)&cop_list[$ix]");
  327. }
  328.  
  329. sub B::PMOP::save {
  330.     my ($op, $level) = @_;
  331.     my $sym = objsym($op);
  332.     return $sym if defined $sym;
  333.     my $replroot = $op->pmreplroot;
  334.     my $replstart = $op->pmreplstart;
  335.     my $replrootfield = sprintf("s\\_%x", $$replroot);
  336.     my $replstartfield = sprintf("s\\_%x", $$replstart);
  337.     my $gvsym;
  338.     my $ppaddr = $op->ppaddr;
  339.     if ($$replroot) {
  340.     # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
  341.     # argument to a split) stores a GV in op_pmreplroot instead
  342.     # of a substitution syntax tree. We don't want to walk that...
  343.     if ($op->name eq "pushre") {
  344.         $gvsym = $replroot->save;
  345. #        warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
  346.         $replrootfield = 0;
  347.     } else {
  348.         $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
  349.     }
  350.     }
  351.     # pmnext handling is broken in perl itself, I think. Bad op_pmnext
  352.     # fields aren't noticed in perl's runtime (unless you try reset) but we
  353.     # segfault when trying to dereference it to find op->op_pmnext->op_type
  354.     $pmopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, %s, %s, 0, 0, 0x%x, 0x%x",
  355.                ${$op->next}, ${$op->sibling}, $op->targ,
  356.                $op->type, $op_seq, $op->flags, $op->private,
  357.                ${$op->first}, ${$op->last}, $op->children,
  358.                $replrootfield, $replstartfield,
  359.                $op->pmflags, $op->pmpermflags,));
  360.     my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
  361.     $init->add(sprintf("$pm.op_ppaddr = %s;", $ppaddr));
  362.     my $re = $op->precomp;
  363.     if (defined($re)) {
  364.     my $resym = sprintf("re%d", $re_index++);
  365.     $decl->add(sprintf("static char *$resym = %s;", cstring($re)));
  366.     $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
  367.                length($re)));
  368.     }
  369.     if ($gvsym) {
  370.     $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
  371.     }
  372.     savesym($op, "(OP*)&$pm");
  373. }
  374.  
  375. sub B::SPECIAL::save {
  376.     my ($sv) = @_;
  377.     # special case: $$sv is not the address but an index into specialsv_list
  378. #   warn "SPECIAL::save specialsv $$sv\n"; # debug
  379.     my $sym = $specialsv_name[$$sv];
  380.     if (!defined($sym)) {
  381.     confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
  382.     }
  383.     return $sym;
  384. }
  385.  
  386. sub B::OBJECT::save {}
  387.  
  388. sub B::NULL::save {
  389.     my ($sv) = @_;
  390.     my $sym = objsym($sv);
  391.     return $sym if defined $sym;
  392. #   warn "Saving SVt_NULL SV\n"; # debug
  393.     # debug
  394.     if ($$sv == 0) {
  395.         warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
  396.     return savesym($sv, "Nullsv /* XXX */");
  397.     }
  398.     $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS));
  399.     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
  400. }
  401.  
  402. sub B::IV::save {
  403.     my ($sv) = @_;
  404.     my $sym = objsym($sv);
  405.     return $sym if defined $sym;
  406.     $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
  407.     $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
  408.              $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
  409.     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
  410. }
  411.  
  412. sub B::NV::save {
  413.     my ($sv) = @_;
  414.     my $sym = objsym($sv);
  415.     return $sym if defined $sym;
  416.     my $val= $sv->NVX;
  417.     $val .= '.00' if $val =~ /^-?\d+$/;
  418.     $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
  419.     $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
  420.              $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
  421.     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
  422. }
  423.  
  424. sub savepvn {
  425.     my ($dest,$pv) = @_;
  426.     my @res;
  427.     if (defined $max_string_len && length($pv) > $max_string_len) {
  428.     push @res, sprintf("New(0,%s,%u,char);", $dest, length($pv)+1);
  429.     my $offset = 0;
  430.     while (length $pv) {
  431.         my $str = substr $pv, 0, $max_string_len, '';
  432.         push @res, sprintf("Copy(%s,$dest+$offset,%u,char);",
  433.                    cstring($str), length($str));
  434.         $offset += length $str;
  435.     }
  436.     push @res, sprintf("%s[%u] = '\\0';", $dest, $offset);
  437.     }
  438.     else {
  439.     push @res, sprintf("%s = savepvn(%s, %u);", $dest,
  440.                cstring($pv), length($pv));
  441.     }
  442.     return @res;
  443. }
  444.  
  445. sub B::PVLV::save {
  446.     my ($sv) = @_;
  447.     my $sym = objsym($sv);
  448.     return $sym if defined $sym;
  449.     my $pv = $sv->PV;
  450.     my $len = length($pv);
  451.     my ($pvsym, $pvmax) = savepv($pv);
  452.     my ($lvtarg, $lvtarg_sym);
  453.     $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
  454.                 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX, 
  455.                 $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
  456.     $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
  457.              $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS));
  458.     if (!$pv_copy_on_grow) {
  459.     $init->add(savepvn(sprintf("xpvlv_list[%d].xpv_pv",
  460.                    $xpvlvsect->index), $pv));
  461.     }
  462.     $sv->save_magic;
  463.     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
  464. }
  465.  
  466. sub B::PVIV::save {
  467.     my ($sv) = @_;
  468.     my $sym = objsym($sv);
  469.     return $sym if defined $sym;
  470.     my $pv = $sv->PV;
  471.     my $len = length($pv);
  472.     my ($pvsym, $pvmax) = savepv($pv);
  473.     $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
  474.     $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
  475.              $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
  476.     if (!$pv_copy_on_grow) {
  477.     $init->add(savepvn(sprintf("xpviv_list[%d].xpv_pv",
  478.                    $xpvivsect->index), $pv));
  479.     }
  480.     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
  481. }
  482.  
  483. sub B::PVNV::save {
  484.     my ($sv) = @_;
  485.     my $sym = objsym($sv);
  486.     return $sym if defined $sym;
  487.     my $pv = $sv->PV;     
  488.     $pv = '' unless defined $pv;
  489.     my $len = length($pv);
  490.     my ($pvsym, $pvmax) = savepv($pv);
  491.     my $val= $sv->NVX;
  492.     $val .= '.00' if $val =~ /^-?\d+$/;
  493.     $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
  494.                 $pvsym, $len, $pvmax, $sv->IVX, $val));
  495.     $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
  496.              $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
  497.     if (!$pv_copy_on_grow) {
  498.     $init->add(savepvn(sprintf("xpvnv_list[%d].xpv_pv",
  499.                    $xpvnvsect->index), $pv));
  500.     }
  501.     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
  502. }
  503.  
  504. sub B::BM::save {
  505.     my ($sv) = @_;
  506.     my $sym = objsym($sv);
  507.     return $sym if defined $sym;
  508.     my $pv = $sv->PV . "\0" . $sv->TABLE;
  509.     my $len = length($pv);
  510.     $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
  511.                 $len, $len + 258, $sv->IVX, $sv->NVX,
  512.                 $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
  513.     $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
  514.              $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS));
  515.     $sv->save_magic;
  516.     $init->add(savepvn(sprintf("xpvbm_list[%d].xpv_pv",
  517.                    $xpvbmsect->index), $pv),
  518.            sprintf("xpvbm_list[%d].xpv_cur = %u;",
  519.                $xpvbmsect->index, $len - 257));
  520.     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
  521. }
  522.  
  523. sub B::PV::save {
  524.     my ($sv) = @_;
  525.     my $sym = objsym($sv);
  526.     return $sym if defined $sym;
  527.     my $pv = $sv->PV;
  528.     my $len = length($pv);
  529.     my ($pvsym, $pvmax) = savepv($pv);
  530.     $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
  531.     $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
  532.              $xpvsect->index, $sv->REFCNT , $sv->FLAGS));
  533.     if (!$pv_copy_on_grow) {
  534.     $init->add(savepvn(sprintf("xpv_list[%d].xpv_pv",
  535.                    $xpvsect->index), $pv));
  536.     }
  537.     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
  538. }
  539.  
  540. sub B::PVMG::save {
  541.     my ($sv) = @_;
  542.     my $sym = objsym($sv);
  543.     return $sym if defined $sym;
  544.     my $pv = $sv->PV;
  545.     my $len = length($pv);
  546.     my ($pvsym, $pvmax) = savepv($pv);
  547.     $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
  548.                 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
  549.     $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
  550.              $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS));
  551.     if (!$pv_copy_on_grow) {
  552.     $init->add(savepvn(sprintf("xpvmg_list[%d].xpv_pv",
  553.                    $xpvmgsect->index), $pv));
  554.     }
  555.     $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
  556.     $sv->save_magic;
  557.     return $sym;
  558. }
  559.  
  560. sub B::PVMG::save_magic {
  561.     my ($sv) = @_;
  562.     #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
  563.     my $stash = $sv->SvSTASH;
  564.     $stash->save;
  565.     if ($$stash) {
  566.     warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
  567.         if $debug_mg;
  568.     # XXX Hope stash is already going to be saved.
  569.     $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
  570.     }
  571.     my @mgchain = $sv->MAGIC;
  572.     my ($mg, $type, $obj, $ptr,$len,$ptrsv);
  573.     foreach $mg (@mgchain) {
  574.     $type = $mg->TYPE;
  575.     $obj = $mg->OBJ;
  576.     $ptr = $mg->PTR;
  577.     $len=$mg->LENGTH;
  578.     if ($debug_mg) {
  579.         warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
  580.              class($sv), $$sv, class($obj), $$obj,
  581.              cchar($type), cstring($ptr));
  582.     }
  583.     $obj->save;
  584.     if ($len == HEf_SVKEY){
  585.         #The pointer is an SV*
  586.         $ptrsv=svref_2object($ptr)->save;
  587.         $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
  588.                $$sv, $$obj, cchar($type),$ptrsv,$len));
  589.     }else{
  590.         $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
  591.                $$sv, $$obj, cchar($type),cstring($ptr),$len));
  592.     }
  593.     }
  594. }
  595.  
  596. sub B::RV::save {
  597.     my ($sv) = @_;
  598.     my $sym = objsym($sv);
  599.     return $sym if defined $sym;
  600.     my $rv = $sv->RV->save;
  601.     $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/;
  602.     $xrvsect->add($rv);
  603.     $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
  604.              $xrvsect->index, $sv->REFCNT , $sv->FLAGS));
  605.     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
  606. }
  607.  
  608. sub try_autoload {
  609.     my ($cvstashname, $cvname) = @_;
  610.     warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
  611.     # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
  612.     # use should be handled by the class itself.
  613.     no strict 'refs';
  614.     my $isa = \@{"$cvstashname\::ISA"};
  615.     if (grep($_ eq "AutoLoader", @$isa)) {
  616.     warn "Forcing immediate load of sub derived from AutoLoader\n";
  617.     # Tweaked version of AutoLoader::AUTOLOAD
  618.     my $dir = $cvstashname;
  619.     $dir =~ s(::)(/)g;
  620.     eval { require "auto/$dir/$cvname.al" };
  621.     if ($@) {
  622.         warn qq(failed require "auto/$dir/$cvname.al": $@\n);
  623.         return 0;
  624.     } else {
  625.         return 1;
  626.     }
  627.     }
  628. }
  629. sub Dummy_initxs{};
  630. sub B::CV::save {
  631.     my ($cv) = @_;
  632.     my $sym = objsym($cv);
  633.     if (defined($sym)) {
  634. #    warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
  635.     return $sym;
  636.     }
  637.     # Reserve a place in svsect and xpvcvsect and record indices
  638.     my $gv = $cv->GV;
  639.     my ($cvname, $cvstashname);
  640.     if ($$gv){
  641.         $cvname = $gv->NAME;
  642.         $cvstashname = $gv->STASH->NAME;
  643.     }
  644.     my $root = $cv->ROOT;
  645.     my $cvxsub = $cv->XSUB;
  646.     #INIT is removed from the symbol table, so this call must come
  647.     # from PL_initav->save. Re-bootstrapping  will push INIT back in
  648.     # so nullop should be sent.
  649.     if ($cvxsub && ($cvname ne "INIT")) {
  650.     my $egv = $gv->EGV;
  651.     my $stashname = $egv->STASH->NAME;
  652.          if ($cvname eq "bootstrap")
  653.           {                                   
  654.            my $file = $gv->FILE;    
  655.            $decl->add("/* bootstrap $file */"); 
  656.            warn "Bootstrap $stashname $file\n";
  657.            $xsub{$stashname}='Dynamic'; 
  658.        # $xsub{$stashname}='Static' unless  $xsub{$stashname};
  659.            return qq/NULL/;
  660.           }                                   
  661.         warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv;
  662.     return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/;
  663.     }
  664.     if ($cvxsub && $cvname eq "INIT") {
  665.      no strict 'refs';
  666.         return svref_2object(\&Dummy_initxs)->save;
  667.     }
  668.     my $sv_ix = $svsect->index + 1;
  669.     $svsect->add("svix$sv_ix");
  670.     my $xpvcv_ix = $xpvcvsect->index + 1;
  671.     $xpvcvsect->add("xpvcvix$xpvcv_ix");
  672.     # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
  673.     $sym = savesym($cv, "&sv_list[$sv_ix]");
  674.     warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv;
  675.     if (!$$root && !$cvxsub) {
  676.     if (try_autoload($cvstashname, $cvname)) {
  677.         # Recalculate root and xsub
  678.         $root = $cv->ROOT;
  679.         $cvxsub = $cv->XSUB;
  680.         if ($$root || $cvxsub) {
  681.         warn "Successful forced autoload\n";
  682.         }
  683.     }
  684.     }
  685.     my $startfield = 0;
  686.     my $padlist = $cv->PADLIST;
  687.     my $pv = $cv->PV;
  688.     my $xsub = 0;
  689.     my $xsubany = "Nullany";
  690.     if ($$root) {
  691.     warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
  692.              $$cv, $$root) if $debug_cv;
  693.     my $ppname = "";
  694.     if ($$gv) {
  695.         my $stashname = $gv->STASH->NAME;
  696.         my $gvname = $gv->NAME;
  697.         if ($gvname ne "__ANON__") {
  698.         $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
  699.         $ppname .= ($stashname eq "main") ?
  700.                 $gvname : "$stashname\::$gvname";
  701.         $ppname =~ s/::/__/g;
  702.             if ($gvname eq "INIT"){
  703.                $ppname .= "_$initsub_index";
  704.                $initsub_index++;
  705.             }
  706.         }
  707.     }
  708.     if (!$ppname) {
  709.         $ppname = "pp_anonsub_$anonsub_index";
  710.         $anonsub_index++;
  711.     }
  712.     $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
  713.     warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
  714.              $$cv, $ppname, $$root) if $debug_cv;
  715.     if ($$padlist) {
  716.         warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
  717.              $$padlist, $$cv) if $debug_cv;
  718.         $padlist->save;
  719.         warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
  720.              $$padlist, $$cv) if $debug_cv;
  721.     }
  722.     }
  723.     else {
  724.     warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
  725.              $cvstashname, $cvname); # debug
  726.     }              
  727.     $pv = '' unless defined $pv; # Avoid use of undef warnings
  728.     $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",
  729.               $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
  730.               $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
  731.                         $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
  732.  
  733.     if (${$cv->OUTSIDE} == ${main_cv()}){
  734.     $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
  735.     $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
  736.     }
  737.  
  738.     if ($$gv) {
  739.     $gv->save;
  740.     $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
  741.     warn sprintf("done saving GV 0x%x for CV 0x%x\n",
  742.              $$gv, $$cv) if $debug_cv;
  743.     }
  744.     $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE)));
  745.     my $stash = $cv->STASH;
  746.     if ($$stash) {
  747.     $stash->save;
  748.     $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
  749.     warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
  750.              $$stash, $$cv) if $debug_cv;
  751.     }
  752.     $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
  753.               $sv_ix, $xpvcv_ix, $cv->REFCNT +1 , $cv->FLAGS));
  754.     return $sym;
  755. }
  756.  
  757. sub B::GV::save {
  758.     my ($gv) = @_;
  759.     my $sym = objsym($gv);
  760.     if (defined($sym)) {
  761.     #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
  762.     return $sym;
  763.     } else {
  764.     my $ix = $gv_index++;
  765.     $sym = savesym($gv, "gv_list[$ix]");
  766.     #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
  767.     }
  768.     my $is_empty = $gv->is_empty;
  769.     my $gvname = $gv->NAME;
  770.     my $name = cstring($gv->STASH->NAME . "::" . $gvname);
  771.     #warn "GV name is $name\n"; # debug
  772.     my $egvsym;
  773.     unless ($is_empty) {
  774.     my $egv = $gv->EGV;
  775.     if ($$gv != $$egv) {
  776.         #warn(sprintf("EGV name is %s, saving it now\n",
  777.         #         $egv->STASH->NAME . "::" . $egv->NAME)); # debug
  778.         $egvsym = $egv->save;
  779.     }
  780.     }
  781.     $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
  782.            sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
  783.            sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS));
  784.     $init->add(sprintf("GvLINE($sym) = %u;", $gv->LINE)) unless $is_empty;
  785.  
  786.     # Shouldn't need to do save_magic since gv_fetchpv handles that
  787.     #$gv->save_magic;
  788.     my $refcnt = $gv->REFCNT + 1;
  789.     $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
  790.  
  791.     return $sym if $is_empty;
  792.  
  793.     my $gvrefcnt = $gv->GvREFCNT;
  794.     if ($gvrefcnt > 1) {
  795.     $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
  796.     }
  797.     if (defined($egvsym)) {
  798.     # Shared glob *foo = *bar
  799.     $init->add("gp_free($sym);",
  800.            "GvGP($sym) = GvGP($egvsym);");
  801.     } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
  802.     # Don't save subfields of special GVs (*_, *1, *# and so on)
  803. #    warn "GV::save saving subfields\n"; # debug
  804.     my $gvsv = $gv->SV;
  805.     if ($$gvsv) {
  806.         $gvsv->save;
  807.         $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
  808. #        warn "GV::save \$$name\n"; # debug
  809.     }
  810.     my $gvav = $gv->AV;
  811.     if ($$gvav) {
  812.         $gvav->save;
  813.         $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
  814. #        warn "GV::save \@$name\n"; # debug
  815.     }
  816.     my $gvhv = $gv->HV;
  817.     if ($$gvhv) {
  818.         $gvhv->save;
  819.         $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
  820. #        warn "GV::save \%$name\n"; # debug
  821.     }
  822.     my $gvcv = $gv->CV;
  823.     if ($$gvcv) { 
  824.         my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
  825.          "::" . $gvcv->GV->EGV->NAME);  
  826.         if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias
  827.             # must save as a 'stub' so newXS() has a CV to populate
  828.                 $init->add("{ CV *cv;");
  829.                 $init->add("\tcv=perl_get_cv($origname,TRUE);");
  830.                 $init->add("\tGvCV($sym)=cv;");
  831.                 $init->add("\tSvREFCNT_inc((SV *)cv);");
  832.                 $init->add("}");    
  833.         } else {     
  834.                $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
  835. #              warn "GV::save &$name\n"; # debug
  836.         } 
  837.         }     
  838.     $init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE)));
  839. #    warn "GV::save GvFILE(*$name)\n"; # debug
  840.     my $gvform = $gv->FORM;
  841.     if ($$gvform) {
  842.         $gvform->save;
  843.         $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
  844. #        warn "GV::save GvFORM(*$name)\n"; # debug
  845.     }
  846.     my $gvio = $gv->IO;
  847.     if ($$gvio) {
  848.         $gvio->save;
  849.         $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
  850. #        warn "GV::save GvIO(*$name)\n"; # debug
  851.     }
  852.     }
  853.     return $sym;
  854. }
  855. sub B::AV::save {
  856.     my ($av) = @_;
  857.     my $sym = objsym($av);
  858.     return $sym if defined $sym;
  859.     my $avflags = $av->AvFLAGS;
  860.     $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
  861.                 $avflags));
  862.     $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
  863.              $xpvavsect->index, $av->REFCNT  , $av->FLAGS));
  864.     my $sv_list_index = $svsect->index;
  865.     my $fill = $av->FILL;
  866.     $av->save_magic;
  867.     warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
  868.     if $debug_av;
  869.     # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
  870.     #if ($fill > -1 && ($avflags & AVf_REAL)) {
  871.     if ($fill > -1) {
  872.     my @array = $av->ARRAY;
  873.     if ($debug_av) {
  874.         my $el;
  875.         my $i = 0;
  876.         foreach $el (@array) {
  877.         warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
  878.                  $$av, $i++, class($el), $$el);
  879.         }
  880.     }
  881.     my @names = map($_->save, @array);
  882.     # XXX Better ways to write loop?
  883.     # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
  884.     # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
  885.     $init->add("{",
  886.            "\tSV **svp;",
  887.            "\tAV *av = (AV*)&sv_list[$sv_list_index];",
  888.            "\tav_extend(av, $fill);",
  889.            "\tsvp = AvARRAY(av);",
  890.            map("\t*svp++ = (SV*)$_;", @names),
  891.            "\tAvFILLp(av) = $fill;",
  892.            "}");
  893.     } else {
  894.     my $max = $av->MAX;
  895.     $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
  896.         if $max > -1;
  897.     }
  898.     return savesym($av, "(AV*)&sv_list[$sv_list_index]");
  899. }
  900.  
  901. sub B::HV::save {
  902.     my ($hv) = @_;
  903.     my $sym = objsym($hv);
  904.     return $sym if defined $sym;
  905.     my $name = $hv->NAME;
  906.     if ($name) {
  907.     # It's a stash
  908.  
  909.     # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
  910.     # the only symptom is that sv_reset tries to reset the PMf_USED flag of
  911.     # a trashed op but we look at the trashed op_type and segfault.
  912.     #my $adpmroot = ${$hv->PMROOT};
  913.     my $adpmroot = 0;
  914.     $decl->add("static HV *hv$hv_index;");
  915.     # XXX Beware of weird package names containing double-quotes, \n, ...?
  916.     $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
  917.     if ($adpmroot) {
  918.         $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
  919.                    $adpmroot));
  920.     }
  921.     $sym = savesym($hv, "hv$hv_index");
  922.     $hv_index++;
  923.     return $sym;
  924.     }
  925.     # It's just an ordinary HV
  926.     $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
  927.                 $hv->MAX, $hv->RITER));
  928.     $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
  929.              $xpvhvsect->index, $hv->REFCNT  , $hv->FLAGS));
  930.     my $sv_list_index = $svsect->index;
  931.     my @contents = $hv->ARRAY;
  932.     if (@contents) {
  933.     my $i;
  934.     for ($i = 1; $i < @contents; $i += 2) {
  935.         $contents[$i] = $contents[$i]->save;
  936.     }
  937.     $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
  938.     while (@contents) {
  939.         my ($key, $value) = splice(@contents, 0, 2);
  940.         $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
  941.                    cstring($key),length($key),$value, hash($key)));
  942. #        $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
  943. #                   cstring($key),length($key),$value, 0));
  944.     }
  945.     $init->add("}");
  946.     }
  947.     $hv->save_magic();
  948.     return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
  949. }
  950.  
  951. sub B::IO::save {
  952.     my ($io) = @_;
  953.     my $sym = objsym($io);
  954.     return $sym if defined $sym;
  955.     my $pv = $io->PV;
  956.     $pv = '' unless defined $pv;
  957.     my $len = length($pv);
  958.     $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",
  959.                 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
  960.                 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
  961.                 cstring($io->TOP_NAME), cstring($io->FMT_NAME), 
  962.                 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
  963.                 cchar($io->IoTYPE), $io->IoFLAGS));
  964.     $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
  965.              $xpviosect->index, $io->REFCNT , $io->FLAGS));
  966.     $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
  967.     my ($field, $fsym);
  968.     foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
  969.           $fsym = $io->$field();
  970.     if ($$fsym) {
  971.         $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
  972.         $fsym->save;
  973.     }
  974.     }
  975.     $io->save_magic;
  976.     return $sym;
  977. }
  978.  
  979. sub B::SV::save {
  980.     my $sv = shift;
  981.     # This is where we catch an honest-to-goodness Nullsv (which gets
  982.     # blessed into B::SV explicitly) and any stray erroneous SVs.
  983.     return 0 unless $$sv;
  984.     confess sprintf("cannot save that type of SV: %s (0x%x)\n",
  985.             class($sv), $$sv);
  986. }
  987.  
  988. sub output_all {
  989.     my $init_name = shift;
  990.     my $section;
  991.     my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
  992.             $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect,
  993.             $loopsect, $copsect, $svsect, $xpvsect,
  994.             $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
  995.             $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
  996.     $symsect->output(\*STDOUT, "#define %s\n");
  997.     print "\n";
  998.     output_declarations();
  999.     foreach $section (@sections) {
  1000.     my $lines = $section->index + 1;
  1001.     if ($lines) {
  1002.         my $name = $section->name;
  1003.         my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
  1004.         print "Static $typename ${name}_list[$lines];\n";
  1005.     }
  1006.     }
  1007.     $decl->output(\*STDOUT, "%s\n");
  1008.     print "\n";
  1009.     foreach $section (@sections) {
  1010.     my $lines = $section->index + 1;
  1011.     if ($lines) {
  1012.         my $name = $section->name;
  1013.         my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
  1014.         printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
  1015.         $section->output(\*STDOUT, "\t{ %s },\n");
  1016.         print "};\n\n";
  1017.     }
  1018.     }
  1019.  
  1020.     print <<"EOT";
  1021. static int $init_name()
  1022. {
  1023.     dTHR;
  1024.     dTARG;
  1025.     djSP;
  1026. EOT
  1027.     $init->output(\*STDOUT, "\t%s\n");
  1028.     print "\treturn 0;\n}\n";
  1029.     if ($verbose) {
  1030.     warn compile_stats();
  1031.     warn "NULLOP count: $nullop_count\n";
  1032.     }
  1033. }
  1034.  
  1035. sub output_declarations {
  1036.     print <<'EOT';
  1037. #ifdef BROKEN_STATIC_REDECL
  1038. #define Static extern
  1039. #else
  1040. #define Static static
  1041. #endif /* BROKEN_STATIC_REDECL */
  1042.  
  1043. #ifdef BROKEN_UNION_INIT
  1044. /*
  1045.  * Cribbed from cv.h with ANY (a union) replaced by void*.
  1046.  * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
  1047.  */
  1048. typedef struct {
  1049.     char *    xpv_pv;        /* pointer to malloced string */
  1050.     STRLEN    xpv_cur;    /* length of xp_pv as a C string */
  1051.     STRLEN    xpv_len;    /* allocated size */
  1052.     IV        xof_off;    /* integer value */
  1053.     double    xnv_nv;        /* numeric value, if any */
  1054.     MAGIC*    xmg_magic;    /* magic for scalar array */
  1055.     HV*        xmg_stash;    /* class package */
  1056.  
  1057.     HV *    xcv_stash;
  1058.     OP *    xcv_start;
  1059.     OP *    xcv_root;
  1060.     void      (*xcv_xsub) (CV*);
  1061.     void *    xcv_xsubany;
  1062.     GV *    xcv_gv;
  1063.     char *    xcv_file;
  1064.     long    xcv_depth;    /* >= 2 indicates recursive call */
  1065.     AV *    xcv_padlist;
  1066.     CV *    xcv_outside;
  1067. #ifdef USE_THREADS
  1068.     perl_mutex *xcv_mutexp;
  1069.     struct perl_thread *xcv_owner;    /* current owner thread */
  1070. #endif /* USE_THREADS */
  1071.     cv_flags_t    xcv_flags;
  1072. } XPVCV_or_similar;
  1073. #define ANYINIT(i) i
  1074. #else
  1075. #define XPVCV_or_similar XPVCV
  1076. #define ANYINIT(i) {i}
  1077. #endif /* BROKEN_UNION_INIT */
  1078. #define Nullany ANYINIT(0)
  1079.  
  1080. #define UNUSED 0
  1081. #define sym_0 0
  1082.  
  1083. EOT
  1084.     print "static GV *gv_list[$gv_index];\n" if $gv_index;
  1085.     print "\n";
  1086. }
  1087.  
  1088.  
  1089. sub output_boilerplate {
  1090.     print <<'EOT';
  1091. #include "EXTERN.h"
  1092. #include "perl.h"
  1093. #include "XSUB.h"
  1094.  
  1095. /* Workaround for mapstart: the only op which needs a different ppaddr */
  1096. #undef Perl_pp_mapstart
  1097. #define Perl_pp_mapstart Perl_pp_grepstart
  1098. #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
  1099. EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
  1100.  
  1101. static void xs_init (pTHX);
  1102. static void dl_init (pTHX);
  1103. static PerlInterpreter *my_perl;
  1104. EOT
  1105. }
  1106.  
  1107. sub output_main {
  1108.     print <<'EOT';
  1109. int
  1110. main(int argc, char **argv, char **env)
  1111. {
  1112.     int exitstatus;
  1113.     int i;
  1114.     char **fakeargv;
  1115.  
  1116.     PERL_SYS_INIT3(&argc,&argv,&env);
  1117.  
  1118.     if (!PL_do_undump) {
  1119.     my_perl = perl_alloc();
  1120.     if (!my_perl)
  1121.         exit(1);
  1122.     perl_construct( my_perl );
  1123.     PL_perl_destruct_level = 0;
  1124.     }
  1125.  
  1126. #ifdef CSH
  1127.     if (!PL_cshlen) 
  1128.       PL_cshlen = strlen(PL_cshname);
  1129. #endif
  1130.  
  1131. #ifdef ALLOW_PERL_OPTIONS
  1132. #define EXTRA_OPTIONS 2
  1133. #else
  1134. #define EXTRA_OPTIONS 3
  1135. #endif /* ALLOW_PERL_OPTIONS */
  1136.     New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
  1137.     fakeargv[0] = argv[0];
  1138.     fakeargv[1] = "-e";
  1139.     fakeargv[2] = "";
  1140. #ifndef ALLOW_PERL_OPTIONS
  1141.     fakeargv[3] = "--";
  1142. #endif /* ALLOW_PERL_OPTIONS */
  1143.     for (i = 1; i < argc; i++)
  1144.     fakeargv[i + EXTRA_OPTIONS] = argv[i];
  1145.     fakeargv[argc + EXTRA_OPTIONS] = 0;
  1146.     
  1147.     exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
  1148.                 fakeargv, NULL);
  1149.     if (exitstatus)
  1150.     exit( exitstatus );
  1151.  
  1152.     sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
  1153.     PL_main_cv = PL_compcv;
  1154.     PL_compcv = 0;
  1155.  
  1156.     exitstatus = perl_init();
  1157.     if (exitstatus)
  1158.     exit( exitstatus );
  1159.     dl_init(aTHX);
  1160.  
  1161.     exitstatus = perl_run( my_perl );
  1162.  
  1163.     perl_destruct( my_perl );
  1164.     perl_free( my_perl );
  1165.  
  1166.     PERL_SYS_TERM();
  1167.  
  1168.     exit( exitstatus );
  1169. }
  1170.  
  1171. /* yanked from perl.c */
  1172. static void
  1173. xs_init(pTHX)
  1174. {
  1175.     char *file = __FILE__;
  1176.     dTARG;
  1177.     djSP;
  1178. EOT
  1179.     print "\n#ifdef USE_DYNAMIC_LOADING";
  1180.     print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
  1181.     print "\n#endif\n" ;
  1182.     # delete $xsub{'DynaLoader'}; 
  1183.     delete $xsub{'UNIVERSAL'}; 
  1184.     print("/* bootstrapping code*/\n\tSAVETMPS;\n");
  1185.     print("\ttarg=sv_newmortal();\n");
  1186.     print "#ifdef DYNALOADER_BOOTSTRAP\n";
  1187.     print "\tPUSHMARK(sp);\n";
  1188.     print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
  1189.     print qq/\tPUTBACK;\n/;
  1190.     print "\tboot_DynaLoader(aTHX_ NULL);\n";
  1191.     print qq/\tSPAGAIN;\n/;
  1192.     print "#endif\n";
  1193.     foreach my $stashname (keys %xsub){
  1194.     if ($xsub{$stashname} ne 'Dynamic') {
  1195.        my $stashxsub=$stashname;
  1196.        $stashxsub  =~ s/::/__/g; 
  1197.        print "\tPUSHMARK(sp);\n";
  1198.        print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
  1199.        print qq/\tPUTBACK;\n/;
  1200.        print "\tboot_$stashxsub(aTHX_ NULL);\n";
  1201.        print qq/\tSPAGAIN;\n/;
  1202.     }   
  1203.     }
  1204.     print("\tFREETMPS;\n/* end bootstrapping code */\n");
  1205.     print "}\n";
  1206.     
  1207. print <<'EOT';
  1208. static void
  1209. dl_init(pTHX)
  1210. {
  1211.     char *file = __FILE__;
  1212.     dTARG;
  1213.     djSP;
  1214. EOT
  1215.     print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
  1216.     print("\ttarg=sv_newmortal();\n");
  1217.     foreach my $stashname (@DynaLoader::dl_modules) {
  1218.     warn "Loaded $stashname\n";
  1219.     if (exists($xsub{$stashname}) && $xsub{$stashname} eq 'Dynamic') {
  1220.          my $stashxsub=$stashname;
  1221.        $stashxsub  =~ s/::/__/g; 
  1222.           print "\tPUSHMARK(sp);\n";
  1223.           print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
  1224.        print qq/\tPUTBACK;\n/;
  1225.            print "#ifdef DYNALOADER_BOOTSTRAP\n";
  1226.        warn "bootstrapping $stashname added to xs_init\n";
  1227.        print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
  1228.            print "\n#else\n";
  1229.        print "\tboot_$stashxsub(aTHX_ NULL);\n";
  1230.            print "#endif\n";
  1231.        print qq/\tSPAGAIN;\n/;
  1232.     }   
  1233.     }
  1234.     print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
  1235.     print "}\n";
  1236. }
  1237. sub dump_symtable {
  1238.     # For debugging
  1239.     my ($sym, $val);
  1240.     warn "----Symbol table:\n";
  1241.     while (($sym, $val) = each %symtable) {
  1242.     warn "$sym => $val\n";
  1243.     }
  1244.     warn "---End of symbol table\n";
  1245. }
  1246.  
  1247. sub save_object {
  1248.     my $sv;
  1249.     foreach $sv (@_) {
  1250.     svref_2object($sv)->save;
  1251.     }
  1252. }       
  1253.  
  1254. sub Dummy_BootStrap { }            
  1255.  
  1256. sub B::GV::savecv 
  1257. {
  1258.  my $gv = shift;
  1259.  my $package=$gv->STASH->NAME;
  1260.  my $name = $gv->NAME;
  1261.  my $cv = $gv->CV;
  1262.  my $sv = $gv->SV;
  1263.  my $av = $gv->AV;
  1264.  my $hv = $gv->HV;
  1265.  
  1266.  # We may be looking at this package just because it is a branch in the 
  1267.  # symbol table which is on the path to a package which we need to save
  1268.  # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
  1269.  # 
  1270.  return unless ($unused_sub_packages{$package});
  1271.  return unless ($$cv || $$av || $$sv || $$hv);
  1272.  $gv->save;
  1273. }
  1274.  
  1275. sub mark_package
  1276. {    
  1277.  my $package = shift;
  1278.  unless ($unused_sub_packages{$package})
  1279.   {    
  1280.    no strict 'refs';
  1281.    $unused_sub_packages{$package} = 1;
  1282.    if (defined @{$package.'::ISA'})
  1283.     {
  1284.      foreach my $isa (@{$package.'::ISA'}) 
  1285.       {
  1286.        if ($isa eq 'DynaLoader')
  1287.         {
  1288.          unless (defined(&{$package.'::bootstrap'}))
  1289.           {                    
  1290.            warn "Forcing bootstrap of $package\n";
  1291.            eval { $package->bootstrap }; 
  1292.           }
  1293.         }
  1294. #      else
  1295.         {
  1296.          unless ($unused_sub_packages{$isa})
  1297.           {
  1298.            warn "$isa saved (it is in $package\'s \@ISA)\n";
  1299.            mark_package($isa);
  1300.           }
  1301.         }
  1302.       }
  1303.     }
  1304.   }
  1305.  return 1;
  1306. }
  1307.      
  1308. sub should_save
  1309. {
  1310.  no strict qw(vars refs);
  1311.  my $package = shift;
  1312.  $package =~ s/::$//;
  1313.  return $unused_sub_packages{$package} = 0 if ($package =~ /::::/);  # skip ::::ISA::CACHE etc.
  1314.  # warn "Considering $package\n";#debug
  1315.  foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages)) 
  1316.   {  
  1317.    # If this package is a prefix to something we are saving, traverse it 
  1318.    # but do not mark it for saving if it is not already
  1319.    # e.g. to get to Getopt::Long we need to traverse Getopt but need
  1320.    # not save Getopt
  1321.    return 1 if ($u =~ /^$package\:\:/);
  1322.   }
  1323.  if (exists $unused_sub_packages{$package})
  1324.   {
  1325.    # warn "Cached $package is ".$unused_sub_packages{$package}."\n"; 
  1326.    delete_unsaved_hashINC($package) unless  $unused_sub_packages{$package} ;
  1327.    return $unused_sub_packages{$package}; 
  1328.   }
  1329.  # Omit the packages which we use (and which cause grief
  1330.  # because of fancy "goto &$AUTOLOAD" stuff).
  1331.  # XXX Surely there must be a nicer way to do this.
  1332.  if ($package eq "FileHandle" || $package eq "Config" || 
  1333.      $package eq "SelectSaver" || $package =~/^(B|IO)::/) 
  1334.   {
  1335.    delete_unsaved_hashINC($package);
  1336.    return $unused_sub_packages{$package} = 0;
  1337.   }
  1338.  # Now see if current package looks like an OO class this is probably too strong.
  1339.  foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE)) 
  1340.   {
  1341.    if ($package->can($m)) 
  1342.     {
  1343.      warn "$package has method $m: saving package\n";#debug
  1344.      return mark_package($package);
  1345.     }
  1346.   }
  1347.  delete_unsaved_hashINC($package);
  1348.  return $unused_sub_packages{$package} = 0;
  1349. }
  1350. sub delete_unsaved_hashINC{
  1351.     my $packname=shift;
  1352.     $packname =~ s/\:\:/\//g;
  1353.     $packname .= '.pm';
  1354. #    warn "deleting $packname" if $INC{$packname} ;# debug
  1355.     delete $INC{$packname};
  1356. }
  1357. sub walkpackages 
  1358. {
  1359.  my ($symref, $recurse, $prefix) = @_;
  1360.  my $sym;
  1361.  my $ref;
  1362.  no strict 'vars';
  1363.  local(*glob);
  1364.  $prefix = '' unless defined $prefix;
  1365.  while (($sym, $ref) = each %$symref) 
  1366.   {             
  1367.    *glob = $ref;
  1368.    if ($sym =~ /::$/) 
  1369.     {
  1370.      $sym = $prefix . $sym;
  1371.      if ($sym ne "main::" && &$recurse($sym)) 
  1372.       {
  1373.        walkpackages(\%glob, $recurse, $sym);
  1374.       }
  1375.     } 
  1376.   }
  1377. }
  1378.  
  1379.  
  1380. sub save_unused_subs 
  1381. {
  1382.  no strict qw(refs);
  1383.  &descend_marked_unused;
  1384.  warn "Prescan\n";
  1385.  walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
  1386.  warn "Saving methods\n";
  1387.  walksymtable(\%{"main::"}, "savecv", \&should_save);
  1388. }
  1389.  
  1390. sub save_context
  1391. {
  1392.  my $curpad_nam = (comppadlist->ARRAY)[0]->save;
  1393.  my $curpad_sym = (comppadlist->ARRAY)[1]->save;
  1394.  my $inc_hv     = svref_2object(\%INC)->save;
  1395.  my $inc_av     = svref_2object(\@INC)->save;
  1396.  my $amagic_generate= amagic_generation;          
  1397.  $init->add(   "PL_curpad = AvARRAY($curpad_sym);",
  1398.            "GvHV(PL_incgv) = $inc_hv;",
  1399.            "GvAV(PL_incgv) = $inc_av;",
  1400.                "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
  1401.                "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
  1402.           "PL_amagic_generation= $amagic_generate;" );
  1403. }
  1404.  
  1405. sub descend_marked_unused {
  1406.     foreach my $pack (keys %unused_sub_packages)
  1407.     {
  1408.         mark_package($pack);
  1409.     }
  1410. }
  1411.  
  1412. sub save_main {
  1413.     warn "Starting compile\n";
  1414.     warn "Walking tree\n";
  1415.     seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
  1416.     walkoptree(main_root, "save");
  1417.     warn "done main optree, walking symtable for extras\n" if $debug_cv;
  1418.     save_unused_subs();
  1419.     my $init_av = init_av->save;
  1420.     $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
  1421.            sprintf("PL_main_start = s\\_%x;", ${main_start()}),
  1422.               "PL_initav = (AV *) $init_av;");                                
  1423.     save_context();
  1424.     warn "Writing output\n";
  1425.     output_boilerplate();
  1426.     print "\n";
  1427.     output_all("perl_init");
  1428.     print "\n";
  1429.     output_main();
  1430. }
  1431.  
  1432. sub init_sections {
  1433.     my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
  1434.             binop => \$binopsect, condop => \$condopsect,
  1435.             cop => \$copsect, padop => \$padopsect,
  1436.             listop => \$listopsect, logop => \$logopsect,
  1437.             loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
  1438.             pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
  1439.             sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
  1440.             xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
  1441.             xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
  1442.             xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
  1443.             xrv => \$xrvsect, xpvbm => \$xpvbmsect,
  1444.             xpvio => \$xpviosect);
  1445.     my ($name, $sectref);
  1446.     while (($name, $sectref) = splice(@sections, 0, 2)) {
  1447.     $$sectref = new B::C::Section $name, \%symtable, 0;
  1448.     }
  1449. }           
  1450.  
  1451. sub mark_unused
  1452. {
  1453.  my ($arg,$val) = @_;
  1454.  $unused_sub_packages{$arg} = $val;
  1455. }
  1456.  
  1457. sub compile {
  1458.     my @options = @_;
  1459.     my ($option, $opt, $arg);
  1460.   OPTION:
  1461.     while ($option = shift @options) {
  1462.     if ($option =~ /^-(.)(.*)/) {
  1463.         $opt = $1;
  1464.         $arg = $2;
  1465.     } else {
  1466.         unshift @options, $option;
  1467.         last OPTION;
  1468.     }
  1469.     if ($opt eq "-" && $arg eq "-") {
  1470.         shift @options;
  1471.         last OPTION;
  1472.     }
  1473.     if ($opt eq "w") {
  1474.         $warn_undefined_syms = 1;
  1475.     } elsif ($opt eq "D") {
  1476.         $arg ||= shift @options;
  1477.         foreach $arg (split(//, $arg)) {
  1478.         if ($arg eq "o") {
  1479.             B->debug(1);
  1480.         } elsif ($arg eq "c") {
  1481.             $debug_cops = 1;
  1482.         } elsif ($arg eq "A") {
  1483.             $debug_av = 1;
  1484.         } elsif ($arg eq "C") {
  1485.             $debug_cv = 1;
  1486.         } elsif ($arg eq "M") {
  1487.             $debug_mg = 1;
  1488.         } else {
  1489.             warn "ignoring unknown debug option: $arg\n";
  1490.         }
  1491.         }
  1492.     } elsif ($opt eq "o") {
  1493.         $arg ||= shift @options;
  1494.         open(STDOUT, ">$arg") or return "$arg: $!\n";
  1495.     } elsif ($opt eq "v") {
  1496.         $verbose = 1;
  1497.     } elsif ($opt eq "u") {
  1498.         $arg ||= shift @options;
  1499.         mark_unused($arg,undef);
  1500.     } elsif ($opt eq "f") {
  1501.         $arg ||= shift @options;
  1502.         if ($arg eq "cog") {
  1503.         $pv_copy_on_grow = 1;
  1504.         } elsif ($arg eq "no-cog") {
  1505.         $pv_copy_on_grow = 0;
  1506.         }
  1507.     } elsif ($opt eq "O") {
  1508.         $arg = 1 if $arg eq "";
  1509.         $pv_copy_on_grow = 0;
  1510.         if ($arg >= 1) {
  1511.         # Optimisations for -O1
  1512.         $pv_copy_on_grow = 1;
  1513.         }
  1514.     } elsif ($opt eq "l") {
  1515.         $max_string_len = $arg;
  1516.     }
  1517.     }
  1518.     init_sections();
  1519.     if (@options) {
  1520.     return sub {
  1521.         my $objname;
  1522.         foreach $objname (@options) {
  1523.         eval "save_object(\\$objname)";
  1524.         }
  1525.         output_all();
  1526.     }
  1527.     } else {
  1528.     return sub { save_main() };
  1529.     }
  1530. }
  1531.  
  1532. 1;
  1533.  
  1534. __END__
  1535.  
  1536. =head1 NAME
  1537.  
  1538. B::C - Perl compiler's C backend
  1539.  
  1540. =head1 SYNOPSIS
  1541.  
  1542.     perl -MO=C[,OPTIONS] foo.pl
  1543.  
  1544. =head1 DESCRIPTION
  1545.  
  1546. This compiler backend takes Perl source and generates C source code
  1547. corresponding to the internal structures that perl uses to run
  1548. your program. When the generated C source is compiled and run, it
  1549. cuts out the time which perl would have taken to load and parse
  1550. your program into its internal semi-compiled form. That means that
  1551. compiling with this backend will not help improve the runtime
  1552. execution speed of your program but may improve the start-up time.
  1553. Depending on the environment in which your program runs this may be
  1554. either a help or a hindrance.
  1555.  
  1556. =head1 OPTIONS
  1557.  
  1558. If there are any non-option arguments, they are taken to be
  1559. names of objects to be saved (probably doesn't work properly yet).
  1560. Without extra arguments, it saves the main program.
  1561.  
  1562. =over 4
  1563.  
  1564. =item B<-ofilename>
  1565.  
  1566. Output to filename instead of STDOUT
  1567.  
  1568. =item B<-v>
  1569.  
  1570. Verbose compilation (currently gives a few compilation statistics).
  1571.  
  1572. =item B<-->
  1573.  
  1574. Force end of options
  1575.  
  1576. =item B<-uPackname>
  1577.  
  1578. Force apparently unused subs from package Packname to be compiled.
  1579. This allows programs to use eval "foo()" even when sub foo is never
  1580. seen to be used at compile time. The down side is that any subs which
  1581. really are never used also have code generated. This option is
  1582. necessary, for example, if you have a signal handler foo which you
  1583. initialise with C<$SIG{BAR} = "foo">.  A better fix, though, is just
  1584. to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
  1585. options. The compiler tries to figure out which packages may possibly
  1586. have subs in which need compiling but the current version doesn't do
  1587. it very well. In particular, it is confused by nested packages (i.e.
  1588. of the form C<A::B>) where package C<A> does not contain any subs.
  1589.  
  1590. =item B<-D>
  1591.  
  1592. Debug options (concatenated or separate flags like C<perl -D>).
  1593.  
  1594. =item B<-Do>
  1595.  
  1596. OPs, prints each OP as it's processed
  1597.  
  1598. =item B<-Dc>
  1599.  
  1600. COPs, prints COPs as processed (incl. file & line num)
  1601.  
  1602. =item B<-DA>
  1603.  
  1604. prints AV information on saving
  1605.  
  1606. =item B<-DC>
  1607.  
  1608. prints CV information on saving
  1609.  
  1610. =item B<-DM>
  1611.  
  1612. prints MAGIC information on saving
  1613.  
  1614. =item B<-f>
  1615.  
  1616. Force optimisations on or off one at a time.
  1617.  
  1618. =item B<-fcog>
  1619.  
  1620. Copy-on-grow: PVs declared and initialised statically.
  1621.  
  1622. =item B<-fno-cog>
  1623.  
  1624. No copy-on-grow.
  1625.  
  1626. =item B<-On>
  1627.  
  1628. Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.  Currently,
  1629. B<-O1> and higher set B<-fcog>.
  1630.  
  1631. =item B<-llimit>
  1632.  
  1633. Some C compilers impose an arbitrary limit on the length of string
  1634. constants (e.g. 2048 characters for Microsoft Visual C++).  The
  1635. B<-llimit> options tells the C backend not to generate string literals
  1636. exceeding that limit.
  1637.  
  1638. =back
  1639.  
  1640. =head1 EXAMPLES
  1641.  
  1642.     perl -MO=C,-ofoo.c foo.pl
  1643.     perl cc_harness -o foo foo.c
  1644.  
  1645. Note that C<cc_harness> lives in the C<B> subdirectory of your perl
  1646. library directory. The utility called C<perlcc> may also be used to
  1647. help make use of this compiler.
  1648.  
  1649.     perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null
  1650.  
  1651. =head1 BUGS
  1652.  
  1653. Plenty. Current status: experimental.
  1654.  
  1655. =head1 AUTHOR
  1656.  
  1657. Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
  1658.  
  1659. =cut
  1660.