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 warn sprintf("COP: line %d file %s\n", $op->line, $op->file)
298 $copsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u",
299 ${$op->next}, ${$op->sibling}, $op->ppaddr,
300 $op->targ, $op->type, $op_seq, $op->flags,
301 $op->private, cstring($op->label), $op->cop_seq,
302 $op->arybase, $op->line));
303 my $copix = $copsect->index;
304 $init->add(sprintf("CopFILE_set(&cop_list[%d], %s);", $copix, cstring($op->file)),
305 sprintf("CopSTASHPV_set(&cop_list[%d], %s);", $copix, cstring($op->stashpv));
306 savesym($op, "(OP*)&cop_list[$copix]");
310 my ($op, $level) = @_;
311 my $sym = objsym($op);
312 return $sym if defined $sym;
313 my $replroot = $op->pmreplroot;
314 my $replstart = $op->pmreplstart;
315 my $replrootfield = sprintf("s\\_%x", $$replroot);
316 my $replstartfield = sprintf("s\\_%x", $$replstart);
318 my $ppaddr = $op->ppaddr;
320 # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
321 # argument to a split) stores a GV in op_pmreplroot instead
322 # of a substitution syntax tree. We don't want to walk that...
323 if ($op->name eq "pushre") {
324 $gvsym = $replroot->save;
325 # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
328 $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
331 # pmnext handling is broken in perl itself, I think. Bad op_pmnext
332 # fields aren't noticed in perl's runtime (unless you try reset) but we
333 # segfault when trying to dereference it to find op->op_pmnext->op_type
334 $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",
335 ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ,
336 $op->type, $op_seq, $op->flags, $op->private,
337 ${$op->first}, ${$op->last}, $op->children,
338 $replrootfield, $replstartfield,
339 $op->pmflags, $op->pmpermflags,));
340 my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
341 my $re = $op->precomp;
343 my $resym = sprintf("re%d", $re_index++);
344 $decl->add(sprintf("static char *$resym = %s;", cstring($re)));
345 $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
349 $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
351 savesym($op, sprintf("(OP*)&pmop_list[%d]", $pmopsect->index));
354 sub B::SPECIAL::save {
356 # special case: $$sv is not the address but an index into specialsv_list
357 # warn "SPECIAL::save specialsv $$sv\n"; # debug
358 my $sym = $specialsv_name[$$sv];
359 if (!defined($sym)) {
360 confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
365 sub B::OBJECT::save {}
369 my $sym = objsym($sv);
370 return $sym if defined $sym;
371 # warn "Saving SVt_NULL SV\n"; # debug
374 # warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
376 $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS));
377 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
382 my $sym = objsym($sv);
383 return $sym if defined $sym;
384 $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
385 $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
386 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
387 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
392 my $sym = objsym($sv);
393 return $sym if defined $sym;
395 $val .= '.00' if $val =~ /^-?\d+$/;
396 $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
397 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
398 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
399 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
404 my $sym = objsym($sv);
405 return $sym if defined $sym;
407 my $len = length($pv);
408 my ($pvsym, $pvmax) = savepv($pv);
409 my ($lvtarg, $lvtarg_sym);
410 $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
411 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
412 $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
413 $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
414 $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS));
415 if (!$pv_copy_on_grow) {
416 $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);",
417 $xpvlvsect->index, cstring($pv), $len));
420 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
425 my $sym = objsym($sv);
426 return $sym if defined $sym;
428 my $len = length($pv);
429 my ($pvsym, $pvmax) = savepv($pv);
430 $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
431 $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
432 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
433 if (!$pv_copy_on_grow) {
434 $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);",
435 $xpvivsect->index, cstring($pv), $len));
437 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
442 my $sym = objsym($sv);
443 return $sym if defined $sym;
445 $pv = '' unless defined $pv;
446 my $len = length($pv);
447 my ($pvsym, $pvmax) = savepv($pv);
449 $val .= '.00' if $val =~ /^-?\d+$/;
450 $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
451 $pvsym, $len, $pvmax, $sv->IVX, $val));
452 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
453 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
454 if (!$pv_copy_on_grow) {
455 $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);",
456 $xpvnvsect->index, cstring($pv), $len));
458 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
463 my $sym = objsym($sv);
464 return $sym if defined $sym;
465 my $pv = $sv->PV . "\0" . $sv->TABLE;
466 my $len = length($pv);
467 $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
468 $len, $len + 258, $sv->IVX, $sv->NVX,
469 $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
470 $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
471 $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS));
473 $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);",
474 $xpvbmsect->index, cstring($pv), $len),
475 sprintf("xpvbm_list[%d].xpv_cur = %u;",
476 $xpvbmsect->index, $len - 257));
477 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
482 my $sym = objsym($sv);
483 return $sym if defined $sym;
485 my $len = length($pv);
486 my ($pvsym, $pvmax) = savepv($pv);
487 $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
488 $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
489 $xpvsect->index, $sv->REFCNT , $sv->FLAGS));
490 if (!$pv_copy_on_grow) {
491 $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);",
492 $xpvsect->index, cstring($pv), $len));
494 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
499 my $sym = objsym($sv);
500 return $sym if defined $sym;
502 my $len = length($pv);
503 my ($pvsym, $pvmax) = savepv($pv);
504 $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
505 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
506 $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
507 $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS));
508 if (!$pv_copy_on_grow) {
509 $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);",
510 $xpvmgsect->index, cstring($pv), $len));
512 $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
517 sub B::PVMG::save_magic {
519 #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
520 my $stash = $sv->SvSTASH;
523 warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
525 # XXX Hope stash is already going to be saved.
526 $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
528 my @mgchain = $sv->MAGIC;
529 my ($mg, $type, $obj, $ptr,$len,$ptrsv);
530 foreach $mg (@mgchain) {
536 warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
537 class($sv), $$sv, class($obj), $$obj,
538 cchar($type), cstring($ptr));
541 if ($len == HEf_SVKEY){
542 #The pointer is an SV*
543 $ptrsv=svref_2object($ptr)->save;
544 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
545 $$sv, $$obj, cchar($type),$ptrsv,$len));
547 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
548 $$sv, $$obj, cchar($type),cstring($ptr),$len));
555 my $sym = objsym($sv);
556 return $sym if defined $sym;
557 my $rv = $sv->RV->save;
558 $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/;
560 $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
561 $xrvsect->index, $sv->REFCNT , $sv->FLAGS));
562 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
566 my ($cvstashname, $cvname) = @_;
567 warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
568 # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
569 # use should be handled by the class itself.
571 my $isa = \@{"$cvstashname\::ISA"};
572 if (grep($_ eq "AutoLoader", @$isa)) {
573 warn "Forcing immediate load of sub derived from AutoLoader\n";
574 # Tweaked version of AutoLoader::AUTOLOAD
575 my $dir = $cvstashname;
577 eval { require "auto/$dir/$cvname.al" };
579 warn qq(failed require "auto/$dir/$cvname.al": $@\n);
589 my $sym = objsym($cv);
591 # warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
594 # Reserve a place in svsect and xpvcvsect and record indices
596 my ($cvname, $cvstashname);
599 $cvstashname = $gv->STASH->NAME;
601 my $root = $cv->ROOT;
602 my $cvxsub = $cv->XSUB;
603 #INIT is removed from the symbol table, so this call must come
604 # from PL_initav->save. Re-bootstrapping will push INIT back in
605 # so nullop should be sent.
606 if ($cvxsub && ($cvname ne "INIT")) {
608 my $stashname = $egv->STASH->NAME;
609 if ($cvname eq "bootstrap")
611 my $file = $gv->FILE;
612 $decl->add("/* bootstrap $file */");
613 warn "Bootstrap $stashname $file\n";
614 $xsub{$stashname}='Dynamic';
615 # $xsub{$stashname}='Static' unless $xsub{$stashname};
618 warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv;
619 return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/;
621 if ($cvxsub && $cvname eq "INIT") {
623 return svref_2object(\&Dummy_initxs)->save;
625 my $sv_ix = $svsect->index + 1;
626 $svsect->add("svix$sv_ix");
627 my $xpvcv_ix = $xpvcvsect->index + 1;
628 $xpvcvsect->add("xpvcvix$xpvcv_ix");
629 # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
630 $sym = savesym($cv, "&sv_list[$sv_ix]");
631 warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv;
632 if (!$$root && !$cvxsub) {
633 if (try_autoload($cvstashname, $cvname)) {
634 # Recalculate root and xsub
637 if ($$root || $cvxsub) {
638 warn "Successful forced autoload\n";
643 my $padlist = $cv->PADLIST;
646 my $xsubany = "Nullany";
648 warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
649 $$cv, $$root) if $debug_cv;
652 my $stashname = $gv->STASH->NAME;
653 my $gvname = $gv->NAME;
654 if ($gvname ne "__ANON__") {
655 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
656 $ppname .= ($stashname eq "main") ?
657 $gvname : "$stashname\::$gvname";
658 $ppname =~ s/::/__/g;
659 if ($gvname eq "INIT"){
660 $ppname .= "_$initsub_index";
666 $ppname = "pp_anonsub_$anonsub_index";
669 $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
670 warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
671 $$cv, $ppname, $$root) if $debug_cv;
673 warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
674 $$padlist, $$cv) if $debug_cv;
676 warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
677 $$padlist, $$cv) if $debug_cv;
681 warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
682 $cvstashname, $cvname); # debug
684 $pv = '' unless defined $pv; # Avoid use of undef warnings
685 $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",
686 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
687 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
688 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
690 if (${$cv->OUTSIDE} == ${main_cv()}){
691 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
692 $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
697 $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
698 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
699 $$gv, $$cv) if $debug_cv;
701 $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE)));
702 my $stash = $cv->STASH;
705 $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
706 warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
707 $$stash, $$cv) if $debug_cv;
709 $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
710 $sv_ix, $xpvcv_ix, $cv->REFCNT +1 , $cv->FLAGS));
716 my $sym = objsym($gv);
718 #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
721 my $ix = $gv_index++;
722 $sym = savesym($gv, "gv_list[$ix]");
723 #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
725 my $gvname = $gv->NAME;
726 my $name = cstring($gv->STASH->NAME . "::" . $gvname);
727 #warn "GV name is $name\n"; # debug
731 #warn(sprintf("EGV name is %s, saving it now\n",
732 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
733 $egvsym = $egv->save;
735 $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
736 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
737 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS),
738 sprintf("GvLINE($sym) = %u;", $gv->LINE));
739 # Shouldn't need to do save_magic since gv_fetchpv handles that
741 my $refcnt = $gv->REFCNT + 1;
742 $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
743 my $gvrefcnt = $gv->GvREFCNT;
745 $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
747 if (defined($egvsym)) {
748 # Shared glob *foo = *bar
749 $init->add("gp_free($sym);",
750 "GvGP($sym) = GvGP($egvsym);");
751 } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
752 # Don't save subfields of special GVs (*_, *1, *# and so on)
753 # warn "GV::save saving subfields\n"; # debug
757 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
758 # warn "GV::save \$$name\n"; # debug
763 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
764 # warn "GV::save \@$name\n"; # debug
769 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
770 # warn "GV::save \%$name\n"; # debug
774 my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
775 "::" . $gvcv->GV->EGV->NAME);
776 if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias
777 # must save as a 'stub' so newXS() has a CV to populate
778 $init->add("{ CV *cv;");
779 $init->add("\tcv=perl_get_cv($origname,TRUE);");
780 $init->add("\tGvCV($sym)=cv;");
781 $init->add("\tSvREFCNT_inc((SV *)cv);");
784 $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
785 # warn "GV::save &$name\n"; # debug
788 $init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE)));
789 # warn "GV::save GvFILE(*$name)\n"; # debug
790 my $gvform = $gv->FORM;
793 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
794 # warn "GV::save GvFORM(*$name)\n"; # debug
799 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
800 # warn "GV::save GvIO(*$name)\n"; # debug
807 my $sym = objsym($av);
808 return $sym if defined $sym;
809 my $avflags = $av->AvFLAGS;
810 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
812 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
813 $xpvavsect->index, $av->REFCNT , $av->FLAGS));
814 my $sv_list_index = $svsect->index;
815 my $fill = $av->FILL;
817 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
819 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
820 #if ($fill > -1 && ($avflags & AVf_REAL)) {
822 my @array = $av->ARRAY;
826 foreach $el (@array) {
827 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
828 $$av, $i++, class($el), $$el);
831 my @names = map($_->save, @array);
832 # XXX Better ways to write loop?
833 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
834 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
837 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
838 "\tav_extend(av, $fill);",
839 "\tsvp = AvARRAY(av);",
840 map("\t*svp++ = (SV*)$_;", @names),
841 "\tAvFILLp(av) = $fill;",
845 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
848 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
853 my $sym = objsym($hv);
854 return $sym if defined $sym;
855 my $name = $hv->NAME;
859 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
860 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
861 # a trashed op but we look at the trashed op_type and segfault.
862 #my $adpmroot = ${$hv->PMROOT};
864 $decl->add("static HV *hv$hv_index;");
865 # XXX Beware of weird package names containing double-quotes, \n, ...?
866 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
868 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
871 $sym = savesym($hv, "hv$hv_index");
875 # It's just an ordinary HV
876 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
877 $hv->MAX, $hv->RITER));
878 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
879 $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS));
880 my $sv_list_index = $svsect->index;
881 my @contents = $hv->ARRAY;
884 for ($i = 1; $i < @contents; $i += 2) {
885 $contents[$i] = $contents[$i]->save;
887 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
889 my ($key, $value) = splice(@contents, 0, 2);
890 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
891 cstring($key),length($key),$value, hash($key)));
892 # $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
893 # cstring($key),length($key),$value, 0));
898 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
903 my $sym = objsym($io);
904 return $sym if defined $sym;
906 $pv = '' unless defined $pv;
907 my $len = length($pv);
908 $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",
909 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
910 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
911 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
912 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
913 cchar($io->IoTYPE), $io->IoFLAGS));
914 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
915 $xpviosect->index, $io->REFCNT , $io->FLAGS));
916 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
918 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
919 $fsym = $io->$field();
921 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
931 # This is where we catch an honest-to-goodness Nullsv (which gets
932 # blessed into B::SV explicitly) and any stray erroneous SVs.
933 return 0 unless $$sv;
934 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
939 my $init_name = shift;
941 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
942 $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect,
943 $loopsect, $copsect, $svsect, $xpvsect,
944 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
945 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
946 $symsect->output(\*STDOUT, "#define %s\n");
948 output_declarations();
949 foreach $section (@sections) {
950 my $lines = $section->index + 1;
952 my $name = $section->name;
953 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
954 print "Static $typename ${name}_list[$lines];\n";
957 $decl->output(\*STDOUT, "%s\n");
959 foreach $section (@sections) {
960 my $lines = $section->index + 1;
962 my $name = $section->name;
963 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
964 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
965 $section->output(\*STDOUT, "\t{ %s },\n");
971 static int $init_name()
977 $init->output(\*STDOUT, "\t%s\n");
978 print "\treturn 0;\n}\n";
980 warn compile_stats();
981 warn "NULLOP count: $nullop_count\n";
985 sub output_declarations {
987 #ifdef BROKEN_STATIC_REDECL
988 #define Static extern
990 #define Static static
991 #endif /* BROKEN_STATIC_REDECL */
993 #ifdef BROKEN_UNION_INIT
995 * Cribbed from cv.h with ANY (a union) replaced by void*.
996 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
999 char * xpv_pv; /* pointer to malloced string */
1000 STRLEN xpv_cur; /* length of xp_pv as a C string */
1001 STRLEN xpv_len; /* allocated size */
1002 IV xof_off; /* integer value */
1003 double xnv_nv; /* numeric value, if any */
1004 MAGIC* xmg_magic; /* magic for scalar array */
1005 HV* xmg_stash; /* class package */
1010 void (*xcv_xsub) (CV*);
1014 long xcv_depth; /* >= 2 indicates recursive call */
1018 perl_mutex *xcv_mutexp;
1019 struct perl_thread *xcv_owner; /* current owner thread */
1020 #endif /* USE_THREADS */
1023 #define ANYINIT(i) i
1025 #define XPVCV_or_similar XPVCV
1026 #define ANYINIT(i) {i}
1027 #endif /* BROKEN_UNION_INIT */
1028 #define Nullany ANYINIT(0)
1034 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1039 sub output_boilerplate {
1044 /* Workaround for mapstart: the only op which needs a different ppaddr */
1045 #undef Perl_pp_mapstart
1046 #define Perl_pp_mapstart Perl_pp_grepstart
1047 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1048 EXTERN_C void boot_DynaLoader (CV* cv);
1050 static void xs_init (void);
1051 static void dl_init (void);
1052 static PerlInterpreter *my_perl;
1059 #ifndef CAN_PROTOTYPE
1060 main(argc, argv, env)
1064 #else /* def(CAN_PROTOTYPE) */
1065 main(int argc, char **argv, char **env)
1066 #endif /* def(CAN_PROTOTYPE) */
1072 PERL_SYS_INIT(&argc,&argv);
1074 perl_init_i18nl10n(1);
1076 if (!PL_do_undump) {
1077 my_perl = perl_alloc();
1080 perl_construct( my_perl );
1085 PL_cshlen = strlen(PL_cshname);
1088 #ifdef ALLOW_PERL_OPTIONS
1089 #define EXTRA_OPTIONS 2
1091 #define EXTRA_OPTIONS 3
1092 #endif /* ALLOW_PERL_OPTIONS */
1093 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1094 fakeargv[0] = argv[0];
1097 #ifndef ALLOW_PERL_OPTIONS
1099 #endif /* ALLOW_PERL_OPTIONS */
1100 for (i = 1; i < argc; i++)
1101 fakeargv[i + EXTRA_OPTIONS] = argv[i];
1102 fakeargv[argc + EXTRA_OPTIONS] = 0;
1104 exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1109 sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1110 PL_main_cv = PL_compcv;
1113 exitstatus = perl_init();
1118 exitstatus = perl_run( my_perl );
1120 perl_destruct( my_perl );
1121 perl_free( my_perl );
1126 /* yanked from perl.c */
1130 char *file = __FILE__;
1134 print "\n#ifdef USE_DYNAMIC_LOADING";
1135 print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1136 print "\n#endif\n" ;
1137 # delete $xsub{'DynaLoader'};
1138 delete $xsub{'UNIVERSAL'};
1139 print("/* bootstrapping code*/\n\tSAVETMPS;\n");
1140 print("\ttarg=sv_newmortal();\n");
1141 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1142 print "\tPUSHMARK(sp);\n";
1143 print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
1144 print qq/\tPUTBACK;\n/;
1145 print "\tboot_DynaLoader(NULL);\n";
1146 print qq/\tSPAGAIN;\n/;
1148 foreach my $stashname (keys %xsub){
1149 if ($xsub{$stashname} ne 'Dynamic') {
1150 my $stashxsub=$stashname;
1151 $stashxsub =~ s/::/__/g;
1152 print "\tPUSHMARK(sp);\n";
1153 print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
1154 print qq/\tPUTBACK;\n/;
1155 print "\tboot_$stashxsub(NULL);\n";
1156 print qq/\tSPAGAIN;\n/;
1159 print("\tFREETMPS;\n/* end bootstrapping code */\n");
1166 char *file = __FILE__;
1170 print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
1171 print("\ttarg=sv_newmortal();\n");
1172 foreach my $stashname (@DynaLoader::dl_modules) {
1173 warn "Loaded $stashname\n";
1174 if (exists($xsub{$stashname}) && $xsub{$stashname} eq 'Dynamic') {
1175 my $stashxsub=$stashname;
1176 $stashxsub =~ s/::/__/g;
1177 print "\tPUSHMARK(sp);\n";
1178 print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
1179 print qq/\tPUTBACK;\n/;
1180 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1181 warn "bootstrapping $stashname added to xs_init\n";
1182 print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
1184 print "\tboot_$stashxsub(NULL);\n";
1186 print qq/\tSPAGAIN;\n/;
1189 print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
1195 warn "----Symbol table:\n";
1196 while (($sym, $val) = each %symtable) {
1197 warn "$sym => $val\n";
1199 warn "---End of symbol table\n";
1205 svref_2object($sv)->save;
1209 sub Dummy_BootStrap { }
1214 my $package=$gv->STASH->NAME;
1215 my $name = $gv->NAME;
1221 # We may be looking at this package just because it is a branch in the
1222 # symbol table which is on the path to a package which we need to save
1223 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1225 return unless ($unused_sub_packages{$package});
1226 return unless ($$cv || $$av || $$sv || $$hv);
1232 my $package = shift;
1233 unless ($unused_sub_packages{$package})
1236 $unused_sub_packages{$package} = 1;
1237 if (defined @{$package.'::ISA'})
1239 foreach my $isa (@{$package.'::ISA'})
1241 if ($isa eq 'DynaLoader')
1243 unless (defined(&{$package.'::bootstrap'}))
1245 warn "Forcing bootstrap of $package\n";
1246 eval { $package->bootstrap };
1251 unless ($unused_sub_packages{$isa})
1253 warn "$isa saved (it is in $package\'s \@ISA)\n";
1265 no strict qw(vars refs);
1266 my $package = shift;
1267 $package =~ s/::$//;
1268 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1269 # warn "Considering $package\n";#debug
1270 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1272 # If this package is a prefix to something we are saving, traverse it
1273 # but do not mark it for saving if it is not already
1274 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1276 return 1 if ($u =~ /^$package\:\:/);
1278 if (exists $unused_sub_packages{$package})
1280 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1281 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1282 return $unused_sub_packages{$package};
1284 # Omit the packages which we use (and which cause grief
1285 # because of fancy "goto &$AUTOLOAD" stuff).
1286 # XXX Surely there must be a nicer way to do this.
1287 if ($package eq "FileHandle" || $package eq "Config" ||
1288 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1290 delete_unsaved_hashINC($package);
1291 return $unused_sub_packages{$package} = 0;
1293 # Now see if current package looks like an OO class this is probably too strong.
1294 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1296 if ($package->can($m))
1298 warn "$package has method $m: saving package\n";#debug
1299 return mark_package($package);
1302 delete_unsaved_hashINC($package);
1303 return $unused_sub_packages{$package} = 0;
1305 sub delete_unsaved_hashINC{
1307 $packname =~ s/\:\:/\//g;
1309 # warn "deleting $packname" if $INC{$packname} ;# debug
1310 delete $INC{$packname};
1314 my ($symref, $recurse, $prefix) = @_;
1319 $prefix = '' unless defined $prefix;
1320 while (($sym, $ref) = each %$symref)
1325 $sym = $prefix . $sym;
1326 if ($sym ne "main::" && &$recurse($sym))
1328 walkpackages(\%glob, $recurse, $sym);
1335 sub save_unused_subs
1338 &descend_marked_unused;
1340 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1341 warn "Saving methods\n";
1342 walksymtable(\%{"main::"}, "savecv", \&should_save);
1347 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1348 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1349 my $inc_hv = svref_2object(\%INC)->save;
1350 my $inc_av = svref_2object(\@INC)->save;
1351 my $amagic_generate= amagic_generation;
1352 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1353 "GvHV(PL_incgv) = $inc_hv;",
1354 "GvAV(PL_incgv) = $inc_av;",
1355 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1356 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1357 "PL_amagic_generation= $amagic_generate;" );
1360 sub descend_marked_unused {
1361 foreach my $pack (keys %unused_sub_packages)
1363 mark_package($pack);
1368 warn "Starting compile\n";
1369 warn "Walking tree\n";
1370 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1371 walkoptree(main_root, "save");
1372 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1374 my $init_av = init_av->save;
1375 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1376 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1377 "PL_initav = (AV *) $init_av;");
1379 warn "Writing output\n";
1380 output_boilerplate();
1382 output_all("perl_init");
1388 my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1389 binop => \$binopsect, condop => \$condopsect,
1390 cop => \$copsect, padop => \$padopsect,
1391 listop => \$listopsect, logop => \$logopsect,
1392 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1393 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1394 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1395 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1396 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1397 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1398 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1399 xpvio => \$xpviosect);
1400 my ($name, $sectref);
1401 while (($name, $sectref) = splice(@sections, 0, 2)) {
1402 $$sectref = new B::C::Section $name, \%symtable, 0;
1408 my ($arg,$val) = @_;
1409 $unused_sub_packages{$arg} = $val;
1414 my ($option, $opt, $arg);
1416 while ($option = shift @options) {
1417 if ($option =~ /^-(.)(.*)/) {
1421 unshift @options, $option;
1424 if ($opt eq "-" && $arg eq "-") {
1429 $warn_undefined_syms = 1;
1430 } elsif ($opt eq "D") {
1431 $arg ||= shift @options;
1432 foreach $arg (split(//, $arg)) {
1435 } elsif ($arg eq "c") {
1437 } elsif ($arg eq "A") {
1439 } elsif ($arg eq "C") {
1441 } elsif ($arg eq "M") {
1444 warn "ignoring unknown debug option: $arg\n";
1447 } elsif ($opt eq "o") {
1448 $arg ||= shift @options;
1449 open(STDOUT, ">$arg") or return "$arg: $!\n";
1450 } elsif ($opt eq "v") {
1452 } elsif ($opt eq "u") {
1453 $arg ||= shift @options;
1454 mark_unused($arg,undef);
1455 } elsif ($opt eq "f") {
1456 $arg ||= shift @options;
1457 if ($arg eq "cog") {
1458 $pv_copy_on_grow = 1;
1459 } elsif ($arg eq "no-cog") {
1460 $pv_copy_on_grow = 0;
1462 } elsif ($opt eq "O") {
1463 $arg = 1 if $arg eq "";
1464 $pv_copy_on_grow = 0;
1466 # Optimisations for -O1
1467 $pv_copy_on_grow = 1;
1475 foreach $objname (@options) {
1476 eval "save_object(\\$objname)";
1481 return sub { save_main() };
1491 B::C - Perl compiler's C backend
1495 perl -MO=C[,OPTIONS] foo.pl
1499 This compiler backend takes Perl source and generates C source code
1500 corresponding to the internal structures that perl uses to run
1501 your program. When the generated C source is compiled and run, it
1502 cuts out the time which perl would have taken to load and parse
1503 your program into its internal semi-compiled form. That means that
1504 compiling with this backend will not help improve the runtime
1505 execution speed of your program but may improve the start-up time.
1506 Depending on the environment in which your program runs this may be
1507 either a help or a hindrance.
1511 If there are any non-option arguments, they are taken to be
1512 names of objects to be saved (probably doesn't work properly yet).
1513 Without extra arguments, it saves the main program.
1519 Output to filename instead of STDOUT
1523 Verbose compilation (currently gives a few compilation statistics).
1527 Force end of options
1531 Force apparently unused subs from package Packname to be compiled.
1532 This allows programs to use eval "foo()" even when sub foo is never
1533 seen to be used at compile time. The down side is that any subs which
1534 really are never used also have code generated. This option is
1535 necessary, for example, if you have a signal handler foo which you
1536 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1537 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1538 options. The compiler tries to figure out which packages may possibly
1539 have subs in which need compiling but the current version doesn't do
1540 it very well. In particular, it is confused by nested packages (i.e.
1541 of the form C<A::B>) where package C<A> does not contain any subs.
1545 Debug options (concatenated or separate flags like C<perl -D>).
1549 OPs, prints each OP as it's processed
1553 COPs, prints COPs as processed (incl. file & line num)
1557 prints AV information on saving
1561 prints CV information on saving
1565 prints MAGIC information on saving
1569 Force optimisations on or off one at a time.
1573 Copy-on-grow: PVs declared and initialised statically.
1581 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
1582 B<-O1> and higher set B<-fcog>.
1586 perl -MO=C,-ofoo.c foo.pl
1587 perl cc_harness -o foo foo.c
1589 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1590 library directory. The utility called C<perlcc> may also be used to
1591 help make use of this compiler.
1593 perl -MO=C,-v,-DcA bar.pl > /dev/null
1597 Plenty. Current status: experimental.
1601 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>