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.04';
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 # Set the values for op_opt and op_static in each op. The value of
230 # op_opt is irrelevant, and the value of op_static needs to be 1 to tell
231 # op_free that this is a statically defined op and that is shouldn't be
233 my $op_os = "0, 1, 0";
235 # Look this up here so we can do just a number compare
236 # rather than looking up the name of every BASEOP in B::OP
237 my $OP_THREADSV = opnumber('threadsv');
240 my ($obj, $value) = @_;
241 my $sym = sprintf("s\\_%x", $$obj);
242 $symtable{$sym} = $value;
247 return $symtable{sprintf("s\\_%x", $$obj)};
254 return 0 if $sym eq "sym_0"; # special case
255 $value = $symtable{$sym};
256 if (defined($value)) {
259 warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
266 my $sym = sprintf("re%d", $re_index++);
267 $decl->add(sprintf("static char *$sym = %s;", cstring($re)));
269 return ($sym,length(pack "a*",$re));
273 my $pv = pack "a*", shift;
276 if ($pv_copy_on_grow) {
277 $pvsym = sprintf("pv%d", $pv_index++);
279 if( defined $max_string_len && length($pv) > $max_string_len ) {
280 my $chars = join ', ', map { cchar $_ } split //, $pv;
281 $decl->add(sprintf("static char %s[] = { %s };", $pvsym, $chars));
284 my $cstring = cstring($pv);
285 if ($cstring ne "0") { # sic
286 $decl->add(sprintf("static char %s[] = %s;",
291 $pvmax = length(pack "a*",$pv) + 1;
293 return ($pvsym, $pvmax);
298 # confess "Can't save RV: not ROK" unless $sv->FLAGS & SVf_ROK;
299 my $rv = $sv->RV->save;
301 $rv =~ s/^\(([AGHS]V|IO)\s*\*\)\s*(\&sv_list.*)$/$2/;
306 # savesym, pvmax, len, pv
310 my $rok = $sv->FLAGS & SVf_ROK;
311 my $pok = $sv->FLAGS & SVf_POK;
312 my( $len, $pvmax, $savesym, $pv ) = ( 0, 0 );
314 $savesym = '(char*)' . save_rv( $sv );
317 $pv = $pok ? (pack "a*", $sv->PV) : undef;
318 $len = $pok ? length($pv) : 0;
319 ($savesym, $pvmax) = $pok ? savepv($pv) : ( 'NULL', 0 );
322 return ( $savesym, $pvmax, $len, $pv );
325 # see also init_op_ppaddr below; initializes the ppaddt to the
326 # OpTYPE; init_op_ppaddr iterates over the ops and sets
327 # op_ppaddr to PL_ppaddr[op_ppaddr]; this avoids an explicit assignmente
328 # in perl_init ( ~10 bytes/op with GCC/i386 )
329 sub B::OP::fake_ppaddr {
330 return $optimize_ppaddr ?
331 sprintf("INT2PTR(void*,OP_%s)", uc( $_[0]->name ) ) :
336 my ($op, $level) = @_;
337 my $sym = objsym($op);
338 return $sym if defined $sym;
339 my $type = $op->type;
340 $nullop_count++ unless $type;
341 if ($type == $OP_THREADSV) {
342 # saves looking up ppaddr but it's a bit naughty to hard code this
343 $init->add(sprintf("(void)find_threadsv(%s);",
344 cstring($threadsv_names[$op->targ])));
346 $opsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x",
347 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, $op->targ,
348 $type, $op->flags, $op->private));
349 my $ix = $opsect->index;
350 $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr))
351 unless $optimize_ppaddr;
352 savesym($op, "&op_list[$ix]");
356 my ($class, %objdata) = @_;
357 bless \%objdata, $class;
360 sub B::FAKEOP::save {
361 my ($op, $level) = @_;
362 $opsect->add(sprintf("%s, %s, %s, %u, %u, $op_os, 0x%x, 0x%x",
363 $op->next, $op->sibling, $op->fake_ppaddr, $op->targ,
364 $op->type, $op->flags, $op->private));
365 my $ix = $opsect->index;
366 $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr))
367 unless $optimize_ppaddr;
368 return "&op_list[$ix]";
371 sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
372 sub B::FAKEOP::type { $_[0]->{type} || 0}
373 sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
374 sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
375 sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
376 sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
377 sub B::FAKEOP::private { $_[0]->{private} || 0 }
380 my ($op, $level) = @_;
381 my $sym = objsym($op);
382 return $sym if defined $sym;
383 $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, s\\_%x",
384 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
385 $op->targ, $op->type, $op->flags,
386 $op->private, ${$op->first}));
387 my $ix = $unopsect->index;
388 $init->add(sprintf("unop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
389 unless $optimize_ppaddr;
390 savesym($op, "(OP*)&unop_list[$ix]");
394 my ($op, $level) = @_;
395 my $sym = objsym($op);
396 return $sym if defined $sym;
397 $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, s\\_%x, s\\_%x",
398 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
399 $op->targ, $op->type, $op->flags,
400 $op->private, ${$op->first}, ${$op->last}));
401 my $ix = $binopsect->index;
402 $init->add(sprintf("binop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
403 unless $optimize_ppaddr;
404 savesym($op, "(OP*)&binop_list[$ix]");
407 sub B::LISTOP::save {
408 my ($op, $level) = @_;
409 my $sym = objsym($op);
410 return $sym if defined $sym;
411 $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, s\\_%x, s\\_%x",
412 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
413 $op->targ, $op->type, $op->flags,
414 $op->private, ${$op->first}, ${$op->last}));
415 my $ix = $listopsect->index;
416 $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
417 unless $optimize_ppaddr;
418 savesym($op, "(OP*)&listop_list[$ix]");
422 my ($op, $level) = @_;
423 my $sym = objsym($op);
424 return $sym if defined $sym;
425 $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, s\\_%x, s\\_%x",
426 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
427 $op->targ, $op->type, $op->flags,
428 $op->private, ${$op->first}, ${$op->other}));
429 my $ix = $logopsect->index;
430 $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
431 unless $optimize_ppaddr;
432 savesym($op, "(OP*)&logop_list[$ix]");
436 my ($op, $level) = @_;
437 my $sym = objsym($op);
438 return $sym if defined $sym;
439 #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
440 # peekop($op->redoop), peekop($op->nextop),
441 # peekop($op->lastop)); # debug
442 $loopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x",
443 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
444 $op->targ, $op->type, $op->flags,
445 $op->private, ${$op->first}, ${$op->last},
446 ${$op->redoop}, ${$op->nextop},
448 my $ix = $loopsect->index;
449 $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
450 unless $optimize_ppaddr;
451 savesym($op, "(OP*)&loop_list[$ix]");
455 my ($op, $level) = @_;
456 my $sym = objsym($op);
457 return $sym if defined $sym;
458 $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, %s",
459 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
460 $op->targ, $op->type, $op->flags,
461 $op->private, cstring($op->pv)));
462 my $ix = $pvopsect->index;
463 $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
464 unless $optimize_ppaddr;
465 savesym($op, "(OP*)&pvop_list[$ix]");
469 my ($op, $level) = @_;
470 my $sym = objsym($op);
471 return $sym if defined $sym;
473 my $svsym = '(SV*)' . $sv->save;
474 my $is_const_addr = $svsym =~ m/Null|\&/;
475 $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, %s",
476 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
477 $op->targ, $op->type, $op->flags,
479 ( $is_const_addr ? $svsym : 'Nullsv' )));
480 my $ix = $svopsect->index;
481 $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
482 unless $optimize_ppaddr;
483 $init->add("svop_list[$ix].op_sv = $svsym;")
484 unless $is_const_addr;
485 savesym($op, "(OP*)&svop_list[$ix]");
489 my ($op, $level) = @_;
490 my $sym = objsym($op);
491 return $sym if defined $sym;
492 $padopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, %d",
493 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
494 $op->targ, $op->type, $op->flags,
495 $op->private,$op->padix));
496 my $ix = $padopsect->index;
497 $init->add(sprintf("padop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
498 unless $optimize_ppaddr;
499 # $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix));
500 savesym($op, "(OP*)&padop_list[$ix]");
504 my ($op, $level) = @_;
505 my $sym = objsym($op);
506 return $sym if defined $sym;
507 warn sprintf("COP: line %d file %s\n", $op->line, $op->file)
509 # shameless cut'n'paste from B::Deparse
511 my $warnings = $op->warnings;
512 my $is_special = $warnings->isa("B::SPECIAL");
513 if ($is_special && $$warnings == 4) {
514 # use warnings 'all';
515 $warn_sv = $optimize_warn_sv ?
519 elsif ($is_special && $$warnings == 5) {
521 $warn_sv = $optimize_warn_sv ?
525 elsif ($is_special) {
527 $warn_sv = $optimize_warn_sv ?
533 $warn_sv = $warnings->save;
536 $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, %s, NULL, NULL, %u, %d, %u, %s",
537 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
538 $op->targ, $op->type, $op->flags,
539 $op->private, cstring($op->label), $op->cop_seq,
540 $op->arybase, $op->line,
541 ( $optimize_warn_sv ? $warn_sv : 'NULL' )));
542 my $ix = $copsect->index;
543 $init->add(sprintf("cop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
544 unless $optimize_ppaddr;
545 $init->add(sprintf("cop_list[$ix].cop_warnings = %s;", $warn_sv ))
546 unless $optimize_warn_sv;
547 $init->add(sprintf("CopFILE_set(&cop_list[$ix], %s);", cstring($op->file)),
548 sprintf("CopSTASHPV_set(&cop_list[$ix], %s);", cstring($op->stashpv)));
550 savesym($op, "(OP*)&cop_list[$ix]");
554 my ($op, $level) = @_;
555 my $sym = objsym($op);
556 return $sym if defined $sym;
557 my $replroot = $op->pmreplroot;
558 my $replstart = $op->pmreplstart;
560 my $replstartfield = sprintf("s\\_%x", $$replstart);
562 my $ppaddr = $op->ppaddr;
563 # under ithreads, OP_PUSHRE.op_replroot is an integer
564 $replrootfield = sprintf("s\\_%x", $$replroot) if ref $replroot;
565 if($ithreads && $op->name eq "pushre") {
566 $replrootfield = "INT2PTR(OP*,${replroot})";
567 } elsif ($$replroot) {
568 # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
569 # argument to a split) stores a GV in op_pmreplroot instead
570 # of a substitution syntax tree. We don't want to walk that...
571 if ($op->name eq "pushre") {
572 $gvsym = $replroot->save;
573 # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
576 $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
579 # pmnext handling is broken in perl itself, I think. Bad op_pmnext
580 # fields aren't noticed in perl's runtime (unless you try reset) but we
581 # segfault when trying to dereference it to find op->op_pmnext->op_type
582 $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, s\\_%x, s\\_%x, %s, %s, 0, %u, 0x%x, 0x%x, 0x%x",
583 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, $op->targ,
584 $op->type, $op->flags, $op->private,
585 ${$op->first}, ${$op->last},
586 $replrootfield, $replstartfield,
587 ( $ithreads ? $op->pmoffset : 0 ),
588 $op->pmflags, $op->pmpermflags, $op->pmdynflags ));
589 my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
590 $init->add(sprintf("$pm.op_ppaddr = %s;", $ppaddr))
591 unless $optimize_ppaddr;
592 my $re = $op->precomp;
594 my( $resym, $relen ) = savere( $re );
595 $init->add(sprintf("PM_SETRE(&$pm,pregcomp($resym, $resym + %u, &$pm));",
599 $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
601 savesym($op, "(OP*)&$pm");
604 sub B::SPECIAL::save {
606 # special case: $$sv is not the address but an index into specialsv_list
607 # warn "SPECIAL::save specialsv $$sv\n"; # debug
608 my $sym = $specialsv_name[$$sv];
609 if (!defined($sym)) {
610 confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
615 sub B::OBJECT::save {}
619 my $sym = objsym($sv);
620 return $sym if defined $sym;
621 # warn "Saving SVt_NULL SV\n"; # debug
624 warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
625 return savesym($sv, "(void*)Nullsv /* XXX */");
627 $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS));
628 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
633 my $sym = objsym($sv);
634 return $sym if defined $sym;
635 $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
636 $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
637 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
638 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
643 my $sym = objsym($sv);
644 return $sym if defined $sym;
646 $val .= '.00' if $val =~ /^-?\d+$/;
647 $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
648 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
649 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
650 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
656 # work with byte offsets/lengths
657 my $pv = pack "a*", $pv;
658 if (defined $max_string_len && length($pv) > $max_string_len) {
659 push @res, sprintf("New(0,%s,%u,char);", $dest, length($pv)+1);
662 my $str = substr $pv, 0, $max_string_len, '';
663 push @res, sprintf("Copy(%s,$dest+$offset,%u,char);",
664 cstring($str), length($str));
665 $offset += length $str;
667 push @res, sprintf("%s[%u] = '\\0';", $dest, $offset);
670 push @res, sprintf("%s = savepvn(%s, %u);", $dest,
671 cstring($pv), length($pv));
678 my $sym = objsym($sv);
679 return $sym if defined $sym;
681 my $len = length($pv);
682 my ($pvsym, $pvmax) = savepv($pv);
683 my ($lvtarg, $lvtarg_sym);
684 $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
685 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
686 $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
687 $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
688 $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS));
689 if (!$pv_copy_on_grow) {
690 $init->add(savepvn(sprintf("xpvlv_list[%d].xpv_pv",
691 $xpvlvsect->index), $pv));
694 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
699 my $sym = objsym($sv);
700 return $sym if defined $sym;
701 my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
702 $xpvivsect->add(sprintf("%s, %u, %u, %d", $savesym, $len, $pvmax, $sv->IVX));
703 $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
704 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
705 if (defined($pv) && !$pv_copy_on_grow) {
706 $init->add(savepvn(sprintf("xpviv_list[%d].xpv_pv",
707 $xpvivsect->index), $pv));
709 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
714 my $sym = objsym($sv);
715 return $sym if defined $sym;
716 my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
718 $val .= '.00' if $val =~ /^-?\d+$/;
719 $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
720 $savesym, $len, $pvmax, $sv->IVX, $val));
721 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
722 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
723 if (defined($pv) && !$pv_copy_on_grow) {
724 $init->add(savepvn(sprintf("xpvnv_list[%d].xpv_pv",
725 $xpvnvsect->index), $pv));
727 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
732 my $sym = objsym($sv);
733 return $sym if defined $sym;
734 my $pv = pack "a*", ($sv->PV . "\0" . $sv->TABLE);
735 my $len = length($pv);
736 $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
737 $len, $len + 258, $sv->IVX, $sv->NVX,
738 $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
739 $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
740 $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS));
742 $init->add(savepvn(sprintf("xpvbm_list[%d].xpv_pv",
743 $xpvbmsect->index), $pv),
744 sprintf("xpvbm_list[%d].xpv_cur = %u;",
745 $xpvbmsect->index, $len - 257));
746 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
751 my $sym = objsym($sv);
752 return $sym if defined $sym;
753 my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
754 $xpvsect->add(sprintf("%s, %u, %u", $savesym, $len, $pvmax));
755 $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
756 $xpvsect->index, $sv->REFCNT , $sv->FLAGS));
757 if (defined($pv) && !$pv_copy_on_grow) {
758 $init->add(savepvn(sprintf("xpv_list[%d].xpv_pv",
759 $xpvsect->index), $pv));
761 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
766 my $sym = objsym($sv);
767 return $sym if defined $sym;
768 my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
770 $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
771 $savesym, $len, $pvmax,
772 $sv->IVX, $sv->NVX));
773 $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
774 $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS));
775 if (defined($pv) && !$pv_copy_on_grow) {
776 $init->add(savepvn(sprintf("xpvmg_list[%d].xpv_pv",
777 $xpvmgsect->index), $pv));
779 $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
784 sub B::PVMG::save_magic {
786 #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
787 my $stash = $sv->SvSTASH;
790 warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
792 # XXX Hope stash is already going to be saved.
793 $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
795 my @mgchain = $sv->MAGIC;
796 my ($mg, $type, $obj, $ptr,$len,$ptrsv);
797 foreach $mg (@mgchain) {
802 warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
803 class($sv), $$sv, class($obj), $$obj,
804 cchar($type), cstring($ptr));
807 unless( $type eq 'r' ) {
812 if ($len == HEf_SVKEY){
813 #The pointer is an SV*
814 $ptrsv=svref_2object($ptr)->save;
815 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
816 $$sv, $$obj, cchar($type),$ptrsv,$len));
817 }elsif( $type eq 'r' ){
819 my $pmop = $REGEXP{$rx};
821 confess "PMOP not found for REGEXP $rx" unless $pmop;
823 my( $resym, $relen ) = savere( $mg->precomp );
824 my $pmsym = $pmop->save;
825 $init->add( split /\n/, sprintf <<CODE, $$sv, cchar($type), cstring($ptr) );
827 REGEXP* rx = pregcomp($resym, $resym + $relen, (PMOP*)$pmsym);
828 sv_magic((SV*)s\\_%x, (SV*)rx, %s, %s, %d);
832 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
833 $$sv, $$obj, cchar($type),cstring($ptr),$len));
840 my $sym = objsym($sv);
841 return $sym if defined $sym;
842 my $rv = save_rv( $sv );
843 # GVs need to be handled at runtime
844 if( ref( $sv->RV ) eq 'B::GV' ) {
845 $xrvsect->add( "(SV*)Nullgv" );
846 $init->add(sprintf("xrv_list[%d].xrv_rv = (SV*)%s;\n", $xrvsect->index, $rv));
849 elsif( $sv->RV->isa( 'B::HV' ) && $sv->RV->NAME ) {
850 $xrvsect->add( "(SV*)Nullhv" );
851 $init->add(sprintf("xrv_list[%d].xrv_rv = (SV*)%s;\n", $xrvsect->index, $rv));
856 $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
857 $xrvsect->index, $sv->REFCNT , $sv->FLAGS));
858 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
862 my ($cvstashname, $cvname) = @_;
863 warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
864 # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
865 # use should be handled by the class itself.
867 my $isa = \@{"$cvstashname\::ISA"};
868 if (grep($_ eq "AutoLoader", @$isa)) {
869 warn "Forcing immediate load of sub derived from AutoLoader\n";
870 # Tweaked version of AutoLoader::AUTOLOAD
871 my $dir = $cvstashname;
873 eval { require "auto/$dir/$cvname.al" };
875 warn qq(failed require "auto/$dir/$cvname.al": $@\n);
885 my $sym = objsym($cv);
887 # warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
890 # Reserve a place in svsect and xpvcvsect and record indices
892 my ($cvname, $cvstashname);
895 $cvstashname = $gv->STASH->NAME;
897 my $root = $cv->ROOT;
898 my $cvxsub = $cv->XSUB;
899 my $isconst = $cv->CvFLAGS & CVf_CONST;
901 my $value = $cv->XSUBANY;
902 my $stash = $gv->STASH;
903 my $vsym = $value->save;
904 my $stsym = $stash->save;
905 my $name = cstring($cvname);
906 $decl->add( "static CV* cv$cv_index;" );
907 $init->add( "cv$cv_index = newCONSTSUB( $stsym, NULL, $vsym );" );
908 my $sym = savesym( $cv, "cv$cv_index" );
912 #INIT is removed from the symbol table, so this call must come
913 # from PL_initav->save. Re-bootstrapping will push INIT back in
914 # so nullop should be sent.
915 if (!$isconst && $cvxsub && ($cvname ne "INIT")) {
917 my $stashname = $egv->STASH->NAME;
918 if ($cvname eq "bootstrap")
920 my $file = $gv->FILE;
921 $decl->add("/* bootstrap $file */");
922 warn "Bootstrap $stashname $file\n";
923 # if it not isa('DynaLoader'), it should hopefully be XSLoaded
924 # ( attributes being an exception, of course )
925 if( $stashname ne 'attributes' &&
926 !UNIVERSAL::isa($stashname,'DynaLoader') ) {
927 $xsub{$stashname}='Dynamic-XSLoaded';
931 $xsub{$stashname}='Dynamic';
933 # $xsub{$stashname}='Static' unless $xsub{$stashname};
938 # XSUBs for IO::File, IO::Handle, IO::Socket,
939 # IO::Seekable and IO::Poll
940 # are defined in IO.xs, so let's bootstrap it
941 svref_2object( \&IO::bootstrap )->save
942 if grep { $stashname eq $_ } qw(IO::File IO::Handle IO::Socket
943 IO::Seekable IO::Poll);
945 warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv;
946 return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/;
948 if ($cvxsub && $cvname eq "INIT") {
950 return svref_2object(\&Dummy_initxs)->save;
952 my $sv_ix = $svsect->index + 1;
953 $svsect->add("svix$sv_ix");
954 my $xpvcv_ix = $xpvcvsect->index + 1;
955 $xpvcvsect->add("xpvcvix$xpvcv_ix");
956 # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
957 $sym = savesym($cv, "&sv_list[$sv_ix]");
958 warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv;
959 if (!$$root && !$cvxsub) {
960 if (try_autoload($cvstashname, $cvname)) {
961 # Recalculate root and xsub
964 if ($$root || $cvxsub) {
965 warn "Successful forced autoload\n";
970 my $padlist = $cv->PADLIST;
973 my $xsubany = "Nullany";
975 warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
976 $$cv, $$root) if $debug_cv;
979 my $stashname = $gv->STASH->NAME;
980 my $gvname = $gv->NAME;
981 if ($gvname ne "__ANON__") {
982 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
983 $ppname .= ($stashname eq "main") ?
984 $gvname : "$stashname\::$gvname";
985 $ppname =~ s/::/__/g;
986 if ($gvname eq "INIT"){
987 $ppname .= "_$initsub_index";
993 $ppname = "pp_anonsub_$anonsub_index";
996 $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
997 warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
998 $$cv, $ppname, $$root) if $debug_cv;
1000 warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
1001 $$padlist, $$cv) if $debug_cv;
1003 warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
1004 $$padlist, $$cv) if $debug_cv;
1008 warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
1009 $cvstashname, $cvname); # debug
1011 $pv = '' unless defined $pv; # Avoid use of undef warnings
1012 $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",
1013 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
1014 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
1015 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS,
1018 if (${$cv->OUTSIDE} == ${main_cv()}){
1019 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
1020 $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
1025 $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
1026 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
1027 $$gv, $$cv) if $debug_cv;
1030 $init->add( savepvn( "CvFILE($sym)", $cv->FILE) );
1033 $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE)));
1035 my $stash = $cv->STASH;
1038 $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
1039 warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
1040 $$stash, $$cv) if $debug_cv;
1042 $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
1043 $sv_ix, $xpvcv_ix, $cv->REFCNT +1*0 , $cv->FLAGS));
1049 my $sym = objsym($gv);
1050 if (defined($sym)) {
1051 #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
1054 my $ix = $gv_index++;
1055 $sym = savesym($gv, "gv_list[$ix]");
1056 #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
1058 my $is_empty = $gv->is_empty;
1059 my $gvname = $gv->NAME;
1060 my $fullname = $gv->STASH->NAME . "::" . $gvname;
1061 my $name = cstring($fullname);
1062 #warn "GV name is $name\n"; # debug
1064 unless ($is_empty) {
1066 if ($$gv != $$egv) {
1067 #warn(sprintf("EGV name is %s, saving it now\n",
1068 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
1069 $egvsym = $egv->save;
1072 $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
1073 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS ),
1074 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS));
1075 $init->add(sprintf("GvLINE($sym) = %u;", $gv->LINE)) unless $is_empty;
1076 # XXX hack for when Perl accesses PVX of GVs
1077 $init->add("SvPVX($sym) = emptystring;\n");
1078 # Shouldn't need to do save_magic since gv_fetchpv handles that
1080 # XXX will always be > 1!!!
1081 my $refcnt = $gv->REFCNT + 1;
1082 $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1 )) if $refcnt > 1;
1084 return $sym if $is_empty;
1086 # XXX B::walksymtable creates an extra reference to the GV
1087 my $gvrefcnt = $gv->GvREFCNT;
1088 if ($gvrefcnt > 1) {
1089 $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
1091 # some non-alphavetic globs require some parts to be saved
1092 # ( ex. %!, but not $! )
1097 sub Save_FORM() { 16 }
1098 sub Save_IO() { 32 }
1100 if( $gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/ ) {
1101 $savefields = Save_HV|Save_AV|Save_SV|Save_CV|Save_FORM|Save_IO;
1103 elsif( $gvname eq '!' ) {
1104 $savefields = Save_HV;
1106 # attributes::bootstrap is created in perl_parse
1107 # saving it would overwrite it, because perl_init() is
1108 # called after perl_parse()
1109 $savefields&=~Save_CV if $fullname eq 'attributes::bootstrap';
1112 # XXX is that correct?
1113 if (defined($egvsym) && $egvsym !~ m/Null/ ) {
1114 # Shared glob *foo = *bar
1115 $init->add("gp_free($sym);",
1116 "GvGP($sym) = GvGP($egvsym);");
1117 } elsif ($savefields) {
1118 # Don't save subfields of special GVs (*_, *1, *# and so on)
1119 # warn "GV::save saving subfields\n"; # debug
1121 if ($$gvsv && $savefields&Save_SV) {
1123 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
1124 # warn "GV::save \$$name\n"; # debug
1127 if ($$gvav && $savefields&Save_AV) {
1129 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
1130 # warn "GV::save \@$name\n"; # debug
1133 if ($$gvhv && $savefields&Save_HV) {
1135 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
1136 # warn "GV::save \%$name\n"; # debug
1139 if ($$gvcv && $savefields&Save_CV) {
1140 my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
1141 "::" . $gvcv->GV->EGV->NAME);
1142 if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias
1143 # must save as a 'stub' so newXS() has a CV to populate
1144 $init->add("{ CV *cv;");
1145 $init->add("\tcv=perl_get_cv($origname,TRUE);");
1146 $init->add("\tGvCV($sym)=cv;");
1147 $init->add("\tSvREFCNT_inc((SV *)cv);");
1150 $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
1151 # warn "GV::save &$name\n"; # debug
1154 $init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE)));
1155 # warn "GV::save GvFILE(*$name)\n"; # debug
1156 my $gvform = $gv->FORM;
1157 if ($$gvform && $savefields&Save_FORM) {
1159 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
1160 # warn "GV::save GvFORM(*$name)\n"; # debug
1163 if ($$gvio && $savefields&Save_IO) {
1165 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
1166 if( $fullname =~ m/::DATA$/ && $save_data_fh ) {
1168 my $fh = *{$fullname}{IO};
1170 $gvio->save_data( $fullname, <$fh> ) if $fh->opened;
1172 # warn "GV::save GvIO(*$name)\n"; # debug
1180 my $sym = objsym($av);
1181 return $sym if defined $sym;
1182 my $avflags = $av->AvFLAGS;
1183 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
1185 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
1186 $xpvavsect->index, $av->REFCNT , $av->FLAGS));
1187 my $sv_list_index = $svsect->index;
1188 my $fill = $av->FILL;
1190 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
1192 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
1193 #if ($fill > -1 && ($avflags & AVf_REAL)) {
1195 my @array = $av->ARRAY;
1199 foreach $el (@array) {
1200 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
1201 $$av, $i++, class($el), $$el);
1204 # my @names = map($_->save, @array);
1205 # XXX Better ways to write loop?
1206 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
1207 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
1209 # micro optimization: op/pat.t ( and other code probably )
1210 # has very large pads ( 20k/30k elements ) passing them to
1211 # ->add is a performance bottleneck: passing them as a
1212 # single string cuts runtime from 6min20sec to 40sec
1214 # you want to keep this out of the no_split/split
1215 # map("\t*svp++ = (SV*)$_;", @names),
1217 foreach my $i ( 0..$#array ) {
1218 $acc .= "\t*svp++ = (SV*)" . $array[$i]->save . ";\n\t";
1225 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
1226 "\tav_extend(av, $fill);",
1227 "\tsvp = AvARRAY(av);" );
1229 $init->add("\tAvFILLp(av) = $fill;",
1232 # we really added a lot of lines ( B::C::InitSection->add
1233 # should really scan for \n, but that would slow
1235 $init->inc_count( $#array );
1238 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
1241 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
1246 my $sym = objsym($hv);
1247 return $sym if defined $sym;
1248 my $name = $hv->NAME;
1252 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
1253 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
1254 # a trashed op but we look at the trashed op_type and segfault.
1255 #my $adpmroot = ${$hv->PMROOT};
1257 $decl->add("static HV *hv$hv_index;");
1258 # XXX Beware of weird package names containing double-quotes, \n, ...?
1259 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
1261 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
1264 $sym = savesym($hv, "hv$hv_index");
1268 # It's just an ordinary HV
1269 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
1270 $hv->MAX, $hv->RITER));
1271 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
1272 $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS));
1273 my $sv_list_index = $svsect->index;
1274 my @contents = $hv->ARRAY;
1277 for ($i = 1; $i < @contents; $i += 2) {
1278 $contents[$i] = $contents[$i]->save;
1281 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
1283 my ($key, $value) = splice(@contents, 0, 2);
1284 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
1285 cstring($key),length(pack "a*",$key),
1286 $value, hash($key)));
1287 # $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
1288 # cstring($key),length($key),$value, 0));
1294 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
1297 sub B::IO::save_data {
1298 my( $io, $globname, @data ) = @_;
1299 my $data = join '', @data;
1301 # XXX using $DATA might clobber it!
1302 my $sym = svref_2object( \\$data )->save;
1303 $init->add( split /\n/, <<CODE );
1305 GV* gv = (GV*)gv_fetchpv( "$globname", TRUE, SVt_PV );
1310 # for PerlIO::scalar
1312 $init->add_eval( sprintf 'open(%s, "<", $%s)', $globname, $globname );
1317 my $sym = objsym($io);
1318 return $sym if defined $sym;
1320 $pv = '' unless defined $pv;
1321 my $len = length($pv);
1322 $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",
1323 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
1324 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
1325 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
1326 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
1327 cchar($io->IoTYPE), $io->IoFLAGS));
1328 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
1329 $xpviosect->index, $io->REFCNT , $io->FLAGS));
1330 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
1331 # deal with $x = *STDIN/STDOUT/STDERR{IO}
1333 foreach ( qw(stdin stdout stderr) ) {
1334 $io->IsSTD($_) and $perlio_func = $_;
1336 if( $perlio_func ) {
1337 $init->add( "IoIFP(${sym})=PerlIO_${perlio_func}();" );
1338 $init->add( "IoOFP(${sym})=PerlIO_${perlio_func}();" );
1342 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
1343 $fsym = $io->$field();
1345 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
1355 # This is where we catch an honest-to-goodness Nullsv (which gets
1356 # blessed into B::SV explicitly) and any stray erroneous SVs.
1357 return 0 unless $$sv;
1358 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
1363 my $init_name = shift;
1365 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
1366 $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect,
1367 $loopsect, $copsect, $svsect, $xpvsect,
1368 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
1369 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
1370 $symsect->output(\*STDOUT, "#define %s\n");
1372 output_declarations();
1373 foreach $section (@sections) {
1374 my $lines = $section->index + 1;
1376 my $name = $section->name;
1377 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
1378 print "Static $typename ${name}_list[$lines];\n";
1381 # XXX hack for when Perl accesses PVX of GVs
1382 print 'Static char emptystring[] = "\0";';
1384 $decl->output(\*STDOUT, "%s\n");
1386 foreach $section (@sections) {
1387 my $lines = $section->index + 1;
1389 my $name = $section->name;
1390 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
1391 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
1392 $section->output(\*STDOUT, "\t{ %s }, /* %d */\n");
1397 $init->output(\*STDOUT, "\t%s\n", $init_name );
1399 warn compile_stats();
1400 warn "NULLOP count: $nullop_count\n";
1404 sub output_declarations {
1406 #ifdef BROKEN_STATIC_REDECL
1407 #define Static extern
1409 #define Static static
1410 #endif /* BROKEN_STATIC_REDECL */
1412 #ifdef BROKEN_UNION_INIT
1414 * Cribbed from cv.h with ANY (a union) replaced by void*.
1415 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
1418 char * xpv_pv; /* pointer to malloced string */
1419 STRLEN xpv_cur; /* length of xp_pv as a C string */
1420 STRLEN xpv_len; /* allocated size */
1421 IV xof_off; /* integer value */
1422 NV xnv_nv; /* numeric value, if any */
1423 MAGIC* xmg_magic; /* magic for scalar array */
1424 HV* xmg_stash; /* class package */
1429 void (*xcv_xsub) (pTHX_ CV*);
1433 long xcv_depth; /* >= 2 indicates recursive call */
1436 cv_flags_t xcv_flags;
1437 U32 xcv_outside_seq; /* the COP sequence (at the point of our
1438 * compilation) in the lexically enclosing
1441 #define ANYINIT(i) i
1443 #define XPVCV_or_similar XPVCV
1444 #define ANYINIT(i) {i}
1445 #endif /* BROKEN_UNION_INIT */
1446 #define Nullany ANYINIT(0)
1451 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1456 sub output_boilerplate {
1462 /* Workaround for mapstart: the only op which needs a different ppaddr */
1463 #undef Perl_pp_mapstart
1464 #define Perl_pp_mapstart Perl_pp_grepstart
1466 #define OP_MAPSTART OP_GREPSTART
1467 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1468 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
1470 static void xs_init (pTHX);
1471 static void dl_init (pTHX);
1472 static PerlInterpreter *my_perl;
1477 my( $op_type, $num ) = @_;
1478 my $op_list = $op_type."_list";
1480 $init->add( split /\n/, <<EOT );
1484 for( i = 0; i < ${num}; ++i )
1486 ${op_list}\[i].op_ppaddr = PL_ppaddr[INT2PTR(int,${op_list}\[i].op_ppaddr)];
1493 my( $op_type, $num ) = @_;
1494 my $op_list = $op_type."_list";
1496 # for resons beyond imagination, MSVC5 considers pWARN_ALL non-const
1497 $init->add( split /\n/, <<EOT );
1501 for( i = 0; i < ${num}; ++i )
1503 switch( (int)(${op_list}\[i].cop_warnings) )
1506 ${op_list}\[i].cop_warnings = pWARN_ALL;
1509 ${op_list}\[i].cop_warnings = pWARN_NONE;
1512 ${op_list}\[i].cop_warnings = pWARN_STD;
1524 /* if USE_IMPLICIT_SYS, we need a 'real' exit */
1530 main(int argc, char **argv, char **env)
1539 PERL_SYS_INIT3(&argc,&argv,&env);
1541 if (!PL_do_undump) {
1542 my_perl = perl_alloc();
1545 perl_construct( my_perl );
1546 PL_perl_destruct_level = 0;
1550 # XXX init free elems!
1551 my $pad_len = regex_padav->FILL + 1 - 1; # first is an avref
1555 for( i = 0; i < $pad_len; ++i ) {
1556 av_push( PL_regex_padav, newSViv(0) );
1558 PL_regex_pad = AvARRAY( PL_regex_padav );
1566 PL_cshlen = strlen(PL_cshname);
1569 #ifdef ALLOW_PERL_OPTIONS
1570 #define EXTRA_OPTIONS 3
1572 #define EXTRA_OPTIONS 4
1573 #endif /* ALLOW_PERL_OPTIONS */
1574 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1576 fakeargv[0] = argv[0];
1584 fakeargv[options_count] = "-T";
1589 #ifndef ALLOW_PERL_OPTIONS
1590 fakeargv[options_count] = "--";
1592 #endif /* ALLOW_PERL_OPTIONS */
1593 for (i = 1; i < argc; i++)
1594 fakeargv[i + options_count - 1] = argv[i];
1595 fakeargv[argc + options_count - 1] = 0;
1597 exitstatus = perl_parse(my_perl, xs_init, argc + options_count - 1,
1606 if( $use_perl_script_name ) {
1608 $dollar_0 =~ s/\\/\\\\/g;
1609 $dollar_0 = '"' . $dollar_0 . '"';
1612 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */
1613 tmpsv = GvSV(tmpgv);
1614 sv_setpv(tmpsv, ${dollar_0});
1621 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */
1622 tmpsv = GvSV(tmpgv);
1623 sv_setpv(tmpsv, argv[0]);
1630 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
1631 tmpsv = GvSV(tmpgv);
1633 sv_setpv(tmpsv,"perl.exe");
1635 sv_setpv(tmpsv,"perl");
1642 /* PL_main_cv = PL_compcv; */
1645 exitstatus = perl_init();
1650 exitstatus = perl_run( my_perl );
1652 perl_destruct( my_perl );
1653 perl_free( my_perl );
1660 /* yanked from perl.c */
1664 char *file = __FILE__;
1668 print "\n#ifdef USE_DYNAMIC_LOADING";
1669 print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1670 print "\n#endif\n" ;
1671 # delete $xsub{'DynaLoader'};
1672 delete $xsub{'UNIVERSAL'};
1673 print("/* bootstrapping code*/\n\tSAVETMPS;\n");
1674 print("\ttarg=sv_newmortal();\n");
1675 print "#ifdef USE_DYNAMIC_LOADING\n";
1676 print "\tPUSHMARK(sp);\n";
1677 print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
1678 print qq/\tPUTBACK;\n/;
1679 print "\tboot_DynaLoader(aTHX_ NULL);\n";
1680 print qq/\tSPAGAIN;\n/;
1682 foreach my $stashname (keys %xsub){
1683 if ($xsub{$stashname} !~ m/Dynamic/ ) {
1684 my $stashxsub=$stashname;
1685 $stashxsub =~ s/::/__/g;
1686 print "\tPUSHMARK(sp);\n";
1687 print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
1688 print qq/\tPUTBACK;\n/;
1689 print "\tboot_$stashxsub(aTHX_ NULL);\n";
1690 print qq/\tSPAGAIN;\n/;
1693 print("\tFREETMPS;\n/* end bootstrapping code */\n");
1700 char *file = __FILE__;
1704 print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
1705 print("\ttarg=sv_newmortal();\n");
1706 foreach my $stashname (@DynaLoader::dl_modules) {
1707 warn "Loaded $stashname\n";
1708 if (exists($xsub{$stashname}) && $xsub{$stashname} =~ m/Dynamic/) {
1709 my $stashxsub=$stashname;
1710 $stashxsub =~ s/::/__/g;
1711 print "\tPUSHMARK(sp);\n";
1712 print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
1713 print qq/\tPUTBACK;\n/;
1714 print "#ifdef USE_DYNAMIC_LOADING\n";
1715 warn "bootstrapping $stashname added to xs_init\n";
1716 if( $xsub{$stashname} eq 'Dynamic' ) {
1717 print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
1720 print qq/\tperl_call_pv("XSLoader::load",G_DISCARD);\n/;
1723 print "\tboot_$stashxsub(aTHX_ NULL);\n";
1725 print qq/\tSPAGAIN;\n/;
1728 print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
1734 warn "----Symbol table:\n";
1735 while (($sym, $val) = each %symtable) {
1736 warn "$sym => $val\n";
1738 warn "---End of symbol table\n";
1744 svref_2object($sv)->save;
1748 sub Dummy_BootStrap { }
1753 my $package=$gv->STASH->NAME;
1754 my $name = $gv->NAME;
1760 my $fullname = $gv->STASH->NAME . "::" . $gv->NAME;
1762 # We may be looking at this package just because it is a branch in the
1763 # symbol table which is on the path to a package which we need to save
1764 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1766 return unless ($unused_sub_packages{$package});
1767 return unless ($$cv || $$av || $$sv || $$hv);
1773 my $package = shift;
1774 unless ($unused_sub_packages{$package})
1777 $unused_sub_packages{$package} = 1;
1778 if (defined @{$package.'::ISA'})
1780 foreach my $isa (@{$package.'::ISA'})
1782 if ($isa eq 'DynaLoader')
1784 unless (defined(&{$package.'::bootstrap'}))
1786 warn "Forcing bootstrap of $package\n";
1787 eval { $package->bootstrap };
1792 unless ($unused_sub_packages{$isa})
1794 warn "$isa saved (it is in $package\'s \@ISA)\n";
1806 no strict qw(vars refs);
1807 my $package = shift;
1808 $package =~ s/::$//;
1809 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1810 # warn "Considering $package\n";#debug
1811 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1813 # If this package is a prefix to something we are saving, traverse it
1814 # but do not mark it for saving if it is not already
1815 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1817 return 1 if ($u =~ /^$package\:\:/);
1819 if (exists $unused_sub_packages{$package})
1821 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1822 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1823 return $unused_sub_packages{$package};
1825 # Omit the packages which we use (and which cause grief
1826 # because of fancy "goto &$AUTOLOAD" stuff).
1827 # XXX Surely there must be a nicer way to do this.
1828 if ($package eq "FileHandle" || $package eq "Config" ||
1829 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1831 delete_unsaved_hashINC($package);
1832 return $unused_sub_packages{$package} = 0;
1834 # Now see if current package looks like an OO class this is probably too strong.
1835 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1837 if (UNIVERSAL::can($package, $m))
1839 warn "$package has method $m: saving package\n";#debug
1840 return mark_package($package);
1843 delete_unsaved_hashINC($package);
1844 return $unused_sub_packages{$package} = 0;
1846 sub delete_unsaved_hashINC{
1848 $packname =~ s/\:\:/\//g;
1850 # warn "deleting $packname" if $INC{$packname} ;# debug
1851 delete $INC{$packname};
1855 my ($symref, $recurse, $prefix) = @_;
1859 $prefix = '' unless defined $prefix;
1860 while (($sym, $ref) = each %$symref)
1866 $sym = $prefix . $sym;
1867 if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym))
1869 walkpackages(\%glob, $recurse, $sym);
1876 sub save_unused_subs
1879 &descend_marked_unused;
1881 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1882 warn "Saving methods\n";
1883 walksymtable(\%{"main::"}, "savecv", \&should_save);
1888 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1889 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1890 my $inc_hv = svref_2object(\%INC)->save;
1891 my $inc_av = svref_2object(\@INC)->save;
1892 my $amagic_generate= amagic_generation;
1893 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1894 "GvHV(PL_incgv) = $inc_hv;",
1895 "GvAV(PL_incgv) = $inc_av;",
1896 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1897 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1898 "PL_amagic_generation= $amagic_generate;" );
1901 sub descend_marked_unused {
1902 foreach my $pack (keys %unused_sub_packages)
1904 mark_package($pack);
1909 # this is mainly for the test suite
1910 my $warner = $SIG{__WARN__};
1911 local $SIG{__WARN__} = sub { print STDERR @_ };
1913 warn "Starting compile\n";
1914 warn "Walking tree\n";
1915 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1916 walkoptree(main_root, "save");
1917 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1919 # XSLoader was used, force saving of XSLoader::load
1920 if( $use_xsloader ) {
1921 my $cv = svref_2object( \&XSLoader::load );
1924 # save %SIG ( in case it was set in a BEGIN block )
1926 local $SIG{__WARN__} = $warner;
1928 $init->add("{", "\tHV* hv = get_hv(\"main::SIG\",1);" );
1929 foreach my $k ( keys %SIG ) {
1930 next unless ref $SIG{$k};
1931 my $cv = svref_2object( \$SIG{$k} );
1933 $init->add('{',sprintf 'SV* sv = (SV*)%s;', $sv );
1934 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
1935 cstring($k),length(pack "a*",$k),
1937 $init->add('mg_set(sv);','}');
1943 $init->add( sprintf " PL_dowarn = ( %s ) ? G_WARN_ON : G_WARN_OFF;", $^W );
1945 my $init_av = init_av->save;
1946 my $end_av = end_av->save;
1947 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1948 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1949 "PL_initav = (AV *) $init_av;",
1950 "PL_endav = (AV*) $end_av;");
1952 # init op addrs ( must be the last action, otherwise
1953 # some ops might not be initialized
1954 if( $optimize_ppaddr ) {
1955 foreach my $i ( @op_sections ) {
1957 next unless $section->index >= 0;
1958 init_op_addr( $section->name, $section->index + 1);
1961 init_op_warn( $copsect->name, $copsect->index + 1)
1962 if $optimize_warn_sv && $copsect->index >= 0;
1964 warn "Writing output\n";
1965 output_boilerplate();
1967 output_all("perl_init");
1973 my @sections = (decl => \$decl, sym => \$symsect,
1974 binop => \$binopsect, condop => \$condopsect,
1975 cop => \$copsect, padop => \$padopsect,
1976 listop => \$listopsect, logop => \$logopsect,
1977 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1978 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1979 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1980 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1981 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1982 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1983 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1984 xpvio => \$xpviosect);
1985 my ($name, $sectref);
1986 while (($name, $sectref) = splice(@sections, 0, 2)) {
1987 $$sectref = new B::C::Section $name, \%symtable, 0;
1989 $init = new B::C::InitSection 'init', \%symtable, 0;
1994 my ($arg,$val) = @_;
1995 $unused_sub_packages{$arg} = $val;
2000 my ($option, $opt, $arg);
2001 my @eval_at_startup;
2002 my %option_map = ( 'cog' => \$pv_copy_on_grow,
2003 'save-data' => \$save_data_fh,
2004 'ppaddr' => \$optimize_ppaddr,
2005 'warn-sv' => \$optimize_warn_sv,
2006 'use-script-name' => \$use_perl_script_name,
2007 'save-sig-hash' => \$save_sig,
2009 my %optimization_map = ( 0 => [ qw() ], # special case
2011 2 => [ qw(-fwarn-sv -fppaddr) ],
2014 while ($option = shift @options) {
2015 if ($option =~ /^-(.)(.*)/) {
2019 unshift @options, $option;
2022 if ($opt eq "-" && $arg eq "-") {
2027 $warn_undefined_syms = 1;
2028 } elsif ($opt eq "D") {
2029 $arg ||= shift @options;
2030 foreach $arg (split(//, $arg)) {
2033 } elsif ($arg eq "c") {
2035 } elsif ($arg eq "A") {
2037 } elsif ($arg eq "C") {
2039 } elsif ($arg eq "M") {
2042 warn "ignoring unknown debug option: $arg\n";
2045 } elsif ($opt eq "o") {
2046 $arg ||= shift @options;
2047 open(STDOUT, ">$arg") or return "$arg: $!\n";
2048 } elsif ($opt eq "v") {
2050 } elsif ($opt eq "u") {
2051 $arg ||= shift @options;
2052 mark_unused($arg,undef);
2053 } elsif ($opt eq "f") {
2054 $arg ||= shift @options;
2055 $arg =~ m/(no-)?(.*)/;
2056 my $no = defined($1) && $1 eq 'no-';
2057 $arg = $no ? $2 : $arg;
2058 if( exists $option_map{$arg} ) {
2059 ${$option_map{$arg}} = !$no;
2061 die "Invalid optimization '$arg'";
2063 } elsif ($opt eq "O") {
2064 $arg = 1 if $arg eq "";
2066 foreach my $i ( 1 .. $arg ) {
2067 push @opt, @{$optimization_map{$i}}
2068 if exists $optimization_map{$i};
2070 unshift @options, @opt;
2071 } elsif ($opt eq "e") {
2072 push @eval_at_startup, $arg;
2073 } elsif ($opt eq "l") {
2074 $max_string_len = $arg;
2078 foreach my $i ( @eval_at_startup ) {
2079 $init->add_eval( $i );
2084 foreach $objname (@options) {
2085 eval "save_object(\\$objname)";
2090 return sub { save_main() };
2100 B::C - Perl compiler's C backend
2104 perl -MO=C[,OPTIONS] foo.pl
2108 This compiler backend takes Perl source and generates C source code
2109 corresponding to the internal structures that perl uses to run
2110 your program. When the generated C source is compiled and run, it
2111 cuts out the time which perl would have taken to load and parse
2112 your program into its internal semi-compiled form. That means that
2113 compiling with this backend will not help improve the runtime
2114 execution speed of your program but may improve the start-up time.
2115 Depending on the environment in which your program runs this may be
2116 either a help or a hindrance.
2120 If there are any non-option arguments, they are taken to be
2121 names of objects to be saved (probably doesn't work properly yet).
2122 Without extra arguments, it saves the main program.
2128 Output to filename instead of STDOUT
2132 Verbose compilation (currently gives a few compilation statistics).
2136 Force end of options
2140 Force apparently unused subs from package Packname to be compiled.
2141 This allows programs to use eval "foo()" even when sub foo is never
2142 seen to be used at compile time. The down side is that any subs which
2143 really are never used also have code generated. This option is
2144 necessary, for example, if you have a signal handler foo which you
2145 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
2146 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
2147 options. The compiler tries to figure out which packages may possibly
2148 have subs in which need compiling but the current version doesn't do
2149 it very well. In particular, it is confused by nested packages (i.e.
2150 of the form C<A::B>) where package C<A> does not contain any subs.
2154 Debug options (concatenated or separate flags like C<perl -D>).
2158 OPs, prints each OP as it's processed
2162 COPs, prints COPs as processed (incl. file & line num)
2166 prints AV information on saving
2170 prints CV information on saving
2174 prints MAGIC information on saving
2178 Force options/optimisations on or off one at a time. You can explicitly
2179 disable an option using B<-fno-option>. All options default to
2186 Copy-on-grow: PVs declared and initialised statically.
2188 =item B<-fsave-data>
2190 Save package::DATA filehandles ( only available with PerlIO ).
2194 Optimize the initialization of op_ppaddr.
2198 Optimize the initialization of cop_warnings.
2200 =item B<-fuse-script-name>
2202 Use the script name instead of the program name as $0.
2204 =item B<-fsave-sig-hash>
2206 Save compile-time modifications to the %SIG hash.
2212 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
2218 Disable all optimizations.
2226 Enable B<-fppaddr>, B<-fwarn-sv>.
2232 Some C compilers impose an arbitrary limit on the length of string
2233 constants (e.g. 2048 characters for Microsoft Visual C++). The
2234 B<-llimit> options tells the C backend not to generate string literals
2235 exceeding that limit.
2241 perl -MO=C,-ofoo.c foo.pl
2242 perl cc_harness -o foo foo.c
2244 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
2245 library directory. The utility called C<perlcc> may also be used to
2246 help make use of this compiler.
2248 perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null
2252 Plenty. Current status: experimental.
2256 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>