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