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