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