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, %s",
273 ${$op->next}, ${$op->sibling}, $op->ppaddr,
274 $op->targ, $op->type, $op_seq, $op->flags,
275 $op->private, "(SV*)$svsym"));
276 savesym($op, sprintf("(OP*)&svop_list[%d]", $svopsect->index));
280 my ($op, $level) = @_;
281 my $sym = objsym($op);
282 return $sym if defined $sym;
283 $padopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, Nullgv",
284 ${$op->next}, ${$op->sibling}, $op->ppaddr,
285 $op->targ, $op->type, $op_seq, $op->flags,
287 $init->add(sprintf("padop_list[%d].op_padix = %ld;",
288 $padopsect->index, $op->padix));
289 savesym($op, sprintf("(OP*)&padop_list[%d]", $padopsect->index));
293 my ($op, $level) = @_;
294 my $sym = objsym($op);
295 return $sym if defined $sym;
296 my $gvsym = $op->filegv->save;
297 my $stashsym = $op->stash->save;
298 warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV)
300 $copsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u",
301 ${$op->next}, ${$op->sibling}, $op->ppaddr,
302 $op->targ, $op->type, $op_seq, $op->flags,
303 $op->private, cstring($op->label), $op->cop_seq,
304 $op->arybase, $op->line));
305 my $copix = $copsect->index;
306 $init->add(sprintf("cop_list[%d].cop_filegv = %s;", $copix, $gvsym),
307 sprintf("cop_list[%d].cop_stash = %s;", $copix, $stashsym));
308 savesym($op, "(OP*)&cop_list[$copix]");
312 my ($op, $level) = @_;
313 my $sym = objsym($op);
314 return $sym if defined $sym;
315 my $replroot = $op->pmreplroot;
316 my $replstart = $op->pmreplstart;
317 my $replrootfield = sprintf("s\\_%x", $$replroot);
318 my $replstartfield = sprintf("s\\_%x", $$replstart);
320 my $ppaddr = $op->ppaddr;
322 # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
323 # argument to a split) stores a GV in op_pmreplroot instead
324 # of a substitution syntax tree. We don't want to walk that...
325 if ($op->name eq "pushre") {
326 $gvsym = $replroot->save;
327 # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
330 $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
333 # pmnext handling is broken in perl itself, I think. Bad op_pmnext
334 # fields aren't noticed in perl's runtime (unless you try reset) but we
335 # segfault when trying to dereference it to find op->op_pmnext->op_type
336 $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",
337 ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ,
338 $op->type, $op_seq, $op->flags, $op->private,
339 ${$op->first}, ${$op->last}, $op->children,
340 $replrootfield, $replstartfield,
341 $op->pmflags, $op->pmpermflags,));
342 my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
343 my $re = $op->precomp;
345 my $resym = sprintf("re%d", $re_index++);
346 $decl->add(sprintf("static char *$resym = %s;", cstring($re)));
347 $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
351 $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
353 savesym($op, sprintf("(OP*)&pmop_list[%d]", $pmopsect->index));
356 sub B::SPECIAL::save {
358 # special case: $$sv is not the address but an index into specialsv_list
359 # warn "SPECIAL::save specialsv $$sv\n"; # debug
360 my $sym = $specialsv_name[$$sv];
361 if (!defined($sym)) {
362 confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
367 sub B::OBJECT::save {}
371 my $sym = objsym($sv);
372 return $sym if defined $sym;
373 # warn "Saving SVt_NULL SV\n"; # debug
376 # warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
378 $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS));
379 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
384 my $sym = objsym($sv);
385 return $sym if defined $sym;
386 $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
387 $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
388 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
389 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
394 my $sym = objsym($sv);
395 return $sym if defined $sym;
397 $val .= '.00' if $val =~ /^-?\d+$/;
398 $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
399 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
400 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
401 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
406 my $sym = objsym($sv);
407 return $sym if defined $sym;
409 my $len = length($pv);
410 my ($pvsym, $pvmax) = savepv($pv);
411 my ($lvtarg, $lvtarg_sym);
412 $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
413 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
414 $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
415 $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
416 $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS));
417 if (!$pv_copy_on_grow) {
418 $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);",
419 $xpvlvsect->index, cstring($pv), $len));
422 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
427 my $sym = objsym($sv);
428 return $sym if defined $sym;
430 my $len = length($pv);
431 my ($pvsym, $pvmax) = savepv($pv);
432 $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
433 $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
434 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
435 if (!$pv_copy_on_grow) {
436 $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);",
437 $xpvivsect->index, cstring($pv), $len));
439 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
444 my $sym = objsym($sv);
445 return $sym if defined $sym;
447 $pv = '' unless defined $pv;
448 my $len = length($pv);
449 my ($pvsym, $pvmax) = savepv($pv);
451 $val .= '.00' if $val =~ /^-?\d+$/;
452 $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
453 $pvsym, $len, $pvmax, $sv->IVX, $val));
454 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
455 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
456 if (!$pv_copy_on_grow) {
457 $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);",
458 $xpvnvsect->index, cstring($pv), $len));
460 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
465 my $sym = objsym($sv);
466 return $sym if defined $sym;
467 my $pv = $sv->PV . "\0" . $sv->TABLE;
468 my $len = length($pv);
469 $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
470 $len, $len + 258, $sv->IVX, $sv->NVX,
471 $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
472 $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
473 $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS));
475 $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);",
476 $xpvbmsect->index, cstring($pv), $len),
477 sprintf("xpvbm_list[%d].xpv_cur = %u;",
478 $xpvbmsect->index, $len - 257));
479 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
484 my $sym = objsym($sv);
485 return $sym if defined $sym;
487 my $len = length($pv);
488 my ($pvsym, $pvmax) = savepv($pv);
489 $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
490 $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
491 $xpvsect->index, $sv->REFCNT , $sv->FLAGS));
492 if (!$pv_copy_on_grow) {
493 $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);",
494 $xpvsect->index, cstring($pv), $len));
496 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
501 my $sym = objsym($sv);
502 return $sym if defined $sym;
504 my $len = length($pv);
505 my ($pvsym, $pvmax) = savepv($pv);
506 $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
507 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
508 $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
509 $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS));
510 if (!$pv_copy_on_grow) {
511 $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);",
512 $xpvmgsect->index, cstring($pv), $len));
514 $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
519 sub B::PVMG::save_magic {
521 #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
522 my $stash = $sv->SvSTASH;
525 warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
527 # XXX Hope stash is already going to be saved.
528 $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
530 my @mgchain = $sv->MAGIC;
531 my ($mg, $type, $obj, $ptr,$len,$ptrsv);
532 foreach $mg (@mgchain) {
538 warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
539 class($sv), $$sv, class($obj), $$obj,
540 cchar($type), cstring($ptr));
543 if ($len == HEf_SVKEY){
544 #The pointer is an SV*
545 $ptrsv=svref_2object($ptr)->save;
546 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
547 $$sv, $$obj, cchar($type),$ptrsv,$len));
549 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
550 $$sv, $$obj, cchar($type),cstring($ptr),$len));
557 my $sym = objsym($sv);
558 return $sym if defined $sym;
559 my $rv = $sv->RV->save;
560 $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/;
562 $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
563 $xrvsect->index, $sv->REFCNT , $sv->FLAGS));
564 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
568 my ($cvstashname, $cvname) = @_;
569 warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
570 # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
571 # use should be handled by the class itself.
573 my $isa = \@{"$cvstashname\::ISA"};
574 if (grep($_ eq "AutoLoader", @$isa)) {
575 warn "Forcing immediate load of sub derived from AutoLoader\n";
576 # Tweaked version of AutoLoader::AUTOLOAD
577 my $dir = $cvstashname;
579 eval { require "auto/$dir/$cvname.al" };
581 warn qq(failed require "auto/$dir/$cvname.al": $@\n);
591 my $sym = objsym($cv);
593 # warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
596 # Reserve a place in svsect and xpvcvsect and record indices
598 my ($cvname, $cvstashname);
601 $cvstashname = $gv->STASH->NAME;
603 my $root = $cv->ROOT;
604 my $cvxsub = $cv->XSUB;
605 #INIT is removed from the symbol table, so this call must come
606 # from PL_initav->save. Re-bootstrapping will push INIT back in
607 # so nullop should be sent.
608 if ($cvxsub && ($cvname ne "INIT")) {
610 my $stashname = $egv->STASH->NAME;
611 if ($cvname eq "bootstrap")
613 my $file = $gv->FILE;
614 $decl->add("/* bootstrap $file */");
615 warn "Bootstrap $stashname $file\n";
616 $xsub{$stashname}='Dynamic';
617 # $xsub{$stashname}='Static' unless $xsub{$stashname};
620 warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv;
621 return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/;
623 if ($cvxsub && $cvname eq "INIT") {
625 return svref_2object(\&Dummy_initxs)->save;
627 my $sv_ix = $svsect->index + 1;
628 $svsect->add("svix$sv_ix");
629 my $xpvcv_ix = $xpvcvsect->index + 1;
630 $xpvcvsect->add("xpvcvix$xpvcv_ix");
631 # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
632 $sym = savesym($cv, "&sv_list[$sv_ix]");
633 warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv;
634 if (!$$root && !$cvxsub) {
635 if (try_autoload($cvstashname, $cvname)) {
636 # Recalculate root and xsub
639 if ($$root || $cvxsub) {
640 warn "Successful forced autoload\n";
645 my $padlist = $cv->PADLIST;
648 my $xsubany = "Nullany";
650 warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
651 $$cv, $$root) if $debug_cv;
654 my $stashname = $gv->STASH->NAME;
655 my $gvname = $gv->NAME;
656 if ($gvname ne "__ANON__") {
657 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
658 $ppname .= ($stashname eq "main") ?
659 $gvname : "$stashname\::$gvname";
660 $ppname =~ s/::/__/g;
661 if ($gvname eq "INIT"){
662 $ppname .= "_$initsub_index";
668 $ppname = "pp_anonsub_$anonsub_index";
671 $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
672 warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
673 $$cv, $ppname, $$root) if $debug_cv;
675 warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
676 $$padlist, $$cv) if $debug_cv;
678 warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
679 $$padlist, $$cv) if $debug_cv;
683 warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
684 $cvstashname, $cvname); # debug
686 $pv = '' unless defined $pv; # Avoid use of undef warnings
687 $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",
688 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
689 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
690 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
692 if (${$cv->OUTSIDE} == ${main_cv()}){
693 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
694 $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
699 $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
700 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
701 $$gv, $$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 $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*);
1014 #if defined(PERL_BINCOMPAT_5005)
1015 GV * xcv_filegv; /* XXX unused (and deprecated) */
1017 long xcv_depth; /* >= 2 indicates recursive call */
1021 perl_mutex *xcv_mutexp;
1022 struct perl_thread *xcv_owner; /* current owner thread */
1023 #endif /* USE_THREADS */
1026 #define ANYINIT(i) i
1028 #define XPVCV_or_similar XPVCV
1029 #define ANYINIT(i) {i}
1030 #endif /* BROKEN_UNION_INIT */
1031 #define Nullany ANYINIT(0)
1037 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1042 sub output_boilerplate {
1047 /* Workaround for mapstart: the only op which needs a different ppaddr */
1048 #undef Perl_pp_mapstart
1049 #define Perl_pp_mapstart Perl_pp_grepstart
1050 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1051 EXTERN_C void boot_DynaLoader (CV* cv);
1053 static void xs_init (void);
1054 static void dl_init (void);
1055 static PerlInterpreter *my_perl;
1062 #ifndef CAN_PROTOTYPE
1063 main(argc, argv, env)
1067 #else /* def(CAN_PROTOTYPE) */
1068 main(int argc, char **argv, char **env)
1069 #endif /* def(CAN_PROTOTYPE) */
1075 PERL_SYS_INIT(&argc,&argv);
1077 perl_init_i18nl10n(1);
1079 if (!PL_do_undump) {
1080 my_perl = perl_alloc();
1083 perl_construct( my_perl );
1088 PL_cshlen = strlen(PL_cshname);
1091 #ifdef ALLOW_PERL_OPTIONS
1092 #define EXTRA_OPTIONS 2
1094 #define EXTRA_OPTIONS 3
1095 #endif /* ALLOW_PERL_OPTIONS */
1096 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1097 fakeargv[0] = argv[0];
1100 #ifndef ALLOW_PERL_OPTIONS
1102 #endif /* ALLOW_PERL_OPTIONS */
1103 for (i = 1; i < argc; i++)
1104 fakeargv[i + EXTRA_OPTIONS] = argv[i];
1105 fakeargv[argc + EXTRA_OPTIONS] = 0;
1107 exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1112 sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1113 PL_main_cv = PL_compcv;
1116 exitstatus = perl_init();
1121 exitstatus = perl_run( my_perl );
1123 perl_destruct( my_perl );
1124 perl_free( my_perl );
1129 /* yanked from perl.c */
1133 char *file = __FILE__;
1137 print "\n#ifdef USE_DYNAMIC_LOADING";
1138 print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1139 print "\n#endif\n" ;
1140 # delete $xsub{'DynaLoader'};
1141 delete $xsub{'UNIVERSAL'};
1142 print("/* bootstrapping code*/\n\tSAVETMPS;\n");
1143 print("\ttarg=sv_newmortal();\n");
1144 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1145 print "\tPUSHMARK(sp);\n";
1146 print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
1147 print qq/\tPUTBACK;\n/;
1148 print "\tboot_DynaLoader(NULL);\n";
1149 print qq/\tSPAGAIN;\n/;
1151 foreach my $stashname (keys %xsub){
1152 if ($xsub{$stashname} ne 'Dynamic') {
1153 my $stashxsub=$stashname;
1154 $stashxsub =~ s/::/__/g;
1155 print "\tPUSHMARK(sp);\n";
1156 print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
1157 print qq/\tPUTBACK;\n/;
1158 print "\tboot_$stashxsub(NULL);\n";
1159 print qq/\tSPAGAIN;\n/;
1162 print("\tFREETMPS;\n/* end bootstrapping code */\n");
1169 char *file = __FILE__;
1173 print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
1174 print("\ttarg=sv_newmortal();\n");
1175 foreach my $stashname (@DynaLoader::dl_modules) {
1176 warn "Loaded $stashname\n";
1177 if (exists($xsub{$stashname}) && $xsub{$stashname} eq 'Dynamic') {
1178 my $stashxsub=$stashname;
1179 $stashxsub =~ s/::/__/g;
1180 print "\tPUSHMARK(sp);\n";
1181 print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
1182 print qq/\tPUTBACK;\n/;
1183 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1184 warn "bootstrapping $stashname added to xs_init\n";
1185 print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
1187 print "\tboot_$stashxsub(NULL);\n";
1189 print qq/\tSPAGAIN;\n/;
1192 print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
1198 warn "----Symbol table:\n";
1199 while (($sym, $val) = each %symtable) {
1200 warn "$sym => $val\n";
1202 warn "---End of symbol table\n";
1208 svref_2object($sv)->save;
1212 sub Dummy_BootStrap { }
1217 my $package=$gv->STASH->NAME;
1218 my $name = $gv->NAME;
1224 # We may be looking at this package just because it is a branch in the
1225 # symbol table which is on the path to a package which we need to save
1226 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1228 return unless ($unused_sub_packages{$package});
1229 return unless ($$cv || $$av || $$sv || $$hv);
1235 my $package = shift;
1236 unless ($unused_sub_packages{$package})
1239 $unused_sub_packages{$package} = 1;
1240 if (defined @{$package.'::ISA'})
1242 foreach my $isa (@{$package.'::ISA'})
1244 if ($isa eq 'DynaLoader')
1246 unless (defined(&{$package.'::bootstrap'}))
1248 warn "Forcing bootstrap of $package\n";
1249 eval { $package->bootstrap };
1254 unless ($unused_sub_packages{$isa})
1256 warn "$isa saved (it is in $package\'s \@ISA)\n";
1268 no strict qw(vars refs);
1269 my $package = shift;
1270 $package =~ s/::$//;
1271 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1272 # warn "Considering $package\n";#debug
1273 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1275 # If this package is a prefix to something we are saving, traverse it
1276 # but do not mark it for saving if it is not already
1277 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1279 return 1 if ($u =~ /^$package\:\:/);
1281 if (exists $unused_sub_packages{$package})
1283 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1284 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1285 return $unused_sub_packages{$package};
1287 # Omit the packages which we use (and which cause grief
1288 # because of fancy "goto &$AUTOLOAD" stuff).
1289 # XXX Surely there must be a nicer way to do this.
1290 if ($package eq "FileHandle" || $package eq "Config" ||
1291 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1293 delete_unsaved_hashINC($package);
1294 return $unused_sub_packages{$package} = 0;
1296 # Now see if current package looks like an OO class this is probably too strong.
1297 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1299 if ($package->can($m))
1301 warn "$package has method $m: saving package\n";#debug
1302 return mark_package($package);
1305 delete_unsaved_hashINC($package);
1306 return $unused_sub_packages{$package} = 0;
1308 sub delete_unsaved_hashINC{
1310 $packname =~ s/\:\:/\//g;
1312 # warn "deleting $packname" if $INC{$packname} ;# debug
1313 delete $INC{$packname};
1317 my ($symref, $recurse, $prefix) = @_;
1322 $prefix = '' unless defined $prefix;
1323 while (($sym, $ref) = each %$symref)
1328 $sym = $prefix . $sym;
1329 if ($sym ne "main::" && &$recurse($sym))
1331 walkpackages(\%glob, $recurse, $sym);
1338 sub save_unused_subs
1341 &descend_marked_unused;
1343 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1344 warn "Saving methods\n";
1345 walksymtable(\%{"main::"}, "savecv", \&should_save);
1350 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1351 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1352 my $inc_hv = svref_2object(\%INC)->save;
1353 my $inc_av = svref_2object(\@INC)->save;
1354 my $amagic_generate= amagic_generation;
1355 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1356 "GvHV(PL_incgv) = $inc_hv;",
1357 "GvAV(PL_incgv) = $inc_av;",
1358 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1359 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1360 "PL_amagic_generation= $amagic_generate;" );
1363 sub descend_marked_unused {
1364 foreach my $pack (keys %unused_sub_packages)
1366 mark_package($pack);
1371 warn "Starting compile\n";
1372 warn "Walking tree\n";
1373 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1374 walkoptree(main_root, "save");
1375 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1377 my $init_av = init_av->save;
1378 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1379 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1380 "PL_initav = (AV *) $init_av;");
1382 warn "Writing output\n";
1383 output_boilerplate();
1385 output_all("perl_init");
1391 my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1392 binop => \$binopsect, condop => \$condopsect,
1393 cop => \$copsect, padop => \$padopsect,
1394 listop => \$listopsect, logop => \$logopsect,
1395 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1396 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1397 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1398 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1399 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1400 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1401 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1402 xpvio => \$xpviosect);
1403 my ($name, $sectref);
1404 while (($name, $sectref) = splice(@sections, 0, 2)) {
1405 $$sectref = new B::C::Section $name, \%symtable, 0;
1411 my ($arg,$val) = @_;
1412 $unused_sub_packages{$arg} = $val;
1417 my ($option, $opt, $arg);
1419 while ($option = shift @options) {
1420 if ($option =~ /^-(.)(.*)/) {
1424 unshift @options, $option;
1427 if ($opt eq "-" && $arg eq "-") {
1432 $warn_undefined_syms = 1;
1433 } elsif ($opt eq "D") {
1434 $arg ||= shift @options;
1435 foreach $arg (split(//, $arg)) {
1438 } elsif ($arg eq "c") {
1440 } elsif ($arg eq "A") {
1442 } elsif ($arg eq "C") {
1444 } elsif ($arg eq "M") {
1447 warn "ignoring unknown debug option: $arg\n";
1450 } elsif ($opt eq "o") {
1451 $arg ||= shift @options;
1452 open(STDOUT, ">$arg") or return "$arg: $!\n";
1453 } elsif ($opt eq "v") {
1455 } elsif ($opt eq "u") {
1456 $arg ||= shift @options;
1457 mark_unused($arg,undef);
1458 } elsif ($opt eq "f") {
1459 $arg ||= shift @options;
1460 if ($arg eq "cog") {
1461 $pv_copy_on_grow = 1;
1462 } elsif ($arg eq "no-cog") {
1463 $pv_copy_on_grow = 0;
1465 } elsif ($opt eq "O") {
1466 $arg = 1 if $arg eq "";
1467 $pv_copy_on_grow = 0;
1469 # Optimisations for -O1
1470 $pv_copy_on_grow = 1;
1478 foreach $objname (@options) {
1479 eval "save_object(\\$objname)";
1484 return sub { save_main() };
1494 B::C - Perl compiler's C backend
1498 perl -MO=C[,OPTIONS] foo.pl
1502 This compiler backend takes Perl source and generates C source code
1503 corresponding to the internal structures that perl uses to run
1504 your program. When the generated C source is compiled and run, it
1505 cuts out the time which perl would have taken to load and parse
1506 your program into its internal semi-compiled form. That means that
1507 compiling with this backend will not help improve the runtime
1508 execution speed of your program but may improve the start-up time.
1509 Depending on the environment in which your program runs this may be
1510 either a help or a hindrance.
1514 If there are any non-option arguments, they are taken to be
1515 names of objects to be saved (probably doesn't work properly yet).
1516 Without extra arguments, it saves the main program.
1522 Output to filename instead of STDOUT
1526 Verbose compilation (currently gives a few compilation statistics).
1530 Force end of options
1534 Force apparently unused subs from package Packname to be compiled.
1535 This allows programs to use eval "foo()" even when sub foo is never
1536 seen to be used at compile time. The down side is that any subs which
1537 really are never used also have code generated. This option is
1538 necessary, for example, if you have a signal handler foo which you
1539 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1540 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1541 options. The compiler tries to figure out which packages may possibly
1542 have subs in which need compiling but the current version doesn't do
1543 it very well. In particular, it is confused by nested packages (i.e.
1544 of the form C<A::B>) where package C<A> does not contain any subs.
1548 Debug options (concatenated or separate flags like C<perl -D>).
1552 OPs, prints each OP as it's processed
1556 COPs, prints COPs as processed (incl. file & line num)
1560 prints AV information on saving
1564 prints CV information on saving
1568 prints MAGIC information on saving
1572 Force optimisations on or off one at a time.
1576 Copy-on-grow: PVs declared and initialised statically.
1584 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
1585 B<-O1> and higher set B<-fcog>.
1589 perl -MO=C,-ofoo.c foo.pl
1590 perl cc_harness -o foo foo.c
1592 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1593 library directory. The utility called C<perlcc> may also be used to
1594 help make use of this compiler.
1596 perl -MO=C,-v,-DcA bar.pl > /dev/null
1600 Plenty. Current status: experimental.
1604 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>