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