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