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);
60 my $handle_VC_problem = "";
61 $handle_VC_problem="{0}," if $^O eq 'MSWin32' and $Config{cc} =~ /^cl/i;
67 my $anonsub_index = 0;
68 my $initsub_index = 0;
72 my $warn_undefined_syms;
74 my %unused_sub_packages;
76 my $pv_copy_on_grow = 0;
77 my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
81 @threadsv_names = threadsv_names();
85 my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect,
86 $padopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
87 $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
88 $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
89 $xrvsect, $xpvbmsect, $xpviosect );
91 sub walk_and_save_optree;
92 my $saveoptree_callback = \&walk_and_save_optree;
93 sub set_callback { $saveoptree_callback = shift }
94 sub saveoptree { &$saveoptree_callback(@_) }
96 sub walk_and_save_optree {
97 my ($name, $root, $start) = @_;
98 walkoptree($root, "save");
99 return objsym($start);
102 # Current workaround/fix for op_free() trying to free statically
103 # defined OPs is to set op_seq = -1 and check for that in op_free().
104 # Instead of hardwiring -1 in place of $op->seq, we use $op_seq
105 # so that it can be changed back easily if necessary. In fact, to
106 # stop compilers from moaning about a U16 being initialised with an
107 # uncast -1 (the printf format is %d so we can't tweak it), we have
108 # to "know" that op_seq is a U16 and use 65535. Ugh.
111 # Look this up here so we can do just a number compare
112 # rather than looking up the name of every BASEOP in B::OP
113 my $OP_THREADSV = opnumber('threadsv');
116 my ($obj, $value) = @_;
117 my $sym = sprintf("s\\_%x", $$obj);
118 $symtable{$sym} = $value;
123 return $symtable{sprintf("s\\_%x", $$obj)};
130 return 0 if $sym eq "sym_0"; # special case
131 $value = $symtable{$sym};
132 if (defined($value)) {
135 warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
142 $pv = '' unless defined $pv; # Is this sane ?
145 if ($pv_copy_on_grow) {
146 my $cstring = cstring($pv);
147 if ($cstring ne "0") { # sic
148 $pvsym = sprintf("pv%d", $pv_index++);
149 $decl->add(sprintf("static char %s[] = %s;", $pvsym, $cstring));
152 $pvmax = length($pv) + 1;
154 return ($pvsym, $pvmax);
158 my ($op, $level) = @_;
159 my $sym = objsym($op);
160 return $sym if defined $sym;
161 my $type = $op->type;
162 $nullop_count++ unless $type;
163 if ($type == $OP_THREADSV) {
164 # saves looking up ppaddr but it's a bit naughty to hard code this
165 $init->add(sprintf("(void)find_threadsv(%s);",
166 cstring($threadsv_names[$op->targ])));
168 $opsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x",
169 ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
170 $type, $op_seq, $op->flags, $op->private));
171 savesym($op, sprintf("&op_list[%d]", $opsect->index));
175 my ($class, %objdata) = @_;
176 bless \%objdata, $class;
179 sub B::FAKEOP::save {
180 my ($op, $level) = @_;
181 $opsect->add(sprintf("%s, %s, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x",
182 $op->next, $op->sibling, $op->ppaddr, $op->targ,
183 $op->type, $op_seq, $op->flags, $op->private));
184 return sprintf("&op_list[%d]", $opsect->index);
187 sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
188 sub B::FAKEOP::type { $_[0]->{type} || 0}
189 sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
190 sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
191 sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
192 sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
193 sub B::FAKEOP::private { $_[0]->{private} || 0 }
196 my ($op, $level) = @_;
197 my $sym = objsym($op);
198 return $sym if defined $sym;
199 $unopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, s\\_%x",
200 ${$op->next}, ${$op->sibling}, $op->ppaddr,
201 $op->targ, $op->type, $op_seq, $op->flags,
202 $op->private, ${$op->first}));
203 savesym($op, sprintf("(OP*)&unop_list[%d]", $unopsect->index));
207 my ($op, $level) = @_;
208 my $sym = objsym($op);
209 return $sym if defined $sym;
210 $binopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
211 ${$op->next}, ${$op->sibling}, $op->ppaddr,
212 $op->targ, $op->type, $op_seq, $op->flags,
213 $op->private, ${$op->first}, ${$op->last}));
214 savesym($op, sprintf("(OP*)&binop_list[%d]", $binopsect->index));
217 sub B::LISTOP::save {
218 my ($op, $level) = @_;
219 my $sym = objsym($op);
220 return $sym if defined $sym;
221 $listopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u",
222 ${$op->next}, ${$op->sibling}, $op->ppaddr,
223 $op->targ, $op->type, $op_seq, $op->flags,
224 $op->private, ${$op->first}, ${$op->last},
226 savesym($op, sprintf("(OP*)&listop_list[%d]", $listopsect->index));
230 my ($op, $level) = @_;
231 my $sym = objsym($op);
232 return $sym if defined $sym;
233 $logopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
234 ${$op->next}, ${$op->sibling}, $op->ppaddr,
235 $op->targ, $op->type, $op_seq, $op->flags,
236 $op->private, ${$op->first}, ${$op->other}));
237 savesym($op, sprintf("(OP*)&logop_list[%d]", $logopsect->index));
241 my ($op, $level) = @_;
242 my $sym = objsym($op);
243 return $sym if defined $sym;
244 #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
245 # peekop($op->redoop), peekop($op->nextop),
246 # peekop($op->lastop)); # debug
247 $loopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, s\\_%x, s\\_%x, s\\_%x",
248 ${$op->next}, ${$op->sibling}, $op->ppaddr,
249 $op->targ, $op->type, $op_seq, $op->flags,
250 $op->private, ${$op->first}, ${$op->last},
251 $op->children, ${$op->redoop}, ${$op->nextop},
253 savesym($op, sprintf("(OP*)&loop_list[%d]", $loopsect->index));
257 my ($op, $level) = @_;
258 my $sym = objsym($op);
259 return $sym if defined $sym;
260 $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, $handle_VC_problem %u, %u, %u, 0x%x, 0x%x, %s",
261 ${$op->next}, ${$op->sibling}, $op->ppaddr,
262 $op->targ, $op->type, $op_seq, $op->flags,
263 $op->private, cstring($op->pv)));
264 savesym($op, sprintf("(OP*)&pvop_list[%d]", $pvopsect->index));
268 my ($op, $level) = @_;
269 my $sym = objsym($op);
270 return $sym if defined $sym;
271 my $svsym = $op->sv->save;
272 $svopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, Nullsv",
273 ${$op->next}, ${$op->sibling}, $op->ppaddr,
274 $op->targ, $op->type, $op_seq, $op->flags,
276 $init->add(sprintf("svop_list[%d].op_sv = %s;", $svopsect->index, "(SV*)$svsym"));
277 savesym($op, sprintf("(OP*)&svop_list[%d]", $svopsect->index));
281 my ($op, $level) = @_;
282 my $sym = objsym($op);
283 return $sym if defined $sym;
284 $padopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, Nullgv",
285 ${$op->next}, ${$op->sibling}, $op->ppaddr,
286 $op->targ, $op->type, $op_seq, $op->flags,
288 $init->add(sprintf("padop_list[%d].op_padix = %ld;",
289 $padopsect->index, $op->padix));
290 savesym($op, sprintf("(OP*)&padop_list[%d]", $padopsect->index));
294 my ($op, $level) = @_;
295 my $sym = objsym($op);
296 return $sym if defined $sym;
297 warn sprintf("COP: line %d file %s\n", $op->line, $op->file)
299 $copsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u",
300 ${$op->next}, ${$op->sibling}, $op->ppaddr,
301 $op->targ, $op->type, $op_seq, $op->flags,
302 $op->private, cstring($op->label), $op->cop_seq,
303 $op->arybase, $op->line));
304 my $copix = $copsect->index;
305 $init->add(sprintf("CopFILE_set(&cop_list[%d], %s);", $copix, cstring($op->file)),
306 sprintf("CopSTASHPV_set(&cop_list[%d], %s);", $copix, cstring($op->stashpv)));
307 savesym($op, "(OP*)&cop_list[$copix]");
311 my ($op, $level) = @_;
312 my $sym = objsym($op);
313 return $sym if defined $sym;
314 my $replroot = $op->pmreplroot;
315 my $replstart = $op->pmreplstart;
316 my $replrootfield = sprintf("s\\_%x", $$replroot);
317 my $replstartfield = sprintf("s\\_%x", $$replstart);
319 my $ppaddr = $op->ppaddr;
321 # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
322 # argument to a split) stores a GV in op_pmreplroot instead
323 # of a substitution syntax tree. We don't want to walk that...
324 if ($op->name eq "pushre") {
325 $gvsym = $replroot->save;
326 # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
329 $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
332 # pmnext handling is broken in perl itself, I think. Bad op_pmnext
333 # fields aren't noticed in perl's runtime (unless you try reset) but we
334 # segfault when trying to dereference it to find op->op_pmnext->op_type
335 $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, %s, %s, 0, 0, 0x%x, 0x%x",
336 ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ,
337 $op->type, $op_seq, $op->flags, $op->private,
338 ${$op->first}, ${$op->last}, $op->children,
339 $replrootfield, $replstartfield,
340 $op->pmflags, $op->pmpermflags,));
341 my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
342 my $re = $op->precomp;
344 my $resym = sprintf("re%d", $re_index++);
345 $decl->add(sprintf("static char *$resym = %s;", cstring($re)));
346 $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
350 $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
352 savesym($op, sprintf("(OP*)&pmop_list[%d]", $pmopsect->index));
355 sub B::SPECIAL::save {
357 # special case: $$sv is not the address but an index into specialsv_list
358 # warn "SPECIAL::save specialsv $$sv\n"; # debug
359 my $sym = $specialsv_name[$$sv];
360 if (!defined($sym)) {
361 confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
366 sub B::OBJECT::save {}
370 my $sym = objsym($sv);
371 return $sym if defined $sym;
372 # warn "Saving SVt_NULL SV\n"; # debug
375 # warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
377 $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS));
378 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
383 my $sym = objsym($sv);
384 return $sym if defined $sym;
385 $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
386 $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
387 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
388 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
393 my $sym = objsym($sv);
394 return $sym if defined $sym;
396 $val .= '.00' if $val =~ /^-?\d+$/;
397 $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
398 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
399 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
400 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
405 my $sym = objsym($sv);
406 return $sym if defined $sym;
408 my $len = length($pv);
409 my ($pvsym, $pvmax) = savepv($pv);
410 my ($lvtarg, $lvtarg_sym);
411 $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
412 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
413 $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
414 $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
415 $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS));
416 if (!$pv_copy_on_grow) {
417 $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);",
418 $xpvlvsect->index, cstring($pv), $len));
421 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
426 my $sym = objsym($sv);
427 return $sym if defined $sym;
429 my $len = length($pv);
430 my ($pvsym, $pvmax) = savepv($pv);
431 $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
432 $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
433 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
434 if (!$pv_copy_on_grow) {
435 $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);",
436 $xpvivsect->index, cstring($pv), $len));
438 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
443 my $sym = objsym($sv);
444 return $sym if defined $sym;
446 $pv = '' unless defined $pv;
447 my $len = length($pv);
448 my ($pvsym, $pvmax) = savepv($pv);
450 $val .= '.00' if $val =~ /^-?\d+$/;
451 $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
452 $pvsym, $len, $pvmax, $sv->IVX, $val));
453 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
454 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
455 if (!$pv_copy_on_grow) {
456 $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);",
457 $xpvnvsect->index, cstring($pv), $len));
459 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
464 my $sym = objsym($sv);
465 return $sym if defined $sym;
466 my $pv = $sv->PV . "\0" . $sv->TABLE;
467 my $len = length($pv);
468 $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
469 $len, $len + 258, $sv->IVX, $sv->NVX,
470 $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
471 $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
472 $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS));
474 $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);",
475 $xpvbmsect->index, cstring($pv), $len),
476 sprintf("xpvbm_list[%d].xpv_cur = %u;",
477 $xpvbmsect->index, $len - 257));
478 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
483 my $sym = objsym($sv);
484 return $sym if defined $sym;
486 my $len = length($pv);
487 my ($pvsym, $pvmax) = savepv($pv);
488 $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
489 $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
490 $xpvsect->index, $sv->REFCNT , $sv->FLAGS));
491 if (!$pv_copy_on_grow) {
492 $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);",
493 $xpvsect->index, cstring($pv), $len));
495 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
500 my $sym = objsym($sv);
501 return $sym if defined $sym;
503 my $len = length($pv);
504 my ($pvsym, $pvmax) = savepv($pv);
505 $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
506 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
507 $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
508 $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS));
509 if (!$pv_copy_on_grow) {
510 $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);",
511 $xpvmgsect->index, cstring($pv), $len));
513 $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
518 sub B::PVMG::save_magic {
520 #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
521 my $stash = $sv->SvSTASH;
524 warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
526 # XXX Hope stash is already going to be saved.
527 $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
529 my @mgchain = $sv->MAGIC;
530 my ($mg, $type, $obj, $ptr,$len,$ptrsv);
531 foreach $mg (@mgchain) {
537 warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
538 class($sv), $$sv, class($obj), $$obj,
539 cchar($type), cstring($ptr));
542 if ($len == HEf_SVKEY){
543 #The pointer is an SV*
544 $ptrsv=svref_2object($ptr)->save;
545 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
546 $$sv, $$obj, cchar($type),$ptrsv,$len));
548 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
549 $$sv, $$obj, cchar($type),cstring($ptr),$len));
556 my $sym = objsym($sv);
557 return $sym if defined $sym;
558 my $rv = $sv->RV->save;
559 $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/;
561 $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
562 $xrvsect->index, $sv->REFCNT , $sv->FLAGS));
563 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
567 my ($cvstashname, $cvname) = @_;
568 warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
569 # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
570 # use should be handled by the class itself.
572 my $isa = \@{"$cvstashname\::ISA"};
573 if (grep($_ eq "AutoLoader", @$isa)) {
574 warn "Forcing immediate load of sub derived from AutoLoader\n";
575 # Tweaked version of AutoLoader::AUTOLOAD
576 my $dir = $cvstashname;
578 eval { require "auto/$dir/$cvname.al" };
580 warn qq(failed require "auto/$dir/$cvname.al": $@\n);
590 my $sym = objsym($cv);
592 # warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
595 # Reserve a place in svsect and xpvcvsect and record indices
597 my ($cvname, $cvstashname);
600 $cvstashname = $gv->STASH->NAME;
602 my $root = $cv->ROOT;
603 my $cvxsub = $cv->XSUB;
604 #INIT is removed from the symbol table, so this call must come
605 # from PL_initav->save. Re-bootstrapping will push INIT back in
606 # so nullop should be sent.
607 if ($cvxsub && ($cvname ne "INIT")) {
609 my $stashname = $egv->STASH->NAME;
610 if ($cvname eq "bootstrap")
612 my $file = $gv->FILE;
613 $decl->add("/* bootstrap $file */");
614 warn "Bootstrap $stashname $file\n";
615 $xsub{$stashname}='Dynamic';
616 # $xsub{$stashname}='Static' unless $xsub{$stashname};
619 warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv;
620 return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/;
622 if ($cvxsub && $cvname eq "INIT") {
624 return svref_2object(\&Dummy_initxs)->save;
626 my $sv_ix = $svsect->index + 1;
627 $svsect->add("svix$sv_ix");
628 my $xpvcv_ix = $xpvcvsect->index + 1;
629 $xpvcvsect->add("xpvcvix$xpvcv_ix");
630 # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
631 $sym = savesym($cv, "&sv_list[$sv_ix]");
632 warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv;
633 if (!$$root && !$cvxsub) {
634 if (try_autoload($cvstashname, $cvname)) {
635 # Recalculate root and xsub
638 if ($$root || $cvxsub) {
639 warn "Successful forced autoload\n";
644 my $padlist = $cv->PADLIST;
647 my $xsubany = "Nullany";
649 warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
650 $$cv, $$root) if $debug_cv;
653 my $stashname = $gv->STASH->NAME;
654 my $gvname = $gv->NAME;
655 if ($gvname ne "__ANON__") {
656 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
657 $ppname .= ($stashname eq "main") ?
658 $gvname : "$stashname\::$gvname";
659 $ppname =~ s/::/__/g;
660 if ($gvname eq "INIT"){
661 $ppname .= "_$initsub_index";
667 $ppname = "pp_anonsub_$anonsub_index";
670 $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
671 warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
672 $$cv, $ppname, $$root) if $debug_cv;
674 warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
675 $$padlist, $$cv) if $debug_cv;
677 warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
678 $$padlist, $$cv) if $debug_cv;
682 warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
683 $cvstashname, $cvname); # debug
685 $pv = '' unless defined $pv; # Avoid use of undef warnings
686 $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, \"\", %d, s\\_%x, (CV*)s\\_%x, 0x%x",
687 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
688 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
689 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
691 if (${$cv->OUTSIDE} == ${main_cv()}){
692 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
693 $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
698 $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
699 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
700 $$gv, $$cv) if $debug_cv;
702 $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE)));
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 $init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE)));
790 # warn "GV::save GvFILE(*$name)\n"; # debug
791 my $gvform = $gv->FORM;
794 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
795 # warn "GV::save GvFORM(*$name)\n"; # debug
800 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
801 # warn "GV::save GvIO(*$name)\n"; # debug
808 my $sym = objsym($av);
809 return $sym if defined $sym;
810 my $avflags = $av->AvFLAGS;
811 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
813 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
814 $xpvavsect->index, $av->REFCNT , $av->FLAGS));
815 my $sv_list_index = $svsect->index;
816 my $fill = $av->FILL;
818 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
820 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
821 #if ($fill > -1 && ($avflags & AVf_REAL)) {
823 my @array = $av->ARRAY;
827 foreach $el (@array) {
828 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
829 $$av, $i++, class($el), $$el);
832 my @names = map($_->save, @array);
833 # XXX Better ways to write loop?
834 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
835 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
838 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
839 "\tav_extend(av, $fill);",
840 "\tsvp = AvARRAY(av);",
841 map("\t*svp++ = (SV*)$_;", @names),
842 "\tAvFILLp(av) = $fill;",
846 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
849 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
854 my $sym = objsym($hv);
855 return $sym if defined $sym;
856 my $name = $hv->NAME;
860 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
861 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
862 # a trashed op but we look at the trashed op_type and segfault.
863 #my $adpmroot = ${$hv->PMROOT};
865 $decl->add("static HV *hv$hv_index;");
866 # XXX Beware of weird package names containing double-quotes, \n, ...?
867 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
869 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
872 $sym = savesym($hv, "hv$hv_index");
876 # It's just an ordinary HV
877 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
878 $hv->MAX, $hv->RITER));
879 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
880 $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS));
881 my $sv_list_index = $svsect->index;
882 my @contents = $hv->ARRAY;
885 for ($i = 1; $i < @contents; $i += 2) {
886 $contents[$i] = $contents[$i]->save;
888 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
890 my ($key, $value) = splice(@contents, 0, 2);
891 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
892 cstring($key),length($key),$value, hash($key)));
893 # $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
894 # cstring($key),length($key),$value, 0));
899 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
904 my $sym = objsym($io);
905 return $sym if defined $sym;
907 $pv = '' unless defined $pv;
908 my $len = length($pv);
909 $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",
910 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
911 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
912 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
913 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
914 cchar($io->IoTYPE), $io->IoFLAGS));
915 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
916 $xpviosect->index, $io->REFCNT , $io->FLAGS));
917 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
919 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
920 $fsym = $io->$field();
922 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
932 # This is where we catch an honest-to-goodness Nullsv (which gets
933 # blessed into B::SV explicitly) and any stray erroneous SVs.
934 return 0 unless $$sv;
935 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
940 my $init_name = shift;
942 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
943 $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect,
944 $loopsect, $copsect, $svsect, $xpvsect,
945 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
946 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
947 $symsect->output(\*STDOUT, "#define %s\n");
949 output_declarations();
950 foreach $section (@sections) {
951 my $lines = $section->index + 1;
953 my $name = $section->name;
954 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
955 print "Static $typename ${name}_list[$lines];\n";
958 $decl->output(\*STDOUT, "%s\n");
960 foreach $section (@sections) {
961 my $lines = $section->index + 1;
963 my $name = $section->name;
964 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
965 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
966 $section->output(\*STDOUT, "\t{ %s },\n");
972 static int $init_name()
978 $init->output(\*STDOUT, "\t%s\n");
979 print "\treturn 0;\n}\n";
981 warn compile_stats();
982 warn "NULLOP count: $nullop_count\n";
986 sub output_declarations {
988 #ifdef BROKEN_STATIC_REDECL
989 #define Static extern
991 #define Static static
992 #endif /* BROKEN_STATIC_REDECL */
994 #ifdef BROKEN_UNION_INIT
996 * Cribbed from cv.h with ANY (a union) replaced by void*.
997 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
1000 char * xpv_pv; /* pointer to malloced string */
1001 STRLEN xpv_cur; /* length of xp_pv as a C string */
1002 STRLEN xpv_len; /* allocated size */
1003 IV xof_off; /* integer value */
1004 double xnv_nv; /* numeric value, if any */
1005 MAGIC* xmg_magic; /* magic for scalar array */
1006 HV* xmg_stash; /* class package */
1011 void (*xcv_xsub) (CV*);
1015 long xcv_depth; /* >= 2 indicates recursive call */
1019 perl_mutex *xcv_mutexp;
1020 struct perl_thread *xcv_owner; /* current owner thread */
1021 #endif /* USE_THREADS */
1024 #define ANYINIT(i) i
1026 #define XPVCV_or_similar XPVCV
1027 #define ANYINIT(i) {i}
1028 #endif /* BROKEN_UNION_INIT */
1029 #define Nullany ANYINIT(0)
1035 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1040 sub output_boilerplate {
1045 /* Workaround for mapstart: the only op which needs a different ppaddr */
1046 #undef Perl_pp_mapstart
1047 #define Perl_pp_mapstart Perl_pp_grepstart
1048 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1049 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
1051 static void xs_init (pTHX);
1052 static void dl_init (pTHX);
1053 static PerlInterpreter *my_perl;
1060 main(int argc, char **argv, char **env)
1066 PERL_SYS_INIT3(&argc,&argv,&env);
1068 if (!PL_do_undump) {
1069 my_perl = perl_alloc();
1072 perl_construct( my_perl );
1073 PL_perl_destruct_level = 0;
1078 PL_cshlen = strlen(PL_cshname);
1081 #ifdef ALLOW_PERL_OPTIONS
1082 #define EXTRA_OPTIONS 2
1084 #define EXTRA_OPTIONS 3
1085 #endif /* ALLOW_PERL_OPTIONS */
1086 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1087 fakeargv[0] = argv[0];
1090 #ifndef ALLOW_PERL_OPTIONS
1092 #endif /* ALLOW_PERL_OPTIONS */
1093 for (i = 1; i < argc; i++)
1094 fakeargv[i + EXTRA_OPTIONS] = argv[i];
1095 fakeargv[argc + EXTRA_OPTIONS] = 0;
1097 exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1102 sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1103 PL_main_cv = PL_compcv;
1106 exitstatus = perl_init();
1111 exitstatus = perl_run( my_perl );
1113 perl_destruct( my_perl );
1114 perl_free( my_perl );
1121 /* yanked from perl.c */
1125 char *file = __FILE__;
1129 print "\n#ifdef USE_DYNAMIC_LOADING";
1130 print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1131 print "\n#endif\n" ;
1132 # delete $xsub{'DynaLoader'};
1133 delete $xsub{'UNIVERSAL'};
1134 print("/* bootstrapping code*/\n\tSAVETMPS;\n");
1135 print("\ttarg=sv_newmortal();\n");
1136 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1137 print "\tPUSHMARK(sp);\n";
1138 print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
1139 print qq/\tPUTBACK;\n/;
1140 print "\tboot_DynaLoader(aTHX_ NULL);\n";
1141 print qq/\tSPAGAIN;\n/;
1143 foreach my $stashname (keys %xsub){
1144 if ($xsub{$stashname} ne 'Dynamic') {
1145 my $stashxsub=$stashname;
1146 $stashxsub =~ s/::/__/g;
1147 print "\tPUSHMARK(sp);\n";
1148 print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
1149 print qq/\tPUTBACK;\n/;
1150 print "\tboot_$stashxsub(aTHX_ NULL);\n";
1151 print qq/\tSPAGAIN;\n/;
1154 print("\tFREETMPS;\n/* end bootstrapping code */\n");
1161 char *file = __FILE__;
1165 print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
1166 print("\ttarg=sv_newmortal();\n");
1167 foreach my $stashname (@DynaLoader::dl_modules) {
1168 warn "Loaded $stashname\n";
1169 if (exists($xsub{$stashname}) && $xsub{$stashname} eq 'Dynamic') {
1170 my $stashxsub=$stashname;
1171 $stashxsub =~ s/::/__/g;
1172 print "\tPUSHMARK(sp);\n";
1173 print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
1174 print qq/\tPUTBACK;\n/;
1175 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1176 warn "bootstrapping $stashname added to xs_init\n";
1177 print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
1179 print "\tboot_$stashxsub(aTHX_ NULL);\n";
1181 print qq/\tSPAGAIN;\n/;
1184 print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
1190 warn "----Symbol table:\n";
1191 while (($sym, $val) = each %symtable) {
1192 warn "$sym => $val\n";
1194 warn "---End of symbol table\n";
1200 svref_2object($sv)->save;
1204 sub Dummy_BootStrap { }
1209 my $package=$gv->STASH->NAME;
1210 my $name = $gv->NAME;
1216 # We may be looking at this package just because it is a branch in the
1217 # symbol table which is on the path to a package which we need to save
1218 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1220 return unless ($unused_sub_packages{$package});
1221 return unless ($$cv || $$av || $$sv || $$hv);
1227 my $package = shift;
1228 unless ($unused_sub_packages{$package})
1231 $unused_sub_packages{$package} = 1;
1232 if (defined @{$package.'::ISA'})
1234 foreach my $isa (@{$package.'::ISA'})
1236 if ($isa eq 'DynaLoader')
1238 unless (defined(&{$package.'::bootstrap'}))
1240 warn "Forcing bootstrap of $package\n";
1241 eval { $package->bootstrap };
1246 unless ($unused_sub_packages{$isa})
1248 warn "$isa saved (it is in $package\'s \@ISA)\n";
1260 no strict qw(vars refs);
1261 my $package = shift;
1262 $package =~ s/::$//;
1263 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1264 # warn "Considering $package\n";#debug
1265 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1267 # If this package is a prefix to something we are saving, traverse it
1268 # but do not mark it for saving if it is not already
1269 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1271 return 1 if ($u =~ /^$package\:\:/);
1273 if (exists $unused_sub_packages{$package})
1275 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1276 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1277 return $unused_sub_packages{$package};
1279 # Omit the packages which we use (and which cause grief
1280 # because of fancy "goto &$AUTOLOAD" stuff).
1281 # XXX Surely there must be a nicer way to do this.
1282 if ($package eq "FileHandle" || $package eq "Config" ||
1283 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1285 delete_unsaved_hashINC($package);
1286 return $unused_sub_packages{$package} = 0;
1288 # Now see if current package looks like an OO class this is probably too strong.
1289 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1291 if ($package->can($m))
1293 warn "$package has method $m: saving package\n";#debug
1294 return mark_package($package);
1297 delete_unsaved_hashINC($package);
1298 return $unused_sub_packages{$package} = 0;
1300 sub delete_unsaved_hashINC{
1302 $packname =~ s/\:\:/\//g;
1304 # warn "deleting $packname" if $INC{$packname} ;# debug
1305 delete $INC{$packname};
1309 my ($symref, $recurse, $prefix) = @_;
1314 $prefix = '' unless defined $prefix;
1315 while (($sym, $ref) = each %$symref)
1320 $sym = $prefix . $sym;
1321 if ($sym ne "main::" && &$recurse($sym))
1323 walkpackages(\%glob, $recurse, $sym);
1330 sub save_unused_subs
1333 &descend_marked_unused;
1335 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1336 warn "Saving methods\n";
1337 walksymtable(\%{"main::"}, "savecv", \&should_save);
1342 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1343 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1344 my $inc_hv = svref_2object(\%INC)->save;
1345 my $inc_av = svref_2object(\@INC)->save;
1346 my $amagic_generate= amagic_generation;
1347 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1348 "GvHV(PL_incgv) = $inc_hv;",
1349 "GvAV(PL_incgv) = $inc_av;",
1350 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1351 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1352 "PL_amagic_generation= $amagic_generate;" );
1355 sub descend_marked_unused {
1356 foreach my $pack (keys %unused_sub_packages)
1358 mark_package($pack);
1363 warn "Starting compile\n";
1364 warn "Walking tree\n";
1365 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1366 walkoptree(main_root, "save");
1367 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1369 my $init_av = init_av->save;
1370 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1371 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1372 "PL_initav = (AV *) $init_av;");
1374 warn "Writing output\n";
1375 output_boilerplate();
1377 output_all("perl_init");
1383 my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1384 binop => \$binopsect, condop => \$condopsect,
1385 cop => \$copsect, padop => \$padopsect,
1386 listop => \$listopsect, logop => \$logopsect,
1387 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1388 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1389 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1390 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1391 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1392 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1393 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1394 xpvio => \$xpviosect);
1395 my ($name, $sectref);
1396 while (($name, $sectref) = splice(@sections, 0, 2)) {
1397 $$sectref = new B::C::Section $name, \%symtable, 0;
1403 my ($arg,$val) = @_;
1404 $unused_sub_packages{$arg} = $val;
1409 my ($option, $opt, $arg);
1411 while ($option = shift @options) {
1412 if ($option =~ /^-(.)(.*)/) {
1416 unshift @options, $option;
1419 if ($opt eq "-" && $arg eq "-") {
1424 $warn_undefined_syms = 1;
1425 } elsif ($opt eq "D") {
1426 $arg ||= shift @options;
1427 foreach $arg (split(//, $arg)) {
1430 } elsif ($arg eq "c") {
1432 } elsif ($arg eq "A") {
1434 } elsif ($arg eq "C") {
1436 } elsif ($arg eq "M") {
1439 warn "ignoring unknown debug option: $arg\n";
1442 } elsif ($opt eq "o") {
1443 $arg ||= shift @options;
1444 open(STDOUT, ">$arg") or return "$arg: $!\n";
1445 } elsif ($opt eq "v") {
1447 } elsif ($opt eq "u") {
1448 $arg ||= shift @options;
1449 mark_unused($arg,undef);
1450 } elsif ($opt eq "f") {
1451 $arg ||= shift @options;
1452 if ($arg eq "cog") {
1453 $pv_copy_on_grow = 1;
1454 } elsif ($arg eq "no-cog") {
1455 $pv_copy_on_grow = 0;
1457 } elsif ($opt eq "O") {
1458 $arg = 1 if $arg eq "";
1459 $pv_copy_on_grow = 0;
1461 # Optimisations for -O1
1462 $pv_copy_on_grow = 1;
1470 foreach $objname (@options) {
1471 eval "save_object(\\$objname)";
1476 return sub { save_main() };
1486 B::C - Perl compiler's C backend
1490 perl -MO=C[,OPTIONS] foo.pl
1494 This compiler backend takes Perl source and generates C source code
1495 corresponding to the internal structures that perl uses to run
1496 your program. When the generated C source is compiled and run, it
1497 cuts out the time which perl would have taken to load and parse
1498 your program into its internal semi-compiled form. That means that
1499 compiling with this backend will not help improve the runtime
1500 execution speed of your program but may improve the start-up time.
1501 Depending on the environment in which your program runs this may be
1502 either a help or a hindrance.
1506 If there are any non-option arguments, they are taken to be
1507 names of objects to be saved (probably doesn't work properly yet).
1508 Without extra arguments, it saves the main program.
1514 Output to filename instead of STDOUT
1518 Verbose compilation (currently gives a few compilation statistics).
1522 Force end of options
1526 Force apparently unused subs from package Packname to be compiled.
1527 This allows programs to use eval "foo()" even when sub foo is never
1528 seen to be used at compile time. The down side is that any subs which
1529 really are never used also have code generated. This option is
1530 necessary, for example, if you have a signal handler foo which you
1531 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1532 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1533 options. The compiler tries to figure out which packages may possibly
1534 have subs in which need compiling but the current version doesn't do
1535 it very well. In particular, it is confused by nested packages (i.e.
1536 of the form C<A::B>) where package C<A> does not contain any subs.
1540 Debug options (concatenated or separate flags like C<perl -D>).
1544 OPs, prints each OP as it's processed
1548 COPs, prints COPs as processed (incl. file & line num)
1552 prints AV information on saving
1556 prints CV information on saving
1560 prints MAGIC information on saving
1564 Force optimisations on or off one at a time.
1568 Copy-on-grow: PVs declared and initialised statically.
1576 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
1577 B<-O1> and higher set B<-fcog>.
1581 perl -MO=C,-ofoo.c foo.pl
1582 perl cc_harness -o foo foo.c
1584 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1585 library directory. The utility called C<perlcc> may also be used to
1586 help make use of this compiler.
1588 perl -MO=C,-v,-DcA bar.pl > /dev/null
1592 Plenty. Current status: experimental.
1596 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>