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;
41 foreach (@{$section->[-1]{values}})
43 s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
44 printf $fh $format, $_, $i;
49 package B::C::InitSection;
52 @B::C::InitSection::ISA = qw(B::C::Section);
56 my $max_lines = 10000; #pop;
57 my $section = $class->SUPER::new( @_ );
59 $section->[-1]{evals} = [];
60 $section->[-1]{chunks} = [];
61 $section->[-1]{nosplit} = 0;
62 $section->[-1]{current} = [];
63 $section->[-1]{count} = 0;
64 $section->[-1]{max_lines} = $max_lines;
71 $section->[-1]{nosplit}--
72 if $section->[-1]{nosplit} > 0;
76 shift->[-1]{nosplit}++;
82 $section->[-1]{count} += $_[0];
88 my $section = shift->[-1];
89 my $current = $section->{current};
90 my $nosplit = $section->{nosplit};
93 $section->{count} += scalar(@_);
94 if( !$nosplit && $section->{count} >= $section->{max_lines} ) {
95 push @{$section->{chunks}}, $current;
96 $section->{current} = [];
97 $section->{count} = 0;
105 foreach my $i ( @strings ) {
108 push @{$section->[-1]{evals}}, @strings;
112 my( $section, $fh, $format, $init_name ) = @_;
113 my $sym = $section->symtable || {};
114 my $default = $section->default;
115 push @{$section->[-1]{chunks}}, $section->[-1]{current};
118 foreach my $i ( @{$section->[-1]{chunks}} ) {
120 static int perl_init_${name}()
125 foreach my $j ( @$i ) {
126 $j =~ s{(s\\_[0-9a-f]+)}
127 { exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
130 print $fh "\treturn 0;\n}\n";
132 $section->SUPER::add( "perl_init_${name}();" );
135 foreach my $i ( @{$section->[-1]{evals}} ) {
136 $section->SUPER::add( sprintf q{eval_pv("%s",1);}, $i );
140 static int ${init_name}()
145 $section->SUPER::output( $fh, $format );
146 print $fh "\treturn 0;\n}\n";
154 { # block necessary for caller to work
156 if( $caller eq 'O' ) {
158 XSLoader::load( 'B::C' );
163 @EXPORT_OK = qw(output_all output_boilerplate output_main mark_unused
164 init_sections set_callback save_unused_subs objsym save_context);
166 use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop
167 class cstring cchar svref_2object compile_stats comppadlist hash
168 threadsv_names main_cv init_av end_av regex_padav opnumber amagic_generation
169 AVf_REAL HEf_SVKEY SVf_POK SVf_ROK CVf_CONST);
170 use B::Asmdata qw(@specialsv_name);
182 my $anonsub_index = 0;
183 my $initsub_index = 0;
187 my $warn_undefined_syms;
189 my %unused_sub_packages;
192 my $pv_copy_on_grow = 0;
193 my $optimize_ppaddr = 0;
194 my $optimize_warn_sv = 0;
195 my $use_perl_script_name = 0;
196 my $save_data_fh = 0;
198 my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
201 my $ithreads = $Config{useithreads} eq 'define';
205 @threadsv_names = threadsv_names();
209 my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect,
210 $padopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
211 $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
212 $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
213 $xrvsect, $xpvbmsect, $xpviosect );
214 my @op_sections = \( $binopsect, $condopsect, $copsect, $padopsect, $listopsect,
215 $logopsect, $loopsect, $opsect, $pmopsect, $pvopsect, $svopsect,
218 sub walk_and_save_optree;
219 my $saveoptree_callback = \&walk_and_save_optree;
220 sub set_callback { $saveoptree_callback = shift }
221 sub saveoptree { &$saveoptree_callback(@_) }
223 sub walk_and_save_optree {
224 my ($name, $root, $start) = @_;
225 walkoptree($root, "save");
226 return objsym($start);
229 # Current workaround/fix for op_free() trying to free statically
230 # defined OPs is to set op_seq = -1 and check for that in op_free().
231 # Instead of hardwiring -1 in place of $op->seq, we use $op_seq
232 # so that it can be changed back easily if necessary. In fact, to
233 # stop compilers from moaning about a U16 being initialised with an
234 # uncast -1 (the printf format is %d so we can't tweak it), we have
235 # to "know" that op_seq is a U16 and use 65535. Ugh.
238 # Look this up here so we can do just a number compare
239 # rather than looking up the name of every BASEOP in B::OP
240 my $OP_THREADSV = opnumber('threadsv');
243 my ($obj, $value) = @_;
244 my $sym = sprintf("s\\_%x", $$obj);
245 $symtable{$sym} = $value;
250 return $symtable{sprintf("s\\_%x", $$obj)};
257 return 0 if $sym eq "sym_0"; # special case
258 $value = $symtable{$sym};
259 if (defined($value)) {
262 warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
269 my $sym = sprintf("re%d", $re_index++);
270 $decl->add(sprintf("static char *$sym = %s;", cstring($re)));
272 return ($sym,length(pack "a*",$re));
276 my $pv = pack "a*", shift;
279 if ($pv_copy_on_grow) {
280 $pvsym = sprintf("pv%d", $pv_index++);
282 if( defined $max_string_len && length($pv) > $max_string_len ) {
283 my $chars = join ', ', map { cchar $_ } split //, $pv;
284 $decl->add(sprintf("static char %s[] = { %s };", $pvsym, $chars));
287 my $cstring = cstring($pv);
288 if ($cstring ne "0") { # sic
289 $decl->add(sprintf("static char %s[] = %s;",
294 $pvmax = length(pack "a*",$pv) + 1;
296 return ($pvsym, $pvmax);
301 # confess "Can't save RV: not ROK" unless $sv->FLAGS & SVf_ROK;
302 my $rv = $sv->RV->save;
304 $rv =~ s/^\(([AGHS]V|IO)\s*\*\)\s*(\&sv_list.*)$/$2/;
309 # savesym, pvmax, len, pv
313 my $rok = $sv->FLAGS & SVf_ROK;
314 my $pok = $sv->FLAGS & SVf_POK;
315 my( $len, $pvmax, $savesym, $pv ) = ( 0, 0 );
317 $savesym = '(char*)' . save_rv( $sv );
320 $pv = $pok ? (pack "a*", $sv->PV) : undef;
321 $len = $pok ? length($pv) : 0;
322 ($savesym, $pvmax) = $pok ? savepv($pv) : ( 'NULL', 0 );
325 return ( $savesym, $pvmax, $len, $pv );
328 # see also init_op_ppaddr below; initializes the ppaddt to the
329 # OpTYPE; init_op_ppaddr iterates over the ops and sets
330 # op_ppaddr to PL_ppaddr[op_ppaddr]; this avoids an explicit assignmente
331 # in perl_init ( ~10 bytes/op with GCC/i386 )
332 sub B::OP::fake_ppaddr {
333 return $optimize_ppaddr ?
334 sprintf("INT2PTR(void*,OP_%s)", uc( $_[0]->name ) ) :
339 my ($op, $level) = @_;
340 my $sym = objsym($op);
341 return $sym if defined $sym;
342 my $type = $op->type;
343 $nullop_count++ unless $type;
344 if ($type == $OP_THREADSV) {
345 # saves looking up ppaddr but it's a bit naughty to hard code this
346 $init->add(sprintf("(void)find_threadsv(%s);",
347 cstring($threadsv_names[$op->targ])));
349 $opsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x",
350 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, $op->targ,
351 $type, $op_seq, $op->flags, $op->private));
352 my $ix = $opsect->index;
353 $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr))
354 unless $optimize_ppaddr;
355 savesym($op, "&op_list[$ix]");
359 my ($class, %objdata) = @_;
360 bless \%objdata, $class;
363 sub B::FAKEOP::save {
364 my ($op, $level) = @_;
365 $opsect->add(sprintf("%s, %s, %s, %u, %u, %u, 0x%x, 0x%x",
366 $op->next, $op->sibling, $op->fake_ppaddr, $op->targ,
367 $op->type, $op_seq, $op->flags, $op->private));
368 my $ix = $opsect->index;
369 $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr))
370 unless $optimize_ppaddr;
371 return "&op_list[$ix]";
374 sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
375 sub B::FAKEOP::type { $_[0]->{type} || 0}
376 sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
377 sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
378 sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
379 sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
380 sub B::FAKEOP::private { $_[0]->{private} || 0 }
383 my ($op, $level) = @_;
384 my $sym = objsym($op);
385 return $sym if defined $sym;
386 $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x",
387 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
388 $op->targ, $op->type, $op_seq, $op->flags,
389 $op->private, ${$op->first}));
390 my $ix = $unopsect->index;
391 $init->add(sprintf("unop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
392 unless $optimize_ppaddr;
393 savesym($op, "(OP*)&unop_list[$ix]");
397 my ($op, $level) = @_;
398 my $sym = objsym($op);
399 return $sym if defined $sym;
400 $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
401 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
402 $op->targ, $op->type, $op_seq, $op->flags,
403 $op->private, ${$op->first}, ${$op->last}));
404 my $ix = $binopsect->index;
405 $init->add(sprintf("binop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
406 unless $optimize_ppaddr;
407 savesym($op, "(OP*)&binop_list[$ix]");
410 sub B::LISTOP::save {
411 my ($op, $level) = @_;
412 my $sym = objsym($op);
413 return $sym if defined $sym;
414 $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
415 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
416 $op->targ, $op->type, $op_seq, $op->flags,
417 $op->private, ${$op->first}, ${$op->last}));
418 my $ix = $listopsect->index;
419 $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
420 unless $optimize_ppaddr;
421 savesym($op, "(OP*)&listop_list[$ix]");
425 my ($op, $level) = @_;
426 my $sym = objsym($op);
427 return $sym if defined $sym;
428 $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
429 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
430 $op->targ, $op->type, $op_seq, $op->flags,
431 $op->private, ${$op->first}, ${$op->other}));
432 my $ix = $logopsect->index;
433 $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
434 unless $optimize_ppaddr;
435 savesym($op, "(OP*)&logop_list[$ix]");
439 my ($op, $level) = @_;
440 my $sym = objsym($op);
441 return $sym if defined $sym;
442 #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
443 # peekop($op->redoop), peekop($op->nextop),
444 # peekop($op->lastop)); # debug
445 $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",
446 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
447 $op->targ, $op->type, $op_seq, $op->flags,
448 $op->private, ${$op->first}, ${$op->last},
449 ${$op->redoop}, ${$op->nextop},
451 my $ix = $loopsect->index;
452 $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
453 unless $optimize_ppaddr;
454 savesym($op, "(OP*)&loop_list[$ix]");
458 my ($op, $level) = @_;
459 my $sym = objsym($op);
460 return $sym if defined $sym;
461 $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
462 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
463 $op->targ, $op->type, $op_seq, $op->flags,
464 $op->private, cstring($op->pv)));
465 my $ix = $pvopsect->index;
466 $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
467 unless $optimize_ppaddr;
468 savesym($op, "(OP*)&pvop_list[$ix]");
472 my ($op, $level) = @_;
473 my $sym = objsym($op);
474 return $sym if defined $sym;
476 my $svsym = '(SV*)' . $sv->save;
477 my $is_const_addr = $svsym =~ m/Null|\&/;
478 $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
479 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
480 $op->targ, $op->type, $op_seq, $op->flags,
482 ( $is_const_addr ? $svsym : 'Nullsv' )));
483 my $ix = $svopsect->index;
484 $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
485 unless $optimize_ppaddr;
486 $init->add("svop_list[$ix].op_sv = $svsym;")
487 unless $is_const_addr;
488 savesym($op, "(OP*)&svop_list[$ix]");
492 my ($op, $level) = @_;
493 my $sym = objsym($op);
494 return $sym if defined $sym;
495 $padopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %d",
496 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
497 $op->targ, $op->type, $op_seq, $op->flags,
498 $op->private,$op->padix));
499 my $ix = $padopsect->index;
500 $init->add(sprintf("padop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
501 unless $optimize_ppaddr;
502 # $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix));
503 savesym($op, "(OP*)&padop_list[$ix]");
507 my ($op, $level) = @_;
508 my $sym = objsym($op);
509 return $sym if defined $sym;
510 warn sprintf("COP: line %d file %s\n", $op->line, $op->file)
512 # shameless cut'n'paste from B::Deparse
514 my $warnings = $op->warnings;
515 my $is_special = $warnings->isa("B::SPECIAL");
516 if ($is_special && $$warnings == 4) {
517 # use warnings 'all';
518 $warn_sv = $optimize_warn_sv ?
522 elsif ($is_special && $$warnings == 5) {
524 $warn_sv = $optimize_warn_sv ?
528 elsif ($is_special) {
530 $warn_sv = $optimize_warn_sv ?
536 $warn_sv = $warnings->save;
539 $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, NULL, NULL, %u, %d, %u, %s",
540 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
541 $op->targ, $op->type, $op_seq, $op->flags,
542 $op->private, cstring($op->label), $op->cop_seq,
543 $op->arybase, $op->line,
544 ( $optimize_warn_sv ? $warn_sv : 'NULL' )));
545 my $ix = $copsect->index;
546 $init->add(sprintf("cop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
547 unless $optimize_ppaddr;
548 $init->add(sprintf("cop_list[$ix].cop_warnings = %s;", $warn_sv ))
549 unless $optimize_warn_sv;
550 $init->add(sprintf("CopFILE_set(&cop_list[$ix], %s);", cstring($op->file)),
551 sprintf("CopSTASHPV_set(&cop_list[$ix], %s);", cstring($op->stashpv)));
553 savesym($op, "(OP*)&cop_list[$ix]");
557 my ($op, $level) = @_;
558 my $sym = objsym($op);
559 return $sym if defined $sym;
560 my $replroot = $op->pmreplroot;
561 my $replstart = $op->pmreplstart;
563 my $replstartfield = sprintf("s\\_%x", $$replstart);
565 my $ppaddr = $op->ppaddr;
566 # under ithreads, OP_PUSHRE.op_replroot is an integer
567 $replrootfield = sprintf("s\\_%x", $$replroot) if ref $replroot;
568 if($ithreads && $op->name eq "pushre") {
569 $replrootfield = "INT2PTR(OP*,${replroot})";
570 } elsif ($$replroot) {
571 # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
572 # argument to a split) stores a GV in op_pmreplroot instead
573 # of a substitution syntax tree. We don't want to walk that...
574 if ($op->name eq "pushre") {
575 $gvsym = $replroot->save;
576 # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
579 $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
582 # pmnext handling is broken in perl itself, I think. Bad op_pmnext
583 # fields aren't noticed in perl's runtime (unless you try reset) but we
584 # segfault when trying to dereference it to find op->op_pmnext->op_type
585 $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %s, %s, 0, %u, 0x%x, 0x%x, 0x%x",
586 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, $op->targ,
587 $op->type, $op_seq, $op->flags, $op->private,
588 ${$op->first}, ${$op->last},
589 $replrootfield, $replstartfield,
590 ( $ithreads ? $op->pmoffset : 0 ),
591 $op->pmflags, $op->pmpermflags, $op->pmdynflags ));
592 my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
593 $init->add(sprintf("$pm.op_ppaddr = %s;", $ppaddr))
594 unless $optimize_ppaddr;
595 my $re = $op->precomp;
597 my( $resym, $relen ) = savere( $re );
598 $init->add(sprintf("PM_SETRE(&$pm,pregcomp($resym, $resym + %u, &$pm));",
602 $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
604 savesym($op, "(OP*)&$pm");
607 sub B::SPECIAL::save {
609 # special case: $$sv is not the address but an index into specialsv_list
610 # warn "SPECIAL::save specialsv $$sv\n"; # debug
611 my $sym = $specialsv_name[$$sv];
612 if (!defined($sym)) {
613 confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
618 sub B::OBJECT::save {}
622 my $sym = objsym($sv);
623 return $sym if defined $sym;
624 # warn "Saving SVt_NULL SV\n"; # debug
627 warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
628 return savesym($sv, "(void*)Nullsv /* XXX */");
630 $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS));
631 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
636 my $sym = objsym($sv);
637 return $sym if defined $sym;
638 $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
639 $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
640 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
641 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
646 my $sym = objsym($sv);
647 return $sym if defined $sym;
649 $val .= '.00' if $val =~ /^-?\d+$/;
650 $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
651 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
652 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
653 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
659 # work with byte offsets/lengths
660 my $pv = pack "a*", $pv;
661 if (defined $max_string_len && length($pv) > $max_string_len) {
662 push @res, sprintf("New(0,%s,%u,char);", $dest, length($pv)+1);
665 my $str = substr $pv, 0, $max_string_len, '';
666 push @res, sprintf("Copy(%s,$dest+$offset,%u,char);",
667 cstring($str), length($str));
668 $offset += length $str;
670 push @res, sprintf("%s[%u] = '\\0';", $dest, $offset);
673 push @res, sprintf("%s = savepvn(%s, %u);", $dest,
674 cstring($pv), length($pv));
681 my $sym = objsym($sv);
682 return $sym if defined $sym;
684 my $len = length($pv);
685 my ($pvsym, $pvmax) = savepv($pv);
686 my ($lvtarg, $lvtarg_sym);
687 $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
688 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
689 $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
690 $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
691 $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS));
692 if (!$pv_copy_on_grow) {
693 $init->add(savepvn(sprintf("xpvlv_list[%d].xpv_pv",
694 $xpvlvsect->index), $pv));
697 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
702 my $sym = objsym($sv);
703 return $sym if defined $sym;
704 my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
705 $xpvivsect->add(sprintf("%s, %u, %u, %d", $savesym, $len, $pvmax, $sv->IVX));
706 $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
707 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
708 if (defined($pv) && !$pv_copy_on_grow) {
709 $init->add(savepvn(sprintf("xpviv_list[%d].xpv_pv",
710 $xpvivsect->index), $pv));
712 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
717 my $sym = objsym($sv);
718 return $sym if defined $sym;
719 my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
721 $val .= '.00' if $val =~ /^-?\d+$/;
722 $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
723 $savesym, $len, $pvmax, $sv->IVX, $val));
724 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
725 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
726 if (defined($pv) && !$pv_copy_on_grow) {
727 $init->add(savepvn(sprintf("xpvnv_list[%d].xpv_pv",
728 $xpvnvsect->index), $pv));
730 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
735 my $sym = objsym($sv);
736 return $sym if defined $sym;
737 my $pv = pack "a*", ($sv->PV . "\0" . $sv->TABLE);
738 my $len = length($pv);
739 $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
740 $len, $len + 258, $sv->IVX, $sv->NVX,
741 $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
742 $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
743 $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS));
745 $init->add(savepvn(sprintf("xpvbm_list[%d].xpv_pv",
746 $xpvbmsect->index), $pv),
747 sprintf("xpvbm_list[%d].xpv_cur = %u;",
748 $xpvbmsect->index, $len - 257));
749 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
754 my $sym = objsym($sv);
755 return $sym if defined $sym;
756 my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
757 $xpvsect->add(sprintf("%s, %u, %u", $savesym, $len, $pvmax));
758 $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
759 $xpvsect->index, $sv->REFCNT , $sv->FLAGS));
760 if (defined($pv) && !$pv_copy_on_grow) {
761 $init->add(savepvn(sprintf("xpv_list[%d].xpv_pv",
762 $xpvsect->index), $pv));
764 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
769 my $sym = objsym($sv);
770 return $sym if defined $sym;
771 my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
773 $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
774 $savesym, $len, $pvmax,
775 $sv->IVX, $sv->NVX));
776 $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
777 $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS));
778 if (defined($pv) && !$pv_copy_on_grow) {
779 $init->add(savepvn(sprintf("xpvmg_list[%d].xpv_pv",
780 $xpvmgsect->index), $pv));
782 $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
787 sub B::PVMG::save_magic {
789 #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
790 my $stash = $sv->SvSTASH;
793 warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
795 # XXX Hope stash is already going to be saved.
796 $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
798 my @mgchain = $sv->MAGIC;
799 my ($mg, $type, $obj, $ptr,$len,$ptrsv);
800 foreach $mg (@mgchain) {
805 warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
806 class($sv), $$sv, class($obj), $$obj,
807 cchar($type), cstring($ptr));
810 unless( $type eq 'r' ) {
815 if ($len == HEf_SVKEY){
816 #The pointer is an SV*
817 $ptrsv=svref_2object($ptr)->save;
818 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
819 $$sv, $$obj, cchar($type),$ptrsv,$len));
820 }elsif( $type eq 'r' ){
822 my $pmop = $REGEXP{$rx};
824 confess "PMOP not found for REGEXP $rx" unless $pmop;
826 my( $resym, $relen ) = savere( $mg->precomp );
827 my $pmsym = $pmop->save;
828 $init->add( split /\n/, sprintf <<CODE, $$sv, cchar($type), cstring($ptr) );
830 REGEXP* rx = pregcomp($resym, $resym + $relen, (PMOP*)$pmsym);
831 sv_magic((SV*)s\\_%x, (SV*)rx, %s, %s, %d);
835 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
836 $$sv, $$obj, cchar($type),cstring($ptr),$len));
843 my $sym = objsym($sv);
844 return $sym if defined $sym;
845 my $rv = save_rv( $sv );
846 # GVs need to be handled at runtime
847 if( ref( $sv->RV ) eq 'B::GV' ) {
848 $xrvsect->add( "(SV*)Nullgv" );
849 $init->add(sprintf("xrv_list[%d].xrv_rv = (SV*)%s;\n", $xrvsect->index, $rv));
852 elsif( $sv->RV->isa( 'B::HV' ) && $sv->RV->NAME ) {
853 $xrvsect->add( "(SV*)Nullhv" );
854 $init->add(sprintf("xrv_list[%d].xrv_rv = (SV*)%s;\n", $xrvsect->index, $rv));
859 $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
860 $xrvsect->index, $sv->REFCNT , $sv->FLAGS));
861 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
865 my ($cvstashname, $cvname) = @_;
866 warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
867 # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
868 # use should be handled by the class itself.
870 my $isa = \@{"$cvstashname\::ISA"};
871 if (grep($_ eq "AutoLoader", @$isa)) {
872 warn "Forcing immediate load of sub derived from AutoLoader\n";
873 # Tweaked version of AutoLoader::AUTOLOAD
874 my $dir = $cvstashname;
876 eval { require "auto/$dir/$cvname.al" };
878 warn qq(failed require "auto/$dir/$cvname.al": $@\n);
888 my $sym = objsym($cv);
890 # warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
893 # Reserve a place in svsect and xpvcvsect and record indices
895 my ($cvname, $cvstashname);
898 $cvstashname = $gv->STASH->NAME;
900 my $root = $cv->ROOT;
901 my $cvxsub = $cv->XSUB;
902 my $isconst = $cv->CvFLAGS & CVf_CONST;
904 my $value = $cv->XSUBANY;
905 my $stash = $gv->STASH;
906 my $vsym = $value->save;
907 my $stsym = $stash->save;
908 my $name = cstring($cvname);
909 $decl->add( "static CV* cv$cv_index;" );
910 $init->add( "cv$cv_index = newCONSTSUB( $stsym, NULL, $vsym );" );
911 my $sym = savesym( $cv, "cv$cv_index" );
915 #INIT is removed from the symbol table, so this call must come
916 # from PL_initav->save. Re-bootstrapping will push INIT back in
917 # so nullop should be sent.
918 if (!$isconst && $cvxsub && ($cvname ne "INIT")) {
920 my $stashname = $egv->STASH->NAME;
921 if ($cvname eq "bootstrap")
923 my $file = $gv->FILE;
924 $decl->add("/* bootstrap $file */");
925 warn "Bootstrap $stashname $file\n";
926 # if it not isa('DynaLoader'), it should hopefully be XSLoaded
927 # ( attributes being an exception, of course )
928 if( $stashname ne 'attributes' &&
929 !UNIVERSAL::isa($stashname,'DynaLoader') ) {
930 $xsub{$stashname}='Dynamic-XSLoaded';
934 $xsub{$stashname}='Dynamic';
936 # $xsub{$stashname}='Static' unless $xsub{$stashname};
941 # XSUBs for IO::File, IO::Handle, IO::Socket,
942 # IO::Seekable and IO::Poll
943 # are defined in IO.xs, so let's bootstrap it
944 svref_2object( \&IO::bootstrap )->save
945 if grep { $stashname eq $_ } qw(IO::File IO::Handle IO::Socket
946 IO::Seekable IO::Poll);
948 warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv;
949 return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/;
951 if ($cvxsub && $cvname eq "INIT") {
953 return svref_2object(\&Dummy_initxs)->save;
955 my $sv_ix = $svsect->index + 1;
956 $svsect->add("svix$sv_ix");
957 my $xpvcv_ix = $xpvcvsect->index + 1;
958 $xpvcvsect->add("xpvcvix$xpvcv_ix");
959 # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
960 $sym = savesym($cv, "&sv_list[$sv_ix]");
961 warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv;
962 if (!$$root && !$cvxsub) {
963 if (try_autoload($cvstashname, $cvname)) {
964 # Recalculate root and xsub
967 if ($$root || $cvxsub) {
968 warn "Successful forced autoload\n";
973 my $padlist = $cv->PADLIST;
976 my $xsubany = "Nullany";
978 warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
979 $$cv, $$root) if $debug_cv;
982 my $stashname = $gv->STASH->NAME;
983 my $gvname = $gv->NAME;
984 if ($gvname ne "__ANON__") {
985 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
986 $ppname .= ($stashname eq "main") ?
987 $gvname : "$stashname\::$gvname";
988 $ppname =~ s/::/__/g;
989 if ($gvname eq "INIT"){
990 $ppname .= "_$initsub_index";
996 $ppname = "pp_anonsub_$anonsub_index";
999 $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
1000 warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
1001 $$cv, $ppname, $$root) if $debug_cv;
1003 warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
1004 $$padlist, $$cv) if $debug_cv;
1006 warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
1007 $$padlist, $$cv) if $debug_cv;
1011 warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
1012 $cvstashname, $cvname); # debug
1014 $pv = '' unless defined $pv; # Avoid use of undef warnings
1015 $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, 0x%x",
1016 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
1017 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
1018 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS,
1021 if (${$cv->OUTSIDE} == ${main_cv()}){
1022 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
1023 $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
1028 $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
1029 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
1030 $$gv, $$cv) if $debug_cv;
1033 $init->add( savepvn( "CvFILE($sym)", $cv->FILE) );
1036 $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE)));
1038 my $stash = $cv->STASH;
1041 $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
1042 warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
1043 $$stash, $$cv) if $debug_cv;
1045 $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
1046 $sv_ix, $xpvcv_ix, $cv->REFCNT +1*0 , $cv->FLAGS));
1052 my $sym = objsym($gv);
1053 if (defined($sym)) {
1054 #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
1057 my $ix = $gv_index++;
1058 $sym = savesym($gv, "gv_list[$ix]");
1059 #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
1061 my $is_empty = $gv->is_empty;
1062 my $gvname = $gv->NAME;
1063 my $fullname = $gv->STASH->NAME . "::" . $gvname;
1064 my $name = cstring($fullname);
1065 #warn "GV name is $name\n"; # debug
1067 unless ($is_empty) {
1069 if ($$gv != $$egv) {
1070 #warn(sprintf("EGV name is %s, saving it now\n",
1071 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
1072 $egvsym = $egv->save;
1075 $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
1076 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS ),
1077 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS));
1078 $init->add(sprintf("GvLINE($sym) = %u;", $gv->LINE)) unless $is_empty;
1079 # XXX hack for when Perl accesses PVX of GVs
1080 $init->add("SvPVX($sym) = emptystring;\n");
1081 # Shouldn't need to do save_magic since gv_fetchpv handles that
1083 # XXX will always be > 1!!!
1084 my $refcnt = $gv->REFCNT + 1;
1085 $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1 )) if $refcnt > 1;
1087 return $sym if $is_empty;
1089 # XXX B::walksymtable creates an extra reference to the GV
1090 my $gvrefcnt = $gv->GvREFCNT;
1091 if ($gvrefcnt > 1) {
1092 $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
1094 # some non-alphavetic globs require some parts to be saved
1095 # ( ex. %!, but not $! )
1100 sub Save_FORM() { 16 }
1101 sub Save_IO() { 32 }
1103 if( $gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/ ) {
1104 $savefields = Save_HV|Save_AV|Save_SV|Save_CV|Save_FORM|Save_IO;
1106 elsif( $gvname eq '!' ) {
1107 $savefields = Save_HV;
1109 # attributes::bootstrap is created in perl_parse
1110 # saving it would overwrite it, because perl_init() is
1111 # called after perl_parse()
1112 $savefields&=~Save_CV if $fullname eq 'attributes::bootstrap';
1115 # XXX is that correct?
1116 if (defined($egvsym) && $egvsym !~ m/Null/ ) {
1117 # Shared glob *foo = *bar
1118 $init->add("gp_free($sym);",
1119 "GvGP($sym) = GvGP($egvsym);");
1120 } elsif ($savefields) {
1121 # Don't save subfields of special GVs (*_, *1, *# and so on)
1122 # warn "GV::save saving subfields\n"; # debug
1124 if ($$gvsv && $savefields&Save_SV) {
1126 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
1127 # warn "GV::save \$$name\n"; # debug
1130 if ($$gvav && $savefields&Save_AV) {
1132 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
1133 # warn "GV::save \@$name\n"; # debug
1136 if ($$gvhv && $savefields&Save_HV) {
1138 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
1139 # warn "GV::save \%$name\n"; # debug
1142 if ($$gvcv && $savefields&Save_CV) {
1143 my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
1144 "::" . $gvcv->GV->EGV->NAME);
1145 if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias
1146 # must save as a 'stub' so newXS() has a CV to populate
1147 $init->add("{ CV *cv;");
1148 $init->add("\tcv=perl_get_cv($origname,TRUE);");
1149 $init->add("\tGvCV($sym)=cv;");
1150 $init->add("\tSvREFCNT_inc((SV *)cv);");
1153 $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
1154 # warn "GV::save &$name\n"; # debug
1157 $init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE)));
1158 # warn "GV::save GvFILE(*$name)\n"; # debug
1159 my $gvform = $gv->FORM;
1160 if ($$gvform && $savefields&Save_FORM) {
1162 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
1163 # warn "GV::save GvFORM(*$name)\n"; # debug
1166 if ($$gvio && $savefields&Save_IO) {
1168 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
1169 if( $fullname =~ m/::DATA$/ && $save_data_fh ) {
1171 my $fh = *{$fullname}{IO};
1173 $gvio->save_data( $fullname, <$fh> ) if $fh->opened;
1175 # warn "GV::save GvIO(*$name)\n"; # debug
1183 my $sym = objsym($av);
1184 return $sym if defined $sym;
1185 my $avflags = $av->AvFLAGS;
1186 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
1188 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
1189 $xpvavsect->index, $av->REFCNT , $av->FLAGS));
1190 my $sv_list_index = $svsect->index;
1191 my $fill = $av->FILL;
1193 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
1195 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
1196 #if ($fill > -1 && ($avflags & AVf_REAL)) {
1198 my @array = $av->ARRAY;
1202 foreach $el (@array) {
1203 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
1204 $$av, $i++, class($el), $$el);
1207 # my @names = map($_->save, @array);
1208 # XXX Better ways to write loop?
1209 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
1210 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
1212 # micro optimization: op/pat.t ( and other code probably )
1213 # has very large pads ( 20k/30k elements ) passing them to
1214 # ->add is a performance bottleneck: passing them as a
1215 # single string cuts runtime from 6min20sec to 40sec
1217 # you want to keep this out of the no_split/split
1218 # map("\t*svp++ = (SV*)$_;", @names),
1220 foreach my $i ( 0..$#array ) {
1221 $acc .= "\t*svp++ = (SV*)" . $array[$i]->save . ";\n\t";
1228 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
1229 "\tav_extend(av, $fill);",
1230 "\tsvp = AvARRAY(av);" );
1232 $init->add("\tAvFILLp(av) = $fill;",
1235 # we really added a lot of lines ( B::C::InitSection->add
1236 # should really scan for \n, but that would slow
1238 $init->inc_count( $#array );
1241 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
1244 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
1249 my $sym = objsym($hv);
1250 return $sym if defined $sym;
1251 my $name = $hv->NAME;
1255 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
1256 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
1257 # a trashed op but we look at the trashed op_type and segfault.
1258 #my $adpmroot = ${$hv->PMROOT};
1260 $decl->add("static HV *hv$hv_index;");
1261 # XXX Beware of weird package names containing double-quotes, \n, ...?
1262 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
1264 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
1267 $sym = savesym($hv, "hv$hv_index");
1271 # It's just an ordinary HV
1272 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
1273 $hv->MAX, $hv->RITER));
1274 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
1275 $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS));
1276 my $sv_list_index = $svsect->index;
1277 my @contents = $hv->ARRAY;
1280 for ($i = 1; $i < @contents; $i += 2) {
1281 $contents[$i] = $contents[$i]->save;
1284 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
1286 my ($key, $value) = splice(@contents, 0, 2);
1287 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
1288 cstring($key),length(pack "a*",$key),
1289 $value, hash($key)));
1290 # $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
1291 # cstring($key),length($key),$value, 0));
1297 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
1300 sub B::IO::save_data {
1301 my( $io, $globname, @data ) = @_;
1302 my $data = join '', @data;
1304 # XXX using $DATA might clobber it!
1305 my $sym = svref_2object( \\$data )->save;
1306 $init->add( split /\n/, <<CODE );
1308 GV* gv = (GV*)gv_fetchpv( "$globname", TRUE, SVt_PV );
1313 # for PerlIO::scalar
1315 $init->add_eval( sprintf 'open(%s, "<", $%s)', $globname, $globname );
1320 my $sym = objsym($io);
1321 return $sym if defined $sym;
1323 $pv = '' unless defined $pv;
1324 my $len = length($pv);
1325 $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",
1326 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
1327 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
1328 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
1329 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
1330 cchar($io->IoTYPE), $io->IoFLAGS));
1331 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
1332 $xpviosect->index, $io->REFCNT , $io->FLAGS));
1333 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
1334 # deal with $x = *STDIN/STDOUT/STDERR{IO}
1336 foreach ( qw(stdin stdout stderr) ) {
1337 $io->IsSTD($_) and $perlio_func = $_;
1339 if( $perlio_func ) {
1340 $init->add( "IoIFP(${sym})=PerlIO_${perlio_func}();" );
1341 $init->add( "IoOFP(${sym})=PerlIO_${perlio_func}();" );
1345 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
1346 $fsym = $io->$field();
1348 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
1358 # This is where we catch an honest-to-goodness Nullsv (which gets
1359 # blessed into B::SV explicitly) and any stray erroneous SVs.
1360 return 0 unless $$sv;
1361 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
1366 my $init_name = shift;
1368 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
1369 $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect,
1370 $loopsect, $copsect, $svsect, $xpvsect,
1371 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
1372 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
1373 $symsect->output(\*STDOUT, "#define %s\n");
1375 output_declarations();
1376 foreach $section (@sections) {
1377 my $lines = $section->index + 1;
1379 my $name = $section->name;
1380 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
1381 print "Static $typename ${name}_list[$lines];\n";
1384 # XXX hack for when Perl accesses PVX of GVs
1385 print 'Static char emptystring[] = "\0";';
1387 $decl->output(\*STDOUT, "%s\n");
1389 foreach $section (@sections) {
1390 my $lines = $section->index + 1;
1392 my $name = $section->name;
1393 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
1394 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
1395 $section->output(\*STDOUT, "\t{ %s }, /* %d */\n");
1400 $init->output(\*STDOUT, "\t%s\n", $init_name );
1402 warn compile_stats();
1403 warn "NULLOP count: $nullop_count\n";
1407 sub output_declarations {
1409 #ifdef BROKEN_STATIC_REDECL
1410 #define Static extern
1412 #define Static static
1413 #endif /* BROKEN_STATIC_REDECL */
1415 #ifdef BROKEN_UNION_INIT
1417 * Cribbed from cv.h with ANY (a union) replaced by void*.
1418 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
1421 char * xpv_pv; /* pointer to malloced string */
1422 STRLEN xpv_cur; /* length of xp_pv as a C string */
1423 STRLEN xpv_len; /* allocated size */
1424 IV xof_off; /* integer value */
1425 NV xnv_nv; /* numeric value, if any */
1426 MAGIC* xmg_magic; /* magic for scalar array */
1427 HV* xmg_stash; /* class package */
1432 void (*xcv_xsub) (pTHX_ CV*);
1436 long xcv_depth; /* >= 2 indicates recursive call */
1439 cv_flags_t xcv_flags;
1440 U32 xcv_outside_seq; /* the COP sequence (at the point of our
1441 * compilation) in the lexically enclosing
1444 #define ANYINIT(i) i
1446 #define XPVCV_or_similar XPVCV
1447 #define ANYINIT(i) {i}
1448 #endif /* BROKEN_UNION_INIT */
1449 #define Nullany ANYINIT(0)
1454 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1459 sub output_boilerplate {
1465 /* Workaround for mapstart: the only op which needs a different ppaddr */
1466 #undef Perl_pp_mapstart
1467 #define Perl_pp_mapstart Perl_pp_grepstart
1469 #define OP_MAPSTART OP_GREPSTART
1470 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1471 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
1473 static void xs_init (pTHX);
1474 static void dl_init (pTHX);
1475 static PerlInterpreter *my_perl;
1480 my( $op_type, $num ) = @_;
1481 my $op_list = $op_type."_list";
1483 $init->add( split /\n/, <<EOT );
1487 for( i = 0; i < ${num}; ++i )
1489 ${op_list}\[i].op_ppaddr = PL_ppaddr[INT2PTR(int,${op_list}\[i].op_ppaddr)];
1496 my( $op_type, $num ) = @_;
1497 my $op_list = $op_type."_list";
1499 # for resons beyond imagination, MSVC5 considers pWARN_ALL non-const
1500 $init->add( split /\n/, <<EOT );
1504 for( i = 0; i < ${num}; ++i )
1506 switch( (int)(${op_list}\[i].cop_warnings) )
1509 ${op_list}\[i].cop_warnings = pWARN_ALL;
1512 ${op_list}\[i].cop_warnings = pWARN_NONE;
1515 ${op_list}\[i].cop_warnings = pWARN_STD;
1527 /* if USE_IMPLICIT_SYS, we need a 'real' exit */
1533 main(int argc, char **argv, char **env)
1542 PERL_SYS_INIT3(&argc,&argv,&env);
1544 if (!PL_do_undump) {
1545 my_perl = perl_alloc();
1548 perl_construct( my_perl );
1549 PL_perl_destruct_level = 0;
1553 # XXX init free elems!
1554 my $pad_len = regex_padav->FILL + 1 - 1; # first is an avref
1558 for( i = 0; i < $pad_len; ++i ) {
1559 av_push( PL_regex_padav, newSViv(0) );
1561 PL_regex_pad = AvARRAY( PL_regex_padav );
1569 PL_cshlen = strlen(PL_cshname);
1572 #ifdef ALLOW_PERL_OPTIONS
1573 #define EXTRA_OPTIONS 3
1575 #define EXTRA_OPTIONS 4
1576 #endif /* ALLOW_PERL_OPTIONS */
1577 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1579 fakeargv[0] = argv[0];
1587 fakeargv[options_count] = "-T";
1592 #ifndef ALLOW_PERL_OPTIONS
1593 fakeargv[options_count] = "--";
1595 #endif /* ALLOW_PERL_OPTIONS */
1596 for (i = 1; i < argc; i++)
1597 fakeargv[i + options_count - 1] = argv[i];
1598 fakeargv[argc + options_count - 1] = 0;
1600 exitstatus = perl_parse(my_perl, xs_init, argc + options_count - 1,
1609 if( $use_perl_script_name ) {
1611 $dollar_0 =~ s/\\/\\\\/g;
1612 $dollar_0 = '"' . $dollar_0 . '"';
1615 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */
1616 tmpsv = GvSV(tmpgv);
1617 sv_setpv(tmpsv, ${dollar_0});
1624 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */
1625 tmpsv = GvSV(tmpgv);
1626 sv_setpv(tmpsv, argv[0]);
1633 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
1634 tmpsv = GvSV(tmpgv);
1636 sv_setpv(tmpsv,"perl.exe");
1638 sv_setpv(tmpsv,"perl");
1645 /* PL_main_cv = PL_compcv; */
1648 exitstatus = perl_init();
1653 exitstatus = perl_run( my_perl );
1655 perl_destruct( my_perl );
1656 perl_free( my_perl );
1663 /* yanked from perl.c */
1667 char *file = __FILE__;
1671 print "\n#ifdef USE_DYNAMIC_LOADING";
1672 print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1673 print "\n#endif\n" ;
1674 # delete $xsub{'DynaLoader'};
1675 delete $xsub{'UNIVERSAL'};
1676 print("/* bootstrapping code*/\n\tSAVETMPS;\n");
1677 print("\ttarg=sv_newmortal();\n");
1678 print "#ifdef USE_DYNAMIC_LOADING\n";
1679 print "\tPUSHMARK(sp);\n";
1680 print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
1681 print qq/\tPUTBACK;\n/;
1682 print "\tboot_DynaLoader(aTHX_ NULL);\n";
1683 print qq/\tSPAGAIN;\n/;
1685 foreach my $stashname (keys %xsub){
1686 if ($xsub{$stashname} !~ m/Dynamic/ ) {
1687 my $stashxsub=$stashname;
1688 $stashxsub =~ s/::/__/g;
1689 print "\tPUSHMARK(sp);\n";
1690 print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
1691 print qq/\tPUTBACK;\n/;
1692 print "\tboot_$stashxsub(aTHX_ NULL);\n";
1693 print qq/\tSPAGAIN;\n/;
1696 print("\tFREETMPS;\n/* end bootstrapping code */\n");
1703 char *file = __FILE__;
1707 print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
1708 print("\ttarg=sv_newmortal();\n");
1709 foreach my $stashname (@DynaLoader::dl_modules) {
1710 warn "Loaded $stashname\n";
1711 if (exists($xsub{$stashname}) && $xsub{$stashname} =~ m/Dynamic/) {
1712 my $stashxsub=$stashname;
1713 $stashxsub =~ s/::/__/g;
1714 print "\tPUSHMARK(sp);\n";
1715 print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
1716 print qq/\tPUTBACK;\n/;
1717 print "#ifdef USE_DYNAMIC_LOADING\n";
1718 warn "bootstrapping $stashname added to xs_init\n";
1719 if( $xsub{$stashname} eq 'Dynamic' ) {
1720 print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
1723 print qq/\tperl_call_pv("XSLoader::load",G_DISCARD);\n/;
1726 print "\tboot_$stashxsub(aTHX_ NULL);\n";
1728 print qq/\tSPAGAIN;\n/;
1731 print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
1737 warn "----Symbol table:\n";
1738 while (($sym, $val) = each %symtable) {
1739 warn "$sym => $val\n";
1741 warn "---End of symbol table\n";
1747 svref_2object($sv)->save;
1751 sub Dummy_BootStrap { }
1756 my $package=$gv->STASH->NAME;
1757 my $name = $gv->NAME;
1763 my $fullname = $gv->STASH->NAME . "::" . $gv->NAME;
1765 # We may be looking at this package just because it is a branch in the
1766 # symbol table which is on the path to a package which we need to save
1767 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1769 return unless ($unused_sub_packages{$package});
1770 return unless ($$cv || $$av || $$sv || $$hv);
1776 my $package = shift;
1777 unless ($unused_sub_packages{$package})
1780 $unused_sub_packages{$package} = 1;
1781 if (defined @{$package.'::ISA'})
1783 foreach my $isa (@{$package.'::ISA'})
1785 if ($isa eq 'DynaLoader')
1787 unless (defined(&{$package.'::bootstrap'}))
1789 warn "Forcing bootstrap of $package\n";
1790 eval { $package->bootstrap };
1795 unless ($unused_sub_packages{$isa})
1797 warn "$isa saved (it is in $package\'s \@ISA)\n";
1809 no strict qw(vars refs);
1810 my $package = shift;
1811 $package =~ s/::$//;
1812 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1813 # warn "Considering $package\n";#debug
1814 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1816 # If this package is a prefix to something we are saving, traverse it
1817 # but do not mark it for saving if it is not already
1818 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1820 return 1 if ($u =~ /^$package\:\:/);
1822 if (exists $unused_sub_packages{$package})
1824 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1825 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1826 return $unused_sub_packages{$package};
1828 # Omit the packages which we use (and which cause grief
1829 # because of fancy "goto &$AUTOLOAD" stuff).
1830 # XXX Surely there must be a nicer way to do this.
1831 if ($package eq "FileHandle" || $package eq "Config" ||
1832 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1834 delete_unsaved_hashINC($package);
1835 return $unused_sub_packages{$package} = 0;
1837 # Now see if current package looks like an OO class this is probably too strong.
1838 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1840 if (UNIVERSAL::can($package, $m))
1842 warn "$package has method $m: saving package\n";#debug
1843 return mark_package($package);
1846 delete_unsaved_hashINC($package);
1847 return $unused_sub_packages{$package} = 0;
1849 sub delete_unsaved_hashINC{
1851 $packname =~ s/\:\:/\//g;
1853 # warn "deleting $packname" if $INC{$packname} ;# debug
1854 delete $INC{$packname};
1858 my ($symref, $recurse, $prefix) = @_;
1863 $prefix = '' unless defined $prefix;
1864 while (($sym, $ref) = each %$symref)
1869 $sym = $prefix . $sym;
1870 if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym))
1872 walkpackages(\%glob, $recurse, $sym);
1879 sub save_unused_subs
1882 &descend_marked_unused;
1884 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1885 warn "Saving methods\n";
1886 walksymtable(\%{"main::"}, "savecv", \&should_save);
1891 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1892 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1893 my $inc_hv = svref_2object(\%INC)->save;
1894 my $inc_av = svref_2object(\@INC)->save;
1895 my $amagic_generate= amagic_generation;
1896 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1897 "GvHV(PL_incgv) = $inc_hv;",
1898 "GvAV(PL_incgv) = $inc_av;",
1899 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1900 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1901 "PL_amagic_generation= $amagic_generate;" );
1904 sub descend_marked_unused {
1905 foreach my $pack (keys %unused_sub_packages)
1907 mark_package($pack);
1912 # this is mainly for the test suite
1913 my $warner = $SIG{__WARN__};
1914 local $SIG{__WARN__} = sub { print STDERR @_ };
1916 warn "Starting compile\n";
1917 warn "Walking tree\n";
1918 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1919 walkoptree(main_root, "save");
1920 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1922 # XSLoader was used, force saving of XSLoader::load
1923 if( $use_xsloader ) {
1924 my $cv = svref_2object( \&XSLoader::load );
1927 # save %SIG ( in case it was set in a BEGIN block )
1929 local $SIG{__WARN__} = $warner;
1931 $init->add("{", "\tHV* hv = get_hv(\"main::SIG\",1);" );
1932 foreach my $k ( keys %SIG ) {
1933 next unless ref $SIG{$k};
1934 my $cv = svref_2object( \$SIG{$k} );
1936 $init->add('{',sprintf 'SV* sv = (SV*)%s;', $sv );
1937 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
1938 cstring($k),length(pack "a*",$k),
1940 $init->add('mg_set(sv);','}');
1946 $init->add( sprintf " PL_dowarn = ( %s ) ? G_WARN_ON : G_WARN_OFF;", $^W );
1948 my $init_av = init_av->save;
1949 my $end_av = end_av->save;
1950 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1951 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1952 "PL_initav = (AV *) $init_av;",
1953 "PL_endav = (AV*) $end_av;");
1955 # init op addrs ( must be the last action, otherwise
1956 # some ops might not be initialized
1957 if( $optimize_ppaddr ) {
1958 foreach my $i ( @op_sections ) {
1960 next unless $section->index >= 0;
1961 init_op_addr( $section->name, $section->index + 1);
1964 init_op_warn( $copsect->name, $copsect->index + 1)
1965 if $optimize_warn_sv && $copsect->index >= 0;
1967 warn "Writing output\n";
1968 output_boilerplate();
1970 output_all("perl_init");
1976 my @sections = (decl => \$decl, sym => \$symsect,
1977 binop => \$binopsect, condop => \$condopsect,
1978 cop => \$copsect, padop => \$padopsect,
1979 listop => \$listopsect, logop => \$logopsect,
1980 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1981 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1982 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1983 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1984 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1985 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1986 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1987 xpvio => \$xpviosect);
1988 my ($name, $sectref);
1989 while (($name, $sectref) = splice(@sections, 0, 2)) {
1990 $$sectref = new B::C::Section $name, \%symtable, 0;
1992 $init = new B::C::InitSection 'init', \%symtable, 0;
1997 my ($arg,$val) = @_;
1998 $unused_sub_packages{$arg} = $val;
2003 my ($option, $opt, $arg);
2004 my @eval_at_startup;
2005 my %option_map = ( 'cog' => \$pv_copy_on_grow,
2006 'save-data' => \$save_data_fh,
2007 'ppaddr' => \$optimize_ppaddr,
2008 'warn-sv' => \$optimize_warn_sv,
2009 'use-script-name' => \$use_perl_script_name,
2010 'save-sig-hash' => \$save_sig,
2012 my %optimization_map = ( 0 => [ qw() ], # special case
2014 2 => [ qw(-fwarn-sv -fppaddr) ],
2017 while ($option = shift @options) {
2018 if ($option =~ /^-(.)(.*)/) {
2022 unshift @options, $option;
2025 if ($opt eq "-" && $arg eq "-") {
2030 $warn_undefined_syms = 1;
2031 } elsif ($opt eq "D") {
2032 $arg ||= shift @options;
2033 foreach $arg (split(//, $arg)) {
2036 } elsif ($arg eq "c") {
2038 } elsif ($arg eq "A") {
2040 } elsif ($arg eq "C") {
2042 } elsif ($arg eq "M") {
2045 warn "ignoring unknown debug option: $arg\n";
2048 } elsif ($opt eq "o") {
2049 $arg ||= shift @options;
2050 open(STDOUT, ">$arg") or return "$arg: $!\n";
2051 } elsif ($opt eq "v") {
2053 } elsif ($opt eq "u") {
2054 $arg ||= shift @options;
2055 mark_unused($arg,undef);
2056 } elsif ($opt eq "f") {
2057 $arg ||= shift @options;
2058 $arg =~ m/(no-)?(.*)/;
2059 my $no = defined($1) && $1 eq 'no-';
2060 $arg = $no ? $2 : $arg;
2061 if( exists $option_map{$arg} ) {
2062 ${$option_map{$arg}} = !$no;
2064 die "Invalid optimization '$arg'";
2066 } elsif ($opt eq "O") {
2067 $arg = 1 if $arg eq "";
2069 foreach my $i ( 1 .. $arg ) {
2070 push @opt, @{$optimization_map{$i}}
2071 if exists $optimization_map{$i};
2073 unshift @options, @opt;
2074 } elsif ($opt eq "e") {
2075 push @eval_at_startup, $arg;
2076 } elsif ($opt eq "l") {
2077 $max_string_len = $arg;
2081 foreach my $i ( @eval_at_startup ) {
2082 $init->add_eval( $i );
2087 foreach $objname (@options) {
2088 eval "save_object(\\$objname)";
2093 return sub { save_main() };
2103 B::C - Perl compiler's C backend
2107 perl -MO=C[,OPTIONS] foo.pl
2111 This compiler backend takes Perl source and generates C source code
2112 corresponding to the internal structures that perl uses to run
2113 your program. When the generated C source is compiled and run, it
2114 cuts out the time which perl would have taken to load and parse
2115 your program into its internal semi-compiled form. That means that
2116 compiling with this backend will not help improve the runtime
2117 execution speed of your program but may improve the start-up time.
2118 Depending on the environment in which your program runs this may be
2119 either a help or a hindrance.
2123 If there are any non-option arguments, they are taken to be
2124 names of objects to be saved (probably doesn't work properly yet).
2125 Without extra arguments, it saves the main program.
2131 Output to filename instead of STDOUT
2135 Verbose compilation (currently gives a few compilation statistics).
2139 Force end of options
2143 Force apparently unused subs from package Packname to be compiled.
2144 This allows programs to use eval "foo()" even when sub foo is never
2145 seen to be used at compile time. The down side is that any subs which
2146 really are never used also have code generated. This option is
2147 necessary, for example, if you have a signal handler foo which you
2148 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
2149 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
2150 options. The compiler tries to figure out which packages may possibly
2151 have subs in which need compiling but the current version doesn't do
2152 it very well. In particular, it is confused by nested packages (i.e.
2153 of the form C<A::B>) where package C<A> does not contain any subs.
2157 Debug options (concatenated or separate flags like C<perl -D>).
2161 OPs, prints each OP as it's processed
2165 COPs, prints COPs as processed (incl. file & line num)
2169 prints AV information on saving
2173 prints CV information on saving
2177 prints MAGIC information on saving
2181 Force options/optimisations on or off one at a time. You can explicitly
2182 disable an option using B<-fno-option>. All options default to
2189 Copy-on-grow: PVs declared and initialised statically.
2191 =item B<-fsave-data>
2193 Save package::DATA filehandles ( only available with PerlIO ).
2197 Optimize the initialization of op_ppaddr.
2201 Optimize the initialization of cop_warnings.
2203 =item B<-fuse-script-name>
2205 Use the script name instead of the program name as $0.
2207 =item B<-fsave-sig-hash>
2209 Save compile-time modifications to the %SIG hash.
2215 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
2221 Disable all optimizations.
2229 Enable B<-fppaddr>, B<-fwarn-sv>.
2235 Some C compilers impose an arbitrary limit on the length of string
2236 constants (e.g. 2048 characters for Microsoft Visual C++). The
2237 B<-llimit> options tells the C backend not to generate string literals
2238 exceeding that limit.
2244 perl -MO=C,-ofoo.c foo.pl
2245 perl cc_harness -o foo foo.c
2247 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
2248 library directory. The utility called C<perlcc> may also be used to
2249 help make use of this compiler.
2251 perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null
2255 Plenty. Current status: experimental.
2259 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>