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.
10 our $VERSION = '1.00';
18 my $o = $class->SUPER::new(@_);
26 push(@{$section->[-1]},@_);
32 return scalar(@{$section->[-1]})-1;
37 my ($section, $fh, $format) = @_;
38 my $sym = $section->symtable || {};
39 my $default = $section->default;
40 foreach (@{$section->[-1]})
42 s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
43 printf $fh $format, $_;
50 @EXPORT_OK = qw(output_all output_boilerplate output_main mark_unused
51 init_sections set_callback save_unused_subs objsym save_context);
53 use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop
54 class cstring cchar svref_2object compile_stats comppadlist hash
55 threadsv_names main_cv init_av opnumber amagic_generation
57 use B::Asmdata qw(@specialsv_name);
68 my $anonsub_index = 0;
69 my $initsub_index = 0;
73 my $warn_undefined_syms;
75 my %unused_sub_packages;
77 my $pv_copy_on_grow = 0;
78 my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
83 @threadsv_names = threadsv_names();
87 my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect,
88 $padopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
89 $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
90 $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
91 $xrvsect, $xpvbmsect, $xpviosect );
93 sub walk_and_save_optree;
94 my $saveoptree_callback = \&walk_and_save_optree;
95 sub set_callback { $saveoptree_callback = shift }
96 sub saveoptree { &$saveoptree_callback(@_) }
98 sub walk_and_save_optree {
99 my ($name, $root, $start) = @_;
100 walkoptree($root, "save");
101 return objsym($start);
104 # Current workaround/fix for op_free() trying to free statically
105 # defined OPs is to set op_seq = -1 and check for that in op_free().
106 # Instead of hardwiring -1 in place of $op->seq, we use $op_seq
107 # so that it can be changed back easily if necessary. In fact, to
108 # stop compilers from moaning about a U16 being initialised with an
109 # uncast -1 (the printf format is %d so we can't tweak it), we have
110 # to "know" that op_seq is a U16 and use 65535. Ugh.
113 # Look this up here so we can do just a number compare
114 # rather than looking up the name of every BASEOP in B::OP
115 my $OP_THREADSV = opnumber('threadsv');
118 my ($obj, $value) = @_;
119 my $sym = sprintf("s\\_%x", $$obj);
120 $symtable{$sym} = $value;
125 return $symtable{sprintf("s\\_%x", $$obj)};
132 return 0 if $sym eq "sym_0"; # special case
133 $value = $symtable{$sym};
134 if (defined($value)) {
137 warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
144 $pv = '' unless defined $pv; # Is this sane ?
147 if ($pv_copy_on_grow) {
148 my $cstring = cstring($pv);
149 if ($cstring ne "0") { # sic
150 $pvsym = sprintf("pv%d", $pv_index++);
151 $decl->add(sprintf("static char %s[] = %s;", $pvsym, $cstring));
154 $pvmax = length($pv) + 1;
156 return ($pvsym, $pvmax);
160 my ($op, $level) = @_;
161 my $sym = objsym($op);
162 return $sym if defined $sym;
163 my $type = $op->type;
164 $nullop_count++ unless $type;
165 if ($type == $OP_THREADSV) {
166 # saves looking up ppaddr but it's a bit naughty to hard code this
167 $init->add(sprintf("(void)find_threadsv(%s);",
168 cstring($threadsv_names[$op->targ])));
170 $opsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x",
171 ${$op->next}, ${$op->sibling}, $op->targ,
172 $type, $op_seq, $op->flags, $op->private));
173 my $ix = $opsect->index;
174 $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr));
175 savesym($op, "&op_list[$ix]");
179 my ($class, %objdata) = @_;
180 bless \%objdata, $class;
183 sub B::FAKEOP::save {
184 my ($op, $level) = @_;
185 $opsect->add(sprintf("%s, %s, NULL, %u, %u, %u, 0x%x, 0x%x",
186 $op->next, $op->sibling, $op->targ,
187 $op->type, $op_seq, $op->flags, $op->private));
188 my $ix = $opsect->index;
189 $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr));
190 return "&op_list[$ix]";
193 sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
194 sub B::FAKEOP::type { $_[0]->{type} || 0}
195 sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
196 sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
197 sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
198 sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
199 sub B::FAKEOP::private { $_[0]->{private} || 0 }
202 my ($op, $level) = @_;
203 my $sym = objsym($op);
204 return $sym if defined $sym;
205 $unopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x",
206 ${$op->next}, ${$op->sibling},
207 $op->targ, $op->type, $op_seq, $op->flags,
208 $op->private, ${$op->first}));
209 my $ix = $unopsect->index;
210 $init->add(sprintf("unop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
211 savesym($op, "(OP*)&unop_list[$ix]");
215 my ($op, $level) = @_;
216 my $sym = objsym($op);
217 return $sym if defined $sym;
218 $binopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
219 ${$op->next}, ${$op->sibling},
220 $op->targ, $op->type, $op_seq, $op->flags,
221 $op->private, ${$op->first}, ${$op->last}));
222 my $ix = $binopsect->index;
223 $init->add(sprintf("binop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
224 savesym($op, "(OP*)&binop_list[$ix]");
227 sub B::LISTOP::save {
228 my ($op, $level) = @_;
229 my $sym = objsym($op);
230 return $sym if defined $sym;
231 $listopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
232 ${$op->next}, ${$op->sibling},
233 $op->targ, $op->type, $op_seq, $op->flags,
234 $op->private, ${$op->first}, ${$op->last}));
235 my $ix = $listopsect->index;
236 $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
237 savesym($op, "(OP*)&listop_list[$ix]");
241 my ($op, $level) = @_;
242 my $sym = objsym($op);
243 return $sym if defined $sym;
244 $logopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
245 ${$op->next}, ${$op->sibling},
246 $op->targ, $op->type, $op_seq, $op->flags,
247 $op->private, ${$op->first}, ${$op->other}));
248 my $ix = $logopsect->index;
249 $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
250 savesym($op, "(OP*)&logop_list[$ix]");
254 my ($op, $level) = @_;
255 my $sym = objsym($op);
256 return $sym if defined $sym;
257 #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
258 # peekop($op->redoop), peekop($op->nextop),
259 # peekop($op->lastop)); # debug
260 $loopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x",
261 ${$op->next}, ${$op->sibling},
262 $op->targ, $op->type, $op_seq, $op->flags,
263 $op->private, ${$op->first}, ${$op->last},
264 ${$op->redoop}, ${$op->nextop},
266 my $ix = $loopsect->index;
267 $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
268 savesym($op, "(OP*)&loop_list[$ix]");
272 my ($op, $level) = @_;
273 my $sym = objsym($op);
274 return $sym if defined $sym;
275 $pvopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, %s",
276 ${$op->next}, ${$op->sibling},
277 $op->targ, $op->type, $op_seq, $op->flags,
278 $op->private, cstring($op->pv)));
279 my $ix = $pvopsect->index;
280 $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
281 savesym($op, "(OP*)&pvop_list[$ix]");
285 my ($op, $level) = @_;
286 my $sym = objsym($op);
287 return $sym if defined $sym;
288 my $svsym = $op->sv->save;
289 $svopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, Nullsv",
290 ${$op->next}, ${$op->sibling},
291 $op->targ, $op->type, $op_seq, $op->flags,
293 my $ix = $svopsect->index;
294 $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
295 $init->add("svop_list[$ix].op_sv = (SV*)$svsym;");
296 savesym($op, "(OP*)&svop_list[$ix]");
300 my ($op, $level) = @_;
301 my $sym = objsym($op);
302 return $sym if defined $sym;
303 $padopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, 0",
304 ${$op->next}, ${$op->sibling},
305 $op->targ, $op->type, $op_seq, $op->flags,
307 $init->add(sprintf("padop_list[%d].op_ppaddr = %s;", $padopsect->index, $op->ppaddr));
308 my $ix = $padopsect->index;
309 $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix));
310 savesym($op, "(OP*)&padop_list[$ix]");
314 my ($op, $level) = @_;
315 my $sym = objsym($op);
316 return $sym if defined $sym;
317 warn sprintf("COP: line %d file %s\n", $op->line, $op->file)
319 $copsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, %s, NULL, NULL, %u, %d, %u",
320 ${$op->next}, ${$op->sibling},
321 $op->targ, $op->type, $op_seq, $op->flags,
322 $op->private, cstring($op->label), $op->cop_seq,
323 $op->arybase, $op->line));
324 my $ix = $copsect->index;
325 $init->add(sprintf("cop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
326 $init->add(sprintf("CopFILE_set(&cop_list[$ix], %s);", cstring($op->file)),
327 sprintf("CopSTASHPV_set(&cop_list[$ix], %s);", cstring($op->stashpv)));
328 savesym($op, "(OP*)&cop_list[$ix]");
332 my ($op, $level) = @_;
333 my $sym = objsym($op);
334 return $sym if defined $sym;
335 my $replroot = $op->pmreplroot;
336 my $replstart = $op->pmreplstart;
337 my $replrootfield = sprintf("s\\_%x", $$replroot);
338 my $replstartfield = sprintf("s\\_%x", $$replstart);
340 my $ppaddr = $op->ppaddr;
342 # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
343 # argument to a split) stores a GV in op_pmreplroot instead
344 # of a substitution syntax tree. We don't want to walk that...
345 if ($op->name eq "pushre") {
346 $gvsym = $replroot->save;
347 # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
350 $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
353 # pmnext handling is broken in perl itself, I think. Bad op_pmnext
354 # fields aren't noticed in perl's runtime (unless you try reset) but we
355 # segfault when trying to dereference it to find op->op_pmnext->op_type
356 $pmopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %s, %s, 0, 0, 0x%x, 0x%x",
357 ${$op->next}, ${$op->sibling}, $op->targ,
358 $op->type, $op_seq, $op->flags, $op->private,
359 ${$op->first}, ${$op->last},
360 $replrootfield, $replstartfield,
361 $op->pmflags, $op->pmpermflags,));
362 my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
363 $init->add(sprintf("$pm.op_ppaddr = %s;", $ppaddr));
364 my $re = $op->precomp;
366 my $resym = sprintf("re%d", $re_index++);
367 $decl->add(sprintf("static char *$resym = %s;", cstring($re)));
368 $init->add(sprintf("PM_SETRE(&$pm,pregcomp($resym, $resym + %u, &$pm));",
372 $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
374 savesym($op, "(OP*)&$pm");
377 sub B::SPECIAL::save {
379 # special case: $$sv is not the address but an index into specialsv_list
380 # warn "SPECIAL::save specialsv $$sv\n"; # debug
381 my $sym = $specialsv_name[$$sv];
382 if (!defined($sym)) {
383 confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
388 sub B::OBJECT::save {}
392 my $sym = objsym($sv);
393 return $sym if defined $sym;
394 # warn "Saving SVt_NULL SV\n"; # debug
397 warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
398 return savesym($sv, "Nullsv /* XXX */");
400 $svsect->add(sprintf("0, %u, 0x%x", $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;
408 $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
409 $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
410 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
411 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
416 my $sym = objsym($sv);
417 return $sym if defined $sym;
419 $val .= '.00' if $val =~ /^-?\d+$/;
420 $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
421 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
422 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
423 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
429 if (defined $max_string_len && length($pv) > $max_string_len) {
430 push @res, sprintf("New(0,%s,%u,char);", $dest, length($pv)+1);
433 my $str = substr $pv, 0, $max_string_len, '';
434 push @res, sprintf("Copy(%s,$dest+$offset,%u,char);",
435 cstring($str), length($str));
436 $offset += length $str;
438 push @res, sprintf("%s[%u] = '\\0';", $dest, $offset);
441 push @res, sprintf("%s = savepvn(%s, %u);", $dest,
442 cstring($pv), length($pv));
449 my $sym = objsym($sv);
450 return $sym if defined $sym;
452 my $len = length($pv);
453 my ($pvsym, $pvmax) = savepv($pv);
454 my ($lvtarg, $lvtarg_sym);
455 $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
456 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
457 $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
458 $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
459 $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS));
460 if (!$pv_copy_on_grow) {
461 $init->add(savepvn(sprintf("xpvlv_list[%d].xpv_pv",
462 $xpvlvsect->index), $pv));
465 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
470 my $sym = objsym($sv);
471 return $sym if defined $sym;
473 my $len = length($pv);
474 my ($pvsym, $pvmax) = savepv($pv);
475 $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
476 $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
477 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
478 if (!$pv_copy_on_grow) {
479 $init->add(savepvn(sprintf("xpviv_list[%d].xpv_pv",
480 $xpvivsect->index), $pv));
482 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
487 my $sym = objsym($sv);
488 return $sym if defined $sym;
490 $pv = '' unless defined $pv;
491 my $len = length($pv);
492 my ($pvsym, $pvmax) = savepv($pv);
494 $val .= '.00' if $val =~ /^-?\d+$/;
495 $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
496 $pvsym, $len, $pvmax, $sv->IVX, $val));
497 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
498 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
499 if (!$pv_copy_on_grow) {
500 $init->add(savepvn(sprintf("xpvnv_list[%d].xpv_pv",
501 $xpvnvsect->index), $pv));
503 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
508 my $sym = objsym($sv);
509 return $sym if defined $sym;
510 my $pv = $sv->PV . "\0" . $sv->TABLE;
511 my $len = length($pv);
512 $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
513 $len, $len + 258, $sv->IVX, $sv->NVX,
514 $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
515 $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
516 $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS));
518 $init->add(savepvn(sprintf("xpvbm_list[%d].xpv_pv",
519 $xpvbmsect->index), $pv),
520 sprintf("xpvbm_list[%d].xpv_cur = %u;",
521 $xpvbmsect->index, $len - 257));
522 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
527 my $sym = objsym($sv);
528 return $sym if defined $sym;
530 my $len = length($pv);
531 my ($pvsym, $pvmax) = savepv($pv);
532 $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
533 $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
534 $xpvsect->index, $sv->REFCNT , $sv->FLAGS));
535 if (!$pv_copy_on_grow) {
536 $init->add(savepvn(sprintf("xpv_list[%d].xpv_pv",
537 $xpvsect->index), $pv));
539 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
544 my $sym = objsym($sv);
545 return $sym if defined $sym;
547 my $len = length($pv);
548 my ($pvsym, $pvmax) = savepv($pv);
549 $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
550 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
551 $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
552 $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS));
553 if (!$pv_copy_on_grow) {
554 $init->add(savepvn(sprintf("xpvmg_list[%d].xpv_pv",
555 $xpvmgsect->index), $pv));
557 $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
562 sub B::PVMG::save_magic {
564 #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
565 my $stash = $sv->SvSTASH;
568 warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
570 # XXX Hope stash is already going to be saved.
571 $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
573 my @mgchain = $sv->MAGIC;
574 my ($mg, $type, $obj, $ptr,$len,$ptrsv);
575 foreach $mg (@mgchain) {
581 warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
582 class($sv), $$sv, class($obj), $$obj,
583 cchar($type), cstring($ptr));
586 if ($len == HEf_SVKEY){
587 #The pointer is an SV*
588 $ptrsv=svref_2object($ptr)->save;
589 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
590 $$sv, $$obj, cchar($type),$ptrsv,$len));
592 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
593 $$sv, $$obj, cchar($type),cstring($ptr),$len));
600 my $sym = objsym($sv);
601 return $sym if defined $sym;
602 my $rv = $sv->RV->save;
603 $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/;
605 $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
606 $xrvsect->index, $sv->REFCNT , $sv->FLAGS));
607 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
611 my ($cvstashname, $cvname) = @_;
612 warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
613 # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
614 # use should be handled by the class itself.
616 my $isa = \@{"$cvstashname\::ISA"};
617 if (grep($_ eq "AutoLoader", @$isa)) {
618 warn "Forcing immediate load of sub derived from AutoLoader\n";
619 # Tweaked version of AutoLoader::AUTOLOAD
620 my $dir = $cvstashname;
622 eval { require "auto/$dir/$cvname.al" };
624 warn qq(failed require "auto/$dir/$cvname.al": $@\n);
634 my $sym = objsym($cv);
636 # warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
639 # Reserve a place in svsect and xpvcvsect and record indices
641 my ($cvname, $cvstashname);
644 $cvstashname = $gv->STASH->NAME;
646 my $root = $cv->ROOT;
647 my $cvxsub = $cv->XSUB;
648 #INIT is removed from the symbol table, so this call must come
649 # from PL_initav->save. Re-bootstrapping will push INIT back in
650 # so nullop should be sent.
651 if ($cvxsub && ($cvname ne "INIT")) {
653 my $stashname = $egv->STASH->NAME;
654 if ($cvname eq "bootstrap")
656 my $file = $gv->FILE;
657 $decl->add("/* bootstrap $file */");
658 warn "Bootstrap $stashname $file\n";
659 $xsub{$stashname}='Dynamic';
660 # $xsub{$stashname}='Static' unless $xsub{$stashname};
663 warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv;
664 return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/;
666 if ($cvxsub && $cvname eq "INIT") {
668 return svref_2object(\&Dummy_initxs)->save;
670 my $sv_ix = $svsect->index + 1;
671 $svsect->add("svix$sv_ix");
672 my $xpvcv_ix = $xpvcvsect->index + 1;
673 $xpvcvsect->add("xpvcvix$xpvcv_ix");
674 # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
675 $sym = savesym($cv, "&sv_list[$sv_ix]");
676 warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv;
677 if (!$$root && !$cvxsub) {
678 if (try_autoload($cvstashname, $cvname)) {
679 # Recalculate root and xsub
682 if ($$root || $cvxsub) {
683 warn "Successful forced autoload\n";
688 my $padlist = $cv->PADLIST;
691 my $xsubany = "Nullany";
693 warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
694 $$cv, $$root) if $debug_cv;
697 my $stashname = $gv->STASH->NAME;
698 my $gvname = $gv->NAME;
699 if ($gvname ne "__ANON__") {
700 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
701 $ppname .= ($stashname eq "main") ?
702 $gvname : "$stashname\::$gvname";
703 $ppname =~ s/::/__/g;
704 if ($gvname eq "INIT"){
705 $ppname .= "_$initsub_index";
711 $ppname = "pp_anonsub_$anonsub_index";
714 $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
715 warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
716 $$cv, $ppname, $$root) if $debug_cv;
718 warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
719 $$padlist, $$cv) if $debug_cv;
721 warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
722 $$padlist, $$cv) if $debug_cv;
726 warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
727 $cvstashname, $cvname); # debug
729 $pv = '' unless defined $pv; # Avoid use of undef warnings
730 $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",
731 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
732 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
733 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
735 if (${$cv->OUTSIDE} == ${main_cv()}){
736 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
737 $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
742 $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
743 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
744 $$gv, $$cv) if $debug_cv;
746 $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE)));
747 my $stash = $cv->STASH;
750 $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
751 warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
752 $$stash, $$cv) if $debug_cv;
754 $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
755 $sv_ix, $xpvcv_ix, $cv->REFCNT +1 , $cv->FLAGS));
761 my $sym = objsym($gv);
763 #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
766 my $ix = $gv_index++;
767 $sym = savesym($gv, "gv_list[$ix]");
768 #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
770 my $is_empty = $gv->is_empty;
771 my $gvname = $gv->NAME;
772 my $name = cstring($gv->STASH->NAME . "::" . $gvname);
773 #warn "GV name is $name\n"; # debug
778 #warn(sprintf("EGV name is %s, saving it now\n",
779 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
780 $egvsym = $egv->save;
783 $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
784 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
785 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS));
786 $init->add(sprintf("GvLINE($sym) = %u;", $gv->LINE)) unless $is_empty;
788 # Shouldn't need to do save_magic since gv_fetchpv handles that
790 my $refcnt = $gv->REFCNT + 1;
791 $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
793 return $sym if $is_empty;
795 my $gvrefcnt = $gv->GvREFCNT;
797 $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
799 if (defined($egvsym)) {
800 # Shared glob *foo = *bar
801 $init->add("gp_free($sym);",
802 "GvGP($sym) = GvGP($egvsym);");
803 } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
804 # Don't save subfields of special GVs (*_, *1, *# and so on)
805 # warn "GV::save saving subfields\n"; # debug
809 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
810 # warn "GV::save \$$name\n"; # debug
815 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
816 # warn "GV::save \@$name\n"; # debug
821 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
822 # warn "GV::save \%$name\n"; # debug
826 my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
827 "::" . $gvcv->GV->EGV->NAME);
828 if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias
829 # must save as a 'stub' so newXS() has a CV to populate
830 $init->add("{ CV *cv;");
831 $init->add("\tcv=perl_get_cv($origname,TRUE);");
832 $init->add("\tGvCV($sym)=cv;");
833 $init->add("\tSvREFCNT_inc((SV *)cv);");
836 $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
837 # warn "GV::save &$name\n"; # debug
840 $init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE)));
841 # warn "GV::save GvFILE(*$name)\n"; # debug
842 my $gvform = $gv->FORM;
845 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
846 # warn "GV::save GvFORM(*$name)\n"; # debug
851 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
852 # warn "GV::save GvIO(*$name)\n"; # debug
859 my $sym = objsym($av);
860 return $sym if defined $sym;
861 my $avflags = $av->AvFLAGS;
862 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
864 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
865 $xpvavsect->index, $av->REFCNT , $av->FLAGS));
866 my $sv_list_index = $svsect->index;
867 my $fill = $av->FILL;
869 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
871 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
872 #if ($fill > -1 && ($avflags & AVf_REAL)) {
874 my @array = $av->ARRAY;
878 foreach $el (@array) {
879 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
880 $$av, $i++, class($el), $$el);
883 my @names = map($_->save, @array);
884 # XXX Better ways to write loop?
885 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
886 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
889 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
890 "\tav_extend(av, $fill);",
891 "\tsvp = AvARRAY(av);",
892 map("\t*svp++ = (SV*)$_;", @names),
893 "\tAvFILLp(av) = $fill;",
897 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
900 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
905 my $sym = objsym($hv);
906 return $sym if defined $sym;
907 my $name = $hv->NAME;
911 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
912 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
913 # a trashed op but we look at the trashed op_type and segfault.
914 #my $adpmroot = ${$hv->PMROOT};
916 $decl->add("static HV *hv$hv_index;");
917 # XXX Beware of weird package names containing double-quotes, \n, ...?
918 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
920 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
923 $sym = savesym($hv, "hv$hv_index");
927 # It's just an ordinary HV
928 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
929 $hv->MAX, $hv->RITER));
930 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
931 $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS));
932 my $sv_list_index = $svsect->index;
933 my @contents = $hv->ARRAY;
936 for ($i = 1; $i < @contents; $i += 2) {
937 $contents[$i] = $contents[$i]->save;
939 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
941 my ($key, $value) = splice(@contents, 0, 2);
942 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
943 cstring($key),length($key),$value, hash($key)));
944 # $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
945 # cstring($key),length($key),$value, 0));
950 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
955 my $sym = objsym($io);
956 return $sym if defined $sym;
958 $pv = '' unless defined $pv;
959 my $len = length($pv);
960 $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",
961 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
962 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
963 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
964 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
965 cchar($io->IoTYPE), $io->IoFLAGS));
966 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
967 $xpviosect->index, $io->REFCNT , $io->FLAGS));
968 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
970 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
971 $fsym = $io->$field();
973 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
983 # This is where we catch an honest-to-goodness Nullsv (which gets
984 # blessed into B::SV explicitly) and any stray erroneous SVs.
985 return 0 unless $$sv;
986 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
991 my $init_name = shift;
993 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
994 $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect,
995 $loopsect, $copsect, $svsect, $xpvsect,
996 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
997 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
998 $symsect->output(\*STDOUT, "#define %s\n");
1000 output_declarations();
1001 foreach $section (@sections) {
1002 my $lines = $section->index + 1;
1004 my $name = $section->name;
1005 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
1006 print "Static $typename ${name}_list[$lines];\n";
1009 $decl->output(\*STDOUT, "%s\n");
1011 foreach $section (@sections) {
1012 my $lines = $section->index + 1;
1014 my $name = $section->name;
1015 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
1016 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
1017 $section->output(\*STDOUT, "\t{ %s },\n");
1023 static int $init_name()
1028 $init->output(\*STDOUT, "\t%s\n");
1029 print "\treturn 0;\n}\n";
1031 warn compile_stats();
1032 warn "NULLOP count: $nullop_count\n";
1036 sub output_declarations {
1038 #ifdef BROKEN_STATIC_REDECL
1039 #define Static extern
1041 #define Static static
1042 #endif /* BROKEN_STATIC_REDECL */
1044 #ifdef BROKEN_UNION_INIT
1046 * Cribbed from cv.h with ANY (a union) replaced by void*.
1047 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
1050 char * xpv_pv; /* pointer to malloced string */
1051 STRLEN xpv_cur; /* length of xp_pv as a C string */
1052 STRLEN xpv_len; /* allocated size */
1053 IV xof_off; /* integer value */
1054 NV xnv_nv; /* numeric value, if any */
1055 MAGIC* xmg_magic; /* magic for scalar array */
1056 HV* xmg_stash; /* class package */
1061 void (*xcv_xsub) (pTHX_ CV*);
1065 long xcv_depth; /* >= 2 indicates recursive call */
1068 #ifdef USE_5005THREADS
1069 perl_mutex *xcv_mutexp;
1070 struct perl_thread *xcv_owner; /* current owner thread */
1071 #endif /* USE_5005THREADS */
1072 cv_flags_t xcv_flags;
1074 #define ANYINIT(i) i
1076 #define XPVCV_or_similar XPVCV
1077 #define ANYINIT(i) {i}
1078 #endif /* BROKEN_UNION_INIT */
1079 #define Nullany ANYINIT(0)
1085 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1090 sub output_boilerplate {
1096 /* Workaround for mapstart: the only op which needs a different ppaddr */
1097 #undef Perl_pp_mapstart
1098 #define Perl_pp_mapstart Perl_pp_grepstart
1099 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1100 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
1102 static void xs_init (pTHX);
1103 static void dl_init (pTHX);
1104 static PerlInterpreter *my_perl;
1111 main(int argc, char **argv, char **env)
1117 PERL_SYS_INIT3(&argc,&argv,&env);
1119 if (!PL_do_undump) {
1120 my_perl = perl_alloc();
1123 perl_construct( my_perl );
1124 PL_perl_destruct_level = 0;
1129 PL_cshlen = strlen(PL_cshname);
1132 #ifdef ALLOW_PERL_OPTIONS
1133 #define EXTRA_OPTIONS 2
1135 #define EXTRA_OPTIONS 3
1136 #endif /* ALLOW_PERL_OPTIONS */
1137 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1138 fakeargv[0] = argv[0];
1141 #ifndef ALLOW_PERL_OPTIONS
1143 #endif /* ALLOW_PERL_OPTIONS */
1144 for (i = 1; i < argc; i++)
1145 fakeargv[i + EXTRA_OPTIONS] = argv[i];
1146 fakeargv[argc + EXTRA_OPTIONS] = 0;
1148 exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1153 sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1154 PL_main_cv = PL_compcv;
1157 exitstatus = perl_init();
1162 exitstatus = perl_run( my_perl );
1164 perl_destruct( my_perl );
1165 perl_free( my_perl );
1172 /* yanked from perl.c */
1176 char *file = __FILE__;
1180 print "\n#ifdef USE_DYNAMIC_LOADING";
1181 print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1182 print "\n#endif\n" ;
1183 # delete $xsub{'DynaLoader'};
1184 delete $xsub{'UNIVERSAL'};
1185 print("/* bootstrapping code*/\n\tSAVETMPS;\n");
1186 print("\ttarg=sv_newmortal();\n");
1187 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1188 print "\tPUSHMARK(sp);\n";
1189 print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
1190 print qq/\tPUTBACK;\n/;
1191 print "\tboot_DynaLoader(aTHX_ NULL);\n";
1192 print qq/\tSPAGAIN;\n/;
1194 foreach my $stashname (keys %xsub){
1195 if ($xsub{$stashname} ne 'Dynamic') {
1196 my $stashxsub=$stashname;
1197 $stashxsub =~ s/::/__/g;
1198 print "\tPUSHMARK(sp);\n";
1199 print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
1200 print qq/\tPUTBACK;\n/;
1201 print "\tboot_$stashxsub(aTHX_ NULL);\n";
1202 print qq/\tSPAGAIN;\n/;
1205 print("\tFREETMPS;\n/* end bootstrapping code */\n");
1212 char *file = __FILE__;
1216 print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
1217 print("\ttarg=sv_newmortal();\n");
1218 foreach my $stashname (@DynaLoader::dl_modules) {
1219 warn "Loaded $stashname\n";
1220 if (exists($xsub{$stashname}) && $xsub{$stashname} eq 'Dynamic') {
1221 my $stashxsub=$stashname;
1222 $stashxsub =~ s/::/__/g;
1223 print "\tPUSHMARK(sp);\n";
1224 print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
1225 print qq/\tPUTBACK;\n/;
1226 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1227 warn "bootstrapping $stashname added to xs_init\n";
1228 print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
1230 print "\tboot_$stashxsub(aTHX_ NULL);\n";
1232 print qq/\tSPAGAIN;\n/;
1235 print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
1241 warn "----Symbol table:\n";
1242 while (($sym, $val) = each %symtable) {
1243 warn "$sym => $val\n";
1245 warn "---End of symbol table\n";
1251 svref_2object($sv)->save;
1255 sub Dummy_BootStrap { }
1260 my $package=$gv->STASH->NAME;
1261 my $name = $gv->NAME;
1267 # We may be looking at this package just because it is a branch in the
1268 # symbol table which is on the path to a package which we need to save
1269 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1271 return unless ($unused_sub_packages{$package});
1272 return unless ($$cv || $$av || $$sv || $$hv);
1278 my $package = shift;
1279 unless ($unused_sub_packages{$package})
1282 $unused_sub_packages{$package} = 1;
1283 if (defined @{$package.'::ISA'})
1285 foreach my $isa (@{$package.'::ISA'})
1287 if ($isa eq 'DynaLoader')
1289 unless (defined(&{$package.'::bootstrap'}))
1291 warn "Forcing bootstrap of $package\n";
1292 eval { $package->bootstrap };
1297 unless ($unused_sub_packages{$isa})
1299 warn "$isa saved (it is in $package\'s \@ISA)\n";
1311 no strict qw(vars refs);
1312 my $package = shift;
1313 $package =~ s/::$//;
1314 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1315 # warn "Considering $package\n";#debug
1316 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1318 # If this package is a prefix to something we are saving, traverse it
1319 # but do not mark it for saving if it is not already
1320 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1322 return 1 if ($u =~ /^$package\:\:/);
1324 if (exists $unused_sub_packages{$package})
1326 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1327 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1328 return $unused_sub_packages{$package};
1330 # Omit the packages which we use (and which cause grief
1331 # because of fancy "goto &$AUTOLOAD" stuff).
1332 # XXX Surely there must be a nicer way to do this.
1333 if ($package eq "FileHandle" || $package eq "Config" ||
1334 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1336 delete_unsaved_hashINC($package);
1337 return $unused_sub_packages{$package} = 0;
1339 # Now see if current package looks like an OO class this is probably too strong.
1340 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1342 if (UNIVERSAL::can($package, $m))
1344 warn "$package has method $m: saving package\n";#debug
1345 return mark_package($package);
1348 delete_unsaved_hashINC($package);
1349 return $unused_sub_packages{$package} = 0;
1351 sub delete_unsaved_hashINC{
1353 $packname =~ s/\:\:/\//g;
1355 # warn "deleting $packname" if $INC{$packname} ;# debug
1356 delete $INC{$packname};
1360 my ($symref, $recurse, $prefix) = @_;
1365 $prefix = '' unless defined $prefix;
1366 while (($sym, $ref) = each %$symref)
1371 $sym = $prefix . $sym;
1372 if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym))
1374 walkpackages(\%glob, $recurse, $sym);
1381 sub save_unused_subs
1384 &descend_marked_unused;
1386 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1387 warn "Saving methods\n";
1388 walksymtable(\%{"main::"}, "savecv", \&should_save);
1393 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1394 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1395 my $inc_hv = svref_2object(\%INC)->save;
1396 my $inc_av = svref_2object(\@INC)->save;
1397 my $amagic_generate= amagic_generation;
1398 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1399 "GvHV(PL_incgv) = $inc_hv;",
1400 "GvAV(PL_incgv) = $inc_av;",
1401 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1402 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1403 "PL_amagic_generation= $amagic_generate;" );
1406 sub descend_marked_unused {
1407 foreach my $pack (keys %unused_sub_packages)
1409 mark_package($pack);
1414 warn "Starting compile\n";
1415 warn "Walking tree\n";
1416 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1417 walkoptree(main_root, "save");
1418 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1420 my $init_av = init_av->save;
1421 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1422 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1423 "PL_initav = (AV *) $init_av;");
1425 warn "Writing output\n";
1426 output_boilerplate();
1428 output_all("perl_init");
1434 my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1435 binop => \$binopsect, condop => \$condopsect,
1436 cop => \$copsect, padop => \$padopsect,
1437 listop => \$listopsect, logop => \$logopsect,
1438 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1439 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1440 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1441 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1442 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1443 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1444 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1445 xpvio => \$xpviosect);
1446 my ($name, $sectref);
1447 while (($name, $sectref) = splice(@sections, 0, 2)) {
1448 $$sectref = new B::C::Section $name, \%symtable, 0;
1454 my ($arg,$val) = @_;
1455 $unused_sub_packages{$arg} = $val;
1460 my ($option, $opt, $arg);
1462 while ($option = shift @options) {
1463 if ($option =~ /^-(.)(.*)/) {
1467 unshift @options, $option;
1470 if ($opt eq "-" && $arg eq "-") {
1475 $warn_undefined_syms = 1;
1476 } elsif ($opt eq "D") {
1477 $arg ||= shift @options;
1478 foreach $arg (split(//, $arg)) {
1481 } elsif ($arg eq "c") {
1483 } elsif ($arg eq "A") {
1485 } elsif ($arg eq "C") {
1487 } elsif ($arg eq "M") {
1490 warn "ignoring unknown debug option: $arg\n";
1493 } elsif ($opt eq "o") {
1494 $arg ||= shift @options;
1495 open(STDOUT, ">$arg") or return "$arg: $!\n";
1496 } elsif ($opt eq "v") {
1498 } elsif ($opt eq "u") {
1499 $arg ||= shift @options;
1500 mark_unused($arg,undef);
1501 } elsif ($opt eq "f") {
1502 $arg ||= shift @options;
1503 if ($arg eq "cog") {
1504 $pv_copy_on_grow = 1;
1505 } elsif ($arg eq "no-cog") {
1506 $pv_copy_on_grow = 0;
1508 } elsif ($opt eq "O") {
1509 $arg = 1 if $arg eq "";
1510 $pv_copy_on_grow = 0;
1512 # Optimisations for -O1
1513 $pv_copy_on_grow = 1;
1515 } elsif ($opt eq "l") {
1516 $max_string_len = $arg;
1523 foreach $objname (@options) {
1524 eval "save_object(\\$objname)";
1529 return sub { save_main() };
1539 B::C - Perl compiler's C backend
1543 perl -MO=C[,OPTIONS] foo.pl
1547 This compiler backend takes Perl source and generates C source code
1548 corresponding to the internal structures that perl uses to run
1549 your program. When the generated C source is compiled and run, it
1550 cuts out the time which perl would have taken to load and parse
1551 your program into its internal semi-compiled form. That means that
1552 compiling with this backend will not help improve the runtime
1553 execution speed of your program but may improve the start-up time.
1554 Depending on the environment in which your program runs this may be
1555 either a help or a hindrance.
1559 If there are any non-option arguments, they are taken to be
1560 names of objects to be saved (probably doesn't work properly yet).
1561 Without extra arguments, it saves the main program.
1567 Output to filename instead of STDOUT
1571 Verbose compilation (currently gives a few compilation statistics).
1575 Force end of options
1579 Force apparently unused subs from package Packname to be compiled.
1580 This allows programs to use eval "foo()" even when sub foo is never
1581 seen to be used at compile time. The down side is that any subs which
1582 really are never used also have code generated. This option is
1583 necessary, for example, if you have a signal handler foo which you
1584 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1585 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1586 options. The compiler tries to figure out which packages may possibly
1587 have subs in which need compiling but the current version doesn't do
1588 it very well. In particular, it is confused by nested packages (i.e.
1589 of the form C<A::B>) where package C<A> does not contain any subs.
1593 Debug options (concatenated or separate flags like C<perl -D>).
1597 OPs, prints each OP as it's processed
1601 COPs, prints COPs as processed (incl. file & line num)
1605 prints AV information on saving
1609 prints CV information on saving
1613 prints MAGIC information on saving
1617 Force optimisations on or off one at a time.
1621 Copy-on-grow: PVs declared and initialised statically.
1629 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
1630 B<-O1> and higher set B<-fcog>.
1634 Some C compilers impose an arbitrary limit on the length of string
1635 constants (e.g. 2048 characters for Microsoft Visual C++). The
1636 B<-llimit> options tells the C backend not to generate string literals
1637 exceeding that limit.
1643 perl -MO=C,-ofoo.c foo.pl
1644 perl cc_harness -o foo foo.c
1646 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1647 library directory. The utility called C<perlcc> may also be used to
1648 help make use of this compiler.
1650 perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null
1654 Plenty. Current status: experimental.
1658 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>