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));
680 my ($gv,$skip_cv) = @_;
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
738 if ($$gvcv && !$skip_cv) {
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;
1119 # We may be looking at this package just because it is a branch in the
1120 # symbol table which is on the path to a package which we need to save
1121 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1123 return unless ($unused_sub_packages{$package});
1126 if ($name eq "bootstrap" && $cv->XSUB)
1128 my $file = $cv->FILEGV->SV->PV;
1129 $bootstrap->add($file);
1130 my $name = $gv->STASH->NAME.'::'.$name;
1132 *{$name} = \&Dummy_BootStrap;
1135 warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
1136 $package, $name, $$cv, $$gv) if ($debug_cv);
1140 return unless ($$av || $$sv || $$hv)
1142 $gv->save($skip_cv);
1147 my $package = shift;
1148 unless ($unused_sub_packages{$package})
1151 $unused_sub_packages{$package} = 1;
1152 if (defined(@{$package.'::ISA'}))
1154 foreach my $isa (@{$package.'::ISA'})
1156 if ($isa eq 'DynaLoader')
1158 unless (defined(&{$package.'::bootstrap'}))
1160 warn "Forcing bootstrap of $package\n";
1161 eval { $package->bootstrap };
1166 unless ($unused_sub_packages{$isa})
1168 warn "$isa saved (it is in $package\'s \@ISA)\n";
1180 no strict qw(vars refs);
1181 my $package = shift;
1182 $package =~ s/::$//;
1183 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1184 # warn "Considering $package\n";#debug
1185 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1187 # If this package is a prefix to something we are saving, traverse it
1188 # but do not mark it for saving if it is not already
1189 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1191 return 1 if ($u =~ /^$package\:\:/);
1193 if (exists $unused_sub_packages{$package})
1195 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1196 return $unused_sub_packages{$package}
1198 # Omit the packages which we use (and which cause grief
1199 # because of fancy "goto &$AUTOLOAD" stuff).
1200 # XXX Surely there must be a nicer way to do this.
1201 if ($package eq "FileHandle" || $package eq "Config" ||
1202 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1204 return $unused_sub_packages{$package} = 0;
1206 # Now see if current package looks like an OO class this is probably too strong.
1207 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1209 if ($package->can($m))
1211 warn "$package has method $m: saving package\n";#debug
1212 return mark_package($package);
1215 return $unused_sub_packages{$package} = 0;
1220 my ($symref, $recurse, $prefix) = @_;
1225 $prefix = '' unless defined $prefix;
1226 while (($sym, $ref) = each %$symref)
1231 $sym = $prefix . $sym;
1232 if ($sym ne "main::" && &$recurse($sym))
1234 walkpackages(\%glob, $recurse, $sym);
1241 sub save_unused_subs
1244 &descend_marked_unused;
1246 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1247 warn "Saving methods\n";
1248 walksymtable(\%{"main::"}, "savecv", \&should_save);
1253 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1254 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1255 my $inc_hv = svref_2object(\%INC)->save;
1256 my $inc_av = svref_2object(\@INC)->save;
1257 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1258 "GvHV(PL_incgv) = $inc_hv;",
1259 "GvAV(PL_incgv) = $inc_av;",
1260 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1261 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));");
1264 sub descend_marked_unused {
1265 foreach my $pack (keys %unused_sub_packages)
1267 mark_package($pack);
1271 sub descend_marked_unused {
1272 foreach my $pack (keys %unused_sub_packages)
1274 mark_package($pack);
1279 warn "Starting compile\n";
1280 warn "Walking tree\n";
1281 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1282 walkoptree(main_root, "save");
1283 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1285 my $init_av = init_av->save;
1286 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1287 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1288 "PL_initav = $init_av;");
1290 warn "Writing output\n";
1291 output_boilerplate();
1293 output_all("perl_init");
1299 my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1300 binop => \$binopsect, condop => \$condopsect,
1301 cop => \$copsect, gvop => \$gvopsect,
1302 listop => \$listopsect, logop => \$logopsect,
1303 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1304 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1305 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1306 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1307 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1308 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1309 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1310 xpvio => \$xpviosect, bootstrap => \$bootstrap);
1311 my ($name, $sectref);
1312 while (($name, $sectref) = splice(@sections, 0, 2)) {
1313 $$sectref = new B::C::Section $name, \%symtable, 0;
1319 my ($arg,$val) = @_;
1320 $unused_sub_packages{$arg} = $val;
1325 my ($option, $opt, $arg);
1327 while ($option = shift @options) {
1328 if ($option =~ /^-(.)(.*)/) {
1332 unshift @options, $option;
1335 if ($opt eq "-" && $arg eq "-") {
1340 $warn_undefined_syms = 1;
1341 } elsif ($opt eq "D") {
1342 $arg ||= shift @options;
1343 foreach $arg (split(//, $arg)) {
1346 } elsif ($arg eq "c") {
1348 } elsif ($arg eq "A") {
1350 } elsif ($arg eq "C") {
1352 } elsif ($arg eq "M") {
1355 warn "ignoring unknown debug option: $arg\n";
1358 } elsif ($opt eq "o") {
1359 $arg ||= shift @options;
1360 open(STDOUT, ">$arg") or return "$arg: $!\n";
1361 } elsif ($opt eq "v") {
1363 } elsif ($opt eq "u") {
1364 $arg ||= shift @options;
1365 mark_unused($arg,undef);
1366 } elsif ($opt eq "f") {
1367 $arg ||= shift @options;
1368 if ($arg eq "cog") {
1369 $pv_copy_on_grow = 1;
1370 } elsif ($arg eq "no-cog") {
1371 $pv_copy_on_grow = 0;
1373 } elsif ($opt eq "O") {
1374 $arg = 1 if $arg eq "";
1375 $pv_copy_on_grow = 0;
1377 # Optimisations for -O1
1378 $pv_copy_on_grow = 1;
1386 foreach $objname (@options) {
1387 eval "save_object(\\$objname)";
1392 return sub { save_main() };
1402 B::C - Perl compiler's C backend
1406 perl -MO=C[,OPTIONS] foo.pl
1410 This compiler backend takes Perl source and generates C source code
1411 corresponding to the internal structures that perl uses to run
1412 your program. When the generated C source is compiled and run, it
1413 cuts out the time which perl would have taken to load and parse
1414 your program into its internal semi-compiled form. That means that
1415 compiling with this backend will not help improve the runtime
1416 execution speed of your program but may improve the start-up time.
1417 Depending on the environment in which your program runs this may be
1418 either a help or a hindrance.
1422 If there are any non-option arguments, they are taken to be
1423 names of objects to be saved (probably doesn't work properly yet).
1424 Without extra arguments, it saves the main program.
1430 Output to filename instead of STDOUT
1434 Verbose compilation (currently gives a few compilation statistics).
1438 Force end of options
1442 Force apparently unused subs from package Packname to be compiled.
1443 This allows programs to use eval "foo()" even when sub foo is never
1444 seen to be used at compile time. The down side is that any subs which
1445 really are never used also have code generated. This option is
1446 necessary, for example, if you have a signal handler foo which you
1447 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1448 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1449 options. The compiler tries to figure out which packages may possibly
1450 have subs in which need compiling but the current version doesn't do
1451 it very well. In particular, it is confused by nested packages (i.e.
1452 of the form C<A::B>) where package C<A> does not contain any subs.
1456 Debug options (concatenated or separate flags like C<perl -D>).
1460 OPs, prints each OP as it's processed
1464 COPs, prints COPs as processed (incl. file & line num)
1468 prints AV information on saving
1472 prints CV information on saving
1476 prints MAGIC information on saving
1480 Force optimisations on or off one at a time.
1484 Copy-on-grow: PVs declared and initialised statically.
1492 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
1493 B<-O1> and higher set B<-fcog>.
1497 perl -MO=C,-ofoo.c foo.pl
1498 perl cc_harness -o foo foo.c
1500 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1501 library directory. The utility called C<perlcc> may also be used to
1502 help make use of this compiler.
1504 perl -MO=C,-v,-DcA bar.pl > /dev/null
1508 Plenty. Current status: experimental.
1512 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>