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