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
CommitLineData
a798dbf2
MB
1# C.pm
2#
1a52ab62 3# Copyright (c) 1996, 1997, 1998 Malcolm Beattie
a798dbf2
MB
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#
66a2622e
NIS
8package B::C::Section;
9use B ();
10use base B::Section;
11
12sub new
13{
14 my $class = shift;
15 my $o = $class->SUPER::new(@_);
16 push(@$o,[]);
17 return $o;
18}
19
20sub add
21{
22 my $section = shift;
23 push(@{$section->[-1]},@_);
24}
25
26sub index
27{
28 my $section = shift;
29 return scalar(@{$section->[-1]})-1;
30}
31
32sub 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
a798dbf2
MB
44package B::C;
45use Exporter ();
46@ISA = qw(Exporter);
0cc1d052
NIS
47@EXPORT_OK = qw(output_all output_boilerplate output_main mark_unused
48 init_sections set_callback save_unused_subs objsym save_context);
a798dbf2
MB
49
50use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop
51 class cstring cchar svref_2object compile_stats comppadlist hash
56eca212 52 threadsv_names main_cv init_av opnumber amagic_generation
b874ff32 53 AVf_REAL HEf_SVKEY);
a798dbf2
MB
54use B::Asmdata qw(@specialsv_name);
55
56use FileHandle;
57use Carp;
58use strict;
f0cd5c3a
VB
59use Config;
60my $handle_VC_problem = "";
61$handle_VC_problem="{0}," if $^O eq 'MSWin32' and $Config{cc} =~ /^cl/i;
a798dbf2
MB
62
63my $hv_index = 0;
64my $gv_index = 0;
65my $re_index = 0;
66my $pv_index = 0;
67my $anonsub_index = 0;
44887cfa 68my $initsub_index = 0;
a798dbf2
MB
69
70my %symtable;
af765ed9 71my %xsub;
a798dbf2
MB
72my $warn_undefined_syms;
73my $verbose;
66a2622e 74my %unused_sub_packages;
a798dbf2 75my $nullop_count;
66a2622e 76my $pv_copy_on_grow = 0;
a798dbf2
MB
77my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
78
79my @threadsv_names;
80BEGIN {
81 @threadsv_names = threadsv_names();
82}
83
84# Code sections
66a2622e 85my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect,
a798dbf2
MB
86 $gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
87 $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
88 $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
af765ed9 89 $xrvsect, $xpvbmsect, $xpviosect );
a798dbf2
MB
90
91sub walk_and_save_optree;
92my $saveoptree_callback = \&walk_and_save_optree;
93sub set_callback { $saveoptree_callback = shift }
94sub saveoptree { &$saveoptree_callback(@_) }
95
96sub 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.
109my $op_seq = 65535;
110
0cc1d052
NIS
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
113my $OP_THREADSV = opnumber('threadsv');
a798dbf2
MB
114
115sub savesym {
116 my ($obj, $value) = @_;
117 my $sym = sprintf("s\\_%x", $$obj);
118 $symtable{$sym} = $value;
119}
120
121sub objsym {
122 my $obj = shift;
123 return $symtable{sprintf("s\\_%x", $$obj)};
124}
125
126sub 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
140sub savepv {
66a2622e
NIS
141 my $pv = shift;
142 $pv = '' unless defined $pv; # Is this sane ?
a798dbf2
MB
143 my $pvsym = 0;
144 my $pvmax = 0;
66a2622e 145 if ($pv_copy_on_grow) {
a798dbf2
MB
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
157sub B::OP::save {
158 my ($op, $level) = @_;
2c0b28dd
VB
159 my $sym = objsym($op);
160 return $sym if defined $sym;
a798dbf2
MB
161 my $type = $op->type;
162 $nullop_count++ unless $type;
0cc1d052 163 if ($type == $OP_THREADSV) {
a798dbf2
MB
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 }
f0cd5c3a 168 $opsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x",
a798dbf2
MB
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
174sub B::FAKEOP::new {
175 my ($class, %objdata) = @_;
176 bless \%objdata, $class;
177}
178
179sub B::FAKEOP::save {
180 my ($op, $level) = @_;
f0cd5c3a 181 $opsect->add(sprintf("%s, %s, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x",
a798dbf2
MB
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
187sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
188sub B::FAKEOP::type { $_[0]->{type} || 0}
189sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
190sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
191sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
192sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
193sub B::FAKEOP::private { $_[0]->{private} || 0 }
194
195sub B::UNOP::save {
196 my ($op, $level) = @_;
2c0b28dd
VB
197 my $sym = objsym($op);
198 return $sym if defined $sym;
f0cd5c3a 199 $unopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, s\\_%x",
a798dbf2
MB
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
206sub B::BINOP::save {
207 my ($op, $level) = @_;
2c0b28dd
VB
208 my $sym = objsym($op);
209 return $sym if defined $sym;
f0cd5c3a 210 $binopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
a798dbf2
MB
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
217sub B::LISTOP::save {
218 my ($op, $level) = @_;
2c0b28dd
VB
219 my $sym = objsym($op);
220 return $sym if defined $sym;
f0cd5c3a 221 $listopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u",
a798dbf2
MB
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
229sub B::LOGOP::save {
230 my ($op, $level) = @_;
2c0b28dd
VB
231 my $sym = objsym($op);
232 return $sym if defined $sym;
f0cd5c3a 233 $logopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
a798dbf2
MB
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
a798dbf2
MB
240sub B::LOOP::save {
241 my ($op, $level) = @_;
2c0b28dd
VB
242 my $sym = objsym($op);
243 return $sym if defined $sym;
a798dbf2
MB
244 #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
245 # peekop($op->redoop), peekop($op->nextop),
246 # peekop($op->lastop)); # debug
f0cd5c3a 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",
a798dbf2
MB
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
256sub B::PVOP::save {
257 my ($op, $level) = @_;
2c0b28dd
VB
258 my $sym = objsym($op);
259 return $sym if defined $sym;
f0cd5c3a 260 $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, $handle_VC_problem %u, %u, %u, 0x%x, 0x%x, %s",
a798dbf2
MB
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
267sub B::SVOP::save {
268 my ($op, $level) = @_;
2c0b28dd
VB
269 my $sym = objsym($op);
270 return $sym if defined $sym;
a798dbf2 271 my $svsym = $op->sv->save;
f0cd5c3a 272 $svopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, %s",
a798dbf2
MB
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
279sub B::GVOP::save {
280 my ($op, $level) = @_;
2c0b28dd
VB
281 my $sym = objsym($op);
282 return $sym if defined $sym;
a798dbf2 283 my $gvsym = $op->gv->save;
f0cd5c3a 284 $gvopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, Nullgv",
a798dbf2
MB
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
292sub B::COP::save {
293 my ($op, $level) = @_;
2c0b28dd
VB
294 my $sym = objsym($op);
295 return $sym if defined $sym;
a798dbf2
MB
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;
f0cd5c3a 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",
a798dbf2
MB
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
311sub B::PMOP::save {
312 my ($op, $level) = @_;
2c0b28dd
VB
313 my $sym = objsym($op);
314 return $sym if defined $sym;
a798dbf2
MB
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...
3f872cb9 325 if ($op->name eq "pushre") {
a798dbf2
MB
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
f0cd5c3a 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",
a798dbf2
MB
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
356sub 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
367sub B::OBJECT::save {}
368
369sub 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
382sub 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
392sub B::NV::save {
393 my ($sv) = @_;
394 my $sym = objsym($sv);
395 return $sym if defined $sym;
56eca212
GS
396 my $val= $sv->NVX;
397 $val .= '.00' if $val =~ /^-?\d+$/;
398 $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
a798dbf2
MB
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
404sub 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
425sub 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
442sub B::PVNV::save {
443 my ($sv) = @_;
444 my $sym = objsym($sv);
445 return $sym if defined $sym;
66a2622e
NIS
446 my $pv = $sv->PV;
447 $pv = '' unless defined $pv;
a798dbf2
MB
448 my $len = length($pv);
449 my ($pvsym, $pvmax) = savepv($pv);
56eca212
GS
450 my $val= $sv->NVX;
451 $val .= '.00' if $val =~ /^-?\d+$/;
a798dbf2 452 $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
56eca212 453 $pvsym, $len, $pvmax, $sv->IVX, $val));
a798dbf2
MB
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
463sub 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
482sub 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
499sub 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
519sub 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;
56eca212 523 $stash->save;
a798dbf2
MB
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;
88b39979 531 my ($mg, $type, $obj, $ptr,$len,$ptrsv);
a798dbf2
MB
532 foreach $mg (@mgchain) {
533 $type = $mg->TYPE;
534 $obj = $mg->OBJ;
535 $ptr = $mg->PTR;
88b39979 536 $len=$mg->LENGTH;
a798dbf2
MB
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 }
56eca212 542 $obj->save;
88b39979
VB
543 if ($len == HEf_SVKEY){
544 #The pointer is an SV*
545 $ptrsv=svref_2object($ptr)->save;
5ab5c7a4 546 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
88b39979
VB
547 $$sv, $$obj, cchar($type),$ptrsv,$len));
548 }else{
549 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
a798dbf2 550 $$sv, $$obj, cchar($type),cstring($ptr),$len));
88b39979 551 }
a798dbf2
MB
552 }
553}
554
555sub B::RV::save {
556 my ($sv) = @_;
557 my $sym = objsym($sv);
558 return $sym if defined $sym;
66a2622e
NIS
559 my $rv = $sv->RV->save;
560 $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/;
561 $xrvsect->add($rv);
a798dbf2
MB
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
567sub 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}
e9a14d94 588sub Dummy_initxs{};
a798dbf2
MB
589sub 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
af765ed9
VB
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;
e9a14d94
VB
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")) {
af765ed9
VB
606 my $egv = $gv->EGV;
607 my $stashname = $egv->STASH->NAME;
be6f3502
NIS
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};
a0e9c8c7 615 return qq/NULL/;
be6f3502 616 }
a0e9c8c7 617 warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv;
be6f3502 618 return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/;
e9a14d94
VB
619 }
620 if ($cvxsub && $cvname eq "INIT") {
621 no strict 'refs';
622 return svref_2object(\&Dummy_initxs)->save;
af765ed9 623 }
a798dbf2
MB
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]");
a0e9c8c7 630 warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv;
a798dbf2
MB
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;
44887cfa
NIS
658 if ($gvname eq "INIT"){
659 $ppname .= "_$initsub_index";
660 $initsub_index++;
661 }
a798dbf2
MB
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 }
a798dbf2
MB
679 else {
680 warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
681 $cvstashname, $cvname); # debug
66a2622e
NIS
682 }
683 $pv = '' unless defined $pv; # Avoid use of undef warnings
5cfd8ad4 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",
a798dbf2
MB
685 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
686 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
5cfd8ad4
VB
687 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
688
689 if (${$cv->OUTSIDE} == ${main_cv()}){
690 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
358b5eb8 691 $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
5cfd8ad4
VB
692 }
693
a798dbf2
MB
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
719sub B::GV::save {
be6f3502 720 my ($gv) = @_;
a798dbf2
MB
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) {
cfa4c8ee 761 $gvsv->save;
a798dbf2
MB
762 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
763# warn "GV::save \$$name\n"; # debug
a798dbf2
MB
764 }
765 my $gvav = $gv->AV;
766 if ($$gvav) {
cfa4c8ee 767 $gvav->save;
a798dbf2
MB
768 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
769# warn "GV::save \@$name\n"; # debug
a798dbf2
MB
770 }
771 my $gvhv = $gv->HV;
772 if ($$gvhv) {
cfa4c8ee 773 $gvhv->save;
a798dbf2
MB
774 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
775# warn "GV::save \%$name\n"; # debug
a798dbf2
MB
776 }
777 my $gvcv = $gv->CV;
be6f3502
NIS
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
af765ed9 783 $init->add("{ CV *cv;");
be6f3502 784 $init->add("\tcv=perl_get_cv($origname,TRUE);");
af765ed9
VB
785 $init->add("\tGvCV($sym)=cv;");
786 $init->add("\tSvREFCNT_inc((SV *)cv);");
be6f3502
NIS
787 $init->add("}");
788 } else {
789 $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
790# warn "GV::save &$name\n"; # debug
791 }
af765ed9 792 }
a798dbf2
MB
793 my $gvfilegv = $gv->FILEGV;
794 if ($$gvfilegv) {
cfa4c8ee 795 $gvfilegv->save;
5ed82aed 796 $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv));
a798dbf2 797# warn "GV::save GvFILEGV(*$name)\n"; # debug
a798dbf2
MB
798 }
799 my $gvform = $gv->FORM;
800 if ($$gvform) {
cfa4c8ee 801 $gvform->save;
a798dbf2
MB
802 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
803# warn "GV::save GvFORM(*$name)\n"; # debug
a798dbf2
MB
804 }
805 my $gvio = $gv->IO;
806 if ($$gvio) {
cfa4c8ee 807 $gvio->save;
a798dbf2
MB
808 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
809# warn "GV::save GvIO(*$name)\n"; # debug
a798dbf2
MB
810 }
811 }
812 return $sym;
813}
814sub 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
860sub 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)));
cf86991c
NIS
901# $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
902# cstring($key),length($key),$value, 0));
a798dbf2
MB
903 }
904 $init->add("}");
905 }
56eca212 906 $hv->save_magic();
a798dbf2
MB
907 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
908}
909
910sub B::IO::save {
911 my ($io) = @_;
912 my $sym = objsym($io);
913 return $sym if defined $sym;
914 my $pv = $io->PV;
66a2622e 915 $pv = '' unless defined $pv;
a798dbf2
MB
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
938sub 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
947sub output_all {
948 my $init_name = shift;
949 my $section;
950 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
951 $listopsect, $pmopsect, $svopsect, $gvopsect, $pvopsect,
66a2622e 952 $loopsect, $copsect, $svsect, $xpvsect,
a798dbf2
MB
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";
980static int $init_name()
981{
982 dTHR;
af765ed9
VB
983 dTARG;
984 djSP;
a798dbf2
MB
985EOT
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
994sub 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 */
1007typedef 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;
20ce7b12 1019 void (*xcv_xsub) (CV*);
a798dbf2
MB
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
1042EOT
1043 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1044 print "\n";
1045}
1046
1047
1048sub output_boilerplate {
1049 print <<'EOT';
1050#include "EXTERN.h"
1051#include "perl.h"
a798dbf2
MB
1052
1053/* Workaround for mapstart: the only op which needs a different ppaddr */
3f872cb9
GS
1054#undef Perl_pp_mapstart
1055#define Perl_pp_mapstart Perl_pp_grepstart
511dd457 1056#define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
20ce7b12 1057EXTERN_C void boot_DynaLoader (CV* cv);
a798dbf2 1058
20ce7b12 1059static void xs_init (void);
be6f3502 1060static void dl_init (void);
a798dbf2
MB
1061static PerlInterpreter *my_perl;
1062EOT
1063}
1064
1065sub output_main {
1066 print <<'EOT';
1067int
1068#ifndef CAN_PROTOTYPE
1069main(argc, argv, env)
1070int argc;
1071char **argv;
1072char **env;
1073#else /* def(CAN_PROTOTYPE) */
1074main(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
81009501 1085 if (!PL_do_undump) {
a798dbf2
MB
1086 my_perl = perl_alloc();
1087 if (!my_perl)
1088 exit(1);
1089 perl_construct( my_perl );
1090 }
1091
1092#ifdef CSH
81009501
GS
1093 if (!PL_cshlen)
1094 PL_cshlen = strlen(PL_cshname);
a798dbf2
MB
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]);
81009501
GS
1119 PL_main_cv = PL_compcv;
1120 PL_compcv = 0;
a798dbf2
MB
1121
1122 exitstatus = perl_init();
1123 if (exitstatus)
1124 exit( exitstatus );
be6f3502 1125 dl_init();
a798dbf2
MB
1126
1127 exitstatus = perl_run( my_perl );
1128
1129 perl_destruct( my_perl );
1130 perl_free( my_perl );
1131
1132 exit( exitstatus );
1133}
1134
511dd457 1135/* yanked from perl.c */
a798dbf2
MB
1136static void
1137xs_init()
1138{
511dd457 1139 char *file = __FILE__;
af765ed9
VB
1140 dTARG;
1141 djSP;
a798dbf2 1142EOT
af765ed9
VB
1143 print "\n#ifdef USE_DYNAMIC_LOADING";
1144 print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1145 print "\n#endif\n" ;
a0e9c8c7 1146 # delete $xsub{'DynaLoader'};
af765ed9 1147 delete $xsub{'UNIVERSAL'};
be6f3502 1148 print("/* bootstrapping code*/\n\tSAVETMPS;\n");
af765ed9 1149 print("\ttarg=sv_newmortal();\n");
a0e9c8c7
NIS
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){
be6f3502
NIS
1158 if ($xsub{$stashname} ne 'Dynamic') {
1159 my $stashxsub=$stashname;
1160 $stashxsub =~ s/::/__/g;
1161 print "\tPUSHMARK(sp);\n";
a0e9c8c7
NIS
1162 print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
1163 print qq/\tPUTBACK;\n/;
be6f3502 1164 print "\tboot_$stashxsub(NULL);\n";
a0e9c8c7 1165 print qq/\tSPAGAIN;\n/;
be6f3502
NIS
1166 }
1167 }
1168 print("\tFREETMPS;\n/* end bootstrapping code */\n");
a0e9c8c7 1169 print "}\n";
be6f3502
NIS
1170
1171print <<'EOT';
1172static void
1173dl_init()
1174{
1175 char *file = __FILE__;
1176 dTARG;
1177 djSP;
1178EOT
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";
a0e9c8c7 1187 print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
be6f3502 1188 print qq/\tPUTBACK;\n/;
af765ed9
VB
1189 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1190 warn "bootstrapping $stashname added to xs_init\n";
be6f3502 1191 print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
af765ed9 1192 print "\n#else\n";
be6f3502
NIS
1193 print "\tboot_$stashxsub(NULL);\n";
1194 print "#endif\n";
1195 print qq/\tSPAGAIN;\n/;
1196 }
af765ed9 1197 }
be6f3502 1198 print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
a0e9c8c7 1199 print "}\n";
af765ed9 1200}
a798dbf2
MB
1201sub 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
1211sub save_object {
1212 my $sv;
1213 foreach $sv (@_) {
1214 svref_2object($sv)->save;
1215 }
338a6d08
NIS
1216}
1217
1218sub Dummy_BootStrap { }
a798dbf2 1219
66a2622e
NIS
1220sub B::GV::savecv
1221{
1222 my $gv = shift;
1223 my $package=$gv->STASH->NAME;
1224 my $name = $gv->NAME;
1225 my $cv = $gv->CV;
7cf11ee8
NIS
1226 my $sv = $gv->SV;
1227 my $av = $gv->AV;
1228 my $hv = $gv->HV;
7cf11ee8 1229
66a2622e
NIS
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
7cf11ee8 1232 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
66a2622e 1233 #
7cf11ee8 1234 return unless ($unused_sub_packages{$package});
be6f3502
NIS
1235 return unless ($$cv || $$av || $$sv || $$hv);
1236 $gv->save;
66a2622e 1237}
5ed82aed 1238
66a2622e
NIS
1239sub mark_package
1240{
1241 my $package = shift;
1242 unless ($unused_sub_packages{$package})
1243 {
1244 no strict 'refs';
1245 $unused_sub_packages{$package} = 1;
475342a6 1246 if (@{$package.'::ISA'})
66a2622e
NIS
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 }
a0e9c8c7 1258# else
66a2622e
NIS
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
1272sub 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.
cf86991c 1278 # warn "Considering $package\n";#debug
66a2622e
NIS
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 {
cf86991c 1289 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
cfa4c8ee
VB
1290 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1291 return $unused_sub_packages{$package};
66a2622e
NIS
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" ||
cf86991c 1297 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
66a2622e 1298 {
cfa4c8ee 1299 delete_unsaved_hashINC($package);
66a2622e
NIS
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 }
cfa4c8ee 1311 delete_unsaved_hashINC($package);
66a2622e 1312 return $unused_sub_packages{$package} = 0;
a798dbf2 1313}
cfa4c8ee
VB
1314sub delete_unsaved_hashINC{
1315 my $packname=shift;
1316 $packname =~ s/\:\:/\//g;
1317 $packname .= '.pm';
59c10aa2 1318# warn "deleting $packname" if $INC{$packname} ;# debug
cfa4c8ee
VB
1319 delete $INC{$packname};
1320}
66a2622e
NIS
1321sub 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}
338a6d08
NIS
1342
1343
66a2622e
NIS
1344sub save_unused_subs
1345{
1346 no strict qw(refs);
a9b6343a 1347 &descend_marked_unused;
66a2622e
NIS
1348 warn "Prescan\n";
1349 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1350 warn "Saving methods\n";
1351 walksymtable(\%{"main::"}, "savecv", \&should_save);
a798dbf2
MB
1352}
1353
0cc1d052
NIS
1354sub 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;
56eca212 1360 my $amagic_generate= amagic_generation;
0cc1d052
NIS
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));",
56eca212
GS
1365 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1366 "PL_amagic_generation= $amagic_generate;" );
0cc1d052
NIS
1367}
1368
a9b6343a
VB
1369sub descend_marked_unused {
1370 foreach my $pack (keys %unused_sub_packages)
1371 {
1372 mark_package($pack);
1373 }
1374}
73544139 1375
a798dbf2 1376sub save_main {
66a2622e 1377 warn "Starting compile\n";
66a2622e 1378 warn "Walking tree\n";
73544139 1379 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
a798dbf2
MB
1380 walkoptree(main_root, "save");
1381 warn "done main optree, walking symtable for extras\n" if $debug_cv;
66a2622e 1382 save_unused_subs();
0cc1d052 1383 my $init_av = init_av->save;
81009501
GS
1384 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1385 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
5ab5c7a4 1386 "PL_initav = (AV *) $init_av;");
0cc1d052 1387 save_context();
5ed82aed 1388 warn "Writing output\n";
a798dbf2
MB
1389 output_boilerplate();
1390 print "\n";
1391 output_all("perl_init");
1392 print "\n";
1393 output_main();
1394}
1395
1396sub init_sections {
1397 my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1398 binop => \$binopsect, condop => \$condopsect,
66a2622e 1399 cop => \$copsect, gvop => \$gvopsect,
a798dbf2
MB
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,
af765ed9 1408 xpvio => \$xpviosect);
a798dbf2
MB
1409 my ($name, $sectref);
1410 while (($name, $sectref) = splice(@sections, 0, 2)) {
66a2622e 1411 $$sectref = new B::C::Section $name, \%symtable, 0;
a798dbf2 1412 }
0cc1d052
NIS
1413}
1414
1415sub mark_unused
1416{
1417 my ($arg,$val) = @_;
1418 $unused_sub_packages{$arg} = $val;
a798dbf2
MB
1419}
1420
1421sub 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;
0cc1d052 1463 mark_unused($arg,undef);
a798dbf2
MB
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
14941;
7f20e9dd
GS
1495
1496__END__
1497
1498=head1 NAME
1499
1500B::C - Perl compiler's C backend
1501
1502=head1 SYNOPSIS
1503
1504 perl -MO=C[,OPTIONS] foo.pl
1505
1506=head1 DESCRIPTION
1507
1a52ab62
MB
1508This compiler backend takes Perl source and generates C source code
1509corresponding to the internal structures that perl uses to run
1510your program. When the generated C source is compiled and run, it
1511cuts out the time which perl would have taken to load and parse
1512your program into its internal semi-compiled form. That means that
1513compiling with this backend will not help improve the runtime
1514execution speed of your program but may improve the start-up time.
1515Depending on the environment in which your program runs this may be
1516either a help or a hindrance.
1517
1518=head1 OPTIONS
1519
1520If there are any non-option arguments, they are taken to be
1521names of objects to be saved (probably doesn't work properly yet).
1522Without extra arguments, it saves the main program.
1523
1524=over 4
1525
1526=item B<-ofilename>
1527
1528Output to filename instead of STDOUT
1529
1530=item B<-v>
1531
1532Verbose compilation (currently gives a few compilation statistics).
1533
1534=item B<-->
1535
1536Force end of options
1537
1538=item B<-uPackname>
1539
1540Force apparently unused subs from package Packname to be compiled.
1541This allows programs to use eval "foo()" even when sub foo is never
1542seen to be used at compile time. The down side is that any subs which
1543really are never used also have code generated. This option is
1544necessary, for example, if you have a signal handler foo which you
1545initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1546to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1547options. The compiler tries to figure out which packages may possibly
1548have subs in which need compiling but the current version doesn't do
1549it very well. In particular, it is confused by nested packages (i.e.
1550of the form C<A::B>) where package C<A> does not contain any subs.
1551
1552=item B<-D>
1553
1554Debug options (concatenated or separate flags like C<perl -D>).
1555
1556=item B<-Do>
1557
1558OPs, prints each OP as it's processed
1559
1560=item B<-Dc>
1561
1562COPs, prints COPs as processed (incl. file & line num)
1563
1564=item B<-DA>
1565
1566prints AV information on saving
1567
1568=item B<-DC>
1569
1570prints CV information on saving
1571
1572=item B<-DM>
1573
1574prints MAGIC information on saving
1575
1576=item B<-f>
1577
1578Force optimisations on or off one at a time.
1579
1580=item B<-fcog>
1581
1582Copy-on-grow: PVs declared and initialised statically.
1583
1584=item B<-fno-cog>
1585
1586No copy-on-grow.
1587
1588=item B<-On>
1589
1590Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
1591B<-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
1598Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1599library directory. The utility called C<perlcc> may also be used to
1600help make use of this compiler.
1601
1602 perl -MO=C,-v,-DcA bar.pl > /dev/null
1603
1604=head1 BUGS
1605
1606Plenty. Current status: experimental.
7f20e9dd
GS
1607
1608=head1 AUTHOR
1609
1610Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
1611
1612=cut