3 # Copyright (c) 1996, 1997, 1998 Malcolm Beattie
5 # You may distribute under the terms of either the GNU General Public
6 # License or the Artistic License, as specified in the README file.
10 our $VERSION = '1.01';
18 my $o = $class->SUPER::new(@_);
19 push @$o, { values => [] };
26 push(@{$section->[-1]{values}},@_);
32 return scalar(@{$section->[-1]{values}})-1;
37 my ($section, $fh, $format) = @_;
38 my $sym = $section->symtable || {};
39 my $default = $section->default;
40 foreach (@{$section->[-1]{values}})
42 s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
43 printf $fh $format, $_;
47 package B::C::InitSection;
49 use vars qw(@ISA); @ISA = qw(B::C::Section);
53 my $section = $class->SUPER::new( @_ );
55 $section->[-1]{evals} = [];
64 foreach my $i ( @strings ) {
67 push @{$section->[-1]{evals}}, @strings;
73 foreach my $i ( @{$section->[-1]{evals}} ) {
74 $section->add( sprintf q{eval_pv("%s",1);}, $i );
76 $section->SUPER::output( @_ );
83 @EXPORT_OK = qw(output_all output_boilerplate output_main mark_unused
84 init_sections set_callback save_unused_subs objsym save_context);
86 use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop
87 class cstring cchar svref_2object compile_stats comppadlist hash
88 threadsv_names main_cv init_av end_av opnumber amagic_generation
89 AVf_REAL HEf_SVKEY SVf_POK SVf_ROK CVf_CONST);
90 use B::Asmdata qw(@specialsv_name);
102 my $anonsub_index = 0;
103 my $initsub_index = 0;
107 my $warn_undefined_syms;
109 my %unused_sub_packages;
112 my $pv_copy_on_grow = 0;
113 my $optimize_ppaddr = 0;
114 my $optimize_warn_sv = 0;
115 my $use_perl_script_name = 0;
116 my $save_data_fh = 0;
118 my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
123 @threadsv_names = threadsv_names();
127 my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect,
128 $padopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
129 $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
130 $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
131 $xrvsect, $xpvbmsect, $xpviosect );
132 my @op_sections = \( $binopsect, $condopsect, $copsect, $padopsect, $listopsect,
133 $logopsect, $loopsect, $opsect, $pmopsect, $pvopsect, $svopsect,
136 sub walk_and_save_optree;
137 my $saveoptree_callback = \&walk_and_save_optree;
138 sub set_callback { $saveoptree_callback = shift }
139 sub saveoptree { &$saveoptree_callback(@_) }
141 sub walk_and_save_optree {
142 my ($name, $root, $start) = @_;
143 walkoptree($root, "save");
144 return objsym($start);
147 # Current workaround/fix for op_free() trying to free statically
148 # defined OPs is to set op_seq = -1 and check for that in op_free().
149 # Instead of hardwiring -1 in place of $op->seq, we use $op_seq
150 # so that it can be changed back easily if necessary. In fact, to
151 # stop compilers from moaning about a U16 being initialised with an
152 # uncast -1 (the printf format is %d so we can't tweak it), we have
153 # to "know" that op_seq is a U16 and use 65535. Ugh.
156 # Look this up here so we can do just a number compare
157 # rather than looking up the name of every BASEOP in B::OP
158 my $OP_THREADSV = opnumber('threadsv');
161 my ($obj, $value) = @_;
162 my $sym = sprintf("s\\_%x", $$obj);
163 $symtable{$sym} = $value;
168 return $symtable{sprintf("s\\_%x", $$obj)};
175 return 0 if $sym eq "sym_0"; # special case
176 $value = $symtable{$sym};
177 if (defined($value)) {
180 warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
187 my $sym = sprintf("re%d", $re_index++);
188 $decl->add(sprintf("static char *$sym = %s;", cstring($re)));
190 return ($sym,length(pack "a*",$re));
195 $pv = '' unless defined $pv; # Is this sane ?
198 if ($pv_copy_on_grow) {
199 my $cstring = cstring($pv);
200 if ($cstring ne "0") { # sic
201 $pvsym = sprintf("pv%d", $pv_index++);
202 $decl->add(sprintf("static char %s[] = %s;", $pvsym, $cstring));
205 $pvmax = length(pack "a*",$pv) + 1;
207 return ($pvsym, $pvmax);
212 # confess "Can't save RV: not ROK" unless $sv->FLAGS & SVf_ROK;
213 my $rv = $sv->RV->save;
215 $rv =~ s/^\(([AGHS]V|IO)\s*\*\)\s*(\&sv_list.*)$/$2/;
220 # savesym, pvmax, len, pv
224 my $rok = $sv->FLAGS & SVf_ROK;
225 my $pok = $sv->FLAGS & SVf_POK;
226 my( $pv, $len, $savesym, $pvmax );
228 $savesym = '(char*)' . save_rv( $sv );
231 $pv = $pok ? (pack "a*", $sv->PV) : undef;
232 $len = $pok ? length($pv) : 0;
233 ($savesym, $pvmax) = $pok ? savepv($pv) : ( 'NULL', 0 );
236 return ( $savesym, $pvmax, $len, $pv );
239 # see also init_op_ppaddr below; initializes the ppaddt to the
240 # OpTYPE; init_op_ppaddr iterates over the ops and sets
241 # op_ppaddr to PL_ppaddr[op_ppaddr]; this avoids an explicit assignmente
242 # in perl_init ( ~10 bytes/op with GCC/i386 )
243 sub B::OP::fake_ppaddr {
244 return $optimize_ppaddr ?
245 sprintf("INT2PTR(void*,OP_%s)", uc( $_[0]->name ) ) :
250 my ($op, $level) = @_;
251 my $sym = objsym($op);
252 return $sym if defined $sym;
253 my $type = $op->type;
254 $nullop_count++ unless $type;
255 if ($type == $OP_THREADSV) {
256 # saves looking up ppaddr but it's a bit naughty to hard code this
257 $init->add(sprintf("(void)find_threadsv(%s);",
258 cstring($threadsv_names[$op->targ])));
260 $opsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x",
261 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, $op->targ,
262 $type, $op_seq, $op->flags, $op->private));
263 my $ix = $opsect->index;
264 $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr))
265 unless $optimize_ppaddr;
266 savesym($op, "&op_list[$ix]");
270 my ($class, %objdata) = @_;
271 bless \%objdata, $class;
274 sub B::FAKEOP::save {
275 my ($op, $level) = @_;
276 $opsect->add(sprintf("%s, %s, %s, %u, %u, %u, 0x%x, 0x%x",
277 $op->next, $op->sibling, $op->fake_ppaddr, $op->targ,
278 $op->type, $op_seq, $op->flags, $op->private));
279 my $ix = $opsect->index;
280 $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr))
281 unless $optimize_ppaddr;
282 return "&op_list[$ix]";
285 sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
286 sub B::FAKEOP::type { $_[0]->{type} || 0}
287 sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
288 sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
289 sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
290 sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
291 sub B::FAKEOP::private { $_[0]->{private} || 0 }
294 my ($op, $level) = @_;
295 my $sym = objsym($op);
296 return $sym if defined $sym;
297 $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x",
298 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
299 $op->targ, $op->type, $op_seq, $op->flags,
300 $op->private, ${$op->first}));
301 my $ix = $unopsect->index;
302 $init->add(sprintf("unop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
303 unless $optimize_ppaddr;
304 savesym($op, "(OP*)&unop_list[$ix]");
308 my ($op, $level) = @_;
309 my $sym = objsym($op);
310 return $sym if defined $sym;
311 $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
312 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
313 $op->targ, $op->type, $op_seq, $op->flags,
314 $op->private, ${$op->first}, ${$op->last}));
315 my $ix = $binopsect->index;
316 $init->add(sprintf("binop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
317 unless $optimize_ppaddr;
318 savesym($op, "(OP*)&binop_list[$ix]");
321 sub B::LISTOP::save {
322 my ($op, $level) = @_;
323 my $sym = objsym($op);
324 return $sym if defined $sym;
325 $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
326 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
327 $op->targ, $op->type, $op_seq, $op->flags,
328 $op->private, ${$op->first}, ${$op->last}));
329 my $ix = $listopsect->index;
330 $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
331 unless $optimize_ppaddr;
332 savesym($op, "(OP*)&listop_list[$ix]");
336 my ($op, $level) = @_;
337 my $sym = objsym($op);
338 return $sym if defined $sym;
339 $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
340 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
341 $op->targ, $op->type, $op_seq, $op->flags,
342 $op->private, ${$op->first}, ${$op->other}));
343 my $ix = $logopsect->index;
344 $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
345 unless $optimize_ppaddr;
346 savesym($op, "(OP*)&logop_list[$ix]");
350 my ($op, $level) = @_;
351 my $sym = objsym($op);
352 return $sym if defined $sym;
353 #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
354 # peekop($op->redoop), peekop($op->nextop),
355 # peekop($op->lastop)); # debug
356 $loopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x",
357 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
358 $op->targ, $op->type, $op_seq, $op->flags,
359 $op->private, ${$op->first}, ${$op->last},
360 ${$op->redoop}, ${$op->nextop},
362 my $ix = $loopsect->index;
363 $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
364 unless $optimize_ppaddr;
365 savesym($op, "(OP*)&loop_list[$ix]");
369 my ($op, $level) = @_;
370 my $sym = objsym($op);
371 return $sym if defined $sym;
372 $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
373 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
374 $op->targ, $op->type, $op_seq, $op->flags,
375 $op->private, cstring($op->pv)));
376 my $ix = $pvopsect->index;
377 $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
378 unless $optimize_ppaddr;
379 savesym($op, "(OP*)&pvop_list[$ix]");
383 my ($op, $level) = @_;
384 my $sym = objsym($op);
385 return $sym if defined $sym;
386 my $svsym = $op->sv->save;
387 $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullsv",
388 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
389 $op->targ, $op->type, $op_seq, $op->flags,
391 my $ix = $svopsect->index;
392 $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
393 unless $optimize_ppaddr;
394 $init->add("svop_list[$ix].op_sv = (SV*)$svsym;");
395 savesym($op, "(OP*)&svop_list[$ix]");
399 my ($op, $level) = @_;
400 my $sym = objsym($op);
401 return $sym if defined $sym;
402 $padopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, 0",
403 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
404 $op->targ, $op->type, $op_seq, $op->flags,
406 my $ix = $padopsect->index;
407 $init->add(sprintf("padop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
408 unless $optimize_ppaddr;
409 $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix));
410 savesym($op, "(OP*)&padop_list[$ix]");
414 my ($op, $level) = @_;
415 my $sym = objsym($op);
416 return $sym if defined $sym;
417 warn sprintf("COP: line %d file %s\n", $op->line, $op->file)
419 # shameless cut'n'paste from B::Deparse
421 my $warnings = $op->warnings;
422 my $is_special = $warnings->isa("B::SPECIAL");
423 if ($is_special && $$warnings == 4) {
424 # use warnings 'all';
425 $warn_sv = $optimize_warn_sv ?
429 elsif ($is_special && $$warnings == 5) {
431 $warn_sv = $optimize_warn_sv ?
435 elsif ($is_special) {
437 $warn_sv = $optimize_warn_sv ?
443 $warn_sv = $warnings->save;
446 $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, NULL, NULL, %u, %d, %u, %s",
447 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
448 $op->targ, $op->type, $op_seq, $op->flags,
449 $op->private, cstring($op->label), $op->cop_seq,
450 $op->arybase, $op->line,
451 ( $optimize_warn_sv ? $warn_sv : 'NULL' )));
452 my $ix = $copsect->index;
453 $init->add(sprintf("cop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
454 unless $optimize_ppaddr;
455 $init->add(sprintf("cop_list[$ix].cop_warnings = %s;", $warn_sv ))
456 unless $optimize_warn_sv;
457 $init->add(sprintf("CopFILE_set(&cop_list[$ix], %s);", cstring($op->file)),
458 sprintf("CopSTASHPV_set(&cop_list[$ix], %s);", cstring($op->stashpv)));
460 savesym($op, "(OP*)&cop_list[$ix]");
464 my ($op, $level) = @_;
465 my $sym = objsym($op);
466 return $sym if defined $sym;
467 my $replroot = $op->pmreplroot;
468 my $replstart = $op->pmreplstart;
469 my $replrootfield = sprintf("s\\_%x", $$replroot);
470 my $replstartfield = sprintf("s\\_%x", $$replstart);
472 my $ppaddr = $op->ppaddr;
474 # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
475 # argument to a split) stores a GV in op_pmreplroot instead
476 # of a substitution syntax tree. We don't want to walk that...
477 if ($op->name eq "pushre") {
478 $gvsym = $replroot->save;
479 # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
482 $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
485 # pmnext handling is broken in perl itself, I think. Bad op_pmnext
486 # fields aren't noticed in perl's runtime (unless you try reset) but we
487 # segfault when trying to dereference it to find op->op_pmnext->op_type
488 $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %s, %s, 0, 0, 0x%x, 0x%x",
489 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, $op->targ,
490 $op->type, $op_seq, $op->flags, $op->private,
491 ${$op->first}, ${$op->last},
492 $replrootfield, $replstartfield,
493 $op->pmflags, $op->pmpermflags,));
494 my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
495 $init->add(sprintf("$pm.op_ppaddr = %s;", $ppaddr))
496 unless $optimize_ppaddr;
497 my $re = $op->precomp;
499 my( $resym, $relen ) = savere( $re );
500 $init->add(sprintf("PM_SETRE(&$pm,pregcomp($resym, $resym + %u, &$pm));",
504 $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
506 savesym($op, "(OP*)&$pm");
509 sub B::SPECIAL::save {
511 # special case: $$sv is not the address but an index into specialsv_list
512 # warn "SPECIAL::save specialsv $$sv\n"; # debug
513 my $sym = $specialsv_name[$$sv];
514 if (!defined($sym)) {
515 confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
520 sub B::OBJECT::save {}
524 my $sym = objsym($sv);
525 return $sym if defined $sym;
526 # warn "Saving SVt_NULL SV\n"; # debug
529 warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
530 return savesym($sv, "(void*)Nullsv /* XXX */");
532 $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS));
533 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
538 my $sym = objsym($sv);
539 return $sym if defined $sym;
540 $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
541 $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
542 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
543 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
548 my $sym = objsym($sv);
549 return $sym if defined $sym;
551 $val .= '.00' if $val =~ /^-?\d+$/;
552 $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
553 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
554 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
555 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
561 # work with byte offsets/lengths
562 my $pv = pack "a*", $pv;
563 if (defined $max_string_len && length($pv) > $max_string_len) {
564 push @res, sprintf("New(0,%s,%u,char);", $dest, length($pv)+1);
567 my $str = substr $pv, 0, $max_string_len, '';
568 push @res, sprintf("Copy(%s,$dest+$offset,%u,char);",
569 cstring($str), length($str));
570 $offset += length $str;
572 push @res, sprintf("%s[%u] = '\\0';", $dest, $offset);
575 push @res, sprintf("%s = savepvn(%s, %u);", $dest,
576 cstring($pv), length($pv));
583 my $sym = objsym($sv);
584 return $sym if defined $sym;
586 my $len = length($pv);
587 my ($pvsym, $pvmax) = savepv($pv);
588 my ($lvtarg, $lvtarg_sym);
589 $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
590 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
591 $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
592 $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
593 $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS));
594 if (!$pv_copy_on_grow) {
595 $init->add(savepvn(sprintf("xpvlv_list[%d].xpv_pv",
596 $xpvlvsect->index), $pv));
599 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
604 my $sym = objsym($sv);
605 return $sym if defined $sym;
606 my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
607 $xpvivsect->add(sprintf("%s, %u, %u, %d", $savesym, $len, $pvmax, $sv->IVX));
608 $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
609 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
610 if (defined($pv) && !$pv_copy_on_grow) {
611 $init->add(savepvn(sprintf("xpviv_list[%d].xpv_pv",
612 $xpvivsect->index), $pv));
614 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
619 my $sym = objsym($sv);
620 return $sym if defined $sym;
621 my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
623 $val .= '.00' if $val =~ /^-?\d+$/;
624 $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
625 $savesym, $len, $pvmax, $sv->IVX, $val));
626 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
627 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
628 if (defined($pv) && !$pv_copy_on_grow) {
629 $init->add(savepvn(sprintf("xpvnv_list[%d].xpv_pv",
630 $xpvnvsect->index), $pv));
632 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
637 my $sym = objsym($sv);
638 return $sym if defined $sym;
639 my $pv = pack "a*", ($sv->PV . "\0" . $sv->TABLE);
640 my $len = length($pv);
641 $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
642 $len, $len + 258, $sv->IVX, $sv->NVX,
643 $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
644 $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
645 $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS));
647 $init->add(savepvn(sprintf("xpvbm_list[%d].xpv_pv",
648 $xpvbmsect->index), $pv),
649 sprintf("xpvbm_list[%d].xpv_cur = %u;",
650 $xpvbmsect->index, $len - 257));
651 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
656 my $sym = objsym($sv);
657 return $sym if defined $sym;
658 my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
659 $xpvsect->add(sprintf("%s, %u, %u", $savesym, $len, $pvmax));
660 $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
661 $xpvsect->index, $sv->REFCNT , $sv->FLAGS));
662 if (defined($pv) && !$pv_copy_on_grow) {
663 $init->add(savepvn(sprintf("xpv_list[%d].xpv_pv",
664 $xpvsect->index), $pv));
666 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
671 my $sym = objsym($sv);
672 return $sym if defined $sym;
673 my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
675 $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
676 $savesym, $len, $pvmax,
677 $sv->IVX, $sv->NVX));
678 $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
679 $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS));
680 if (defined($pv) && !$pv_copy_on_grow) {
681 $init->add(savepvn(sprintf("xpvmg_list[%d].xpv_pv",
682 $xpvmgsect->index), $pv));
684 $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
689 sub B::PVMG::save_magic {
691 #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
692 my $stash = $sv->SvSTASH;
695 warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
697 # XXX Hope stash is already going to be saved.
698 $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
700 my @mgchain = $sv->MAGIC;
701 my ($mg, $type, $obj, $ptr,$len,$ptrsv);
702 foreach $mg (@mgchain) {
707 warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
708 class($sv), $$sv, class($obj), $$obj,
709 cchar($type), cstring($ptr));
712 unless( $type eq 'r' ) {
717 if ($len == HEf_SVKEY){
718 #The pointer is an SV*
719 $ptrsv=svref_2object($ptr)->save;
720 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
721 $$sv, $$obj, cchar($type),$ptrsv,$len));
722 }elsif( $type eq 'r' ){
723 # can't save r-MAGIC: we need a PMOP to recompile
724 # the regexp, so die 'cleanly'
725 confess "Can't save r-MAGICAL scalars (yet)"
726 # my($resym,$relen) = savere( $sv->precomp );
727 # $init->add(sprintf("sv_magic((SV*)s\\_%x, , %s, %s, %d);",
728 # $$sv, $resym, cchar($type),cstring($ptr),$len));
730 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
731 $$sv, $$obj, cchar($type),cstring($ptr),$len));
738 my $sym = objsym($sv);
739 return $sym if defined $sym;
740 my $rv = save_rv( $sv );
741 # GVs need to be handled at runtime
742 if( ref( $sv->RV ) eq 'B::GV' ) {
743 $xrvsect->add( "(SV*)Nullgv" );
744 $init->add(sprintf("xrv_list[%d].xrv_rv = (SV*)%s;\n", $xrvsect->index, $rv));
747 elsif( $sv->RV->isa( 'B::HV' ) && $sv->RV->NAME ) {
748 $xrvsect->add( "(SV*)Nullhv" );
749 $init->add(sprintf("xrv_list[%d].xrv_rv = (SV*)%s;\n", $xrvsect->index, $rv));
754 $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
755 $xrvsect->index, $sv->REFCNT , $sv->FLAGS));
756 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
760 my ($cvstashname, $cvname) = @_;
761 warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
762 # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
763 # use should be handled by the class itself.
765 my $isa = \@{"$cvstashname\::ISA"};
766 if (grep($_ eq "AutoLoader", @$isa)) {
767 warn "Forcing immediate load of sub derived from AutoLoader\n";
768 # Tweaked version of AutoLoader::AUTOLOAD
769 my $dir = $cvstashname;
771 eval { require "auto/$dir/$cvname.al" };
773 warn qq(failed require "auto/$dir/$cvname.al": $@\n);
783 my $sym = objsym($cv);
785 # warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
788 # Reserve a place in svsect and xpvcvsect and record indices
790 my ($cvname, $cvstashname);
793 $cvstashname = $gv->STASH->NAME;
795 my $root = $cv->ROOT;
796 my $cvxsub = $cv->XSUB;
797 my $isconst = $cv->CvFLAGS & CVf_CONST;
799 my $value = $cv->XSUBANY;
800 my $stash = $gv->STASH;
801 my $vsym = $value->save;
802 my $stsym = $stash->save;
803 my $name = cstring($cvname);
804 $decl->add( "static CV* cv$cv_index;" );
805 $init->add( "cv$cv_index = newCONSTSUB( $stsym, NULL, $vsym );" );
806 my $sym = savesym( $cv, "cv$cv_index" );
810 #INIT is removed from the symbol table, so this call must come
811 # from PL_initav->save. Re-bootstrapping will push INIT back in
812 # so nullop should be sent.
813 if (!$isconst && $cvxsub && ($cvname ne "INIT")) {
815 my $stashname = $egv->STASH->NAME;
816 if ($cvname eq "bootstrap")
818 my $file = $gv->FILE;
819 $decl->add("/* bootstrap $file */");
820 warn "Bootstrap $stashname $file\n";
821 # if it not isa('DynaLoader'), it should hopefully be XSLoaded
822 # ( attributes being an exception, of course )
823 if( $stashname ne 'attributes' &&
824 !UNIVERSAL::isa($stashname,'DynaLoader') ) {
825 $xsub{$stashname}='Dynamic-XSLoaded';
829 $xsub{$stashname}='Dynamic';
831 # $xsub{$stashname}='Static' unless $xsub{$stashname};
836 # XSUBs for IO::File, IO::Handle, IO::Socket,
837 # IO::Seekable and IO::Poll
838 # are defined in IO.xs, so let's bootstrap it
839 svref_2object( \&IO::bootstrap )->save
840 if grep { $stashname eq $_ } qw(IO::File IO::Handle IO::Socket
841 IO::Seekable IO::Poll);
843 warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv;
844 return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/;
846 if ($cvxsub && $cvname eq "INIT") {
848 return svref_2object(\&Dummy_initxs)->save;
850 my $sv_ix = $svsect->index + 1;
851 $svsect->add("svix$sv_ix");
852 my $xpvcv_ix = $xpvcvsect->index + 1;
853 $xpvcvsect->add("xpvcvix$xpvcv_ix");
854 # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
855 $sym = savesym($cv, "&sv_list[$sv_ix]");
856 warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv;
857 if (!$$root && !$cvxsub) {
858 if (try_autoload($cvstashname, $cvname)) {
859 # Recalculate root and xsub
862 if ($$root || $cvxsub) {
863 warn "Successful forced autoload\n";
868 my $padlist = $cv->PADLIST;
871 my $xsubany = "Nullany";
873 warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
874 $$cv, $$root) if $debug_cv;
877 my $stashname = $gv->STASH->NAME;
878 my $gvname = $gv->NAME;
879 if ($gvname ne "__ANON__") {
880 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
881 $ppname .= ($stashname eq "main") ?
882 $gvname : "$stashname\::$gvname";
883 $ppname =~ s/::/__/g;
884 if ($gvname eq "INIT"){
885 $ppname .= "_$initsub_index";
891 $ppname = "pp_anonsub_$anonsub_index";
894 $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
895 warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
896 $$cv, $ppname, $$root) if $debug_cv;
898 warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
899 $$padlist, $$cv) if $debug_cv;
901 warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
902 $$padlist, $$cv) if $debug_cv;
906 warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
907 $cvstashname, $cvname); # debug
909 $pv = '' unless defined $pv; # Avoid use of undef warnings
910 $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",
911 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
912 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
913 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
915 if (${$cv->OUTSIDE} == ${main_cv()}){
916 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
917 $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
922 $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
923 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
924 $$gv, $$cv) if $debug_cv;
926 $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE)));
927 my $stash = $cv->STASH;
930 $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
931 warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
932 $$stash, $$cv) if $debug_cv;
934 $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
935 $sv_ix, $xpvcv_ix, $cv->REFCNT +1 , $cv->FLAGS));
941 my $sym = objsym($gv);
943 #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
946 my $ix = $gv_index++;
947 $sym = savesym($gv, "gv_list[$ix]");
948 #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
950 my $is_empty = $gv->is_empty;
951 my $gvname = $gv->NAME;
952 my $fullname = $gv->STASH->NAME . "::" . $gvname;
953 my $name = cstring($fullname);
954 #warn "GV name is $name\n"; # debug
959 #warn(sprintf("EGV name is %s, saving it now\n",
960 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
961 $egvsym = $egv->save;
964 $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
965 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
966 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS));
967 $init->add(sprintf("GvLINE($sym) = %u;", $gv->LINE)) unless $is_empty;
969 # Shouldn't need to do save_magic since gv_fetchpv handles that
971 my $refcnt = $gv->REFCNT + 1;
972 $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
974 return $sym if $is_empty;
976 my $gvrefcnt = $gv->GvREFCNT;
978 $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
980 # some non-alphavetic globs require some parts to be saved
981 # ( ex. %!, but not $! )
986 sub Save_FORM() { 16 }
989 if( $gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/ ) {
990 $savefields = Save_HV|Save_AV|Save_SV|Save_CV|Save_FORM|Save_IO;
992 elsif( $gvname eq '!' ) {
993 $savefields = Save_HV;
995 # attributes::bootstrap is created in perl_parse
996 # saving it would overwrite it, because perl_init() is
997 # called after perl_parse()
998 $savefields&=~Save_CV if $fullname eq 'attributes::bootstrap';
1001 if (defined($egvsym)) {
1002 # Shared glob *foo = *bar
1003 $init->add("gp_free($sym);",
1004 "GvGP($sym) = GvGP($egvsym);");
1005 } elsif ($savefields) {
1006 # Don't save subfields of special GVs (*_, *1, *# and so on)
1007 # warn "GV::save saving subfields\n"; # debug
1009 if ($$gvsv && $savefields&Save_SV) {
1011 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
1012 # warn "GV::save \$$name\n"; # debug
1015 if ($$gvav && $savefields&Save_AV) {
1017 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
1018 # warn "GV::save \@$name\n"; # debug
1021 if ($$gvhv && $savefields&Save_HV) {
1023 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
1024 # warn "GV::save \%$name\n"; # debug
1027 if ($$gvcv && $savefields&Save_CV) {
1028 my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
1029 "::" . $gvcv->GV->EGV->NAME);
1030 if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias
1031 # must save as a 'stub' so newXS() has a CV to populate
1032 $init->add("{ CV *cv;");
1033 $init->add("\tcv=perl_get_cv($origname,TRUE);");
1034 $init->add("\tGvCV($sym)=cv;");
1035 $init->add("\tSvREFCNT_inc((SV *)cv);");
1038 $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
1039 # warn "GV::save &$name\n"; # debug
1042 $init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE)));
1043 # warn "GV::save GvFILE(*$name)\n"; # debug
1044 my $gvform = $gv->FORM;
1045 if ($$gvform && $savefields&Save_FORM) {
1047 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
1048 # warn "GV::save GvFORM(*$name)\n"; # debug
1051 if ($$gvio && $savefields&Save_IO) {
1053 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
1054 if( $fullname =~ m/::DATA$/ && $save_data_fh ) {
1056 my $fh = *{$fullname}{IO};
1058 $gvio->save_data( $fullname, <$fh> ) if $fh->opened;
1060 # warn "GV::save GvIO(*$name)\n"; # debug
1067 my $sym = objsym($av);
1068 return $sym if defined $sym;
1069 my $avflags = $av->AvFLAGS;
1070 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
1072 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
1073 $xpvavsect->index, $av->REFCNT , $av->FLAGS));
1074 my $sv_list_index = $svsect->index;
1075 my $fill = $av->FILL;
1077 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
1079 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
1080 #if ($fill > -1 && ($avflags & AVf_REAL)) {
1082 my @array = $av->ARRAY;
1086 foreach $el (@array) {
1087 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
1088 $$av, $i++, class($el), $$el);
1091 my @names = map($_->save, @array);
1092 # XXX Better ways to write loop?
1093 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
1094 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
1097 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
1098 "\tav_extend(av, $fill);",
1099 "\tsvp = AvARRAY(av);",
1100 map("\t*svp++ = (SV*)$_;", @names),
1101 "\tAvFILLp(av) = $fill;",
1105 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
1108 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
1113 my $sym = objsym($hv);
1114 return $sym if defined $sym;
1115 my $name = $hv->NAME;
1119 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
1120 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
1121 # a trashed op but we look at the trashed op_type and segfault.
1122 #my $adpmroot = ${$hv->PMROOT};
1124 $decl->add("static HV *hv$hv_index;");
1125 # XXX Beware of weird package names containing double-quotes, \n, ...?
1126 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
1128 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
1131 $sym = savesym($hv, "hv$hv_index");
1135 # It's just an ordinary HV
1136 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
1137 $hv->MAX, $hv->RITER));
1138 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
1139 $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS));
1140 my $sv_list_index = $svsect->index;
1141 my @contents = $hv->ARRAY;
1144 for ($i = 1; $i < @contents; $i += 2) {
1145 $contents[$i] = $contents[$i]->save;
1147 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
1149 my ($key, $value) = splice(@contents, 0, 2);
1150 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
1151 cstring($key),length(pack "a*",$key),
1152 $value, hash($key)));
1153 # $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
1154 # cstring($key),length($key),$value, 0));
1159 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
1162 sub B::IO::save_data {
1163 my( $io, $globname, @data ) = @_;
1164 my $data = join '', @data;
1166 # XXX using $DATA might clobber it!
1167 my $sym = svref_2object( \\$data )->save;
1168 foreach my $i ( split /\n/, <<CODE ) {
1170 GV* gv = (GV*)gv_fetchpv( "$globname", TRUE, SVt_PV );
1177 # for PerlIO::Scalar
1179 $init->add_eval( sprintf 'open(%s, "<", $%s)', $globname, $globname );
1184 my $sym = objsym($io);
1185 return $sym if defined $sym;
1187 $pv = '' unless defined $pv;
1188 my $len = length($pv);
1189 $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",
1190 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
1191 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
1192 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
1193 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
1194 cchar($io->IoTYPE), $io->IoFLAGS));
1195 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
1196 $xpviosect->index, $io->REFCNT , $io->FLAGS));
1197 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
1198 # deal with $x = *STDIN/STDOUT/STDERR{IO}
1200 foreach ( qw(stdin stdout stderr) ) {
1201 $io->IsSTD($_) and $perlio_func = $_;
1203 if( $perlio_func ) {
1204 $init->add( "IoIFP(${sym})=PerlIO_${perlio_func}();" );
1205 $init->add( "IoOFP(${sym})=PerlIO_${perlio_func}();" );
1209 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
1210 $fsym = $io->$field();
1212 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
1222 # This is where we catch an honest-to-goodness Nullsv (which gets
1223 # blessed into B::SV explicitly) and any stray erroneous SVs.
1224 return 0 unless $$sv;
1225 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
1230 my $init_name = shift;
1232 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
1233 $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect,
1234 $loopsect, $copsect, $svsect, $xpvsect,
1235 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
1236 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
1237 $symsect->output(\*STDOUT, "#define %s\n");
1239 output_declarations();
1240 foreach $section (@sections) {
1241 my $lines = $section->index + 1;
1243 my $name = $section->name;
1244 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
1245 print "Static $typename ${name}_list[$lines];\n";
1248 $decl->output(\*STDOUT, "%s\n");
1250 foreach $section (@sections) {
1251 my $lines = $section->index + 1;
1253 my $name = $section->name;
1254 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
1255 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
1256 $section->output(\*STDOUT, "\t{ %s },\n");
1262 static int $init_name()
1267 $init->output(\*STDOUT, "\t%s\n");
1268 print "\treturn 0;\n}\n";
1270 warn compile_stats();
1271 warn "NULLOP count: $nullop_count\n";
1275 sub output_declarations {
1277 #ifdef BROKEN_STATIC_REDECL
1278 #define Static extern
1280 #define Static static
1281 #endif /* BROKEN_STATIC_REDECL */
1283 #ifdef BROKEN_UNION_INIT
1285 * Cribbed from cv.h with ANY (a union) replaced by void*.
1286 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
1289 char * xpv_pv; /* pointer to malloced string */
1290 STRLEN xpv_cur; /* length of xp_pv as a C string */
1291 STRLEN xpv_len; /* allocated size */
1292 IV xof_off; /* integer value */
1293 NV xnv_nv; /* numeric value, if any */
1294 MAGIC* xmg_magic; /* magic for scalar array */
1295 HV* xmg_stash; /* class package */
1300 void (*xcv_xsub) (pTHX_ CV*);
1304 long xcv_depth; /* >= 2 indicates recursive call */
1307 #ifdef USE_5005THREADS
1308 perl_mutex *xcv_mutexp;
1309 struct perl_thread *xcv_owner; /* current owner thread */
1310 #endif /* USE_5005THREADS */
1311 cv_flags_t xcv_flags;
1313 #define ANYINIT(i) i
1315 #define XPVCV_or_similar XPVCV
1316 #define ANYINIT(i) {i}
1317 #endif /* BROKEN_UNION_INIT */
1318 #define Nullany ANYINIT(0)
1323 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1328 sub output_boilerplate {
1334 /* Workaround for mapstart: the only op which needs a different ppaddr */
1335 #undef Perl_pp_mapstart
1336 #define Perl_pp_mapstart Perl_pp_grepstart
1338 #define OP_MAPSTART OP_GREPSTART
1339 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1340 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
1342 static void xs_init (pTHX);
1343 static void dl_init (pTHX);
1344 static PerlInterpreter *my_perl;
1349 my( $op_type, $num ) = @_;
1350 my $op_list = $op_type."_list";
1352 $init->add( split /\n/, <<EOT );
1356 for( i = 0; i < ${num}; ++i )
1358 ${op_list}\[i].op_ppaddr = PL_ppaddr[INT2PTR(int,${op_list}\[i].op_ppaddr)];
1365 my( $op_type, $num ) = @_;
1366 my $op_list = $op_type."_list";
1368 # for resons beyond imagination, MSVC5 considers pWARN_ALL non-const
1369 $init->add( split /\n/, <<EOT );
1373 for( i = 0; i < ${num}; ++i )
1375 switch( (int)(${op_list}\[i].cop_warnings) )
1378 ${op_list}\[i].cop_warnings = pWARN_ALL;
1381 ${op_list}\[i].cop_warnings = pWARN_NONE;
1384 ${op_list}\[i].cop_warnings = pWARN_STD;
1397 main(int argc, char **argv, char **env)
1405 PERL_SYS_INIT3(&argc,&argv,&env);
1407 if (!PL_do_undump) {
1408 my_perl = perl_alloc();
1411 perl_construct( my_perl );
1412 PL_perl_destruct_level = 0;
1417 PL_cshlen = strlen(PL_cshname);
1420 #ifdef ALLOW_PERL_OPTIONS
1421 #define EXTRA_OPTIONS 3
1423 #define EXTRA_OPTIONS 4
1424 #endif /* ALLOW_PERL_OPTIONS */
1425 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1427 fakeargv[0] = argv[0];
1432 print sprintf ' fakeargv[3] = ( %s ) ? "-T" : "" ;'."\n", ${^TAINT};
1434 #ifndef ALLOW_PERL_OPTIONS
1436 #endif /* ALLOW_PERL_OPTIONS */
1437 for (i = 1; i < argc; i++)
1438 fakeargv[i + EXTRA_OPTIONS] = argv[i];
1439 fakeargv[argc + EXTRA_OPTIONS] = 0;
1441 exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1450 if( $use_perl_script_name ) {
1452 $dollar_0 =~ s/\\/\\\\/g;
1453 $dollar_0 = '"' . $dollar_0 . '"';
1456 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */
1457 tmpsv = GvSV(tmpgv);
1458 sv_setpv(tmpsv, ${dollar_0});
1465 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
1466 tmpsv = GvSV(tmpgv);
1468 sv_setpv(tmpsv,"perl.exe");
1470 sv_setpv(tmpsv,"perl");
1477 /* PL_main_cv = PL_compcv; */
1480 exitstatus = perl_init();
1485 exitstatus = perl_run( my_perl );
1487 perl_destruct( my_perl );
1488 perl_free( my_perl );
1495 /* yanked from perl.c */
1499 char *file = __FILE__;
1503 print "\n#ifdef USE_DYNAMIC_LOADING";
1504 print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1505 print "\n#endif\n" ;
1506 # delete $xsub{'DynaLoader'};
1507 delete $xsub{'UNIVERSAL'};
1508 print("/* bootstrapping code*/\n\tSAVETMPS;\n");
1509 print("\ttarg=sv_newmortal();\n");
1510 print "#ifdef USE_DYNAMIC_LOADING\n";
1511 print "\tPUSHMARK(sp);\n";
1512 print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
1513 print qq/\tPUTBACK;\n/;
1514 print "\tboot_DynaLoader(aTHX_ NULL);\n";
1515 print qq/\tSPAGAIN;\n/;
1517 foreach my $stashname (keys %xsub){
1518 if ($xsub{$stashname} !~ m/Dynamic/ ) {
1519 my $stashxsub=$stashname;
1520 $stashxsub =~ s/::/__/g;
1521 print "\tPUSHMARK(sp);\n";
1522 print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
1523 print qq/\tPUTBACK;\n/;
1524 print "\tboot_$stashxsub(aTHX_ NULL);\n";
1525 print qq/\tSPAGAIN;\n/;
1528 print("\tFREETMPS;\n/* end bootstrapping code */\n");
1535 char *file = __FILE__;
1539 print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
1540 print("\ttarg=sv_newmortal();\n");
1541 foreach my $stashname (@DynaLoader::dl_modules) {
1542 warn "Loaded $stashname\n";
1543 if (exists($xsub{$stashname}) && $xsub{$stashname} =~ m/Dynamic/) {
1544 my $stashxsub=$stashname;
1545 $stashxsub =~ s/::/__/g;
1546 print "\tPUSHMARK(sp);\n";
1547 print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
1548 print qq/\tPUTBACK;\n/;
1549 print "#ifdef USE_DYNAMIC_LOADING\n";
1550 warn "bootstrapping $stashname added to xs_init\n";
1551 if( $xsub{$stashname} eq 'Dynamic' ) {
1552 print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
1555 print qq/\tperl_call_pv("XSLoader::load",G_DISCARD);\n/;
1558 print "\tboot_$stashxsub(aTHX_ NULL);\n";
1560 print qq/\tSPAGAIN;\n/;
1563 print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
1569 warn "----Symbol table:\n";
1570 while (($sym, $val) = each %symtable) {
1571 warn "$sym => $val\n";
1573 warn "---End of symbol table\n";
1579 svref_2object($sv)->save;
1583 sub Dummy_BootStrap { }
1588 my $package=$gv->STASH->NAME;
1589 my $name = $gv->NAME;
1595 my $fullname = $gv->STASH->NAME . "::" . $gv->NAME;
1597 # We may be looking at this package just because it is a branch in the
1598 # symbol table which is on the path to a package which we need to save
1599 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1601 return unless ($unused_sub_packages{$package});
1602 return unless ($$cv || $$av || $$sv || $$hv);
1608 my $package = shift;
1609 unless ($unused_sub_packages{$package})
1612 $unused_sub_packages{$package} = 1;
1613 if (defined @{$package.'::ISA'})
1615 foreach my $isa (@{$package.'::ISA'})
1617 if ($isa eq 'DynaLoader')
1619 unless (defined(&{$package.'::bootstrap'}))
1621 warn "Forcing bootstrap of $package\n";
1622 eval { $package->bootstrap };
1627 unless ($unused_sub_packages{$isa})
1629 warn "$isa saved (it is in $package\'s \@ISA)\n";
1641 no strict qw(vars refs);
1642 my $package = shift;
1643 $package =~ s/::$//;
1644 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1645 # warn "Considering $package\n";#debug
1646 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1648 # If this package is a prefix to something we are saving, traverse it
1649 # but do not mark it for saving if it is not already
1650 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1652 return 1 if ($u =~ /^$package\:\:/);
1654 if (exists $unused_sub_packages{$package})
1656 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1657 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1658 return $unused_sub_packages{$package};
1660 # Omit the packages which we use (and which cause grief
1661 # because of fancy "goto &$AUTOLOAD" stuff).
1662 # XXX Surely there must be a nicer way to do this.
1663 if ($package eq "FileHandle" || $package eq "Config" ||
1664 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1666 delete_unsaved_hashINC($package);
1667 return $unused_sub_packages{$package} = 0;
1669 # Now see if current package looks like an OO class this is probably too strong.
1670 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1672 if (UNIVERSAL::can($package, $m))
1674 warn "$package has method $m: saving package\n";#debug
1675 return mark_package($package);
1678 delete_unsaved_hashINC($package);
1679 return $unused_sub_packages{$package} = 0;
1681 sub delete_unsaved_hashINC{
1683 $packname =~ s/\:\:/\//g;
1685 # warn "deleting $packname" if $INC{$packname} ;# debug
1686 delete $INC{$packname};
1690 my ($symref, $recurse, $prefix) = @_;
1695 $prefix = '' unless defined $prefix;
1696 while (($sym, $ref) = each %$symref)
1701 $sym = $prefix . $sym;
1702 if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym))
1704 walkpackages(\%glob, $recurse, $sym);
1711 sub save_unused_subs
1714 &descend_marked_unused;
1716 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1717 warn "Saving methods\n";
1718 walksymtable(\%{"main::"}, "savecv", \&should_save);
1723 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1724 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1725 my $inc_hv = svref_2object(\%INC)->save;
1726 my $inc_av = svref_2object(\@INC)->save;
1727 my $amagic_generate= amagic_generation;
1728 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1729 "GvHV(PL_incgv) = $inc_hv;",
1730 "GvAV(PL_incgv) = $inc_av;",
1731 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1732 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1733 "PL_amagic_generation= $amagic_generate;" );
1736 sub descend_marked_unused {
1737 foreach my $pack (keys %unused_sub_packages)
1739 mark_package($pack);
1744 # this is mainly for the test suite
1745 my $warner = $SIG{__WARN__};
1746 local $SIG{__WARN__} = sub { print STDERR @_ };
1748 warn "Starting compile\n";
1749 warn "Walking tree\n";
1750 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1751 walkoptree(main_root, "save");
1752 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1754 # XSLoader was used, force saving of XSLoader::load
1755 if( $use_xsloader ) {
1756 my $cv = svref_2object( \&XSLoader::load );
1759 # save %SIG ( in case it was set in a BEGIN block )
1761 local $SIG{__WARN__} = $warner;
1762 $init->add("{", "\tHV* hv = get_hv(\"main::SIG\",1);" );
1763 foreach my $k ( keys %SIG ) {
1764 next unless $SIG{$k};
1765 my $cv = svref_2object( \$SIG{$k} );
1767 $init->add('{',sprintf 'SV* sv = (SV*)%s;', $sv );
1768 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
1769 cstring($k),length(pack "a*",$k),
1771 $init->add('mg_set(sv);','}');
1776 $init->add( sprintf " PL_dowarn = ( %s ) ? G_WARN_ON : G_WARN_OFF;", $^W );
1778 my $init_av = init_av->save;
1779 my $end_av = end_av->save;
1780 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1781 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1782 "PL_initav = (AV *) $init_av;",
1783 "PL_endav = (AV*) $end_av;");
1785 # init op addrs ( must be the last action, otherwise
1786 # some ops might not be initialized
1787 if( $optimize_ppaddr ) {
1788 foreach my $i ( @op_sections ) {
1790 next unless $section->index >= 0;
1791 init_op_addr( $section->name, $section->index + 1);
1794 init_op_warn( $copsect->name, $copsect->index + 1)
1795 if $optimize_warn_sv && $copsect->index >= 0;
1797 warn "Writing output\n";
1798 output_boilerplate();
1800 output_all("perl_init");
1806 my @sections = (decl => \$decl, sym => \$symsect,
1807 binop => \$binopsect, condop => \$condopsect,
1808 cop => \$copsect, padop => \$padopsect,
1809 listop => \$listopsect, logop => \$logopsect,
1810 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1811 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1812 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1813 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1814 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1815 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1816 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1817 xpvio => \$xpviosect);
1818 my ($name, $sectref);
1819 while (($name, $sectref) = splice(@sections, 0, 2)) {
1820 $$sectref = new B::C::Section $name, \%symtable, 0;
1822 $init = new B::C::InitSection 'init', \%symtable, 0;
1827 my ($arg,$val) = @_;
1828 $unused_sub_packages{$arg} = $val;
1833 my ($option, $opt, $arg);
1834 my @eval_at_startup;
1835 my %option_map = ( 'cog' => \$pv_copy_on_grow,
1836 'save-data' => \$save_data_fh,
1837 'ppaddr' => \$optimize_ppaddr,
1838 'warn-sv' => \$optimize_warn_sv,
1839 'use-script-name' => \$use_perl_script_name,
1840 'save-sig-hash' => \$save_sig,
1843 while ($option = shift @options) {
1844 if ($option =~ /^-(.)(.*)/) {
1848 unshift @options, $option;
1851 if ($opt eq "-" && $arg eq "-") {
1856 $warn_undefined_syms = 1;
1857 } elsif ($opt eq "D") {
1858 $arg ||= shift @options;
1859 foreach $arg (split(//, $arg)) {
1862 } elsif ($arg eq "c") {
1864 } elsif ($arg eq "A") {
1866 } elsif ($arg eq "C") {
1868 } elsif ($arg eq "M") {
1871 warn "ignoring unknown debug option: $arg\n";
1874 } elsif ($opt eq "o") {
1875 $arg ||= shift @options;
1876 open(STDOUT, ">$arg") or return "$arg: $!\n";
1877 } elsif ($opt eq "v") {
1879 } elsif ($opt eq "u") {
1880 $arg ||= shift @options;
1881 mark_unused($arg,undef);
1882 } elsif ($opt eq "f") {
1883 $arg ||= shift @options;
1884 $arg =~ m/(no-)?(.*)/;
1885 my $no = defined($1) && $1 eq 'no-';
1886 $arg = $no ? $2 : $arg;
1887 if( exists $option_map{$arg} ) {
1888 ${$option_map{$arg}} = !$no;
1890 die "Invalid optimization '$arg'";
1892 } elsif ($opt eq "O") {
1893 $arg = 1 if $arg eq "";
1894 $pv_copy_on_grow = 0;
1896 # Optimisations for -O1
1897 $pv_copy_on_grow = 1;
1899 } elsif ($opt eq "e") {
1900 push @eval_at_startup, $arg;
1901 } elsif ($opt eq "l") {
1902 $max_string_len = $arg;
1906 foreach my $i ( @eval_at_startup ) {
1907 $init->add_eval( $i );
1912 foreach $objname (@options) {
1913 eval "save_object(\\$objname)";
1918 return sub { save_main() };
1928 B::C - Perl compiler's C backend
1932 perl -MO=C[,OPTIONS] foo.pl
1936 This compiler backend takes Perl source and generates C source code
1937 corresponding to the internal structures that perl uses to run
1938 your program. When the generated C source is compiled and run, it
1939 cuts out the time which perl would have taken to load and parse
1940 your program into its internal semi-compiled form. That means that
1941 compiling with this backend will not help improve the runtime
1942 execution speed of your program but may improve the start-up time.
1943 Depending on the environment in which your program runs this may be
1944 either a help or a hindrance.
1948 If there are any non-option arguments, they are taken to be
1949 names of objects to be saved (probably doesn't work properly yet).
1950 Without extra arguments, it saves the main program.
1956 Output to filename instead of STDOUT
1960 Verbose compilation (currently gives a few compilation statistics).
1964 Force end of options
1968 Force apparently unused subs from package Packname to be compiled.
1969 This allows programs to use eval "foo()" even when sub foo is never
1970 seen to be used at compile time. The down side is that any subs which
1971 really are never used also have code generated. This option is
1972 necessary, for example, if you have a signal handler foo which you
1973 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1974 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1975 options. The compiler tries to figure out which packages may possibly
1976 have subs in which need compiling but the current version doesn't do
1977 it very well. In particular, it is confused by nested packages (i.e.
1978 of the form C<A::B>) where package C<A> does not contain any subs.
1982 Debug options (concatenated or separate flags like C<perl -D>).
1986 OPs, prints each OP as it's processed
1990 COPs, prints COPs as processed (incl. file & line num)
1994 prints AV information on saving
1998 prints CV information on saving
2002 prints MAGIC information on saving
2006 Force options/optimisations on or off one at a time. You can explicitly
2007 disable an option using B<-fno-option>. All options default to
2014 Copy-on-grow: PVs declared and initialised statically.
2016 =item B<-fsave-data>
2018 Save package::DATA filehandles ( only available with PerlIO ).
2022 Optimize the initialization of op_ppaddr.
2026 Optimize the initialization of cop_warnings.
2028 =item B<-fuse-script-name>
2030 Use the script name instead of the program name as $0.
2032 =item B<-fsave-sig-hash>
2034 Save compile-time modifications to the %SIG hash.
2040 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
2041 B<-O1> and higher set B<-fcog>.
2045 Some C compilers impose an arbitrary limit on the length of string
2046 constants (e.g. 2048 characters for Microsoft Visual C++). The
2047 B<-llimit> options tells the C backend not to generate string literals
2048 exceeding that limit.
2054 perl -MO=C,-ofoo.c foo.pl
2055 perl cc_harness -o foo foo.c
2057 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
2058 library directory. The utility called C<perlcc> may also be used to
2059 help make use of this compiler.
2061 perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null
2065 Plenty. Current status: experimental.
2069 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>