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, Nullgv",
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, Nullhv, Nullgv, %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";
397 $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS));
398 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
403 my $sym = objsym($sv);
404 return $sym if defined $sym;
405 $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
406 $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
407 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
408 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
413 my $sym = objsym($sv);
414 return $sym if defined $sym;
416 $val .= '.00' if $val =~ /^-?\d+$/;
417 $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
418 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
419 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
420 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
426 if (defined $max_string_len && length($pv) > $max_string_len) {
427 push @res, sprintf("New(0,%s,%u,char);", $dest, length($pv)+1);
430 my $str = substr $pv, 0, $max_string_len, '';
431 push @res, sprintf("Copy(%s,$dest+$offset,%u,char);",
432 cstring($str), length($str));
433 $offset += length $str;
435 push @res, sprintf("%s[%u] = '\\0';", $dest, $offset);
438 push @res, sprintf("%s = savepvn(%s, %u);", $dest,
439 cstring($pv), length($pv));
446 my $sym = objsym($sv);
447 return $sym if defined $sym;
449 my $len = length($pv);
450 my ($pvsym, $pvmax) = savepv($pv);
451 my ($lvtarg, $lvtarg_sym);
452 $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
453 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
454 $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
455 $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
456 $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS));
457 if (!$pv_copy_on_grow) {
458 $init->add(savepvn(sprintf("xpvlv_list[%d].xpv_pv",
459 $xpvlvsect->index), $pv));
462 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
467 my $sym = objsym($sv);
468 return $sym if defined $sym;
470 my $len = length($pv);
471 my ($pvsym, $pvmax) = savepv($pv);
472 $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
473 $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
474 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
475 if (!$pv_copy_on_grow) {
476 $init->add(savepvn(sprintf("xpviv_list[%d].xpv_pv",
477 $xpvivsect->index), $pv));
479 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
484 my $sym = objsym($sv);
485 return $sym if defined $sym;
487 $pv = '' unless defined $pv;
488 my $len = length($pv);
489 my ($pvsym, $pvmax) = savepv($pv);
491 $val .= '.00' if $val =~ /^-?\d+$/;
492 $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
493 $pvsym, $len, $pvmax, $sv->IVX, $val));
494 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
495 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
496 if (!$pv_copy_on_grow) {
497 $init->add(savepvn(sprintf("xpvnv_list[%d].xpv_pv",
498 $xpvnvsect->index), $pv));
500 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
505 my $sym = objsym($sv);
506 return $sym if defined $sym;
507 my $pv = $sv->PV . "\0" . $sv->TABLE;
508 my $len = length($pv);
509 $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
510 $len, $len + 258, $sv->IVX, $sv->NVX,
511 $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
512 $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
513 $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS));
515 $init->add(savepvn(sprintf("xpvbm_list[%d].xpv_pv",
516 $xpvbmsect->index), $pv),
517 sprintf("xpvbm_list[%d].xpv_cur = %u;",
518 $xpvbmsect->index, $len - 257));
519 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
524 my $sym = objsym($sv);
525 return $sym if defined $sym;
527 my $len = length($pv);
528 my ($pvsym, $pvmax) = savepv($pv);
529 $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
530 $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
531 $xpvsect->index, $sv->REFCNT , $sv->FLAGS));
532 if (!$pv_copy_on_grow) {
533 $init->add(savepvn(sprintf("xpv_list[%d].xpv_pv",
534 $xpvsect->index), $pv));
536 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
541 my $sym = objsym($sv);
542 return $sym if defined $sym;
544 my $len = length($pv);
545 my ($pvsym, $pvmax) = savepv($pv);
546 $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
547 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
548 $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
549 $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS));
550 if (!$pv_copy_on_grow) {
551 $init->add(savepvn(sprintf("xpvmg_list[%d].xpv_pv",
552 $xpvmgsect->index), $pv));
554 $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
559 sub B::PVMG::save_magic {
561 #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
562 my $stash = $sv->SvSTASH;
565 warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
567 # XXX Hope stash is already going to be saved.
568 $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
570 my @mgchain = $sv->MAGIC;
571 my ($mg, $type, $obj, $ptr,$len,$ptrsv);
572 foreach $mg (@mgchain) {
578 warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
579 class($sv), $$sv, class($obj), $$obj,
580 cchar($type), cstring($ptr));
583 if ($len == HEf_SVKEY){
584 #The pointer is an SV*
585 $ptrsv=svref_2object($ptr)->save;
586 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
587 $$sv, $$obj, cchar($type),$ptrsv,$len));
589 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
590 $$sv, $$obj, cchar($type),cstring($ptr),$len));
597 my $sym = objsym($sv);
598 return $sym if defined $sym;
599 my $rv = $sv->RV->save;
600 $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/;
602 $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
603 $xrvsect->index, $sv->REFCNT , $sv->FLAGS));
604 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
608 my ($cvstashname, $cvname) = @_;
609 warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
610 # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
611 # use should be handled by the class itself.
613 my $isa = \@{"$cvstashname\::ISA"};
614 if (grep($_ eq "AutoLoader", @$isa)) {
615 warn "Forcing immediate load of sub derived from AutoLoader\n";
616 # Tweaked version of AutoLoader::AUTOLOAD
617 my $dir = $cvstashname;
619 eval { require "auto/$dir/$cvname.al" };
621 warn qq(failed require "auto/$dir/$cvname.al": $@\n);
631 my $sym = objsym($cv);
633 # warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
636 # Reserve a place in svsect and xpvcvsect and record indices
638 my ($cvname, $cvstashname);
641 $cvstashname = $gv->STASH->NAME;
643 my $root = $cv->ROOT;
644 my $cvxsub = $cv->XSUB;
645 #INIT is removed from the symbol table, so this call must come
646 # from PL_initav->save. Re-bootstrapping will push INIT back in
647 # so nullop should be sent.
648 if ($cvxsub && ($cvname ne "INIT")) {
650 my $stashname = $egv->STASH->NAME;
651 if ($cvname eq "bootstrap")
653 my $file = $gv->FILE;
654 $decl->add("/* bootstrap $file */");
655 warn "Bootstrap $stashname $file\n";
656 $xsub{$stashname}='Dynamic';
657 # $xsub{$stashname}='Static' unless $xsub{$stashname};
660 warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv;
661 return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/;
663 if ($cvxsub && $cvname eq "INIT") {
665 return svref_2object(\&Dummy_initxs)->save;
667 my $sv_ix = $svsect->index + 1;
668 $svsect->add("svix$sv_ix");
669 my $xpvcv_ix = $xpvcvsect->index + 1;
670 $xpvcvsect->add("xpvcvix$xpvcv_ix");
671 # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
672 $sym = savesym($cv, "&sv_list[$sv_ix]");
673 warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv;
674 if (!$$root && !$cvxsub) {
675 if (try_autoload($cvstashname, $cvname)) {
676 # Recalculate root and xsub
679 if ($$root || $cvxsub) {
680 warn "Successful forced autoload\n";
685 my $padlist = $cv->PADLIST;
688 my $xsubany = "Nullany";
690 warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
691 $$cv, $$root) if $debug_cv;
694 my $stashname = $gv->STASH->NAME;
695 my $gvname = $gv->NAME;
696 if ($gvname ne "__ANON__") {
697 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
698 $ppname .= ($stashname eq "main") ?
699 $gvname : "$stashname\::$gvname";
700 $ppname =~ s/::/__/g;
701 if ($gvname eq "INIT"){
702 $ppname .= "_$initsub_index";
708 $ppname = "pp_anonsub_$anonsub_index";
711 $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
712 warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
713 $$cv, $ppname, $$root) if $debug_cv;
715 warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
716 $$padlist, $$cv) if $debug_cv;
718 warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
719 $$padlist, $$cv) if $debug_cv;
723 warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
724 $cvstashname, $cvname); # debug
726 $pv = '' unless defined $pv; # Avoid use of undef warnings
727 $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",
728 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
729 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
730 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
732 if (${$cv->OUTSIDE} == ${main_cv()}){
733 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
734 $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
739 $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
740 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
741 $$gv, $$cv) if $debug_cv;
743 $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE)));
744 my $stash = $cv->STASH;
747 $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
748 warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
749 $$stash, $$cv) if $debug_cv;
751 $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
752 $sv_ix, $xpvcv_ix, $cv->REFCNT +1 , $cv->FLAGS));
758 my $sym = objsym($gv);
760 #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
763 my $ix = $gv_index++;
764 $sym = savesym($gv, "gv_list[$ix]");
765 #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
767 my $gvname = $gv->NAME;
768 my $name = cstring($gv->STASH->NAME . "::" . $gvname);
769 #warn "GV name is $name\n"; # debug
773 #warn(sprintf("EGV name is %s, saving it now\n",
774 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
775 $egvsym = $egv->save;
777 $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
778 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
779 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS),
780 sprintf("GvLINE($sym) = %u;", $gv->LINE));
781 # Shouldn't need to do save_magic since gv_fetchpv handles that
783 my $refcnt = $gv->REFCNT + 1;
784 $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
785 my $gvrefcnt = $gv->GvREFCNT;
787 $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
789 if (defined($egvsym)) {
790 # Shared glob *foo = *bar
791 $init->add("gp_free($sym);",
792 "GvGP($sym) = GvGP($egvsym);");
793 } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
794 # Don't save subfields of special GVs (*_, *1, *# and so on)
795 # warn "GV::save saving subfields\n"; # debug
799 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
800 # warn "GV::save \$$name\n"; # debug
805 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
806 # warn "GV::save \@$name\n"; # debug
811 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
812 # warn "GV::save \%$name\n"; # debug
816 my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
817 "::" . $gvcv->GV->EGV->NAME);
818 if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias
819 # must save as a 'stub' so newXS() has a CV to populate
820 $init->add("{ CV *cv;");
821 $init->add("\tcv=perl_get_cv($origname,TRUE);");
822 $init->add("\tGvCV($sym)=cv;");
823 $init->add("\tSvREFCNT_inc((SV *)cv);");
826 $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
827 # warn "GV::save &$name\n"; # debug
830 $init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE)));
831 # warn "GV::save GvFILE(*$name)\n"; # debug
832 my $gvform = $gv->FORM;
835 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
836 # warn "GV::save GvFORM(*$name)\n"; # debug
841 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
842 # warn "GV::save GvIO(*$name)\n"; # debug
849 my $sym = objsym($av);
850 return $sym if defined $sym;
851 my $avflags = $av->AvFLAGS;
852 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
854 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
855 $xpvavsect->index, $av->REFCNT , $av->FLAGS));
856 my $sv_list_index = $svsect->index;
857 my $fill = $av->FILL;
859 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
861 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
862 #if ($fill > -1 && ($avflags & AVf_REAL)) {
864 my @array = $av->ARRAY;
868 foreach $el (@array) {
869 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
870 $$av, $i++, class($el), $$el);
873 my @names = map($_->save, @array);
874 # XXX Better ways to write loop?
875 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
876 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
879 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
880 "\tav_extend(av, $fill);",
881 "\tsvp = AvARRAY(av);",
882 map("\t*svp++ = (SV*)$_;", @names),
883 "\tAvFILLp(av) = $fill;",
887 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
890 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
895 my $sym = objsym($hv);
896 return $sym if defined $sym;
897 my $name = $hv->NAME;
901 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
902 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
903 # a trashed op but we look at the trashed op_type and segfault.
904 #my $adpmroot = ${$hv->PMROOT};
906 $decl->add("static HV *hv$hv_index;");
907 # XXX Beware of weird package names containing double-quotes, \n, ...?
908 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
910 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
913 $sym = savesym($hv, "hv$hv_index");
917 # It's just an ordinary HV
918 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
919 $hv->MAX, $hv->RITER));
920 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
921 $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS));
922 my $sv_list_index = $svsect->index;
923 my @contents = $hv->ARRAY;
926 for ($i = 1; $i < @contents; $i += 2) {
927 $contents[$i] = $contents[$i]->save;
929 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
931 my ($key, $value) = splice(@contents, 0, 2);
932 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
933 cstring($key),length($key),$value, hash($key)));
934 # $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
935 # cstring($key),length($key),$value, 0));
940 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
945 my $sym = objsym($io);
946 return $sym if defined $sym;
948 $pv = '' unless defined $pv;
949 my $len = length($pv);
950 $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",
951 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
952 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
953 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
954 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
955 cchar($io->IoTYPE), $io->IoFLAGS));
956 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
957 $xpviosect->index, $io->REFCNT , $io->FLAGS));
958 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
960 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
961 $fsym = $io->$field();
963 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
973 # This is where we catch an honest-to-goodness Nullsv (which gets
974 # blessed into B::SV explicitly) and any stray erroneous SVs.
975 return 0 unless $$sv;
976 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
981 my $init_name = shift;
983 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
984 $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect,
985 $loopsect, $copsect, $svsect, $xpvsect,
986 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
987 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
988 $symsect->output(\*STDOUT, "#define %s\n");
990 output_declarations();
991 foreach $section (@sections) {
992 my $lines = $section->index + 1;
994 my $name = $section->name;
995 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
996 print "Static $typename ${name}_list[$lines];\n";
999 $decl->output(\*STDOUT, "%s\n");
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 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
1007 $section->output(\*STDOUT, "\t{ %s },\n");
1013 static int $init_name()
1019 $init->output(\*STDOUT, "\t%s\n");
1020 print "\treturn 0;\n}\n";
1022 warn compile_stats();
1023 warn "NULLOP count: $nullop_count\n";
1027 sub output_declarations {
1029 #ifdef BROKEN_STATIC_REDECL
1030 #define Static extern
1032 #define Static static
1033 #endif /* BROKEN_STATIC_REDECL */
1035 #ifdef BROKEN_UNION_INIT
1037 * Cribbed from cv.h with ANY (a union) replaced by void*.
1038 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
1041 char * xpv_pv; /* pointer to malloced string */
1042 STRLEN xpv_cur; /* length of xp_pv as a C string */
1043 STRLEN xpv_len; /* allocated size */
1044 IV xof_off; /* integer value */
1045 double xnv_nv; /* numeric value, if any */
1046 MAGIC* xmg_magic; /* magic for scalar array */
1047 HV* xmg_stash; /* class package */
1052 void (*xcv_xsub) (CV*);
1056 long xcv_depth; /* >= 2 indicates recursive call */
1060 perl_mutex *xcv_mutexp;
1061 struct perl_thread *xcv_owner; /* current owner thread */
1062 #endif /* USE_THREADS */
1065 #define ANYINIT(i) i
1067 #define XPVCV_or_similar XPVCV
1068 #define ANYINIT(i) {i}
1069 #endif /* BROKEN_UNION_INIT */
1070 #define Nullany ANYINIT(0)
1076 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1081 sub output_boilerplate {
1086 /* Workaround for mapstart: the only op which needs a different ppaddr */
1087 #undef Perl_pp_mapstart
1088 #define Perl_pp_mapstart Perl_pp_grepstart
1089 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1090 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
1092 static void xs_init (pTHX);
1093 static void dl_init (pTHX);
1094 static PerlInterpreter *my_perl;
1101 main(int argc, char **argv, char **env)
1107 PERL_SYS_INIT3(&argc,&argv,&env);
1109 if (!PL_do_undump) {
1110 my_perl = perl_alloc();
1113 perl_construct( my_perl );
1114 PL_perl_destruct_level = 0;
1119 PL_cshlen = strlen(PL_cshname);
1122 #ifdef ALLOW_PERL_OPTIONS
1123 #define EXTRA_OPTIONS 2
1125 #define EXTRA_OPTIONS 3
1126 #endif /* ALLOW_PERL_OPTIONS */
1127 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1128 fakeargv[0] = argv[0];
1131 #ifndef ALLOW_PERL_OPTIONS
1133 #endif /* ALLOW_PERL_OPTIONS */
1134 for (i = 1; i < argc; i++)
1135 fakeargv[i + EXTRA_OPTIONS] = argv[i];
1136 fakeargv[argc + EXTRA_OPTIONS] = 0;
1138 exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1143 sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1144 PL_main_cv = PL_compcv;
1147 exitstatus = perl_init();
1152 exitstatus = perl_run( my_perl );
1154 perl_destruct( my_perl );
1155 perl_free( my_perl );
1162 /* yanked from perl.c */
1166 char *file = __FILE__;
1170 print "\n#ifdef USE_DYNAMIC_LOADING";
1171 print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1172 print "\n#endif\n" ;
1173 # delete $xsub{'DynaLoader'};
1174 delete $xsub{'UNIVERSAL'};
1175 print("/* bootstrapping code*/\n\tSAVETMPS;\n");
1176 print("\ttarg=sv_newmortal();\n");
1177 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1178 print "\tPUSHMARK(sp);\n";
1179 print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
1180 print qq/\tPUTBACK;\n/;
1181 print "\tboot_DynaLoader(aTHX_ NULL);\n";
1182 print qq/\tSPAGAIN;\n/;
1184 foreach my $stashname (keys %xsub){
1185 if ($xsub{$stashname} ne 'Dynamic') {
1186 my $stashxsub=$stashname;
1187 $stashxsub =~ s/::/__/g;
1188 print "\tPUSHMARK(sp);\n";
1189 print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
1190 print qq/\tPUTBACK;\n/;
1191 print "\tboot_$stashxsub(aTHX_ NULL);\n";
1192 print qq/\tSPAGAIN;\n/;
1195 print("\tFREETMPS;\n/* end bootstrapping code */\n");
1202 char *file = __FILE__;
1206 print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
1207 print("\ttarg=sv_newmortal();\n");
1208 foreach my $stashname (@DynaLoader::dl_modules) {
1209 warn "Loaded $stashname\n";
1210 if (exists($xsub{$stashname}) && $xsub{$stashname} eq 'Dynamic') {
1211 my $stashxsub=$stashname;
1212 $stashxsub =~ s/::/__/g;
1213 print "\tPUSHMARK(sp);\n";
1214 print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
1215 print qq/\tPUTBACK;\n/;
1216 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1217 warn "bootstrapping $stashname added to xs_init\n";
1218 print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
1220 print "\tboot_$stashxsub(aTHX_ NULL);\n";
1222 print qq/\tSPAGAIN;\n/;
1225 print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
1231 warn "----Symbol table:\n";
1232 while (($sym, $val) = each %symtable) {
1233 warn "$sym => $val\n";
1235 warn "---End of symbol table\n";
1241 svref_2object($sv)->save;
1245 sub Dummy_BootStrap { }
1250 my $package=$gv->STASH->NAME;
1251 my $name = $gv->NAME;
1257 # We may be looking at this package just because it is a branch in the
1258 # symbol table which is on the path to a package which we need to save
1259 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1261 return unless ($unused_sub_packages{$package});
1262 return unless ($$cv || $$av || $$sv || $$hv);
1268 my $package = shift;
1269 unless ($unused_sub_packages{$package})
1272 $unused_sub_packages{$package} = 1;
1273 if (defined @{$package.'::ISA'})
1275 foreach my $isa (@{$package.'::ISA'})
1277 if ($isa eq 'DynaLoader')
1279 unless (defined(&{$package.'::bootstrap'}))
1281 warn "Forcing bootstrap of $package\n";
1282 eval { $package->bootstrap };
1287 unless ($unused_sub_packages{$isa})
1289 warn "$isa saved (it is in $package\'s \@ISA)\n";
1301 no strict qw(vars refs);
1302 my $package = shift;
1303 $package =~ s/::$//;
1304 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1305 # warn "Considering $package\n";#debug
1306 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1308 # If this package is a prefix to something we are saving, traverse it
1309 # but do not mark it for saving if it is not already
1310 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1312 return 1 if ($u =~ /^$package\:\:/);
1314 if (exists $unused_sub_packages{$package})
1316 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1317 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1318 return $unused_sub_packages{$package};
1320 # Omit the packages which we use (and which cause grief
1321 # because of fancy "goto &$AUTOLOAD" stuff).
1322 # XXX Surely there must be a nicer way to do this.
1323 if ($package eq "FileHandle" || $package eq "Config" ||
1324 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1326 delete_unsaved_hashINC($package);
1327 return $unused_sub_packages{$package} = 0;
1329 # Now see if current package looks like an OO class this is probably too strong.
1330 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1332 if ($package->can($m))
1334 warn "$package has method $m: saving package\n";#debug
1335 return mark_package($package);
1338 delete_unsaved_hashINC($package);
1339 return $unused_sub_packages{$package} = 0;
1341 sub delete_unsaved_hashINC{
1343 $packname =~ s/\:\:/\//g;
1345 # warn "deleting $packname" if $INC{$packname} ;# debug
1346 delete $INC{$packname};
1350 my ($symref, $recurse, $prefix) = @_;
1355 $prefix = '' unless defined $prefix;
1356 while (($sym, $ref) = each %$symref)
1361 $sym = $prefix . $sym;
1362 if ($sym ne "main::" && &$recurse($sym))
1364 walkpackages(\%glob, $recurse, $sym);
1371 sub save_unused_subs
1374 &descend_marked_unused;
1376 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1377 warn "Saving methods\n";
1378 walksymtable(\%{"main::"}, "savecv", \&should_save);
1383 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1384 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1385 my $inc_hv = svref_2object(\%INC)->save;
1386 my $inc_av = svref_2object(\@INC)->save;
1387 my $amagic_generate= amagic_generation;
1388 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1389 "GvHV(PL_incgv) = $inc_hv;",
1390 "GvAV(PL_incgv) = $inc_av;",
1391 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1392 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1393 "PL_amagic_generation= $amagic_generate;" );
1396 sub descend_marked_unused {
1397 foreach my $pack (keys %unused_sub_packages)
1399 mark_package($pack);
1404 warn "Starting compile\n";
1405 warn "Walking tree\n";
1406 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1407 walkoptree(main_root, "save");
1408 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1410 my $init_av = init_av->save;
1411 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1412 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1413 "PL_initav = (AV *) $init_av;");
1415 warn "Writing output\n";
1416 output_boilerplate();
1418 output_all("perl_init");
1424 my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1425 binop => \$binopsect, condop => \$condopsect,
1426 cop => \$copsect, padop => \$padopsect,
1427 listop => \$listopsect, logop => \$logopsect,
1428 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1429 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1430 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1431 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1432 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1433 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1434 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1435 xpvio => \$xpviosect);
1436 my ($name, $sectref);
1437 while (($name, $sectref) = splice(@sections, 0, 2)) {
1438 $$sectref = new B::C::Section $name, \%symtable, 0;
1444 my ($arg,$val) = @_;
1445 $unused_sub_packages{$arg} = $val;
1450 my ($option, $opt, $arg);
1452 while ($option = shift @options) {
1453 if ($option =~ /^-(.)(.*)/) {
1457 unshift @options, $option;
1460 if ($opt eq "-" && $arg eq "-") {
1465 $warn_undefined_syms = 1;
1466 } elsif ($opt eq "D") {
1467 $arg ||= shift @options;
1468 foreach $arg (split(//, $arg)) {
1471 } elsif ($arg eq "c") {
1473 } elsif ($arg eq "A") {
1475 } elsif ($arg eq "C") {
1477 } elsif ($arg eq "M") {
1480 warn "ignoring unknown debug option: $arg\n";
1483 } elsif ($opt eq "o") {
1484 $arg ||= shift @options;
1485 open(STDOUT, ">$arg") or return "$arg: $!\n";
1486 } elsif ($opt eq "v") {
1488 } elsif ($opt eq "u") {
1489 $arg ||= shift @options;
1490 mark_unused($arg,undef);
1491 } elsif ($opt eq "f") {
1492 $arg ||= shift @options;
1493 if ($arg eq "cog") {
1494 $pv_copy_on_grow = 1;
1495 } elsif ($arg eq "no-cog") {
1496 $pv_copy_on_grow = 0;
1498 } elsif ($opt eq "O") {
1499 $arg = 1 if $arg eq "";
1500 $pv_copy_on_grow = 0;
1502 # Optimisations for -O1
1503 $pv_copy_on_grow = 1;
1505 } elsif ($opt eq "l") {
1506 $max_string_len = $arg;
1513 foreach $objname (@options) {
1514 eval "save_object(\\$objname)";
1519 return sub { save_main() };
1529 B::C - Perl compiler's C backend
1533 perl -MO=C[,OPTIONS] foo.pl
1537 This compiler backend takes Perl source and generates C source code
1538 corresponding to the internal structures that perl uses to run
1539 your program. When the generated C source is compiled and run, it
1540 cuts out the time which perl would have taken to load and parse
1541 your program into its internal semi-compiled form. That means that
1542 compiling with this backend will not help improve the runtime
1543 execution speed of your program but may improve the start-up time.
1544 Depending on the environment in which your program runs this may be
1545 either a help or a hindrance.
1549 If there are any non-option arguments, they are taken to be
1550 names of objects to be saved (probably doesn't work properly yet).
1551 Without extra arguments, it saves the main program.
1557 Output to filename instead of STDOUT
1561 Verbose compilation (currently gives a few compilation statistics).
1565 Force end of options
1569 Force apparently unused subs from package Packname to be compiled.
1570 This allows programs to use eval "foo()" even when sub foo is never
1571 seen to be used at compile time. The down side is that any subs which
1572 really are never used also have code generated. This option is
1573 necessary, for example, if you have a signal handler foo which you
1574 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1575 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1576 options. The compiler tries to figure out which packages may possibly
1577 have subs in which need compiling but the current version doesn't do
1578 it very well. In particular, it is confused by nested packages (i.e.
1579 of the form C<A::B>) where package C<A> does not contain any subs.
1583 Debug options (concatenated or separate flags like C<perl -D>).
1587 OPs, prints each OP as it's processed
1591 COPs, prints COPs as processed (incl. file & line num)
1595 prints AV information on saving
1599 prints CV information on saving
1603 prints MAGIC information on saving
1607 Force optimisations on or off one at a time.
1611 Copy-on-grow: PVs declared and initialised statically.
1619 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
1620 B<-O1> and higher set B<-fcog>.
1624 Some C compilers impose an arbitrary limit on the length of string
1625 constants (e.g. 2048 characters for Microsoft Visual C++). The
1626 B<-llimit> options tells the C backend not to generate string literals
1627 exceeding that limit.
1633 perl -MO=C,-ofoo.c foo.pl
1634 perl cc_harness -o foo foo.c
1636 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1637 library directory. The utility called C<perlcc> may also be used to
1638 help make use of this compiler.
1640 perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null
1644 Plenty. Current status: experimental.
1648 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>