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
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;
404 $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $sv->NVX));
405 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
406 $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
407 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
412 my $sym = objsym($sv);
413 return $sym if defined $sym;
415 my $len = length($pv);
416 my ($pvsym, $pvmax) = savepv($pv);
417 my ($lvtarg, $lvtarg_sym);
418 $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
419 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
420 $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
421 $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
422 $xpvlvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
423 if (!$pv_copy_on_grow) {
424 $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);",
425 $xpvlvsect->index, cstring($pv), $len));
428 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
433 my $sym = objsym($sv);
434 return $sym if defined $sym;
436 my $len = length($pv);
437 my ($pvsym, $pvmax) = savepv($pv);
438 $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
439 $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
440 $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
441 if (!$pv_copy_on_grow) {
442 $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);",
443 $xpvivsect->index, cstring($pv), $len));
445 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
450 my $sym = objsym($sv);
451 return $sym if defined $sym;
453 $pv = '' unless defined $pv;
454 my $len = length($pv);
455 my ($pvsym, $pvmax) = savepv($pv);
456 $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
457 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
458 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
459 $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
460 if (!$pv_copy_on_grow) {
461 $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);",
462 $xpvnvsect->index, cstring($pv), $len));
464 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
469 my $sym = objsym($sv);
470 return $sym if defined $sym;
471 my $pv = $sv->PV . "\0" . $sv->TABLE;
472 my $len = length($pv);
473 $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
474 $len, $len + 258, $sv->IVX, $sv->NVX,
475 $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
476 $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
477 $xpvbmsect->index, $sv->REFCNT + 1, $sv->FLAGS));
479 $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);",
480 $xpvbmsect->index, cstring($pv), $len),
481 sprintf("xpvbm_list[%d].xpv_cur = %u;",
482 $xpvbmsect->index, $len - 257));
483 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
488 my $sym = objsym($sv);
489 return $sym if defined $sym;
491 my $len = length($pv);
492 my ($pvsym, $pvmax) = savepv($pv);
493 $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
494 $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
495 $xpvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
496 if (!$pv_copy_on_grow) {
497 $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);",
498 $xpvsect->index, cstring($pv), $len));
500 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
505 my $sym = objsym($sv);
506 return $sym if defined $sym;
508 my $len = length($pv);
509 my ($pvsym, $pvmax) = savepv($pv);
510 $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
511 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
512 $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
513 $xpvmgsect->index, $sv->REFCNT + 1, $sv->FLAGS));
514 if (!$pv_copy_on_grow) {
515 $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);",
516 $xpvmgsect->index, cstring($pv), $len));
518 $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
523 sub B::PVMG::save_magic {
525 #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
526 my $stash = $sv->SvSTASH;
528 warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
530 # XXX Hope stash is already going to be saved.
531 $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
533 my @mgchain = $sv->MAGIC;
534 my ($mg, $type, $obj, $ptr,$len,$ptrsv);
535 foreach $mg (@mgchain) {
541 warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
542 class($sv), $$sv, class($obj), $$obj,
543 cchar($type), cstring($ptr));
545 if ($len == HEf_SVKEY){
546 #The pointer is an SV*
547 $ptrsv=svref_2object($ptr)->save;
548 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
549 $$sv, $$obj, cchar($type),$ptrsv,$len));
551 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
552 $$sv, $$obj, cchar($type),cstring($ptr),$len));
559 my $sym = objsym($sv);
560 return $sym if defined $sym;
561 my $rv = $sv->RV->save;
562 $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/;
564 $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
565 $xrvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
566 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
570 my ($cvstashname, $cvname) = @_;
571 warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
572 # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
573 # use should be handled by the class itself.
575 my $isa = \@{"$cvstashname\::ISA"};
576 if (grep($_ eq "AutoLoader", @$isa)) {
577 warn "Forcing immediate load of sub derived from AutoLoader\n";
578 # Tweaked version of AutoLoader::AUTOLOAD
579 my $dir = $cvstashname;
581 eval { require "auto/$dir/$cvname.al" };
583 warn qq(failed require "auto/$dir/$cvname.al": $@\n);
593 my $sym = objsym($cv);
595 # warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
598 # Reserve a place in svsect and xpvcvsect and record indices
599 my $sv_ix = $svsect->index + 1;
600 $svsect->add("svix$sv_ix");
601 my $xpvcv_ix = $xpvcvsect->index + 1;
602 $xpvcvsect->add("xpvcvix$xpvcv_ix");
603 # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
604 $sym = savesym($cv, "&sv_list[$sv_ix]");
605 warn sprintf("saving CV 0x%x as $sym\n", $$cv) if $debug_cv;
607 my $cvstashname = $gv->STASH->NAME;
608 my $cvname = $gv->NAME;
609 my $root = $cv->ROOT;
610 my $cvxsub = $cv->XSUB;
611 if (!$$root && !$cvxsub) {
612 if (try_autoload($cvstashname, $cvname)) {
613 # Recalculate root and xsub
616 if ($$root || $cvxsub) {
617 warn "Successful forced autoload\n";
622 my $padlist = $cv->PADLIST;
625 my $xsubany = "Nullany";
627 warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
628 $$cv, $$root) if $debug_cv;
631 my $stashname = $gv->STASH->NAME;
632 my $gvname = $gv->NAME;
633 if ($gvname ne "__ANON__") {
634 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
635 $ppname .= ($stashname eq "main") ?
636 $gvname : "$stashname\::$gvname";
637 $ppname =~ s/::/__/g;
638 if ($gvname eq "INIT"){
639 $ppname .= "_$initsub_index";
645 $ppname = "pp_anonsub_$anonsub_index";
648 $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
649 warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
650 $$cv, $ppname, $$root) if $debug_cv;
652 warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
653 $$padlist, $$cv) if $debug_cv;
655 warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
656 $$padlist, $$cv) if $debug_cv;
660 $xsubany = sprintf("ANYINIT((void*)0x%x)", $cv->XSUBANY);
661 # Try to find out canonical name of XSUB function from EGV.
662 # XXX Doesn't work for XSUBs with PREFIX set (or anyone who
663 # calls newXS() manually with weird arguments).
665 my $stashname = $egv->STASH->NAME;
666 $stashname =~ s/::/__/g;
667 $xsub = sprintf("XS_%s_%s", $stashname, $egv->NAME);
668 $decl->add("void $xsub _((CV*));");
671 warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
672 $cvstashname, $cvname); # debug
674 $pv = '' unless defined $pv; # Avoid use of undef warnings
675 $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",
676 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
677 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
678 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
680 if (${$cv->OUTSIDE} == ${main_cv()}){
681 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
686 $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
687 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
688 $$gv, $$cv) if $debug_cv;
690 my $filegv = $cv->FILEGV;
693 $init->add(sprintf("CvFILEGV(s\\_%x) = s\\_%x;", $$cv, $$filegv));
694 warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n",
695 $$filegv, $$cv) if $debug_cv;
697 my $stash = $cv->STASH;
700 $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
701 warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
702 $$stash, $$cv) if $debug_cv;
704 $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
705 $sv_ix, $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS));
710 my ($gv,$skip_cv) = @_;
711 my $sym = objsym($gv);
713 #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
716 my $ix = $gv_index++;
717 $sym = savesym($gv, "gv_list[$ix]");
718 #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
720 my $gvname = $gv->NAME;
721 my $name = cstring($gv->STASH->NAME . "::" . $gvname);
722 #warn "GV name is $name\n"; # debug
726 #warn(sprintf("EGV name is %s, saving it now\n",
727 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
728 $egvsym = $egv->save;
730 $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
731 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
732 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS),
733 sprintf("GvLINE($sym) = %u;", $gv->LINE));
734 # Shouldn't need to do save_magic since gv_fetchpv handles that
736 my $refcnt = $gv->REFCNT + 1;
737 $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
738 my $gvrefcnt = $gv->GvREFCNT;
740 $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
742 if (defined($egvsym)) {
743 # Shared glob *foo = *bar
744 $init->add("gp_free($sym);",
745 "GvGP($sym) = GvGP($egvsym);");
746 } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
747 # Don't save subfields of special GVs (*_, *1, *# and so on)
748 # warn "GV::save saving subfields\n"; # debug
752 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
753 # warn "GV::save \$$name\n"; # debug
758 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
759 # warn "GV::save \@$name\n"; # debug
764 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
765 # warn "GV::save \%$name\n"; # debug
768 if ($$gvcv && !$skip_cv) {
770 $init->add(sprintf("GvCV($sym) = (CV*)s\\_%x;", $$gvcv));
771 # warn "GV::save &$name\n"; # debug
773 my $gvfilegv = $gv->FILEGV;
776 $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv));
777 # warn "GV::save GvFILEGV(*$name)\n"; # debug
779 my $gvform = $gv->FORM;
782 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
783 # warn "GV::save GvFORM(*$name)\n"; # debug
788 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
789 # warn "GV::save GvIO(*$name)\n"; # debug
796 my $sym = objsym($av);
797 return $sym if defined $sym;
798 my $avflags = $av->AvFLAGS;
799 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
801 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
802 $xpvavsect->index, $av->REFCNT + 1, $av->FLAGS));
803 my $sv_list_index = $svsect->index;
804 my $fill = $av->FILL;
806 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
808 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
809 #if ($fill > -1 && ($avflags & AVf_REAL)) {
811 my @array = $av->ARRAY;
815 foreach $el (@array) {
816 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
817 $$av, $i++, class($el), $$el);
820 my @names = map($_->save, @array);
821 # XXX Better ways to write loop?
822 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
823 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
826 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
827 "\tav_extend(av, $fill);",
828 "\tsvp = AvARRAY(av);",
829 map("\t*svp++ = (SV*)$_;", @names),
830 "\tAvFILLp(av) = $fill;",
834 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
837 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
842 my $sym = objsym($hv);
843 return $sym if defined $sym;
844 my $name = $hv->NAME;
848 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
849 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
850 # a trashed op but we look at the trashed op_type and segfault.
851 #my $adpmroot = ${$hv->PMROOT};
853 $decl->add("static HV *hv$hv_index;");
854 # XXX Beware of weird package names containing double-quotes, \n, ...?
855 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
857 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
860 $sym = savesym($hv, "hv$hv_index");
864 # It's just an ordinary HV
865 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
866 $hv->MAX, $hv->RITER));
867 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
868 $xpvhvsect->index, $hv->REFCNT + 1, $hv->FLAGS));
869 my $sv_list_index = $svsect->index;
870 my @contents = $hv->ARRAY;
873 for ($i = 1; $i < @contents; $i += 2) {
874 $contents[$i] = $contents[$i]->save;
876 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
878 my ($key, $value) = splice(@contents, 0, 2);
879 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
880 cstring($key),length($key),$value, hash($key)));
881 # $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
882 # cstring($key),length($key),$value, 0));
886 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
891 my $sym = objsym($io);
892 return $sym if defined $sym;
894 $pv = '' unless defined $pv;
895 my $len = length($pv);
896 $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",
897 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
898 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
899 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
900 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
901 cchar($io->IoTYPE), $io->IoFLAGS));
902 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
903 $xpviosect->index, $io->REFCNT + 1, $io->FLAGS));
904 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
906 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
907 $fsym = $io->$field();
909 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
919 # This is where we catch an honest-to-goodness Nullsv (which gets
920 # blessed into B::SV explicitly) and any stray erroneous SVs.
921 return 0 unless $$sv;
922 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
927 my $init_name = shift;
929 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
930 $listopsect, $pmopsect, $svopsect, $gvopsect, $pvopsect,
931 $loopsect, $copsect, $svsect, $xpvsect,
932 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
933 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
934 $bootstrap->output(\*STDOUT, "/* bootstrap %s */\n");
935 $symsect->output(\*STDOUT, "#define %s\n");
937 output_declarations();
938 foreach $section (@sections) {
939 my $lines = $section->index + 1;
941 my $name = $section->name;
942 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
943 print "Static $typename ${name}_list[$lines];\n";
946 $decl->output(\*STDOUT, "%s\n");
948 foreach $section (@sections) {
949 my $lines = $section->index + 1;
951 my $name = $section->name;
952 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
953 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
954 $section->output(\*STDOUT, "\t{ %s },\n");
960 static int $init_name()
964 $init->output(\*STDOUT, "\t%s\n");
965 print "\treturn 0;\n}\n";
967 warn compile_stats();
968 warn "NULLOP count: $nullop_count\n";
972 sub output_declarations {
974 #ifdef BROKEN_STATIC_REDECL
975 #define Static extern
977 #define Static static
978 #endif /* BROKEN_STATIC_REDECL */
980 #ifdef BROKEN_UNION_INIT
982 * Cribbed from cv.h with ANY (a union) replaced by void*.
983 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
986 char * xpv_pv; /* pointer to malloced string */
987 STRLEN xpv_cur; /* length of xp_pv as a C string */
988 STRLEN xpv_len; /* allocated size */
989 IV xof_off; /* integer value */
990 double xnv_nv; /* numeric value, if any */
991 MAGIC* xmg_magic; /* magic for scalar array */
992 HV* xmg_stash; /* class package */
997 void (*xcv_xsub) _((CV*));
1001 long xcv_depth; /* >= 2 indicates recursive call */
1005 perl_mutex *xcv_mutexp;
1006 struct perl_thread *xcv_owner; /* current owner thread */
1007 #endif /* USE_THREADS */
1010 #define ANYINIT(i) i
1012 #define XPVCV_or_similar XPVCV
1013 #define ANYINIT(i) {i}
1014 #endif /* BROKEN_UNION_INIT */
1015 #define Nullany ANYINIT(0)
1021 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1026 sub output_boilerplate {
1031 /* Workaround for mapstart: the only op which needs a different ppaddr */
1033 #define pp_mapstart pp_grepstart
1034 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1035 EXTERN_C void boot_DynaLoader _((CV* cv));
1037 static void xs_init _((void));
1038 static PerlInterpreter *my_perl;
1045 #ifndef CAN_PROTOTYPE
1046 main(argc, argv, env)
1050 #else /* def(CAN_PROTOTYPE) */
1051 main(int argc, char **argv, char **env)
1052 #endif /* def(CAN_PROTOTYPE) */
1058 PERL_SYS_INIT(&argc,&argv);
1060 perl_init_i18nl10n(1);
1062 if (!PL_do_undump) {
1063 my_perl = perl_alloc();
1066 perl_construct( my_perl );
1071 PL_cshlen = strlen(PL_cshname);
1074 #ifdef ALLOW_PERL_OPTIONS
1075 #define EXTRA_OPTIONS 2
1077 #define EXTRA_OPTIONS 3
1078 #endif /* ALLOW_PERL_OPTIONS */
1079 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1080 fakeargv[0] = argv[0];
1083 #ifndef ALLOW_PERL_OPTIONS
1085 #endif /* ALLOW_PERL_OPTIONS */
1086 for (i = 1; i < argc; i++)
1087 fakeargv[i + EXTRA_OPTIONS] = argv[i];
1088 fakeargv[argc + EXTRA_OPTIONS] = 0;
1090 exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1095 sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1096 PL_main_cv = PL_compcv;
1099 exitstatus = perl_init();
1103 exitstatus = perl_run( my_perl );
1105 perl_destruct( my_perl );
1106 perl_free( my_perl );
1111 /* yanked from perl.c */
1115 char *file = __FILE__;
1117 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
1125 warn "----Symbol table:\n";
1126 while (($sym, $val) = each %symtable) {
1127 warn "$sym => $val\n";
1129 warn "---End of symbol table\n";
1135 svref_2object($sv)->save;
1139 sub Dummy_BootStrap { }
1144 my $package=$gv->STASH->NAME;
1145 my $name = $gv->NAME;
1152 # We may be looking at this package just because it is a branch in the
1153 # symbol table which is on the path to a package which we need to save
1154 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1156 return unless ($unused_sub_packages{$package});
1159 if ($name eq "bootstrap" && $cv->XSUB)
1161 my $file = $cv->FILEGV->SV->PV;
1162 $bootstrap->add($file);
1163 my $name = $gv->STASH->NAME.'::'.$name;
1165 *{$name} = \&Dummy_BootStrap;
1168 warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
1169 $package, $name, $$cv, $$gv) if ($debug_cv);
1173 return unless ($$av || $$sv || $$hv)
1175 $gv->save($skip_cv);
1180 my $package = shift;
1181 unless ($unused_sub_packages{$package})
1184 $unused_sub_packages{$package} = 1;
1185 if (defined(@{$package.'::ISA'}))
1187 foreach my $isa (@{$package.'::ISA'})
1189 if ($isa eq 'DynaLoader')
1191 unless (defined(&{$package.'::bootstrap'}))
1193 warn "Forcing bootstrap of $package\n";
1194 eval { $package->bootstrap };
1199 unless ($unused_sub_packages{$isa})
1201 warn "$isa saved (it is in $package\'s \@ISA)\n";
1213 no strict qw(vars refs);
1214 my $package = shift;
1215 $package =~ s/::$//;
1216 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1217 # warn "Considering $package\n";#debug
1218 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1220 # If this package is a prefix to something we are saving, traverse it
1221 # but do not mark it for saving if it is not already
1222 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1224 return 1 if ($u =~ /^$package\:\:/);
1226 if (exists $unused_sub_packages{$package})
1228 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1229 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1230 return $unused_sub_packages{$package};
1232 # Omit the packages which we use (and which cause grief
1233 # because of fancy "goto &$AUTOLOAD" stuff).
1234 # XXX Surely there must be a nicer way to do this.
1235 if ($package eq "FileHandle" || $package eq "Config" ||
1236 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1238 delete_unsaved_hashINC($package);
1239 return $unused_sub_packages{$package} = 0;
1241 # Now see if current package looks like an OO class this is probably too strong.
1242 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1244 if ($package->can($m))
1246 warn "$package has method $m: saving package\n";#debug
1247 return mark_package($package);
1250 delete_unsaved_hashINC($package);
1251 return $unused_sub_packages{$package} = 0;
1253 sub delete_unsaved_hashINC{
1255 $packname =~ s/\:\:/\//g;
1257 warn "deleting $packname" if $INC{$packname} ;# debug
1258 delete $INC{$packname};
1262 my ($symref, $recurse, $prefix) = @_;
1267 $prefix = '' unless defined $prefix;
1268 while (($sym, $ref) = each %$symref)
1273 $sym = $prefix . $sym;
1274 if ($sym ne "main::" && &$recurse($sym))
1276 walkpackages(\%glob, $recurse, $sym);
1283 sub save_unused_subs
1286 &descend_marked_unused;
1288 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1289 warn "Saving methods\n";
1290 walksymtable(\%{"main::"}, "savecv", \&should_save);
1295 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1296 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1297 my $inc_hv = svref_2object(\%INC)->save;
1298 my $inc_av = svref_2object(\@INC)->save;
1299 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1300 "GvHV(PL_incgv) = $inc_hv;",
1301 "GvAV(PL_incgv) = $inc_av;",
1302 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1303 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));");
1306 sub descend_marked_unused {
1307 foreach my $pack (keys %unused_sub_packages)
1309 mark_package($pack);
1314 warn "Starting compile\n";
1315 warn "Walking tree\n";
1316 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1317 walkoptree(main_root, "save");
1318 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1320 my $init_av = init_av->save;
1321 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1322 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1323 "PL_initav = $init_av;");
1325 warn "Writing output\n";
1326 output_boilerplate();
1328 output_all("perl_init");
1334 my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1335 binop => \$binopsect, condop => \$condopsect,
1336 cop => \$copsect, gvop => \$gvopsect,
1337 listop => \$listopsect, logop => \$logopsect,
1338 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1339 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1340 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1341 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1342 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1343 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1344 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1345 xpvio => \$xpviosect, bootstrap => \$bootstrap);
1346 my ($name, $sectref);
1347 while (($name, $sectref) = splice(@sections, 0, 2)) {
1348 $$sectref = new B::C::Section $name, \%symtable, 0;
1354 my ($arg,$val) = @_;
1355 $unused_sub_packages{$arg} = $val;
1360 my ($option, $opt, $arg);
1362 while ($option = shift @options) {
1363 if ($option =~ /^-(.)(.*)/) {
1367 unshift @options, $option;
1370 if ($opt eq "-" && $arg eq "-") {
1375 $warn_undefined_syms = 1;
1376 } elsif ($opt eq "D") {
1377 $arg ||= shift @options;
1378 foreach $arg (split(//, $arg)) {
1381 } elsif ($arg eq "c") {
1383 } elsif ($arg eq "A") {
1385 } elsif ($arg eq "C") {
1387 } elsif ($arg eq "M") {
1390 warn "ignoring unknown debug option: $arg\n";
1393 } elsif ($opt eq "o") {
1394 $arg ||= shift @options;
1395 open(STDOUT, ">$arg") or return "$arg: $!\n";
1396 } elsif ($opt eq "v") {
1398 } elsif ($opt eq "u") {
1399 $arg ||= shift @options;
1400 mark_unused($arg,undef);
1401 } elsif ($opt eq "f") {
1402 $arg ||= shift @options;
1403 if ($arg eq "cog") {
1404 $pv_copy_on_grow = 1;
1405 } elsif ($arg eq "no-cog") {
1406 $pv_copy_on_grow = 0;
1408 } elsif ($opt eq "O") {
1409 $arg = 1 if $arg eq "";
1410 $pv_copy_on_grow = 0;
1412 # Optimisations for -O1
1413 $pv_copy_on_grow = 1;
1421 foreach $objname (@options) {
1422 eval "save_object(\\$objname)";
1427 return sub { save_main() };
1437 B::C - Perl compiler's C backend
1441 perl -MO=C[,OPTIONS] foo.pl
1445 This compiler backend takes Perl source and generates C source code
1446 corresponding to the internal structures that perl uses to run
1447 your program. When the generated C source is compiled and run, it
1448 cuts out the time which perl would have taken to load and parse
1449 your program into its internal semi-compiled form. That means that
1450 compiling with this backend will not help improve the runtime
1451 execution speed of your program but may improve the start-up time.
1452 Depending on the environment in which your program runs this may be
1453 either a help or a hindrance.
1457 If there are any non-option arguments, they are taken to be
1458 names of objects to be saved (probably doesn't work properly yet).
1459 Without extra arguments, it saves the main program.
1465 Output to filename instead of STDOUT
1469 Verbose compilation (currently gives a few compilation statistics).
1473 Force end of options
1477 Force apparently unused subs from package Packname to be compiled.
1478 This allows programs to use eval "foo()" even when sub foo is never
1479 seen to be used at compile time. The down side is that any subs which
1480 really are never used also have code generated. This option is
1481 necessary, for example, if you have a signal handler foo which you
1482 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1483 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1484 options. The compiler tries to figure out which packages may possibly
1485 have subs in which need compiling but the current version doesn't do
1486 it very well. In particular, it is confused by nested packages (i.e.
1487 of the form C<A::B>) where package C<A> does not contain any subs.
1491 Debug options (concatenated or separate flags like C<perl -D>).
1495 OPs, prints each OP as it's processed
1499 COPs, prints COPs as processed (incl. file & line num)
1503 prints AV information on saving
1507 prints CV information on saving
1511 prints MAGIC information on saving
1515 Force optimisations on or off one at a time.
1519 Copy-on-grow: PVs declared and initialised statically.
1527 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
1528 B<-O1> and higher set B<-fcog>.
1532 perl -MO=C,-ofoo.c foo.pl
1533 perl cc_harness -o foo foo.c
1535 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1536 library directory. The utility called C<perlcc> may also be used to
1537 help make use of this compiler.
1539 perl -MO=C,-v,-DcA bar.pl > /dev/null
1543 Plenty. Current status: experimental.
1547 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>