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);
53 use B::Asmdata qw(@specialsv_name);
63 my $anonsub_index = 0;
64 my $initsub_index = 0;
67 my $warn_undefined_syms;
69 my %unused_sub_packages;
71 my $pv_copy_on_grow = 0;
72 my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
76 @threadsv_names = threadsv_names();
80 my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect,
81 $gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
82 $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
83 $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
84 $xrvsect, $xpvbmsect, $xpviosect, $bootstrap);
86 sub walk_and_save_optree;
87 my $saveoptree_callback = \&walk_and_save_optree;
88 sub set_callback { $saveoptree_callback = shift }
89 sub saveoptree { &$saveoptree_callback(@_) }
91 sub walk_and_save_optree {
92 my ($name, $root, $start) = @_;
93 walkoptree($root, "save");
94 return objsym($start);
97 # Current workaround/fix for op_free() trying to free statically
98 # defined OPs is to set op_seq = -1 and check for that in op_free().
99 # Instead of hardwiring -1 in place of $op->seq, we use $op_seq
100 # so that it can be changed back easily if necessary. In fact, to
101 # stop compilers from moaning about a U16 being initialised with an
102 # uncast -1 (the printf format is %d so we can't tweak it), we have
103 # to "know" that op_seq is a U16 and use 65535. Ugh.
106 # Look this up here so we can do just a number compare
107 # rather than looking up the name of every BASEOP in B::OP
108 my $OP_THREADSV = opnumber('threadsv');
111 my ($obj, $value) = @_;
112 my $sym = sprintf("s\\_%x", $$obj);
113 $symtable{$sym} = $value;
118 return $symtable{sprintf("s\\_%x", $$obj)};
125 return 0 if $sym eq "sym_0"; # special case
126 $value = $symtable{$sym};
127 if (defined($value)) {
130 warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
137 $pv = '' unless defined $pv; # Is this sane ?
140 if ($pv_copy_on_grow) {
141 my $cstring = cstring($pv);
142 if ($cstring ne "0") { # sic
143 $pvsym = sprintf("pv%d", $pv_index++);
144 $decl->add(sprintf("static char %s[] = %s;", $pvsym, $cstring));
147 $pvmax = length($pv) + 1;
149 return ($pvsym, $pvmax);
153 my ($op, $level) = @_;
154 my $type = $op->type;
155 $nullop_count++ unless $type;
156 if ($type == $OP_THREADSV) {
157 # saves looking up ppaddr but it's a bit naughty to hard code this
158 $init->add(sprintf("(void)find_threadsv(%s);",
159 cstring($threadsv_names[$op->targ])));
161 $opsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x",
162 ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
163 $type, $op_seq, $op->flags, $op->private));
164 savesym($op, sprintf("&op_list[%d]", $opsect->index));
168 my ($class, %objdata) = @_;
169 bless \%objdata, $class;
172 sub B::FAKEOP::save {
173 my ($op, $level) = @_;
174 $opsect->add(sprintf("%s, %s, %s, %u, %u, %u, 0x%x, 0x%x",
175 $op->next, $op->sibling, $op->ppaddr, $op->targ,
176 $op->type, $op_seq, $op->flags, $op->private));
177 return sprintf("&op_list[%d]", $opsect->index);
180 sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
181 sub B::FAKEOP::type { $_[0]->{type} || 0}
182 sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
183 sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
184 sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
185 sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
186 sub B::FAKEOP::private { $_[0]->{private} || 0 }
189 my ($op, $level) = @_;
190 $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x",
191 ${$op->next}, ${$op->sibling}, $op->ppaddr,
192 $op->targ, $op->type, $op_seq, $op->flags,
193 $op->private, ${$op->first}));
194 savesym($op, sprintf("(OP*)&unop_list[%d]", $unopsect->index));
198 my ($op, $level) = @_;
199 $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
200 ${$op->next}, ${$op->sibling}, $op->ppaddr,
201 $op->targ, $op->type, $op_seq, $op->flags,
202 $op->private, ${$op->first}, ${$op->last}));
203 savesym($op, sprintf("(OP*)&binop_list[%d]", $binopsect->index));
206 sub B::LISTOP::save {
207 my ($op, $level) = @_;
208 $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u",
209 ${$op->next}, ${$op->sibling}, $op->ppaddr,
210 $op->targ, $op->type, $op_seq, $op->flags,
211 $op->private, ${$op->first}, ${$op->last},
213 savesym($op, sprintf("(OP*)&listop_list[%d]", $listopsect->index));
217 my ($op, $level) = @_;
218 $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
219 ${$op->next}, ${$op->sibling}, $op->ppaddr,
220 $op->targ, $op->type, $op_seq, $op->flags,
221 $op->private, ${$op->first}, ${$op->other}));
222 savesym($op, sprintf("(OP*)&logop_list[%d]", $logopsect->index));
225 sub B::CONDOP::save {
226 my ($op, $level) = @_;
227 $condopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x",
228 ${$op->next}, ${$op->sibling}, $op->ppaddr,
229 $op->targ, $op->type, $op_seq, $op->flags,
230 $op->private, ${$op->first}, ${$op->true},
232 savesym($op, sprintf("(OP*)&condop_list[%d]", $condopsect->index));
236 my ($op, $level) = @_;
237 #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
238 # peekop($op->redoop), peekop($op->nextop),
239 # peekop($op->lastop)); # debug
240 $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",
241 ${$op->next}, ${$op->sibling}, $op->ppaddr,
242 $op->targ, $op->type, $op_seq, $op->flags,
243 $op->private, ${$op->first}, ${$op->last},
244 $op->children, ${$op->redoop}, ${$op->nextop},
246 savesym($op, sprintf("(OP*)&loop_list[%d]", $loopsect->index));
250 my ($op, $level) = @_;
251 $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
252 ${$op->next}, ${$op->sibling}, $op->ppaddr,
253 $op->targ, $op->type, $op_seq, $op->flags,
254 $op->private, cstring($op->pv)));
255 savesym($op, sprintf("(OP*)&pvop_list[%d]", $pvopsect->index));
259 my ($op, $level) = @_;
260 my $svsym = $op->sv->save;
261 $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
262 ${$op->next}, ${$op->sibling}, $op->ppaddr,
263 $op->targ, $op->type, $op_seq, $op->flags,
264 $op->private, "(SV*)$svsym"));
265 savesym($op, sprintf("(OP*)&svop_list[%d]", $svopsect->index));
269 my ($op, $level) = @_;
270 my $gvsym = $op->gv->save;
271 $gvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullgv",
272 ${$op->next}, ${$op->sibling}, $op->ppaddr,
273 $op->targ, $op->type, $op_seq, $op->flags,
275 $init->add(sprintf("gvop_list[%d].op_gv = %s;", $gvopsect->index, $gvsym));
276 savesym($op, sprintf("(OP*)&gvop_list[%d]", $gvopsect->index));
280 my ($op, $level) = @_;
281 my $gvsym = $op->filegv->save;
282 my $stashsym = $op->stash->save;
283 warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV)
285 $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u",
286 ${$op->next}, ${$op->sibling}, $op->ppaddr,
287 $op->targ, $op->type, $op_seq, $op->flags,
288 $op->private, cstring($op->label), $op->cop_seq,
289 $op->arybase, $op->line));
290 my $copix = $copsect->index;
291 $init->add(sprintf("cop_list[%d].cop_filegv = %s;", $copix, $gvsym),
292 sprintf("cop_list[%d].cop_stash = %s;", $copix, $stashsym));
293 savesym($op, "(OP*)&cop_list[$copix]");
297 my ($op, $level) = @_;
298 my $replroot = $op->pmreplroot;
299 my $replstart = $op->pmreplstart;
300 my $replrootfield = sprintf("s\\_%x", $$replroot);
301 my $replstartfield = sprintf("s\\_%x", $$replstart);
303 my $ppaddr = $op->ppaddr;
305 # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
306 # argument to a split) stores a GV in op_pmreplroot instead
307 # of a substitution syntax tree. We don't want to walk that...
308 if ($ppaddr eq "pp_pushre") {
309 $gvsym = $replroot->save;
310 # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
313 $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
316 # pmnext handling is broken in perl itself, I think. Bad op_pmnext
317 # fields aren't noticed in perl's runtime (unless you try reset) but we
318 # segfault when trying to dereference it to find op->op_pmnext->op_type
319 $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",
320 ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ,
321 $op->type, $op_seq, $op->flags, $op->private,
322 ${$op->first}, ${$op->last}, $op->children,
323 $replrootfield, $replstartfield,
324 $op->pmflags, $op->pmpermflags,));
325 my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
326 my $re = $op->precomp;
328 my $resym = sprintf("re%d", $re_index++);
329 $decl->add(sprintf("static char *$resym = %s;", cstring($re)));
330 $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
334 $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
336 savesym($op, sprintf("(OP*)&pmop_list[%d]", $pmopsect->index));
339 sub B::SPECIAL::save {
341 # special case: $$sv is not the address but an index into specialsv_list
342 # warn "SPECIAL::save specialsv $$sv\n"; # debug
343 my $sym = $specialsv_name[$$sv];
344 if (!defined($sym)) {
345 confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
350 sub B::OBJECT::save {}
354 my $sym = objsym($sv);
355 return $sym if defined $sym;
356 # warn "Saving SVt_NULL SV\n"; # debug
359 # warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
361 $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT + 1, $sv->FLAGS));
362 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
367 my $sym = objsym($sv);
368 return $sym if defined $sym;
369 $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
370 $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
371 $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
372 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
377 my $sym = objsym($sv);
378 return $sym if defined $sym;
379 $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $sv->NVX));
380 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
381 $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
382 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
387 my $sym = objsym($sv);
388 return $sym if defined $sym;
390 my $len = length($pv);
391 my ($pvsym, $pvmax) = savepv($pv);
392 my ($lvtarg, $lvtarg_sym);
393 $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
394 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
395 $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
396 $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
397 $xpvlvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
398 if (!$pv_copy_on_grow) {
399 $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);",
400 $xpvlvsect->index, cstring($pv), $len));
403 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
408 my $sym = objsym($sv);
409 return $sym if defined $sym;
411 my $len = length($pv);
412 my ($pvsym, $pvmax) = savepv($pv);
413 $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
414 $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
415 $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
416 if (!$pv_copy_on_grow) {
417 $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);",
418 $xpvivsect->index, cstring($pv), $len));
420 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
425 my $sym = objsym($sv);
426 return $sym if defined $sym;
428 $pv = '' unless defined $pv;
429 my $len = length($pv);
430 my ($pvsym, $pvmax) = savepv($pv);
431 $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
432 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
433 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
434 $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
435 if (!$pv_copy_on_grow) {
436 $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);",
437 $xpvnvsect->index, cstring($pv), $len));
439 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
444 my $sym = objsym($sv);
445 return $sym if defined $sym;
446 my $pv = $sv->PV . "\0" . $sv->TABLE;
447 my $len = length($pv);
448 $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
449 $len, $len + 258, $sv->IVX, $sv->NVX,
450 $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
451 $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
452 $xpvbmsect->index, $sv->REFCNT + 1, $sv->FLAGS));
454 $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);",
455 $xpvbmsect->index, cstring($pv), $len),
456 sprintf("xpvbm_list[%d].xpv_cur = %u;",
457 $xpvbmsect->index, $len - 257));
458 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
463 my $sym = objsym($sv);
464 return $sym if defined $sym;
466 my $len = length($pv);
467 my ($pvsym, $pvmax) = savepv($pv);
468 $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
469 $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
470 $xpvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
471 if (!$pv_copy_on_grow) {
472 $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);",
473 $xpvsect->index, cstring($pv), $len));
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 $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
486 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
487 $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
488 $xpvmgsect->index, $sv->REFCNT + 1, $sv->FLAGS));
489 if (!$pv_copy_on_grow) {
490 $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);",
491 $xpvmgsect->index, cstring($pv), $len));
493 $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
498 sub B::PVMG::save_magic {
500 #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
501 my $stash = $sv->SvSTASH;
503 warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
505 # XXX Hope stash is already going to be saved.
506 $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
508 my @mgchain = $sv->MAGIC;
509 my ($mg, $type, $obj, $ptr);
510 foreach $mg (@mgchain) {
514 my $len = defined($ptr) ? length($ptr) : 0;
516 warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
517 class($sv), $$sv, class($obj), $$obj,
518 cchar($type), cstring($ptr));
520 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
521 $$sv, $$obj, cchar($type),cstring($ptr),$len));
527 my $sym = objsym($sv);
528 return $sym if defined $sym;
529 my $rv = $sv->RV->save;
530 $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/;
532 $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
533 $xrvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
534 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
538 my ($cvstashname, $cvname) = @_;
539 warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
540 # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
541 # use should be handled by the class itself.
543 my $isa = \@{"$cvstashname\::ISA"};
544 if (grep($_ eq "AutoLoader", @$isa)) {
545 warn "Forcing immediate load of sub derived from AutoLoader\n";
546 # Tweaked version of AutoLoader::AUTOLOAD
547 my $dir = $cvstashname;
549 eval { require "auto/$dir/$cvname.al" };
551 warn qq(failed require "auto/$dir/$cvname.al": $@\n);
561 my $sym = objsym($cv);
563 # warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
566 # Reserve a place in svsect and xpvcvsect and record indices
567 my $sv_ix = $svsect->index + 1;
568 $svsect->add("svix$sv_ix");
569 my $xpvcv_ix = $xpvcvsect->index + 1;
570 $xpvcvsect->add("xpvcvix$xpvcv_ix");
571 # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
572 $sym = savesym($cv, "&sv_list[$sv_ix]");
573 warn sprintf("saving CV 0x%x as $sym\n", $$cv) if $debug_cv;
575 my $cvstashname = $gv->STASH->NAME;
576 my $cvname = $gv->NAME;
577 my $root = $cv->ROOT;
578 my $cvxsub = $cv->XSUB;
579 if (!$$root && !$cvxsub) {
580 if (try_autoload($cvstashname, $cvname)) {
581 # Recalculate root and xsub
584 if ($$root || $cvxsub) {
585 warn "Successful forced autoload\n";
590 my $padlist = $cv->PADLIST;
593 my $xsubany = "Nullany";
595 warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
596 $$cv, $$root) if $debug_cv;
599 my $stashname = $gv->STASH->NAME;
600 my $gvname = $gv->NAME;
601 if ($gvname ne "__ANON__") {
602 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
603 $ppname .= ($stashname eq "main") ?
604 $gvname : "$stashname\::$gvname";
605 $ppname =~ s/::/__/g;
606 if ($gvname eq "INIT"){
607 $ppname .= "_$initsub_index";
613 $ppname = "pp_anonsub_$anonsub_index";
616 $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
617 warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
618 $$cv, $ppname, $$root) if $debug_cv;
620 warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
621 $$padlist, $$cv) if $debug_cv;
623 warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
624 $$padlist, $$cv) if $debug_cv;
628 $xsubany = sprintf("ANYINIT((void*)0x%x)", $cv->XSUBANY);
629 # Try to find out canonical name of XSUB function from EGV.
630 # XXX Doesn't work for XSUBs with PREFIX set (or anyone who
631 # calls newXS() manually with weird arguments).
633 my $stashname = $egv->STASH->NAME;
634 $stashname =~ s/::/__/g;
635 $xsub = sprintf("XS_%s_%s", $stashname, $egv->NAME);
636 $decl->add("void $xsub _((CV*));");
639 warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
640 $cvstashname, $cvname); # debug
642 $pv = '' unless defined $pv; # Avoid use of undef warnings
643 $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",
644 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
645 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
646 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
648 if (${$cv->OUTSIDE} == ${main_cv()}){
649 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
654 $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
655 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
656 $$gv, $$cv) if $debug_cv;
658 my $filegv = $cv->FILEGV;
661 $init->add(sprintf("CvFILEGV(s\\_%x) = s\\_%x;", $$cv, $$filegv));
662 warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n",
663 $$filegv, $$cv) if $debug_cv;
665 my $stash = $cv->STASH;
668 $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
669 warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
670 $$stash, $$cv) if $debug_cv;
672 $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
673 $sv_ix, $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS));
678 my ($gv,$skip_cv) = @_;
679 my $sym = objsym($gv);
681 #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
684 my $ix = $gv_index++;
685 $sym = savesym($gv, "gv_list[$ix]");
686 #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
688 my $gvname = $gv->NAME;
689 my $name = cstring($gv->STASH->NAME . "::" . $gvname);
690 #warn "GV name is $name\n"; # debug
694 #warn(sprintf("EGV name is %s, saving it now\n",
695 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
696 $egvsym = $egv->save;
698 $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
699 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
700 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS),
701 sprintf("GvLINE($sym) = %u;", $gv->LINE));
702 # Shouldn't need to do save_magic since gv_fetchpv handles that
704 my $refcnt = $gv->REFCNT + 1;
705 $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
706 my $gvrefcnt = $gv->GvREFCNT;
708 $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
710 if (defined($egvsym)) {
711 # Shared glob *foo = *bar
712 $init->add("gp_free($sym);",
713 "GvGP($sym) = GvGP($egvsym);");
714 } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
715 # Don't save subfields of special GVs (*_, *1, *# and so on)
716 # warn "GV::save saving subfields\n"; # debug
719 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
720 # warn "GV::save \$$name\n"; # debug
725 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
726 # warn "GV::save \@$name\n"; # debug
731 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
732 # warn "GV::save \%$name\n"; # debug
736 if ($$gvcv && !$skip_cv) {
737 $init->add(sprintf("GvCV($sym) = (CV*)s\\_%x;", $$gvcv));
738 # warn "GV::save &$name\n"; # debug
741 my $gvfilegv = $gv->FILEGV;
743 $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv));
744 # warn "GV::save GvFILEGV(*$name)\n"; # debug
747 my $gvform = $gv->FORM;
749 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
750 # warn "GV::save GvFORM(*$name)\n"; # debug
755 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
756 # warn "GV::save GvIO(*$name)\n"; # debug
764 my $sym = objsym($av);
765 return $sym if defined $sym;
766 my $avflags = $av->AvFLAGS;
767 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
769 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
770 $xpvavsect->index, $av->REFCNT + 1, $av->FLAGS));
771 my $sv_list_index = $svsect->index;
772 my $fill = $av->FILL;
774 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
776 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
777 #if ($fill > -1 && ($avflags & AVf_REAL)) {
779 my @array = $av->ARRAY;
783 foreach $el (@array) {
784 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
785 $$av, $i++, class($el), $$el);
788 my @names = map($_->save, @array);
789 # XXX Better ways to write loop?
790 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
791 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
794 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
795 "\tav_extend(av, $fill);",
796 "\tsvp = AvARRAY(av);",
797 map("\t*svp++ = (SV*)$_;", @names),
798 "\tAvFILLp(av) = $fill;",
802 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
805 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
810 my $sym = objsym($hv);
811 return $sym if defined $sym;
812 my $name = $hv->NAME;
816 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
817 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
818 # a trashed op but we look at the trashed op_type and segfault.
819 #my $adpmroot = ${$hv->PMROOT};
821 $decl->add("static HV *hv$hv_index;");
822 # XXX Beware of weird package names containing double-quotes, \n, ...?
823 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
825 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
828 $sym = savesym($hv, "hv$hv_index");
832 # It's just an ordinary HV
833 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
834 $hv->MAX, $hv->RITER));
835 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
836 $xpvhvsect->index, $hv->REFCNT + 1, $hv->FLAGS));
837 my $sv_list_index = $svsect->index;
838 my @contents = $hv->ARRAY;
841 for ($i = 1; $i < @contents; $i += 2) {
842 $contents[$i] = $contents[$i]->save;
844 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
846 my ($key, $value) = splice(@contents, 0, 2);
847 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
848 cstring($key),length($key),$value, hash($key)));
849 # $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
850 # cstring($key),length($key),$value, 0));
854 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
859 my $sym = objsym($io);
860 return $sym if defined $sym;
862 $pv = '' unless defined $pv;
863 my $len = length($pv);
864 $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",
865 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
866 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
867 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
868 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
869 cchar($io->IoTYPE), $io->IoFLAGS));
870 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
871 $xpviosect->index, $io->REFCNT + 1, $io->FLAGS));
872 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
874 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
875 $fsym = $io->$field();
877 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
887 # This is where we catch an honest-to-goodness Nullsv (which gets
888 # blessed into B::SV explicitly) and any stray erroneous SVs.
889 return 0 unless $$sv;
890 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
895 my $init_name = shift;
897 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
898 $listopsect, $pmopsect, $svopsect, $gvopsect, $pvopsect,
899 $loopsect, $copsect, $svsect, $xpvsect,
900 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
901 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
902 $bootstrap->output(\*STDOUT, "/* bootstrap %s */\n");
903 $symsect->output(\*STDOUT, "#define %s\n");
905 output_declarations();
906 foreach $section (@sections) {
907 my $lines = $section->index + 1;
909 my $name = $section->name;
910 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
911 print "Static $typename ${name}_list[$lines];\n";
914 $decl->output(\*STDOUT, "%s\n");
916 foreach $section (@sections) {
917 my $lines = $section->index + 1;
919 my $name = $section->name;
920 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
921 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
922 $section->output(\*STDOUT, "\t{ %s },\n");
928 static int $init_name()
932 $init->output(\*STDOUT, "\t%s\n");
933 print "\treturn 0;\n}\n";
935 warn compile_stats();
936 warn "NULLOP count: $nullop_count\n";
940 sub output_declarations {
942 #ifdef BROKEN_STATIC_REDECL
943 #define Static extern
945 #define Static static
946 #endif /* BROKEN_STATIC_REDECL */
948 #ifdef BROKEN_UNION_INIT
950 * Cribbed from cv.h with ANY (a union) replaced by void*.
951 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
954 char * xpv_pv; /* pointer to malloced string */
955 STRLEN xpv_cur; /* length of xp_pv as a C string */
956 STRLEN xpv_len; /* allocated size */
957 IV xof_off; /* integer value */
958 double xnv_nv; /* numeric value, if any */
959 MAGIC* xmg_magic; /* magic for scalar array */
960 HV* xmg_stash; /* class package */
965 void (*xcv_xsub) _((CV*));
969 long xcv_depth; /* >= 2 indicates recursive call */
973 perl_mutex *xcv_mutexp;
974 struct perl_thread *xcv_owner; /* current owner thread */
975 #endif /* USE_THREADS */
980 #define XPVCV_or_similar XPVCV
981 #define ANYINIT(i) {i}
982 #endif /* BROKEN_UNION_INIT */
983 #define Nullany ANYINIT(0)
989 print "static GV *gv_list[$gv_index];\n" if $gv_index;
994 sub output_boilerplate {
999 #include "patchlevel.h"
1002 /* Workaround for mapstart: the only op which needs a different ppaddr */
1004 #define pp_mapstart pp_grepstart
1006 static void xs_init _((void));
1007 static PerlInterpreter *my_perl;
1014 #ifndef CAN_PROTOTYPE
1015 main(argc, argv, env)
1019 #else /* def(CAN_PROTOTYPE) */
1020 main(int argc, char **argv, char **env)
1021 #endif /* def(CAN_PROTOTYPE) */
1027 PERL_SYS_INIT(&argc,&argv);
1029 perl_init_i18nl10n(1);
1031 if (!PL_do_undump) {
1032 my_perl = perl_alloc();
1035 perl_construct( my_perl );
1040 PL_cshlen = strlen(PL_cshname);
1043 #ifdef ALLOW_PERL_OPTIONS
1044 #define EXTRA_OPTIONS 2
1046 #define EXTRA_OPTIONS 3
1047 #endif /* ALLOW_PERL_OPTIONS */
1048 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1049 fakeargv[0] = argv[0];
1052 #ifndef ALLOW_PERL_OPTIONS
1054 #endif /* ALLOW_PERL_OPTIONS */
1055 for (i = 1; i < argc; i++)
1056 fakeargv[i + EXTRA_OPTIONS] = argv[i];
1057 fakeargv[argc + EXTRA_OPTIONS] = 0;
1059 exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1064 sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1065 PL_main_cv = PL_compcv;
1068 exitstatus = perl_init();
1072 exitstatus = perl_run( my_perl );
1074 perl_destruct( my_perl );
1075 perl_free( my_perl );
1090 warn "----Symbol table:\n";
1091 while (($sym, $val) = each %symtable) {
1092 warn "$sym => $val\n";
1094 warn "---End of symbol table\n";
1100 svref_2object($sv)->save;
1104 sub Dummy_BootStrap { }
1109 my $package=$gv->STASH->NAME;
1110 my $name = $gv->NAME;
1117 # We may be looking at this package just because it is a branch in the
1118 # symbol table which is on the path to a package which we need to save
1119 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1121 return unless ($unused_sub_packages{$package});
1124 if ($name eq "bootstrap" && $cv->XSUB)
1126 my $file = $cv->FILEGV->SV->PV;
1127 $bootstrap->add($file);
1128 my $name = $gv->STASH->NAME.'::'.$name;
1130 *{$name} = \&Dummy_BootStrap;
1133 warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
1134 $package, $name, $$cv, $$gv) if ($debug_cv);
1138 return unless ($$av || $$sv || $$hv)
1140 $gv->save($skip_cv);
1145 my $package = shift;
1146 unless ($unused_sub_packages{$package})
1149 $unused_sub_packages{$package} = 1;
1150 if (defined(@{$package.'::ISA'}))
1152 foreach my $isa (@{$package.'::ISA'})
1154 if ($isa eq 'DynaLoader')
1156 unless (defined(&{$package.'::bootstrap'}))
1158 warn "Forcing bootstrap of $package\n";
1159 eval { $package->bootstrap };
1164 unless ($unused_sub_packages{$isa})
1166 warn "$isa saved (it is in $package\'s \@ISA)\n";
1178 no strict qw(vars refs);
1179 my $package = shift;
1180 $package =~ s/::$//;
1181 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1182 # warn "Considering $package\n";#debug
1183 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1185 # If this package is a prefix to something we are saving, traverse it
1186 # but do not mark it for saving if it is not already
1187 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1189 return 1 if ($u =~ /^$package\:\:/);
1191 if (exists $unused_sub_packages{$package})
1193 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1194 return $unused_sub_packages{$package}
1196 # Omit the packages which we use (and which cause grief
1197 # because of fancy "goto &$AUTOLOAD" stuff).
1198 # XXX Surely there must be a nicer way to do this.
1199 if ($package eq "FileHandle" || $package eq "Config" ||
1200 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1202 return $unused_sub_packages{$package} = 0;
1204 # Now see if current package looks like an OO class this is probably too strong.
1205 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1207 if ($package->can($m))
1209 warn "$package has method $m: saving package\n";#debug
1210 return mark_package($package);
1213 return $unused_sub_packages{$package} = 0;
1218 my ($symref, $recurse, $prefix) = @_;
1223 $prefix = '' unless defined $prefix;
1224 while (($sym, $ref) = each %$symref)
1229 $sym = $prefix . $sym;
1230 if ($sym ne "main::" && &$recurse($sym))
1232 walkpackages(\%glob, $recurse, $sym);
1239 sub save_unused_subs
1242 &descend_marked_unused;
1244 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1245 warn "Saving methods\n";
1246 walksymtable(\%{"main::"}, "savecv", \&should_save);
1251 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1252 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1253 my $inc_hv = svref_2object(\%INC)->save;
1254 my $inc_av = svref_2object(\@INC)->save;
1255 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1256 "GvHV(PL_incgv) = $inc_hv;",
1257 "GvAV(PL_incgv) = $inc_av;",
1258 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1259 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));");
1262 sub descend_marked_unused {
1263 foreach my $pack (keys %unused_sub_packages)
1265 mark_package($pack);
1269 sub descend_marked_unused {
1270 foreach my $pack (keys %unused_sub_packages)
1272 mark_package($pack);
1277 warn "Starting compile\n";
1278 warn "Walking tree\n";
1279 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1280 walkoptree(main_root, "save");
1281 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1283 my $init_av = init_av->save;
1284 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1285 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1286 "PL_initav = $init_av;");
1288 warn "Writing output\n";
1289 output_boilerplate();
1291 output_all("perl_init");
1297 my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1298 binop => \$binopsect, condop => \$condopsect,
1299 cop => \$copsect, gvop => \$gvopsect,
1300 listop => \$listopsect, logop => \$logopsect,
1301 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1302 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1303 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1304 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1305 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1306 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1307 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1308 xpvio => \$xpviosect, bootstrap => \$bootstrap);
1309 my ($name, $sectref);
1310 while (($name, $sectref) = splice(@sections, 0, 2)) {
1311 $$sectref = new B::C::Section $name, \%symtable, 0;
1317 my ($arg,$val) = @_;
1318 $unused_sub_packages{$arg} = $val;
1323 my ($option, $opt, $arg);
1325 while ($option = shift @options) {
1326 if ($option =~ /^-(.)(.*)/) {
1330 unshift @options, $option;
1333 if ($opt eq "-" && $arg eq "-") {
1338 $warn_undefined_syms = 1;
1339 } elsif ($opt eq "D") {
1340 $arg ||= shift @options;
1341 foreach $arg (split(//, $arg)) {
1344 } elsif ($arg eq "c") {
1346 } elsif ($arg eq "A") {
1348 } elsif ($arg eq "C") {
1350 } elsif ($arg eq "M") {
1353 warn "ignoring unknown debug option: $arg\n";
1356 } elsif ($opt eq "o") {
1357 $arg ||= shift @options;
1358 open(STDOUT, ">$arg") or return "$arg: $!\n";
1359 } elsif ($opt eq "v") {
1361 } elsif ($opt eq "u") {
1362 $arg ||= shift @options;
1363 mark_unused($arg,undef);
1364 } elsif ($opt eq "f") {
1365 $arg ||= shift @options;
1366 if ($arg eq "cog") {
1367 $pv_copy_on_grow = 1;
1368 } elsif ($arg eq "no-cog") {
1369 $pv_copy_on_grow = 0;
1371 } elsif ($opt eq "O") {
1372 $arg = 1 if $arg eq "";
1373 $pv_copy_on_grow = 0;
1375 # Optimisations for -O1
1376 $pv_copy_on_grow = 1;
1384 foreach $objname (@options) {
1385 eval "save_object(\\$objname)";
1390 return sub { save_main() };
1400 B::C - Perl compiler's C backend
1404 perl -MO=C[,OPTIONS] foo.pl
1408 This compiler backend takes Perl source and generates C source code
1409 corresponding to the internal structures that perl uses to run
1410 your program. When the generated C source is compiled and run, it
1411 cuts out the time which perl would have taken to load and parse
1412 your program into its internal semi-compiled form. That means that
1413 compiling with this backend will not help improve the runtime
1414 execution speed of your program but may improve the start-up time.
1415 Depending on the environment in which your program runs this may be
1416 either a help or a hindrance.
1420 If there are any non-option arguments, they are taken to be
1421 names of objects to be saved (probably doesn't work properly yet).
1422 Without extra arguments, it saves the main program.
1428 Output to filename instead of STDOUT
1432 Verbose compilation (currently gives a few compilation statistics).
1436 Force end of options
1440 Force apparently unused subs from package Packname to be compiled.
1441 This allows programs to use eval "foo()" even when sub foo is never
1442 seen to be used at compile time. The down side is that any subs which
1443 really are never used also have code generated. This option is
1444 necessary, for example, if you have a signal handler foo which you
1445 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1446 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1447 options. The compiler tries to figure out which packages may possibly
1448 have subs in which need compiling but the current version doesn't do
1449 it very well. In particular, it is confused by nested packages (i.e.
1450 of the form C<A::B>) where package C<A> does not contain any subs.
1454 Debug options (concatenated or separate flags like C<perl -D>).
1458 OPs, prints each OP as it's processed
1462 COPs, prints COPs as processed (incl. file & line num)
1466 prints AV information on saving
1470 prints CV information on saving
1474 prints MAGIC information on saving
1478 Force optimisations on or off one at a time.
1482 Copy-on-grow: PVs declared and initialised statically.
1490 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
1491 B<-O1> and higher set B<-fcog>.
1495 perl -MO=C,-ofoo.c foo.pl
1496 perl cc_harness -o foo foo.c
1498 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1499 library directory. The utility called C<perlcc> may also be used to
1500 help make use of this compiler.
1502 perl -MO=C,-v,-DcA bar.pl > /dev/null
1506 Plenty. Current status: experimental.
1510 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>