3 # Copyright (c) 1996, 1997, 1998 Malcolm Beattie
5 # You may distribute under the terms of either the GNU General Public
6 # License or the Artistic License, as specified in the README file.
15 my $o = $class->SUPER::new(@_);
23 push(@{$section->[-1]},@_);
29 return scalar(@{$section->[-1]})-1;
34 my ($section, $fh, $format) = @_;
35 my $sym = $section->symtable || {};
36 my $default = $section->default;
37 foreach (@{$section->[-1]})
39 s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
40 printf $fh $format, $_;
47 @EXPORT_OK = qw(output_all output_boilerplate output_main mark_unused
48 init_sections set_callback save_unused_subs objsym save_context);
50 use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop
51 class cstring cchar svref_2object compile_stats comppadlist hash
52 threadsv_names main_cv init_av opnumber
54 use B::Asmdata qw(@specialsv_name);
64 my $anonsub_index = 0;
65 my $initsub_index = 0;
68 my $warn_undefined_syms;
70 my %unused_sub_packages;
72 my $pv_copy_on_grow = 0;
73 my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
77 @threadsv_names = threadsv_names();
81 my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect,
82 $gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
83 $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
84 $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
85 $xrvsect, $xpvbmsect, $xpviosect, $bootstrap);
87 sub walk_and_save_optree;
88 my $saveoptree_callback = \&walk_and_save_optree;
89 sub set_callback { $saveoptree_callback = shift }
90 sub saveoptree { &$saveoptree_callback(@_) }
92 sub walk_and_save_optree {
93 my ($name, $root, $start) = @_;
94 walkoptree($root, "save");
95 return objsym($start);
98 # Current workaround/fix for op_free() trying to free statically
99 # defined OPs is to set op_seq = -1 and check for that in op_free().
100 # Instead of hardwiring -1 in place of $op->seq, we use $op_seq
101 # so that it can be changed back easily if necessary. In fact, to
102 # stop compilers from moaning about a U16 being initialised with an
103 # uncast -1 (the printf format is %d so we can't tweak it), we have
104 # to "know" that op_seq is a U16 and use 65535. Ugh.
107 # Look this up here so we can do just a number compare
108 # rather than looking up the name of every BASEOP in B::OP
109 my $OP_THREADSV = opnumber('threadsv');
112 my ($obj, $value) = @_;
113 my $sym = sprintf("s\\_%x", $$obj);
114 $symtable{$sym} = $value;
119 return $symtable{sprintf("s\\_%x", $$obj)};
126 return 0 if $sym eq "sym_0"; # special case
127 $value = $symtable{$sym};
128 if (defined($value)) {
131 warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
138 $pv = '' unless defined $pv; # Is this sane ?
141 if ($pv_copy_on_grow) {
142 my $cstring = cstring($pv);
143 if ($cstring ne "0") { # sic
144 $pvsym = sprintf("pv%d", $pv_index++);
145 $decl->add(sprintf("static char %s[] = %s;", $pvsym, $cstring));
148 $pvmax = length($pv) + 1;
150 return ($pvsym, $pvmax);
154 my ($op, $level) = @_;
155 my $sym = objsym($op);
156 return $sym if defined $sym;
157 my $type = $op->type;
158 $nullop_count++ unless $type;
159 if ($type == $OP_THREADSV) {
160 # saves looking up ppaddr but it's a bit naughty to hard code this
161 $init->add(sprintf("(void)find_threadsv(%s);",
162 cstring($threadsv_names[$op->targ])));
164 $opsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x",
165 ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
166 $type, $op_seq, $op->flags, $op->private));
167 savesym($op, sprintf("&op_list[%d]", $opsect->index));
171 my ($class, %objdata) = @_;
172 bless \%objdata, $class;
175 sub B::FAKEOP::save {
176 my ($op, $level) = @_;
177 $opsect->add(sprintf("%s, %s, %s, %u, %u, %u, 0x%x, 0x%x",
178 $op->next, $op->sibling, $op->ppaddr, $op->targ,
179 $op->type, $op_seq, $op->flags, $op->private));
180 return sprintf("&op_list[%d]", $opsect->index);
183 sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
184 sub B::FAKEOP::type { $_[0]->{type} || 0}
185 sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
186 sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
187 sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
188 sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
189 sub B::FAKEOP::private { $_[0]->{private} || 0 }
192 my ($op, $level) = @_;
193 my $sym = objsym($op);
194 return $sym if defined $sym;
195 $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x",
196 ${$op->next}, ${$op->sibling}, $op->ppaddr,
197 $op->targ, $op->type, $op_seq, $op->flags,
198 $op->private, ${$op->first}));
199 savesym($op, sprintf("(OP*)&unop_list[%d]", $unopsect->index));
203 my ($op, $level) = @_;
204 my $sym = objsym($op);
205 return $sym if defined $sym;
206 $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
207 ${$op->next}, ${$op->sibling}, $op->ppaddr,
208 $op->targ, $op->type, $op_seq, $op->flags,
209 $op->private, ${$op->first}, ${$op->last}));
210 savesym($op, sprintf("(OP*)&binop_list[%d]", $binopsect->index));
213 sub B::LISTOP::save {
214 my ($op, $level) = @_;
215 my $sym = objsym($op);
216 return $sym if defined $sym;
217 $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u",
218 ${$op->next}, ${$op->sibling}, $op->ppaddr,
219 $op->targ, $op->type, $op_seq, $op->flags,
220 $op->private, ${$op->first}, ${$op->last},
222 savesym($op, sprintf("(OP*)&listop_list[%d]", $listopsect->index));
226 my ($op, $level) = @_;
227 my $sym = objsym($op);
228 return $sym if defined $sym;
229 $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
230 ${$op->next}, ${$op->sibling}, $op->ppaddr,
231 $op->targ, $op->type, $op_seq, $op->flags,
232 $op->private, ${$op->first}, ${$op->other}));
233 savesym($op, sprintf("(OP*)&logop_list[%d]", $logopsect->index));
236 sub B::CONDOP::save {
237 my ($op, $level) = @_;
238 my $sym = objsym($op);
239 return $sym if defined $sym;
240 $condopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x",
241 ${$op->next}, ${$op->sibling}, $op->ppaddr,
242 $op->targ, $op->type, $op_seq, $op->flags,
243 $op->private, ${$op->first}, ${$op->true},
245 savesym($op, sprintf("(OP*)&condop_list[%d]", $condopsect->index));
249 my ($op, $level) = @_;
250 my $sym = objsym($op);
251 return $sym if defined $sym;
252 #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
253 # peekop($op->redoop), peekop($op->nextop),
254 # peekop($op->lastop)); # debug
255 $loopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, s\\_%x, s\\_%x, s\\_%x",
256 ${$op->next}, ${$op->sibling}, $op->ppaddr,
257 $op->targ, $op->type, $op_seq, $op->flags,
258 $op->private, ${$op->first}, ${$op->last},
259 $op->children, ${$op->redoop}, ${$op->nextop},
261 savesym($op, sprintf("(OP*)&loop_list[%d]", $loopsect->index));
265 my ($op, $level) = @_;
266 my $sym = objsym($op);
267 return $sym if defined $sym;
268 $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
269 ${$op->next}, ${$op->sibling}, $op->ppaddr,
270 $op->targ, $op->type, $op_seq, $op->flags,
271 $op->private, cstring($op->pv)));
272 savesym($op, sprintf("(OP*)&pvop_list[%d]", $pvopsect->index));
276 my ($op, $level) = @_;
277 my $sym = objsym($op);
278 return $sym if defined $sym;
279 my $svsym = $op->sv->save;
280 $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
281 ${$op->next}, ${$op->sibling}, $op->ppaddr,
282 $op->targ, $op->type, $op_seq, $op->flags,
283 $op->private, "(SV*)$svsym"));
284 savesym($op, sprintf("(OP*)&svop_list[%d]", $svopsect->index));
288 my ($op, $level) = @_;
289 my $sym = objsym($op);
290 return $sym if defined $sym;
291 my $gvsym = $op->gv->save;
292 $gvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullgv",
293 ${$op->next}, ${$op->sibling}, $op->ppaddr,
294 $op->targ, $op->type, $op_seq, $op->flags,
296 $init->add(sprintf("gvop_list[%d].op_gv = %s;", $gvopsect->index, $gvsym));
297 savesym($op, sprintf("(OP*)&gvop_list[%d]", $gvopsect->index));
301 my ($op, $level) = @_;
302 my $sym = objsym($op);
303 return $sym if defined $sym;
304 my $gvsym = $op->filegv->save;
305 my $stashsym = $op->stash->save;
306 warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV)
308 $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u",
309 ${$op->next}, ${$op->sibling}, $op->ppaddr,
310 $op->targ, $op->type, $op_seq, $op->flags,
311 $op->private, cstring($op->label), $op->cop_seq,
312 $op->arybase, $op->line));
313 my $copix = $copsect->index;
314 $init->add(sprintf("cop_list[%d].cop_filegv = %s;", $copix, $gvsym),
315 sprintf("cop_list[%d].cop_stash = %s;", $copix, $stashsym));
316 savesym($op, "(OP*)&cop_list[$copix]");
320 my ($op, $level) = @_;
321 my $sym = objsym($op);
322 return $sym if defined $sym;
323 my $replroot = $op->pmreplroot;
324 my $replstart = $op->pmreplstart;
325 my $replrootfield = sprintf("s\\_%x", $$replroot);
326 my $replstartfield = sprintf("s\\_%x", $$replstart);
328 my $ppaddr = $op->ppaddr;
330 # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
331 # argument to a split) stores a GV in op_pmreplroot instead
332 # of a substitution syntax tree. We don't want to walk that...
333 if ($ppaddr eq "pp_pushre") {
334 $gvsym = $replroot->save;
335 # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
338 $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
341 # pmnext handling is broken in perl itself, I think. Bad op_pmnext
342 # fields aren't noticed in perl's runtime (unless you try reset) but we
343 # segfault when trying to dereference it to find op->op_pmnext->op_type
344 $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, %s, %s, 0, 0, 0x%x, 0x%x",
345 ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ,
346 $op->type, $op_seq, $op->flags, $op->private,
347 ${$op->first}, ${$op->last}, $op->children,
348 $replrootfield, $replstartfield,
349 $op->pmflags, $op->pmpermflags,));
350 my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
351 my $re = $op->precomp;
353 my $resym = sprintf("re%d", $re_index++);
354 $decl->add(sprintf("static char *$resym = %s;", cstring($re)));
355 $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
359 $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
361 savesym($op, sprintf("(OP*)&pmop_list[%d]", $pmopsect->index));
364 sub B::SPECIAL::save {
366 # special case: $$sv is not the address but an index into specialsv_list
367 # warn "SPECIAL::save specialsv $$sv\n"; # debug
368 my $sym = $specialsv_name[$$sv];
369 if (!defined($sym)) {
370 confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
375 sub B::OBJECT::save {}
379 my $sym = objsym($sv);
380 return $sym if defined $sym;
381 # warn "Saving SVt_NULL SV\n"; # debug
384 # warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
386 $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT + 1, $sv->FLAGS));
387 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
392 my $sym = objsym($sv);
393 return $sym if defined $sym;
394 $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
395 $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
396 $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
397 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
402 my $sym = objsym($sv);
403 return $sym if defined $sym;
404 $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $sv->NVX));
405 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
406 $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
407 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
412 my $sym = objsym($sv);
413 return $sym if defined $sym;
415 my $len = length($pv);
416 my ($pvsym, $pvmax) = savepv($pv);
417 my ($lvtarg, $lvtarg_sym);
418 $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
419 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
420 $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
421 $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
422 $xpvlvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
423 if (!$pv_copy_on_grow) {
424 $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);",
425 $xpvlvsect->index, cstring($pv), $len));
428 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
433 my $sym = objsym($sv);
434 return $sym if defined $sym;
436 my $len = length($pv);
437 my ($pvsym, $pvmax) = savepv($pv);
438 $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
439 $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
440 $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
441 if (!$pv_copy_on_grow) {
442 $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);",
443 $xpvivsect->index, cstring($pv), $len));
445 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
450 my $sym = objsym($sv);
451 return $sym if defined $sym;
453 $pv = '' unless defined $pv;
454 my $len = length($pv);
455 my ($pvsym, $pvmax) = savepv($pv);
456 $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
457 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
458 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
459 $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
460 if (!$pv_copy_on_grow) {
461 $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);",
462 $xpvnvsect->index, cstring($pv), $len));
464 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
469 my $sym = objsym($sv);
470 return $sym if defined $sym;
471 my $pv = $sv->PV . "\0" . $sv->TABLE;
472 my $len = length($pv);
473 $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
474 $len, $len + 258, $sv->IVX, $sv->NVX,
475 $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
476 $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
477 $xpvbmsect->index, $sv->REFCNT + 1, $sv->FLAGS));
479 $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);",
480 $xpvbmsect->index, cstring($pv), $len),
481 sprintf("xpvbm_list[%d].xpv_cur = %u;",
482 $xpvbmsect->index, $len - 257));
483 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
488 my $sym = objsym($sv);
489 return $sym if defined $sym;
491 my $len = length($pv);
492 my ($pvsym, $pvmax) = savepv($pv);
493 $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
494 $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
495 $xpvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
496 if (!$pv_copy_on_grow) {
497 $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);",
498 $xpvsect->index, cstring($pv), $len));
500 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
505 my $sym = objsym($sv);
506 return $sym if defined $sym;
508 my $len = length($pv);
509 my ($pvsym, $pvmax) = savepv($pv);
510 $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
511 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
512 $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
513 $xpvmgsect->index, $sv->REFCNT + 1, $sv->FLAGS));
514 if (!$pv_copy_on_grow) {
515 $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);",
516 $xpvmgsect->index, cstring($pv), $len));
518 $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
523 sub B::PVMG::save_magic {
525 #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
526 my $stash = $sv->SvSTASH;
528 warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
530 # XXX Hope stash is already going to be saved.
531 $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
533 my @mgchain = $sv->MAGIC;
534 my ($mg, $type, $obj, $ptr,$len,$ptrsv);
535 foreach $mg (@mgchain) {
541 warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
542 class($sv), $$sv, class($obj), $$obj,
543 cchar($type), cstring($ptr));
545 if ($len == HEf_SVKEY){
546 #The pointer is an SV*
547 $ptrsv=svref_2object($ptr)->save;
548 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
549 $$sv, $$obj, cchar($type),$ptrsv,$len));
551 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
552 $$sv, $$obj, cchar($type),cstring($ptr),$len));
559 my $sym = objsym($sv);
560 return $sym if defined $sym;
561 my $rv = $sv->RV->save;
562 $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/;
564 $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
565 $xrvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
566 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
570 my ($cvstashname, $cvname) = @_;
571 warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
572 # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
573 # use should be handled by the class itself.
575 my $isa = \@{"$cvstashname\::ISA"};
576 if (grep($_ eq "AutoLoader", @$isa)) {
577 warn "Forcing immediate load of sub derived from AutoLoader\n";
578 # Tweaked version of AutoLoader::AUTOLOAD
579 my $dir = $cvstashname;
581 eval { require "auto/$dir/$cvname.al" };
583 warn qq(failed require "auto/$dir/$cvname.al": $@\n);
593 my $sym = objsym($cv);
595 # warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
598 # Reserve a place in svsect and xpvcvsect and record indices
599 my $sv_ix = $svsect->index + 1;
600 $svsect->add("svix$sv_ix");
601 my $xpvcv_ix = $xpvcvsect->index + 1;
602 $xpvcvsect->add("xpvcvix$xpvcv_ix");
603 # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
604 $sym = savesym($cv, "&sv_list[$sv_ix]");
605 warn sprintf("saving CV 0x%x as $sym\n", $$cv) if $debug_cv;
607 my $cvstashname = $gv->STASH->NAME;
608 my $cvname = $gv->NAME;
609 my $root = $cv->ROOT;
610 my $cvxsub = $cv->XSUB;
611 if (!$$root && !$cvxsub) {
612 if (try_autoload($cvstashname, $cvname)) {
613 # Recalculate root and xsub
616 if ($$root || $cvxsub) {
617 warn "Successful forced autoload\n";
622 my $padlist = $cv->PADLIST;
625 my $xsubany = "Nullany";
627 warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
628 $$cv, $$root) if $debug_cv;
631 my $stashname = $gv->STASH->NAME;
632 my $gvname = $gv->NAME;
633 if ($gvname ne "__ANON__") {
634 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
635 $ppname .= ($stashname eq "main") ?
636 $gvname : "$stashname\::$gvname";
637 $ppname =~ s/::/__/g;
638 if ($gvname eq "INIT"){
639 $ppname .= "_$initsub_index";
645 $ppname = "pp_anonsub_$anonsub_index";
648 $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
649 warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
650 $$cv, $ppname, $$root) if $debug_cv;
652 warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
653 $$padlist, $$cv) if $debug_cv;
655 warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
656 $$padlist, $$cv) if $debug_cv;
660 $xsubany = sprintf("ANYINIT((void*)0x%x)", $cv->XSUBANY);
661 # Try to find out canonical name of XSUB function from EGV.
662 # XXX Doesn't work for XSUBs with PREFIX set (or anyone who
663 # calls newXS() manually with weird arguments).
665 my $stashname = $egv->STASH->NAME;
666 $stashname =~ s/::/__/g;
667 $xsub = sprintf("XS_%s_%s", $stashname, $egv->NAME);
668 $decl->add("void $xsub _((CV*));");
671 warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
672 $cvstashname, $cvname); # debug
674 $pv = '' unless defined $pv; # Avoid use of undef warnings
675 $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, Nullgv, %d, s\\_%x, (CV*)s\\_%x, 0x%x",
676 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
677 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
678 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
680 if (${$cv->OUTSIDE} == ${main_cv()}){
681 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
682 $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
687 $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
688 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
689 $$gv, $$cv) if $debug_cv;
691 my $filegv = $cv->FILEGV;
694 $init->add(sprintf("CvFILEGV(s\\_%x) = s\\_%x;", $$cv, $$filegv));
695 warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n",
696 $$filegv, $$cv) if $debug_cv;
698 my $stash = $cv->STASH;
701 $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
702 warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
703 $$stash, $$cv) if $debug_cv;
705 $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
706 $sv_ix, $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS));
711 my ($gv,$skip_cv) = @_;
712 my $sym = objsym($gv);
714 #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
717 my $ix = $gv_index++;
718 $sym = savesym($gv, "gv_list[$ix]");
719 #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
721 my $gvname = $gv->NAME;
722 my $name = cstring($gv->STASH->NAME . "::" . $gvname);
723 #warn "GV name is $name\n"; # debug
727 #warn(sprintf("EGV name is %s, saving it now\n",
728 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
729 $egvsym = $egv->save;
731 $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
732 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
733 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS),
734 sprintf("GvLINE($sym) = %u;", $gv->LINE));
735 # Shouldn't need to do save_magic since gv_fetchpv handles that
737 my $refcnt = $gv->REFCNT + 1;
738 $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
739 my $gvrefcnt = $gv->GvREFCNT;
741 $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
743 if (defined($egvsym)) {
744 # Shared glob *foo = *bar
745 $init->add("gp_free($sym);",
746 "GvGP($sym) = GvGP($egvsym);");
747 } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
748 # Don't save subfields of special GVs (*_, *1, *# and so on)
749 # warn "GV::save saving subfields\n"; # debug
753 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
754 # warn "GV::save \$$name\n"; # debug
759 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
760 # warn "GV::save \@$name\n"; # debug
765 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
766 # warn "GV::save \%$name\n"; # debug
769 if ($$gvcv && !$skip_cv) {
771 $init->add(sprintf("GvCV($sym) = (CV*)s\\_%x;", $$gvcv));
772 # warn "GV::save &$name\n"; # debug
774 my $gvfilegv = $gv->FILEGV;
777 $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv));
778 # warn "GV::save GvFILEGV(*$name)\n"; # debug
780 my $gvform = $gv->FORM;
783 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
784 # warn "GV::save GvFORM(*$name)\n"; # debug
789 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
790 # warn "GV::save GvIO(*$name)\n"; # debug
797 my $sym = objsym($av);
798 return $sym if defined $sym;
799 my $avflags = $av->AvFLAGS;
800 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
802 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
803 $xpvavsect->index, $av->REFCNT + 1, $av->FLAGS));
804 my $sv_list_index = $svsect->index;
805 my $fill = $av->FILL;
807 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
809 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
810 #if ($fill > -1 && ($avflags & AVf_REAL)) {
812 my @array = $av->ARRAY;
816 foreach $el (@array) {
817 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
818 $$av, $i++, class($el), $$el);
821 my @names = map($_->save, @array);
822 # XXX Better ways to write loop?
823 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
824 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
827 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
828 "\tav_extend(av, $fill);",
829 "\tsvp = AvARRAY(av);",
830 map("\t*svp++ = (SV*)$_;", @names),
831 "\tAvFILLp(av) = $fill;",
835 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
838 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
843 my $sym = objsym($hv);
844 return $sym if defined $sym;
845 my $name = $hv->NAME;
849 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
850 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
851 # a trashed op but we look at the trashed op_type and segfault.
852 #my $adpmroot = ${$hv->PMROOT};
854 $decl->add("static HV *hv$hv_index;");
855 # XXX Beware of weird package names containing double-quotes, \n, ...?
856 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
858 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
861 $sym = savesym($hv, "hv$hv_index");
865 # It's just an ordinary HV
866 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
867 $hv->MAX, $hv->RITER));
868 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
869 $xpvhvsect->index, $hv->REFCNT + 1, $hv->FLAGS));
870 my $sv_list_index = $svsect->index;
871 my @contents = $hv->ARRAY;
874 for ($i = 1; $i < @contents; $i += 2) {
875 $contents[$i] = $contents[$i]->save;
877 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
879 my ($key, $value) = splice(@contents, 0, 2);
880 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
881 cstring($key),length($key),$value, hash($key)));
882 # $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
883 # cstring($key),length($key),$value, 0));
887 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
892 my $sym = objsym($io);
893 return $sym if defined $sym;
895 $pv = '' unless defined $pv;
896 my $len = length($pv);
897 $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",
898 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
899 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
900 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
901 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
902 cchar($io->IoTYPE), $io->IoFLAGS));
903 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
904 $xpviosect->index, $io->REFCNT + 1, $io->FLAGS));
905 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
907 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
908 $fsym = $io->$field();
910 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
920 # This is where we catch an honest-to-goodness Nullsv (which gets
921 # blessed into B::SV explicitly) and any stray erroneous SVs.
922 return 0 unless $$sv;
923 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
928 my $init_name = shift;
930 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
931 $listopsect, $pmopsect, $svopsect, $gvopsect, $pvopsect,
932 $loopsect, $copsect, $svsect, $xpvsect,
933 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
934 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
935 $bootstrap->output(\*STDOUT, "/* bootstrap %s */\n");
936 $symsect->output(\*STDOUT, "#define %s\n");
938 output_declarations();
939 foreach $section (@sections) {
940 my $lines = $section->index + 1;
942 my $name = $section->name;
943 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
944 print "Static $typename ${name}_list[$lines];\n";
947 $decl->output(\*STDOUT, "%s\n");
949 foreach $section (@sections) {
950 my $lines = $section->index + 1;
952 my $name = $section->name;
953 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
954 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
955 $section->output(\*STDOUT, "\t{ %s },\n");
961 static int $init_name()
965 $init->output(\*STDOUT, "\t%s\n");
966 print "\treturn 0;\n}\n";
968 warn compile_stats();
969 warn "NULLOP count: $nullop_count\n";
973 sub output_declarations {
975 #ifdef BROKEN_STATIC_REDECL
976 #define Static extern
978 #define Static static
979 #endif /* BROKEN_STATIC_REDECL */
981 #ifdef BROKEN_UNION_INIT
983 * Cribbed from cv.h with ANY (a union) replaced by void*.
984 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
987 char * xpv_pv; /* pointer to malloced string */
988 STRLEN xpv_cur; /* length of xp_pv as a C string */
989 STRLEN xpv_len; /* allocated size */
990 IV xof_off; /* integer value */
991 double xnv_nv; /* numeric value, if any */
992 MAGIC* xmg_magic; /* magic for scalar array */
993 HV* xmg_stash; /* class package */
998 void (*xcv_xsub) _((CV*));
1002 long xcv_depth; /* >= 2 indicates recursive call */
1006 perl_mutex *xcv_mutexp;
1007 struct perl_thread *xcv_owner; /* current owner thread */
1008 #endif /* USE_THREADS */
1011 #define ANYINIT(i) i
1013 #define XPVCV_or_similar XPVCV
1014 #define ANYINIT(i) {i}
1015 #endif /* BROKEN_UNION_INIT */
1016 #define Nullany ANYINIT(0)
1022 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1027 sub output_boilerplate {
1032 /* Workaround for mapstart: the only op which needs a different ppaddr */
1034 #define pp_mapstart pp_grepstart
1035 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1036 EXTERN_C void boot_DynaLoader _((CV* cv));
1038 static void xs_init _((void));
1039 static PerlInterpreter *my_perl;
1046 #ifndef CAN_PROTOTYPE
1047 main(argc, argv, env)
1051 #else /* def(CAN_PROTOTYPE) */
1052 main(int argc, char **argv, char **env)
1053 #endif /* def(CAN_PROTOTYPE) */
1059 PERL_SYS_INIT(&argc,&argv);
1061 perl_init_i18nl10n(1);
1063 if (!PL_do_undump) {
1064 my_perl = perl_alloc();
1067 perl_construct( my_perl );
1072 PL_cshlen = strlen(PL_cshname);
1075 #ifdef ALLOW_PERL_OPTIONS
1076 #define EXTRA_OPTIONS 2
1078 #define EXTRA_OPTIONS 3
1079 #endif /* ALLOW_PERL_OPTIONS */
1080 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1081 fakeargv[0] = argv[0];
1084 #ifndef ALLOW_PERL_OPTIONS
1086 #endif /* ALLOW_PERL_OPTIONS */
1087 for (i = 1; i < argc; i++)
1088 fakeargv[i + EXTRA_OPTIONS] = argv[i];
1089 fakeargv[argc + EXTRA_OPTIONS] = 0;
1091 exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1096 sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1097 PL_main_cv = PL_compcv;
1100 exitstatus = perl_init();
1104 exitstatus = perl_run( my_perl );
1106 perl_destruct( my_perl );
1107 perl_free( my_perl );
1112 /* yanked from perl.c */
1116 char *file = __FILE__;
1118 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
1126 warn "----Symbol table:\n";
1127 while (($sym, $val) = each %symtable) {
1128 warn "$sym => $val\n";
1130 warn "---End of symbol table\n";
1136 svref_2object($sv)->save;
1140 sub Dummy_BootStrap { }
1145 my $package=$gv->STASH->NAME;
1146 my $name = $gv->NAME;
1153 # We may be looking at this package just because it is a branch in the
1154 # symbol table which is on the path to a package which we need to save
1155 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1157 return unless ($unused_sub_packages{$package});
1160 if ($name eq "bootstrap" && $cv->XSUB)
1162 my $file = $cv->FILEGV->SV->PV;
1163 $bootstrap->add($file);
1164 my $name = $gv->STASH->NAME.'::'.$name;
1166 *{$name} = \&Dummy_BootStrap;
1169 warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
1170 $package, $name, $$cv, $$gv) if ($debug_cv);
1174 return unless ($$av || $$sv || $$hv)
1176 $gv->save($skip_cv);
1181 my $package = shift;
1182 unless ($unused_sub_packages{$package})
1185 $unused_sub_packages{$package} = 1;
1186 if (defined(@{$package.'::ISA'}))
1188 foreach my $isa (@{$package.'::ISA'})
1190 if ($isa eq 'DynaLoader')
1192 unless (defined(&{$package.'::bootstrap'}))
1194 warn "Forcing bootstrap of $package\n";
1195 eval { $package->bootstrap };
1200 unless ($unused_sub_packages{$isa})
1202 warn "$isa saved (it is in $package\'s \@ISA)\n";
1214 no strict qw(vars refs);
1215 my $package = shift;
1216 $package =~ s/::$//;
1217 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1218 # warn "Considering $package\n";#debug
1219 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1221 # If this package is a prefix to something we are saving, traverse it
1222 # but do not mark it for saving if it is not already
1223 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1225 return 1 if ($u =~ /^$package\:\:/);
1227 if (exists $unused_sub_packages{$package})
1229 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1230 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1231 return $unused_sub_packages{$package};
1233 # Omit the packages which we use (and which cause grief
1234 # because of fancy "goto &$AUTOLOAD" stuff).
1235 # XXX Surely there must be a nicer way to do this.
1236 if ($package eq "FileHandle" || $package eq "Config" ||
1237 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1239 delete_unsaved_hashINC($package);
1240 return $unused_sub_packages{$package} = 0;
1242 # Now see if current package looks like an OO class this is probably too strong.
1243 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1245 if ($package->can($m))
1247 warn "$package has method $m: saving package\n";#debug
1248 return mark_package($package);
1251 delete_unsaved_hashINC($package);
1252 return $unused_sub_packages{$package} = 0;
1254 sub delete_unsaved_hashINC{
1256 $packname =~ s/\:\:/\//g;
1258 warn "deleting $packname" if $INC{$packname} ;# debug
1259 delete $INC{$packname};
1263 my ($symref, $recurse, $prefix) = @_;
1268 $prefix = '' unless defined $prefix;
1269 while (($sym, $ref) = each %$symref)
1274 $sym = $prefix . $sym;
1275 if ($sym ne "main::" && &$recurse($sym))
1277 walkpackages(\%glob, $recurse, $sym);
1284 sub save_unused_subs
1287 &descend_marked_unused;
1289 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1290 warn "Saving methods\n";
1291 walksymtable(\%{"main::"}, "savecv", \&should_save);
1296 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1297 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1298 my $inc_hv = svref_2object(\%INC)->save;
1299 my $inc_av = svref_2object(\@INC)->save;
1300 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1301 "GvHV(PL_incgv) = $inc_hv;",
1302 "GvAV(PL_incgv) = $inc_av;",
1303 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1304 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));");
1307 sub descend_marked_unused {
1308 foreach my $pack (keys %unused_sub_packages)
1310 mark_package($pack);
1315 warn "Starting compile\n";
1316 warn "Walking tree\n";
1317 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1318 walkoptree(main_root, "save");
1319 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1321 my $init_av = init_av->save;
1322 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1323 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1324 "PL_initav = $init_av;");
1326 warn "Writing output\n";
1327 output_boilerplate();
1329 output_all("perl_init");
1335 my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1336 binop => \$binopsect, condop => \$condopsect,
1337 cop => \$copsect, gvop => \$gvopsect,
1338 listop => \$listopsect, logop => \$logopsect,
1339 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1340 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1341 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1342 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1343 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1344 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1345 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1346 xpvio => \$xpviosect, bootstrap => \$bootstrap);
1347 my ($name, $sectref);
1348 while (($name, $sectref) = splice(@sections, 0, 2)) {
1349 $$sectref = new B::C::Section $name, \%symtable, 0;
1355 my ($arg,$val) = @_;
1356 $unused_sub_packages{$arg} = $val;
1361 my ($option, $opt, $arg);
1363 while ($option = shift @options) {
1364 if ($option =~ /^-(.)(.*)/) {
1368 unshift @options, $option;
1371 if ($opt eq "-" && $arg eq "-") {
1376 $warn_undefined_syms = 1;
1377 } elsif ($opt eq "D") {
1378 $arg ||= shift @options;
1379 foreach $arg (split(//, $arg)) {
1382 } elsif ($arg eq "c") {
1384 } elsif ($arg eq "A") {
1386 } elsif ($arg eq "C") {
1388 } elsif ($arg eq "M") {
1391 warn "ignoring unknown debug option: $arg\n";
1394 } elsif ($opt eq "o") {
1395 $arg ||= shift @options;
1396 open(STDOUT, ">$arg") or return "$arg: $!\n";
1397 } elsif ($opt eq "v") {
1399 } elsif ($opt eq "u") {
1400 $arg ||= shift @options;
1401 mark_unused($arg,undef);
1402 } elsif ($opt eq "f") {
1403 $arg ||= shift @options;
1404 if ($arg eq "cog") {
1405 $pv_copy_on_grow = 1;
1406 } elsif ($arg eq "no-cog") {
1407 $pv_copy_on_grow = 0;
1409 } elsif ($opt eq "O") {
1410 $arg = 1 if $arg eq "";
1411 $pv_copy_on_grow = 0;
1413 # Optimisations for -O1
1414 $pv_copy_on_grow = 1;
1422 foreach $objname (@options) {
1423 eval "save_object(\\$objname)";
1428 return sub { save_main() };
1438 B::C - Perl compiler's C backend
1442 perl -MO=C[,OPTIONS] foo.pl
1446 This compiler backend takes Perl source and generates C source code
1447 corresponding to the internal structures that perl uses to run
1448 your program. When the generated C source is compiled and run, it
1449 cuts out the time which perl would have taken to load and parse
1450 your program into its internal semi-compiled form. That means that
1451 compiling with this backend will not help improve the runtime
1452 execution speed of your program but may improve the start-up time.
1453 Depending on the environment in which your program runs this may be
1454 either a help or a hindrance.
1458 If there are any non-option arguments, they are taken to be
1459 names of objects to be saved (probably doesn't work properly yet).
1460 Without extra arguments, it saves the main program.
1466 Output to filename instead of STDOUT
1470 Verbose compilation (currently gives a few compilation statistics).
1474 Force end of options
1478 Force apparently unused subs from package Packname to be compiled.
1479 This allows programs to use eval "foo()" even when sub foo is never
1480 seen to be used at compile time. The down side is that any subs which
1481 really are never used also have code generated. This option is
1482 necessary, for example, if you have a signal handler foo which you
1483 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1484 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1485 options. The compiler tries to figure out which packages may possibly
1486 have subs in which need compiling but the current version doesn't do
1487 it very well. In particular, it is confused by nested packages (i.e.
1488 of the form C<A::B>) where package C<A> does not contain any subs.
1492 Debug options (concatenated or separate flags like C<perl -D>).
1496 OPs, prints each OP as it's processed
1500 COPs, prints COPs as processed (incl. file & line num)
1504 prints AV information on saving
1508 prints CV information on saving
1512 prints MAGIC information on saving
1516 Force optimisations on or off one at a time.
1520 Copy-on-grow: PVs declared and initialised statically.
1528 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
1529 B<-O1> and higher set B<-fcog>.
1533 perl -MO=C,-ofoo.c foo.pl
1534 perl cc_harness -o foo foo.c
1536 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1537 library directory. The utility called C<perlcc> may also be used to
1538 help make use of this compiler.
1540 perl -MO=C,-v,-DcA bar.pl > /dev/null
1544 Plenty. Current status: experimental.
1548 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>