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;
69 my $warn_undefined_syms;
71 my %unused_sub_packages;
73 my $pv_copy_on_grow = 0;
74 my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
78 @threadsv_names = threadsv_names();
82 my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect,
83 $gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
84 $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
85 $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
86 $xrvsect, $xpvbmsect, $xpviosect );
88 sub walk_and_save_optree;
89 my $saveoptree_callback = \&walk_and_save_optree;
90 sub set_callback { $saveoptree_callback = shift }
91 sub saveoptree { &$saveoptree_callback(@_) }
93 sub walk_and_save_optree {
94 my ($name, $root, $start) = @_;
95 walkoptree($root, "save");
96 return objsym($start);
99 # Current workaround/fix for op_free() trying to free statically
100 # defined OPs is to set op_seq = -1 and check for that in op_free().
101 # Instead of hardwiring -1 in place of $op->seq, we use $op_seq
102 # so that it can be changed back easily if necessary. In fact, to
103 # stop compilers from moaning about a U16 being initialised with an
104 # uncast -1 (the printf format is %d so we can't tweak it), we have
105 # to "know" that op_seq is a U16 and use 65535. Ugh.
108 # Look this up here so we can do just a number compare
109 # rather than looking up the name of every BASEOP in B::OP
110 my $OP_THREADSV = opnumber('threadsv');
113 my ($obj, $value) = @_;
114 my $sym = sprintf("s\\_%x", $$obj);
115 $symtable{$sym} = $value;
120 return $symtable{sprintf("s\\_%x", $$obj)};
127 return 0 if $sym eq "sym_0"; # special case
128 $value = $symtable{$sym};
129 if (defined($value)) {
132 warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
139 $pv = '' unless defined $pv; # Is this sane ?
142 if ($pv_copy_on_grow) {
143 my $cstring = cstring($pv);
144 if ($cstring ne "0") { # sic
145 $pvsym = sprintf("pv%d", $pv_index++);
146 $decl->add(sprintf("static char %s[] = %s;", $pvsym, $cstring));
149 $pvmax = length($pv) + 1;
151 return ($pvsym, $pvmax);
155 my ($op, $level) = @_;
156 my $sym = objsym($op);
157 return $sym if defined $sym;
158 my $type = $op->type;
159 $nullop_count++ unless $type;
160 if ($type == $OP_THREADSV) {
161 # saves looking up ppaddr but it's a bit naughty to hard code this
162 $init->add(sprintf("(void)find_threadsv(%s);",
163 cstring($threadsv_names[$op->targ])));
165 $opsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x",
166 ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
167 $type, $op_seq, $op->flags, $op->private));
168 savesym($op, sprintf("&op_list[%d]", $opsect->index));
172 my ($class, %objdata) = @_;
173 bless \%objdata, $class;
176 sub B::FAKEOP::save {
177 my ($op, $level) = @_;
178 $opsect->add(sprintf("%s, %s, %s, %u, %u, %u, 0x%x, 0x%x",
179 $op->next, $op->sibling, $op->ppaddr, $op->targ,
180 $op->type, $op_seq, $op->flags, $op->private));
181 return sprintf("&op_list[%d]", $opsect->index);
184 sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
185 sub B::FAKEOP::type { $_[0]->{type} || 0}
186 sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
187 sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
188 sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
189 sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
190 sub B::FAKEOP::private { $_[0]->{private} || 0 }
193 my ($op, $level) = @_;
194 my $sym = objsym($op);
195 return $sym if defined $sym;
196 $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x",
197 ${$op->next}, ${$op->sibling}, $op->ppaddr,
198 $op->targ, $op->type, $op_seq, $op->flags,
199 $op->private, ${$op->first}));
200 savesym($op, sprintf("(OP*)&unop_list[%d]", $unopsect->index));
204 my ($op, $level) = @_;
205 my $sym = objsym($op);
206 return $sym if defined $sym;
207 $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
208 ${$op->next}, ${$op->sibling}, $op->ppaddr,
209 $op->targ, $op->type, $op_seq, $op->flags,
210 $op->private, ${$op->first}, ${$op->last}));
211 savesym($op, sprintf("(OP*)&binop_list[%d]", $binopsect->index));
214 sub B::LISTOP::save {
215 my ($op, $level) = @_;
216 my $sym = objsym($op);
217 return $sym if defined $sym;
218 $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u",
219 ${$op->next}, ${$op->sibling}, $op->ppaddr,
220 $op->targ, $op->type, $op_seq, $op->flags,
221 $op->private, ${$op->first}, ${$op->last},
223 savesym($op, sprintf("(OP*)&listop_list[%d]", $listopsect->index));
227 my ($op, $level) = @_;
228 my $sym = objsym($op);
229 return $sym if defined $sym;
230 $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
231 ${$op->next}, ${$op->sibling}, $op->ppaddr,
232 $op->targ, $op->type, $op_seq, $op->flags,
233 $op->private, ${$op->first}, ${$op->other}));
234 savesym($op, sprintf("(OP*)&logop_list[%d]", $logopsect->index));
238 my ($op, $level) = @_;
239 my $sym = objsym($op);
240 return $sym if defined $sym;
241 #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
242 # peekop($op->redoop), peekop($op->nextop),
243 # peekop($op->lastop)); # debug
244 $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",
245 ${$op->next}, ${$op->sibling}, $op->ppaddr,
246 $op->targ, $op->type, $op_seq, $op->flags,
247 $op->private, ${$op->first}, ${$op->last},
248 $op->children, ${$op->redoop}, ${$op->nextop},
250 savesym($op, sprintf("(OP*)&loop_list[%d]", $loopsect->index));
254 my ($op, $level) = @_;
255 my $sym = objsym($op);
256 return $sym if defined $sym;
257 $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
258 ${$op->next}, ${$op->sibling}, $op->ppaddr,
259 $op->targ, $op->type, $op_seq, $op->flags,
260 $op->private, cstring($op->pv)));
261 savesym($op, sprintf("(OP*)&pvop_list[%d]", $pvopsect->index));
265 my ($op, $level) = @_;
266 my $sym = objsym($op);
267 return $sym if defined $sym;
268 my $svsym = $op->sv->save;
269 $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
270 ${$op->next}, ${$op->sibling}, $op->ppaddr,
271 $op->targ, $op->type, $op_seq, $op->flags,
272 $op->private, "(SV*)$svsym"));
273 savesym($op, sprintf("(OP*)&svop_list[%d]", $svopsect->index));
277 my ($op, $level) = @_;
278 my $sym = objsym($op);
279 return $sym if defined $sym;
280 my $gvsym = $op->gv->save;
281 $gvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullgv",
282 ${$op->next}, ${$op->sibling}, $op->ppaddr,
283 $op->targ, $op->type, $op_seq, $op->flags,
285 $init->add(sprintf("gvop_list[%d].op_gv = %s;", $gvopsect->index, $gvsym));
286 savesym($op, sprintf("(OP*)&gvop_list[%d]", $gvopsect->index));
290 my ($op, $level) = @_;
291 my $sym = objsym($op);
292 return $sym if defined $sym;
293 my $gvsym = $op->filegv->save;
294 my $stashsym = $op->stash->save;
295 warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV)
297 $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u",
298 ${$op->next}, ${$op->sibling}, $op->ppaddr,
299 $op->targ, $op->type, $op_seq, $op->flags,
300 $op->private, cstring($op->label), $op->cop_seq,
301 $op->arybase, $op->line));
302 my $copix = $copsect->index;
303 $init->add(sprintf("cop_list[%d].cop_filegv = %s;", $copix, $gvsym),
304 sprintf("cop_list[%d].cop_stash = %s;", $copix, $stashsym));
305 savesym($op, "(OP*)&cop_list[$copix]");
309 my ($op, $level) = @_;
310 my $sym = objsym($op);
311 return $sym if defined $sym;
312 my $replroot = $op->pmreplroot;
313 my $replstart = $op->pmreplstart;
314 my $replrootfield = sprintf("s\\_%x", $$replroot);
315 my $replstartfield = sprintf("s\\_%x", $$replstart);
317 my $ppaddr = $op->ppaddr;
319 # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
320 # argument to a split) stores a GV in op_pmreplroot instead
321 # of a substitution syntax tree. We don't want to walk that...
322 if ($op->name eq "pushre") {
323 $gvsym = $replroot->save;
324 # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
327 $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
330 # pmnext handling is broken in perl itself, I think. Bad op_pmnext
331 # fields aren't noticed in perl's runtime (unless you try reset) but we
332 # segfault when trying to dereference it to find op->op_pmnext->op_type
333 $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",
334 ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ,
335 $op->type, $op_seq, $op->flags, $op->private,
336 ${$op->first}, ${$op->last}, $op->children,
337 $replrootfield, $replstartfield,
338 $op->pmflags, $op->pmpermflags,));
339 my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
340 my $re = $op->precomp;
342 my $resym = sprintf("re%d", $re_index++);
343 $decl->add(sprintf("static char *$resym = %s;", cstring($re)));
344 $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
348 $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
350 savesym($op, sprintf("(OP*)&pmop_list[%d]", $pmopsect->index));
353 sub B::SPECIAL::save {
355 # special case: $$sv is not the address but an index into specialsv_list
356 # warn "SPECIAL::save specialsv $$sv\n"; # debug
357 my $sym = $specialsv_name[$$sv];
358 if (!defined($sym)) {
359 confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
364 sub B::OBJECT::save {}
368 my $sym = objsym($sv);
369 return $sym if defined $sym;
370 # warn "Saving SVt_NULL SV\n"; # debug
373 # warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
375 $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT + 1, $sv->FLAGS));
376 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
381 my $sym = objsym($sv);
382 return $sym if defined $sym;
383 $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
384 $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
385 $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
386 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
391 my $sym = objsym($sv);
392 return $sym if defined $sym;
394 $val .= '.00' if $val =~ /^-?\d+$/;
395 $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
396 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
397 $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
398 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
403 my $sym = objsym($sv);
404 return $sym if defined $sym;
406 my $len = length($pv);
407 my ($pvsym, $pvmax) = savepv($pv);
408 my ($lvtarg, $lvtarg_sym);
409 $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
410 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
411 $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
412 $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
413 $xpvlvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
414 if (!$pv_copy_on_grow) {
415 $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);",
416 $xpvlvsect->index, cstring($pv), $len));
419 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
424 my $sym = objsym($sv);
425 return $sym if defined $sym;
427 my $len = length($pv);
428 my ($pvsym, $pvmax) = savepv($pv);
429 $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
430 $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
431 $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
432 if (!$pv_copy_on_grow) {
433 $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);",
434 $xpvivsect->index, cstring($pv), $len));
436 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
441 my $sym = objsym($sv);
442 return $sym if defined $sym;
444 $pv = '' unless defined $pv;
445 my $len = length($pv);
446 my ($pvsym, $pvmax) = savepv($pv);
448 $val .= '.00' if $val =~ /^-?\d+$/;
449 $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
450 $pvsym, $len, $pvmax, $sv->IVX, $val));
451 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
452 $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
453 if (!$pv_copy_on_grow) {
454 $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);",
455 $xpvnvsect->index, cstring($pv), $len));
457 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
462 my $sym = objsym($sv);
463 return $sym if defined $sym;
464 my $pv = $sv->PV . "\0" . $sv->TABLE;
465 my $len = length($pv);
466 $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
467 $len, $len + 258, $sv->IVX, $sv->NVX,
468 $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
469 $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
470 $xpvbmsect->index, $sv->REFCNT + 1, $sv->FLAGS));
472 $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);",
473 $xpvbmsect->index, cstring($pv), $len),
474 sprintf("xpvbm_list[%d].xpv_cur = %u;",
475 $xpvbmsect->index, $len - 257));
476 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
481 my $sym = objsym($sv);
482 return $sym if defined $sym;
484 my $len = length($pv);
485 my ($pvsym, $pvmax) = savepv($pv);
486 $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
487 $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
488 $xpvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
489 if (!$pv_copy_on_grow) {
490 $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);",
491 $xpvsect->index, cstring($pv), $len));
493 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
498 my $sym = objsym($sv);
499 return $sym if defined $sym;
501 my $len = length($pv);
502 my ($pvsym, $pvmax) = savepv($pv);
503 $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
504 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
505 $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
506 $xpvmgsect->index, $sv->REFCNT + 1, $sv->FLAGS));
507 if (!$pv_copy_on_grow) {
508 $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);",
509 $xpvmgsect->index, cstring($pv), $len));
511 $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
516 sub B::PVMG::save_magic {
518 #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
519 my $stash = $sv->SvSTASH;
522 warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
524 # XXX Hope stash is already going to be saved.
525 $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
527 my @mgchain = $sv->MAGIC;
528 my ($mg, $type, $obj, $ptr,$len,$ptrsv);
529 foreach $mg (@mgchain) {
535 warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
536 class($sv), $$sv, class($obj), $$obj,
537 cchar($type), cstring($ptr));
540 if ($len == HEf_SVKEY){
541 #The pointer is an SV*
542 $ptrsv=svref_2object($ptr)->save;
543 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
544 $$sv, $$obj, cchar($type),$ptrsv,$len));
546 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
547 $$sv, $$obj, cchar($type),cstring($ptr),$len));
554 my $sym = objsym($sv);
555 return $sym if defined $sym;
556 my $rv = $sv->RV->save;
557 $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/;
559 $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
560 $xrvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
561 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
565 my ($cvstashname, $cvname) = @_;
566 warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
567 # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
568 # use should be handled by the class itself.
570 my $isa = \@{"$cvstashname\::ISA"};
571 if (grep($_ eq "AutoLoader", @$isa)) {
572 warn "Forcing immediate load of sub derived from AutoLoader\n";
573 # Tweaked version of AutoLoader::AUTOLOAD
574 my $dir = $cvstashname;
576 eval { require "auto/$dir/$cvname.al" };
578 warn qq(failed require "auto/$dir/$cvname.al": $@\n);
588 my $sym = objsym($cv);
590 # warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
593 # Reserve a place in svsect and xpvcvsect and record indices
595 my $cvstashname = $gv->STASH->NAME;
596 my $cvname = $gv->NAME;
597 my $root = $cv->ROOT;
598 my $cvxsub = $cv->XSUB;
599 #INIT is removed from the symbol table, so this call must come
600 # from PL_initav->save. Re-bootstrapping will push INIT back in
601 # so nullop should be sent.
602 if ($cvxsub && ($cvname ne "INIT")) {
605 my $stashname = $egv->STASH->NAME;
606 $xsub{$stashname}='Static' unless $xsub{$stashname};
607 return qq/(perl_get_cv("$stashname\:\:$cvname",0))/;
609 if ($cvxsub && $cvname eq "INIT") {
611 return svref_2object(\&Dummy_initxs)->save;
613 my $sv_ix = $svsect->index + 1;
614 $svsect->add("svix$sv_ix");
615 my $xpvcv_ix = $xpvcvsect->index + 1;
616 $xpvcvsect->add("xpvcvix$xpvcv_ix");
617 # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
618 $sym = savesym($cv, "&sv_list[$sv_ix]");
619 warn sprintf("saving CV 0x%x as $sym\n", $$cv) if $debug_cv;
620 if (!$$root && !$cvxsub) {
621 if (try_autoload($cvstashname, $cvname)) {
622 # Recalculate root and xsub
625 if ($$root || $cvxsub) {
626 warn "Successful forced autoload\n";
631 my $padlist = $cv->PADLIST;
634 my $xsubany = "Nullany";
636 warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
637 $$cv, $$root) if $debug_cv;
640 my $stashname = $gv->STASH->NAME;
641 my $gvname = $gv->NAME;
642 if ($gvname ne "__ANON__") {
643 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
644 $ppname .= ($stashname eq "main") ?
645 $gvname : "$stashname\::$gvname";
646 $ppname =~ s/::/__/g;
647 if ($gvname eq "INIT"){
648 $ppname .= "_$initsub_index";
654 $ppname = "pp_anonsub_$anonsub_index";
657 $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
658 warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
659 $$cv, $ppname, $$root) if $debug_cv;
661 warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
662 $$padlist, $$cv) if $debug_cv;
664 warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
665 $$padlist, $$cv) if $debug_cv;
669 warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
670 $cvstashname, $cvname); # debug
672 $pv = '' unless defined $pv; # Avoid use of undef warnings
673 $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",
674 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
675 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
676 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
678 if (${$cv->OUTSIDE} == ${main_cv()}){
679 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
680 $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
685 $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
686 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
687 $$gv, $$cv) if $debug_cv;
689 my $filegv = $cv->FILEGV;
692 $init->add(sprintf("CvFILEGV(s\\_%x) = s\\_%x;", $$cv, $$filegv));
693 warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n",
694 $$filegv, $$cv) if $debug_cv;
696 my $stash = $cv->STASH;
699 $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
700 warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
701 $$stash, $$cv) if $debug_cv;
703 $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
704 $sv_ix, $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS));
709 my ($gv,$skip_cv) = @_;
710 my $sym = objsym($gv);
712 #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
715 my $ix = $gv_index++;
716 $sym = savesym($gv, "gv_list[$ix]");
717 #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
719 my $gvname = $gv->NAME;
720 my $name = cstring($gv->STASH->NAME . "::" . $gvname);
721 #warn "GV name is $name\n"; # debug
725 #warn(sprintf("EGV name is %s, saving it now\n",
726 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
727 $egvsym = $egv->save;
729 $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
730 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
731 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS),
732 sprintf("GvLINE($sym) = %u;", $gv->LINE));
733 # Shouldn't need to do save_magic since gv_fetchpv handles that
735 my $refcnt = $gv->REFCNT + 1;
736 $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
737 my $gvrefcnt = $gv->GvREFCNT;
739 $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
741 if (defined($egvsym)) {
742 # Shared glob *foo = *bar
743 $init->add("gp_free($sym);",
744 "GvGP($sym) = GvGP($egvsym);");
745 } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
746 # Don't save subfields of special GVs (*_, *1, *# and so on)
747 # warn "GV::save saving subfields\n"; # debug
751 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
752 # warn "GV::save \$$name\n"; # debug
757 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
758 # warn "GV::save \@$name\n"; # debug
763 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
764 # warn "GV::save \%$name\n"; # debug
767 if ($$gvcv && !$skip_cv && !$gvcv->XSUB) { #not XSUB
769 $init->add(sprintf("GvCV($sym) = (CV*)s\\_%x;", $$gvcv));
770 # warn "GV::save &$name\n"; # debug
771 }elsif ($$gvcv && $gvcv->XSUB && $name ne
772 (my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
773 "::" . $gvcv->GV->EGV->NAME))) { #XSUB alias
775 $init->add("{ CV *cv;");
776 $init->add("\tcv=GvCV(gv_fetchpv($origname,FALSE,SVt_PV));");
777 $init->add("\tGvCV($sym)=cv;");
778 $init->add("\tSvREFCNT_inc((SV *)cv);");
782 my $gvfilegv = $gv->FILEGV;
785 $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv));
786 # warn "GV::save GvFILEGV(*$name)\n"; # debug
788 my $gvform = $gv->FORM;
791 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
792 # warn "GV::save GvFORM(*$name)\n"; # debug
797 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
798 # warn "GV::save GvIO(*$name)\n"; # debug
805 my $sym = objsym($av);
806 return $sym if defined $sym;
807 my $avflags = $av->AvFLAGS;
808 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
810 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
811 $xpvavsect->index, $av->REFCNT + 1, $av->FLAGS));
812 my $sv_list_index = $svsect->index;
813 my $fill = $av->FILL;
815 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
817 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
818 #if ($fill > -1 && ($avflags & AVf_REAL)) {
820 my @array = $av->ARRAY;
824 foreach $el (@array) {
825 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
826 $$av, $i++, class($el), $$el);
829 my @names = map($_->save, @array);
830 # XXX Better ways to write loop?
831 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
832 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
835 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
836 "\tav_extend(av, $fill);",
837 "\tsvp = AvARRAY(av);",
838 map("\t*svp++ = (SV*)$_;", @names),
839 "\tAvFILLp(av) = $fill;",
843 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
846 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
851 my $sym = objsym($hv);
852 return $sym if defined $sym;
853 my $name = $hv->NAME;
857 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
858 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
859 # a trashed op but we look at the trashed op_type and segfault.
860 #my $adpmroot = ${$hv->PMROOT};
862 $decl->add("static HV *hv$hv_index;");
863 # XXX Beware of weird package names containing double-quotes, \n, ...?
864 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
866 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
869 $sym = savesym($hv, "hv$hv_index");
873 # It's just an ordinary HV
874 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
875 $hv->MAX, $hv->RITER));
876 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
877 $xpvhvsect->index, $hv->REFCNT + 1, $hv->FLAGS));
878 my $sv_list_index = $svsect->index;
879 my @contents = $hv->ARRAY;
882 for ($i = 1; $i < @contents; $i += 2) {
883 $contents[$i] = $contents[$i]->save;
885 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
887 my ($key, $value) = splice(@contents, 0, 2);
888 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
889 cstring($key),length($key),$value, hash($key)));
890 # $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
891 # cstring($key),length($key),$value, 0));
896 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
901 my $sym = objsym($io);
902 return $sym if defined $sym;
904 $pv = '' unless defined $pv;
905 my $len = length($pv);
906 $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",
907 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
908 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
909 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
910 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
911 cchar($io->IoTYPE), $io->IoFLAGS));
912 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
913 $xpviosect->index, $io->REFCNT + 1, $io->FLAGS));
914 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
916 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
917 $fsym = $io->$field();
919 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
929 # This is where we catch an honest-to-goodness Nullsv (which gets
930 # blessed into B::SV explicitly) and any stray erroneous SVs.
931 return 0 unless $$sv;
932 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
937 my $init_name = shift;
939 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
940 $listopsect, $pmopsect, $svopsect, $gvopsect, $pvopsect,
941 $loopsect, $copsect, $svsect, $xpvsect,
942 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
943 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
944 $symsect->output(\*STDOUT, "#define %s\n");
946 output_declarations();
947 foreach $section (@sections) {
948 my $lines = $section->index + 1;
950 my $name = $section->name;
951 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
952 print "Static $typename ${name}_list[$lines];\n";
955 $decl->output(\*STDOUT, "%s\n");
957 foreach $section (@sections) {
958 my $lines = $section->index + 1;
960 my $name = $section->name;
961 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
962 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
963 $section->output(\*STDOUT, "\t{ %s },\n");
969 static int $init_name()
975 $init->output(\*STDOUT, "\t%s\n");
976 print "\treturn 0;\n}\n";
978 warn compile_stats();
979 warn "NULLOP count: $nullop_count\n";
983 sub output_declarations {
985 #ifdef BROKEN_STATIC_REDECL
986 #define Static extern
988 #define Static static
989 #endif /* BROKEN_STATIC_REDECL */
991 #ifdef BROKEN_UNION_INIT
993 * Cribbed from cv.h with ANY (a union) replaced by void*.
994 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
997 char * xpv_pv; /* pointer to malloced string */
998 STRLEN xpv_cur; /* length of xp_pv as a C string */
999 STRLEN xpv_len; /* allocated size */
1000 IV xof_off; /* integer value */
1001 double xnv_nv; /* numeric value, if any */
1002 MAGIC* xmg_magic; /* magic for scalar array */
1003 HV* xmg_stash; /* class package */
1008 void (*xcv_xsub) (CV*);
1012 long xcv_depth; /* >= 2 indicates recursive call */
1016 perl_mutex *xcv_mutexp;
1017 struct perl_thread *xcv_owner; /* current owner thread */
1018 #endif /* USE_THREADS */
1021 #define ANYINIT(i) i
1023 #define XPVCV_or_similar XPVCV
1024 #define ANYINIT(i) {i}
1025 #endif /* BROKEN_UNION_INIT */
1026 #define Nullany ANYINIT(0)
1032 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1037 sub output_boilerplate {
1042 /* Workaround for mapstart: the only op which needs a different ppaddr */
1043 #undef Perl_pp_mapstart
1044 #define Perl_pp_mapstart Perl_pp_grepstart
1045 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1046 EXTERN_C void boot_DynaLoader (CV* cv);
1048 static void xs_init (void);
1049 static PerlInterpreter *my_perl;
1056 #ifndef CAN_PROTOTYPE
1057 main(argc, argv, env)
1061 #else /* def(CAN_PROTOTYPE) */
1062 main(int argc, char **argv, char **env)
1063 #endif /* def(CAN_PROTOTYPE) */
1069 PERL_SYS_INIT(&argc,&argv);
1071 perl_init_i18nl10n(1);
1073 if (!PL_do_undump) {
1074 my_perl = perl_alloc();
1077 perl_construct( my_perl );
1082 PL_cshlen = strlen(PL_cshname);
1085 #ifdef ALLOW_PERL_OPTIONS
1086 #define EXTRA_OPTIONS 2
1088 #define EXTRA_OPTIONS 3
1089 #endif /* ALLOW_PERL_OPTIONS */
1090 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1091 fakeargv[0] = argv[0];
1094 #ifndef ALLOW_PERL_OPTIONS
1096 #endif /* ALLOW_PERL_OPTIONS */
1097 for (i = 1; i < argc; i++)
1098 fakeargv[i + EXTRA_OPTIONS] = argv[i];
1099 fakeargv[argc + EXTRA_OPTIONS] = 0;
1101 exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1106 sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1107 PL_main_cv = PL_compcv;
1110 exitstatus = perl_init();
1114 exitstatus = perl_run( my_perl );
1116 perl_destruct( my_perl );
1117 perl_free( my_perl );
1122 /* yanked from perl.c */
1126 char *file = __FILE__;
1130 print "\n#ifdef USE_DYNAMIC_LOADING";
1131 print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1132 print "\n#endif\n" ;
1133 delete $xsub{'DynaLoader'};
1134 delete $xsub{'UNIVERSAL'};
1135 print("/* bootstrapping code*/\nSAVETMPS;\n");
1136 print("\ttarg=sv_newmortal();\n");
1137 foreach my $stashname (keys %xsub ){
1138 my $stashxsub=$stashname;
1139 $stashxsub =~ s/::/__/g;
1140 if ($xsub{$stashname} eq 'Dynamic') {
1141 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1142 warn "bootstrapping $stashname added to xs_init\n";
1143 print qq/\n\t{\n\tchar *args[]={"$stashxsub", NULL};/;
1144 print qq/\n\t\tperl_call_argv("${stashxsub}::bootstrap",G_DISCARD,args);\n\t}/;
1147 print "\tPUSHMARK(sp);\n";
1148 print qq/\tXPUSHp("$stashname",strlen("$stashname")+1);\n/;
1149 print "\tboot_$stashxsub(NULL);\n";
1150 print "#endif\n" if ($xsub{$stashname} eq 'Dynamic');
1153 print("\tFREETMPS;\n/* end bootstrapping code */\n");
1159 warn "----Symbol table:\n";
1160 while (($sym, $val) = each %symtable) {
1161 warn "$sym => $val\n";
1163 warn "---End of symbol table\n";
1169 svref_2object($sv)->save;
1173 sub Dummy_BootStrap { }
1178 my $package=$gv->STASH->NAME;
1179 my $name = $gv->NAME;
1186 # We may be looking at this package just because it is a branch in the
1187 # symbol table which is on the path to a package which we need to save
1188 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1190 return unless ($unused_sub_packages{$package});
1193 if ($name eq "bootstrap" && $cv->XSUB)
1195 my $file = $cv->FILEGV->SV->PV;
1196 my $name = $gv->STASH->NAME.'::'.$name;
1198 *{$name} = \&Dummy_BootStrap;
1199 $xsub{$gv->STASH->NAME}='Dynamic';
1202 warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
1203 $package, $name, $$cv, $$gv) if ($debug_cv);
1207 return unless ($$av || $$sv || $$hv)
1209 $gv->save($skip_cv);
1214 my $package = shift;
1215 unless ($unused_sub_packages{$package})
1218 $unused_sub_packages{$package} = 1;
1219 if (@{$package.'::ISA'})
1221 foreach my $isa (@{$package.'::ISA'})
1223 if ($isa eq 'DynaLoader')
1225 unless (defined(&{$package.'::bootstrap'}))
1227 warn "Forcing bootstrap of $package\n";
1228 eval { $package->bootstrap };
1233 unless ($unused_sub_packages{$isa})
1235 warn "$isa saved (it is in $package\'s \@ISA)\n";
1247 no strict qw(vars refs);
1248 my $package = shift;
1249 $package =~ s/::$//;
1250 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1251 # warn "Considering $package\n";#debug
1252 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1254 # If this package is a prefix to something we are saving, traverse it
1255 # but do not mark it for saving if it is not already
1256 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1258 return 1 if ($u =~ /^$package\:\:/);
1260 if (exists $unused_sub_packages{$package})
1262 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1263 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1264 return $unused_sub_packages{$package};
1266 # Omit the packages which we use (and which cause grief
1267 # because of fancy "goto &$AUTOLOAD" stuff).
1268 # XXX Surely there must be a nicer way to do this.
1269 if ($package eq "FileHandle" || $package eq "Config" ||
1270 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1272 delete_unsaved_hashINC($package);
1273 return $unused_sub_packages{$package} = 0;
1275 # Now see if current package looks like an OO class this is probably too strong.
1276 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1278 if ($package->can($m))
1280 warn "$package has method $m: saving package\n";#debug
1281 return mark_package($package);
1284 delete_unsaved_hashINC($package);
1285 return $unused_sub_packages{$package} = 0;
1287 sub delete_unsaved_hashINC{
1289 $packname =~ s/\:\:/\//g;
1291 # warn "deleting $packname" if $INC{$packname} ;# debug
1292 delete $INC{$packname};
1296 my ($symref, $recurse, $prefix) = @_;
1301 $prefix = '' unless defined $prefix;
1302 while (($sym, $ref) = each %$symref)
1307 $sym = $prefix . $sym;
1308 if ($sym ne "main::" && &$recurse($sym))
1310 walkpackages(\%glob, $recurse, $sym);
1317 sub save_unused_subs
1320 &descend_marked_unused;
1322 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1323 warn "Saving methods\n";
1324 walksymtable(\%{"main::"}, "savecv", \&should_save);
1329 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1330 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1331 my $inc_hv = svref_2object(\%INC)->save;
1332 my $inc_av = svref_2object(\@INC)->save;
1333 my $amagic_generate= amagic_generation;
1334 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1335 "GvHV(PL_incgv) = $inc_hv;",
1336 "GvAV(PL_incgv) = $inc_av;",
1337 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1338 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1339 "PL_amagic_generation= $amagic_generate;" );
1342 sub descend_marked_unused {
1343 foreach my $pack (keys %unused_sub_packages)
1345 mark_package($pack);
1350 warn "Starting compile\n";
1351 warn "Walking tree\n";
1352 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1353 walkoptree(main_root, "save");
1354 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1356 my $init_av = init_av->save;
1357 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1358 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1359 "PL_initav = (AV *) $init_av;");
1361 warn "Writing output\n";
1362 output_boilerplate();
1364 output_all("perl_init");
1370 my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1371 binop => \$binopsect, condop => \$condopsect,
1372 cop => \$copsect, gvop => \$gvopsect,
1373 listop => \$listopsect, logop => \$logopsect,
1374 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1375 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1376 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1377 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1378 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1379 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1380 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1381 xpvio => \$xpviosect);
1382 my ($name, $sectref);
1383 while (($name, $sectref) = splice(@sections, 0, 2)) {
1384 $$sectref = new B::C::Section $name, \%symtable, 0;
1390 my ($arg,$val) = @_;
1391 $unused_sub_packages{$arg} = $val;
1396 my ($option, $opt, $arg);
1398 while ($option = shift @options) {
1399 if ($option =~ /^-(.)(.*)/) {
1403 unshift @options, $option;
1406 if ($opt eq "-" && $arg eq "-") {
1411 $warn_undefined_syms = 1;
1412 } elsif ($opt eq "D") {
1413 $arg ||= shift @options;
1414 foreach $arg (split(//, $arg)) {
1417 } elsif ($arg eq "c") {
1419 } elsif ($arg eq "A") {
1421 } elsif ($arg eq "C") {
1423 } elsif ($arg eq "M") {
1426 warn "ignoring unknown debug option: $arg\n";
1429 } elsif ($opt eq "o") {
1430 $arg ||= shift @options;
1431 open(STDOUT, ">$arg") or return "$arg: $!\n";
1432 } elsif ($opt eq "v") {
1434 } elsif ($opt eq "u") {
1435 $arg ||= shift @options;
1436 mark_unused($arg,undef);
1437 } elsif ($opt eq "f") {
1438 $arg ||= shift @options;
1439 if ($arg eq "cog") {
1440 $pv_copy_on_grow = 1;
1441 } elsif ($arg eq "no-cog") {
1442 $pv_copy_on_grow = 0;
1444 } elsif ($opt eq "O") {
1445 $arg = 1 if $arg eq "";
1446 $pv_copy_on_grow = 0;
1448 # Optimisations for -O1
1449 $pv_copy_on_grow = 1;
1457 foreach $objname (@options) {
1458 eval "save_object(\\$objname)";
1463 return sub { save_main() };
1473 B::C - Perl compiler's C backend
1477 perl -MO=C[,OPTIONS] foo.pl
1481 This compiler backend takes Perl source and generates C source code
1482 corresponding to the internal structures that perl uses to run
1483 your program. When the generated C source is compiled and run, it
1484 cuts out the time which perl would have taken to load and parse
1485 your program into its internal semi-compiled form. That means that
1486 compiling with this backend will not help improve the runtime
1487 execution speed of your program but may improve the start-up time.
1488 Depending on the environment in which your program runs this may be
1489 either a help or a hindrance.
1493 If there are any non-option arguments, they are taken to be
1494 names of objects to be saved (probably doesn't work properly yet).
1495 Without extra arguments, it saves the main program.
1501 Output to filename instead of STDOUT
1505 Verbose compilation (currently gives a few compilation statistics).
1509 Force end of options
1513 Force apparently unused subs from package Packname to be compiled.
1514 This allows programs to use eval "foo()" even when sub foo is never
1515 seen to be used at compile time. The down side is that any subs which
1516 really are never used also have code generated. This option is
1517 necessary, for example, if you have a signal handler foo which you
1518 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1519 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1520 options. The compiler tries to figure out which packages may possibly
1521 have subs in which need compiling but the current version doesn't do
1522 it very well. In particular, it is confused by nested packages (i.e.
1523 of the form C<A::B>) where package C<A> does not contain any subs.
1527 Debug options (concatenated or separate flags like C<perl -D>).
1531 OPs, prints each OP as it's processed
1535 COPs, prints COPs as processed (incl. file & line num)
1539 prints AV information on saving
1543 prints CV information on saving
1547 prints MAGIC information on saving
1551 Force optimisations on or off one at a time.
1555 Copy-on-grow: PVs declared and initialised statically.
1563 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
1564 B<-O1> and higher set B<-fcog>.
1568 perl -MO=C,-ofoo.c foo.pl
1569 perl cc_harness -o foo foo.c
1571 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1572 library directory. The utility called C<perlcc> may also be used to
1573 help make use of this compiler.
1575 perl -MO=C,-v,-DcA bar.pl > /dev/null
1579 Plenty. Current status: experimental.
1583 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>