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 ($op->name eq "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;
599 #INIT is removed from the symbol table, so this call must come
600 # from PL_initav->save. Re-bootstrapping will push INIT back in
601 # so nullop should be sent.
602 if ($cvxsub && ($cvname ne "INIT")) {
604 my $stashname = $egv->STASH->NAME;
605 if ($cvname eq "bootstrap")
607 my $file = $cv->FILEGV->SV->PV;
608 $decl->add("/* bootstrap $file */");
609 warn "Bootstrap $stashname $file\n";
610 $xsub{$stashname}='Dynamic';
611 # $xsub{$stashname}='Static' unless $xsub{$stashname};
614 return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/;
616 if ($cvxsub && $cvname eq "INIT") {
618 return svref_2object(\&Dummy_initxs)->save;
620 my $sv_ix = $svsect->index + 1;
621 $svsect->add("svix$sv_ix");
622 my $xpvcv_ix = $xpvcvsect->index + 1;
623 $xpvcvsect->add("xpvcvix$xpvcv_ix");
624 # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
625 $sym = savesym($cv, "&sv_list[$sv_ix]");
626 warn sprintf("saving CV 0x%x as $sym\n", $$cv) if $debug_cv;
627 if (!$$root && !$cvxsub) {
628 if (try_autoload($cvstashname, $cvname)) {
629 # Recalculate root and xsub
632 if ($$root || $cvxsub) {
633 warn "Successful forced autoload\n";
638 my $padlist = $cv->PADLIST;
641 my $xsubany = "Nullany";
643 warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
644 $$cv, $$root) if $debug_cv;
647 my $stashname = $gv->STASH->NAME;
648 my $gvname = $gv->NAME;
649 if ($gvname ne "__ANON__") {
650 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
651 $ppname .= ($stashname eq "main") ?
652 $gvname : "$stashname\::$gvname";
653 $ppname =~ s/::/__/g;
654 if ($gvname eq "INIT"){
655 $ppname .= "_$initsub_index";
661 $ppname = "pp_anonsub_$anonsub_index";
664 $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
665 warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
666 $$cv, $ppname, $$root) if $debug_cv;
668 warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
669 $$padlist, $$cv) if $debug_cv;
671 warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
672 $$padlist, $$cv) if $debug_cv;
676 warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
677 $cvstashname, $cvname); # debug
679 $pv = '' unless defined $pv; # Avoid use of undef warnings
680 $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",
681 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
682 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
683 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
685 if (${$cv->OUTSIDE} == ${main_cv()}){
686 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
687 $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
692 $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
693 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
694 $$gv, $$cv) if $debug_cv;
696 my $filegv = $cv->FILEGV;
699 $init->add(sprintf("CvFILEGV(s\\_%x) = s\\_%x;", $$cv, $$filegv));
700 warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n",
701 $$filegv, $$cv) if $debug_cv;
703 my $stash = $cv->STASH;
706 $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
707 warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
708 $$stash, $$cv) if $debug_cv;
710 $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
711 $sv_ix, $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS));
717 my $sym = objsym($gv);
719 #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
722 my $ix = $gv_index++;
723 $sym = savesym($gv, "gv_list[$ix]");
724 #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
726 my $gvname = $gv->NAME;
727 my $name = cstring($gv->STASH->NAME . "::" . $gvname);
728 #warn "GV name is $name\n"; # debug
732 #warn(sprintf("EGV name is %s, saving it now\n",
733 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
734 $egvsym = $egv->save;
736 $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
737 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
738 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS),
739 sprintf("GvLINE($sym) = %u;", $gv->LINE));
740 # Shouldn't need to do save_magic since gv_fetchpv handles that
742 my $refcnt = $gv->REFCNT + 1;
743 $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
744 my $gvrefcnt = $gv->GvREFCNT;
746 $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
748 if (defined($egvsym)) {
749 # Shared glob *foo = *bar
750 $init->add("gp_free($sym);",
751 "GvGP($sym) = GvGP($egvsym);");
752 } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
753 # Don't save subfields of special GVs (*_, *1, *# and so on)
754 # warn "GV::save saving subfields\n"; # debug
758 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
759 # warn "GV::save \$$name\n"; # debug
764 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
765 # warn "GV::save \@$name\n"; # debug
770 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
771 # warn "GV::save \%$name\n"; # debug
775 my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
776 "::" . $gvcv->GV->EGV->NAME);
777 if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias
778 # must save as a 'stub' so newXS() has a CV to populate
779 $init->add("{ CV *cv;");
780 $init->add("\tcv=perl_get_cv($origname,TRUE);");
781 $init->add("\tGvCV($sym)=cv;");
782 $init->add("\tSvREFCNT_inc((SV *)cv);");
785 $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
786 # warn "GV::save &$name\n"; # debug
789 my $gvfilegv = $gv->FILEGV;
792 $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv));
793 # warn "GV::save GvFILEGV(*$name)\n"; # debug
795 my $gvform = $gv->FORM;
798 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
799 # warn "GV::save GvFORM(*$name)\n"; # debug
804 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
805 # warn "GV::save GvIO(*$name)\n"; # debug
812 my $sym = objsym($av);
813 return $sym if defined $sym;
814 my $avflags = $av->AvFLAGS;
815 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
817 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
818 $xpvavsect->index, $av->REFCNT + 1, $av->FLAGS));
819 my $sv_list_index = $svsect->index;
820 my $fill = $av->FILL;
822 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
824 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
825 #if ($fill > -1 && ($avflags & AVf_REAL)) {
827 my @array = $av->ARRAY;
831 foreach $el (@array) {
832 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
833 $$av, $i++, class($el), $$el);
836 my @names = map($_->save, @array);
837 # XXX Better ways to write loop?
838 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
839 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
842 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
843 "\tav_extend(av, $fill);",
844 "\tsvp = AvARRAY(av);",
845 map("\t*svp++ = (SV*)$_;", @names),
846 "\tAvFILLp(av) = $fill;",
850 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
853 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
858 my $sym = objsym($hv);
859 return $sym if defined $sym;
860 my $name = $hv->NAME;
864 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
865 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
866 # a trashed op but we look at the trashed op_type and segfault.
867 #my $adpmroot = ${$hv->PMROOT};
869 $decl->add("static HV *hv$hv_index;");
870 # XXX Beware of weird package names containing double-quotes, \n, ...?
871 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
873 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
876 $sym = savesym($hv, "hv$hv_index");
880 # It's just an ordinary HV
881 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
882 $hv->MAX, $hv->RITER));
883 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
884 $xpvhvsect->index, $hv->REFCNT + 1, $hv->FLAGS));
885 my $sv_list_index = $svsect->index;
886 my @contents = $hv->ARRAY;
889 for ($i = 1; $i < @contents; $i += 2) {
890 $contents[$i] = $contents[$i]->save;
892 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
894 my ($key, $value) = splice(@contents, 0, 2);
895 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
896 cstring($key),length($key),$value, hash($key)));
897 # $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
898 # cstring($key),length($key),$value, 0));
903 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
908 my $sym = objsym($io);
909 return $sym if defined $sym;
911 $pv = '' unless defined $pv;
912 my $len = length($pv);
913 $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",
914 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
915 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
916 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
917 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
918 cchar($io->IoTYPE), $io->IoFLAGS));
919 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
920 $xpviosect->index, $io->REFCNT + 1, $io->FLAGS));
921 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
923 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
924 $fsym = $io->$field();
926 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
936 # This is where we catch an honest-to-goodness Nullsv (which gets
937 # blessed into B::SV explicitly) and any stray erroneous SVs.
938 return 0 unless $$sv;
939 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
944 my $init_name = shift;
946 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
947 $listopsect, $pmopsect, $svopsect, $gvopsect, $pvopsect,
948 $loopsect, $copsect, $svsect, $xpvsect,
949 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
950 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
951 $symsect->output(\*STDOUT, "#define %s\n");
953 output_declarations();
954 foreach $section (@sections) {
955 my $lines = $section->index + 1;
957 my $name = $section->name;
958 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
959 print "Static $typename ${name}_list[$lines];\n";
962 $decl->output(\*STDOUT, "%s\n");
964 foreach $section (@sections) {
965 my $lines = $section->index + 1;
967 my $name = $section->name;
968 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
969 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
970 $section->output(\*STDOUT, "\t{ %s },\n");
976 static int $init_name()
982 $init->output(\*STDOUT, "\t%s\n");
983 print "\treturn 0;\n}\n";
985 warn compile_stats();
986 warn "NULLOP count: $nullop_count\n";
990 sub output_declarations {
992 #ifdef BROKEN_STATIC_REDECL
993 #define Static extern
995 #define Static static
996 #endif /* BROKEN_STATIC_REDECL */
998 #ifdef BROKEN_UNION_INIT
1000 * Cribbed from cv.h with ANY (a union) replaced by void*.
1001 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
1004 char * xpv_pv; /* pointer to malloced string */
1005 STRLEN xpv_cur; /* length of xp_pv as a C string */
1006 STRLEN xpv_len; /* allocated size */
1007 IV xof_off; /* integer value */
1008 double xnv_nv; /* numeric value, if any */
1009 MAGIC* xmg_magic; /* magic for scalar array */
1010 HV* xmg_stash; /* class package */
1015 void (*xcv_xsub) (CV*);
1019 long xcv_depth; /* >= 2 indicates recursive call */
1023 perl_mutex *xcv_mutexp;
1024 struct perl_thread *xcv_owner; /* current owner thread */
1025 #endif /* USE_THREADS */
1028 #define ANYINIT(i) i
1030 #define XPVCV_or_similar XPVCV
1031 #define ANYINIT(i) {i}
1032 #endif /* BROKEN_UNION_INIT */
1033 #define Nullany ANYINIT(0)
1039 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1044 sub output_boilerplate {
1049 /* Workaround for mapstart: the only op which needs a different ppaddr */
1050 #undef Perl_pp_mapstart
1051 #define Perl_pp_mapstart Perl_pp_grepstart
1052 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1053 EXTERN_C void boot_DynaLoader (CV* cv);
1055 static void xs_init (void);
1056 static void dl_init (void);
1057 static PerlInterpreter *my_perl;
1064 #ifndef CAN_PROTOTYPE
1065 main(argc, argv, env)
1069 #else /* def(CAN_PROTOTYPE) */
1070 main(int argc, char **argv, char **env)
1071 #endif /* def(CAN_PROTOTYPE) */
1077 PERL_SYS_INIT(&argc,&argv);
1079 perl_init_i18nl10n(1);
1081 if (!PL_do_undump) {
1082 my_perl = perl_alloc();
1085 perl_construct( my_perl );
1090 PL_cshlen = strlen(PL_cshname);
1093 #ifdef ALLOW_PERL_OPTIONS
1094 #define EXTRA_OPTIONS 2
1096 #define EXTRA_OPTIONS 3
1097 #endif /* ALLOW_PERL_OPTIONS */
1098 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1099 fakeargv[0] = argv[0];
1102 #ifndef ALLOW_PERL_OPTIONS
1104 #endif /* ALLOW_PERL_OPTIONS */
1105 for (i = 1; i < argc; i++)
1106 fakeargv[i + EXTRA_OPTIONS] = argv[i];
1107 fakeargv[argc + EXTRA_OPTIONS] = 0;
1109 exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1114 sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1115 PL_main_cv = PL_compcv;
1118 exitstatus = perl_init();
1123 exitstatus = perl_run( my_perl );
1125 perl_destruct( my_perl );
1126 perl_free( my_perl );
1131 /* yanked from perl.c */
1135 char *file = __FILE__;
1139 print "\n#ifdef USE_DYNAMIC_LOADING";
1140 print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1141 print "\n#endif\n" ;
1142 delete $xsub{'DynaLoader'};
1143 delete $xsub{'UNIVERSAL'};
1144 print("/* bootstrapping code*/\n\tSAVETMPS;\n");
1145 print("\ttarg=sv_newmortal();\n");
1146 foreach my $stashname (keys %xsub ){
1147 if ($xsub{$stashname} ne 'Dynamic') {
1148 my $stashxsub=$stashname;
1149 $stashxsub =~ s/::/__/g;
1150 print "\tPUSHMARK(sp);\n";
1151 print qq/\tXPUSHp("$stashname",strlen("$stashname")+1);\n/;
1152 print "\tboot_$stashxsub(NULL);\n";
1155 print("\tFREETMPS;\n/* end bootstrapping code */\n");
1162 char *file = __FILE__;
1166 print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
1167 print("\ttarg=sv_newmortal();\n");
1168 foreach my $stashname (@DynaLoader::dl_modules) {
1169 warn "Loaded $stashname\n";
1170 if (exists($xsub{$stashname}) && $xsub{$stashname} eq 'Dynamic') {
1171 my $stashxsub=$stashname;
1172 $stashxsub =~ s/::/__/g;
1173 print "\tPUSHMARK(sp);\n";
1174 print qq/\tXPUSHp("$stashname",/,length($stashname)+1,qq/);\n/;
1175 print qq/\tPUTBACK;\n/;
1176 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1177 warn "bootstrapping $stashname added to xs_init\n";
1178 print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
1180 print "\tboot_$stashxsub(NULL);\n";
1182 print qq/\tSPAGAIN;\n/;
1185 print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
1191 warn "----Symbol table:\n";
1192 while (($sym, $val) = each %symtable) {
1193 warn "$sym => $val\n";
1195 warn "---End of symbol table\n";
1201 svref_2object($sv)->save;
1205 sub Dummy_BootStrap { }
1210 my $package=$gv->STASH->NAME;
1211 my $name = $gv->NAME;
1217 # We may be looking at this package just because it is a branch in the
1218 # symbol table which is on the path to a package which we need to save
1219 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1221 return unless ($unused_sub_packages{$package});
1222 return unless ($$cv || $$av || $$sv || $$hv);
1228 my $package = shift;
1229 unless ($unused_sub_packages{$package})
1232 $unused_sub_packages{$package} = 1;
1233 if (@{$package.'::ISA'})
1235 foreach my $isa (@{$package.'::ISA'})
1237 if ($isa eq 'DynaLoader')
1239 unless (defined(&{$package.'::bootstrap'}))
1241 warn "Forcing bootstrap of $package\n";
1242 eval { $package->bootstrap };
1247 unless ($unused_sub_packages{$isa})
1249 warn "$isa saved (it is in $package\'s \@ISA)\n";
1261 no strict qw(vars refs);
1262 my $package = shift;
1263 $package =~ s/::$//;
1264 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1265 # warn "Considering $package\n";#debug
1266 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1268 # If this package is a prefix to something we are saving, traverse it
1269 # but do not mark it for saving if it is not already
1270 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1272 return 1 if ($u =~ /^$package\:\:/);
1274 if (exists $unused_sub_packages{$package})
1276 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1277 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1278 return $unused_sub_packages{$package};
1280 # Omit the packages which we use (and which cause grief
1281 # because of fancy "goto &$AUTOLOAD" stuff).
1282 # XXX Surely there must be a nicer way to do this.
1283 if ($package eq "FileHandle" || $package eq "Config" ||
1284 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1286 delete_unsaved_hashINC($package);
1287 return $unused_sub_packages{$package} = 0;
1289 # Now see if current package looks like an OO class this is probably too strong.
1290 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1292 if ($package->can($m))
1294 warn "$package has method $m: saving package\n";#debug
1295 return mark_package($package);
1298 delete_unsaved_hashINC($package);
1299 return $unused_sub_packages{$package} = 0;
1301 sub delete_unsaved_hashINC{
1303 $packname =~ s/\:\:/\//g;
1305 # warn "deleting $packname" if $INC{$packname} ;# debug
1306 delete $INC{$packname};
1310 my ($symref, $recurse, $prefix) = @_;
1315 $prefix = '' unless defined $prefix;
1316 while (($sym, $ref) = each %$symref)
1321 $sym = $prefix . $sym;
1322 if ($sym ne "main::" && &$recurse($sym))
1324 walkpackages(\%glob, $recurse, $sym);
1331 sub save_unused_subs
1334 &descend_marked_unused;
1336 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1337 warn "Saving methods\n";
1338 walksymtable(\%{"main::"}, "savecv", \&should_save);
1343 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1344 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1345 my $inc_hv = svref_2object(\%INC)->save;
1346 my $inc_av = svref_2object(\@INC)->save;
1347 my $amagic_generate= amagic_generation;
1348 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1349 "GvHV(PL_incgv) = $inc_hv;",
1350 "GvAV(PL_incgv) = $inc_av;",
1351 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1352 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1353 "PL_amagic_generation= $amagic_generate;" );
1356 sub descend_marked_unused {
1357 foreach my $pack (keys %unused_sub_packages)
1359 mark_package($pack);
1364 warn "Starting compile\n";
1365 warn "Walking tree\n";
1366 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1367 walkoptree(main_root, "save");
1368 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1370 my $init_av = init_av->save;
1371 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1372 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1373 "PL_initav = (AV *) $init_av;");
1375 warn "Writing output\n";
1376 output_boilerplate();
1378 output_all("perl_init");
1384 my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1385 binop => \$binopsect, condop => \$condopsect,
1386 cop => \$copsect, gvop => \$gvopsect,
1387 listop => \$listopsect, logop => \$logopsect,
1388 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1389 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1390 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1391 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1392 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1393 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1394 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1395 xpvio => \$xpviosect);
1396 my ($name, $sectref);
1397 while (($name, $sectref) = splice(@sections, 0, 2)) {
1398 $$sectref = new B::C::Section $name, \%symtable, 0;
1404 my ($arg,$val) = @_;
1405 $unused_sub_packages{$arg} = $val;
1410 my ($option, $opt, $arg);
1412 while ($option = shift @options) {
1413 if ($option =~ /^-(.)(.*)/) {
1417 unshift @options, $option;
1420 if ($opt eq "-" && $arg eq "-") {
1425 $warn_undefined_syms = 1;
1426 } elsif ($opt eq "D") {
1427 $arg ||= shift @options;
1428 foreach $arg (split(//, $arg)) {
1431 } elsif ($arg eq "c") {
1433 } elsif ($arg eq "A") {
1435 } elsif ($arg eq "C") {
1437 } elsif ($arg eq "M") {
1440 warn "ignoring unknown debug option: $arg\n";
1443 } elsif ($opt eq "o") {
1444 $arg ||= shift @options;
1445 open(STDOUT, ">$arg") or return "$arg: $!\n";
1446 } elsif ($opt eq "v") {
1448 } elsif ($opt eq "u") {
1449 $arg ||= shift @options;
1450 mark_unused($arg,undef);
1451 } elsif ($opt eq "f") {
1452 $arg ||= shift @options;
1453 if ($arg eq "cog") {
1454 $pv_copy_on_grow = 1;
1455 } elsif ($arg eq "no-cog") {
1456 $pv_copy_on_grow = 0;
1458 } elsif ($opt eq "O") {
1459 $arg = 1 if $arg eq "";
1460 $pv_copy_on_grow = 0;
1462 # Optimisations for -O1
1463 $pv_copy_on_grow = 1;
1471 foreach $objname (@options) {
1472 eval "save_object(\\$objname)";
1477 return sub { save_main() };
1487 B::C - Perl compiler's C backend
1491 perl -MO=C[,OPTIONS] foo.pl
1495 This compiler backend takes Perl source and generates C source code
1496 corresponding to the internal structures that perl uses to run
1497 your program. When the generated C source is compiled and run, it
1498 cuts out the time which perl would have taken to load and parse
1499 your program into its internal semi-compiled form. That means that
1500 compiling with this backend will not help improve the runtime
1501 execution speed of your program but may improve the start-up time.
1502 Depending on the environment in which your program runs this may be
1503 either a help or a hindrance.
1507 If there are any non-option arguments, they are taken to be
1508 names of objects to be saved (probably doesn't work properly yet).
1509 Without extra arguments, it saves the main program.
1515 Output to filename instead of STDOUT
1519 Verbose compilation (currently gives a few compilation statistics).
1523 Force end of options
1527 Force apparently unused subs from package Packname to be compiled.
1528 This allows programs to use eval "foo()" even when sub foo is never
1529 seen to be used at compile time. The down side is that any subs which
1530 really are never used also have code generated. This option is
1531 necessary, for example, if you have a signal handler foo which you
1532 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1533 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1534 options. The compiler tries to figure out which packages may possibly
1535 have subs in which need compiling but the current version doesn't do
1536 it very well. In particular, it is confused by nested packages (i.e.
1537 of the form C<A::B>) where package C<A> does not contain any subs.
1541 Debug options (concatenated or separate flags like C<perl -D>).
1545 OPs, prints each OP as it's processed
1549 COPs, prints COPs as processed (incl. file & line num)
1553 prints AV information on saving
1557 prints CV information on saving
1561 prints MAGIC information on saving
1565 Force optimisations on or off one at a time.
1569 Copy-on-grow: PVs declared and initialised statically.
1577 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
1578 B<-O1> and higher set B<-fcog>.
1582 perl -MO=C,-ofoo.c foo.pl
1583 perl cc_harness -o foo foo.c
1585 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1586 library directory. The utility called C<perlcc> may also be used to
1587 help make use of this compiler.
1589 perl -MO=C,-v,-DcA bar.pl > /dev/null
1593 Plenty. Current status: experimental.
1597 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>