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 sub AVf_REAL () { 1 }
108 # Look this up here so we can do just a number compare
109 # rather than looking up the name of every BASEOP in B::OP
110 my $OP_THREADSV = opnumber('threadsv');
113 my ($obj, $value) = @_;
114 my $sym = sprintf("s\\_%x", $$obj);
115 $symtable{$sym} = $value;
120 return $symtable{sprintf("s\\_%x", $$obj)};
127 return 0 if $sym eq "sym_0"; # special case
128 $value = $symtable{$sym};
129 if (defined($value)) {
132 warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
139 $pv = '' unless defined $pv; # Is this sane ?
142 if ($pv_copy_on_grow) {
143 my $cstring = cstring($pv);
144 if ($cstring ne "0") { # sic
145 $pvsym = sprintf("pv%d", $pv_index++);
146 $decl->add(sprintf("static char %s[] = %s;", $pvsym, $cstring));
149 $pvmax = length($pv) + 1;
151 return ($pvsym, $pvmax);
155 my ($op, $level) = @_;
156 my $type = $op->type;
157 $nullop_count++ unless $type;
158 if ($type == $OP_THREADSV) {
159 # saves looking up ppaddr but it's a bit naughty to hard code this
160 $init->add(sprintf("(void)find_threadsv(%s);",
161 cstring($threadsv_names[$op->targ])));
163 $opsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x",
164 ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
165 $type, $op_seq, $op->flags, $op->private));
166 savesym($op, sprintf("&op_list[%d]", $opsect->index));
170 my ($class, %objdata) = @_;
171 bless \%objdata, $class;
174 sub B::FAKEOP::save {
175 my ($op, $level) = @_;
176 $opsect->add(sprintf("%s, %s, %s, %u, %u, %u, 0x%x, 0x%x",
177 $op->next, $op->sibling, $op->ppaddr, $op->targ,
178 $op->type, $op_seq, $op->flags, $op->private));
179 return sprintf("&op_list[%d]", $opsect->index);
182 sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
183 sub B::FAKEOP::type { $_[0]->{type} || 0}
184 sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
185 sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
186 sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
187 sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
188 sub B::FAKEOP::private { $_[0]->{private} || 0 }
191 my ($op, $level) = @_;
192 $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x",
193 ${$op->next}, ${$op->sibling}, $op->ppaddr,
194 $op->targ, $op->type, $op_seq, $op->flags,
195 $op->private, ${$op->first}));
196 savesym($op, sprintf("(OP*)&unop_list[%d]", $unopsect->index));
200 my ($op, $level) = @_;
201 $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
202 ${$op->next}, ${$op->sibling}, $op->ppaddr,
203 $op->targ, $op->type, $op_seq, $op->flags,
204 $op->private, ${$op->first}, ${$op->last}));
205 savesym($op, sprintf("(OP*)&binop_list[%d]", $binopsect->index));
208 sub B::LISTOP::save {
209 my ($op, $level) = @_;
210 $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u",
211 ${$op->next}, ${$op->sibling}, $op->ppaddr,
212 $op->targ, $op->type, $op_seq, $op->flags,
213 $op->private, ${$op->first}, ${$op->last},
215 savesym($op, sprintf("(OP*)&listop_list[%d]", $listopsect->index));
219 my ($op, $level) = @_;
220 $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
221 ${$op->next}, ${$op->sibling}, $op->ppaddr,
222 $op->targ, $op->type, $op_seq, $op->flags,
223 $op->private, ${$op->first}, ${$op->other}));
224 savesym($op, sprintf("(OP*)&logop_list[%d]", $logopsect->index));
227 sub B::CONDOP::save {
228 my ($op, $level) = @_;
229 $condopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%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->true},
234 savesym($op, sprintf("(OP*)&condop_list[%d]", $condopsect->index));
238 my ($op, $level) = @_;
239 #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
240 # peekop($op->redoop), peekop($op->nextop),
241 # peekop($op->lastop)); # debug
242 $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",
243 ${$op->next}, ${$op->sibling}, $op->ppaddr,
244 $op->targ, $op->type, $op_seq, $op->flags,
245 $op->private, ${$op->first}, ${$op->last},
246 $op->children, ${$op->redoop}, ${$op->nextop},
248 savesym($op, sprintf("(OP*)&loop_list[%d]", $loopsect->index));
252 my ($op, $level) = @_;
253 $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
254 ${$op->next}, ${$op->sibling}, $op->ppaddr,
255 $op->targ, $op->type, $op_seq, $op->flags,
256 $op->private, cstring($op->pv)));
257 savesym($op, sprintf("(OP*)&pvop_list[%d]", $pvopsect->index));
261 my ($op, $level) = @_;
262 my $svsym = $op->sv->save;
263 $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
264 ${$op->next}, ${$op->sibling}, $op->ppaddr,
265 $op->targ, $op->type, $op_seq, $op->flags,
266 $op->private, "(SV*)$svsym"));
267 savesym($op, sprintf("(OP*)&svop_list[%d]", $svopsect->index));
271 my ($op, $level) = @_;
272 my $gvsym = $op->gv->save;
273 $gvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullgv",
274 ${$op->next}, ${$op->sibling}, $op->ppaddr,
275 $op->targ, $op->type, $op_seq, $op->flags,
277 $init->add(sprintf("gvop_list[%d].op_gv = %s;", $gvopsect->index, $gvsym));
278 savesym($op, sprintf("(OP*)&gvop_list[%d]", $gvopsect->index));
282 my ($op, $level) = @_;
283 my $gvsym = $op->filegv->save;
284 my $stashsym = $op->stash->save;
285 warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV)
287 $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u",
288 ${$op->next}, ${$op->sibling}, $op->ppaddr,
289 $op->targ, $op->type, $op_seq, $op->flags,
290 $op->private, cstring($op->label), $op->cop_seq,
291 $op->arybase, $op->line));
292 my $copix = $copsect->index;
293 $init->add(sprintf("cop_list[%d].cop_filegv = %s;", $copix, $gvsym),
294 sprintf("cop_list[%d].cop_stash = %s;", $copix, $stashsym));
295 savesym($op, "(OP*)&cop_list[$copix]");
299 my ($op, $level) = @_;
300 my $replroot = $op->pmreplroot;
301 my $replstart = $op->pmreplstart;
302 my $replrootfield = sprintf("s\\_%x", $$replroot);
303 my $replstartfield = sprintf("s\\_%x", $$replstart);
305 my $ppaddr = $op->ppaddr;
307 # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
308 # argument to a split) stores a GV in op_pmreplroot instead
309 # of a substitution syntax tree. We don't want to walk that...
310 if ($ppaddr eq "pp_pushre") {
311 $gvsym = $replroot->save;
312 # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
315 $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
318 # pmnext handling is broken in perl itself, I think. Bad op_pmnext
319 # fields aren't noticed in perl's runtime (unless you try reset) but we
320 # segfault when trying to dereference it to find op->op_pmnext->op_type
321 $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",
322 ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ,
323 $op->type, $op_seq, $op->flags, $op->private,
324 ${$op->first}, ${$op->last}, $op->children,
325 $replrootfield, $replstartfield,
326 $op->pmflags, $op->pmpermflags,));
327 my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
328 my $re = $op->precomp;
330 my $resym = sprintf("re%d", $re_index++);
331 $decl->add(sprintf("static char *$resym = %s;", cstring($re)));
332 $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
336 $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
338 savesym($op, sprintf("(OP*)&pmop_list[%d]", $pmopsect->index));
341 sub B::SPECIAL::save {
343 # special case: $$sv is not the address but an index into specialsv_list
344 # warn "SPECIAL::save specialsv $$sv\n"; # debug
345 my $sym = $specialsv_name[$$sv];
346 if (!defined($sym)) {
347 confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
352 sub B::OBJECT::save {}
356 my $sym = objsym($sv);
357 return $sym if defined $sym;
358 # warn "Saving SVt_NULL SV\n"; # debug
361 # warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
363 $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT + 1, $sv->FLAGS));
364 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
369 my $sym = objsym($sv);
370 return $sym if defined $sym;
371 $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
372 $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
373 $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
374 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
379 my $sym = objsym($sv);
380 return $sym if defined $sym;
381 $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $sv->NVX));
382 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
383 $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
384 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
389 my $sym = objsym($sv);
390 return $sym if defined $sym;
392 my $len = length($pv);
393 my ($pvsym, $pvmax) = savepv($pv);
394 my ($lvtarg, $lvtarg_sym);
395 $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
396 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
397 $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
398 $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
399 $xpvlvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
400 if (!$pv_copy_on_grow) {
401 $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);",
402 $xpvlvsect->index, cstring($pv), $len));
405 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
410 my $sym = objsym($sv);
411 return $sym if defined $sym;
413 my $len = length($pv);
414 my ($pvsym, $pvmax) = savepv($pv);
415 $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
416 $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
417 $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
418 if (!$pv_copy_on_grow) {
419 $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);",
420 $xpvivsect->index, cstring($pv), $len));
422 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
427 my $sym = objsym($sv);
428 return $sym if defined $sym;
430 $pv = '' unless defined $pv;
431 my $len = length($pv);
432 my ($pvsym, $pvmax) = savepv($pv);
433 $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
434 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
435 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
436 $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
437 if (!$pv_copy_on_grow) {
438 $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);",
439 $xpvnvsect->index, cstring($pv), $len));
441 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
446 my $sym = objsym($sv);
447 return $sym if defined $sym;
448 my $pv = $sv->PV . "\0" . $sv->TABLE;
449 my $len = length($pv);
450 $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
451 $len, $len + 258, $sv->IVX, $sv->NVX,
452 $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
453 $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
454 $xpvbmsect->index, $sv->REFCNT + 1, $sv->FLAGS));
456 $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);",
457 $xpvbmsect->index, cstring($pv), $len),
458 sprintf("xpvbm_list[%d].xpv_cur = %u;",
459 $xpvbmsect->index, $len - 257));
460 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
465 my $sym = objsym($sv);
466 return $sym if defined $sym;
468 my $len = length($pv);
469 my ($pvsym, $pvmax) = savepv($pv);
470 $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
471 $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
472 $xpvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
473 if (!$pv_copy_on_grow) {
474 $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);",
475 $xpvsect->index, cstring($pv), $len));
477 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
482 my $sym = objsym($sv);
483 return $sym if defined $sym;
485 my $len = length($pv);
486 my ($pvsym, $pvmax) = savepv($pv);
487 $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
488 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
489 $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
490 $xpvmgsect->index, $sv->REFCNT + 1, $sv->FLAGS));
491 if (!$pv_copy_on_grow) {
492 $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);",
493 $xpvmgsect->index, cstring($pv), $len));
495 $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
500 sub B::PVMG::save_magic {
502 #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
503 my $stash = $sv->SvSTASH;
505 warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
507 # XXX Hope stash is already going to be saved.
508 $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
510 my @mgchain = $sv->MAGIC;
511 my ($mg, $type, $obj, $ptr);
512 foreach $mg (@mgchain) {
516 my $len = defined($ptr) ? length($ptr) : 0;
518 warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
519 class($sv), $$sv, class($obj), $$obj,
520 cchar($type), cstring($ptr));
522 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
523 $$sv, $$obj, cchar($type),cstring($ptr),$len));
529 my $sym = objsym($sv);
530 return $sym if defined $sym;
531 my $rv = $sv->RV->save;
532 $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/;
534 $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
535 $xrvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
536 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
540 my ($cvstashname, $cvname) = @_;
541 warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
542 # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
543 # use should be handled by the class itself.
545 my $isa = \@{"$cvstashname\::ISA"};
546 if (grep($_ eq "AutoLoader", @$isa)) {
547 warn "Forcing immediate load of sub derived from AutoLoader\n";
548 # Tweaked version of AutoLoader::AUTOLOAD
549 my $dir = $cvstashname;
551 eval { require "auto/$dir/$cvname.al" };
553 warn qq(failed require "auto/$dir/$cvname.al": $@\n);
563 my $sym = objsym($cv);
565 # warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
568 # Reserve a place in svsect and xpvcvsect and record indices
569 my $sv_ix = $svsect->index + 1;
570 $svsect->add("svix$sv_ix");
571 my $xpvcv_ix = $xpvcvsect->index + 1;
572 $xpvcvsect->add("xpvcvix$xpvcv_ix");
573 # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
574 $sym = savesym($cv, "&sv_list[$sv_ix]");
575 warn sprintf("saving CV 0x%x as $sym\n", $$cv) if $debug_cv;
577 my $cvstashname = $gv->STASH->NAME;
578 my $cvname = $gv->NAME;
579 my $root = $cv->ROOT;
580 my $cvxsub = $cv->XSUB;
581 if (!$$root && !$cvxsub) {
582 if (try_autoload($cvstashname, $cvname)) {
583 # Recalculate root and xsub
586 if ($$root || $cvxsub) {
587 warn "Successful forced autoload\n";
592 my $padlist = $cv->PADLIST;
595 my $xsubany = "Nullany";
597 warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
598 $$cv, $$root) if $debug_cv;
601 my $stashname = $gv->STASH->NAME;
602 my $gvname = $gv->NAME;
603 if ($gvname ne "__ANON__") {
604 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
605 $ppname .= ($stashname eq "main") ?
606 $gvname : "$stashname\::$gvname";
607 $ppname =~ s/::/__/g;
608 if ($gvname eq "INIT"){
609 $ppname .= "_$initsub_index";
615 $ppname = "pp_anonsub_$anonsub_index";
618 $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
619 warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
620 $$cv, $ppname, $$root) if $debug_cv;
622 warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
623 $$padlist, $$cv) if $debug_cv;
625 warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
626 $$padlist, $$cv) if $debug_cv;
630 $xsubany = sprintf("ANYINIT((void*)0x%x)", $cv->XSUBANY);
631 # Try to find out canonical name of XSUB function from EGV.
632 # XXX Doesn't work for XSUBs with PREFIX set (or anyone who
633 # calls newXS() manually with weird arguments).
635 my $stashname = $egv->STASH->NAME;
636 $stashname =~ s/::/__/g;
637 $xsub = sprintf("XS_%s_%s", $stashname, $egv->NAME);
638 $decl->add("void $xsub _((CV*));");
641 warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
642 $cvstashname, $cvname); # debug
644 $pv = '' unless defined $pv; # Avoid use of undef warnings
645 $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",
646 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
647 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
648 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
650 if (${$cv->OUTSIDE} == ${main_cv()}){
651 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
656 $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
657 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
658 $$gv, $$cv) if $debug_cv;
660 my $filegv = $cv->FILEGV;
663 $init->add(sprintf("CvFILEGV(s\\_%x) = s\\_%x;", $$cv, $$filegv));
664 warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n",
665 $$filegv, $$cv) if $debug_cv;
667 my $stash = $cv->STASH;
670 $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
671 warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
672 $$stash, $$cv) if $debug_cv;
674 $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
675 $sv_ix, $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS));
681 my $sym = objsym($gv);
683 #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
686 my $ix = $gv_index++;
687 $sym = savesym($gv, "gv_list[$ix]");
688 #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
690 my $gvname = $gv->NAME;
691 my $name = cstring($gv->STASH->NAME . "::" . $gvname);
692 #warn "GV name is $name\n"; # debug
696 #warn(sprintf("EGV name is %s, saving it now\n",
697 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
698 $egvsym = $egv->save;
700 $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
701 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
702 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS),
703 sprintf("GvLINE($sym) = %u;", $gv->LINE));
704 # Shouldn't need to do save_magic since gv_fetchpv handles that
706 my $refcnt = $gv->REFCNT + 1;
707 $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
708 my $gvrefcnt = $gv->GvREFCNT;
710 $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
712 if (defined($egvsym)) {
713 # Shared glob *foo = *bar
714 $init->add("gp_free($sym);",
715 "GvGP($sym) = GvGP($egvsym);");
716 } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
717 # Don't save subfields of special GVs (*_, *1, *# and so on)
718 # warn "GV::save saving subfields\n"; # debug
721 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
722 # warn "GV::save \$$name\n"; # debug
727 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
728 # warn "GV::save \@$name\n"; # debug
733 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
734 # warn "GV::save \%$name\n"; # debug
739 $init->add(sprintf("GvCV($sym) = (CV*)s\\_%x;", $$gvcv));
740 # warn "GV::save &$name\n"; # debug
743 my $gvfilegv = $gv->FILEGV;
745 $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv));
746 # warn "GV::save GvFILEGV(*$name)\n"; # debug
749 my $gvform = $gv->FORM;
751 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
752 # warn "GV::save GvFORM(*$name)\n"; # debug
757 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
758 # warn "GV::save GvIO(*$name)\n"; # debug
766 my $sym = objsym($av);
767 return $sym if defined $sym;
768 my $avflags = $av->AvFLAGS;
769 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
771 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
772 $xpvavsect->index, $av->REFCNT + 1, $av->FLAGS));
773 my $sv_list_index = $svsect->index;
774 my $fill = $av->FILL;
776 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
778 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
779 #if ($fill > -1 && ($avflags & AVf_REAL)) {
781 my @array = $av->ARRAY;
785 foreach $el (@array) {
786 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
787 $$av, $i++, class($el), $$el);
790 my @names = map($_->save, @array);
791 # XXX Better ways to write loop?
792 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
793 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
796 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
797 "\tav_extend(av, $fill);",
798 "\tsvp = AvARRAY(av);",
799 map("\t*svp++ = (SV*)$_;", @names),
800 "\tAvFILLp(av) = $fill;",
804 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
807 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
812 my $sym = objsym($hv);
813 return $sym if defined $sym;
814 my $name = $hv->NAME;
818 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
819 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
820 # a trashed op but we look at the trashed op_type and segfault.
821 #my $adpmroot = ${$hv->PMROOT};
823 $decl->add("static HV *hv$hv_index;");
824 # XXX Beware of weird package names containing double-quotes, \n, ...?
825 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
827 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
830 $sym = savesym($hv, "hv$hv_index");
834 # It's just an ordinary HV
835 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
836 $hv->MAX, $hv->RITER));
837 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
838 $xpvhvsect->index, $hv->REFCNT + 1, $hv->FLAGS));
839 my $sv_list_index = $svsect->index;
840 my @contents = $hv->ARRAY;
843 for ($i = 1; $i < @contents; $i += 2) {
844 $contents[$i] = $contents[$i]->save;
846 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
848 my ($key, $value) = splice(@contents, 0, 2);
849 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
850 cstring($key),length($key),$value, hash($key)));
851 # $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
852 # cstring($key),length($key),$value, 0));
856 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
861 my $sym = objsym($io);
862 return $sym if defined $sym;
864 $pv = '' unless defined $pv;
865 my $len = length($pv);
866 $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",
867 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
868 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
869 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
870 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
871 cchar($io->IoTYPE), $io->IoFLAGS));
872 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
873 $xpviosect->index, $io->REFCNT + 1, $io->FLAGS));
874 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
876 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
877 $fsym = $io->$field();
879 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
889 # This is where we catch an honest-to-goodness Nullsv (which gets
890 # blessed into B::SV explicitly) and any stray erroneous SVs.
891 return 0 unless $$sv;
892 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
897 my $init_name = shift;
899 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
900 $listopsect, $pmopsect, $svopsect, $gvopsect, $pvopsect,
901 $loopsect, $copsect, $svsect, $xpvsect,
902 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
903 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
904 $bootstrap->output(\*STDOUT, "/* bootstrap %s */\n");
905 $symsect->output(\*STDOUT, "#define %s\n");
907 output_declarations();
908 foreach $section (@sections) {
909 my $lines = $section->index + 1;
911 my $name = $section->name;
912 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
913 print "Static $typename ${name}_list[$lines];\n";
916 $decl->output(\*STDOUT, "%s\n");
918 foreach $section (@sections) {
919 my $lines = $section->index + 1;
921 my $name = $section->name;
922 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
923 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
924 $section->output(\*STDOUT, "\t{ %s },\n");
930 static int $init_name()
934 $init->output(\*STDOUT, "\t%s\n");
935 print "\treturn 0;\n}\n";
937 warn compile_stats();
938 warn "NULLOP count: $nullop_count\n";
942 sub output_declarations {
944 #ifdef BROKEN_STATIC_REDECL
945 #define Static extern
947 #define Static static
948 #endif /* BROKEN_STATIC_REDECL */
950 #ifdef BROKEN_UNION_INIT
952 * Cribbed from cv.h with ANY (a union) replaced by void*.
953 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
956 char * xpv_pv; /* pointer to malloced string */
957 STRLEN xpv_cur; /* length of xp_pv as a C string */
958 STRLEN xpv_len; /* allocated size */
959 IV xof_off; /* integer value */
960 double xnv_nv; /* numeric value, if any */
961 MAGIC* xmg_magic; /* magic for scalar array */
962 HV* xmg_stash; /* class package */
967 void (*xcv_xsub) _((CV*));
971 long xcv_depth; /* >= 2 indicates recursive call */
975 perl_mutex *xcv_mutexp;
976 struct perl_thread *xcv_owner; /* current owner thread */
977 #endif /* USE_THREADS */
982 #define XPVCV_or_similar XPVCV
983 #define ANYINIT(i) {i}
984 #endif /* BROKEN_UNION_INIT */
985 #define Nullany ANYINIT(0)
991 print "static GV *gv_list[$gv_index];\n" if $gv_index;
996 sub output_boilerplate {
1001 #include "patchlevel.h"
1004 /* Workaround for mapstart: the only op which needs a different ppaddr */
1006 #define pp_mapstart pp_grepstart
1008 static void xs_init _((void));
1009 static PerlInterpreter *my_perl;
1016 #ifndef CAN_PROTOTYPE
1017 main(argc, argv, env)
1021 #else /* def(CAN_PROTOTYPE) */
1022 main(int argc, char **argv, char **env)
1023 #endif /* def(CAN_PROTOTYPE) */
1029 PERL_SYS_INIT(&argc,&argv);
1031 perl_init_i18nl10n(1);
1033 if (!PL_do_undump) {
1034 my_perl = perl_alloc();
1037 perl_construct( my_perl );
1042 PL_cshlen = strlen(PL_cshname);
1045 #ifdef ALLOW_PERL_OPTIONS
1046 #define EXTRA_OPTIONS 2
1048 #define EXTRA_OPTIONS 3
1049 #endif /* ALLOW_PERL_OPTIONS */
1050 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1051 fakeargv[0] = argv[0];
1054 #ifndef ALLOW_PERL_OPTIONS
1056 #endif /* ALLOW_PERL_OPTIONS */
1057 for (i = 1; i < argc; i++)
1058 fakeargv[i + EXTRA_OPTIONS] = argv[i];
1059 fakeargv[argc + EXTRA_OPTIONS] = 0;
1061 exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1066 sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1067 PL_main_cv = PL_compcv;
1070 exitstatus = perl_init();
1074 exitstatus = perl_run( my_perl );
1076 perl_destruct( my_perl );
1077 perl_free( my_perl );
1092 warn "----Symbol table:\n";
1093 while (($sym, $val) = each %symtable) {
1094 warn "$sym => $val\n";
1096 warn "---End of symbol table\n";
1102 svref_2object($sv)->save;
1106 sub Dummy_BootStrap { }
1111 my $package=$gv->STASH->NAME;
1112 my $name = $gv->NAME;
1114 return unless ($$cv || $name eq 'ISA');
1115 # We may be looking at this package just because it is a branch in the
1116 # symbol table which is on the path to a package which we need to save
1117 # e.g. this is 'Getopt' and wee need to save 'Getopt::Long'
1119 if ($$cv && $name eq "bootstrap" && $cv->XSUB)
1121 my $file = $cv->FILEGV->SV->PV;
1122 $bootstrap->add($file);
1124 unless ($unused_sub_packages{$package})
1126 warn sprintf("omitting cv $name in %s\n", $package) if $$cv; # if $debug_cv;
1131 if ($name eq "bootstrap" && $cv->XSUB)
1133 my $name = $gv->STASH->NAME.'::'.$name;
1135 *{$name} = \&Dummy_BootStrap;
1138 warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
1139 $package, $name, $$cv, $$gv) if ($debug_cv);
1142 elsif ($name eq 'ISA')
1150 my $package = shift;
1151 unless ($unused_sub_packages{$package})
1154 $unused_sub_packages{$package} = 1;
1155 if (defined(@{$package.'::ISA'}))
1157 foreach my $isa (@{$package.'::ISA'})
1159 if ($isa eq 'DynaLoader')
1161 unless (defined(&{$package.'::bootstrap'}))
1163 warn "Forcing bootstrap of $package\n";
1164 eval { $package->bootstrap };
1169 unless ($unused_sub_packages{$isa})
1171 warn "$isa saved (it is in $package\'s \@ISA)\n";
1183 no strict qw(vars refs);
1184 my $package = shift;
1185 $package =~ s/::$//;
1186 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1187 # warn "Considering $package\n";#debug
1188 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1190 # If this package is a prefix to something we are saving, traverse it
1191 # but do not mark it for saving if it is not already
1192 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1194 return 1 if ($u =~ /^$package\:\:/);
1196 if (exists $unused_sub_packages{$package})
1198 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1199 return $unused_sub_packages{$package}
1201 # Omit the packages which we use (and which cause grief
1202 # because of fancy "goto &$AUTOLOAD" stuff).
1203 # XXX Surely there must be a nicer way to do this.
1204 if ($package eq "FileHandle" || $package eq "Config" ||
1205 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1207 return $unused_sub_packages{$package} = 0;
1209 # Now see if current package looks like an OO class this is probably too strong.
1210 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1212 if ($package->can($m))
1214 warn "$package has method $m: saving package\n";#debug
1215 return mark_package($package);
1218 return $unused_sub_packages{$package} = 0;
1223 my ($symref, $recurse, $prefix) = @_;
1228 $prefix = '' unless defined $prefix;
1229 while (($sym, $ref) = each %$symref)
1234 $sym = $prefix . $sym;
1235 if ($sym ne "main::" && &$recurse($sym))
1237 walkpackages(\%glob, $recurse, $sym);
1244 sub save_unused_subs
1247 &descend_marked_unused;
1249 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1250 warn "Saving methods\n";
1251 walksymtable(\%{"main::"}, "savecv", \&should_save);
1256 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1257 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1258 my $inc_hv = svref_2object(\%INC)->save;
1259 my $inc_av = svref_2object(\@INC)->save;
1260 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1261 "GvHV(PL_incgv) = $inc_hv;",
1262 "GvAV(PL_incgv) = $inc_av;",
1263 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1264 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));");
1267 sub descend_marked_unused {
1268 foreach my $pack (keys %unused_sub_packages)
1270 mark_package($pack);
1275 warn "Starting compile\n";
1276 warn "Walking tree\n";
1277 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1278 walkoptree(main_root, "save");
1279 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1281 my $init_av = init_av->save;
1282 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1283 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1284 "PL_initav = $init_av;");
1286 warn "Writing output\n";
1287 output_boilerplate();
1289 output_all("perl_init");
1295 my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1296 binop => \$binopsect, condop => \$condopsect,
1297 cop => \$copsect, gvop => \$gvopsect,
1298 listop => \$listopsect, logop => \$logopsect,
1299 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1300 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1301 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1302 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1303 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1304 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1305 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1306 xpvio => \$xpviosect, bootstrap => \$bootstrap);
1307 my ($name, $sectref);
1308 while (($name, $sectref) = splice(@sections, 0, 2)) {
1309 $$sectref = new B::C::Section $name, \%symtable, 0;
1315 my ($arg,$val) = @_;
1316 $unused_sub_packages{$arg} = $val;
1321 my ($option, $opt, $arg);
1323 while ($option = shift @options) {
1324 if ($option =~ /^-(.)(.*)/) {
1328 unshift @options, $option;
1331 if ($opt eq "-" && $arg eq "-") {
1336 $warn_undefined_syms = 1;
1337 } elsif ($opt eq "D") {
1338 $arg ||= shift @options;
1339 foreach $arg (split(//, $arg)) {
1342 } elsif ($arg eq "c") {
1344 } elsif ($arg eq "A") {
1346 } elsif ($arg eq "C") {
1348 } elsif ($arg eq "M") {
1351 warn "ignoring unknown debug option: $arg\n";
1354 } elsif ($opt eq "o") {
1355 $arg ||= shift @options;
1356 open(STDOUT, ">$arg") or return "$arg: $!\n";
1357 } elsif ($opt eq "v") {
1359 } elsif ($opt eq "u") {
1360 $arg ||= shift @options;
1361 mark_unused($arg,undef);
1362 } elsif ($opt eq "f") {
1363 $arg ||= shift @options;
1364 if ($arg eq "cog") {
1365 $pv_copy_on_grow = 1;
1366 } elsif ($arg eq "no-cog") {
1367 $pv_copy_on_grow = 0;
1369 } elsif ($opt eq "O") {
1370 $arg = 1 if $arg eq "";
1371 $pv_copy_on_grow = 0;
1373 # Optimisations for -O1
1374 $pv_copy_on_grow = 1;
1382 foreach $objname (@options) {
1383 eval "save_object(\\$objname)";
1388 return sub { save_main() };
1398 B::C - Perl compiler's C backend
1402 perl -MO=C[,OPTIONS] foo.pl
1406 This compiler backend takes Perl source and generates C source code
1407 corresponding to the internal structures that perl uses to run
1408 your program. When the generated C source is compiled and run, it
1409 cuts out the time which perl would have taken to load and parse
1410 your program into its internal semi-compiled form. That means that
1411 compiling with this backend will not help improve the runtime
1412 execution speed of your program but may improve the start-up time.
1413 Depending on the environment in which your program runs this may be
1414 either a help or a hindrance.
1418 If there are any non-option arguments, they are taken to be
1419 names of objects to be saved (probably doesn't work properly yet).
1420 Without extra arguments, it saves the main program.
1426 Output to filename instead of STDOUT
1430 Verbose compilation (currently gives a few compilation statistics).
1434 Force end of options
1438 Force apparently unused subs from package Packname to be compiled.
1439 This allows programs to use eval "foo()" even when sub foo is never
1440 seen to be used at compile time. The down side is that any subs which
1441 really are never used also have code generated. This option is
1442 necessary, for example, if you have a signal handler foo which you
1443 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1444 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1445 options. The compiler tries to figure out which packages may possibly
1446 have subs in which need compiling but the current version doesn't do
1447 it very well. In particular, it is confused by nested packages (i.e.
1448 of the form C<A::B>) where package C<A> does not contain any subs.
1452 Debug options (concatenated or separate flags like C<perl -D>).
1456 OPs, prints each OP as it's processed
1460 COPs, prints COPs as processed (incl. file & line num)
1464 prints AV information on saving
1468 prints CV information on saving
1472 prints MAGIC information on saving
1476 Force optimisations on or off one at a time.
1480 Copy-on-grow: PVs declared and initialised statically.
1488 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
1489 B<-O1> and higher set B<-fcog>.
1493 perl -MO=C,-ofoo.c foo.pl
1494 perl cc_harness -o foo foo.c
1496 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1497 library directory. The utility called C<perlcc> may also be used to
1498 help make use of this compiler.
1500 perl -MO=C,-v,-DcA bar.pl > /dev/null
1504 Plenty. Current status: experimental.
1508 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>