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));
237 my ($op, $level) = @_;
238 my $sym = objsym($op);
239 return $sym if defined $sym;
240 #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
241 # peekop($op->redoop), peekop($op->nextop),
242 # peekop($op->lastop)); # debug
243 $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",
244 ${$op->next}, ${$op->sibling}, $op->ppaddr,
245 $op->targ, $op->type, $op_seq, $op->flags,
246 $op->private, ${$op->first}, ${$op->last},
247 $op->children, ${$op->redoop}, ${$op->nextop},
249 savesym($op, sprintf("(OP*)&loop_list[%d]", $loopsect->index));
253 my ($op, $level) = @_;
254 my $sym = objsym($op);
255 return $sym if defined $sym;
256 $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
257 ${$op->next}, ${$op->sibling}, $op->ppaddr,
258 $op->targ, $op->type, $op_seq, $op->flags,
259 $op->private, cstring($op->pv)));
260 savesym($op, sprintf("(OP*)&pvop_list[%d]", $pvopsect->index));
264 my ($op, $level) = @_;
265 my $sym = objsym($op);
266 return $sym if defined $sym;
267 my $svsym = $op->sv->save;
268 $svopsect->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, "(SV*)$svsym"));
272 savesym($op, sprintf("(OP*)&svop_list[%d]", $svopsect->index));
276 my ($op, $level) = @_;
277 my $sym = objsym($op);
278 return $sym if defined $sym;
279 my $gvsym = $op->gv->save;
280 $gvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullgv",
281 ${$op->next}, ${$op->sibling}, $op->ppaddr,
282 $op->targ, $op->type, $op_seq, $op->flags,
284 $init->add(sprintf("gvop_list[%d].op_gv = %s;", $gvopsect->index, $gvsym));
285 savesym($op, sprintf("(OP*)&gvop_list[%d]", $gvopsect->index));
289 my ($op, $level) = @_;
290 my $sym = objsym($op);
291 return $sym if defined $sym;
292 my $gvsym = $op->filegv->save;
293 my $stashsym = $op->stash->save;
294 warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV)
296 $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u",
297 ${$op->next}, ${$op->sibling}, $op->ppaddr,
298 $op->targ, $op->type, $op_seq, $op->flags,
299 $op->private, cstring($op->label), $op->cop_seq,
300 $op->arybase, $op->line));
301 my $copix = $copsect->index;
302 $init->add(sprintf("cop_list[%d].cop_filegv = %s;", $copix, $gvsym),
303 sprintf("cop_list[%d].cop_stash = %s;", $copix, $stashsym));
304 savesym($op, "(OP*)&cop_list[$copix]");
308 my ($op, $level) = @_;
309 my $sym = objsym($op);
310 return $sym if defined $sym;
311 my $replroot = $op->pmreplroot;
312 my $replstart = $op->pmreplstart;
313 my $replrootfield = sprintf("s\\_%x", $$replroot);
314 my $replstartfield = sprintf("s\\_%x", $$replstart);
316 my $ppaddr = $op->ppaddr;
318 # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
319 # argument to a split) stores a GV in op_pmreplroot instead
320 # of a substitution syntax tree. We don't want to walk that...
321 if ($ppaddr eq "pp_pushre") {
322 $gvsym = $replroot->save;
323 # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
326 $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
329 # pmnext handling is broken in perl itself, I think. Bad op_pmnext
330 # fields aren't noticed in perl's runtime (unless you try reset) but we
331 # segfault when trying to dereference it to find op->op_pmnext->op_type
332 $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",
333 ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ,
334 $op->type, $op_seq, $op->flags, $op->private,
335 ${$op->first}, ${$op->last}, $op->children,
336 $replrootfield, $replstartfield,
337 $op->pmflags, $op->pmpermflags,));
338 my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
339 my $re = $op->precomp;
341 my $resym = sprintf("re%d", $re_index++);
342 $decl->add(sprintf("static char *$resym = %s;", cstring($re)));
343 $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
347 $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
349 savesym($op, sprintf("(OP*)&pmop_list[%d]", $pmopsect->index));
352 sub B::SPECIAL::save {
354 # special case: $$sv is not the address but an index into specialsv_list
355 # warn "SPECIAL::save specialsv $$sv\n"; # debug
356 my $sym = $specialsv_name[$$sv];
357 if (!defined($sym)) {
358 confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
363 sub B::OBJECT::save {}
367 my $sym = objsym($sv);
368 return $sym if defined $sym;
369 # warn "Saving SVt_NULL SV\n"; # debug
372 # warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
374 $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT + 1, $sv->FLAGS));
375 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
380 my $sym = objsym($sv);
381 return $sym if defined $sym;
382 $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
383 $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
384 $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
385 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
390 my $sym = objsym($sv);
391 return $sym if defined $sym;
393 $val .= '.00' if $val =~ /^-?\d+$/;
394 $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
395 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
396 $xpvnvsect->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 my $len = length($pv);
406 my ($pvsym, $pvmax) = savepv($pv);
407 my ($lvtarg, $lvtarg_sym);
408 $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
409 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
410 $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
411 $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
412 $xpvlvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
413 if (!$pv_copy_on_grow) {
414 $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);",
415 $xpvlvsect->index, cstring($pv), $len));
418 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
423 my $sym = objsym($sv);
424 return $sym if defined $sym;
426 my $len = length($pv);
427 my ($pvsym, $pvmax) = savepv($pv);
428 $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
429 $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
430 $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
431 if (!$pv_copy_on_grow) {
432 $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);",
433 $xpvivsect->index, cstring($pv), $len));
435 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
440 my $sym = objsym($sv);
441 return $sym if defined $sym;
443 $pv = '' unless defined $pv;
444 my $len = length($pv);
445 my ($pvsym, $pvmax) = savepv($pv);
447 $val .= '.00' if $val =~ /^-?\d+$/;
448 $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
449 $pvsym, $len, $pvmax, $sv->IVX, $val));
450 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
451 $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
452 if (!$pv_copy_on_grow) {
453 $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);",
454 $xpvnvsect->index, cstring($pv), $len));
456 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
461 my $sym = objsym($sv);
462 return $sym if defined $sym;
463 my $pv = $sv->PV . "\0" . $sv->TABLE;
464 my $len = length($pv);
465 $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
466 $len, $len + 258, $sv->IVX, $sv->NVX,
467 $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
468 $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
469 $xpvbmsect->index, $sv->REFCNT + 1, $sv->FLAGS));
471 $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);",
472 $xpvbmsect->index, cstring($pv), $len),
473 sprintf("xpvbm_list[%d].xpv_cur = %u;",
474 $xpvbmsect->index, $len - 257));
475 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
480 my $sym = objsym($sv);
481 return $sym if defined $sym;
483 my $len = length($pv);
484 my ($pvsym, $pvmax) = savepv($pv);
485 $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
486 $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
487 $xpvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
488 if (!$pv_copy_on_grow) {
489 $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);",
490 $xpvsect->index, cstring($pv), $len));
492 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
497 my $sym = objsym($sv);
498 return $sym if defined $sym;
500 my $len = length($pv);
501 my ($pvsym, $pvmax) = savepv($pv);
502 $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
503 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
504 $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
505 $xpvmgsect->index, $sv->REFCNT + 1, $sv->FLAGS));
506 if (!$pv_copy_on_grow) {
507 $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);",
508 $xpvmgsect->index, cstring($pv), $len));
510 $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
515 sub B::PVMG::save_magic {
517 #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
518 my $stash = $sv->SvSTASH;
521 warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
523 # XXX Hope stash is already going to be saved.
524 $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
526 my @mgchain = $sv->MAGIC;
527 my ($mg, $type, $obj, $ptr,$len,$ptrsv);
528 foreach $mg (@mgchain) {
534 warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
535 class($sv), $$sv, class($obj), $$obj,
536 cchar($type), cstring($ptr));
539 if ($len == HEf_SVKEY){
540 #The pointer is an SV*
541 $ptrsv=svref_2object($ptr)->save;
542 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
543 $$sv, $$obj, cchar($type),$ptrsv,$len));
545 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
546 $$sv, $$obj, cchar($type),cstring($ptr),$len));
553 my $sym = objsym($sv);
554 return $sym if defined $sym;
555 my $rv = $sv->RV->save;
556 $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/;
558 $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
559 $xrvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
560 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
564 my ($cvstashname, $cvname) = @_;
565 warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
566 # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
567 # use should be handled by the class itself.
569 my $isa = \@{"$cvstashname\::ISA"};
570 if (grep($_ eq "AutoLoader", @$isa)) {
571 warn "Forcing immediate load of sub derived from AutoLoader\n";
572 # Tweaked version of AutoLoader::AUTOLOAD
573 my $dir = $cvstashname;
575 eval { require "auto/$dir/$cvname.al" };
577 warn qq(failed require "auto/$dir/$cvname.al": $@\n);
587 my $sym = objsym($cv);
589 # warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
592 # Reserve a place in svsect and xpvcvsect and record indices
593 my $sv_ix = $svsect->index + 1;
594 $svsect->add("svix$sv_ix");
595 my $xpvcv_ix = $xpvcvsect->index + 1;
596 $xpvcvsect->add("xpvcvix$xpvcv_ix");
597 # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
598 $sym = savesym($cv, "&sv_list[$sv_ix]");
599 warn sprintf("saving CV 0x%x as $sym\n", $$cv) if $debug_cv;
601 my $cvstashname = $gv->STASH->NAME;
602 my $cvname = $gv->NAME;
603 my $root = $cv->ROOT;
604 my $cvxsub = $cv->XSUB;
605 if (!$$root && !$cvxsub) {
606 if (try_autoload($cvstashname, $cvname)) {
607 # Recalculate root and xsub
610 if ($$root || $cvxsub) {
611 warn "Successful forced autoload\n";
616 my $padlist = $cv->PADLIST;
619 my $xsubany = "Nullany";
621 warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
622 $$cv, $$root) if $debug_cv;
625 my $stashname = $gv->STASH->NAME;
626 my $gvname = $gv->NAME;
627 if ($gvname ne "__ANON__") {
628 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
629 $ppname .= ($stashname eq "main") ?
630 $gvname : "$stashname\::$gvname";
631 $ppname =~ s/::/__/g;
632 if ($gvname eq "INIT"){
633 $ppname .= "_$initsub_index";
639 $ppname = "pp_anonsub_$anonsub_index";
642 $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
643 warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
644 $$cv, $ppname, $$root) if $debug_cv;
646 warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
647 $$padlist, $$cv) if $debug_cv;
649 warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
650 $$padlist, $$cv) if $debug_cv;
654 $xsubany = sprintf("ANYINIT((void*)0x%x)", $cv->XSUBANY);
655 # Try to find out canonical name of XSUB function from EGV.
656 # XXX Doesn't work for XSUBs with PREFIX set (or anyone who
657 # calls newXS() manually with weird arguments).
659 my $stashname = $egv->STASH->NAME;
660 $stashname =~ s/::/__/g;
661 $xsub = sprintf("XS_%s_%s", $stashname, $egv->NAME);
662 $decl->add("void $xsub (CV*));";
665 warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
666 $cvstashname, $cvname); # debug
668 $pv = '' unless defined $pv; # Avoid use of undef warnings
669 $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",
670 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
671 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
672 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
674 if (${$cv->OUTSIDE} == ${main_cv()}){
675 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
676 $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
681 $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
682 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
683 $$gv, $$cv) if $debug_cv;
685 my $filegv = $cv->FILEGV;
688 $init->add(sprintf("CvFILEGV(s\\_%x) = s\\_%x;", $$cv, $$filegv));
689 warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n",
690 $$filegv, $$cv) if $debug_cv;
692 my $stash = $cv->STASH;
695 $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
696 warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
697 $$stash, $$cv) if $debug_cv;
699 $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
700 $sv_ix, $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS));
705 my ($gv,$skip_cv) = @_;
706 my $sym = objsym($gv);
708 #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
711 my $ix = $gv_index++;
712 $sym = savesym($gv, "gv_list[$ix]");
713 #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
715 my $gvname = $gv->NAME;
716 my $name = cstring($gv->STASH->NAME . "::" . $gvname);
717 #warn "GV name is $name\n"; # debug
721 #warn(sprintf("EGV name is %s, saving it now\n",
722 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
723 $egvsym = $egv->save;
725 $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
726 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
727 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS),
728 sprintf("GvLINE($sym) = %u;", $gv->LINE));
729 # Shouldn't need to do save_magic since gv_fetchpv handles that
731 my $refcnt = $gv->REFCNT + 1;
732 $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
733 my $gvrefcnt = $gv->GvREFCNT;
735 $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
737 if (defined($egvsym)) {
738 # Shared glob *foo = *bar
739 $init->add("gp_free($sym);",
740 "GvGP($sym) = GvGP($egvsym);");
741 } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
742 # Don't save subfields of special GVs (*_, *1, *# and so on)
743 # warn "GV::save saving subfields\n"; # debug
747 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
748 # warn "GV::save \$$name\n"; # debug
753 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
754 # warn "GV::save \@$name\n"; # debug
759 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
760 # warn "GV::save \%$name\n"; # debug
763 if ($$gvcv && !$skip_cv) {
765 $init->add(sprintf("GvCV($sym) = (CV*)s\\_%x;", $$gvcv));
766 # warn "GV::save &$name\n"; # debug
768 my $gvfilegv = $gv->FILEGV;
771 $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv));
772 # warn "GV::save GvFILEGV(*$name)\n"; # debug
774 my $gvform = $gv->FORM;
777 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
778 # warn "GV::save GvFORM(*$name)\n"; # debug
783 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
784 # warn "GV::save GvIO(*$name)\n"; # debug
791 my $sym = objsym($av);
792 return $sym if defined $sym;
793 my $avflags = $av->AvFLAGS;
794 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
796 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
797 $xpvavsect->index, $av->REFCNT + 1, $av->FLAGS));
798 my $sv_list_index = $svsect->index;
799 my $fill = $av->FILL;
801 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
803 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
804 #if ($fill > -1 && ($avflags & AVf_REAL)) {
806 my @array = $av->ARRAY;
810 foreach $el (@array) {
811 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
812 $$av, $i++, class($el), $$el);
815 my @names = map($_->save, @array);
816 # XXX Better ways to write loop?
817 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
818 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
821 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
822 "\tav_extend(av, $fill);",
823 "\tsvp = AvARRAY(av);",
824 map("\t*svp++ = (SV*)$_;", @names),
825 "\tAvFILLp(av) = $fill;",
829 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
832 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
837 my $sym = objsym($hv);
838 return $sym if defined $sym;
839 my $name = $hv->NAME;
843 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
844 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
845 # a trashed op but we look at the trashed op_type and segfault.
846 #my $adpmroot = ${$hv->PMROOT};
848 $decl->add("static HV *hv$hv_index;");
849 # XXX Beware of weird package names containing double-quotes, \n, ...?
850 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
852 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
855 $sym = savesym($hv, "hv$hv_index");
859 # It's just an ordinary HV
860 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
861 $hv->MAX, $hv->RITER));
862 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
863 $xpvhvsect->index, $hv->REFCNT + 1, $hv->FLAGS));
864 my $sv_list_index = $svsect->index;
865 my @contents = $hv->ARRAY;
868 for ($i = 1; $i < @contents; $i += 2) {
869 $contents[$i] = $contents[$i]->save;
871 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
873 my ($key, $value) = splice(@contents, 0, 2);
874 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
875 cstring($key),length($key),$value, hash($key)));
876 # $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
877 # cstring($key),length($key),$value, 0));
882 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
887 my $sym = objsym($io);
888 return $sym if defined $sym;
890 $pv = '' unless defined $pv;
891 my $len = length($pv);
892 $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",
893 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
894 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
895 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
896 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
897 cchar($io->IoTYPE), $io->IoFLAGS));
898 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
899 $xpviosect->index, $io->REFCNT + 1, $io->FLAGS));
900 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
902 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
903 $fsym = $io->$field();
905 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
915 # This is where we catch an honest-to-goodness Nullsv (which gets
916 # blessed into B::SV explicitly) and any stray erroneous SVs.
917 return 0 unless $$sv;
918 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
923 my $init_name = shift;
925 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
926 $listopsect, $pmopsect, $svopsect, $gvopsect, $pvopsect,
927 $loopsect, $copsect, $svsect, $xpvsect,
928 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
929 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
930 $bootstrap->output(\*STDOUT, "/* bootstrap %s */\n");
931 $symsect->output(\*STDOUT, "#define %s\n");
933 output_declarations();
934 foreach $section (@sections) {
935 my $lines = $section->index + 1;
937 my $name = $section->name;
938 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
939 print "Static $typename ${name}_list[$lines];\n";
942 $decl->output(\*STDOUT, "%s\n");
944 foreach $section (@sections) {
945 my $lines = $section->index + 1;
947 my $name = $section->name;
948 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
949 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
950 $section->output(\*STDOUT, "\t{ %s },\n");
956 static int $init_name()
960 $init->output(\*STDOUT, "\t%s\n");
961 print "\treturn 0;\n}\n";
963 warn compile_stats();
964 warn "NULLOP count: $nullop_count\n";
968 sub output_declarations {
970 #ifdef BROKEN_STATIC_REDECL
971 #define Static extern
973 #define Static static
974 #endif /* BROKEN_STATIC_REDECL */
976 #ifdef BROKEN_UNION_INIT
978 * Cribbed from cv.h with ANY (a union) replaced by void*.
979 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
982 char * xpv_pv; /* pointer to malloced string */
983 STRLEN xpv_cur; /* length of xp_pv as a C string */
984 STRLEN xpv_len; /* allocated size */
985 IV xof_off; /* integer value */
986 double xnv_nv; /* numeric value, if any */
987 MAGIC* xmg_magic; /* magic for scalar array */
988 HV* xmg_stash; /* class package */
993 void (*xcv_xsub) (CV*);
997 long xcv_depth; /* >= 2 indicates recursive call */
1001 perl_mutex *xcv_mutexp;
1002 struct perl_thread *xcv_owner; /* current owner thread */
1003 #endif /* USE_THREADS */
1006 #define ANYINIT(i) i
1008 #define XPVCV_or_similar XPVCV
1009 #define ANYINIT(i) {i}
1010 #endif /* BROKEN_UNION_INIT */
1011 #define Nullany ANYINIT(0)
1017 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1022 sub output_boilerplate {
1027 /* Workaround for mapstart: the only op which needs a different ppaddr */
1029 #define pp_mapstart pp_grepstart
1030 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1031 EXTERN_C void boot_DynaLoader (CV* cv);
1033 static void xs_init (void);
1034 static PerlInterpreter *my_perl;
1041 #ifndef CAN_PROTOTYPE
1042 main(argc, argv, env)
1046 #else /* def(CAN_PROTOTYPE) */
1047 main(int argc, char **argv, char **env)
1048 #endif /* def(CAN_PROTOTYPE) */
1054 PERL_SYS_INIT(&argc,&argv);
1056 perl_init_i18nl10n(1);
1058 if (!PL_do_undump) {
1059 my_perl = perl_alloc();
1062 perl_construct( my_perl );
1067 PL_cshlen = strlen(PL_cshname);
1070 #ifdef ALLOW_PERL_OPTIONS
1071 #define EXTRA_OPTIONS 2
1073 #define EXTRA_OPTIONS 3
1074 #endif /* ALLOW_PERL_OPTIONS */
1075 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1076 fakeargv[0] = argv[0];
1079 #ifndef ALLOW_PERL_OPTIONS
1081 #endif /* ALLOW_PERL_OPTIONS */
1082 for (i = 1; i < argc; i++)
1083 fakeargv[i + EXTRA_OPTIONS] = argv[i];
1084 fakeargv[argc + EXTRA_OPTIONS] = 0;
1086 exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1091 sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1092 PL_main_cv = PL_compcv;
1095 exitstatus = perl_init();
1099 exitstatus = perl_run( my_perl );
1101 perl_destruct( my_perl );
1102 perl_free( my_perl );
1107 /* yanked from perl.c */
1111 char *file = __FILE__;
1113 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
1121 warn "----Symbol table:\n";
1122 while (($sym, $val) = each %symtable) {
1123 warn "$sym => $val\n";
1125 warn "---End of symbol table\n";
1131 svref_2object($sv)->save;
1135 sub Dummy_BootStrap { }
1140 my $package=$gv->STASH->NAME;
1141 my $name = $gv->NAME;
1148 # We may be looking at this package just because it is a branch in the
1149 # symbol table which is on the path to a package which we need to save
1150 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1152 return unless ($unused_sub_packages{$package});
1155 if ($name eq "bootstrap" && $cv->XSUB)
1157 my $file = $cv->FILEGV->SV->PV;
1158 $bootstrap->add($file);
1159 my $name = $gv->STASH->NAME.'::'.$name;
1161 *{$name} = \&Dummy_BootStrap;
1164 warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
1165 $package, $name, $$cv, $$gv) if ($debug_cv);
1169 return unless ($$av || $$sv || $$hv)
1171 $gv->save($skip_cv);
1176 my $package = shift;
1177 unless ($unused_sub_packages{$package})
1180 $unused_sub_packages{$package} = 1;
1181 if (defined(@{$package.'::ISA'}))
1183 foreach my $isa (@{$package.'::ISA'})
1185 if ($isa eq 'DynaLoader')
1187 unless (defined(&{$package.'::bootstrap'}))
1189 warn "Forcing bootstrap of $package\n";
1190 eval { $package->bootstrap };
1195 unless ($unused_sub_packages{$isa})
1197 warn "$isa saved (it is in $package\'s \@ISA)\n";
1209 no strict qw(vars refs);
1210 my $package = shift;
1211 $package =~ s/::$//;
1212 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1213 # warn "Considering $package\n";#debug
1214 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1216 # If this package is a prefix to something we are saving, traverse it
1217 # but do not mark it for saving if it is not already
1218 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1220 return 1 if ($u =~ /^$package\:\:/);
1222 if (exists $unused_sub_packages{$package})
1224 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1225 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1226 return $unused_sub_packages{$package};
1228 # Omit the packages which we use (and which cause grief
1229 # because of fancy "goto &$AUTOLOAD" stuff).
1230 # XXX Surely there must be a nicer way to do this.
1231 if ($package eq "FileHandle" || $package eq "Config" ||
1232 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1234 delete_unsaved_hashINC($package);
1235 return $unused_sub_packages{$package} = 0;
1237 # Now see if current package looks like an OO class this is probably too strong.
1238 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1240 if ($package->can($m))
1242 warn "$package has method $m: saving package\n";#debug
1243 return mark_package($package);
1246 delete_unsaved_hashINC($package);
1247 return $unused_sub_packages{$package} = 0;
1249 sub delete_unsaved_hashINC{
1251 $packname =~ s/\:\:/\//g;
1253 # warn "deleting $packname" if $INC{$packname} ;# debug
1254 delete $INC{$packname};
1258 my ($symref, $recurse, $prefix) = @_;
1263 $prefix = '' unless defined $prefix;
1264 while (($sym, $ref) = each %$symref)
1269 $sym = $prefix . $sym;
1270 if ($sym ne "main::" && &$recurse($sym))
1272 walkpackages(\%glob, $recurse, $sym);
1279 sub save_unused_subs
1282 &descend_marked_unused;
1284 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1285 warn "Saving methods\n";
1286 walksymtable(\%{"main::"}, "savecv", \&should_save);
1291 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1292 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1293 my $inc_hv = svref_2object(\%INC)->save;
1294 my $inc_av = svref_2object(\@INC)->save;
1295 my $amagic_generate= amagic_generation;
1296 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1297 "GvHV(PL_incgv) = $inc_hv;",
1298 "GvAV(PL_incgv) = $inc_av;",
1299 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1300 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1301 "PL_amagic_generation= $amagic_generate;" );
1304 sub descend_marked_unused {
1305 foreach my $pack (keys %unused_sub_packages)
1307 mark_package($pack);
1312 warn "Starting compile\n";
1313 warn "Walking tree\n";
1314 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1315 walkoptree(main_root, "save");
1316 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1318 my $init_av = init_av->save;
1319 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1320 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1321 "PL_initav = (AV *) $init_av;");
1323 warn "Writing output\n";
1324 output_boilerplate();
1326 output_all("perl_init");
1332 my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1333 binop => \$binopsect, condop => \$condopsect,
1334 cop => \$copsect, gvop => \$gvopsect,
1335 listop => \$listopsect, logop => \$logopsect,
1336 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1337 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1338 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1339 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1340 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1341 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1342 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1343 xpvio => \$xpviosect, bootstrap => \$bootstrap);
1344 my ($name, $sectref);
1345 while (($name, $sectref) = splice(@sections, 0, 2)) {
1346 $$sectref = new B::C::Section $name, \%symtable, 0;
1352 my ($arg,$val) = @_;
1353 $unused_sub_packages{$arg} = $val;
1358 my ($option, $opt, $arg);
1360 while ($option = shift @options) {
1361 if ($option =~ /^-(.)(.*)/) {
1365 unshift @options, $option;
1368 if ($opt eq "-" && $arg eq "-") {
1373 $warn_undefined_syms = 1;
1374 } elsif ($opt eq "D") {
1375 $arg ||= shift @options;
1376 foreach $arg (split(//, $arg)) {
1379 } elsif ($arg eq "c") {
1381 } elsif ($arg eq "A") {
1383 } elsif ($arg eq "C") {
1385 } elsif ($arg eq "M") {
1388 warn "ignoring unknown debug option: $arg\n";
1391 } elsif ($opt eq "o") {
1392 $arg ||= shift @options;
1393 open(STDOUT, ">$arg") or return "$arg: $!\n";
1394 } elsif ($opt eq "v") {
1396 } elsif ($opt eq "u") {
1397 $arg ||= shift @options;
1398 mark_unused($arg,undef);
1399 } elsif ($opt eq "f") {
1400 $arg ||= shift @options;
1401 if ($arg eq "cog") {
1402 $pv_copy_on_grow = 1;
1403 } elsif ($arg eq "no-cog") {
1404 $pv_copy_on_grow = 0;
1406 } elsif ($opt eq "O") {
1407 $arg = 1 if $arg eq "";
1408 $pv_copy_on_grow = 0;
1410 # Optimisations for -O1
1411 $pv_copy_on_grow = 1;
1419 foreach $objname (@options) {
1420 eval "save_object(\\$objname)";
1425 return sub { save_main() };
1435 B::C - Perl compiler's C backend
1439 perl -MO=C[,OPTIONS] foo.pl
1443 This compiler backend takes Perl source and generates C source code
1444 corresponding to the internal structures that perl uses to run
1445 your program. When the generated C source is compiled and run, it
1446 cuts out the time which perl would have taken to load and parse
1447 your program into its internal semi-compiled form. That means that
1448 compiling with this backend will not help improve the runtime
1449 execution speed of your program but may improve the start-up time.
1450 Depending on the environment in which your program runs this may be
1451 either a help or a hindrance.
1455 If there are any non-option arguments, they are taken to be
1456 names of objects to be saved (probably doesn't work properly yet).
1457 Without extra arguments, it saves the main program.
1463 Output to filename instead of STDOUT
1467 Verbose compilation (currently gives a few compilation statistics).
1471 Force end of options
1475 Force apparently unused subs from package Packname to be compiled.
1476 This allows programs to use eval "foo()" even when sub foo is never
1477 seen to be used at compile time. The down side is that any subs which
1478 really are never used also have code generated. This option is
1479 necessary, for example, if you have a signal handler foo which you
1480 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1481 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1482 options. The compiler tries to figure out which packages may possibly
1483 have subs in which need compiling but the current version doesn't do
1484 it very well. In particular, it is confused by nested packages (i.e.
1485 of the form C<A::B>) where package C<A> does not contain any subs.
1489 Debug options (concatenated or separate flags like C<perl -D>).
1493 OPs, prints each OP as it's processed
1497 COPs, prints COPs as processed (incl. file & line num)
1501 prints AV information on saving
1505 prints CV information on saving
1509 prints MAGIC information on saving
1513 Force optimisations on or off one at a time.
1517 Copy-on-grow: PVs declared and initialised statically.
1525 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
1526 B<-O1> and higher set B<-fcog>.
1530 perl -MO=C,-ofoo.c foo.pl
1531 perl cc_harness -o foo foo.c
1533 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1534 library directory. The utility called C<perlcc> may also be used to
1535 help make use of this compiler.
1537 perl -MO=C,-v,-DcA bar.pl > /dev/null
1541 Plenty. Current status: experimental.
1545 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>