This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
da9f7ddd1b91c165bd78189a6bcd87660eb62a02
[perl5.git] / ext / B / B / C.pm
1 #      C.pm
2 #
3 #      Copyright (c) 1996, 1997, 1998 Malcolm Beattie
4 #
5 #      You may distribute under the terms of either the GNU General Public
6 #      License or the Artistic License, as specified in the README file.
7 #
8 package B::C;
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 B::GV::savecv {
1058     my $gv = shift;
1059     my $cv = $gv->CV;
1060     my $name = $gv->NAME;
1061     if ($$cv && !objsym($cv)) {
1062         if ($name eq "bootstrap" && $cv->XSUB) {
1063             my $file = $cv->FILEGV->SV->PV;
1064             $bootstrap->add($file);
1065             return;
1066         }
1067         if ($debug_cv) {
1068             warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
1069                          $gv->STASH->NAME, $name, $$cv, $$gv);
1070         }
1071       my $package=$gv->STASH->NAME;
1072       # This seems to undo all the ->isa and prefix stuff we do below
1073       # so disable again for now
1074       if (0 && ! grep(/^$package$/,@unused_sub_packages)){
1075           warn sprintf("omitting cv in superclass %s", $gv->STASH->NAME) 
1076               if $debug_cv;
1077           return ;
1078       }
1079         $gv->save;
1080     }
1081     elsif ($name eq 'ISA')
1082      {
1083       $gv->save;
1084      }
1085
1086 }
1087
1088 sub save_unused_subs {
1089     my %search_pack;
1090     map { $search_pack{$_} = 1 } @_;
1091     @unused_sub_packages=@_;
1092     no strict qw(vars refs);
1093     walksymtable(\%{"main::"}, "savecv", sub {
1094         my $package = shift;
1095         $package =~ s/::$//;
1096         return 0 if ($package =~ /::::/);  # skip ::::ISA::CACHE etc.
1097         #warn "Considering $package\n";#debug
1098         return 1 if exists $search_pack{$package};
1099       #sub try for a partial match
1100       if (grep(/^$package\:\:/,@unused_sub_packages)){ 
1101           return 1;   
1102       }       
1103         #warn "    (nothing explicit)\n";#debug
1104         # Omit the packages which we use (and which cause grief
1105         # because of fancy "goto &$AUTOLOAD" stuff).
1106         # XXX Surely there must be a nicer way to do this.
1107         if ($package eq "FileHandle"
1108             || $package eq "Config"
1109             || $package eq "SelectSaver") {
1110             return 0;
1111         }
1112         foreach my $u (keys %search_pack) {
1113             if ($package =~ /^${u}::/) {
1114                 warn "$package starts with $u\n";
1115                 return 1
1116             }
1117             if ($package->isa($u)) {
1118                 warn "$package isa $u\n";
1119                 return 1
1120             }
1121             return 1 if $package->isa($u);
1122         }
1123         foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) {
1124             if (defined(&{$package."::$m"})) {
1125                 warn "$package has method $m: -u$package assumed\n";#debug
1126               push @unused_sub_package, $package;
1127                 return 1;
1128             }
1129         }
1130         return 0;
1131     });
1132 }
1133
1134 sub save_main {
1135     my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1136     my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1137     my $init_av    = init_av->save;
1138     walkoptree(main_root, "save");
1139     warn "done main optree, walking symtable for extras\n" if $debug_cv;
1140     save_unused_subs(@unused_sub_packages);
1141
1142     $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1143                sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1144                "PL_curpad = AvARRAY($curpad_sym);",
1145                "PL_initav = $init_av;",
1146                "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1147                "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));");
1148     warn "Writing output\n";
1149     output_boilerplate();
1150     print "\n";
1151     output_all("perl_init");
1152     print "\n";
1153     output_main();
1154 }
1155
1156 sub init_sections {
1157     my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1158                     binop => \$binopsect, condop => \$condopsect,
1159                     cop => \$copsect, cvop => \$cvopsect, gvop => \$gvopsect,
1160                     listop => \$listopsect, logop => \$logopsect,
1161                     loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1162                     pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1163                     sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1164                     xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1165                     xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1166                     xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1167                     xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1168                     xpvio => \$xpviosect, bootstrap => \$bootstrap);
1169     my ($name, $sectref);
1170     while (($name, $sectref) = splice(@sections, 0, 2)) {
1171         $$sectref = new B::Section $name, \%symtable, 0;
1172     }
1173 }
1174
1175 sub compile {
1176     my @options = @_;
1177     my ($option, $opt, $arg);
1178   OPTION:
1179     while ($option = shift @options) {
1180         if ($option =~ /^-(.)(.*)/) {
1181             $opt = $1;
1182             $arg = $2;
1183         } else {
1184             unshift @options, $option;
1185             last OPTION;
1186         }
1187         if ($opt eq "-" && $arg eq "-") {
1188             shift @options;
1189             last OPTION;
1190         }
1191         if ($opt eq "w") {
1192             $warn_undefined_syms = 1;
1193         } elsif ($opt eq "D") {
1194             $arg ||= shift @options;
1195             foreach $arg (split(//, $arg)) {
1196                 if ($arg eq "o") {
1197                     B->debug(1);
1198                 } elsif ($arg eq "c") {
1199                     $debug_cops = 1;
1200                 } elsif ($arg eq "A") {
1201                     $debug_av = 1;
1202                 } elsif ($arg eq "C") {
1203                     $debug_cv = 1;
1204                 } elsif ($arg eq "M") {
1205                     $debug_mg = 1;
1206                 } else {
1207                     warn "ignoring unknown debug option: $arg\n";
1208                 }
1209             }
1210         } elsif ($opt eq "o") {
1211             $arg ||= shift @options;
1212             open(STDOUT, ">$arg") or return "$arg: $!\n";
1213         } elsif ($opt eq "v") {
1214             $verbose = 1;
1215         } elsif ($opt eq "u") {
1216             $arg ||= shift @options;
1217             push(@unused_sub_packages, $arg);
1218         } elsif ($opt eq "f") {
1219             $arg ||= shift @options;
1220             if ($arg eq "cog") {
1221                 $pv_copy_on_grow = 1;
1222             } elsif ($arg eq "no-cog") {
1223                 $pv_copy_on_grow = 0;
1224             }
1225         } elsif ($opt eq "O") {
1226             $arg = 1 if $arg eq "";
1227             $pv_copy_on_grow = 0;
1228             if ($arg >= 1) {
1229                 # Optimisations for -O1
1230                 $pv_copy_on_grow = 1;
1231             }
1232         }
1233     }
1234     init_sections();
1235     if (@options) {
1236         return sub {
1237             my $objname;
1238             foreach $objname (@options) {
1239                 eval "save_object(\\$objname)";
1240             }
1241             output_all();
1242         }
1243     } else {
1244         return sub { save_main() };
1245     }
1246 }
1247
1248 1;
1249
1250 __END__
1251
1252 =head1 NAME
1253
1254 B::C - Perl compiler's C backend
1255
1256 =head1 SYNOPSIS
1257
1258         perl -MO=C[,OPTIONS] foo.pl
1259
1260 =head1 DESCRIPTION
1261
1262 This compiler backend takes Perl source and generates C source code
1263 corresponding to the internal structures that perl uses to run
1264 your program. When the generated C source is compiled and run, it
1265 cuts out the time which perl would have taken to load and parse
1266 your program into its internal semi-compiled form. That means that
1267 compiling with this backend will not help improve the runtime
1268 execution speed of your program but may improve the start-up time.
1269 Depending on the environment in which your program runs this may be
1270 either a help or a hindrance.
1271
1272 =head1 OPTIONS
1273
1274 If there are any non-option arguments, they are taken to be
1275 names of objects to be saved (probably doesn't work properly yet).
1276 Without extra arguments, it saves the main program.
1277
1278 =over 4
1279
1280 =item B<-ofilename>
1281
1282 Output to filename instead of STDOUT
1283
1284 =item B<-v>
1285
1286 Verbose compilation (currently gives a few compilation statistics).
1287
1288 =item B<-->
1289
1290 Force end of options
1291
1292 =item B<-uPackname>
1293
1294 Force apparently unused subs from package Packname to be compiled.
1295 This allows programs to use eval "foo()" even when sub foo is never
1296 seen to be used at compile time. The down side is that any subs which
1297 really are never used also have code generated. This option is
1298 necessary, for example, if you have a signal handler foo which you
1299 initialise with C<$SIG{BAR} = "foo">.  A better fix, though, is just
1300 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1301 options. The compiler tries to figure out which packages may possibly
1302 have subs in which need compiling but the current version doesn't do
1303 it very well. In particular, it is confused by nested packages (i.e.
1304 of the form C<A::B>) where package C<A> does not contain any subs.
1305
1306 =item B<-D>
1307
1308 Debug options (concatenated or separate flags like C<perl -D>).
1309
1310 =item B<-Do>
1311
1312 OPs, prints each OP as it's processed
1313
1314 =item B<-Dc>
1315
1316 COPs, prints COPs as processed (incl. file & line num)
1317
1318 =item B<-DA>
1319
1320 prints AV information on saving
1321
1322 =item B<-DC>
1323
1324 prints CV information on saving
1325
1326 =item B<-DM>
1327
1328 prints MAGIC information on saving
1329
1330 =item B<-f>
1331
1332 Force optimisations on or off one at a time.
1333
1334 =item B<-fcog>
1335
1336 Copy-on-grow: PVs declared and initialised statically.
1337
1338 =item B<-fno-cog>
1339
1340 No copy-on-grow.
1341
1342 =item B<-On>
1343
1344 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.  Currently,
1345 B<-O1> and higher set B<-fcog>.
1346
1347 =head1 EXAMPLES
1348
1349     perl -MO=C,-ofoo.c foo.pl
1350     perl cc_harness -o foo foo.c
1351
1352 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1353 library directory. The utility called C<perlcc> may also be used to
1354 help make use of this compiler.
1355
1356     perl -MO=C,-v,-DcA bar.pl > /dev/null
1357
1358 =head1 BUGS
1359
1360 Plenty. Current status: experimental.
1361
1362 =head1 AUTHOR
1363
1364 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
1365
1366 =cut