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()
1027 $init->output(\*STDOUT, "\t%s\n");
1028 print "\treturn 0;\n}\n";
1030 warn compile_stats();
1031 warn "NULLOP count: $nullop_count\n";
1035 sub output_declarations {
1037 #ifdef BROKEN_STATIC_REDECL
1038 #define Static extern
1040 #define Static static
1041 #endif /* BROKEN_STATIC_REDECL */
1043 #ifdef BROKEN_UNION_INIT
1045 * Cribbed from cv.h with ANY (a union) replaced by void*.
1046 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
1049 char * xpv_pv; /* pointer to malloced string */
1050 STRLEN xpv_cur; /* length of xp_pv as a C string */
1051 STRLEN xpv_len; /* allocated size */
1052 IV xof_off; /* integer value */
1053 double xnv_nv; /* numeric value, if any */
1054 MAGIC* xmg_magic; /* magic for scalar array */
1055 HV* xmg_stash; /* class package */
1060 void (*xcv_xsub) (CV*);
1064 long xcv_depth; /* >= 2 indicates recursive call */
1068 perl_mutex *xcv_mutexp;
1069 struct perl_thread *xcv_owner; /* current owner thread */
1070 #endif /* USE_THREADS */
1071 cv_flags_t xcv_flags;
1073 #define ANYINIT(i) i
1075 #define XPVCV_or_similar XPVCV
1076 #define ANYINIT(i) {i}
1077 #endif /* BROKEN_UNION_INIT */
1078 #define Nullany ANYINIT(0)
1084 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1089 sub output_boilerplate {
1095 /* Workaround for mapstart: the only op which needs a different ppaddr */
1096 #undef Perl_pp_mapstart
1097 #define Perl_pp_mapstart Perl_pp_grepstart
1098 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1099 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
1101 static void xs_init (pTHX);
1102 static void dl_init (pTHX);
1103 static PerlInterpreter *my_perl;
1110 main(int argc, char **argv, char **env)
1116 PERL_SYS_INIT3(&argc,&argv,&env);
1118 if (!PL_do_undump) {
1119 my_perl = perl_alloc();
1122 perl_construct( my_perl );
1123 PL_perl_destruct_level = 0;
1128 PL_cshlen = strlen(PL_cshname);
1131 #ifdef ALLOW_PERL_OPTIONS
1132 #define EXTRA_OPTIONS 2
1134 #define EXTRA_OPTIONS 3
1135 #endif /* ALLOW_PERL_OPTIONS */
1136 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1137 fakeargv[0] = argv[0];
1140 #ifndef ALLOW_PERL_OPTIONS
1142 #endif /* ALLOW_PERL_OPTIONS */
1143 for (i = 1; i < argc; i++)
1144 fakeargv[i + EXTRA_OPTIONS] = argv[i];
1145 fakeargv[argc + EXTRA_OPTIONS] = 0;
1147 exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1152 sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1153 PL_main_cv = PL_compcv;
1156 exitstatus = perl_init();
1161 exitstatus = perl_run( my_perl );
1163 perl_destruct( my_perl );
1164 perl_free( my_perl );
1171 /* yanked from perl.c */
1175 char *file = __FILE__;
1179 print "\n#ifdef USE_DYNAMIC_LOADING";
1180 print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1181 print "\n#endif\n" ;
1182 # delete $xsub{'DynaLoader'};
1183 delete $xsub{'UNIVERSAL'};
1184 print("/* bootstrapping code*/\n\tSAVETMPS;\n");
1185 print("\ttarg=sv_newmortal();\n");
1186 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1187 print "\tPUSHMARK(sp);\n";
1188 print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
1189 print qq/\tPUTBACK;\n/;
1190 print "\tboot_DynaLoader(aTHX_ NULL);\n";
1191 print qq/\tSPAGAIN;\n/;
1193 foreach my $stashname (keys %xsub){
1194 if ($xsub{$stashname} ne 'Dynamic') {
1195 my $stashxsub=$stashname;
1196 $stashxsub =~ s/::/__/g;
1197 print "\tPUSHMARK(sp);\n";
1198 print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
1199 print qq/\tPUTBACK;\n/;
1200 print "\tboot_$stashxsub(aTHX_ NULL);\n";
1201 print qq/\tSPAGAIN;\n/;
1204 print("\tFREETMPS;\n/* end bootstrapping code */\n");
1211 char *file = __FILE__;
1215 print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
1216 print("\ttarg=sv_newmortal();\n");
1217 foreach my $stashname (@DynaLoader::dl_modules) {
1218 warn "Loaded $stashname\n";
1219 if (exists($xsub{$stashname}) && $xsub{$stashname} eq 'Dynamic') {
1220 my $stashxsub=$stashname;
1221 $stashxsub =~ s/::/__/g;
1222 print "\tPUSHMARK(sp);\n";
1223 print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
1224 print qq/\tPUTBACK;\n/;
1225 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1226 warn "bootstrapping $stashname added to xs_init\n";
1227 print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
1229 print "\tboot_$stashxsub(aTHX_ NULL);\n";
1231 print qq/\tSPAGAIN;\n/;
1234 print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
1240 warn "----Symbol table:\n";
1241 while (($sym, $val) = each %symtable) {
1242 warn "$sym => $val\n";
1244 warn "---End of symbol table\n";
1250 svref_2object($sv)->save;
1254 sub Dummy_BootStrap { }
1259 my $package=$gv->STASH->NAME;
1260 my $name = $gv->NAME;
1266 # We may be looking at this package just because it is a branch in the
1267 # symbol table which is on the path to a package which we need to save
1268 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1270 return unless ($unused_sub_packages{$package});
1271 return unless ($$cv || $$av || $$sv || $$hv);
1277 my $package = shift;
1278 unless ($unused_sub_packages{$package})
1281 $unused_sub_packages{$package} = 1;
1282 if (defined @{$package.'::ISA'})
1284 foreach my $isa (@{$package.'::ISA'})
1286 if ($isa eq 'DynaLoader')
1288 unless (defined(&{$package.'::bootstrap'}))
1290 warn "Forcing bootstrap of $package\n";
1291 eval { $package->bootstrap };
1296 unless ($unused_sub_packages{$isa})
1298 warn "$isa saved (it is in $package\'s \@ISA)\n";
1310 no strict qw(vars refs);
1311 my $package = shift;
1312 $package =~ s/::$//;
1313 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1314 # warn "Considering $package\n";#debug
1315 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1317 # If this package is a prefix to something we are saving, traverse it
1318 # but do not mark it for saving if it is not already
1319 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1321 return 1 if ($u =~ /^$package\:\:/);
1323 if (exists $unused_sub_packages{$package})
1325 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1326 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1327 return $unused_sub_packages{$package};
1329 # Omit the packages which we use (and which cause grief
1330 # because of fancy "goto &$AUTOLOAD" stuff).
1331 # XXX Surely there must be a nicer way to do this.
1332 if ($package eq "FileHandle" || $package eq "Config" ||
1333 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1335 delete_unsaved_hashINC($package);
1336 return $unused_sub_packages{$package} = 0;
1338 # Now see if current package looks like an OO class this is probably too strong.
1339 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1341 if (UNIVERSAL::can($package, $m))
1343 warn "$package has method $m: saving package\n";#debug
1344 return mark_package($package);
1347 delete_unsaved_hashINC($package);
1348 return $unused_sub_packages{$package} = 0;
1350 sub delete_unsaved_hashINC{
1352 $packname =~ s/\:\:/\//g;
1354 # warn "deleting $packname" if $INC{$packname} ;# debug
1355 delete $INC{$packname};
1359 my ($symref, $recurse, $prefix) = @_;
1364 $prefix = '' unless defined $prefix;
1365 while (($sym, $ref) = each %$symref)
1370 $sym = $prefix . $sym;
1371 if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym))
1373 walkpackages(\%glob, $recurse, $sym);
1380 sub save_unused_subs
1383 &descend_marked_unused;
1385 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1386 warn "Saving methods\n";
1387 walksymtable(\%{"main::"}, "savecv", \&should_save);
1392 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1393 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1394 my $inc_hv = svref_2object(\%INC)->save;
1395 my $inc_av = svref_2object(\@INC)->save;
1396 my $amagic_generate= amagic_generation;
1397 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1398 "GvHV(PL_incgv) = $inc_hv;",
1399 "GvAV(PL_incgv) = $inc_av;",
1400 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1401 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1402 "PL_amagic_generation= $amagic_generate;" );
1405 sub descend_marked_unused {
1406 foreach my $pack (keys %unused_sub_packages)
1408 mark_package($pack);
1413 warn "Starting compile\n";
1414 warn "Walking tree\n";
1415 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1416 walkoptree(main_root, "save");
1417 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1419 my $init_av = init_av->save;
1420 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1421 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1422 "PL_initav = (AV *) $init_av;");
1424 warn "Writing output\n";
1425 output_boilerplate();
1427 output_all("perl_init");
1433 my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1434 binop => \$binopsect, condop => \$condopsect,
1435 cop => \$copsect, padop => \$padopsect,
1436 listop => \$listopsect, logop => \$logopsect,
1437 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1438 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1439 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1440 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1441 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1442 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1443 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1444 xpvio => \$xpviosect);
1445 my ($name, $sectref);
1446 while (($name, $sectref) = splice(@sections, 0, 2)) {
1447 $$sectref = new B::C::Section $name, \%symtable, 0;
1453 my ($arg,$val) = @_;
1454 $unused_sub_packages{$arg} = $val;
1459 my ($option, $opt, $arg);
1461 while ($option = shift @options) {
1462 if ($option =~ /^-(.)(.*)/) {
1466 unshift @options, $option;
1469 if ($opt eq "-" && $arg eq "-") {
1474 $warn_undefined_syms = 1;
1475 } elsif ($opt eq "D") {
1476 $arg ||= shift @options;
1477 foreach $arg (split(//, $arg)) {
1480 } elsif ($arg eq "c") {
1482 } elsif ($arg eq "A") {
1484 } elsif ($arg eq "C") {
1486 } elsif ($arg eq "M") {
1489 warn "ignoring unknown debug option: $arg\n";
1492 } elsif ($opt eq "o") {
1493 $arg ||= shift @options;
1494 open(STDOUT, ">$arg") or return "$arg: $!\n";
1495 } elsif ($opt eq "v") {
1497 } elsif ($opt eq "u") {
1498 $arg ||= shift @options;
1499 mark_unused($arg,undef);
1500 } elsif ($opt eq "f") {
1501 $arg ||= shift @options;
1502 if ($arg eq "cog") {
1503 $pv_copy_on_grow = 1;
1504 } elsif ($arg eq "no-cog") {
1505 $pv_copy_on_grow = 0;
1507 } elsif ($opt eq "O") {
1508 $arg = 1 if $arg eq "";
1509 $pv_copy_on_grow = 0;
1511 # Optimisations for -O1
1512 $pv_copy_on_grow = 1;
1514 } elsif ($opt eq "l") {
1515 $max_string_len = $arg;
1522 foreach $objname (@options) {
1523 eval "save_object(\\$objname)";
1528 return sub { save_main() };
1538 B::C - Perl compiler's C backend
1542 perl -MO=C[,OPTIONS] foo.pl
1546 This compiler backend takes Perl source and generates C source code
1547 corresponding to the internal structures that perl uses to run
1548 your program. When the generated C source is compiled and run, it
1549 cuts out the time which perl would have taken to load and parse
1550 your program into its internal semi-compiled form. That means that
1551 compiling with this backend will not help improve the runtime
1552 execution speed of your program but may improve the start-up time.
1553 Depending on the environment in which your program runs this may be
1554 either a help or a hindrance.
1558 If there are any non-option arguments, they are taken to be
1559 names of objects to be saved (probably doesn't work properly yet).
1560 Without extra arguments, it saves the main program.
1566 Output to filename instead of STDOUT
1570 Verbose compilation (currently gives a few compilation statistics).
1574 Force end of options
1578 Force apparently unused subs from package Packname to be compiled.
1579 This allows programs to use eval "foo()" even when sub foo is never
1580 seen to be used at compile time. The down side is that any subs which
1581 really are never used also have code generated. This option is
1582 necessary, for example, if you have a signal handler foo which you
1583 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1584 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1585 options. The compiler tries to figure out which packages may possibly
1586 have subs in which need compiling but the current version doesn't do
1587 it very well. In particular, it is confused by nested packages (i.e.
1588 of the form C<A::B>) where package C<A> does not contain any subs.
1592 Debug options (concatenated or separate flags like C<perl -D>).
1596 OPs, prints each OP as it's processed
1600 COPs, prints COPs as processed (incl. file & line num)
1604 prints AV information on saving
1608 prints CV information on saving
1612 prints MAGIC information on saving
1616 Force optimisations on or off one at a time.
1620 Copy-on-grow: PVs declared and initialised statically.
1628 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
1629 B<-O1> and higher set B<-fcog>.
1633 Some C compilers impose an arbitrary limit on the length of string
1634 constants (e.g. 2048 characters for Microsoft Visual C++). The
1635 B<-llimit> options tells the C backend not to generate string literals
1636 exceeding that limit.
1642 perl -MO=C,-ofoo.c foo.pl
1643 perl cc_harness -o foo foo.c
1645 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1646 library directory. The utility called C<perlcc> may also be used to
1647 help make use of this compiler.
1649 perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null
1653 Plenty. Current status: experimental.
1657 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>