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 amagic_generation
54 use B::Asmdata qw(@specialsv_name);
64 my $anonsub_index = 0;
65 my $initsub_index = 0;
69 my $warn_undefined_syms;
71 my %unused_sub_packages;
73 my $pv_copy_on_grow = 0;
74 my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
78 @threadsv_names = threadsv_names();
82 my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect,
83 $gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
84 $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
85 $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
86 $xrvsect, $xpvbmsect, $xpviosect );
88 sub walk_and_save_optree;
89 my $saveoptree_callback = \&walk_and_save_optree;
90 sub set_callback { $saveoptree_callback = shift }
91 sub saveoptree { &$saveoptree_callback(@_) }
93 sub walk_and_save_optree {
94 my ($name, $root, $start) = @_;
95 walkoptree($root, "save");
96 return objsym($start);
99 # Current workaround/fix for op_free() trying to free statically
100 # defined OPs is to set op_seq = -1 and check for that in op_free().
101 # Instead of hardwiring -1 in place of $op->seq, we use $op_seq
102 # so that it can be changed back easily if necessary. In fact, to
103 # stop compilers from moaning about a U16 being initialised with an
104 # uncast -1 (the printf format is %d so we can't tweak it), we have
105 # to "know" that op_seq is a U16 and use 65535. Ugh.
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 $sym = objsym($op);
157 return $sym if defined $sym;
158 my $type = $op->type;
159 $nullop_count++ unless $type;
160 if ($type == $OP_THREADSV) {
161 # saves looking up ppaddr but it's a bit naughty to hard code this
162 $init->add(sprintf("(void)find_threadsv(%s);",
163 cstring($threadsv_names[$op->targ])));
165 $opsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x",
166 ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
167 $type, $op_seq, $op->flags, $op->private));
168 savesym($op, sprintf("&op_list[%d]", $opsect->index));
172 my ($class, %objdata) = @_;
173 bless \%objdata, $class;
176 sub B::FAKEOP::save {
177 my ($op, $level) = @_;
178 $opsect->add(sprintf("%s, %s, %s, %u, %u, %u, 0x%x, 0x%x",
179 $op->next, $op->sibling, $op->ppaddr, $op->targ,
180 $op->type, $op_seq, $op->flags, $op->private));
181 return sprintf("&op_list[%d]", $opsect->index);
184 sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
185 sub B::FAKEOP::type { $_[0]->{type} || 0}
186 sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
187 sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
188 sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
189 sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
190 sub B::FAKEOP::private { $_[0]->{private} || 0 }
193 my ($op, $level) = @_;
194 my $sym = objsym($op);
195 return $sym if defined $sym;
196 $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x",
197 ${$op->next}, ${$op->sibling}, $op->ppaddr,
198 $op->targ, $op->type, $op_seq, $op->flags,
199 $op->private, ${$op->first}));
200 savesym($op, sprintf("(OP*)&unop_list[%d]", $unopsect->index));
204 my ($op, $level) = @_;
205 my $sym = objsym($op);
206 return $sym if defined $sym;
207 $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
208 ${$op->next}, ${$op->sibling}, $op->ppaddr,
209 $op->targ, $op->type, $op_seq, $op->flags,
210 $op->private, ${$op->first}, ${$op->last}));
211 savesym($op, sprintf("(OP*)&binop_list[%d]", $binopsect->index));
214 sub B::LISTOP::save {
215 my ($op, $level) = @_;
216 my $sym = objsym($op);
217 return $sym if defined $sym;
218 $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u",
219 ${$op->next}, ${$op->sibling}, $op->ppaddr,
220 $op->targ, $op->type, $op_seq, $op->flags,
221 $op->private, ${$op->first}, ${$op->last},
223 savesym($op, sprintf("(OP*)&listop_list[%d]", $listopsect->index));
227 my ($op, $level) = @_;
228 my $sym = objsym($op);
229 return $sym if defined $sym;
230 $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
231 ${$op->next}, ${$op->sibling}, $op->ppaddr,
232 $op->targ, $op->type, $op_seq, $op->flags,
233 $op->private, ${$op->first}, ${$op->other}));
234 savesym($op, sprintf("(OP*)&logop_list[%d]", $logopsect->index));
238 my ($op, $level) = @_;
239 my $sym = objsym($op);
240 return $sym if defined $sym;
241 #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
242 # peekop($op->redoop), peekop($op->nextop),
243 # peekop($op->lastop)); # debug
244 $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",
245 ${$op->next}, ${$op->sibling}, $op->ppaddr,
246 $op->targ, $op->type, $op_seq, $op->flags,
247 $op->private, ${$op->first}, ${$op->last},
248 $op->children, ${$op->redoop}, ${$op->nextop},
250 savesym($op, sprintf("(OP*)&loop_list[%d]", $loopsect->index));
254 my ($op, $level) = @_;
255 my $sym = objsym($op);
256 return $sym if defined $sym;
257 $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
258 ${$op->next}, ${$op->sibling}, $op->ppaddr,
259 $op->targ, $op->type, $op_seq, $op->flags,
260 $op->private, cstring($op->pv)));
261 savesym($op, sprintf("(OP*)&pvop_list[%d]", $pvopsect->index));
265 my ($op, $level) = @_;
266 my $sym = objsym($op);
267 return $sym if defined $sym;
268 my $svsym = $op->sv->save;
269 $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
270 ${$op->next}, ${$op->sibling}, $op->ppaddr,
271 $op->targ, $op->type, $op_seq, $op->flags,
272 $op->private, "(SV*)$svsym"));
273 savesym($op, sprintf("(OP*)&svop_list[%d]", $svopsect->index));
277 my ($op, $level) = @_;
278 my $sym = objsym($op);
279 return $sym if defined $sym;
280 my $gvsym = $op->gv->save;
281 $gvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullgv",
282 ${$op->next}, ${$op->sibling}, $op->ppaddr,
283 $op->targ, $op->type, $op_seq, $op->flags,
285 $init->add(sprintf("gvop_list[%d].op_gv = %s;", $gvopsect->index, $gvsym));
286 savesym($op, sprintf("(OP*)&gvop_list[%d]", $gvopsect->index));
290 my ($op, $level) = @_;
291 my $sym = objsym($op);
292 return $sym if defined $sym;
293 my $gvsym = $op->filegv->save;
294 my $stashsym = $op->stash->save;
295 warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV)
297 $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u",
298 ${$op->next}, ${$op->sibling}, $op->ppaddr,
299 $op->targ, $op->type, $op_seq, $op->flags,
300 $op->private, cstring($op->label), $op->cop_seq,
301 $op->arybase, $op->line));
302 my $copix = $copsect->index;
303 $init->add(sprintf("cop_list[%d].cop_filegv = %s;", $copix, $gvsym),
304 sprintf("cop_list[%d].cop_stash = %s;", $copix, $stashsym));
305 savesym($op, "(OP*)&cop_list[$copix]");
309 my ($op, $level) = @_;
310 my $sym = objsym($op);
311 return $sym if defined $sym;
312 my $replroot = $op->pmreplroot;
313 my $replstart = $op->pmreplstart;
314 my $replrootfield = sprintf("s\\_%x", $$replroot);
315 my $replstartfield = sprintf("s\\_%x", $$replstart);
317 my $ppaddr = $op->ppaddr;
319 # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
320 # argument to a split) stores a GV in op_pmreplroot instead
321 # of a substitution syntax tree. We don't want to walk that...
322 if ($ppaddr eq "pp_pushre") {
323 $gvsym = $replroot->save;
324 # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
327 $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
330 # pmnext handling is broken in perl itself, I think. Bad op_pmnext
331 # fields aren't noticed in perl's runtime (unless you try reset) but we
332 # segfault when trying to dereference it to find op->op_pmnext->op_type
333 $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",
334 ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ,
335 $op->type, $op_seq, $op->flags, $op->private,
336 ${$op->first}, ${$op->last}, $op->children,
337 $replrootfield, $replstartfield,
338 $op->pmflags, $op->pmpermflags,));
339 my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
340 my $re = $op->precomp;
342 my $resym = sprintf("re%d", $re_index++);
343 $decl->add(sprintf("static char *$resym = %s;", cstring($re)));
344 $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
348 $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
350 savesym($op, sprintf("(OP*)&pmop_list[%d]", $pmopsect->index));
353 sub B::SPECIAL::save {
355 # special case: $$sv is not the address but an index into specialsv_list
356 # warn "SPECIAL::save specialsv $$sv\n"; # debug
357 my $sym = $specialsv_name[$$sv];
358 if (!defined($sym)) {
359 confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
364 sub B::OBJECT::save {}
368 my $sym = objsym($sv);
369 return $sym if defined $sym;
370 # warn "Saving SVt_NULL SV\n"; # debug
373 # warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
375 $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT + 1, $sv->FLAGS));
376 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
381 my $sym = objsym($sv);
382 return $sym if defined $sym;
383 $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
384 $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
385 $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
386 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
391 my $sym = objsym($sv);
392 return $sym if defined $sym;
394 $val .= '.00' if $val =~ /^-?\d+$/;
395 $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
396 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
397 $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
398 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
403 my $sym = objsym($sv);
404 return $sym if defined $sym;
406 my $len = length($pv);
407 my ($pvsym, $pvmax) = savepv($pv);
408 my ($lvtarg, $lvtarg_sym);
409 $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
410 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
411 $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
412 $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
413 $xpvlvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
414 if (!$pv_copy_on_grow) {
415 $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);",
416 $xpvlvsect->index, cstring($pv), $len));
419 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
424 my $sym = objsym($sv);
425 return $sym if defined $sym;
427 my $len = length($pv);
428 my ($pvsym, $pvmax) = savepv($pv);
429 $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
430 $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
431 $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
432 if (!$pv_copy_on_grow) {
433 $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);",
434 $xpvivsect->index, cstring($pv), $len));
436 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
441 my $sym = objsym($sv);
442 return $sym if defined $sym;
444 $pv = '' unless defined $pv;
445 my $len = length($pv);
446 my ($pvsym, $pvmax) = savepv($pv);
448 $val .= '.00' if $val =~ /^-?\d+$/;
449 $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
450 $pvsym, $len, $pvmax, $sv->IVX, $val));
451 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
452 $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
453 if (!$pv_copy_on_grow) {
454 $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);",
455 $xpvnvsect->index, cstring($pv), $len));
457 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
462 my $sym = objsym($sv);
463 return $sym if defined $sym;
464 my $pv = $sv->PV . "\0" . $sv->TABLE;
465 my $len = length($pv);
466 $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
467 $len, $len + 258, $sv->IVX, $sv->NVX,
468 $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
469 $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
470 $xpvbmsect->index, $sv->REFCNT + 1, $sv->FLAGS));
472 $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);",
473 $xpvbmsect->index, cstring($pv), $len),
474 sprintf("xpvbm_list[%d].xpv_cur = %u;",
475 $xpvbmsect->index, $len - 257));
476 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
481 my $sym = objsym($sv);
482 return $sym if defined $sym;
484 my $len = length($pv);
485 my ($pvsym, $pvmax) = savepv($pv);
486 $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
487 $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
488 $xpvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
489 if (!$pv_copy_on_grow) {
490 $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);",
491 $xpvsect->index, cstring($pv), $len));
493 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
498 my $sym = objsym($sv);
499 return $sym if defined $sym;
501 my $len = length($pv);
502 my ($pvsym, $pvmax) = savepv($pv);
503 $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
504 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
505 $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
506 $xpvmgsect->index, $sv->REFCNT + 1, $sv->FLAGS));
507 if (!$pv_copy_on_grow) {
508 $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);",
509 $xpvmgsect->index, cstring($pv), $len));
511 $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
516 sub B::PVMG::save_magic {
518 #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
519 my $stash = $sv->SvSTASH;
522 warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
524 # XXX Hope stash is already going to be saved.
525 $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
527 my @mgchain = $sv->MAGIC;
528 my ($mg, $type, $obj, $ptr,$len,$ptrsv);
529 foreach $mg (@mgchain) {
535 warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
536 class($sv), $$sv, class($obj), $$obj,
537 cchar($type), cstring($ptr));
540 if ($len == HEf_SVKEY){
541 #The pointer is an SV*
542 $ptrsv=svref_2object($ptr)->save;
543 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
544 $$sv, $$obj, cchar($type),$ptrsv,$len));
546 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
547 $$sv, $$obj, cchar($type),cstring($ptr),$len));
554 my $sym = objsym($sv);
555 return $sym if defined $sym;
556 my $rv = $sv->RV->save;
557 $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/;
559 $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
560 $xrvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
561 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
565 my ($cvstashname, $cvname) = @_;
566 warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
567 # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
568 # use should be handled by the class itself.
570 my $isa = \@{"$cvstashname\::ISA"};
571 if (grep($_ eq "AutoLoader", @$isa)) {
572 warn "Forcing immediate load of sub derived from AutoLoader\n";
573 # Tweaked version of AutoLoader::AUTOLOAD
574 my $dir = $cvstashname;
576 eval { require "auto/$dir/$cvname.al" };
578 warn qq(failed require "auto/$dir/$cvname.al": $@\n);
588 my $sym = objsym($cv);
590 # warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
593 # Reserve a place in svsect and xpvcvsect and record indices
595 my $cvstashname = $gv->STASH->NAME;
596 my $cvname = $gv->NAME;
597 my $root = $cv->ROOT;
598 my $cvxsub = $cv->XSUB;
601 my $stashname = $egv->STASH->NAME;
602 $xsub{$stashname}='Static' unless $xsub{$stashname};
604 my $sv_ix = $svsect->index + 1;
605 $svsect->add("svix$sv_ix");
606 my $xpvcv_ix = $xpvcvsect->index + 1;
607 $xpvcvsect->add("xpvcvix$xpvcv_ix");
608 # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
609 $sym = savesym($cv, "&sv_list[$sv_ix]");
610 warn sprintf("saving CV 0x%x as $sym\n", $$cv) if $debug_cv;
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 warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
661 $cvstashname, $cvname); # debug
663 $pv = '' unless defined $pv; # Avoid use of undef warnings
664 $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",
665 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
666 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
667 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
669 if (${$cv->OUTSIDE} == ${main_cv()}){
670 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
671 $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
676 $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
677 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
678 $$gv, $$cv) if $debug_cv;
680 my $filegv = $cv->FILEGV;
683 $init->add(sprintf("CvFILEGV(s\\_%x) = s\\_%x;", $$cv, $$filegv));
684 warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n",
685 $$filegv, $$cv) if $debug_cv;
687 my $stash = $cv->STASH;
690 $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
691 warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
692 $$stash, $$cv) if $debug_cv;
694 $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
695 $sv_ix, $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS));
700 my ($gv,$skip_cv) = @_;
701 my $sym = objsym($gv);
703 #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
706 my $ix = $gv_index++;
707 $sym = savesym($gv, "gv_list[$ix]");
708 #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
710 my $gvname = $gv->NAME;
711 my $name = cstring($gv->STASH->NAME . "::" . $gvname);
712 #warn "GV name is $name\n"; # debug
716 #warn(sprintf("EGV name is %s, saving it now\n",
717 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
718 $egvsym = $egv->save;
720 $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
721 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
722 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS),
723 sprintf("GvLINE($sym) = %u;", $gv->LINE));
724 # Shouldn't need to do save_magic since gv_fetchpv handles that
726 my $refcnt = $gv->REFCNT + 1;
727 $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
728 my $gvrefcnt = $gv->GvREFCNT;
730 $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
732 if (defined($egvsym)) {
733 # Shared glob *foo = *bar
734 $init->add("gp_free($sym);",
735 "GvGP($sym) = GvGP($egvsym);");
736 } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
737 # Don't save subfields of special GVs (*_, *1, *# and so on)
738 # warn "GV::save saving subfields\n"; # debug
742 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
743 # warn "GV::save \$$name\n"; # debug
748 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
749 # warn "GV::save \@$name\n"; # debug
754 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
755 # warn "GV::save \%$name\n"; # debug
758 if ($$gvcv && !$skip_cv && !$gvcv->XSUB) { #not XSUB
760 $init->add(sprintf("GvCV($sym) = (CV*)s\\_%x;", $$gvcv));
761 # warn "GV::save &$name\n"; # debug
762 }elsif ($$gvcv && $gvcv->XSUB && $name ne
763 (my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
764 "::" . $gvcv->GV->EGV->NAME))) { #XSUB alias
766 $init->add("{ CV *cv;");
767 $init->add("\tcv=GvCV(gv_fetchpv($origname,FALSE,SVt_PV));");
768 $init->add("\tGvCV($sym)=cv;");
769 $init->add("\tSvREFCNT_inc((SV *)cv);");
773 my $gvfilegv = $gv->FILEGV;
776 $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv));
777 # warn "GV::save GvFILEGV(*$name)\n"; # debug
779 my $gvform = $gv->FORM;
782 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
783 # warn "GV::save GvFORM(*$name)\n"; # debug
788 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
789 # warn "GV::save GvIO(*$name)\n"; # debug
796 my $sym = objsym($av);
797 return $sym if defined $sym;
798 my $avflags = $av->AvFLAGS;
799 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
801 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
802 $xpvavsect->index, $av->REFCNT + 1, $av->FLAGS));
803 my $sv_list_index = $svsect->index;
804 my $fill = $av->FILL;
806 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
808 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
809 #if ($fill > -1 && ($avflags & AVf_REAL)) {
811 my @array = $av->ARRAY;
815 foreach $el (@array) {
816 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
817 $$av, $i++, class($el), $$el);
820 my @names = map($_->save, @array);
821 # XXX Better ways to write loop?
822 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
823 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
826 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
827 "\tav_extend(av, $fill);",
828 "\tsvp = AvARRAY(av);",
829 map("\t*svp++ = (SV*)$_;", @names),
830 "\tAvFILLp(av) = $fill;",
834 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
837 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
842 my $sym = objsym($hv);
843 return $sym if defined $sym;
844 my $name = $hv->NAME;
848 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
849 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
850 # a trashed op but we look at the trashed op_type and segfault.
851 #my $adpmroot = ${$hv->PMROOT};
853 $decl->add("static HV *hv$hv_index;");
854 # XXX Beware of weird package names containing double-quotes, \n, ...?
855 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
857 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
860 $sym = savesym($hv, "hv$hv_index");
864 # It's just an ordinary HV
865 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
866 $hv->MAX, $hv->RITER));
867 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
868 $xpvhvsect->index, $hv->REFCNT + 1, $hv->FLAGS));
869 my $sv_list_index = $svsect->index;
870 my @contents = $hv->ARRAY;
873 for ($i = 1; $i < @contents; $i += 2) {
874 $contents[$i] = $contents[$i]->save;
876 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
878 my ($key, $value) = splice(@contents, 0, 2);
879 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
880 cstring($key),length($key),$value, hash($key)));
881 # $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
882 # cstring($key),length($key),$value, 0));
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 $symsect->output(\*STDOUT, "#define %s\n");
937 output_declarations();
938 foreach $section (@sections) {
939 my $lines = $section->index + 1;
941 my $name = $section->name;
942 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
943 print "Static $typename ${name}_list[$lines];\n";
946 $decl->output(\*STDOUT, "%s\n");
948 foreach $section (@sections) {
949 my $lines = $section->index + 1;
951 my $name = $section->name;
952 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
953 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
954 $section->output(\*STDOUT, "\t{ %s },\n");
960 static int $init_name()
966 $init->output(\*STDOUT, "\t%s\n");
967 print "\treturn 0;\n}\n";
969 warn compile_stats();
970 warn "NULLOP count: $nullop_count\n";
974 sub output_declarations {
976 #ifdef BROKEN_STATIC_REDECL
977 #define Static extern
979 #define Static static
980 #endif /* BROKEN_STATIC_REDECL */
982 #ifdef BROKEN_UNION_INIT
984 * Cribbed from cv.h with ANY (a union) replaced by void*.
985 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
988 char * xpv_pv; /* pointer to malloced string */
989 STRLEN xpv_cur; /* length of xp_pv as a C string */
990 STRLEN xpv_len; /* allocated size */
991 IV xof_off; /* integer value */
992 double xnv_nv; /* numeric value, if any */
993 MAGIC* xmg_magic; /* magic for scalar array */
994 HV* xmg_stash; /* class package */
999 void (*xcv_xsub) (CV*);
1003 long xcv_depth; /* >= 2 indicates recursive call */
1007 perl_mutex *xcv_mutexp;
1008 struct perl_thread *xcv_owner; /* current owner thread */
1009 #endif /* USE_THREADS */
1012 #define ANYINIT(i) i
1014 #define XPVCV_or_similar XPVCV
1015 #define ANYINIT(i) {i}
1016 #endif /* BROKEN_UNION_INIT */
1017 #define Nullany ANYINIT(0)
1023 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1028 sub output_boilerplate {
1033 /* Workaround for mapstart: the only op which needs a different ppaddr */
1035 #define pp_mapstart pp_grepstart
1036 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1037 EXTERN_C void boot_DynaLoader (CV* cv);
1039 static void xs_init (void);
1040 static PerlInterpreter *my_perl;
1047 #ifndef CAN_PROTOTYPE
1048 main(argc, argv, env)
1052 #else /* def(CAN_PROTOTYPE) */
1053 main(int argc, char **argv, char **env)
1054 #endif /* def(CAN_PROTOTYPE) */
1060 PERL_SYS_INIT(&argc,&argv);
1062 perl_init_i18nl10n(1);
1064 if (!PL_do_undump) {
1065 my_perl = perl_alloc();
1068 perl_construct( my_perl );
1073 PL_cshlen = strlen(PL_cshname);
1076 #ifdef ALLOW_PERL_OPTIONS
1077 #define EXTRA_OPTIONS 2
1079 #define EXTRA_OPTIONS 3
1080 #endif /* ALLOW_PERL_OPTIONS */
1081 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1082 fakeargv[0] = argv[0];
1085 #ifndef ALLOW_PERL_OPTIONS
1087 #endif /* ALLOW_PERL_OPTIONS */
1088 for (i = 1; i < argc; i++)
1089 fakeargv[i + EXTRA_OPTIONS] = argv[i];
1090 fakeargv[argc + EXTRA_OPTIONS] = 0;
1092 exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1097 sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1098 PL_main_cv = PL_compcv;
1101 exitstatus = perl_init();
1105 exitstatus = perl_run( my_perl );
1107 perl_destruct( my_perl );
1108 perl_free( my_perl );
1113 /* yanked from perl.c */
1117 char *file = __FILE__;
1121 print "\n#ifdef USE_DYNAMIC_LOADING";
1122 print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1123 print "\n#endif\n" ;
1124 delete $xsub{'DynaLoader'};
1125 delete $xsub{'UNIVERSAL'};
1126 print("/* bootstrapping code*/\nSAVETMPS;\n");
1127 print("\ttarg=sv_newmortal();\n");
1128 foreach my $stashname (keys %xsub ){
1129 my $stashxsub=$stashname;
1130 $stashxsub =~ s/::/__/g;
1131 if ($xsub{$stashname} eq 'Dynamic') {
1132 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1133 warn "bootstrapping $stashname added to xs_init\n";
1134 print qq/\n\t{\n\tchar *args[]={"$stashxsub", NULL};/;
1135 print qq/\n\t\tperl_call_argv("${stashxsub}::bootstrap",G_DISCARD,args);\n\t}/;
1138 print "\tPUSHMARK(sp);\n";
1139 print qq/\tXPUSHp("$stashname",strlen("$stashname")+1);\n/;
1140 print "\tboot_$stashxsub(NULL);\n";
1141 print "#endif\n" if ($xsub{$stashname} eq 'Dynamic');
1144 print("\tFREETMPS;\n/* end bootstrapping code */\n");
1150 warn "----Symbol table:\n";
1151 while (($sym, $val) = each %symtable) {
1152 warn "$sym => $val\n";
1154 warn "---End of symbol table\n";
1160 svref_2object($sv)->save;
1164 sub Dummy_BootStrap { }
1169 my $package=$gv->STASH->NAME;
1170 my $name = $gv->NAME;
1177 # We may be looking at this package just because it is a branch in the
1178 # symbol table which is on the path to a package which we need to save
1179 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1181 return unless ($unused_sub_packages{$package});
1184 if ($name eq "bootstrap" && $cv->XSUB)
1186 my $file = $cv->FILEGV->SV->PV;
1187 my $name = $gv->STASH->NAME.'::'.$name;
1189 *{$name} = \&Dummy_BootStrap;
1190 $xsub{$gv->STASH->NAME}='Dynamic';
1193 warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
1194 $package, $name, $$cv, $$gv) if ($debug_cv);
1198 return unless ($$av || $$sv || $$hv)
1200 $gv->save($skip_cv);
1205 my $package = shift;
1206 unless ($unused_sub_packages{$package})
1209 $unused_sub_packages{$package} = 1;
1210 if (defined(@{$package.'::ISA'}))
1212 foreach my $isa (@{$package.'::ISA'})
1214 if ($isa eq 'DynaLoader')
1216 unless (defined(&{$package.'::bootstrap'}))
1218 warn "Forcing bootstrap of $package\n";
1219 eval { $package->bootstrap };
1224 unless ($unused_sub_packages{$isa})
1226 warn "$isa saved (it is in $package\'s \@ISA)\n";
1238 no strict qw(vars refs);
1239 my $package = shift;
1240 $package =~ s/::$//;
1241 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1242 # warn "Considering $package\n";#debug
1243 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1245 # If this package is a prefix to something we are saving, traverse it
1246 # but do not mark it for saving if it is not already
1247 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1249 return 1 if ($u =~ /^$package\:\:/);
1251 if (exists $unused_sub_packages{$package})
1253 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1254 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1255 return $unused_sub_packages{$package};
1257 # Omit the packages which we use (and which cause grief
1258 # because of fancy "goto &$AUTOLOAD" stuff).
1259 # XXX Surely there must be a nicer way to do this.
1260 if ($package eq "FileHandle" || $package eq "Config" ||
1261 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1263 delete_unsaved_hashINC($package);
1264 return $unused_sub_packages{$package} = 0;
1266 # Now see if current package looks like an OO class this is probably too strong.
1267 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1269 if ($package->can($m))
1271 warn "$package has method $m: saving package\n";#debug
1272 return mark_package($package);
1275 delete_unsaved_hashINC($package);
1276 return $unused_sub_packages{$package} = 0;
1278 sub delete_unsaved_hashINC{
1280 $packname =~ s/\:\:/\//g;
1282 # warn "deleting $packname" if $INC{$packname} ;# debug
1283 delete $INC{$packname};
1287 my ($symref, $recurse, $prefix) = @_;
1292 $prefix = '' unless defined $prefix;
1293 while (($sym, $ref) = each %$symref)
1298 $sym = $prefix . $sym;
1299 if ($sym ne "main::" && &$recurse($sym))
1301 walkpackages(\%glob, $recurse, $sym);
1308 sub save_unused_subs
1311 &descend_marked_unused;
1313 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1314 warn "Saving methods\n";
1315 walksymtable(\%{"main::"}, "savecv", \&should_save);
1320 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1321 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1322 my $inc_hv = svref_2object(\%INC)->save;
1323 my $inc_av = svref_2object(\@INC)->save;
1324 my $amagic_generate= amagic_generation;
1325 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1326 "GvHV(PL_incgv) = $inc_hv;",
1327 "GvAV(PL_incgv) = $inc_av;",
1328 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1329 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1330 "PL_amagic_generation= $amagic_generate;" );
1333 sub descend_marked_unused {
1334 foreach my $pack (keys %unused_sub_packages)
1336 mark_package($pack);
1341 warn "Starting compile\n";
1342 warn "Walking tree\n";
1343 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1344 walkoptree(main_root, "save");
1345 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1347 my $init_av = init_av->save;
1348 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1349 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1350 "PL_initav = (AV *) $init_av;");
1352 warn "Writing output\n";
1353 output_boilerplate();
1355 output_all("perl_init");
1361 my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1362 binop => \$binopsect, condop => \$condopsect,
1363 cop => \$copsect, gvop => \$gvopsect,
1364 listop => \$listopsect, logop => \$logopsect,
1365 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1366 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1367 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1368 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1369 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1370 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1371 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1372 xpvio => \$xpviosect);
1373 my ($name, $sectref);
1374 while (($name, $sectref) = splice(@sections, 0, 2)) {
1375 $$sectref = new B::C::Section $name, \%symtable, 0;
1381 my ($arg,$val) = @_;
1382 $unused_sub_packages{$arg} = $val;
1387 my ($option, $opt, $arg);
1389 while ($option = shift @options) {
1390 if ($option =~ /^-(.)(.*)/) {
1394 unshift @options, $option;
1397 if ($opt eq "-" && $arg eq "-") {
1402 $warn_undefined_syms = 1;
1403 } elsif ($opt eq "D") {
1404 $arg ||= shift @options;
1405 foreach $arg (split(//, $arg)) {
1408 } elsif ($arg eq "c") {
1410 } elsif ($arg eq "A") {
1412 } elsif ($arg eq "C") {
1414 } elsif ($arg eq "M") {
1417 warn "ignoring unknown debug option: $arg\n";
1420 } elsif ($opt eq "o") {
1421 $arg ||= shift @options;
1422 open(STDOUT, ">$arg") or return "$arg: $!\n";
1423 } elsif ($opt eq "v") {
1425 } elsif ($opt eq "u") {
1426 $arg ||= shift @options;
1427 mark_unused($arg,undef);
1428 } elsif ($opt eq "f") {
1429 $arg ||= shift @options;
1430 if ($arg eq "cog") {
1431 $pv_copy_on_grow = 1;
1432 } elsif ($arg eq "no-cog") {
1433 $pv_copy_on_grow = 0;
1435 } elsif ($opt eq "O") {
1436 $arg = 1 if $arg eq "";
1437 $pv_copy_on_grow = 0;
1439 # Optimisations for -O1
1440 $pv_copy_on_grow = 1;
1448 foreach $objname (@options) {
1449 eval "save_object(\\$objname)";
1454 return sub { save_main() };
1464 B::C - Perl compiler's C backend
1468 perl -MO=C[,OPTIONS] foo.pl
1472 This compiler backend takes Perl source and generates C source code
1473 corresponding to the internal structures that perl uses to run
1474 your program. When the generated C source is compiled and run, it
1475 cuts out the time which perl would have taken to load and parse
1476 your program into its internal semi-compiled form. That means that
1477 compiling with this backend will not help improve the runtime
1478 execution speed of your program but may improve the start-up time.
1479 Depending on the environment in which your program runs this may be
1480 either a help or a hindrance.
1484 If there are any non-option arguments, they are taken to be
1485 names of objects to be saved (probably doesn't work properly yet).
1486 Without extra arguments, it saves the main program.
1492 Output to filename instead of STDOUT
1496 Verbose compilation (currently gives a few compilation statistics).
1500 Force end of options
1504 Force apparently unused subs from package Packname to be compiled.
1505 This allows programs to use eval "foo()" even when sub foo is never
1506 seen to be used at compile time. The down side is that any subs which
1507 really are never used also have code generated. This option is
1508 necessary, for example, if you have a signal handler foo which you
1509 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1510 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1511 options. The compiler tries to figure out which packages may possibly
1512 have subs in which need compiling but the current version doesn't do
1513 it very well. In particular, it is confused by nested packages (i.e.
1514 of the form C<A::B>) where package C<A> does not contain any subs.
1518 Debug options (concatenated or separate flags like C<perl -D>).
1522 OPs, prints each OP as it's processed
1526 COPs, prints COPs as processed (incl. file & line num)
1530 prints AV information on saving
1534 prints CV information on saving
1538 prints MAGIC information on saving
1542 Force optimisations on or off one at a time.
1546 Copy-on-grow: PVs declared and initialised statically.
1554 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
1555 B<-O1> and higher set B<-fcog>.
1559 perl -MO=C,-ofoo.c foo.pl
1560 perl cc_harness -o foo foo.c
1562 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1563 library directory. The utility called C<perlcc> may also be used to
1564 help make use of this compiler.
1566 perl -MO=C,-v,-DcA bar.pl > /dev/null
1570 Plenty. Current status: experimental.
1574 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>