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);
60 my $handle_VC_problem = "";
61 $handle_VC_problem="{0}," if $^O eq 'MSWin32' and $Config{cc} =~ /^cl/i;
67 my $anonsub_index = 0;
68 my $initsub_index = 0;
72 my $warn_undefined_syms;
74 my %unused_sub_packages;
76 my $pv_copy_on_grow = 0;
77 my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
81 @threadsv_names = threadsv_names();
85 my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect,
86 $gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
87 $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
88 $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
89 $xrvsect, $xpvbmsect, $xpviosect );
91 sub walk_and_save_optree;
92 my $saveoptree_callback = \&walk_and_save_optree;
93 sub set_callback { $saveoptree_callback = shift }
94 sub saveoptree { &$saveoptree_callback(@_) }
96 sub walk_and_save_optree {
97 my ($name, $root, $start) = @_;
98 walkoptree($root, "save");
99 return objsym($start);
102 # Current workaround/fix for op_free() trying to free statically
103 # defined OPs is to set op_seq = -1 and check for that in op_free().
104 # Instead of hardwiring -1 in place of $op->seq, we use $op_seq
105 # so that it can be changed back easily if necessary. In fact, to
106 # stop compilers from moaning about a U16 being initialised with an
107 # uncast -1 (the printf format is %d so we can't tweak it), we have
108 # to "know" that op_seq is a U16 and use 65535. Ugh.
111 # Look this up here so we can do just a number compare
112 # rather than looking up the name of every BASEOP in B::OP
113 my $OP_THREADSV = opnumber('threadsv');
116 my ($obj, $value) = @_;
117 my $sym = sprintf("s\\_%x", $$obj);
118 $symtable{$sym} = $value;
123 return $symtable{sprintf("s\\_%x", $$obj)};
130 return 0 if $sym eq "sym_0"; # special case
131 $value = $symtable{$sym};
132 if (defined($value)) {
135 warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
142 $pv = '' unless defined $pv; # Is this sane ?
145 if ($pv_copy_on_grow) {
146 my $cstring = cstring($pv);
147 if ($cstring ne "0") { # sic
148 $pvsym = sprintf("pv%d", $pv_index++);
149 $decl->add(sprintf("static char %s[] = %s;", $pvsym, $cstring));
152 $pvmax = length($pv) + 1;
154 return ($pvsym, $pvmax);
158 my ($op, $level) = @_;
159 my $sym = objsym($op);
160 return $sym if defined $sym;
161 my $type = $op->type;
162 $nullop_count++ unless $type;
163 if ($type == $OP_THREADSV) {
164 # saves looking up ppaddr but it's a bit naughty to hard code this
165 $init->add(sprintf("(void)find_threadsv(%s);",
166 cstring($threadsv_names[$op->targ])));
168 $opsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x",
169 ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
170 $type, $op_seq, $op->flags, $op->private));
171 savesym($op, sprintf("&op_list[%d]", $opsect->index));
175 my ($class, %objdata) = @_;
176 bless \%objdata, $class;
179 sub B::FAKEOP::save {
180 my ($op, $level) = @_;
181 $opsect->add(sprintf("%s, %s, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x",
182 $op->next, $op->sibling, $op->ppaddr, $op->targ,
183 $op->type, $op_seq, $op->flags, $op->private));
184 return sprintf("&op_list[%d]", $opsect->index);
187 sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
188 sub B::FAKEOP::type { $_[0]->{type} || 0}
189 sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
190 sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
191 sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
192 sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
193 sub B::FAKEOP::private { $_[0]->{private} || 0 }
196 my ($op, $level) = @_;
197 my $sym = objsym($op);
198 return $sym if defined $sym;
199 $unopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, s\\_%x",
200 ${$op->next}, ${$op->sibling}, $op->ppaddr,
201 $op->targ, $op->type, $op_seq, $op->flags,
202 $op->private, ${$op->first}));
203 savesym($op, sprintf("(OP*)&unop_list[%d]", $unopsect->index));
207 my ($op, $level) = @_;
208 my $sym = objsym($op);
209 return $sym if defined $sym;
210 $binopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
211 ${$op->next}, ${$op->sibling}, $op->ppaddr,
212 $op->targ, $op->type, $op_seq, $op->flags,
213 $op->private, ${$op->first}, ${$op->last}));
214 savesym($op, sprintf("(OP*)&binop_list[%d]", $binopsect->index));
217 sub B::LISTOP::save {
218 my ($op, $level) = @_;
219 my $sym = objsym($op);
220 return $sym if defined $sym;
221 $listopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u",
222 ${$op->next}, ${$op->sibling}, $op->ppaddr,
223 $op->targ, $op->type, $op_seq, $op->flags,
224 $op->private, ${$op->first}, ${$op->last},
226 savesym($op, sprintf("(OP*)&listop_list[%d]", $listopsect->index));
230 my ($op, $level) = @_;
231 my $sym = objsym($op);
232 return $sym if defined $sym;
233 $logopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
234 ${$op->next}, ${$op->sibling}, $op->ppaddr,
235 $op->targ, $op->type, $op_seq, $op->flags,
236 $op->private, ${$op->first}, ${$op->other}));
237 savesym($op, sprintf("(OP*)&logop_list[%d]", $logopsect->index));
241 my ($op, $level) = @_;
242 my $sym = objsym($op);
243 return $sym if defined $sym;
244 #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
245 # peekop($op->redoop), peekop($op->nextop),
246 # peekop($op->lastop)); # debug
247 $loopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, s\\_%x, s\\_%x, s\\_%x",
248 ${$op->next}, ${$op->sibling}, $op->ppaddr,
249 $op->targ, $op->type, $op_seq, $op->flags,
250 $op->private, ${$op->first}, ${$op->last},
251 $op->children, ${$op->redoop}, ${$op->nextop},
253 savesym($op, sprintf("(OP*)&loop_list[%d]", $loopsect->index));
257 my ($op, $level) = @_;
258 my $sym = objsym($op);
259 return $sym if defined $sym;
260 $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, $handle_VC_problem %u, %u, %u, 0x%x, 0x%x, %s",
261 ${$op->next}, ${$op->sibling}, $op->ppaddr,
262 $op->targ, $op->type, $op_seq, $op->flags,
263 $op->private, cstring($op->pv)));
264 savesym($op, sprintf("(OP*)&pvop_list[%d]", $pvopsect->index));
268 my ($op, $level) = @_;
269 my $sym = objsym($op);
270 return $sym if defined $sym;
271 my $svsym = $op->sv->save;
272 $svopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, %s",
273 ${$op->next}, ${$op->sibling}, $op->ppaddr,
274 $op->targ, $op->type, $op_seq, $op->flags,
275 $op->private, "(SV*)$svsym"));
276 savesym($op, sprintf("(OP*)&svop_list[%d]", $svopsect->index));
280 my ($op, $level) = @_;
281 my $sym = objsym($op);
282 return $sym if defined $sym;
283 my $gvsym = $op->gv->save;
284 $gvopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, Nullgv",
285 ${$op->next}, ${$op->sibling}, $op->ppaddr,
286 $op->targ, $op->type, $op_seq, $op->flags,
288 $init->add(sprintf("gvop_list[%d].op_gv = %s;", $gvopsect->index, $gvsym));
289 savesym($op, sprintf("(OP*)&gvop_list[%d]", $gvopsect->index));
293 my ($op, $level) = @_;
294 my $sym = objsym($op);
295 return $sym if defined $sym;
296 my $gvsym = $op->filegv->save;
297 my $stashsym = $op->stash->save;
298 warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV)
300 $copsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u",
301 ${$op->next}, ${$op->sibling}, $op->ppaddr,
302 $op->targ, $op->type, $op_seq, $op->flags,
303 $op->private, cstring($op->label), $op->cop_seq,
304 $op->arybase, $op->line));
305 my $copix = $copsect->index;
306 $init->add(sprintf("cop_list[%d].cop_filegv = %s;", $copix, $gvsym),
307 sprintf("cop_list[%d].cop_stash = %s;", $copix, $stashsym));
308 savesym($op, "(OP*)&cop_list[$copix]");
312 my ($op, $level) = @_;
313 my $sym = objsym($op);
314 return $sym if defined $sym;
315 my $replroot = $op->pmreplroot;
316 my $replstart = $op->pmreplstart;
317 my $replrootfield = sprintf("s\\_%x", $$replroot);
318 my $replstartfield = sprintf("s\\_%x", $$replstart);
320 my $ppaddr = $op->ppaddr;
322 # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
323 # argument to a split) stores a GV in op_pmreplroot instead
324 # of a substitution syntax tree. We don't want to walk that...
325 if ($op->name eq "pushre") {
326 $gvsym = $replroot->save;
327 # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
330 $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
333 # pmnext handling is broken in perl itself, I think. Bad op_pmnext
334 # fields aren't noticed in perl's runtime (unless you try reset) but we
335 # segfault when trying to dereference it to find op->op_pmnext->op_type
336 $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, %s, %s, 0, 0, 0x%x, 0x%x",
337 ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ,
338 $op->type, $op_seq, $op->flags, $op->private,
339 ${$op->first}, ${$op->last}, $op->children,
340 $replrootfield, $replstartfield,
341 $op->pmflags, $op->pmpermflags,));
342 my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
343 my $re = $op->precomp;
345 my $resym = sprintf("re%d", $re_index++);
346 $decl->add(sprintf("static char *$resym = %s;", cstring($re)));
347 $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
351 $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
353 savesym($op, sprintf("(OP*)&pmop_list[%d]", $pmopsect->index));
356 sub B::SPECIAL::save {
358 # special case: $$sv is not the address but an index into specialsv_list
359 # warn "SPECIAL::save specialsv $$sv\n"; # debug
360 my $sym = $specialsv_name[$$sv];
361 if (!defined($sym)) {
362 confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
367 sub B::OBJECT::save {}
371 my $sym = objsym($sv);
372 return $sym if defined $sym;
373 # warn "Saving SVt_NULL SV\n"; # debug
376 # warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
378 $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT + 1, $sv->FLAGS));
379 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
384 my $sym = objsym($sv);
385 return $sym if defined $sym;
386 $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
387 $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
388 $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
389 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
394 my $sym = objsym($sv);
395 return $sym if defined $sym;
397 $val .= '.00' if $val =~ /^-?\d+$/;
398 $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
399 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
400 $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
401 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
406 my $sym = objsym($sv);
407 return $sym if defined $sym;
409 my $len = length($pv);
410 my ($pvsym, $pvmax) = savepv($pv);
411 my ($lvtarg, $lvtarg_sym);
412 $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
413 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
414 $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
415 $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
416 $xpvlvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
417 if (!$pv_copy_on_grow) {
418 $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);",
419 $xpvlvsect->index, cstring($pv), $len));
422 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
427 my $sym = objsym($sv);
428 return $sym if defined $sym;
430 my $len = length($pv);
431 my ($pvsym, $pvmax) = savepv($pv);
432 $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
433 $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
434 $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
435 if (!$pv_copy_on_grow) {
436 $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);",
437 $xpvivsect->index, cstring($pv), $len));
439 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
444 my $sym = objsym($sv);
445 return $sym if defined $sym;
447 $pv = '' unless defined $pv;
448 my $len = length($pv);
449 my ($pvsym, $pvmax) = savepv($pv);
451 $val .= '.00' if $val =~ /^-?\d+$/;
452 $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
453 $pvsym, $len, $pvmax, $sv->IVX, $val));
454 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
455 $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
456 if (!$pv_copy_on_grow) {
457 $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);",
458 $xpvnvsect->index, cstring($pv), $len));
460 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
465 my $sym = objsym($sv);
466 return $sym if defined $sym;
467 my $pv = $sv->PV . "\0" . $sv->TABLE;
468 my $len = length($pv);
469 $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
470 $len, $len + 258, $sv->IVX, $sv->NVX,
471 $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
472 $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
473 $xpvbmsect->index, $sv->REFCNT + 1, $sv->FLAGS));
475 $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);",
476 $xpvbmsect->index, cstring($pv), $len),
477 sprintf("xpvbm_list[%d].xpv_cur = %u;",
478 $xpvbmsect->index, $len - 257));
479 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
484 my $sym = objsym($sv);
485 return $sym if defined $sym;
487 my $len = length($pv);
488 my ($pvsym, $pvmax) = savepv($pv);
489 $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
490 $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
491 $xpvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
492 if (!$pv_copy_on_grow) {
493 $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);",
494 $xpvsect->index, cstring($pv), $len));
496 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
501 my $sym = objsym($sv);
502 return $sym if defined $sym;
504 my $len = length($pv);
505 my ($pvsym, $pvmax) = savepv($pv);
506 $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
507 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
508 $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
509 $xpvmgsect->index, $sv->REFCNT + 1, $sv->FLAGS));
510 if (!$pv_copy_on_grow) {
511 $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);",
512 $xpvmgsect->index, cstring($pv), $len));
514 $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
519 sub B::PVMG::save_magic {
521 #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
522 my $stash = $sv->SvSTASH;
525 warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
527 # XXX Hope stash is already going to be saved.
528 $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
530 my @mgchain = $sv->MAGIC;
531 my ($mg, $type, $obj, $ptr,$len,$ptrsv);
532 foreach $mg (@mgchain) {
538 warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
539 class($sv), $$sv, class($obj), $$obj,
540 cchar($type), cstring($ptr));
543 if ($len == HEf_SVKEY){
544 #The pointer is an SV*
545 $ptrsv=svref_2object($ptr)->save;
546 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
547 $$sv, $$obj, cchar($type),$ptrsv,$len));
549 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
550 $$sv, $$obj, cchar($type),cstring($ptr),$len));
557 my $sym = objsym($sv);
558 return $sym if defined $sym;
559 my $rv = $sv->RV->save;
560 $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/;
562 $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
563 $xrvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
564 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
568 my ($cvstashname, $cvname) = @_;
569 warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
570 # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
571 # use should be handled by the class itself.
573 my $isa = \@{"$cvstashname\::ISA"};
574 if (grep($_ eq "AutoLoader", @$isa)) {
575 warn "Forcing immediate load of sub derived from AutoLoader\n";
576 # Tweaked version of AutoLoader::AUTOLOAD
577 my $dir = $cvstashname;
579 eval { require "auto/$dir/$cvname.al" };
581 warn qq(failed require "auto/$dir/$cvname.al": $@\n);
591 my $sym = objsym($cv);
593 # warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
596 # Reserve a place in svsect and xpvcvsect and record indices
598 my $cvstashname = $gv->STASH->NAME;
599 my $cvname = $gv->NAME;
600 my $root = $cv->ROOT;
601 my $cvxsub = $cv->XSUB;
602 #INIT is removed from the symbol table, so this call must come
603 # from PL_initav->save. Re-bootstrapping will push INIT back in
604 # so nullop should be sent.
605 if ($cvxsub && ($cvname ne "INIT")) {
607 my $stashname = $egv->STASH->NAME;
608 if ($cvname eq "bootstrap")
610 my $file = $cv->FILEGV->SV->PV;
611 $decl->add("/* bootstrap $file */");
612 warn "Bootstrap $stashname $file\n";
613 $xsub{$stashname}='Dynamic';
614 # $xsub{$stashname}='Static' unless $xsub{$stashname};
617 warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv;
618 return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/;
620 if ($cvxsub && $cvname eq "INIT") {
622 return svref_2object(\&Dummy_initxs)->save;
624 my $sv_ix = $svsect->index + 1;
625 $svsect->add("svix$sv_ix");
626 my $xpvcv_ix = $xpvcvsect->index + 1;
627 $xpvcvsect->add("xpvcvix$xpvcv_ix");
628 # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
629 $sym = savesym($cv, "&sv_list[$sv_ix]");
630 warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv;
631 if (!$$root && !$cvxsub) {
632 if (try_autoload($cvstashname, $cvname)) {
633 # Recalculate root and xsub
636 if ($$root || $cvxsub) {
637 warn "Successful forced autoload\n";
642 my $padlist = $cv->PADLIST;
645 my $xsubany = "Nullany";
647 warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
648 $$cv, $$root) if $debug_cv;
651 my $stashname = $gv->STASH->NAME;
652 my $gvname = $gv->NAME;
653 if ($gvname ne "__ANON__") {
654 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
655 $ppname .= ($stashname eq "main") ?
656 $gvname : "$stashname\::$gvname";
657 $ppname =~ s/::/__/g;
658 if ($gvname eq "INIT"){
659 $ppname .= "_$initsub_index";
665 $ppname = "pp_anonsub_$anonsub_index";
668 $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
669 warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
670 $$cv, $ppname, $$root) if $debug_cv;
672 warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
673 $$padlist, $$cv) if $debug_cv;
675 warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
676 $$padlist, $$cv) if $debug_cv;
680 warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
681 $cvstashname, $cvname); # debug
683 $pv = '' unless defined $pv; # Avoid use of undef warnings
684 $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, Nullgv, %d, s\\_%x, (CV*)s\\_%x, 0x%x",
685 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
686 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
687 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
689 if (${$cv->OUTSIDE} == ${main_cv()}){
690 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
691 $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
696 $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
697 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
698 $$gv, $$cv) if $debug_cv;
700 my $filegv = $cv->FILEGV;
703 $init->add(sprintf("CvFILEGV(s\\_%x) = s\\_%x;", $$cv, $$filegv));
704 warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n",
705 $$filegv, $$cv) if $debug_cv;
707 my $stash = $cv->STASH;
710 $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
711 warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
712 $$stash, $$cv) if $debug_cv;
714 $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
715 $sv_ix, $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS));
721 my $sym = objsym($gv);
723 #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
726 my $ix = $gv_index++;
727 $sym = savesym($gv, "gv_list[$ix]");
728 #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
730 my $gvname = $gv->NAME;
731 my $name = cstring($gv->STASH->NAME . "::" . $gvname);
732 #warn "GV name is $name\n"; # debug
736 #warn(sprintf("EGV name is %s, saving it now\n",
737 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
738 $egvsym = $egv->save;
740 $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
741 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
742 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS),
743 sprintf("GvLINE($sym) = %u;", $gv->LINE));
744 # Shouldn't need to do save_magic since gv_fetchpv handles that
746 my $refcnt = $gv->REFCNT + 1;
747 $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
748 my $gvrefcnt = $gv->GvREFCNT;
750 $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
752 if (defined($egvsym)) {
753 # Shared glob *foo = *bar
754 $init->add("gp_free($sym);",
755 "GvGP($sym) = GvGP($egvsym);");
756 } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
757 # Don't save subfields of special GVs (*_, *1, *# and so on)
758 # warn "GV::save saving subfields\n"; # debug
762 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
763 # warn "GV::save \$$name\n"; # debug
768 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
769 # warn "GV::save \@$name\n"; # debug
774 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
775 # warn "GV::save \%$name\n"; # debug
779 my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
780 "::" . $gvcv->GV->EGV->NAME);
781 if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias
782 # must save as a 'stub' so newXS() has a CV to populate
783 $init->add("{ CV *cv;");
784 $init->add("\tcv=perl_get_cv($origname,TRUE);");
785 $init->add("\tGvCV($sym)=cv;");
786 $init->add("\tSvREFCNT_inc((SV *)cv);");
789 $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
790 # warn "GV::save &$name\n"; # debug
793 my $gvfilegv = $gv->FILEGV;
796 $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv));
797 # warn "GV::save GvFILEGV(*$name)\n"; # debug
799 my $gvform = $gv->FORM;
802 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
803 # warn "GV::save GvFORM(*$name)\n"; # debug
808 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
809 # warn "GV::save GvIO(*$name)\n"; # debug
816 my $sym = objsym($av);
817 return $sym if defined $sym;
818 my $avflags = $av->AvFLAGS;
819 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
821 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
822 $xpvavsect->index, $av->REFCNT + 1, $av->FLAGS));
823 my $sv_list_index = $svsect->index;
824 my $fill = $av->FILL;
826 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
828 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
829 #if ($fill > -1 && ($avflags & AVf_REAL)) {
831 my @array = $av->ARRAY;
835 foreach $el (@array) {
836 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
837 $$av, $i++, class($el), $$el);
840 my @names = map($_->save, @array);
841 # XXX Better ways to write loop?
842 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
843 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
846 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
847 "\tav_extend(av, $fill);",
848 "\tsvp = AvARRAY(av);",
849 map("\t*svp++ = (SV*)$_;", @names),
850 "\tAvFILLp(av) = $fill;",
854 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
857 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
862 my $sym = objsym($hv);
863 return $sym if defined $sym;
864 my $name = $hv->NAME;
868 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
869 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
870 # a trashed op but we look at the trashed op_type and segfault.
871 #my $adpmroot = ${$hv->PMROOT};
873 $decl->add("static HV *hv$hv_index;");
874 # XXX Beware of weird package names containing double-quotes, \n, ...?
875 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
877 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
880 $sym = savesym($hv, "hv$hv_index");
884 # It's just an ordinary HV
885 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
886 $hv->MAX, $hv->RITER));
887 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
888 $xpvhvsect->index, $hv->REFCNT + 1, $hv->FLAGS));
889 my $sv_list_index = $svsect->index;
890 my @contents = $hv->ARRAY;
893 for ($i = 1; $i < @contents; $i += 2) {
894 $contents[$i] = $contents[$i]->save;
896 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
898 my ($key, $value) = splice(@contents, 0, 2);
899 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
900 cstring($key),length($key),$value, hash($key)));
901 # $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
902 # cstring($key),length($key),$value, 0));
907 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
912 my $sym = objsym($io);
913 return $sym if defined $sym;
915 $pv = '' unless defined $pv;
916 my $len = length($pv);
917 $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",
918 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
919 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
920 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
921 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
922 cchar($io->IoTYPE), $io->IoFLAGS));
923 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
924 $xpviosect->index, $io->REFCNT + 1, $io->FLAGS));
925 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
927 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
928 $fsym = $io->$field();
930 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
940 # This is where we catch an honest-to-goodness Nullsv (which gets
941 # blessed into B::SV explicitly) and any stray erroneous SVs.
942 return 0 unless $$sv;
943 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
948 my $init_name = shift;
950 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
951 $listopsect, $pmopsect, $svopsect, $gvopsect, $pvopsect,
952 $loopsect, $copsect, $svsect, $xpvsect,
953 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
954 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
955 $symsect->output(\*STDOUT, "#define %s\n");
957 output_declarations();
958 foreach $section (@sections) {
959 my $lines = $section->index + 1;
961 my $name = $section->name;
962 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
963 print "Static $typename ${name}_list[$lines];\n";
966 $decl->output(\*STDOUT, "%s\n");
968 foreach $section (@sections) {
969 my $lines = $section->index + 1;
971 my $name = $section->name;
972 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
973 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
974 $section->output(\*STDOUT, "\t{ %s },\n");
980 static int $init_name()
986 $init->output(\*STDOUT, "\t%s\n");
987 print "\treturn 0;\n}\n";
989 warn compile_stats();
990 warn "NULLOP count: $nullop_count\n";
994 sub output_declarations {
996 #ifdef BROKEN_STATIC_REDECL
997 #define Static extern
999 #define Static static
1000 #endif /* BROKEN_STATIC_REDECL */
1002 #ifdef BROKEN_UNION_INIT
1004 * Cribbed from cv.h with ANY (a union) replaced by void*.
1005 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
1008 char * xpv_pv; /* pointer to malloced string */
1009 STRLEN xpv_cur; /* length of xp_pv as a C string */
1010 STRLEN xpv_len; /* allocated size */
1011 IV xof_off; /* integer value */
1012 double xnv_nv; /* numeric value, if any */
1013 MAGIC* xmg_magic; /* magic for scalar array */
1014 HV* xmg_stash; /* class package */
1019 void (*xcv_xsub) (CV*);
1023 long xcv_depth; /* >= 2 indicates recursive call */
1027 perl_mutex *xcv_mutexp;
1028 struct perl_thread *xcv_owner; /* current owner thread */
1029 #endif /* USE_THREADS */
1032 #define ANYINIT(i) i
1034 #define XPVCV_or_similar XPVCV
1035 #define ANYINIT(i) {i}
1036 #endif /* BROKEN_UNION_INIT */
1037 #define Nullany ANYINIT(0)
1043 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1048 sub output_boilerplate {
1053 /* Workaround for mapstart: the only op which needs a different ppaddr */
1054 #undef Perl_pp_mapstart
1055 #define Perl_pp_mapstart Perl_pp_grepstart
1056 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1057 EXTERN_C void boot_DynaLoader (CV* cv);
1059 static void xs_init (void);
1060 static void dl_init (void);
1061 static PerlInterpreter *my_perl;
1068 #ifndef CAN_PROTOTYPE
1069 main(argc, argv, env)
1073 #else /* def(CAN_PROTOTYPE) */
1074 main(int argc, char **argv, char **env)
1075 #endif /* def(CAN_PROTOTYPE) */
1081 PERL_SYS_INIT(&argc,&argv);
1083 perl_init_i18nl10n(1);
1085 if (!PL_do_undump) {
1086 my_perl = perl_alloc();
1089 perl_construct( my_perl );
1094 PL_cshlen = strlen(PL_cshname);
1097 #ifdef ALLOW_PERL_OPTIONS
1098 #define EXTRA_OPTIONS 2
1100 #define EXTRA_OPTIONS 3
1101 #endif /* ALLOW_PERL_OPTIONS */
1102 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1103 fakeargv[0] = argv[0];
1106 #ifndef ALLOW_PERL_OPTIONS
1108 #endif /* ALLOW_PERL_OPTIONS */
1109 for (i = 1; i < argc; i++)
1110 fakeargv[i + EXTRA_OPTIONS] = argv[i];
1111 fakeargv[argc + EXTRA_OPTIONS] = 0;
1113 exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1118 sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1119 PL_main_cv = PL_compcv;
1122 exitstatus = perl_init();
1127 exitstatus = perl_run( my_perl );
1129 perl_destruct( my_perl );
1130 perl_free( my_perl );
1135 /* yanked from perl.c */
1139 char *file = __FILE__;
1143 print "\n#ifdef USE_DYNAMIC_LOADING";
1144 print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1145 print "\n#endif\n" ;
1146 # delete $xsub{'DynaLoader'};
1147 delete $xsub{'UNIVERSAL'};
1148 print("/* bootstrapping code*/\n\tSAVETMPS;\n");
1149 print("\ttarg=sv_newmortal();\n");
1150 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1151 print "\tPUSHMARK(sp);\n";
1152 print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
1153 print qq/\tPUTBACK;\n/;
1154 print "\tboot_DynaLoader(NULL);\n";
1155 print qq/\tSPAGAIN;\n/;
1157 foreach my $stashname (keys %xsub){
1158 if ($xsub{$stashname} ne 'Dynamic') {
1159 my $stashxsub=$stashname;
1160 $stashxsub =~ s/::/__/g;
1161 print "\tPUSHMARK(sp);\n";
1162 print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
1163 print qq/\tPUTBACK;\n/;
1164 print "\tboot_$stashxsub(NULL);\n";
1165 print qq/\tSPAGAIN;\n/;
1168 print("\tFREETMPS;\n/* end bootstrapping code */\n");
1175 char *file = __FILE__;
1179 print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
1180 print("\ttarg=sv_newmortal();\n");
1181 foreach my $stashname (@DynaLoader::dl_modules) {
1182 warn "Loaded $stashname\n";
1183 if (exists($xsub{$stashname}) && $xsub{$stashname} eq 'Dynamic') {
1184 my $stashxsub=$stashname;
1185 $stashxsub =~ s/::/__/g;
1186 print "\tPUSHMARK(sp);\n";
1187 print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
1188 print qq/\tPUTBACK;\n/;
1189 print "#ifdef DYNALOADER_BOOTSTRAP\n";
1190 warn "bootstrapping $stashname added to xs_init\n";
1191 print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
1193 print "\tboot_$stashxsub(NULL);\n";
1195 print qq/\tSPAGAIN;\n/;
1198 print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
1204 warn "----Symbol table:\n";
1205 while (($sym, $val) = each %symtable) {
1206 warn "$sym => $val\n";
1208 warn "---End of symbol table\n";
1214 svref_2object($sv)->save;
1218 sub Dummy_BootStrap { }
1223 my $package=$gv->STASH->NAME;
1224 my $name = $gv->NAME;
1230 # We may be looking at this package just because it is a branch in the
1231 # symbol table which is on the path to a package which we need to save
1232 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1234 return unless ($unused_sub_packages{$package});
1235 return unless ($$cv || $$av || $$sv || $$hv);
1241 my $package = shift;
1242 unless ($unused_sub_packages{$package})
1245 $unused_sub_packages{$package} = 1;
1246 if (@{$package.'::ISA'})
1248 foreach my $isa (@{$package.'::ISA'})
1250 if ($isa eq 'DynaLoader')
1252 unless (defined(&{$package.'::bootstrap'}))
1254 warn "Forcing bootstrap of $package\n";
1255 eval { $package->bootstrap };
1260 unless ($unused_sub_packages{$isa})
1262 warn "$isa saved (it is in $package\'s \@ISA)\n";
1274 no strict qw(vars refs);
1275 my $package = shift;
1276 $package =~ s/::$//;
1277 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1278 # warn "Considering $package\n";#debug
1279 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1281 # If this package is a prefix to something we are saving, traverse it
1282 # but do not mark it for saving if it is not already
1283 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1285 return 1 if ($u =~ /^$package\:\:/);
1287 if (exists $unused_sub_packages{$package})
1289 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1290 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1291 return $unused_sub_packages{$package};
1293 # Omit the packages which we use (and which cause grief
1294 # because of fancy "goto &$AUTOLOAD" stuff).
1295 # XXX Surely there must be a nicer way to do this.
1296 if ($package eq "FileHandle" || $package eq "Config" ||
1297 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1299 delete_unsaved_hashINC($package);
1300 return $unused_sub_packages{$package} = 0;
1302 # Now see if current package looks like an OO class this is probably too strong.
1303 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1305 if ($package->can($m))
1307 warn "$package has method $m: saving package\n";#debug
1308 return mark_package($package);
1311 delete_unsaved_hashINC($package);
1312 return $unused_sub_packages{$package} = 0;
1314 sub delete_unsaved_hashINC{
1316 $packname =~ s/\:\:/\//g;
1318 # warn "deleting $packname" if $INC{$packname} ;# debug
1319 delete $INC{$packname};
1323 my ($symref, $recurse, $prefix) = @_;
1328 $prefix = '' unless defined $prefix;
1329 while (($sym, $ref) = each %$symref)
1334 $sym = $prefix . $sym;
1335 if ($sym ne "main::" && &$recurse($sym))
1337 walkpackages(\%glob, $recurse, $sym);
1344 sub save_unused_subs
1347 &descend_marked_unused;
1349 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1350 warn "Saving methods\n";
1351 walksymtable(\%{"main::"}, "savecv", \&should_save);
1356 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1357 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1358 my $inc_hv = svref_2object(\%INC)->save;
1359 my $inc_av = svref_2object(\@INC)->save;
1360 my $amagic_generate= amagic_generation;
1361 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1362 "GvHV(PL_incgv) = $inc_hv;",
1363 "GvAV(PL_incgv) = $inc_av;",
1364 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1365 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1366 "PL_amagic_generation= $amagic_generate;" );
1369 sub descend_marked_unused {
1370 foreach my $pack (keys %unused_sub_packages)
1372 mark_package($pack);
1377 warn "Starting compile\n";
1378 warn "Walking tree\n";
1379 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1380 walkoptree(main_root, "save");
1381 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1383 my $init_av = init_av->save;
1384 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1385 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1386 "PL_initav = (AV *) $init_av;");
1388 warn "Writing output\n";
1389 output_boilerplate();
1391 output_all("perl_init");
1397 my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1398 binop => \$binopsect, condop => \$condopsect,
1399 cop => \$copsect, gvop => \$gvopsect,
1400 listop => \$listopsect, logop => \$logopsect,
1401 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1402 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1403 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1404 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1405 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1406 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1407 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1408 xpvio => \$xpviosect);
1409 my ($name, $sectref);
1410 while (($name, $sectref) = splice(@sections, 0, 2)) {
1411 $$sectref = new B::C::Section $name, \%symtable, 0;
1417 my ($arg,$val) = @_;
1418 $unused_sub_packages{$arg} = $val;
1423 my ($option, $opt, $arg);
1425 while ($option = shift @options) {
1426 if ($option =~ /^-(.)(.*)/) {
1430 unshift @options, $option;
1433 if ($opt eq "-" && $arg eq "-") {
1438 $warn_undefined_syms = 1;
1439 } elsif ($opt eq "D") {
1440 $arg ||= shift @options;
1441 foreach $arg (split(//, $arg)) {
1444 } elsif ($arg eq "c") {
1446 } elsif ($arg eq "A") {
1448 } elsif ($arg eq "C") {
1450 } elsif ($arg eq "M") {
1453 warn "ignoring unknown debug option: $arg\n";
1456 } elsif ($opt eq "o") {
1457 $arg ||= shift @options;
1458 open(STDOUT, ">$arg") or return "$arg: $!\n";
1459 } elsif ($opt eq "v") {
1461 } elsif ($opt eq "u") {
1462 $arg ||= shift @options;
1463 mark_unused($arg,undef);
1464 } elsif ($opt eq "f") {
1465 $arg ||= shift @options;
1466 if ($arg eq "cog") {
1467 $pv_copy_on_grow = 1;
1468 } elsif ($arg eq "no-cog") {
1469 $pv_copy_on_grow = 0;
1471 } elsif ($opt eq "O") {
1472 $arg = 1 if $arg eq "";
1473 $pv_copy_on_grow = 0;
1475 # Optimisations for -O1
1476 $pv_copy_on_grow = 1;
1484 foreach $objname (@options) {
1485 eval "save_object(\\$objname)";
1490 return sub { save_main() };
1500 B::C - Perl compiler's C backend
1504 perl -MO=C[,OPTIONS] foo.pl
1508 This compiler backend takes Perl source and generates C source code
1509 corresponding to the internal structures that perl uses to run
1510 your program. When the generated C source is compiled and run, it
1511 cuts out the time which perl would have taken to load and parse
1512 your program into its internal semi-compiled form. That means that
1513 compiling with this backend will not help improve the runtime
1514 execution speed of your program but may improve the start-up time.
1515 Depending on the environment in which your program runs this may be
1516 either a help or a hindrance.
1520 If there are any non-option arguments, they are taken to be
1521 names of objects to be saved (probably doesn't work properly yet).
1522 Without extra arguments, it saves the main program.
1528 Output to filename instead of STDOUT
1532 Verbose compilation (currently gives a few compilation statistics).
1536 Force end of options
1540 Force apparently unused subs from package Packname to be compiled.
1541 This allows programs to use eval "foo()" even when sub foo is never
1542 seen to be used at compile time. The down side is that any subs which
1543 really are never used also have code generated. This option is
1544 necessary, for example, if you have a signal handler foo which you
1545 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1546 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1547 options. The compiler tries to figure out which packages may possibly
1548 have subs in which need compiling but the current version doesn't do
1549 it very well. In particular, it is confused by nested packages (i.e.
1550 of the form C<A::B>) where package C<A> does not contain any subs.
1554 Debug options (concatenated or separate flags like C<perl -D>).
1558 OPs, prints each OP as it's processed
1562 COPs, prints COPs as processed (incl. file & line num)
1566 prints AV information on saving
1570 prints CV information on saving
1574 prints MAGIC information on saving
1578 Force optimisations on or off one at a time.
1582 Copy-on-grow: PVs declared and initialised statically.
1590 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
1591 B<-O1> and higher set B<-fcog>.
1595 perl -MO=C,-ofoo.c foo.pl
1596 perl cc_harness -o foo foo.c
1598 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1599 library directory. The utility called C<perlcc> may also be used to
1600 help make use of this compiler.
1602 perl -MO=C,-v,-DcA bar.pl > /dev/null
1606 Plenty. Current status: experimental.
1610 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>