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);
65 my $anonsub_index = 0;
66 my $initsub_index = 0;
70 my $warn_undefined_syms;
72 my %unused_sub_packages;
74 my $pv_copy_on_grow = 0;
75 my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
80 @threadsv_names = threadsv_names();
84 my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect,
85 $padopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
86 $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
87 $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
88 $xrvsect, $xpvbmsect, $xpviosect );
90 sub walk_and_save_optree;
91 my $saveoptree_callback = \&walk_and_save_optree;
92 sub set_callback { $saveoptree_callback = shift }
93 sub saveoptree { &$saveoptree_callback(@_) }
95 sub walk_and_save_optree {
96 my ($name, $root, $start) = @_;
97 walkoptree($root, "save");
98 return objsym($start);
101 # Current workaround/fix for op_free() trying to free statically
102 # defined OPs is to set op_seq = -1 and check for that in op_free().
103 # Instead of hardwiring -1 in place of $op->seq, we use $op_seq
104 # so that it can be changed back easily if necessary. In fact, to
105 # stop compilers from moaning about a U16 being initialised with an
106 # uncast -1 (the printf format is %d so we can't tweak it), we have
107 # to "know" that op_seq is a U16 and use 65535. Ugh.
110 # Look this up here so we can do just a number compare
111 # rather than looking up the name of every BASEOP in B::OP
112 my $OP_THREADSV = opnumber('threadsv');
115 my ($obj, $value) = @_;
116 my $sym = sprintf("s\\_%x", $$obj);
117 $symtable{$sym} = $value;
122 return $symtable{sprintf("s\\_%x", $$obj)};
129 return 0 if $sym eq "sym_0"; # special case
130 $value = $symtable{$sym};
131 if (defined($value)) {
134 warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
141 $pv = '' unless defined $pv; # Is this sane ?
144 if ($pv_copy_on_grow) {
145 my $cstring = cstring($pv);
146 if ($cstring ne "0") { # sic
147 $pvsym = sprintf("pv%d", $pv_index++);
148 $decl->add(sprintf("static char %s[] = %s;", $pvsym, $cstring));
151 $pvmax = length($pv) + 1;
153 return ($pvsym, $pvmax);
157 my ($op, $level) = @_;
158 my $sym = objsym($op);
159 return $sym if defined $sym;
160 my $type = $op->type;
161 $nullop_count++ unless $type;
162 if ($type == $OP_THREADSV) {
163 # saves looking up ppaddr but it's a bit naughty to hard code this
164 $init->add(sprintf("(void)find_threadsv(%s);",
165 cstring($threadsv_names[$op->targ])));
167 $opsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x",
168 ${$op->next}, ${$op->sibling}, $op->targ,
169 $type, $op_seq, $op->flags, $op->private));
170 my $ix = $opsect->index;
171 $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr));
172 savesym($op, "&op_list[$ix]");
176 my ($class, %objdata) = @_;
177 bless \%objdata, $class;
180 sub B::FAKEOP::save {
181 my ($op, $level) = @_;
182 $opsect->add(sprintf("%s, %s, NULL, %u, %u, %u, 0x%x, 0x%x",
183 $op->next, $op->sibling, $op->targ,
184 $op->type, $op_seq, $op->flags, $op->private));
185 my $ix = $opsect->index;
186 $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr));
187 return "&op_list[$ix]";
190 sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
191 sub B::FAKEOP::type { $_[0]->{type} || 0}
192 sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
193 sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
194 sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
195 sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
196 sub B::FAKEOP::private { $_[0]->{private} || 0 }
199 my ($op, $level) = @_;
200 my $sym = objsym($op);
201 return $sym if defined $sym;
202 $unopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x",
203 ${$op->next}, ${$op->sibling},
204 $op->targ, $op->type, $op_seq, $op->flags,
205 $op->private, ${$op->first}));
206 my $ix = $unopsect->index;
207 $init->add(sprintf("unop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
208 savesym($op, "(OP*)&unop_list[$ix]");
212 my ($op, $level) = @_;
213 my $sym = objsym($op);
214 return $sym if defined $sym;
215 $binopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
216 ${$op->next}, ${$op->sibling},
217 $op->targ, $op->type, $op_seq, $op->flags,
218 $op->private, ${$op->first}, ${$op->last}));
219 my $ix = $binopsect->index;
220 $init->add(sprintf("binop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
221 savesym($op, "(OP*)&binop_list[$ix]");
224 sub B::LISTOP::save {
225 my ($op, $level) = @_;
226 my $sym = objsym($op);
227 return $sym if defined $sym;
228 $listopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u",
229 ${$op->next}, ${$op->sibling},
230 $op->targ, $op->type, $op_seq, $op->flags,
231 $op->private, ${$op->first}, ${$op->last},
233 my $ix = $listopsect->index;
234 $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
235 savesym($op, "(OP*)&listop_list[$ix]");
239 my ($op, $level) = @_;
240 my $sym = objsym($op);
241 return $sym if defined $sym;
242 $logopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
243 ${$op->next}, ${$op->sibling},
244 $op->targ, $op->type, $op_seq, $op->flags,
245 $op->private, ${$op->first}, ${$op->other}));
246 my $ix = $logopsect->index;
247 $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
248 savesym($op, "(OP*)&logop_list[$ix]");
252 my ($op, $level) = @_;
253 my $sym = objsym($op);
254 return $sym if defined $sym;
255 #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
256 # peekop($op->redoop), peekop($op->nextop),
257 # peekop($op->lastop)); # debug
258 $loopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, s\\_%x, s\\_%x, s\\_%x",
259 ${$op->next}, ${$op->sibling},
260 $op->targ, $op->type, $op_seq, $op->flags,
261 $op->private, ${$op->first}, ${$op->last},
262 $op->children, ${$op->redoop}, ${$op->nextop},
264 my $ix = $loopsect->index;
265 $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
266 savesym($op, "(OP*)&loop_list[$ix]");
270 my ($op, $level) = @_;
271 my $sym = objsym($op);
272 return $sym if defined $sym;
273 $pvopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, %s",
274 ${$op->next}, ${$op->sibling},
275 $op->targ, $op->type, $op_seq, $op->flags,
276 $op->private, cstring($op->pv)));
277 my $ix = $pvopsect->index;
278 $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
279 savesym($op, "(OP*)&pvop_list[$ix]");
283 my ($op, $level) = @_;
284 my $sym = objsym($op);
285 return $sym if defined $sym;
286 my $svsym = $op->sv->save;
287 $svopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, Nullsv",
288 ${$op->next}, ${$op->sibling},
289 $op->targ, $op->type, $op_seq, $op->flags,
291 my $ix = $svopsect->index;
292 $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
293 $init->add("svop_list[$ix].op_sv = (SV*)$svsym;");
294 savesym($op, "(OP*)&svop_list[$ix]");
298 my ($op, $level) = @_;
299 my $sym = objsym($op);
300 return $sym if defined $sym;
301 $padopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, 0",
302 ${$op->next}, ${$op->sibling},
303 $op->targ, $op->type, $op_seq, $op->flags,
305 $init->add(sprintf("padop_list[%d].op_ppaddr = %s;", $padopsect->index, $op->ppaddr));
306 my $ix = $padopsect->index;
307 $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix));
308 savesym($op, "(OP*)&padop_list[$ix]");
312 my ($op, $level) = @_;
313 my $sym = objsym($op);
314 return $sym if defined $sym;
315 warn sprintf("COP: line %d file %s\n", $op->line, $op->file)
317 $copsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, %s, NULL, NULL, %u, %d, %u",
318 ${$op->next}, ${$op->sibling},
319 $op->targ, $op->type, $op_seq, $op->flags,
320 $op->private, cstring($op->label), $op->cop_seq,
321 $op->arybase, $op->line));
322 my $ix = $copsect->index;
323 $init->add(sprintf("cop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
324 $init->add(sprintf("CopFILE_set(&cop_list[$ix], %s);", cstring($op->file)),
325 sprintf("CopSTASHPV_set(&cop_list[$ix], %s);", cstring($op->stashpv)));
326 savesym($op, "(OP*)&cop_list[$ix]");
330 my ($op, $level) = @_;
331 my $sym = objsym($op);
332 return $sym if defined $sym;
333 my $replroot = $op->pmreplroot;
334 my $replstart = $op->pmreplstart;
335 my $replrootfield = sprintf("s\\_%x", $$replroot);
336 my $replstartfield = sprintf("s\\_%x", $$replstart);
338 my $ppaddr = $op->ppaddr;
340 # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
341 # argument to a split) stores a GV in op_pmreplroot instead
342 # of a substitution syntax tree. We don't want to walk that...
343 if ($op->name eq "pushre") {
344 $gvsym = $replroot->save;
345 # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
348 $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
351 # pmnext handling is broken in perl itself, I think. Bad op_pmnext
352 # fields aren't noticed in perl's runtime (unless you try reset) but we
353 # segfault when trying to dereference it to find op->op_pmnext->op_type
354 $pmopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, %s, %s, 0, 0, 0x%x, 0x%x",
355 ${$op->next}, ${$op->sibling}, $op->targ,
356 $op->type, $op_seq, $op->flags, $op->private,
357 ${$op->first}, ${$op->last}, $op->children,
358 $replrootfield, $replstartfield,
359 $op->pmflags, $op->pmpermflags,));
360 my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
361 $init->add(sprintf("$pm.op_ppaddr = %s;", $ppaddr));
362 my $re = $op->precomp;
364 my $resym = sprintf("re%d", $re_index++);
365 $decl->add(sprintf("static char *$resym = %s;", cstring($re)));
366 $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
370 $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
372 savesym($op, "(OP*)&$pm");
375 sub B::SPECIAL::save {
377 # special case: $$sv is not the address but an index into specialsv_list
378 # warn "SPECIAL::save specialsv $$sv\n"; # debug
379 my $sym = $specialsv_name[$$sv];
380 if (!defined($sym)) {
381 confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
386 sub B::OBJECT::save {}
390 my $sym = objsym($sv);
391 return $sym if defined $sym;
392 # warn "Saving SVt_NULL SV\n"; # debug
395 warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
396 return savesym($sv, "Nullsv /* XXX */");
398 $svsect->add(sprintf("0, %u, 0x%x", $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;
406 $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
407 $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
408 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
409 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
414 my $sym = objsym($sv);
415 return $sym if defined $sym;
417 $val .= '.00' if $val =~ /^-?\d+$/;
418 $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
419 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
420 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
421 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
427 if (defined $max_string_len && length($pv) > $max_string_len) {
428 push @res, sprintf("New(0,%s,%u,char);", $dest, length($pv)+1);
431 my $str = substr $pv, 0, $max_string_len, '';
432 push @res, sprintf("Copy(%s,$dest+$offset,%u,char);",
433 cstring($str), length($str));
434 $offset += length $str;
436 push @res, sprintf("%s[%u] = '\\0';", $dest, $offset);
439 push @res, sprintf("%s = savepvn(%s, %u);", $dest,
440 cstring($pv), length($pv));
447 my $sym = objsym($sv);
448 return $sym if defined $sym;
450 my $len = length($pv);
451 my ($pvsym, $pvmax) = savepv($pv);
452 my ($lvtarg, $lvtarg_sym);
453 $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
454 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
455 $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
456 $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
457 $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS));
458 if (!$pv_copy_on_grow) {
459 $init->add(savepvn(sprintf("xpvlv_list[%d].xpv_pv",
460 $xpvlvsect->index), $pv));
463 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
468 my $sym = objsym($sv);
469 return $sym if defined $sym;
471 my $len = length($pv);
472 my ($pvsym, $pvmax) = savepv($pv);
473 $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
474 $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
475 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
476 if (!$pv_copy_on_grow) {
477 $init->add(savepvn(sprintf("xpviv_list[%d].xpv_pv",
478 $xpvivsect->index), $pv));
480 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
485 my $sym = objsym($sv);
486 return $sym if defined $sym;
488 $pv = '' unless defined $pv;
489 my $len = length($pv);
490 my ($pvsym, $pvmax) = savepv($pv);
492 $val .= '.00' if $val =~ /^-?\d+$/;
493 $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
494 $pvsym, $len, $pvmax, $sv->IVX, $val));
495 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
496 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
497 if (!$pv_copy_on_grow) {
498 $init->add(savepvn(sprintf("xpvnv_list[%d].xpv_pv",
499 $xpvnvsect->index), $pv));
501 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
506 my $sym = objsym($sv);
507 return $sym if defined $sym;
508 my $pv = $sv->PV . "\0" . $sv->TABLE;
509 my $len = length($pv);
510 $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
511 $len, $len + 258, $sv->IVX, $sv->NVX,
512 $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
513 $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
514 $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS));
516 $init->add(savepvn(sprintf("xpvbm_list[%d].xpv_pv",
517 $xpvbmsect->index), $pv),
518 sprintf("xpvbm_list[%d].xpv_cur = %u;",
519 $xpvbmsect->index, $len - 257));
520 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
525 my $sym = objsym($sv);
526 return $sym if defined $sym;
528 my $len = length($pv);
529 my ($pvsym, $pvmax) = savepv($pv);
530 $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
531 $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
532 $xpvsect->index, $sv->REFCNT , $sv->FLAGS));
533 if (!$pv_copy_on_grow) {
534 $init->add(savepvn(sprintf("xpv_list[%d].xpv_pv",
535 $xpvsect->index), $pv));
537 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
542 my $sym = objsym($sv);
543 return $sym if defined $sym;
545 my $len = length($pv);
546 my ($pvsym, $pvmax) = savepv($pv);
547 $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
548 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
549 $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
550 $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS));
551 if (!$pv_copy_on_grow) {
552 $init->add(savepvn(sprintf("xpvmg_list[%d].xpv_pv",
553 $xpvmgsect->index), $pv));
555 $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
560 sub B::PVMG::save_magic {
562 #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
563 my $stash = $sv->SvSTASH;
566 warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
568 # XXX Hope stash is already going to be saved.
569 $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
571 my @mgchain = $sv->MAGIC;
572 my ($mg, $type, $obj, $ptr,$len,$ptrsv);
573 foreach $mg (@mgchain) {
579 warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
580 class($sv), $$sv, class($obj), $$obj,
581 cchar($type), cstring($ptr));
584 if ($len == HEf_SVKEY){
585 #The pointer is an SV*
586 $ptrsv=svref_2object($ptr)->save;
587 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
588 $$sv, $$obj, cchar($type),$ptrsv,$len));
590 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
591 $$sv, $$obj, cchar($type),cstring($ptr),$len));
598 my $sym = objsym($sv);
599 return $sym if defined $sym;
600 my $rv = $sv->RV->save;
601 $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/;
603 $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
604 $xrvsect->index, $sv->REFCNT , $sv->FLAGS));
605 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
609 my ($cvstashname, $cvname) = @_;
610 warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
611 # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
612 # use should be handled by the class itself.
614 my $isa = \@{"$cvstashname\::ISA"};
615 if (grep($_ eq "AutoLoader", @$isa)) {
616 warn "Forcing immediate load of sub derived from AutoLoader\n";
617 # Tweaked version of AutoLoader::AUTOLOAD
618 my $dir = $cvstashname;
620 eval { require "auto/$dir/$cvname.al" };
622 warn qq(failed require "auto/$dir/$cvname.al": $@\n);
632 my $sym = objsym($cv);
634 # warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
637 # Reserve a place in svsect and xpvcvsect and record indices
639 my ($cvname, $cvstashname);
642 $cvstashname = $gv->STASH->NAME;
644 my $root = $cv->ROOT;
645 my $cvxsub = $cv->XSUB;
646 #INIT is removed from the symbol table, so this call must come
647 # from PL_initav->save. Re-bootstrapping will push INIT back in
648 # so nullop should be sent.
649 if ($cvxsub && ($cvname ne "INIT")) {
651 my $stashname = $egv->STASH->NAME;
652 if ($cvname eq "bootstrap")
654 my $file = $gv->FILE;
655 $decl->add("/* bootstrap $file */");
656 warn "Bootstrap $stashname $file\n";
657 $xsub{$stashname}='Dynamic';
658 # $xsub{$stashname}='Static' unless $xsub{$stashname};
661 warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv;
662 return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/;
664 if ($cvxsub && $cvname eq "INIT") {
666 return svref_2object(\&Dummy_initxs)->save;
668 my $sv_ix = $svsect->index + 1;
669 $svsect->add("svix$sv_ix");
670 my $xpvcv_ix = $xpvcvsect->index + 1;
671 $xpvcvsect->add("xpvcvix$xpvcv_ix");
672 # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
673 $sym = savesym($cv, "&sv_list[$sv_ix]");
674 warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv;
675 if (!$$root && !$cvxsub) {
676 if (try_autoload($cvstashname, $cvname)) {
677 # Recalculate root and xsub
680 if ($$root || $cvxsub) {
681 warn "Successful forced autoload\n";
686 my $padlist = $cv->PADLIST;
689 my $xsubany = "Nullany";
691 warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
692 $$cv, $$root) if $debug_cv;
695 my $stashname = $gv->STASH->NAME;
696 my $gvname = $gv->NAME;
697 if ($gvname ne "__ANON__") {
698 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
699 $ppname .= ($stashname eq "main") ?
700 $gvname : "$stashname\::$gvname";
701 $ppname =~ s/::/__/g;
702 if ($gvname eq "INIT"){
703 $ppname .= "_$initsub_index";
709 $ppname = "pp_anonsub_$anonsub_index";
712 $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
713 warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
714 $$cv, $ppname, $$root) if $debug_cv;
716 warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
717 $$padlist, $$cv) if $debug_cv;
719 warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
720 $$padlist, $$cv) if $debug_cv;
724 warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
725 $cvstashname, $cvname); # debug
727 $pv = '' unless defined $pv; # Avoid use of undef warnings
728 $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, \"\", %d, s\\_%x, (CV*)s\\_%x, 0x%x",
729 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
730 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
731 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
733 if (${$cv->OUTSIDE} == ${main_cv()}){
734 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
735 $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
740 $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
741 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
742 $$gv, $$cv) if $debug_cv;
744 $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE)));
745 my $stash = $cv->STASH;
748 $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
749 warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
750 $$stash, $$cv) if $debug_cv;
752 $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
753 $sv_ix, $xpvcv_ix, $cv->REFCNT +1 , $cv->FLAGS));
759 my $sym = objsym($gv);
761 #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
764 my $ix = $gv_index++;
765 $sym = savesym($gv, "gv_list[$ix]");
766 #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
768 my $is_empty = $gv->is_empty;
769 my $gvname = $gv->NAME;
770 my $name = cstring($gv->STASH->NAME . "::" . $gvname);
771 #warn "GV name is $name\n"; # debug
776 #warn(sprintf("EGV name is %s, saving it now\n",
777 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
778 $egvsym = $egv->save;
781 $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
782 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
783 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS));
784 $init->add(sprintf("GvLINE($sym) = %u;", $gv->LINE)) unless $is_empty;
786 # Shouldn't need to do save_magic since gv_fetchpv handles that
788 my $refcnt = $gv->REFCNT + 1;
789 $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
791 return $sym if $is_empty;
793 my $gvrefcnt = $gv->GvREFCNT;
795 $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
797 if (defined($egvsym)) {
798 # Shared glob *foo = *bar
799 $init->add("gp_free($sym);",
800 "GvGP($sym) = GvGP($egvsym);");
801 } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
802 # Don't save subfields of special GVs (*_, *1, *# and so on)
803 # warn "GV::save saving subfields\n"; # debug
807 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
808 # warn "GV::save \$$name\n"; # debug
813 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
814 # warn "GV::save \@$name\n"; # debug
819 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
820 # warn "GV::save \%$name\n"; # debug
824 my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
825 "::" . $gvcv->GV->EGV->NAME);
826 if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias
827 # must save as a 'stub' so newXS() has a CV to populate
828 $init->add("{ CV *cv;");
829 $init->add("\tcv=perl_get_cv($origname,TRUE);");
830 $init->add("\tGvCV($sym)=cv;");
831 $init->add("\tSvREFCNT_inc((SV *)cv);");
834 $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
835 # warn "GV::save &$name\n"; # debug
838 $init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE)));
839 # warn "GV::save GvFILE(*$name)\n"; # debug
840 my $gvform = $gv->FORM;
843 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
844 # warn "GV::save GvFORM(*$name)\n"; # debug
849 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
850 # warn "GV::save GvIO(*$name)\n"; # debug
857 my $sym = objsym($av);
858 return $sym if defined $sym;
859 my $avflags = $av->AvFLAGS;
860 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
862 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
863 $xpvavsect->index, $av->REFCNT , $av->FLAGS));
864 my $sv_list_index = $svsect->index;
865 my $fill = $av->FILL;
867 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
869 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
870 #if ($fill > -1 && ($avflags & AVf_REAL)) {
872 my @array = $av->ARRAY;
876 foreach $el (@array) {
877 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
878 $$av, $i++, class($el), $$el);
881 my @names = map($_->save, @array);
882 # XXX Better ways to write loop?
883 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
884 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
887 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
888 "\tav_extend(av, $fill);",
889 "\tsvp = AvARRAY(av);",
890 map("\t*svp++ = (SV*)$_;", @names),
891 "\tAvFILLp(av) = $fill;",
895 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
898 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
903 my $sym = objsym($hv);
904 return $sym if defined $sym;
905 my $name = $hv->NAME;
909 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
910 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
911 # a trashed op but we look at the trashed op_type and segfault.
912 #my $adpmroot = ${$hv->PMROOT};
914 $decl->add("static HV *hv$hv_index;");
915 # XXX Beware of weird package names containing double-quotes, \n, ...?
916 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
918 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
921 $sym = savesym($hv, "hv$hv_index");
925 # It's just an ordinary HV
926 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
927 $hv->MAX, $hv->RITER));
928 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
929 $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS));
930 my $sv_list_index = $svsect->index;
931 my @contents = $hv->ARRAY;
934 for ($i = 1; $i < @contents; $i += 2) {
935 $contents[$i] = $contents[$i]->save;
937 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
939 my ($key, $value) = splice(@contents, 0, 2);
940 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
941 cstring($key),length($key),$value, hash($key)));
942 # $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
943 # cstring($key),length($key),$value, 0));
948 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
953 my $sym = objsym($io);
954 return $sym if defined $sym;
956 $pv = '' unless defined $pv;
957 my $len = length($pv);
958 $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",
959 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
960 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
961 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
962 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
963 cchar($io->IoTYPE), $io->IoFLAGS));
964 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
965 $xpviosect->index, $io->REFCNT , $io->FLAGS));
966 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
968 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
969 $fsym = $io->$field();
971 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
981 # This is where we catch an honest-to-goodness Nullsv (which gets
982 # blessed into B::SV explicitly) and any stray erroneous SVs.
983 return 0 unless $$sv;
984 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
989 my $init_name = shift;
991 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
992 $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect,
993 $loopsect, $copsect, $svsect, $xpvsect,
994 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
995 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
996 $symsect->output(\*STDOUT, "#define %s\n");
998 output_declarations();
999 foreach $section (@sections) {
1000 my $lines = $section->index + 1;
1002 my $name = $section->name;
1003 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
1004 print "Static $typename ${name}_list[$lines];\n";
1007 $decl->output(\*STDOUT, "%s\n");
1009 foreach $section (@sections) {
1010 my $lines = $section->index + 1;
1012 my $name = $section->name;
1013 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
1014 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
1015 $section->output(\*STDOUT, "\t{ %s },\n");
1021 static int $init_name()
1026 $init->output(\*STDOUT, "\t%s\n");
1027 print "\treturn 0;\n}\n";
1029 warn compile_stats();
1030 warn "NULLOP count: $nullop_count\n";
1034 sub output_declarations {
1036 #ifdef BROKEN_STATIC_REDECL
1037 #define Static extern
1039 #define Static static
1040 #endif /* BROKEN_STATIC_REDECL */
1042 #ifdef BROKEN_UNION_INIT
1044 * Cribbed from cv.h with ANY (a union) replaced by void*.
1045 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
1048 char * xpv_pv; /* pointer to malloced string */
1049 STRLEN xpv_cur; /* length of xp_pv as a C string */
1050 STRLEN xpv_len; /* allocated size */
1051 IV xof_off; /* integer value */
1052 double xnv_nv; /* numeric value, if any */
1053 MAGIC* xmg_magic; /* magic for scalar array */
1054 HV* xmg_stash; /* class package */
1059 void (*xcv_xsub) (CV*);
1063 long xcv_depth; /* >= 2 indicates recursive call */
1067 perl_mutex *xcv_mutexp;
1068 struct perl_thread *xcv_owner; /* current owner thread */
1069 #endif /* USE_THREADS */
1070 cv_flags_t xcv_flags;
1072 #define ANYINIT(i) i
1074 #define XPVCV_or_similar XPVCV
1075 #define ANYINIT(i) {i}
1076 #endif /* BROKEN_UNION_INIT */
1077 #define Nullany ANYINIT(0)
1083 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1088 sub output_boilerplate {
1094 /* Workaround for mapstart: the only op which needs a different ppaddr */
1095 #undef Perl_pp_mapstart
1096 #define Perl_pp_mapstart Perl_pp_grepstart
1097 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1098 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
1100 static void xs_init (pTHX);
1101 static void dl_init (pTHX);
1102 static PerlInterpreter *my_perl;
1109 main(int argc, char **argv, char **env)
1115 PERL_SYS_INIT3(&argc,&argv,&env);
1117 if (!PL_do_undump) {
1118 my_perl = perl_alloc();
1121 perl_construct( my_perl );
1122 PL_perl_destruct_level = 0;
1127 PL_cshlen = strlen(PL_cshname);
1130 #ifdef ALLOW_PERL_OPTIONS
1131 #define EXTRA_OPTIONS 2
1133 #define EXTRA_OPTIONS 3
1134 #endif /* ALLOW_PERL_OPTIONS */
1135 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1136 fakeargv[0] = argv[0];
1139 #ifndef ALLOW_PERL_OPTIONS
1141 #endif /* ALLOW_PERL_OPTIONS */
1142 for (i = 1; i < argc; i++)
1143 fakeargv[i + EXTRA_OPTIONS] = argv[i];
1144 fakeargv[argc + EXTRA_OPTIONS] = 0;
1146 exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1151 sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1152 PL_main_cv = PL_compcv;
1155 exitstatus = perl_init();
1160 exitstatus = perl_run( my_perl );
1162 perl_destruct( my_perl );
1163 perl_free( my_perl );
1170 /* yanked from perl.c */
1174 char *file = __FILE__;
1178 print "\n#ifdef USE_DYNAMIC_LOADING";
1179 print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1180 print "\n#endif\n" ;
1181 # delete $xsub{'DynaLoader'};
1182 delete $xsub{'UNIVERSAL'};
1183 print("/* bootstrapping code*/\n\tSAVETMPS;\n");
1184 print("\ttarg=sv_newmortal();\n");
1185 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1186 print "\tPUSHMARK(sp);\n";
1187 print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
1188 print qq/\tPUTBACK;\n/;
1189 print "\tboot_DynaLoader(aTHX_ NULL);\n";
1190 print qq/\tSPAGAIN;\n/;
1192 foreach my $stashname (keys %xsub){
1193 if ($xsub{$stashname} ne 'Dynamic') {
1194 my $stashxsub=$stashname;
1195 $stashxsub =~ s/::/__/g;
1196 print "\tPUSHMARK(sp);\n";
1197 print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
1198 print qq/\tPUTBACK;\n/;
1199 print "\tboot_$stashxsub(aTHX_ NULL);\n";
1200 print qq/\tSPAGAIN;\n/;
1203 print("\tFREETMPS;\n/* end bootstrapping code */\n");
1210 char *file = __FILE__;
1214 print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
1215 print("\ttarg=sv_newmortal();\n");
1216 foreach my $stashname (@DynaLoader::dl_modules) {
1217 warn "Loaded $stashname\n";
1218 if (exists($xsub{$stashname}) && $xsub{$stashname} eq 'Dynamic') {
1219 my $stashxsub=$stashname;
1220 $stashxsub =~ s/::/__/g;
1221 print "\tPUSHMARK(sp);\n";
1222 print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
1223 print qq/\tPUTBACK;\n/;
1224 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1225 warn "bootstrapping $stashname added to xs_init\n";
1226 print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
1228 print "\tboot_$stashxsub(aTHX_ NULL);\n";
1230 print qq/\tSPAGAIN;\n/;
1233 print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
1239 warn "----Symbol table:\n";
1240 while (($sym, $val) = each %symtable) {
1241 warn "$sym => $val\n";
1243 warn "---End of symbol table\n";
1249 svref_2object($sv)->save;
1253 sub Dummy_BootStrap { }
1258 my $package=$gv->STASH->NAME;
1259 my $name = $gv->NAME;
1265 # We may be looking at this package just because it is a branch in the
1266 # symbol table which is on the path to a package which we need to save
1267 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1269 return unless ($unused_sub_packages{$package});
1270 return unless ($$cv || $$av || $$sv || $$hv);
1276 my $package = shift;
1277 unless ($unused_sub_packages{$package})
1280 $unused_sub_packages{$package} = 1;
1281 if (defined @{$package.'::ISA'})
1283 foreach my $isa (@{$package.'::ISA'})
1285 if ($isa eq 'DynaLoader')
1287 unless (defined(&{$package.'::bootstrap'}))
1289 warn "Forcing bootstrap of $package\n";
1290 eval { $package->bootstrap };
1295 unless ($unused_sub_packages{$isa})
1297 warn "$isa saved (it is in $package\'s \@ISA)\n";
1309 no strict qw(vars refs);
1310 my $package = shift;
1311 $package =~ s/::$//;
1312 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1313 # warn "Considering $package\n";#debug
1314 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1316 # If this package is a prefix to something we are saving, traverse it
1317 # but do not mark it for saving if it is not already
1318 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1320 return 1 if ($u =~ /^$package\:\:/);
1322 if (exists $unused_sub_packages{$package})
1324 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1325 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1326 return $unused_sub_packages{$package};
1328 # Omit the packages which we use (and which cause grief
1329 # because of fancy "goto &$AUTOLOAD" stuff).
1330 # XXX Surely there must be a nicer way to do this.
1331 if ($package eq "FileHandle" || $package eq "Config" ||
1332 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1334 delete_unsaved_hashINC($package);
1335 return $unused_sub_packages{$package} = 0;
1337 # Now see if current package looks like an OO class this is probably too strong.
1338 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1340 if (UNIVERSAL::can($package, $m))
1342 warn "$package has method $m: saving package\n";#debug
1343 return mark_package($package);
1346 delete_unsaved_hashINC($package);
1347 return $unused_sub_packages{$package} = 0;
1349 sub delete_unsaved_hashINC{
1351 $packname =~ s/\:\:/\//g;
1353 # warn "deleting $packname" if $INC{$packname} ;# debug
1354 delete $INC{$packname};
1358 my ($symref, $recurse, $prefix) = @_;
1363 $prefix = '' unless defined $prefix;
1364 while (($sym, $ref) = each %$symref)
1369 $sym = $prefix . $sym;
1370 if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym))
1372 walkpackages(\%glob, $recurse, $sym);
1379 sub save_unused_subs
1382 &descend_marked_unused;
1384 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1385 warn "Saving methods\n";
1386 walksymtable(\%{"main::"}, "savecv", \&should_save);
1391 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1392 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1393 my $inc_hv = svref_2object(\%INC)->save;
1394 my $inc_av = svref_2object(\@INC)->save;
1395 my $amagic_generate= amagic_generation;
1396 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1397 "GvHV(PL_incgv) = $inc_hv;",
1398 "GvAV(PL_incgv) = $inc_av;",
1399 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1400 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1401 "PL_amagic_generation= $amagic_generate;" );
1404 sub descend_marked_unused {
1405 foreach my $pack (keys %unused_sub_packages)
1407 mark_package($pack);
1412 warn "Starting compile\n";
1413 warn "Walking tree\n";
1414 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1415 walkoptree(main_root, "save");
1416 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1418 my $init_av = init_av->save;
1419 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1420 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1421 "PL_initav = (AV *) $init_av;");
1423 warn "Writing output\n";
1424 output_boilerplate();
1426 output_all("perl_init");
1432 my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1433 binop => \$binopsect, condop => \$condopsect,
1434 cop => \$copsect, padop => \$padopsect,
1435 listop => \$listopsect, logop => \$logopsect,
1436 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1437 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1438 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1439 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1440 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1441 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1442 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1443 xpvio => \$xpviosect);
1444 my ($name, $sectref);
1445 while (($name, $sectref) = splice(@sections, 0, 2)) {
1446 $$sectref = new B::C::Section $name, \%symtable, 0;
1452 my ($arg,$val) = @_;
1453 $unused_sub_packages{$arg} = $val;
1458 my ($option, $opt, $arg);
1460 while ($option = shift @options) {
1461 if ($option =~ /^-(.)(.*)/) {
1465 unshift @options, $option;
1468 if ($opt eq "-" && $arg eq "-") {
1473 $warn_undefined_syms = 1;
1474 } elsif ($opt eq "D") {
1475 $arg ||= shift @options;
1476 foreach $arg (split(//, $arg)) {
1479 } elsif ($arg eq "c") {
1481 } elsif ($arg eq "A") {
1483 } elsif ($arg eq "C") {
1485 } elsif ($arg eq "M") {
1488 warn "ignoring unknown debug option: $arg\n";
1491 } elsif ($opt eq "o") {
1492 $arg ||= shift @options;
1493 open(STDOUT, ">$arg") or return "$arg: $!\n";
1494 } elsif ($opt eq "v") {
1496 } elsif ($opt eq "u") {
1497 $arg ||= shift @options;
1498 mark_unused($arg,undef);
1499 } elsif ($opt eq "f") {
1500 $arg ||= shift @options;
1501 if ($arg eq "cog") {
1502 $pv_copy_on_grow = 1;
1503 } elsif ($arg eq "no-cog") {
1504 $pv_copy_on_grow = 0;
1506 } elsif ($opt eq "O") {
1507 $arg = 1 if $arg eq "";
1508 $pv_copy_on_grow = 0;
1510 # Optimisations for -O1
1511 $pv_copy_on_grow = 1;
1513 } elsif ($opt eq "l") {
1514 $max_string_len = $arg;
1521 foreach $objname (@options) {
1522 eval "save_object(\\$objname)";
1527 return sub { save_main() };
1537 B::C - Perl compiler's C backend
1541 perl -MO=C[,OPTIONS] foo.pl
1545 This compiler backend takes Perl source and generates C source code
1546 corresponding to the internal structures that perl uses to run
1547 your program. When the generated C source is compiled and run, it
1548 cuts out the time which perl would have taken to load and parse
1549 your program into its internal semi-compiled form. That means that
1550 compiling with this backend will not help improve the runtime
1551 execution speed of your program but may improve the start-up time.
1552 Depending on the environment in which your program runs this may be
1553 either a help or a hindrance.
1557 If there are any non-option arguments, they are taken to be
1558 names of objects to be saved (probably doesn't work properly yet).
1559 Without extra arguments, it saves the main program.
1565 Output to filename instead of STDOUT
1569 Verbose compilation (currently gives a few compilation statistics).
1573 Force end of options
1577 Force apparently unused subs from package Packname to be compiled.
1578 This allows programs to use eval "foo()" even when sub foo is never
1579 seen to be used at compile time. The down side is that any subs which
1580 really are never used also have code generated. This option is
1581 necessary, for example, if you have a signal handler foo which you
1582 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1583 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1584 options. The compiler tries to figure out which packages may possibly
1585 have subs in which need compiling but the current version doesn't do
1586 it very well. In particular, it is confused by nested packages (i.e.
1587 of the form C<A::B>) where package C<A> does not contain any subs.
1591 Debug options (concatenated or separate flags like C<perl -D>).
1595 OPs, prints each OP as it's processed
1599 COPs, prints COPs as processed (incl. file & line num)
1603 prints AV information on saving
1607 prints CV information on saving
1611 prints MAGIC information on saving
1615 Force optimisations on or off one at a time.
1619 Copy-on-grow: PVs declared and initialised statically.
1627 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
1628 B<-O1> and higher set B<-fcog>.
1632 Some C compilers impose an arbitrary limit on the length of string
1633 constants (e.g. 2048 characters for Microsoft Visual C++). The
1634 B<-llimit> options tells the C backend not to generate string literals
1635 exceeding that limit.
1641 perl -MO=C,-ofoo.c foo.pl
1642 perl cc_harness -o foo foo.c
1644 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1645 library directory. The utility called C<perlcc> may also be used to
1646 help make use of this compiler.
1648 perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null
1652 Plenty. Current status: experimental.
1656 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>