3 # Copyright (c) 1996, 1997, 1998 Malcolm Beattie
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.
15 my $o = $class->SUPER::new(@_);
23 push(@{$section->[-1]},@_);
29 return scalar(@{$section->[-1]})-1;
34 my ($section, $fh, $format) = @_;
35 my $sym = $section->symtable || {};
36 my $default = $section->default;
37 foreach (@{$section->[-1]})
39 s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
40 printf $fh $format, $_;
47 @EXPORT_OK = qw(output_all output_boilerplate output_main mark_unused
48 init_sections set_callback save_unused_subs objsym save_context);
50 use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop
51 class cstring cchar svref_2object compile_stats comppadlist hash
52 threadsv_names main_cv init_av opnumber amagic_generation
54 use B::Asmdata qw(@specialsv_name);
64 my $anonsub_index = 0;
65 my $initsub_index = 0;
68 my $warn_undefined_syms;
70 my %unused_sub_packages;
72 my $pv_copy_on_grow = 0;
73 my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
77 @threadsv_names = threadsv_names();
81 my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect,
82 $gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
83 $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
84 $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
85 $xrvsect, $xpvbmsect, $xpviosect, $bootstrap);
87 sub walk_and_save_optree;
88 my $saveoptree_callback = \&walk_and_save_optree;
89 sub set_callback { $saveoptree_callback = shift }
90 sub saveoptree { &$saveoptree_callback(@_) }
92 sub walk_and_save_optree {
93 my ($name, $root, $start) = @_;
94 walkoptree($root, "save");
95 return objsym($start);
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.
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
109 my $OP_THREADSV = opnumber('threadsv');
112 my ($obj, $value) = @_;
113 my $sym = sprintf("s\\_%x", $$obj);
114 $symtable{$sym} = $value;
119 return $symtable{sprintf("s\\_%x", $$obj)};
126 return 0 if $sym eq "sym_0"; # special case
127 $value = $symtable{$sym};
128 if (defined($value)) {
131 warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
138 $pv = '' unless defined $pv; # Is this sane ?
141 if ($pv_copy_on_grow) {
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));
148 $pvmax = length($pv) + 1;
150 return ($pvsym, $pvmax);
154 my ($op, $level) = @_;
155 my $sym = objsym($op);
156 return $sym if defined $sym;
157 my $type = $op->type;
158 $nullop_count++ unless $type;
159 if ($type == $OP_THREADSV) {
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])));
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));
171 my ($class, %objdata) = @_;
172 bless \%objdata, $class;
175 sub 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);
183 sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
184 sub B::FAKEOP::type { $_[0]->{type} || 0}
185 sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
186 sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
187 sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
188 sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
189 sub B::FAKEOP::private { $_[0]->{private} || 0 }
192 my ($op, $level) = @_;
193 my $sym = objsym($op);
194 return $sym if defined $sym;
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));
203 my ($op, $level) = @_;
204 my $sym = objsym($op);
205 return $sym if defined $sym;
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));
213 sub B::LISTOP::save {
214 my ($op, $level) = @_;
215 my $sym = objsym($op);
216 return $sym if defined $sym;
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},
222 savesym($op, sprintf("(OP*)&listop_list[%d]", $listopsect->index));
226 my ($op, $level) = @_;
227 my $sym = objsym($op);
228 return $sym if defined $sym;
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));
236 sub B::CONDOP::save {
237 my ($op, $level) = @_;
238 my $sym = objsym($op);
239 return $sym if defined $sym;
240 $condopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x",
241 ${$op->next}, ${$op->sibling}, $op->ppaddr,
242 $op->targ, $op->type, $op_seq, $op->flags,
243 $op->private, ${$op->first}, ${$op->true},
245 savesym($op, sprintf("(OP*)&condop_list[%d]", $condopsect->index));
249 my ($op, $level) = @_;
250 my $sym = objsym($op);
251 return $sym if defined $sym;
252 #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
253 # peekop($op->redoop), peekop($op->nextop),
254 # peekop($op->lastop)); # debug
255 $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",
256 ${$op->next}, ${$op->sibling}, $op->ppaddr,
257 $op->targ, $op->type, $op_seq, $op->flags,
258 $op->private, ${$op->first}, ${$op->last},
259 $op->children, ${$op->redoop}, ${$op->nextop},
261 savesym($op, sprintf("(OP*)&loop_list[%d]", $loopsect->index));
265 my ($op, $level) = @_;
266 my $sym = objsym($op);
267 return $sym if defined $sym;
268 $pvopsect->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, cstring($op->pv)));
272 savesym($op, sprintf("(OP*)&pvop_list[%d]", $pvopsect->index));
276 my ($op, $level) = @_;
277 my $sym = objsym($op);
278 return $sym if defined $sym;
279 my $svsym = $op->sv->save;
280 $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
281 ${$op->next}, ${$op->sibling}, $op->ppaddr,
282 $op->targ, $op->type, $op_seq, $op->flags,
283 $op->private, "(SV*)$svsym"));
284 savesym($op, sprintf("(OP*)&svop_list[%d]", $svopsect->index));
288 my ($op, $level) = @_;
289 my $sym = objsym($op);
290 return $sym if defined $sym;
291 my $gvsym = $op->gv->save;
292 $gvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullgv",
293 ${$op->next}, ${$op->sibling}, $op->ppaddr,
294 $op->targ, $op->type, $op_seq, $op->flags,
296 $init->add(sprintf("gvop_list[%d].op_gv = %s;", $gvopsect->index, $gvsym));
297 savesym($op, sprintf("(OP*)&gvop_list[%d]", $gvopsect->index));
301 my ($op, $level) = @_;
302 my $sym = objsym($op);
303 return $sym if defined $sym;
304 my $gvsym = $op->filegv->save;
305 my $stashsym = $op->stash->save;
306 warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV)
308 $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u",
309 ${$op->next}, ${$op->sibling}, $op->ppaddr,
310 $op->targ, $op->type, $op_seq, $op->flags,
311 $op->private, cstring($op->label), $op->cop_seq,
312 $op->arybase, $op->line));
313 my $copix = $copsect->index;
314 $init->add(sprintf("cop_list[%d].cop_filegv = %s;", $copix, $gvsym),
315 sprintf("cop_list[%d].cop_stash = %s;", $copix, $stashsym));
316 savesym($op, "(OP*)&cop_list[$copix]");
320 my ($op, $level) = @_;
321 my $sym = objsym($op);
322 return $sym if defined $sym;
323 my $replroot = $op->pmreplroot;
324 my $replstart = $op->pmreplstart;
325 my $replrootfield = sprintf("s\\_%x", $$replroot);
326 my $replstartfield = sprintf("s\\_%x", $$replstart);
328 my $ppaddr = $op->ppaddr;
330 # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
331 # argument to a split) stores a GV in op_pmreplroot instead
332 # of a substitution syntax tree. We don't want to walk that...
333 if ($ppaddr eq "pp_pushre") {
334 $gvsym = $replroot->save;
335 # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
338 $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
341 # pmnext handling is broken in perl itself, I think. Bad op_pmnext
342 # fields aren't noticed in perl's runtime (unless you try reset) but we
343 # segfault when trying to dereference it to find op->op_pmnext->op_type
344 $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",
345 ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ,
346 $op->type, $op_seq, $op->flags, $op->private,
347 ${$op->first}, ${$op->last}, $op->children,
348 $replrootfield, $replstartfield,
349 $op->pmflags, $op->pmpermflags,));
350 my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
351 my $re = $op->precomp;
353 my $resym = sprintf("re%d", $re_index++);
354 $decl->add(sprintf("static char *$resym = %s;", cstring($re)));
355 $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
359 $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
361 savesym($op, sprintf("(OP*)&pmop_list[%d]", $pmopsect->index));
364 sub B::SPECIAL::save {
366 # special case: $$sv is not the address but an index into specialsv_list
367 # warn "SPECIAL::save specialsv $$sv\n"; # debug
368 my $sym = $specialsv_name[$$sv];
369 if (!defined($sym)) {
370 confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
375 sub B::OBJECT::save {}
379 my $sym = objsym($sv);
380 return $sym if defined $sym;
381 # warn "Saving SVt_NULL SV\n"; # debug
384 # warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
386 $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT + 1, $sv->FLAGS));
387 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
392 my $sym = objsym($sv);
393 return $sym if defined $sym;
394 $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
395 $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
396 $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
397 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
402 my $sym = objsym($sv);
403 return $sym if defined $sym;
405 $val .= '.00' if $val =~ /^-?\d+$/;
406 $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
407 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
408 $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
409 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
414 my $sym = objsym($sv);
415 return $sym if defined $sym;
417 my $len = length($pv);
418 my ($pvsym, $pvmax) = savepv($pv);
419 my ($lvtarg, $lvtarg_sym);
420 $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
421 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
422 $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
423 $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
424 $xpvlvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
425 if (!$pv_copy_on_grow) {
426 $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);",
427 $xpvlvsect->index, cstring($pv), $len));
430 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
435 my $sym = objsym($sv);
436 return $sym if defined $sym;
438 my $len = length($pv);
439 my ($pvsym, $pvmax) = savepv($pv);
440 $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
441 $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
442 $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
443 if (!$pv_copy_on_grow) {
444 $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);",
445 $xpvivsect->index, cstring($pv), $len));
447 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
452 my $sym = objsym($sv);
453 return $sym if defined $sym;
455 $pv = '' unless defined $pv;
456 my $len = length($pv);
457 my ($pvsym, $pvmax) = savepv($pv);
459 $val .= '.00' if $val =~ /^-?\d+$/;
460 $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
461 $pvsym, $len, $pvmax, $sv->IVX, $val));
462 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
463 $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
464 if (!$pv_copy_on_grow) {
465 $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);",
466 $xpvnvsect->index, cstring($pv), $len));
468 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
473 my $sym = objsym($sv);
474 return $sym if defined $sym;
475 my $pv = $sv->PV . "\0" . $sv->TABLE;
476 my $len = length($pv);
477 $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
478 $len, $len + 258, $sv->IVX, $sv->NVX,
479 $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
480 $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
481 $xpvbmsect->index, $sv->REFCNT + 1, $sv->FLAGS));
483 $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);",
484 $xpvbmsect->index, cstring($pv), $len),
485 sprintf("xpvbm_list[%d].xpv_cur = %u;",
486 $xpvbmsect->index, $len - 257));
487 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
492 my $sym = objsym($sv);
493 return $sym if defined $sym;
495 my $len = length($pv);
496 my ($pvsym, $pvmax) = savepv($pv);
497 $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
498 $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
499 $xpvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
500 if (!$pv_copy_on_grow) {
501 $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);",
502 $xpvsect->index, cstring($pv), $len));
504 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
509 my $sym = objsym($sv);
510 return $sym if defined $sym;
512 my $len = length($pv);
513 my ($pvsym, $pvmax) = savepv($pv);
514 $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
515 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
516 $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
517 $xpvmgsect->index, $sv->REFCNT + 1, $sv->FLAGS));
518 if (!$pv_copy_on_grow) {
519 $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);",
520 $xpvmgsect->index, cstring($pv), $len));
522 $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
527 sub B::PVMG::save_magic {
529 #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
530 my $stash = $sv->SvSTASH;
533 warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
535 # XXX Hope stash is already going to be saved.
536 $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
538 my @mgchain = $sv->MAGIC;
539 my ($mg, $type, $obj, $ptr,$len,$ptrsv);
540 foreach $mg (@mgchain) {
546 warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
547 class($sv), $$sv, class($obj), $$obj,
548 cchar($type), cstring($ptr));
551 if ($len == HEf_SVKEY){
552 #The pointer is an SV*
553 $ptrsv=svref_2object($ptr)->save;
554 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
555 $$sv, $$obj, cchar($type),$ptrsv,$len));
557 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
558 $$sv, $$obj, cchar($type),cstring($ptr),$len));
565 my $sym = objsym($sv);
566 return $sym if defined $sym;
567 my $rv = $sv->RV->save;
568 $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/;
570 $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
571 $xrvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
572 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
576 my ($cvstashname, $cvname) = @_;
577 warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
578 # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
579 # use should be handled by the class itself.
581 my $isa = \@{"$cvstashname\::ISA"};
582 if (grep($_ eq "AutoLoader", @$isa)) {
583 warn "Forcing immediate load of sub derived from AutoLoader\n";
584 # Tweaked version of AutoLoader::AUTOLOAD
585 my $dir = $cvstashname;
587 eval { require "auto/$dir/$cvname.al" };
589 warn qq(failed require "auto/$dir/$cvname.al": $@\n);
599 my $sym = objsym($cv);
601 # warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
604 # Reserve a place in svsect and xpvcvsect and record indices
605 my $sv_ix = $svsect->index + 1;
606 $svsect->add("svix$sv_ix");
607 my $xpvcv_ix = $xpvcvsect->index + 1;
608 $xpvcvsect->add("xpvcvix$xpvcv_ix");
609 # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
610 $sym = savesym($cv, "&sv_list[$sv_ix]");
611 warn sprintf("saving CV 0x%x as $sym\n", $$cv) if $debug_cv;
613 my $cvstashname = $gv->STASH->NAME;
614 my $cvname = $gv->NAME;
615 my $root = $cv->ROOT;
616 my $cvxsub = $cv->XSUB;
617 if (!$$root && !$cvxsub) {
618 if (try_autoload($cvstashname, $cvname)) {
619 # Recalculate root and xsub
622 if ($$root || $cvxsub) {
623 warn "Successful forced autoload\n";
628 my $padlist = $cv->PADLIST;
631 my $xsubany = "Nullany";
633 warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
634 $$cv, $$root) if $debug_cv;
637 my $stashname = $gv->STASH->NAME;
638 my $gvname = $gv->NAME;
639 if ($gvname ne "__ANON__") {
640 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
641 $ppname .= ($stashname eq "main") ?
642 $gvname : "$stashname\::$gvname";
643 $ppname =~ s/::/__/g;
644 if ($gvname eq "INIT"){
645 $ppname .= "_$initsub_index";
651 $ppname = "pp_anonsub_$anonsub_index";
654 $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
655 warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
656 $$cv, $ppname, $$root) if $debug_cv;
658 warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
659 $$padlist, $$cv) if $debug_cv;
661 warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
662 $$padlist, $$cv) if $debug_cv;
666 $xsubany = sprintf("ANYINIT((void*)0x%x)", $cv->XSUBANY);
667 # Try to find out canonical name of XSUB function from EGV.
668 # XXX Doesn't work for XSUBs with PREFIX set (or anyone who
669 # calls newXS() manually with weird arguments).
671 my $stashname = $egv->STASH->NAME;
672 $stashname =~ s/::/__/g;
673 $xsub = sprintf("XS_%s_%s", $stashname, $egv->NAME);
674 $decl->add("void $xsub (CV*));";
677 warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
678 $cvstashname, $cvname); # debug
680 $pv = '' unless defined $pv; # Avoid use of undef warnings
681 $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",
682 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
683 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
684 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
686 if (${$cv->OUTSIDE} == ${main_cv()}){
687 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
688 $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
693 $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
694 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
695 $$gv, $$cv) if $debug_cv;
697 my $filegv = $cv->FILEGV;
700 $init->add(sprintf("CvFILEGV(s\\_%x) = s\\_%x;", $$cv, $$filegv));
701 warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n",
702 $$filegv, $$cv) if $debug_cv;
704 my $stash = $cv->STASH;
707 $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
708 warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
709 $$stash, $$cv) if $debug_cv;
711 $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
712 $sv_ix, $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS));
717 my ($gv,$skip_cv) = @_;
718 my $sym = objsym($gv);
720 #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
723 my $ix = $gv_index++;
724 $sym = savesym($gv, "gv_list[$ix]");
725 #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
727 my $gvname = $gv->NAME;
728 my $name = cstring($gv->STASH->NAME . "::" . $gvname);
729 #warn "GV name is $name\n"; # debug
733 #warn(sprintf("EGV name is %s, saving it now\n",
734 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
735 $egvsym = $egv->save;
737 $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
738 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
739 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS),
740 sprintf("GvLINE($sym) = %u;", $gv->LINE));
741 # Shouldn't need to do save_magic since gv_fetchpv handles that
743 my $refcnt = $gv->REFCNT + 1;
744 $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
745 my $gvrefcnt = $gv->GvREFCNT;
747 $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
749 if (defined($egvsym)) {
750 # Shared glob *foo = *bar
751 $init->add("gp_free($sym);",
752 "GvGP($sym) = GvGP($egvsym);");
753 } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
754 # Don't save subfields of special GVs (*_, *1, *# and so on)
755 # warn "GV::save saving subfields\n"; # debug
759 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
760 # warn "GV::save \$$name\n"; # debug
765 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
766 # warn "GV::save \@$name\n"; # debug
771 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
772 # warn "GV::save \%$name\n"; # debug
775 if ($$gvcv && !$skip_cv) {
777 $init->add(sprintf("GvCV($sym) = (CV*)s\\_%x;", $$gvcv));
778 # warn "GV::save &$name\n"; # debug
780 my $gvfilegv = $gv->FILEGV;
783 $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv));
784 # warn "GV::save GvFILEGV(*$name)\n"; # debug
786 my $gvform = $gv->FORM;
789 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
790 # warn "GV::save GvFORM(*$name)\n"; # debug
795 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
796 # warn "GV::save GvIO(*$name)\n"; # debug
803 my $sym = objsym($av);
804 return $sym if defined $sym;
805 my $avflags = $av->AvFLAGS;
806 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
808 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
809 $xpvavsect->index, $av->REFCNT + 1, $av->FLAGS));
810 my $sv_list_index = $svsect->index;
811 my $fill = $av->FILL;
813 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
815 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
816 #if ($fill > -1 && ($avflags & AVf_REAL)) {
818 my @array = $av->ARRAY;
822 foreach $el (@array) {
823 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
824 $$av, $i++, class($el), $$el);
827 my @names = map($_->save, @array);
828 # XXX Better ways to write loop?
829 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
830 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
833 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
834 "\tav_extend(av, $fill);",
835 "\tsvp = AvARRAY(av);",
836 map("\t*svp++ = (SV*)$_;", @names),
837 "\tAvFILLp(av) = $fill;",
841 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
844 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
849 my $sym = objsym($hv);
850 return $sym if defined $sym;
851 my $name = $hv->NAME;
855 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
856 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
857 # a trashed op but we look at the trashed op_type and segfault.
858 #my $adpmroot = ${$hv->PMROOT};
860 $decl->add("static HV *hv$hv_index;");
861 # XXX Beware of weird package names containing double-quotes, \n, ...?
862 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
864 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
867 $sym = savesym($hv, "hv$hv_index");
871 # It's just an ordinary HV
872 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
873 $hv->MAX, $hv->RITER));
874 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
875 $xpvhvsect->index, $hv->REFCNT + 1, $hv->FLAGS));
876 my $sv_list_index = $svsect->index;
877 my @contents = $hv->ARRAY;
880 for ($i = 1; $i < @contents; $i += 2) {
881 $contents[$i] = $contents[$i]->save;
883 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
885 my ($key, $value) = splice(@contents, 0, 2);
886 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
887 cstring($key),length($key),$value, hash($key)));
888 # $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
889 # cstring($key),length($key),$value, 0));
894 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
899 my $sym = objsym($io);
900 return $sym if defined $sym;
902 $pv = '' unless defined $pv;
903 my $len = length($pv);
904 $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",
905 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
906 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
907 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
908 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
909 cchar($io->IoTYPE), $io->IoFLAGS));
910 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
911 $xpviosect->index, $io->REFCNT + 1, $io->FLAGS));
912 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
914 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
915 $fsym = $io->$field();
917 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
927 # This is where we catch an honest-to-goodness Nullsv (which gets
928 # blessed into B::SV explicitly) and any stray erroneous SVs.
929 return 0 unless $$sv;
930 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
935 my $init_name = shift;
937 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
938 $listopsect, $pmopsect, $svopsect, $gvopsect, $pvopsect,
939 $loopsect, $copsect, $svsect, $xpvsect,
940 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
941 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
942 $bootstrap->output(\*STDOUT, "/* bootstrap %s */\n");
943 $symsect->output(\*STDOUT, "#define %s\n");
945 output_declarations();
946 foreach $section (@sections) {
947 my $lines = $section->index + 1;
949 my $name = $section->name;
950 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
951 print "Static $typename ${name}_list[$lines];\n";
954 $decl->output(\*STDOUT, "%s\n");
956 foreach $section (@sections) {
957 my $lines = $section->index + 1;
959 my $name = $section->name;
960 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
961 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
962 $section->output(\*STDOUT, "\t{ %s },\n");
968 static int $init_name()
972 $init->output(\*STDOUT, "\t%s\n");
973 print "\treturn 0;\n}\n";
975 warn compile_stats();
976 warn "NULLOP count: $nullop_count\n";
980 sub output_declarations {
982 #ifdef BROKEN_STATIC_REDECL
983 #define Static extern
985 #define Static static
986 #endif /* BROKEN_STATIC_REDECL */
988 #ifdef BROKEN_UNION_INIT
990 * Cribbed from cv.h with ANY (a union) replaced by void*.
991 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
994 char * xpv_pv; /* pointer to malloced string */
995 STRLEN xpv_cur; /* length of xp_pv as a C string */
996 STRLEN xpv_len; /* allocated size */
997 IV xof_off; /* integer value */
998 double xnv_nv; /* numeric value, if any */
999 MAGIC* xmg_magic; /* magic for scalar array */
1000 HV* xmg_stash; /* class package */
1005 void (*xcv_xsub) (CV*);
1009 long xcv_depth; /* >= 2 indicates recursive call */
1013 perl_mutex *xcv_mutexp;
1014 struct perl_thread *xcv_owner; /* current owner thread */
1015 #endif /* USE_THREADS */
1018 #define ANYINIT(i) i
1020 #define XPVCV_or_similar XPVCV
1021 #define ANYINIT(i) {i}
1022 #endif /* BROKEN_UNION_INIT */
1023 #define Nullany ANYINIT(0)
1029 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1034 sub output_boilerplate {
1039 /* Workaround for mapstart: the only op which needs a different ppaddr */
1041 #define pp_mapstart pp_grepstart
1042 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1043 EXTERN_C void boot_DynaLoader (CV* cv);
1045 static void xs_init (void);
1046 static PerlInterpreter *my_perl;
1053 #ifndef CAN_PROTOTYPE
1054 main(argc, argv, env)
1058 #else /* def(CAN_PROTOTYPE) */
1059 main(int argc, char **argv, char **env)
1060 #endif /* def(CAN_PROTOTYPE) */
1066 PERL_SYS_INIT(&argc,&argv);
1068 perl_init_i18nl10n(1);
1070 if (!PL_do_undump) {
1071 my_perl = perl_alloc();
1074 perl_construct( my_perl );
1079 PL_cshlen = strlen(PL_cshname);
1082 #ifdef ALLOW_PERL_OPTIONS
1083 #define EXTRA_OPTIONS 2
1085 #define EXTRA_OPTIONS 3
1086 #endif /* ALLOW_PERL_OPTIONS */
1087 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1088 fakeargv[0] = argv[0];
1091 #ifndef ALLOW_PERL_OPTIONS
1093 #endif /* ALLOW_PERL_OPTIONS */
1094 for (i = 1; i < argc; i++)
1095 fakeargv[i + EXTRA_OPTIONS] = argv[i];
1096 fakeargv[argc + EXTRA_OPTIONS] = 0;
1098 exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1103 sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1104 PL_main_cv = PL_compcv;
1107 exitstatus = perl_init();
1111 exitstatus = perl_run( my_perl );
1113 perl_destruct( my_perl );
1114 perl_free( my_perl );
1119 /* yanked from perl.c */
1123 char *file = __FILE__;
1125 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
1133 warn "----Symbol table:\n";
1134 while (($sym, $val) = each %symtable) {
1135 warn "$sym => $val\n";
1137 warn "---End of symbol table\n";
1143 svref_2object($sv)->save;
1147 sub Dummy_BootStrap { }
1152 my $package=$gv->STASH->NAME;
1153 my $name = $gv->NAME;
1160 # We may be looking at this package just because it is a branch in the
1161 # symbol table which is on the path to a package which we need to save
1162 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1164 return unless ($unused_sub_packages{$package});
1167 if ($name eq "bootstrap" && $cv->XSUB)
1169 my $file = $cv->FILEGV->SV->PV;
1170 $bootstrap->add($file);
1171 my $name = $gv->STASH->NAME.'::'.$name;
1173 *{$name} = \&Dummy_BootStrap;
1176 warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
1177 $package, $name, $$cv, $$gv) if ($debug_cv);
1181 return unless ($$av || $$sv || $$hv)
1183 $gv->save($skip_cv);
1188 my $package = shift;
1189 unless ($unused_sub_packages{$package})
1192 $unused_sub_packages{$package} = 1;
1193 if (defined(@{$package.'::ISA'}))
1195 foreach my $isa (@{$package.'::ISA'})
1197 if ($isa eq 'DynaLoader')
1199 unless (defined(&{$package.'::bootstrap'}))
1201 warn "Forcing bootstrap of $package\n";
1202 eval { $package->bootstrap };
1207 unless ($unused_sub_packages{$isa})
1209 warn "$isa saved (it is in $package\'s \@ISA)\n";
1221 no strict qw(vars refs);
1222 my $package = shift;
1223 $package =~ s/::$//;
1224 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1225 # warn "Considering $package\n";#debug
1226 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1228 # If this package is a prefix to something we are saving, traverse it
1229 # but do not mark it for saving if it is not already
1230 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1232 return 1 if ($u =~ /^$package\:\:/);
1234 if (exists $unused_sub_packages{$package})
1236 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1237 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1238 return $unused_sub_packages{$package};
1240 # Omit the packages which we use (and which cause grief
1241 # because of fancy "goto &$AUTOLOAD" stuff).
1242 # XXX Surely there must be a nicer way to do this.
1243 if ($package eq "FileHandle" || $package eq "Config" ||
1244 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1246 delete_unsaved_hashINC($package);
1247 return $unused_sub_packages{$package} = 0;
1249 # Now see if current package looks like an OO class this is probably too strong.
1250 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1252 if ($package->can($m))
1254 warn "$package has method $m: saving package\n";#debug
1255 return mark_package($package);
1258 delete_unsaved_hashINC($package);
1259 return $unused_sub_packages{$package} = 0;
1261 sub delete_unsaved_hashINC{
1263 $packname =~ s/\:\:/\//g;
1265 # warn "deleting $packname" if $INC{$packname} ;# debug
1266 delete $INC{$packname};
1270 my ($symref, $recurse, $prefix) = @_;
1275 $prefix = '' unless defined $prefix;
1276 while (($sym, $ref) = each %$symref)
1281 $sym = $prefix . $sym;
1282 if ($sym ne "main::" && &$recurse($sym))
1284 walkpackages(\%glob, $recurse, $sym);
1291 sub save_unused_subs
1294 &descend_marked_unused;
1296 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1297 warn "Saving methods\n";
1298 walksymtable(\%{"main::"}, "savecv", \&should_save);
1303 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1304 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1305 my $inc_hv = svref_2object(\%INC)->save;
1306 my $inc_av = svref_2object(\@INC)->save;
1307 my $amagic_generate= amagic_generation;
1308 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1309 "GvHV(PL_incgv) = $inc_hv;",
1310 "GvAV(PL_incgv) = $inc_av;",
1311 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1312 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1313 "PL_amagic_generation= $amagic_generate;" );
1316 sub descend_marked_unused {
1317 foreach my $pack (keys %unused_sub_packages)
1319 mark_package($pack);
1324 warn "Starting compile\n";
1325 warn "Walking tree\n";
1326 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1327 walkoptree(main_root, "save");
1328 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1330 my $init_av = init_av->save;
1331 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1332 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1333 "PL_initav = (AV *) $init_av;");
1335 warn "Writing output\n";
1336 output_boilerplate();
1338 output_all("perl_init");
1344 my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1345 binop => \$binopsect, condop => \$condopsect,
1346 cop => \$copsect, gvop => \$gvopsect,
1347 listop => \$listopsect, logop => \$logopsect,
1348 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1349 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1350 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1351 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1352 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1353 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1354 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1355 xpvio => \$xpviosect, bootstrap => \$bootstrap);
1356 my ($name, $sectref);
1357 while (($name, $sectref) = splice(@sections, 0, 2)) {
1358 $$sectref = new B::C::Section $name, \%symtable, 0;
1364 my ($arg,$val) = @_;
1365 $unused_sub_packages{$arg} = $val;
1370 my ($option, $opt, $arg);
1372 while ($option = shift @options) {
1373 if ($option =~ /^-(.)(.*)/) {
1377 unshift @options, $option;
1380 if ($opt eq "-" && $arg eq "-") {
1385 $warn_undefined_syms = 1;
1386 } elsif ($opt eq "D") {
1387 $arg ||= shift @options;
1388 foreach $arg (split(//, $arg)) {
1391 } elsif ($arg eq "c") {
1393 } elsif ($arg eq "A") {
1395 } elsif ($arg eq "C") {
1397 } elsif ($arg eq "M") {
1400 warn "ignoring unknown debug option: $arg\n";
1403 } elsif ($opt eq "o") {
1404 $arg ||= shift @options;
1405 open(STDOUT, ">$arg") or return "$arg: $!\n";
1406 } elsif ($opt eq "v") {
1408 } elsif ($opt eq "u") {
1409 $arg ||= shift @options;
1410 mark_unused($arg,undef);
1411 } elsif ($opt eq "f") {
1412 $arg ||= shift @options;
1413 if ($arg eq "cog") {
1414 $pv_copy_on_grow = 1;
1415 } elsif ($arg eq "no-cog") {
1416 $pv_copy_on_grow = 0;
1418 } elsif ($opt eq "O") {
1419 $arg = 1 if $arg eq "";
1420 $pv_copy_on_grow = 0;
1422 # Optimisations for -O1
1423 $pv_copy_on_grow = 1;
1431 foreach $objname (@options) {
1432 eval "save_object(\\$objname)";
1437 return sub { save_main() };
1447 B::C - Perl compiler's C backend
1451 perl -MO=C[,OPTIONS] foo.pl
1455 This compiler backend takes Perl source and generates C source code
1456 corresponding to the internal structures that perl uses to run
1457 your program. When the generated C source is compiled and run, it
1458 cuts out the time which perl would have taken to load and parse
1459 your program into its internal semi-compiled form. That means that
1460 compiling with this backend will not help improve the runtime
1461 execution speed of your program but may improve the start-up time.
1462 Depending on the environment in which your program runs this may be
1463 either a help or a hindrance.
1467 If there are any non-option arguments, they are taken to be
1468 names of objects to be saved (probably doesn't work properly yet).
1469 Without extra arguments, it saves the main program.
1475 Output to filename instead of STDOUT
1479 Verbose compilation (currently gives a few compilation statistics).
1483 Force end of options
1487 Force apparently unused subs from package Packname to be compiled.
1488 This allows programs to use eval "foo()" even when sub foo is never
1489 seen to be used at compile time. The down side is that any subs which
1490 really are never used also have code generated. This option is
1491 necessary, for example, if you have a signal handler foo which you
1492 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1493 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1494 options. The compiler tries to figure out which packages may possibly
1495 have subs in which need compiling but the current version doesn't do
1496 it very well. In particular, it is confused by nested packages (i.e.
1497 of the form C<A::B>) where package C<A> does not contain any subs.
1501 Debug options (concatenated or separate flags like C<perl -D>).
1505 OPs, prints each OP as it's processed
1509 COPs, prints COPs as processed (incl. file & line num)
1513 prints AV information on saving
1517 prints CV information on saving
1521 prints MAGIC information on saving
1525 Force optimisations on or off one at a time.
1529 Copy-on-grow: PVs declared and initialised statically.
1537 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
1538 B<-O1> and higher set B<-fcog>.
1542 perl -MO=C,-ofoo.c foo.pl
1543 perl cc_harness -o foo foo.c
1545 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1546 library directory. The utility called C<perlcc> may also be used to
1547 help make use of this compiler.
1549 perl -MO=C,-v,-DcA bar.pl > /dev/null
1553 Plenty. Current status: experimental.
1557 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>