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",
229 ${$op->next}, ${$op->sibling},
230 $op->targ, $op->type, $op_seq, $op->flags,
231 $op->private, ${$op->first}, ${$op->last}));
232 my $ix = $listopsect->index;
233 $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
234 savesym($op, "(OP*)&listop_list[$ix]");
238 my ($op, $level) = @_;
239 my $sym = objsym($op);
240 return $sym if defined $sym;
241 $logopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
242 ${$op->next}, ${$op->sibling},
243 $op->targ, $op->type, $op_seq, $op->flags,
244 $op->private, ${$op->first}, ${$op->other}));
245 my $ix = $logopsect->index;
246 $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
247 savesym($op, "(OP*)&logop_list[$ix]");
251 my ($op, $level) = @_;
252 my $sym = objsym($op);
253 return $sym if defined $sym;
254 #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
255 # peekop($op->redoop), peekop($op->nextop),
256 # peekop($op->lastop)); # debug
257 $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",
258 ${$op->next}, ${$op->sibling},
259 $op->targ, $op->type, $op_seq, $op->flags,
260 $op->private, ${$op->first}, ${$op->last},
261 ${$op->redoop}, ${$op->nextop},
263 my $ix = $loopsect->index;
264 $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
265 savesym($op, "(OP*)&loop_list[$ix]");
269 my ($op, $level) = @_;
270 my $sym = objsym($op);
271 return $sym if defined $sym;
272 $pvopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, %s",
273 ${$op->next}, ${$op->sibling},
274 $op->targ, $op->type, $op_seq, $op->flags,
275 $op->private, cstring($op->pv)));
276 my $ix = $pvopsect->index;
277 $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
278 savesym($op, "(OP*)&pvop_list[$ix]");
282 my ($op, $level) = @_;
283 my $sym = objsym($op);
284 return $sym if defined $sym;
285 my $svsym = $op->sv->save;
286 $svopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, Nullsv",
287 ${$op->next}, ${$op->sibling},
288 $op->targ, $op->type, $op_seq, $op->flags,
290 my $ix = $svopsect->index;
291 $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
292 $init->add("svop_list[$ix].op_sv = (SV*)$svsym;");
293 savesym($op, "(OP*)&svop_list[$ix]");
297 my ($op, $level) = @_;
298 my $sym = objsym($op);
299 return $sym if defined $sym;
300 $padopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, 0",
301 ${$op->next}, ${$op->sibling},
302 $op->targ, $op->type, $op_seq, $op->flags,
304 $init->add(sprintf("padop_list[%d].op_ppaddr = %s;", $padopsect->index, $op->ppaddr));
305 my $ix = $padopsect->index;
306 $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix));
307 savesym($op, "(OP*)&padop_list[$ix]");
311 my ($op, $level) = @_;
312 my $sym = objsym($op);
313 return $sym if defined $sym;
314 warn sprintf("COP: line %d file %s\n", $op->line, $op->file)
316 $copsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, %s, NULL, NULL, %u, %d, %u",
317 ${$op->next}, ${$op->sibling},
318 $op->targ, $op->type, $op_seq, $op->flags,
319 $op->private, cstring($op->label), $op->cop_seq,
320 $op->arybase, $op->line));
321 my $ix = $copsect->index;
322 $init->add(sprintf("cop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
323 $init->add(sprintf("CopFILE_set(&cop_list[$ix], %s);", cstring($op->file)),
324 sprintf("CopSTASHPV_set(&cop_list[$ix], %s);", cstring($op->stashpv)));
325 savesym($op, "(OP*)&cop_list[$ix]");
329 my ($op, $level) = @_;
330 my $sym = objsym($op);
331 return $sym if defined $sym;
332 my $replroot = $op->pmreplroot;
333 my $replstart = $op->pmreplstart;
334 my $replrootfield = sprintf("s\\_%x", $$replroot);
335 my $replstartfield = sprintf("s\\_%x", $$replstart);
337 my $ppaddr = $op->ppaddr;
339 # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
340 # argument to a split) stores a GV in op_pmreplroot instead
341 # of a substitution syntax tree. We don't want to walk that...
342 if ($op->name eq "pushre") {
343 $gvsym = $replroot->save;
344 # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
347 $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
350 # pmnext handling is broken in perl itself, I think. Bad op_pmnext
351 # fields aren't noticed in perl's runtime (unless you try reset) but we
352 # segfault when trying to dereference it to find op->op_pmnext->op_type
353 $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",
354 ${$op->next}, ${$op->sibling}, $op->targ,
355 $op->type, $op_seq, $op->flags, $op->private,
356 ${$op->first}, ${$op->last},
357 $replrootfield, $replstartfield,
358 $op->pmflags, $op->pmpermflags,));
359 my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
360 $init->add(sprintf("$pm.op_ppaddr = %s;", $ppaddr));
361 my $re = $op->precomp;
363 my $resym = sprintf("re%d", $re_index++);
364 $decl->add(sprintf("static char *$resym = %s;", cstring($re)));
365 $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
369 $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
371 savesym($op, "(OP*)&$pm");
374 sub B::SPECIAL::save {
376 # special case: $$sv is not the address but an index into specialsv_list
377 # warn "SPECIAL::save specialsv $$sv\n"; # debug
378 my $sym = $specialsv_name[$$sv];
379 if (!defined($sym)) {
380 confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
385 sub B::OBJECT::save {}
389 my $sym = objsym($sv);
390 return $sym if defined $sym;
391 # warn "Saving SVt_NULL SV\n"; # debug
394 warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
395 return savesym($sv, "Nullsv /* XXX */");
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 $is_empty = $gv->is_empty;
768 my $gvname = $gv->NAME;
769 my $name = cstring($gv->STASH->NAME . "::" . $gvname);
770 #warn "GV name is $name\n"; # debug
775 #warn(sprintf("EGV name is %s, saving it now\n",
776 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
777 $egvsym = $egv->save;
780 $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
781 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
782 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS));
783 $init->add(sprintf("GvLINE($sym) = %u;", $gv->LINE)) unless $is_empty;
785 # Shouldn't need to do save_magic since gv_fetchpv handles that
787 my $refcnt = $gv->REFCNT + 1;
788 $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
790 return $sym if $is_empty;
792 my $gvrefcnt = $gv->GvREFCNT;
794 $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
796 if (defined($egvsym)) {
797 # Shared glob *foo = *bar
798 $init->add("gp_free($sym);",
799 "GvGP($sym) = GvGP($egvsym);");
800 } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
801 # Don't save subfields of special GVs (*_, *1, *# and so on)
802 # warn "GV::save saving subfields\n"; # debug
806 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
807 # warn "GV::save \$$name\n"; # debug
812 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
813 # warn "GV::save \@$name\n"; # debug
818 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
819 # warn "GV::save \%$name\n"; # debug
823 my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
824 "::" . $gvcv->GV->EGV->NAME);
825 if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias
826 # must save as a 'stub' so newXS() has a CV to populate
827 $init->add("{ CV *cv;");
828 $init->add("\tcv=perl_get_cv($origname,TRUE);");
829 $init->add("\tGvCV($sym)=cv;");
830 $init->add("\tSvREFCNT_inc((SV *)cv);");
833 $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
834 # warn "GV::save &$name\n"; # debug
837 $init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE)));
838 # warn "GV::save GvFILE(*$name)\n"; # debug
839 my $gvform = $gv->FORM;
842 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
843 # warn "GV::save GvFORM(*$name)\n"; # debug
848 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
849 # warn "GV::save GvIO(*$name)\n"; # debug
856 my $sym = objsym($av);
857 return $sym if defined $sym;
858 my $avflags = $av->AvFLAGS;
859 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
861 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
862 $xpvavsect->index, $av->REFCNT , $av->FLAGS));
863 my $sv_list_index = $svsect->index;
864 my $fill = $av->FILL;
866 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
868 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
869 #if ($fill > -1 && ($avflags & AVf_REAL)) {
871 my @array = $av->ARRAY;
875 foreach $el (@array) {
876 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
877 $$av, $i++, class($el), $$el);
880 my @names = map($_->save, @array);
881 # XXX Better ways to write loop?
882 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
883 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
886 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
887 "\tav_extend(av, $fill);",
888 "\tsvp = AvARRAY(av);",
889 map("\t*svp++ = (SV*)$_;", @names),
890 "\tAvFILLp(av) = $fill;",
894 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
897 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
902 my $sym = objsym($hv);
903 return $sym if defined $sym;
904 my $name = $hv->NAME;
908 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
909 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
910 # a trashed op but we look at the trashed op_type and segfault.
911 #my $adpmroot = ${$hv->PMROOT};
913 $decl->add("static HV *hv$hv_index;");
914 # XXX Beware of weird package names containing double-quotes, \n, ...?
915 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
917 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
920 $sym = savesym($hv, "hv$hv_index");
924 # It's just an ordinary HV
925 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
926 $hv->MAX, $hv->RITER));
927 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
928 $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS));
929 my $sv_list_index = $svsect->index;
930 my @contents = $hv->ARRAY;
933 for ($i = 1; $i < @contents; $i += 2) {
934 $contents[$i] = $contents[$i]->save;
936 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
938 my ($key, $value) = splice(@contents, 0, 2);
939 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
940 cstring($key),length($key),$value, hash($key)));
941 # $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
942 # cstring($key),length($key),$value, 0));
947 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
952 my $sym = objsym($io);
953 return $sym if defined $sym;
955 $pv = '' unless defined $pv;
956 my $len = length($pv);
957 $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",
958 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
959 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
960 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
961 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
962 cchar($io->IoTYPE), $io->IoFLAGS));
963 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
964 $xpviosect->index, $io->REFCNT , $io->FLAGS));
965 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
967 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
968 $fsym = $io->$field();
970 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
980 # This is where we catch an honest-to-goodness Nullsv (which gets
981 # blessed into B::SV explicitly) and any stray erroneous SVs.
982 return 0 unless $$sv;
983 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
988 my $init_name = shift;
990 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
991 $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect,
992 $loopsect, $copsect, $svsect, $xpvsect,
993 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
994 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
995 $symsect->output(\*STDOUT, "#define %s\n");
997 output_declarations();
998 foreach $section (@sections) {
999 my $lines = $section->index + 1;
1001 my $name = $section->name;
1002 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
1003 print "Static $typename ${name}_list[$lines];\n";
1006 $decl->output(\*STDOUT, "%s\n");
1008 foreach $section (@sections) {
1009 my $lines = $section->index + 1;
1011 my $name = $section->name;
1012 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
1013 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
1014 $section->output(\*STDOUT, "\t{ %s },\n");
1020 static int $init_name()
1025 $init->output(\*STDOUT, "\t%s\n");
1026 print "\treturn 0;\n}\n";
1028 warn compile_stats();
1029 warn "NULLOP count: $nullop_count\n";
1033 sub output_declarations {
1035 #ifdef BROKEN_STATIC_REDECL
1036 #define Static extern
1038 #define Static static
1039 #endif /* BROKEN_STATIC_REDECL */
1041 #ifdef BROKEN_UNION_INIT
1043 * Cribbed from cv.h with ANY (a union) replaced by void*.
1044 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
1047 char * xpv_pv; /* pointer to malloced string */
1048 STRLEN xpv_cur; /* length of xp_pv as a C string */
1049 STRLEN xpv_len; /* allocated size */
1050 IV xof_off; /* integer value */
1051 NV xnv_nv; /* numeric value, if any */
1052 MAGIC* xmg_magic; /* magic for scalar array */
1053 HV* xmg_stash; /* class package */
1058 void (*xcv_xsub) (pTHXo_ CV*);
1062 long xcv_depth; /* >= 2 indicates recursive call */
1066 perl_mutex *xcv_mutexp;
1067 struct perl_thread *xcv_owner; /* current owner thread */
1068 #endif /* USE_THREADS */
1069 cv_flags_t xcv_flags;
1071 #define ANYINIT(i) i
1073 #define XPVCV_or_similar XPVCV
1074 #define ANYINIT(i) {i}
1075 #endif /* BROKEN_UNION_INIT */
1076 #define Nullany ANYINIT(0)
1082 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1087 sub output_boilerplate {
1093 /* Workaround for mapstart: the only op which needs a different ppaddr */
1094 #undef Perl_pp_mapstart
1095 #define Perl_pp_mapstart Perl_pp_grepstart
1096 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1097 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
1099 static void xs_init (pTHX);
1100 static void dl_init (pTHX);
1101 static PerlInterpreter *my_perl;
1108 main(int argc, char **argv, char **env)
1114 PERL_SYS_INIT3(&argc,&argv,&env);
1116 if (!PL_do_undump) {
1117 my_perl = perl_alloc();
1120 perl_construct( my_perl );
1121 PL_perl_destruct_level = 0;
1126 PL_cshlen = strlen(PL_cshname);
1129 #ifdef ALLOW_PERL_OPTIONS
1130 #define EXTRA_OPTIONS 2
1132 #define EXTRA_OPTIONS 3
1133 #endif /* ALLOW_PERL_OPTIONS */
1134 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1135 fakeargv[0] = argv[0];
1138 #ifndef ALLOW_PERL_OPTIONS
1140 #endif /* ALLOW_PERL_OPTIONS */
1141 for (i = 1; i < argc; i++)
1142 fakeargv[i + EXTRA_OPTIONS] = argv[i];
1143 fakeargv[argc + EXTRA_OPTIONS] = 0;
1145 exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1150 sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1151 PL_main_cv = PL_compcv;
1154 exitstatus = perl_init();
1159 exitstatus = perl_run( my_perl );
1161 perl_destruct( my_perl );
1162 perl_free( my_perl );
1169 /* yanked from perl.c */
1173 char *file = __FILE__;
1177 print "\n#ifdef USE_DYNAMIC_LOADING";
1178 print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1179 print "\n#endif\n" ;
1180 # delete $xsub{'DynaLoader'};
1181 delete $xsub{'UNIVERSAL'};
1182 print("/* bootstrapping code*/\n\tSAVETMPS;\n");
1183 print("\ttarg=sv_newmortal();\n");
1184 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1185 print "\tPUSHMARK(sp);\n";
1186 print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
1187 print qq/\tPUTBACK;\n/;
1188 print "\tboot_DynaLoader(aTHX_ NULL);\n";
1189 print qq/\tSPAGAIN;\n/;
1191 foreach my $stashname (keys %xsub){
1192 if ($xsub{$stashname} ne 'Dynamic') {
1193 my $stashxsub=$stashname;
1194 $stashxsub =~ s/::/__/g;
1195 print "\tPUSHMARK(sp);\n";
1196 print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
1197 print qq/\tPUTBACK;\n/;
1198 print "\tboot_$stashxsub(aTHX_ NULL);\n";
1199 print qq/\tSPAGAIN;\n/;
1202 print("\tFREETMPS;\n/* end bootstrapping code */\n");
1209 char *file = __FILE__;
1213 print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
1214 print("\ttarg=sv_newmortal();\n");
1215 foreach my $stashname (@DynaLoader::dl_modules) {
1216 warn "Loaded $stashname\n";
1217 if (exists($xsub{$stashname}) && $xsub{$stashname} eq 'Dynamic') {
1218 my $stashxsub=$stashname;
1219 $stashxsub =~ s/::/__/g;
1220 print "\tPUSHMARK(sp);\n";
1221 print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
1222 print qq/\tPUTBACK;\n/;
1223 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1224 warn "bootstrapping $stashname added to xs_init\n";
1225 print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
1227 print "\tboot_$stashxsub(aTHX_ NULL);\n";
1229 print qq/\tSPAGAIN;\n/;
1232 print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
1238 warn "----Symbol table:\n";
1239 while (($sym, $val) = each %symtable) {
1240 warn "$sym => $val\n";
1242 warn "---End of symbol table\n";
1248 svref_2object($sv)->save;
1252 sub Dummy_BootStrap { }
1257 my $package=$gv->STASH->NAME;
1258 my $name = $gv->NAME;
1264 # We may be looking at this package just because it is a branch in the
1265 # symbol table which is on the path to a package which we need to save
1266 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1268 return unless ($unused_sub_packages{$package});
1269 return unless ($$cv || $$av || $$sv || $$hv);
1275 my $package = shift;
1276 unless ($unused_sub_packages{$package})
1279 $unused_sub_packages{$package} = 1;
1280 if (defined @{$package.'::ISA'})
1282 foreach my $isa (@{$package.'::ISA'})
1284 if ($isa eq 'DynaLoader')
1286 unless (defined(&{$package.'::bootstrap'}))
1288 warn "Forcing bootstrap of $package\n";
1289 eval { $package->bootstrap };
1294 unless ($unused_sub_packages{$isa})
1296 warn "$isa saved (it is in $package\'s \@ISA)\n";
1308 no strict qw(vars refs);
1309 my $package = shift;
1310 $package =~ s/::$//;
1311 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1312 # warn "Considering $package\n";#debug
1313 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1315 # If this package is a prefix to something we are saving, traverse it
1316 # but do not mark it for saving if it is not already
1317 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1319 return 1 if ($u =~ /^$package\:\:/);
1321 if (exists $unused_sub_packages{$package})
1323 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1324 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1325 return $unused_sub_packages{$package};
1327 # Omit the packages which we use (and which cause grief
1328 # because of fancy "goto &$AUTOLOAD" stuff).
1329 # XXX Surely there must be a nicer way to do this.
1330 if ($package eq "FileHandle" || $package eq "Config" ||
1331 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1333 delete_unsaved_hashINC($package);
1334 return $unused_sub_packages{$package} = 0;
1336 # Now see if current package looks like an OO class this is probably too strong.
1337 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1339 if (UNIVERSAL::can($package, $m))
1341 warn "$package has method $m: saving package\n";#debug
1342 return mark_package($package);
1345 delete_unsaved_hashINC($package);
1346 return $unused_sub_packages{$package} = 0;
1348 sub delete_unsaved_hashINC{
1350 $packname =~ s/\:\:/\//g;
1352 # warn "deleting $packname" if $INC{$packname} ;# debug
1353 delete $INC{$packname};
1357 my ($symref, $recurse, $prefix) = @_;
1362 $prefix = '' unless defined $prefix;
1363 while (($sym, $ref) = each %$symref)
1368 $sym = $prefix . $sym;
1369 if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym))
1371 walkpackages(\%glob, $recurse, $sym);
1378 sub save_unused_subs
1381 &descend_marked_unused;
1383 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1384 warn "Saving methods\n";
1385 walksymtable(\%{"main::"}, "savecv", \&should_save);
1390 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1391 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1392 my $inc_hv = svref_2object(\%INC)->save;
1393 my $inc_av = svref_2object(\@INC)->save;
1394 my $amagic_generate= amagic_generation;
1395 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1396 "GvHV(PL_incgv) = $inc_hv;",
1397 "GvAV(PL_incgv) = $inc_av;",
1398 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1399 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1400 "PL_amagic_generation= $amagic_generate;" );
1403 sub descend_marked_unused {
1404 foreach my $pack (keys %unused_sub_packages)
1406 mark_package($pack);
1411 warn "Starting compile\n";
1412 warn "Walking tree\n";
1413 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1414 walkoptree(main_root, "save");
1415 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1417 my $init_av = init_av->save;
1418 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1419 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1420 "PL_initav = (AV *) $init_av;");
1422 warn "Writing output\n";
1423 output_boilerplate();
1425 output_all("perl_init");
1431 my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1432 binop => \$binopsect, condop => \$condopsect,
1433 cop => \$copsect, padop => \$padopsect,
1434 listop => \$listopsect, logop => \$logopsect,
1435 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1436 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1437 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1438 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1439 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1440 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1441 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1442 xpvio => \$xpviosect);
1443 my ($name, $sectref);
1444 while (($name, $sectref) = splice(@sections, 0, 2)) {
1445 $$sectref = new B::C::Section $name, \%symtable, 0;
1451 my ($arg,$val) = @_;
1452 $unused_sub_packages{$arg} = $val;
1457 my ($option, $opt, $arg);
1459 while ($option = shift @options) {
1460 if ($option =~ /^-(.)(.*)/) {
1464 unshift @options, $option;
1467 if ($opt eq "-" && $arg eq "-") {
1472 $warn_undefined_syms = 1;
1473 } elsif ($opt eq "D") {
1474 $arg ||= shift @options;
1475 foreach $arg (split(//, $arg)) {
1478 } elsif ($arg eq "c") {
1480 } elsif ($arg eq "A") {
1482 } elsif ($arg eq "C") {
1484 } elsif ($arg eq "M") {
1487 warn "ignoring unknown debug option: $arg\n";
1490 } elsif ($opt eq "o") {
1491 $arg ||= shift @options;
1492 open(STDOUT, ">$arg") or return "$arg: $!\n";
1493 } elsif ($opt eq "v") {
1495 } elsif ($opt eq "u") {
1496 $arg ||= shift @options;
1497 mark_unused($arg,undef);
1498 } elsif ($opt eq "f") {
1499 $arg ||= shift @options;
1500 if ($arg eq "cog") {
1501 $pv_copy_on_grow = 1;
1502 } elsif ($arg eq "no-cog") {
1503 $pv_copy_on_grow = 0;
1505 } elsif ($opt eq "O") {
1506 $arg = 1 if $arg eq "";
1507 $pv_copy_on_grow = 0;
1509 # Optimisations for -O1
1510 $pv_copy_on_grow = 1;
1512 } elsif ($opt eq "l") {
1513 $max_string_len = $arg;
1520 foreach $objname (@options) {
1521 eval "save_object(\\$objname)";
1526 return sub { save_main() };
1536 B::C - Perl compiler's C backend
1540 perl -MO=C[,OPTIONS] foo.pl
1544 This compiler backend takes Perl source and generates C source code
1545 corresponding to the internal structures that perl uses to run
1546 your program. When the generated C source is compiled and run, it
1547 cuts out the time which perl would have taken to load and parse
1548 your program into its internal semi-compiled form. That means that
1549 compiling with this backend will not help improve the runtime
1550 execution speed of your program but may improve the start-up time.
1551 Depending on the environment in which your program runs this may be
1552 either a help or a hindrance.
1556 If there are any non-option arguments, they are taken to be
1557 names of objects to be saved (probably doesn't work properly yet).
1558 Without extra arguments, it saves the main program.
1564 Output to filename instead of STDOUT
1568 Verbose compilation (currently gives a few compilation statistics).
1572 Force end of options
1576 Force apparently unused subs from package Packname to be compiled.
1577 This allows programs to use eval "foo()" even when sub foo is never
1578 seen to be used at compile time. The down side is that any subs which
1579 really are never used also have code generated. This option is
1580 necessary, for example, if you have a signal handler foo which you
1581 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1582 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1583 options. The compiler tries to figure out which packages may possibly
1584 have subs in which need compiling but the current version doesn't do
1585 it very well. In particular, it is confused by nested packages (i.e.
1586 of the form C<A::B>) where package C<A> does not contain any subs.
1590 Debug options (concatenated or separate flags like C<perl -D>).
1594 OPs, prints each OP as it's processed
1598 COPs, prints COPs as processed (incl. file & line num)
1602 prints AV information on saving
1606 prints CV information on saving
1610 prints MAGIC information on saving
1614 Force optimisations on or off one at a time.
1618 Copy-on-grow: PVs declared and initialised statically.
1626 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
1627 B<-O1> and higher set B<-fcog>.
1631 Some C compilers impose an arbitrary limit on the length of string
1632 constants (e.g. 2048 characters for Microsoft Visual C++). The
1633 B<-llimit> options tells the C backend not to generate string literals
1634 exceeding that limit.
1640 perl -MO=C,-ofoo.c foo.pl
1641 perl cc_harness -o foo foo.c
1643 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1644 library directory. The utility called C<perlcc> may also be used to
1645 help make use of this compiler.
1647 perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null
1651 Plenty. Current status: experimental.
1655 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>