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 = $cv->FILEGV->SV->PV;
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 $filegv = $cv->FILEGV;
706 $init->add(sprintf("CvFILEGV(s\\_%x) = s\\_%x;", $$cv, $$filegv));
707 warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n",
708 $$filegv, $$cv) if $debug_cv;
710 my $stash = $cv->STASH;
713 $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
714 warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
715 $$stash, $$cv) if $debug_cv;
717 $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
718 $sv_ix, $xpvcv_ix, $cv->REFCNT +1 , $cv->FLAGS));
724 my $sym = objsym($gv);
726 #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
729 my $ix = $gv_index++;
730 $sym = savesym($gv, "gv_list[$ix]");
731 #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
733 my $gvname = $gv->NAME;
734 my $name = cstring($gv->STASH->NAME . "::" . $gvname);
735 #warn "GV name is $name\n"; # debug
739 #warn(sprintf("EGV name is %s, saving it now\n",
740 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
741 $egvsym = $egv->save;
743 $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
744 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
745 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS),
746 sprintf("GvLINE($sym) = %u;", $gv->LINE));
747 # Shouldn't need to do save_magic since gv_fetchpv handles that
749 my $refcnt = $gv->REFCNT + 1;
750 $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
751 my $gvrefcnt = $gv->GvREFCNT;
753 $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
755 if (defined($egvsym)) {
756 # Shared glob *foo = *bar
757 $init->add("gp_free($sym);",
758 "GvGP($sym) = GvGP($egvsym);");
759 } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
760 # Don't save subfields of special GVs (*_, *1, *# and so on)
761 # warn "GV::save saving subfields\n"; # debug
765 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
766 # warn "GV::save \$$name\n"; # debug
771 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
772 # warn "GV::save \@$name\n"; # debug
777 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
778 # warn "GV::save \%$name\n"; # debug
782 my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
783 "::" . $gvcv->GV->EGV->NAME);
784 if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias
785 # must save as a 'stub' so newXS() has a CV to populate
786 $init->add("{ CV *cv;");
787 $init->add("\tcv=perl_get_cv($origname,TRUE);");
788 $init->add("\tGvCV($sym)=cv;");
789 $init->add("\tSvREFCNT_inc((SV *)cv);");
792 $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
793 # warn "GV::save &$name\n"; # debug
796 my $gvfilegv = $gv->FILEGV;
799 $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv));
800 # warn "GV::save GvFILEGV(*$name)\n"; # debug
802 my $gvform = $gv->FORM;
805 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
806 # warn "GV::save GvFORM(*$name)\n"; # debug
811 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
812 # warn "GV::save GvIO(*$name)\n"; # debug
819 my $sym = objsym($av);
820 return $sym if defined $sym;
821 my $avflags = $av->AvFLAGS;
822 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
824 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
825 $xpvavsect->index, $av->REFCNT , $av->FLAGS));
826 my $sv_list_index = $svsect->index;
827 my $fill = $av->FILL;
829 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
831 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
832 #if ($fill > -1 && ($avflags & AVf_REAL)) {
834 my @array = $av->ARRAY;
838 foreach $el (@array) {
839 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
840 $$av, $i++, class($el), $$el);
843 my @names = map($_->save, @array);
844 # XXX Better ways to write loop?
845 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
846 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
849 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
850 "\tav_extend(av, $fill);",
851 "\tsvp = AvARRAY(av);",
852 map("\t*svp++ = (SV*)$_;", @names),
853 "\tAvFILLp(av) = $fill;",
857 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
860 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
865 my $sym = objsym($hv);
866 return $sym if defined $sym;
867 my $name = $hv->NAME;
871 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
872 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
873 # a trashed op but we look at the trashed op_type and segfault.
874 #my $adpmroot = ${$hv->PMROOT};
876 $decl->add("static HV *hv$hv_index;");
877 # XXX Beware of weird package names containing double-quotes, \n, ...?
878 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
880 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
883 $sym = savesym($hv, "hv$hv_index");
887 # It's just an ordinary HV
888 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
889 $hv->MAX, $hv->RITER));
890 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
891 $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS));
892 my $sv_list_index = $svsect->index;
893 my @contents = $hv->ARRAY;
896 for ($i = 1; $i < @contents; $i += 2) {
897 $contents[$i] = $contents[$i]->save;
899 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
901 my ($key, $value) = splice(@contents, 0, 2);
902 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
903 cstring($key),length($key),$value, hash($key)));
904 # $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
905 # cstring($key),length($key),$value, 0));
910 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
915 my $sym = objsym($io);
916 return $sym if defined $sym;
918 $pv = '' unless defined $pv;
919 my $len = length($pv);
920 $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",
921 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
922 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
923 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
924 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
925 cchar($io->IoTYPE), $io->IoFLAGS));
926 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
927 $xpviosect->index, $io->REFCNT , $io->FLAGS));
928 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
930 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
931 $fsym = $io->$field();
933 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
943 # This is where we catch an honest-to-goodness Nullsv (which gets
944 # blessed into B::SV explicitly) and any stray erroneous SVs.
945 return 0 unless $$sv;
946 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
951 my $init_name = shift;
953 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
954 $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect,
955 $loopsect, $copsect, $svsect, $xpvsect,
956 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
957 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
958 $symsect->output(\*STDOUT, "#define %s\n");
960 output_declarations();
961 foreach $section (@sections) {
962 my $lines = $section->index + 1;
964 my $name = $section->name;
965 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
966 print "Static $typename ${name}_list[$lines];\n";
969 $decl->output(\*STDOUT, "%s\n");
971 foreach $section (@sections) {
972 my $lines = $section->index + 1;
974 my $name = $section->name;
975 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
976 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
977 $section->output(\*STDOUT, "\t{ %s },\n");
983 static int $init_name()
989 $init->output(\*STDOUT, "\t%s\n");
990 print "\treturn 0;\n}\n";
992 warn compile_stats();
993 warn "NULLOP count: $nullop_count\n";
997 sub output_declarations {
999 #ifdef BROKEN_STATIC_REDECL
1000 #define Static extern
1002 #define Static static
1003 #endif /* BROKEN_STATIC_REDECL */
1005 #ifdef BROKEN_UNION_INIT
1007 * Cribbed from cv.h with ANY (a union) replaced by void*.
1008 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
1011 char * xpv_pv; /* pointer to malloced string */
1012 STRLEN xpv_cur; /* length of xp_pv as a C string */
1013 STRLEN xpv_len; /* allocated size */
1014 IV xof_off; /* integer value */
1015 double xnv_nv; /* numeric value, if any */
1016 MAGIC* xmg_magic; /* magic for scalar array */
1017 HV* xmg_stash; /* class package */
1022 void (*xcv_xsub) (CV*);
1026 long xcv_depth; /* >= 2 indicates recursive call */
1030 perl_mutex *xcv_mutexp;
1031 struct perl_thread *xcv_owner; /* current owner thread */
1032 #endif /* USE_THREADS */
1035 #define ANYINIT(i) i
1037 #define XPVCV_or_similar XPVCV
1038 #define ANYINIT(i) {i}
1039 #endif /* BROKEN_UNION_INIT */
1040 #define Nullany ANYINIT(0)
1046 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1051 sub output_boilerplate {
1056 /* Workaround for mapstart: the only op which needs a different ppaddr */
1057 #undef Perl_pp_mapstart
1058 #define Perl_pp_mapstart Perl_pp_grepstart
1059 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1060 EXTERN_C void boot_DynaLoader (CV* cv);
1062 static void xs_init (void);
1063 static void dl_init (void);
1064 static PerlInterpreter *my_perl;
1071 #ifndef CAN_PROTOTYPE
1072 main(argc, argv, env)
1076 #else /* def(CAN_PROTOTYPE) */
1077 main(int argc, char **argv, char **env)
1078 #endif /* def(CAN_PROTOTYPE) */
1084 PERL_SYS_INIT(&argc,&argv);
1086 perl_init_i18nl10n(1);
1088 if (!PL_do_undump) {
1089 my_perl = perl_alloc();
1092 perl_construct( my_perl );
1097 PL_cshlen = strlen(PL_cshname);
1100 #ifdef ALLOW_PERL_OPTIONS
1101 #define EXTRA_OPTIONS 2
1103 #define EXTRA_OPTIONS 3
1104 #endif /* ALLOW_PERL_OPTIONS */
1105 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1106 fakeargv[0] = argv[0];
1109 #ifndef ALLOW_PERL_OPTIONS
1111 #endif /* ALLOW_PERL_OPTIONS */
1112 for (i = 1; i < argc; i++)
1113 fakeargv[i + EXTRA_OPTIONS] = argv[i];
1114 fakeargv[argc + EXTRA_OPTIONS] = 0;
1116 exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1121 sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1122 PL_main_cv = PL_compcv;
1125 exitstatus = perl_init();
1130 exitstatus = perl_run( my_perl );
1132 perl_destruct( my_perl );
1133 perl_free( my_perl );
1138 /* yanked from perl.c */
1142 char *file = __FILE__;
1146 print "\n#ifdef USE_DYNAMIC_LOADING";
1147 print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1148 print "\n#endif\n" ;
1149 # delete $xsub{'DynaLoader'};
1150 delete $xsub{'UNIVERSAL'};
1151 print("/* bootstrapping code*/\n\tSAVETMPS;\n");
1152 print("\ttarg=sv_newmortal();\n");
1153 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1154 print "\tPUSHMARK(sp);\n";
1155 print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
1156 print qq/\tPUTBACK;\n/;
1157 print "\tboot_DynaLoader(NULL);\n";
1158 print qq/\tSPAGAIN;\n/;
1160 foreach my $stashname (keys %xsub){
1161 if ($xsub{$stashname} ne 'Dynamic') {
1162 my $stashxsub=$stashname;
1163 $stashxsub =~ s/::/__/g;
1164 print "\tPUSHMARK(sp);\n";
1165 print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
1166 print qq/\tPUTBACK;\n/;
1167 print "\tboot_$stashxsub(NULL);\n";
1168 print qq/\tSPAGAIN;\n/;
1171 print("\tFREETMPS;\n/* end bootstrapping code */\n");
1178 char *file = __FILE__;
1182 print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
1183 print("\ttarg=sv_newmortal();\n");
1184 foreach my $stashname (@DynaLoader::dl_modules) {
1185 warn "Loaded $stashname\n";
1186 if (exists($xsub{$stashname}) && $xsub{$stashname} eq 'Dynamic') {
1187 my $stashxsub=$stashname;
1188 $stashxsub =~ s/::/__/g;
1189 print "\tPUSHMARK(sp);\n";
1190 print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
1191 print qq/\tPUTBACK;\n/;
1192 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1193 warn "bootstrapping $stashname added to xs_init\n";
1194 print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
1196 print "\tboot_$stashxsub(NULL);\n";
1198 print qq/\tSPAGAIN;\n/;
1201 print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
1207 warn "----Symbol table:\n";
1208 while (($sym, $val) = each %symtable) {
1209 warn "$sym => $val\n";
1211 warn "---End of symbol table\n";
1217 svref_2object($sv)->save;
1221 sub Dummy_BootStrap { }
1226 my $package=$gv->STASH->NAME;
1227 my $name = $gv->NAME;
1233 # We may be looking at this package just because it is a branch in the
1234 # symbol table which is on the path to a package which we need to save
1235 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1237 return unless ($unused_sub_packages{$package});
1238 return unless ($$cv || $$av || $$sv || $$hv);
1244 my $package = shift;
1245 unless ($unused_sub_packages{$package})
1248 $unused_sub_packages{$package} = 1;
1249 if (defined @{$package.'::ISA'})
1251 foreach my $isa (@{$package.'::ISA'})
1253 if ($isa eq 'DynaLoader')
1255 unless (defined(&{$package.'::bootstrap'}))
1257 warn "Forcing bootstrap of $package\n";
1258 eval { $package->bootstrap };
1263 unless ($unused_sub_packages{$isa})
1265 warn "$isa saved (it is in $package\'s \@ISA)\n";
1277 no strict qw(vars refs);
1278 my $package = shift;
1279 $package =~ s/::$//;
1280 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1281 # warn "Considering $package\n";#debug
1282 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1284 # If this package is a prefix to something we are saving, traverse it
1285 # but do not mark it for saving if it is not already
1286 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1288 return 1 if ($u =~ /^$package\:\:/);
1290 if (exists $unused_sub_packages{$package})
1292 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1293 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1294 return $unused_sub_packages{$package};
1296 # Omit the packages which we use (and which cause grief
1297 # because of fancy "goto &$AUTOLOAD" stuff).
1298 # XXX Surely there must be a nicer way to do this.
1299 if ($package eq "FileHandle" || $package eq "Config" ||
1300 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1302 delete_unsaved_hashINC($package);
1303 return $unused_sub_packages{$package} = 0;
1305 # Now see if current package looks like an OO class this is probably too strong.
1306 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1308 if ($package->can($m))
1310 warn "$package has method $m: saving package\n";#debug
1311 return mark_package($package);
1314 delete_unsaved_hashINC($package);
1315 return $unused_sub_packages{$package} = 0;
1317 sub delete_unsaved_hashINC{
1319 $packname =~ s/\:\:/\//g;
1321 # warn "deleting $packname" if $INC{$packname} ;# debug
1322 delete $INC{$packname};
1326 my ($symref, $recurse, $prefix) = @_;
1331 $prefix = '' unless defined $prefix;
1332 while (($sym, $ref) = each %$symref)
1337 $sym = $prefix . $sym;
1338 if ($sym ne "main::" && &$recurse($sym))
1340 walkpackages(\%glob, $recurse, $sym);
1347 sub save_unused_subs
1350 &descend_marked_unused;
1352 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1353 warn "Saving methods\n";
1354 walksymtable(\%{"main::"}, "savecv", \&should_save);
1359 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1360 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1361 my $inc_hv = svref_2object(\%INC)->save;
1362 my $inc_av = svref_2object(\@INC)->save;
1363 my $amagic_generate= amagic_generation;
1364 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1365 "GvHV(PL_incgv) = $inc_hv;",
1366 "GvAV(PL_incgv) = $inc_av;",
1367 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1368 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1369 "PL_amagic_generation= $amagic_generate;" );
1372 sub descend_marked_unused {
1373 foreach my $pack (keys %unused_sub_packages)
1375 mark_package($pack);
1380 warn "Starting compile\n";
1381 warn "Walking tree\n";
1382 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1383 walkoptree(main_root, "save");
1384 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1386 my $init_av = init_av->save;
1387 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1388 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1389 "PL_initav = (AV *) $init_av;");
1391 warn "Writing output\n";
1392 output_boilerplate();
1394 output_all("perl_init");
1400 my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1401 binop => \$binopsect, condop => \$condopsect,
1402 cop => \$copsect, padop => \$padopsect,
1403 listop => \$listopsect, logop => \$logopsect,
1404 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1405 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1406 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1407 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1408 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1409 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1410 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1411 xpvio => \$xpviosect);
1412 my ($name, $sectref);
1413 while (($name, $sectref) = splice(@sections, 0, 2)) {
1414 $$sectref = new B::C::Section $name, \%symtable, 0;
1420 my ($arg,$val) = @_;
1421 $unused_sub_packages{$arg} = $val;
1426 my ($option, $opt, $arg);
1428 while ($option = shift @options) {
1429 if ($option =~ /^-(.)(.*)/) {
1433 unshift @options, $option;
1436 if ($opt eq "-" && $arg eq "-") {
1441 $warn_undefined_syms = 1;
1442 } elsif ($opt eq "D") {
1443 $arg ||= shift @options;
1444 foreach $arg (split(//, $arg)) {
1447 } elsif ($arg eq "c") {
1449 } elsif ($arg eq "A") {
1451 } elsif ($arg eq "C") {
1453 } elsif ($arg eq "M") {
1456 warn "ignoring unknown debug option: $arg\n";
1459 } elsif ($opt eq "o") {
1460 $arg ||= shift @options;
1461 open(STDOUT, ">$arg") or return "$arg: $!\n";
1462 } elsif ($opt eq "v") {
1464 } elsif ($opt eq "u") {
1465 $arg ||= shift @options;
1466 mark_unused($arg,undef);
1467 } elsif ($opt eq "f") {
1468 $arg ||= shift @options;
1469 if ($arg eq "cog") {
1470 $pv_copy_on_grow = 1;
1471 } elsif ($arg eq "no-cog") {
1472 $pv_copy_on_grow = 0;
1474 } elsif ($opt eq "O") {
1475 $arg = 1 if $arg eq "";
1476 $pv_copy_on_grow = 0;
1478 # Optimisations for -O1
1479 $pv_copy_on_grow = 1;
1487 foreach $objname (@options) {
1488 eval "save_object(\\$objname)";
1493 return sub { save_main() };
1503 B::C - Perl compiler's C backend
1507 perl -MO=C[,OPTIONS] foo.pl
1511 This compiler backend takes Perl source and generates C source code
1512 corresponding to the internal structures that perl uses to run
1513 your program. When the generated C source is compiled and run, it
1514 cuts out the time which perl would have taken to load and parse
1515 your program into its internal semi-compiled form. That means that
1516 compiling with this backend will not help improve the runtime
1517 execution speed of your program but may improve the start-up time.
1518 Depending on the environment in which your program runs this may be
1519 either a help or a hindrance.
1523 If there are any non-option arguments, they are taken to be
1524 names of objects to be saved (probably doesn't work properly yet).
1525 Without extra arguments, it saves the main program.
1531 Output to filename instead of STDOUT
1535 Verbose compilation (currently gives a few compilation statistics).
1539 Force end of options
1543 Force apparently unused subs from package Packname to be compiled.
1544 This allows programs to use eval "foo()" even when sub foo is never
1545 seen to be used at compile time. The down side is that any subs which
1546 really are never used also have code generated. This option is
1547 necessary, for example, if you have a signal handler foo which you
1548 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1549 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1550 options. The compiler tries to figure out which packages may possibly
1551 have subs in which need compiling but the current version doesn't do
1552 it very well. In particular, it is confused by nested packages (i.e.
1553 of the form C<A::B>) where package C<A> does not contain any subs.
1557 Debug options (concatenated or separate flags like C<perl -D>).
1561 OPs, prints each OP as it's processed
1565 COPs, prints COPs as processed (incl. file & line num)
1569 prints AV information on saving
1573 prints CV information on saving
1577 prints MAGIC information on saving
1581 Force optimisations on or off one at a time.
1585 Copy-on-grow: PVs declared and initialised statically.
1593 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
1594 B<-O1> and higher set B<-fcog>.
1598 perl -MO=C,-ofoo.c foo.pl
1599 perl cc_harness -o foo foo.c
1601 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1602 library directory. The utility called C<perlcc> may also be used to
1603 help make use of this compiler.
1605 perl -MO=C,-v,-DcA bar.pl > /dev/null
1609 Plenty. Current status: experimental.
1613 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>