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",
1016 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
1017 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
1018 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
1020 if (${$cv->OUTSIDE} == ${main_cv()}){
1021 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
1022 $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
1027 $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
1028 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
1029 $$gv, $$cv) if $debug_cv;
1032 $init->add( savepvn( "CvFILE($sym)", $cv->FILE) );
1035 $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE)));
1037 my $stash = $cv->STASH;
1040 $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
1041 warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
1042 $$stash, $$cv) if $debug_cv;
1044 $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
1045 $sv_ix, $xpvcv_ix, $cv->REFCNT +1*0 , $cv->FLAGS));
1051 my $sym = objsym($gv);
1052 if (defined($sym)) {
1053 #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
1056 my $ix = $gv_index++;
1057 $sym = savesym($gv, "gv_list[$ix]");
1058 #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
1060 my $is_empty = $gv->is_empty;
1061 my $gvname = $gv->NAME;
1062 my $fullname = $gv->STASH->NAME . "::" . $gvname;
1063 my $name = cstring($fullname);
1064 #warn "GV name is $name\n"; # debug
1066 unless ($is_empty) {
1068 if ($$gv != $$egv) {
1069 #warn(sprintf("EGV name is %s, saving it now\n",
1070 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
1071 $egvsym = $egv->save;
1074 $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
1075 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS ),
1076 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS));
1077 $init->add(sprintf("GvLINE($sym) = %u;", $gv->LINE)) unless $is_empty;
1078 # XXX hack for when Perl accesses PVX of GVs
1079 $init->add("SvPVX($sym) = emptystring;\n");
1080 # Shouldn't need to do save_magic since gv_fetchpv handles that
1082 # XXX will always be > 1!!!
1083 my $refcnt = $gv->REFCNT + 1;
1084 $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1 )) if $refcnt > 1;
1086 return $sym if $is_empty;
1088 # XXX B::walksymtable creates an extra reference to the GV
1089 my $gvrefcnt = $gv->GvREFCNT;
1090 if ($gvrefcnt > 1) {
1091 $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
1093 # some non-alphavetic globs require some parts to be saved
1094 # ( ex. %!, but not $! )
1099 sub Save_FORM() { 16 }
1100 sub Save_IO() { 32 }
1102 if( $gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/ ) {
1103 $savefields = Save_HV|Save_AV|Save_SV|Save_CV|Save_FORM|Save_IO;
1105 elsif( $gvname eq '!' ) {
1106 $savefields = Save_HV;
1108 # attributes::bootstrap is created in perl_parse
1109 # saving it would overwrite it, because perl_init() is
1110 # called after perl_parse()
1111 $savefields&=~Save_CV if $fullname eq 'attributes::bootstrap';
1114 # XXX is that correct?
1115 if (defined($egvsym) && $egvsym !~ m/Null/ ) {
1116 # Shared glob *foo = *bar
1117 $init->add("gp_free($sym);",
1118 "GvGP($sym) = GvGP($egvsym);");
1119 } elsif ($savefields) {
1120 # Don't save subfields of special GVs (*_, *1, *# and so on)
1121 # warn "GV::save saving subfields\n"; # debug
1123 if ($$gvsv && $savefields&Save_SV) {
1125 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
1126 # warn "GV::save \$$name\n"; # debug
1129 if ($$gvav && $savefields&Save_AV) {
1131 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
1132 # warn "GV::save \@$name\n"; # debug
1135 if ($$gvhv && $savefields&Save_HV) {
1137 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
1138 # warn "GV::save \%$name\n"; # debug
1141 if ($$gvcv && $savefields&Save_CV) {
1142 my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
1143 "::" . $gvcv->GV->EGV->NAME);
1144 if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias
1145 # must save as a 'stub' so newXS() has a CV to populate
1146 $init->add("{ CV *cv;");
1147 $init->add("\tcv=perl_get_cv($origname,TRUE);");
1148 $init->add("\tGvCV($sym)=cv;");
1149 $init->add("\tSvREFCNT_inc((SV *)cv);");
1152 $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
1153 # warn "GV::save &$name\n"; # debug
1156 $init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE)));
1157 # warn "GV::save GvFILE(*$name)\n"; # debug
1158 my $gvform = $gv->FORM;
1159 if ($$gvform && $savefields&Save_FORM) {
1161 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
1162 # warn "GV::save GvFORM(*$name)\n"; # debug
1165 if ($$gvio && $savefields&Save_IO) {
1167 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
1168 if( $fullname =~ m/::DATA$/ && $save_data_fh ) {
1170 my $fh = *{$fullname}{IO};
1172 $gvio->save_data( $fullname, <$fh> ) if $fh->opened;
1174 # warn "GV::save GvIO(*$name)\n"; # debug
1182 my $sym = objsym($av);
1183 return $sym if defined $sym;
1184 my $avflags = $av->AvFLAGS;
1185 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
1187 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
1188 $xpvavsect->index, $av->REFCNT , $av->FLAGS));
1189 my $sv_list_index = $svsect->index;
1190 my $fill = $av->FILL;
1192 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
1194 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
1195 #if ($fill > -1 && ($avflags & AVf_REAL)) {
1197 my @array = $av->ARRAY;
1201 foreach $el (@array) {
1202 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
1203 $$av, $i++, class($el), $$el);
1206 # my @names = map($_->save, @array);
1207 # XXX Better ways to write loop?
1208 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
1209 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
1211 # micro optimization: op/pat.t ( and other code probably )
1212 # has very large pads ( 20k/30k elements ) passing them to
1213 # ->add is a performance bottleneck: passing them as a
1214 # single string cuts runtime from 6min20sec to 40sec
1216 # you want to keep this out of the no_split/split
1217 # map("\t*svp++ = (SV*)$_;", @names),
1219 foreach my $i ( 0..$#array ) {
1220 $acc .= "\t*svp++ = (SV*)" . $array[$i]->save . ";\n\t";
1227 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
1228 "\tav_extend(av, $fill);",
1229 "\tsvp = AvARRAY(av);" );
1231 $init->add("\tAvFILLp(av) = $fill;",
1234 # we really added a lot of lines ( B::C::InitSection->add
1235 # should really scan for \n, but that would slow
1237 $init->inc_count( $#array );
1240 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
1243 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
1248 my $sym = objsym($hv);
1249 return $sym if defined $sym;
1250 my $name = $hv->NAME;
1254 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
1255 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
1256 # a trashed op but we look at the trashed op_type and segfault.
1257 #my $adpmroot = ${$hv->PMROOT};
1259 $decl->add("static HV *hv$hv_index;");
1260 # XXX Beware of weird package names containing double-quotes, \n, ...?
1261 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
1263 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
1266 $sym = savesym($hv, "hv$hv_index");
1270 # It's just an ordinary HV
1271 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
1272 $hv->MAX, $hv->RITER));
1273 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
1274 $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS));
1275 my $sv_list_index = $svsect->index;
1276 my @contents = $hv->ARRAY;
1279 for ($i = 1; $i < @contents; $i += 2) {
1280 $contents[$i] = $contents[$i]->save;
1283 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
1285 my ($key, $value) = splice(@contents, 0, 2);
1286 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
1287 cstring($key),length(pack "a*",$key),
1288 $value, hash($key)));
1289 # $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
1290 # cstring($key),length($key),$value, 0));
1296 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
1299 sub B::IO::save_data {
1300 my( $io, $globname, @data ) = @_;
1301 my $data = join '', @data;
1303 # XXX using $DATA might clobber it!
1304 my $sym = svref_2object( \\$data )->save;
1305 $init->add( split /\n/, <<CODE );
1307 GV* gv = (GV*)gv_fetchpv( "$globname", TRUE, SVt_PV );
1312 # for PerlIO::scalar
1314 $init->add_eval( sprintf 'open(%s, "<", $%s)', $globname, $globname );
1319 my $sym = objsym($io);
1320 return $sym if defined $sym;
1322 $pv = '' unless defined $pv;
1323 my $len = length($pv);
1324 $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",
1325 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
1326 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
1327 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
1328 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
1329 cchar($io->IoTYPE), $io->IoFLAGS));
1330 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
1331 $xpviosect->index, $io->REFCNT , $io->FLAGS));
1332 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
1333 # deal with $x = *STDIN/STDOUT/STDERR{IO}
1335 foreach ( qw(stdin stdout stderr) ) {
1336 $io->IsSTD($_) and $perlio_func = $_;
1338 if( $perlio_func ) {
1339 $init->add( "IoIFP(${sym})=PerlIO_${perlio_func}();" );
1340 $init->add( "IoOFP(${sym})=PerlIO_${perlio_func}();" );
1344 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
1345 $fsym = $io->$field();
1347 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
1357 # This is where we catch an honest-to-goodness Nullsv (which gets
1358 # blessed into B::SV explicitly) and any stray erroneous SVs.
1359 return 0 unless $$sv;
1360 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
1365 my $init_name = shift;
1367 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
1368 $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect,
1369 $loopsect, $copsect, $svsect, $xpvsect,
1370 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
1371 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
1372 $symsect->output(\*STDOUT, "#define %s\n");
1374 output_declarations();
1375 foreach $section (@sections) {
1376 my $lines = $section->index + 1;
1378 my $name = $section->name;
1379 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
1380 print "Static $typename ${name}_list[$lines];\n";
1383 # XXX hack for when Perl accesses PVX of GVs
1384 print 'Static char emptystring[] = "\0";';
1386 $decl->output(\*STDOUT, "%s\n");
1388 foreach $section (@sections) {
1389 my $lines = $section->index + 1;
1391 my $name = $section->name;
1392 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
1393 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
1394 $section->output(\*STDOUT, "\t{ %s }, /* %d */\n");
1399 $init->output(\*STDOUT, "\t%s\n", $init_name );
1401 warn compile_stats();
1402 warn "NULLOP count: $nullop_count\n";
1406 sub output_declarations {
1408 #ifdef BROKEN_STATIC_REDECL
1409 #define Static extern
1411 #define Static static
1412 #endif /* BROKEN_STATIC_REDECL */
1414 #ifdef BROKEN_UNION_INIT
1416 * Cribbed from cv.h with ANY (a union) replaced by void*.
1417 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
1420 char * xpv_pv; /* pointer to malloced string */
1421 STRLEN xpv_cur; /* length of xp_pv as a C string */
1422 STRLEN xpv_len; /* allocated size */
1423 IV xof_off; /* integer value */
1424 NV xnv_nv; /* numeric value, if any */
1425 MAGIC* xmg_magic; /* magic for scalar array */
1426 HV* xmg_stash; /* class package */
1431 void (*xcv_xsub) (pTHX_ CV*);
1435 long xcv_depth; /* >= 2 indicates recursive call */
1438 cv_flags_t xcv_flags;
1440 #define ANYINIT(i) i
1442 #define XPVCV_or_similar XPVCV
1443 #define ANYINIT(i) {i}
1444 #endif /* BROKEN_UNION_INIT */
1445 #define Nullany ANYINIT(0)
1450 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1455 sub output_boilerplate {
1461 /* Workaround for mapstart: the only op which needs a different ppaddr */
1462 #undef Perl_pp_mapstart
1463 #define Perl_pp_mapstart Perl_pp_grepstart
1465 #define OP_MAPSTART OP_GREPSTART
1466 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1467 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
1469 static void xs_init (pTHX);
1470 static void dl_init (pTHX);
1471 static PerlInterpreter *my_perl;
1476 my( $op_type, $num ) = @_;
1477 my $op_list = $op_type."_list";
1479 $init->add( split /\n/, <<EOT );
1483 for( i = 0; i < ${num}; ++i )
1485 ${op_list}\[i].op_ppaddr = PL_ppaddr[INT2PTR(int,${op_list}\[i].op_ppaddr)];
1492 my( $op_type, $num ) = @_;
1493 my $op_list = $op_type."_list";
1495 # for resons beyond imagination, MSVC5 considers pWARN_ALL non-const
1496 $init->add( split /\n/, <<EOT );
1500 for( i = 0; i < ${num}; ++i )
1502 switch( (int)(${op_list}\[i].cop_warnings) )
1505 ${op_list}\[i].cop_warnings = pWARN_ALL;
1508 ${op_list}\[i].cop_warnings = pWARN_NONE;
1511 ${op_list}\[i].cop_warnings = pWARN_STD;
1523 /* if USE_IMPLICIT_SYS, we need a 'real' exit */
1529 main(int argc, char **argv, char **env)
1538 PERL_SYS_INIT3(&argc,&argv,&env);
1540 if (!PL_do_undump) {
1541 my_perl = perl_alloc();
1544 perl_construct( my_perl );
1545 PL_perl_destruct_level = 0;
1549 # XXX init free elems!
1550 my $pad_len = regex_padav->FILL + 1 - 1; # first is an avref
1554 for( i = 0; i < $pad_len; ++i ) {
1555 av_push( PL_regex_padav, newSViv(0) );
1557 PL_regex_pad = AvARRAY( PL_regex_padav );
1565 PL_cshlen = strlen(PL_cshname);
1568 #ifdef ALLOW_PERL_OPTIONS
1569 #define EXTRA_OPTIONS 3
1571 #define EXTRA_OPTIONS 4
1572 #endif /* ALLOW_PERL_OPTIONS */
1573 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1575 fakeargv[0] = argv[0];
1583 fakeargv[options_count] = "-T";
1588 #ifndef ALLOW_PERL_OPTIONS
1589 fakeargv[options_count] = "--";
1591 #endif /* ALLOW_PERL_OPTIONS */
1592 for (i = 1; i < argc; i++)
1593 fakeargv[i + options_count - 1] = argv[i];
1594 fakeargv[argc + options_count - 1] = 0;
1596 exitstatus = perl_parse(my_perl, xs_init, argc + options_count - 1,
1605 if( $use_perl_script_name ) {
1607 $dollar_0 =~ s/\\/\\\\/g;
1608 $dollar_0 = '"' . $dollar_0 . '"';
1611 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */
1612 tmpsv = GvSV(tmpgv);
1613 sv_setpv(tmpsv, ${dollar_0});
1620 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */
1621 tmpsv = GvSV(tmpgv);
1622 sv_setpv(tmpsv, argv[0]);
1629 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
1630 tmpsv = GvSV(tmpgv);
1632 sv_setpv(tmpsv,"perl.exe");
1634 sv_setpv(tmpsv,"perl");
1641 /* PL_main_cv = PL_compcv; */
1644 exitstatus = perl_init();
1649 exitstatus = perl_run( my_perl );
1651 perl_destruct( my_perl );
1652 perl_free( my_perl );
1659 /* yanked from perl.c */
1663 char *file = __FILE__;
1667 print "\n#ifdef USE_DYNAMIC_LOADING";
1668 print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1669 print "\n#endif\n" ;
1670 # delete $xsub{'DynaLoader'};
1671 delete $xsub{'UNIVERSAL'};
1672 print("/* bootstrapping code*/\n\tSAVETMPS;\n");
1673 print("\ttarg=sv_newmortal();\n");
1674 print "#ifdef USE_DYNAMIC_LOADING\n";
1675 print "\tPUSHMARK(sp);\n";
1676 print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
1677 print qq/\tPUTBACK;\n/;
1678 print "\tboot_DynaLoader(aTHX_ NULL);\n";
1679 print qq/\tSPAGAIN;\n/;
1681 foreach my $stashname (keys %xsub){
1682 if ($xsub{$stashname} !~ m/Dynamic/ ) {
1683 my $stashxsub=$stashname;
1684 $stashxsub =~ s/::/__/g;
1685 print "\tPUSHMARK(sp);\n";
1686 print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
1687 print qq/\tPUTBACK;\n/;
1688 print "\tboot_$stashxsub(aTHX_ NULL);\n";
1689 print qq/\tSPAGAIN;\n/;
1692 print("\tFREETMPS;\n/* end bootstrapping code */\n");
1699 char *file = __FILE__;
1703 print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
1704 print("\ttarg=sv_newmortal();\n");
1705 foreach my $stashname (@DynaLoader::dl_modules) {
1706 warn "Loaded $stashname\n";
1707 if (exists($xsub{$stashname}) && $xsub{$stashname} =~ m/Dynamic/) {
1708 my $stashxsub=$stashname;
1709 $stashxsub =~ s/::/__/g;
1710 print "\tPUSHMARK(sp);\n";
1711 print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
1712 print qq/\tPUTBACK;\n/;
1713 print "#ifdef USE_DYNAMIC_LOADING\n";
1714 warn "bootstrapping $stashname added to xs_init\n";
1715 if( $xsub{$stashname} eq 'Dynamic' ) {
1716 print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
1719 print qq/\tperl_call_pv("XSLoader::load",G_DISCARD);\n/;
1722 print "\tboot_$stashxsub(aTHX_ NULL);\n";
1724 print qq/\tSPAGAIN;\n/;
1727 print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
1733 warn "----Symbol table:\n";
1734 while (($sym, $val) = each %symtable) {
1735 warn "$sym => $val\n";
1737 warn "---End of symbol table\n";
1743 svref_2object($sv)->save;
1747 sub Dummy_BootStrap { }
1752 my $package=$gv->STASH->NAME;
1753 my $name = $gv->NAME;
1759 my $fullname = $gv->STASH->NAME . "::" . $gv->NAME;
1761 # We may be looking at this package just because it is a branch in the
1762 # symbol table which is on the path to a package which we need to save
1763 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1765 return unless ($unused_sub_packages{$package});
1766 return unless ($$cv || $$av || $$sv || $$hv);
1772 my $package = shift;
1773 unless ($unused_sub_packages{$package})
1776 $unused_sub_packages{$package} = 1;
1777 if (defined @{$package.'::ISA'})
1779 foreach my $isa (@{$package.'::ISA'})
1781 if ($isa eq 'DynaLoader')
1783 unless (defined(&{$package.'::bootstrap'}))
1785 warn "Forcing bootstrap of $package\n";
1786 eval { $package->bootstrap };
1791 unless ($unused_sub_packages{$isa})
1793 warn "$isa saved (it is in $package\'s \@ISA)\n";
1805 no strict qw(vars refs);
1806 my $package = shift;
1807 $package =~ s/::$//;
1808 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1809 # warn "Considering $package\n";#debug
1810 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1812 # If this package is a prefix to something we are saving, traverse it
1813 # but do not mark it for saving if it is not already
1814 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1816 return 1 if ($u =~ /^$package\:\:/);
1818 if (exists $unused_sub_packages{$package})
1820 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1821 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1822 return $unused_sub_packages{$package};
1824 # Omit the packages which we use (and which cause grief
1825 # because of fancy "goto &$AUTOLOAD" stuff).
1826 # XXX Surely there must be a nicer way to do this.
1827 if ($package eq "FileHandle" || $package eq "Config" ||
1828 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1830 delete_unsaved_hashINC($package);
1831 return $unused_sub_packages{$package} = 0;
1833 # Now see if current package looks like an OO class this is probably too strong.
1834 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1836 if (UNIVERSAL::can($package, $m))
1838 warn "$package has method $m: saving package\n";#debug
1839 return mark_package($package);
1842 delete_unsaved_hashINC($package);
1843 return $unused_sub_packages{$package} = 0;
1845 sub delete_unsaved_hashINC{
1847 $packname =~ s/\:\:/\//g;
1849 # warn "deleting $packname" if $INC{$packname} ;# debug
1850 delete $INC{$packname};
1854 my ($symref, $recurse, $prefix) = @_;
1859 $prefix = '' unless defined $prefix;
1860 while (($sym, $ref) = each %$symref)
1865 $sym = $prefix . $sym;
1866 if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym))
1868 walkpackages(\%glob, $recurse, $sym);
1875 sub save_unused_subs
1878 &descend_marked_unused;
1880 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1881 warn "Saving methods\n";
1882 walksymtable(\%{"main::"}, "savecv", \&should_save);
1887 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1888 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1889 my $inc_hv = svref_2object(\%INC)->save;
1890 my $inc_av = svref_2object(\@INC)->save;
1891 my $amagic_generate= amagic_generation;
1892 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1893 "GvHV(PL_incgv) = $inc_hv;",
1894 "GvAV(PL_incgv) = $inc_av;",
1895 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1896 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1897 "PL_amagic_generation= $amagic_generate;" );
1900 sub descend_marked_unused {
1901 foreach my $pack (keys %unused_sub_packages)
1903 mark_package($pack);
1908 # this is mainly for the test suite
1909 my $warner = $SIG{__WARN__};
1910 local $SIG{__WARN__} = sub { print STDERR @_ };
1912 warn "Starting compile\n";
1913 warn "Walking tree\n";
1914 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1915 walkoptree(main_root, "save");
1916 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1918 # XSLoader was used, force saving of XSLoader::load
1919 if( $use_xsloader ) {
1920 my $cv = svref_2object( \&XSLoader::load );
1923 # save %SIG ( in case it was set in a BEGIN block )
1925 local $SIG{__WARN__} = $warner;
1927 $init->add("{", "\tHV* hv = get_hv(\"main::SIG\",1);" );
1928 foreach my $k ( keys %SIG ) {
1929 next unless ref $SIG{$k};
1930 my $cv = svref_2object( \$SIG{$k} );
1932 $init->add('{',sprintf 'SV* sv = (SV*)%s;', $sv );
1933 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
1934 cstring($k),length(pack "a*",$k),
1936 $init->add('mg_set(sv);','}');
1942 $init->add( sprintf " PL_dowarn = ( %s ) ? G_WARN_ON : G_WARN_OFF;", $^W );
1944 my $init_av = init_av->save;
1945 my $end_av = end_av->save;
1946 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1947 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1948 "PL_initav = (AV *) $init_av;",
1949 "PL_endav = (AV*) $end_av;");
1951 # init op addrs ( must be the last action, otherwise
1952 # some ops might not be initialized
1953 if( $optimize_ppaddr ) {
1954 foreach my $i ( @op_sections ) {
1956 next unless $section->index >= 0;
1957 init_op_addr( $section->name, $section->index + 1);
1960 init_op_warn( $copsect->name, $copsect->index + 1)
1961 if $optimize_warn_sv && $copsect->index >= 0;
1963 warn "Writing output\n";
1964 output_boilerplate();
1966 output_all("perl_init");
1972 my @sections = (decl => \$decl, sym => \$symsect,
1973 binop => \$binopsect, condop => \$condopsect,
1974 cop => \$copsect, padop => \$padopsect,
1975 listop => \$listopsect, logop => \$logopsect,
1976 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1977 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1978 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1979 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1980 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1981 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1982 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1983 xpvio => \$xpviosect);
1984 my ($name, $sectref);
1985 while (($name, $sectref) = splice(@sections, 0, 2)) {
1986 $$sectref = new B::C::Section $name, \%symtable, 0;
1988 $init = new B::C::InitSection 'init', \%symtable, 0;
1993 my ($arg,$val) = @_;
1994 $unused_sub_packages{$arg} = $val;
1999 my ($option, $opt, $arg);
2000 my @eval_at_startup;
2001 my %option_map = ( 'cog' => \$pv_copy_on_grow,
2002 'save-data' => \$save_data_fh,
2003 'ppaddr' => \$optimize_ppaddr,
2004 'warn-sv' => \$optimize_warn_sv,
2005 'use-script-name' => \$use_perl_script_name,
2006 'save-sig-hash' => \$save_sig,
2008 my %optimization_map = ( 0 => [ qw() ], # special case
2010 2 => [ qw(-fwarn-sv -fppaddr) ],
2013 while ($option = shift @options) {
2014 if ($option =~ /^-(.)(.*)/) {
2018 unshift @options, $option;
2021 if ($opt eq "-" && $arg eq "-") {
2026 $warn_undefined_syms = 1;
2027 } elsif ($opt eq "D") {
2028 $arg ||= shift @options;
2029 foreach $arg (split(//, $arg)) {
2032 } elsif ($arg eq "c") {
2034 } elsif ($arg eq "A") {
2036 } elsif ($arg eq "C") {
2038 } elsif ($arg eq "M") {
2041 warn "ignoring unknown debug option: $arg\n";
2044 } elsif ($opt eq "o") {
2045 $arg ||= shift @options;
2046 open(STDOUT, ">$arg") or return "$arg: $!\n";
2047 } elsif ($opt eq "v") {
2049 } elsif ($opt eq "u") {
2050 $arg ||= shift @options;
2051 mark_unused($arg,undef);
2052 } elsif ($opt eq "f") {
2053 $arg ||= shift @options;
2054 $arg =~ m/(no-)?(.*)/;
2055 my $no = defined($1) && $1 eq 'no-';
2056 $arg = $no ? $2 : $arg;
2057 if( exists $option_map{$arg} ) {
2058 ${$option_map{$arg}} = !$no;
2060 die "Invalid optimization '$arg'";
2062 } elsif ($opt eq "O") {
2063 $arg = 1 if $arg eq "";
2065 foreach my $i ( 1 .. $arg ) {
2066 push @opt, @{$optimization_map{$i}}
2067 if exists $optimization_map{$i};
2069 unshift @options, @opt;
2070 } elsif ($opt eq "e") {
2071 push @eval_at_startup, $arg;
2072 } elsif ($opt eq "l") {
2073 $max_string_len = $arg;
2077 foreach my $i ( @eval_at_startup ) {
2078 $init->add_eval( $i );
2083 foreach $objname (@options) {
2084 eval "save_object(\\$objname)";
2089 return sub { save_main() };
2099 B::C - Perl compiler's C backend
2103 perl -MO=C[,OPTIONS] foo.pl
2107 This compiler backend takes Perl source and generates C source code
2108 corresponding to the internal structures that perl uses to run
2109 your program. When the generated C source is compiled and run, it
2110 cuts out the time which perl would have taken to load and parse
2111 your program into its internal semi-compiled form. That means that
2112 compiling with this backend will not help improve the runtime
2113 execution speed of your program but may improve the start-up time.
2114 Depending on the environment in which your program runs this may be
2115 either a help or a hindrance.
2119 If there are any non-option arguments, they are taken to be
2120 names of objects to be saved (probably doesn't work properly yet).
2121 Without extra arguments, it saves the main program.
2127 Output to filename instead of STDOUT
2131 Verbose compilation (currently gives a few compilation statistics).
2135 Force end of options
2139 Force apparently unused subs from package Packname to be compiled.
2140 This allows programs to use eval "foo()" even when sub foo is never
2141 seen to be used at compile time. The down side is that any subs which
2142 really are never used also have code generated. This option is
2143 necessary, for example, if you have a signal handler foo which you
2144 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
2145 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
2146 options. The compiler tries to figure out which packages may possibly
2147 have subs in which need compiling but the current version doesn't do
2148 it very well. In particular, it is confused by nested packages (i.e.
2149 of the form C<A::B>) where package C<A> does not contain any subs.
2153 Debug options (concatenated or separate flags like C<perl -D>).
2157 OPs, prints each OP as it's processed
2161 COPs, prints COPs as processed (incl. file & line num)
2165 prints AV information on saving
2169 prints CV information on saving
2173 prints MAGIC information on saving
2177 Force options/optimisations on or off one at a time. You can explicitly
2178 disable an option using B<-fno-option>. All options default to
2185 Copy-on-grow: PVs declared and initialised statically.
2187 =item B<-fsave-data>
2189 Save package::DATA filehandles ( only available with PerlIO ).
2193 Optimize the initialization of op_ppaddr.
2197 Optimize the initialization of cop_warnings.
2199 =item B<-fuse-script-name>
2201 Use the script name instead of the program name as $0.
2203 =item B<-fsave-sig-hash>
2205 Save compile-time modifications to the %SIG hash.
2211 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
2217 Disable all optimizations.
2225 Enable B<-fppaddr>, B<-fwarn-sv>.
2231 Some C compilers impose an arbitrary limit on the length of string
2232 constants (e.g. 2048 characters for Microsoft Visual C++). The
2233 B<-llimit> options tells the C backend not to generate string literals
2234 exceeding that limit.
2240 perl -MO=C,-ofoo.c foo.pl
2241 perl cc_harness -o foo foo.c
2243 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
2244 library directory. The utility called C<perlcc> may also be used to
2245 help make use of this compiler.
2247 perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null
2251 Plenty. Current status: experimental.
2255 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>