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