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
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
768 if ($$gvcv && !$skip_cv) {
769 $init->add(sprintf("GvCV($sym) = (CV*)s\\_%x;", $$gvcv));
770 # warn "GV::save &$name\n"; # debug
773 my $gvfilegv = $gv->FILEGV;
775 $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv));
776 # warn "GV::save GvFILEGV(*$name)\n"; # debug
779 my $gvform = $gv->FORM;
781 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
782 # warn "GV::save GvFORM(*$name)\n"; # debug
787 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
788 # 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 return $unused_sub_packages{$package}
1231 # Omit the packages which we use (and which cause grief
1232 # because of fancy "goto &$AUTOLOAD" stuff).
1233 # XXX Surely there must be a nicer way to do this.
1234 if ($package eq "FileHandle" || $package eq "Config" ||
1235 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1237 return $unused_sub_packages{$package} = 0;
1239 # Now see if current package looks like an OO class this is probably too strong.
1240 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1242 if ($package->can($m))
1244 warn "$package has method $m: saving package\n";#debug
1245 return mark_package($package);
1248 return $unused_sub_packages{$package} = 0;
1253 my ($symref, $recurse, $prefix) = @_;
1258 $prefix = '' unless defined $prefix;
1259 while (($sym, $ref) = each %$symref)
1264 $sym = $prefix . $sym;
1265 if ($sym ne "main::" && &$recurse($sym))
1267 walkpackages(\%glob, $recurse, $sym);
1274 sub save_unused_subs
1277 &descend_marked_unused;
1279 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1280 warn "Saving methods\n";
1281 walksymtable(\%{"main::"}, "savecv", \&should_save);
1286 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1287 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1288 my $inc_hv = svref_2object(\%INC)->save;
1289 my $inc_av = svref_2object(\@INC)->save;
1290 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1291 "GvHV(PL_incgv) = $inc_hv;",
1292 "GvAV(PL_incgv) = $inc_av;",
1293 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1294 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));");
1297 sub descend_marked_unused {
1298 foreach my $pack (keys %unused_sub_packages)
1300 mark_package($pack);
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 = $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>