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