My favorites | Sign in
Project Home Wiki Issues Source
Repository:
Checkout   Browse   Changes   Clones  
Changes to /B/C.pm
000000000000 vs. c21739460ca5 Compare: vs.  Format:
Revision c21739460ca5
Go to: 
Project members, sign in to write a code review
/B/C.pm /B/C.pm   c21739460ca5
  1 # C.pm
  2 #
  3 # Copyright (c) 1996, 1997, 1998 Malcolm Beattie
  4 #
  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.
  7 #
  8
  9 package B::C;
  10
  11 our $VERSION = '1.04_02';
  12
  13 package B::C::Section;
  14
  15 use B ();
  16 use base B::Section;
  17
  18 sub new
  19 {
  20 my $class = shift;
  21 my $o = $class->SUPER::new(@_);
  22 push @$o, { values => [] };
  23 return $o;
  24 }
  25
  26 sub add
  27 {
  28 my $section = shift;
  29 push(@{$section->[-1]{values}},@_);
  30 }
  31
  32 sub index
  33 {
  34 my $section = shift;
  35 return scalar(@{$section->[-1]{values}})-1;
  36 }
  37
  38 sub output
  39 {
  40 my ($section, $fh, $format) = @_;
  41 my $sym = $section->symtable || {};
  42 my $default = $section->default;
  43 my $i;
  44 foreach (@{$section->[-1]{values}})
  45 {
  46 s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
  47 printf $fh $format, $_, $i;
  48 ++$i;
  49 }
  50 }
  51
  52 package B::C::InitSection;
  53
  54 # avoid use vars
  55 @B::C::InitSection::ISA = qw(B::C::Section);
  56
  57 sub new {
  58 my $class = shift;
  59 my $max_lines = 10000; #pop;
  60 my $section = $class->SUPER::new( @_ );
  61
  62 $section->[-1]{evals} = [];
  63 $section->[-1]{chunks} = [];
  64 $section->[-1]{nosplit} = 0;
  65 $section->[-1]{current} = [];
  66 $section->[-1]{count} = 0;
  67 $section->[-1]{max_lines} = $max_lines;
  68
  69 return $section;
  70 }
  71
  72 sub split {
  73 my $section = shift;
  74 $section->[-1]{nosplit}--
  75 if $section->[-1]{nosplit} > 0;
  76 }
  77
  78 sub no_split {
  79 shift->[-1]{nosplit}++;
  80 }
  81
  82 sub inc_count {
  83 my $section = shift;
  84
  85 $section->[-1]{count} += $_[0];
  86 # this is cheating
  87 $section->add();
  88 }
  89
  90 sub add {
  91 my $section = shift->[-1];
  92 my $current = $section->{current};
  93 my $nosplit = $section->{nosplit};
  94
  95 push @$current, @_;
  96 $section->{count} += scalar(@_);
  97 if( !$nosplit && $section->{count} >= $section->{max_lines} ) {
  98 push @{$section->{chunks}}, $current;
  99 $section->{current} = [];
  100 $section->{count} = 0;
  101 }
  102 }
  103
  104 sub add_eval {
  105 my $section = shift;
  106 my @strings = @_;
  107
  108 foreach my $i ( @strings ) {
  109 $i =~ s/\"/\\\"/g;
  110 }
  111 push @{$section->[-1]{evals}}, @strings;
  112 }
  113
  114 sub output {
  115 my( $section, $fh, $format, $init_name ) = @_;
  116 my $sym = $section->symtable || {};
  117 my $default = $section->default;
  118 push @{$section->[-1]{chunks}}, $section->[-1]{current};
  119
  120 my $name = "aaaa";
  121 foreach my $i ( @{$section->[-1]{chunks}} ) {
  122 print $fh <<"EOT";
  123 static int perl_init_${name}()
  124 {
  125 dTARG;
  126 dSP;
  127 EOT
  128 foreach my $j ( @$i ) {
  129 $j =~ s{(s\\_[0-9a-f]+)}
  130 { exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
  131 print $fh "\t$j\n";
  132 }
  133 print $fh "\treturn 0;\n}\n";
  134
  135 $section->SUPER::add( "perl_init_${name}();" );
  136 ++$name;
  137 }
  138 foreach my $i ( @{$section->[-1]{evals}} ) {
  139 $section->SUPER::add( sprintf q{eval_pv("%s",1);}, $i );
  140 }
  141
  142 print $fh <<"EOT";
  143 static int ${init_name}()
  144 {
  145 dTARG;
  146 dSP;
  147 EOT
  148 $section->SUPER::output( $fh, $format );
  149 print $fh "\treturn 0;\n}\n";
  150 }
  151
  152
  153 package B::C;
  154 use Exporter ();
  155 our %REGEXP;
  156
  157 { # block necessary for caller to work
  158 my $caller = caller;
  159 if( $caller eq 'O' ) {
  160 require XSLoader;
  161 XSLoader::load( 'B::C' );
  162 }
  163 }
  164
  165 @ISA = qw(Exporter);
  166 @EXPORT_OK = qw(output_all output_boilerplate output_main mark_unused
  167 init_sections set_callback save_unused_subs objsym save_context);
  168
  169 use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop
  170 class cstring cchar svref_2object compile_stats comppadlist hash
  171 threadsv_names main_cv init_av end_av regex_padav opnumber amagic_generation
  172 HEf_SVKEY SVf_POK SVf_ROK CVf_CONST);
  173 use B::Asmdata qw(@specialsv_name);
  174
  175 use FileHandle;
  176 use Carp;
  177 use strict;
  178 use Config;
  179
  180 my $hv_index = 0;
  181 my $gv_index = 0;
  182 my $re_index = 0;
  183 my $pv_index = 0;
  184 my $cv_index = 0;
  185 my $anonsub_index = 0;
  186 my $initsub_index = 0;
  187
  188 my %symtable;
  189 my %xsub;
  190 my $warn_undefined_syms;
  191 my $verbose;
  192 my %unused_sub_packages;
  193 my $use_xsloader;
  194 my $nullop_count;
  195 my $pv_copy_on_grow = 0;
  196 my $optimize_ppaddr = 0;
  197 my $optimize_warn_sv = 0;
  198 my $use_perl_script_name = 0;
  199 my $save_data_fh = 0;
  200 my $save_sig = 0;
  201 my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
  202 my $max_string_len;
  203
  204 my $ithreads = $Config{useithreads} eq 'define';
  205
  206 my @threadsv_names;
  207 BEGIN {
  208 @threadsv_names = threadsv_names();
  209 }
  210
  211 # Code sections
  212 my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect,
  213 $padopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
  214 $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
  215 $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
  216 $xrvsect, $xpvbmsect, $xpviosect );
  217 my @op_sections = \( $binopsect, $condopsect, $copsect, $padopsect, $listopsect,
  218 $logopsect, $loopsect, $opsect, $pmopsect, $pvopsect, $svopsect,
  219 $unopsect );
  220
  221 sub walk_and_save_optree;
  222 my $saveoptree_callback = \&walk_and_save_optree;
  223 sub set_callback { $saveoptree_callback = shift }
  224 sub saveoptree { &$saveoptree_callback(@_) }
  225
  226 sub walk_and_save_optree {
  227 my ($name, $root, $start) = @_;
  228 walkoptree($root, "save");
  229 return objsym($start);
  230 }
  231
  232 # Look this up here so we can do just a number compare
  233 # rather than looking up the name of every BASEOP in B::OP
  234 my $OP_THREADSV = opnumber('threadsv');
  235
  236 sub savesym {
  237 my ($obj, $value) = @_;
  238 my $sym = sprintf("s\\_%x", $$obj);
  239 $symtable{$sym} = $value;
  240 }
  241
  242 sub objsym {
  243 my $obj = shift;
  244 return $symtable{sprintf("s\\_%x", $$obj)};
  245 }
  246
  247 sub getsym {
  248 my $sym = shift;
  249 my $value;
  250
  251 return 0 if $sym eq "sym_0"; # special case
  252 $value = $symtable{$sym};
  253 if (defined($value)) {
  254 return $value;
  255 } else {
  256 warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
  257 return "UNUSED";
  258 }
  259 }
  260
  261 sub savere {
  262 my $re = shift;
  263 my $sym = sprintf("re%d", $re_index++);
  264 $decl->add(sprintf("static char *$sym = %s;", cstring($re)));
  265
  266 return ($sym,length(pack "a*",$re));
  267 }
  268
  269 sub savepv {
  270 my $pv = pack "a*", shift;
  271 my $pvsym = 0;
  272 my $pvmax = 0;
  273 if ($pv_copy_on_grow) {
  274 $pvsym = sprintf("pv%d", $pv_index++);
  275
  276 if( defined $max_string_len && length($pv) > $max_string_len ) {
  277 my $chars = join ', ', map { cchar $_ } split //, $pv;
  278 $decl->add(sprintf("static char %s[] = { %s };", $pvsym, $chars));
  279 }
  280 else {
  281 my $cstring = cstring($pv);
  282 if ($cstring ne "0") { # sic
  283 $decl->add(sprintf("static char %s[] = %s;",
  284 $pvsym, $cstring));
  285 }
  286 }
  287 } else {
  288 $pvmax = length(pack "a*",$pv) + 1;
  289 }
  290 return ($pvsym, $pvmax);
  291 }
  292
  293 sub save_rv {
  294 my $sv = shift;
  295 # confess "Can't save RV: not ROK" unless $sv->FLAGS & SVf_ROK;
  296 my $rv = $sv->RV->save;
  297
  298 $rv =~ s/^\(([AGHS]V|IO)\s*\*\)\s*(\&sv_list.*)$/$2/;
  299
  300 return $rv;
  301 }
  302
  303 # savesym, pvmax, len, pv
  304 sub save_pv_or_rv {
  305 my $sv = shift;
  306
  307 my $rok = $sv->FLAGS & SVf_ROK;
  308 my $pok = $sv->FLAGS & SVf_POK;
  309 my( $len, $pvmax, $savesym, $pv ) = ( 0, 0 );
  310 if( $rok ) {
  311 $savesym = '(char*)' . save_rv( $sv );
  312 }
  313 else {
  314 $pv = $pok ? (pack "a*", $sv->PV) : undef;
  315 $len = $pok ? length($pv) : 0;
  316 ($savesym, $pvmax) = $pok ? savepv($pv) : ( 'NULL', 0 );
  317 }
  318
  319 return ( $savesym, $pvmax, $len, $pv );
  320 }
  321
  322 # see also init_op_ppaddr below; initializes the ppaddt to the
  323 # OpTYPE; init_op_ppaddr iterates over the ops and sets
  324 # op_ppaddr to PL_ppaddr[op_ppaddr]; this avoids an explicit assignmente
  325 # in perl_init ( ~10 bytes/op with GCC/i386 )
  326 sub B::OP::fake_ppaddr {
  327 return $optimize_ppaddr ?
  328 sprintf("INT2PTR(void*,OP_%s)", uc( $_[0]->name ) ) :
  329 'NULL';
  330 }
  331
  332 # This pair is needed becase B::FAKEOP::save doesn't scalar dereference
  333 # $op->next and $op->sibling
  334
  335 {
  336 # For 5.9 the hard coded text is the values for op_opt and op_static in each
  337 # op. The value of op_opt is irrelevant, and the value of op_static needs to
  338 # be 1 to tell op_free that this is a statically defined op and that is
  339 # shouldn't be freed.
  340
  341 # For 5.8:
  342 # Current workaround/fix for op_free() trying to free statically
  343 # defined OPs is to set op_seq = -1 and check for that in op_free().
  344 # Instead of hardwiring -1 in place of $op->seq, we use $op_seq
  345 # so that it can be changed back easily if necessary. In fact, to
  346 # stop compilers from moaning about a U16 being initialised with an
  347 # uncast -1 (the printf format is %d so we can't tweak it), we have
  348 # to "know" that op_seq is a U16 and use 65535. Ugh.
  349
  350 my $static = $] > 5.009 ? '0, 1, 0' : sprintf "%u", 65535;
  351 sub B::OP::_save_common_middle {
  352 my $op = shift;
  353 sprintf ("%s, %u, %u, $static, 0x%x, 0x%x",
  354 $op->fake_ppaddr, $op->targ, $op->type, $op->flags, $op->private);
  355 }
  356 }
  357
  358 sub B::OP::_save_common {
  359 my $op = shift;
  360 return sprintf("s\\_%x, s\\_%x, %s",
  361 ${$op->next}, ${$op->sibling}, $op->_save_common_middle);
  362 }
  363
  364 sub B::OP::save {
  365 my ($op, $level) = @_;
  366 my $sym = objsym($op);
  367 return $sym if defined $sym;
  368 my $type = $op->type;
  369 $nullop_count++ unless $type;
  370 if ($type == $OP_THREADSV) {
  371 # saves looking up ppaddr but it's a bit naughty to hard code this
  372 $init->add(sprintf("(void)find_threadsv(%s);",
  373 cstring($threadsv_names[$op->targ])));
  374 }
  375 $opsect->add($op->_save_common);
  376 my $ix = $opsect->index;
  377 $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr))
  378 unless $optimize_ppaddr;
  379 savesym($op, "&op_list[$ix]");
  380 }
  381
  382 sub B::FAKEOP::new {
  383 my ($class, %objdata) = @_;
  384 bless \%objdata, $class;
  385 }
  386
  387 sub B::FAKEOP::save {
  388 my ($op, $level) = @_;
  389 $opsect->add(sprintf("%s, %s, %s",
  390 $op->next, $op->sibling, $op->_save_common_middle));
  391 my $ix = $opsect->index;
  392 $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr))
  393 unless $optimize_ppaddr;
  394 return "&op_list[$ix]";
  395 }
  396
  397 sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
  398 sub B::FAKEOP::type { $_[0]->{type} || 0}
  399 sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
  400 sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
  401 sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
  402 sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
  403 sub B::FAKEOP::private { $_[0]->{private} || 0 }
  404
  405 sub B::UNOP::save {
  406 my ($op, $level) = @_;
  407 my $sym = objsym($op);
  408 return $sym if defined $sym;
  409 $unopsect->add(sprintf("%s, s\\_%x", $op->_save_common, ${$op->first}));
  410 my $ix = $unopsect->index;
  411 $init->add(sprintf("unop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
  412 unless $optimize_ppaddr;
  413 savesym($op, "(OP*)&unop_list[$ix]");
  414 }
  415
  416 sub B::BINOP::save {
  417 my ($op, $level) = @_;
  418 my $sym = objsym($op);
  419 return $sym if defined $sym;
  420 $binopsect->add(sprintf("%s, s\\_%x, s\\_%x",
  421 $op->_save_common, ${$op->first}, ${$op->last}));
  422 my $ix = $binopsect->index;
  423 $init->add(sprintf("binop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
  424 unless $optimize_ppaddr;
  425 savesym($op, "(OP*)&binop_list[$ix]");
  426 }
  427
  428 sub B::LISTOP::save {
  429 my ($op, $level) = @_;
  430 my $sym = objsym($op);
  431 return $sym if defined $sym;
  432 $listopsect->add(sprintf("%s, s\\_%x, s\\_%x",
  433 $op->_save_common, ${$op->first}, ${$op->last}));
  434 my $ix = $listopsect->index;
  435 $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
  436 unless $optimize_ppaddr;
  437 savesym($op, "(OP*)&listop_list[$ix]");
  438 }
  439
  440 sub B::LOGOP::save {
  441 my ($op, $level) = @_;
  442 my $sym = objsym($op);
  443 return $sym if defined $sym;
  444 $logopsect->add(sprintf("%s, s\\_%x, s\\_%x",
  445 $op->_save_common, ${$op->first}, ${$op->other}));
  446 my $ix = $logopsect->index;
  447 $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
  448 unless $optimize_ppaddr;
  449 savesym($op, "(OP*)&logop_list[$ix]");
  450 }
  451
  452 sub B::LOOP::save {
  453 my ($op, $level) = @_;
  454 my $sym = objsym($op);
  455 return $sym if defined $sym;
  456 #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
  457 # peekop($op->redoop), peekop($op->nextop),
  458 # peekop($op->lastop)); # debug
  459 $loopsect->add(sprintf("%s, s\\_%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x",
  460 $op->_save_common, ${$op->first}, ${$op->last},
  461 ${$op->redoop}, ${$op->nextop},
  462 ${$op->lastop}));
  463 my $ix = $loopsect->index;
  464 $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
  465 unless $optimize_ppaddr;
  466 savesym($op, "(OP*)&loop_list[$ix]");
  467 }
  468
  469 sub B::PVOP::save {
  470 my ($op, $level) = @_;
  471 my $sym = objsym($op);
  472 return $sym if defined $sym;
  473 $pvopsect->add(sprintf("%s, %s", $op->_save_common, cstring($op->pv)));
  474 my $ix = $pvopsect->index;
  475 $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
  476 unless $optimize_ppaddr;
  477 savesym($op, "(OP*)&pvop_list[$ix]");
  478 }
  479
  480 sub B::SVOP::save {
  481 my ($op, $level) = @_;
  482 my $sym = objsym($op);
  483 return $sym if defined $sym;
  484 my $sv = $op->sv;
  485 my $svsym = '(SV*)' . $sv->save;
  486 my $is_const_addr = $svsym =~ m/Null|\&/;
  487 $svopsect->add(sprintf("%s, %s", $op->_save_common,
  488 ( $is_const_addr ? $svsym : 'Nullsv' )));
  489 my $ix = $svopsect->index;
  490 $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
  491 unless $optimize_ppaddr;
  492 $init->add("svop_list[$ix].op_sv = $svsym;")
  493 unless $is_const_addr;
  494 savesym($op, "(OP*)&svop_list[$ix]");
  495 }
  496
  497 sub B::PADOP::save {
  498 my ($op, $level) = @_;
  499 my $sym = objsym($op);
  500 return $sym if defined $sym;
  501 $padopsect->add(sprintf("%s, %d",
  502 $op->_save_common, $op->padix));
  503 my $ix = $padopsect->index;
  504 $init->add(sprintf("padop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
  505 unless $optimize_ppaddr;
  506 # $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix));
  507 savesym($op, "(OP*)&padop_list[$ix]");
  508 }
  509
  510 sub B::COP::save {
  511 my ($op, $level) = @_;
  512 my $sym = objsym($op);
  513 return $sym if defined $sym;
  514 warn sprintf("COP: line %d file %s\n", $op->line, $op->file)
  515 if $debug_cops;
  516 # shameless cut'n'paste from B::Deparse
  517 my $warn_sv;
  518 my $warnings = $op->warnings;
  519 my $is_special = $warnings->isa("B::SPECIAL");
  520 if ($is_special && $$warnings == 4) {
  521 # use warnings 'all';
  522 $warn_sv = $optimize_warn_sv ?
  523 'INT2PTR(SV*,1)' :
  524 'pWARN_ALL';
  525 }
  526 elsif ($is_special && $$warnings == 5) {
  527 # no warnings 'all';
  528 $warn_sv = $optimize_warn_sv ?
  529 'INT2PTR(SV*,2)' :
  530 'pWARN_NONE';
  531 }
  532 elsif ($is_special) {
  533 # use warnings;
  534 $warn_sv = $optimize_warn_sv ?
  535 'INT2PTR(SV*,3)' :
  536 'pWARN_STD';
  537 }
  538 else {
  539 # something else
  540 $warn_sv = $warnings->save;
  541 }
  542
  543 $copsect->add(sprintf("%s, %s, NULL, NULL, %u, %d, %u, %s",
  544 $op->_save_common, cstring($op->label), $op->cop_seq,
  545 $op->arybase, $op->line,
  546 ( $optimize_warn_sv ? $warn_sv : 'NULL' )));
  547 my $ix = $copsect->index;
  548 $init->add(sprintf("cop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
  549 unless $optimize_ppaddr;
  550 $init->add(sprintf("cop_list[$ix].cop_warnings = %s;", $warn_sv ))
  551 unless $optimize_warn_sv;
  552 $init->add(sprintf("CopFILE_set(&cop_list[$ix], %s);", cstring($op->file)),
  553 sprintf("CopSTASHPV_set(&cop_list[$ix], %s);", cstring($op->stashpv)));
  554
  555 savesym($op, "(OP*)&cop_list[$ix]");
  556 }
  557
  558 sub B::PMOP::save {
  559 my ($op, $level) = @_;
  560 my $sym = objsym($op);
  561 return $sym if defined $sym;
  562 my $replroot = $op->pmreplroot;
  563 my $replstart = $op->pmreplstart;
  564 my $replrootfield;
  565 my $replstartfield = sprintf("s\\_%x", $$replstart);
  566 my $gvsym;
  567 my $ppaddr = $op->ppaddr;
  568 # under ithreads, OP_PUSHRE.op_replroot is an integer
  569 $replrootfield = sprintf("s\\_%x", $$replroot) if ref $replroot;
  570 if($ithreads && $op->name eq "pushre") {
  571 $replrootfield = "INT2PTR(OP*,${replroot})";
  572 } elsif ($$replroot) {
  573 # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
  574 # argument to a split) stores a GV in op_pmreplroot instead
  575 # of a substitution syntax tree. We don't want to walk that...
  576 if ($op->name eq "pushre") {
  577 $gvsym = $replroot->save;
  578 # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
  579 $replrootfield = 0;
  580 } else {
  581 $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
  582 }
  583 }
  584 # pmnext handling is broken in perl itself, I think. Bad op_pmnext
  585 # fields aren't noticed in perl's runtime (unless you try reset) but we
  586 # segfault when trying to dereference it to find op->op_pmnext->op_type
  587 $pmopsect->add(sprintf("%s, s\\_%x, s\\_%x, %s, %s, 0, %u, 0x%x, 0x%x, 0x%x",
  588 $op->_save_common, ${$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;
  596 if (defined($re)) {
  597 my( $resym, $relen ) = savere( $re );
  598 $init->add(sprintf("PM_SETRE(&$pm,pregcomp($resym, $resym + %u, &$pm));",
  599 $relen));
  600 }
  601 if ($gvsym) {
  602 $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
  603 }
  604 savesym($op, "(OP*)&$pm");
  605 }
  606
  607 sub B::SPECIAL::save {
  608 my ($sv) = @_;
  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";
  614 }
  615 return $sym;
  616 }
  617
  618 sub B::OBJECT::save {}
  619
  620 sub B::NULL::save {
  621 my ($sv) = @_;
  622 my $sym = objsym($sv);
  623 return $sym if defined $sym;
  624 # warn "Saving SVt_NULL SV\n"; # debug
  625 # debug
  626 if ($$sv == 0) {
  627 warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
  628 return savesym($sv, "(void*)Nullsv /* XXX */");
  629 }
  630 $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS));
  631 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
  632 }
  633
  634 sub B::IV::save {
  635 my ($sv) = @_;
  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));
  642 }
  643
  644 sub B::NV::save {
  645 my ($sv) = @_;
  646 my $sym = objsym($sv);
  647 return $sym if defined $sym;
  648 my $val= $sv->NVX;
  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));
  654 }
  655
  656 sub savepvn {
  657 my ($dest,$pv) = @_;
  658 my @res;
  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("Newx(%s,%u,char);", $dest, length($pv)+1);
  663 my $offset = 0;
  664 while (length $pv) {
  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;
  669 }
  670 push @res, sprintf("%s[%u] = '\\0';", $dest, $offset);
  671 }
  672 else {
  673 push @res, sprintf("%s = savepvn(%s, %u);", $dest,
  674 cstring($pv), length($pv));
  675 }
  676 return @res;
  677 }
  678
  679 sub B::PVLV::save {
  680 my ($sv) = @_;
  681 my $sym = objsym($sv);
  682 return $sym if defined $sym;
  683 my $pv = $sv->PV;
  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));
  695 }
  696 $sv->save_magic;
  697 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
  698 }
  699
  700 sub B::PVIV::save {
  701 my ($sv) = @_;
  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));
  711 }
  712 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
  713 }
  714
  715 sub B::PVNV::save {
  716 my ($sv) = @_;
  717 my $sym = objsym($sv);
  718 return $sym if defined $sym;
  719 my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
  720 my $val= $sv->NVX;
  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));
  729 }
  730 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
  731 }
  732
  733 sub B::BM::save {
  734 my ($sv) = @_;
  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));
  744 $sv->save_magic;
  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));
  750 }
  751
  752 sub B::PV::save {
  753 my ($sv) = @_;
  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));
  763 }
  764 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
  765 }
  766
  767 sub B::PVMG::save {
  768 my ($sv) = @_;
  769 my $sym = objsym($sv);
  770 return $sym if defined $sym;
  771 my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
  772
  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));
  781 }
  782 $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
  783 $sv->save_magic;
  784 return $sym;
  785 }
  786
  787 sub B::PVMG::save_magic {
  788 my ($sv) = @_;
  789 #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
  790 my $stash = $sv->SvSTASH;
  791 $stash->save;
  792 if ($$stash) {
  793 warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
  794 if $debug_mg;
  795 # XXX Hope stash is already going to be saved.
  796 $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
  797 }
  798 my @mgchain = $sv->MAGIC;
  799 my ($mg, $type, $obj, $ptr,$len,$ptrsv);
  800 foreach $mg (@mgchain) {
  801 $type = $mg->TYPE;
  802 $ptr = $mg->PTR;
  803 $len=$mg->LENGTH;
  804 if ($debug_mg) {
  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));
  808 }
  809
  810 unless( $type eq 'r' ) {
  811 $obj = $mg->OBJ;
  812 $obj->save;
  813 }
  814
  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' ){
  821 my $rx = $mg->REGEX;
  822 my $pmop = $REGEXP{$rx};
  823
  824 confess "PMOP not found for REGEXP $rx" unless $pmop;
  825
  826 my( $resym, $relen ) = savere( $mg->precomp );
  827 my $pmsym = $pmop->save;
  828 $init->add( split /\n/, sprintf <<CODE, $$sv, cchar($type), cstring($ptr) );
  829 {
  830 REGEXP* rx = pregcomp($resym, $resym + $relen, (PMOP*)$pmsym);
  831 sv_magic((SV*)s\\_%x, (SV*)rx, %s, %s, %d);
  832 }
  833 CODE
  834 }else{
  835 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
  836 $$sv, $$obj, cchar($type),cstring($ptr),$len));
  837 }
  838 }
  839 }
  840
  841 sub B::RV::save {
  842 my ($sv) = @_;
  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));
  850 }
  851 # and stashes, too
  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));
  855 }
  856 else {
  857 $xrvsect->add($rv);
  858 }
  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));
  862 }
  863
  864 sub try_autoload {
  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.
  869 no strict 'refs';
  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;
  875 $dir =~ s(::)(/)g;
  876 eval { require "auto/$dir/$cvname.al" };
  877 if ($@) {
  878 warn qq(failed require "auto/$dir/$cvname.al": $@\n);
  879 return 0;
  880 } else {
  881 return 1;
  882 }
  883 }
  884 }
  885 sub Dummy_initxs{};
  886 sub B::CV::save {
  887 my ($cv) = @_;
  888 my $sym = objsym($cv);
  889 if (defined($sym)) {
  890 # warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
  891 return $sym;
  892 }
  893 # Reserve a place in svsect and xpvcvsect and record indices
  894 my $gv = $cv->GV;
  895 my ($cvname, $cvstashname);
  896 if ($$gv){
  897 $cvname = $gv->NAME;
  898 $cvstashname = $gv->STASH->NAME;
  899 }
  900 my $root = $cv->ROOT;
  901 my $cvxsub = $cv->XSUB;
  902 my $isconst = $cv->CvFLAGS & CVf_CONST;
  903 if( $isconst ) {
  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" );
  912 $cv_index++;
  913 return $sym;
  914 }
  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")) {
  919 my $egv = $gv->EGV;
  920 my $stashname = $egv->STASH->NAME;
  921 if ($cvname eq "bootstrap")
  922 {
  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';
  931 $use_xsloader = 1;
  932 }
  933 else {
  934 $xsub{$stashname}='Dynamic';
  935 }
  936 # $xsub{$stashname}='Static' unless $xsub{$stashname};
  937 return qq/NULL/;
  938 }
  939 else
  940 {
  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);
  947 }
  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))/;
  950 }
  951 if ($cvxsub && $cvname eq "INIT") {
  952 no strict 'refs';
  953 return svref_2object(\&Dummy_initxs)->save;
  954 }
  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
  965 $root = $cv->ROOT;
  966 $cvxsub = $cv->XSUB;
  967 if ($$root || $cvxsub) {
  968 warn "Successful forced autoload\n";
  969 }
  970 }
  971 }
  972 my $startfield = 0;
  973 my $padlist = $cv->PADLIST;
  974 my $pv = $cv->PV;
  975 my $xsub = 0;
  976 my $xsubany = "Nullany";
  977 if ($$root) {
  978 warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
  979 $$cv, $$root) if $debug_cv;
  980 my $ppname = "";
  981 if ($$gv) {
  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";
  991 $initsub_index++;
  992 }
  993 }
  994 }
  995 if (!$ppname) {
  996 $ppname = "pp_anonsub_$anonsub_index";
  997 $anonsub_index++;
  998 }
  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;
  1002 if ($$padlist) {
  1003 warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
  1004 $$padlist, $$cv) if $debug_cv;
  1005 $padlist->save;
  1006 warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
  1007 $$padlist, $$cv) if $debug_cv;
  1008 }
  1009 }
  1010 else {
  1011 warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
  1012 $cvstashname, $cvname); # debug
  1013 }
  1014 $pv = '' unless defined $pv; # Avoid use of undef warnings
  1015 $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, \"\", %d, s\\_%x, (CV*)s\\_%x, 0x%x, 0x%x",
  1016 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
  1017 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
  1018 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS,
  1019 $cv->OUTSIDE_SEQ));
  1020
  1021 if (${$cv->OUTSIDE} == ${main_cv()}){
  1022 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
  1023 $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
  1024 }
  1025
  1026 if ($$gv) {
  1027 $gv->save;
  1028 $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
  1029 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
  1030 $$gv, $$cv) if $debug_cv;
  1031 }
  1032 if( $ithreads ) {
  1033 $init->add( savepvn( "CvFILE($sym)", $cv->FILE) );
  1034 }
  1035 else {
  1036 $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE)));
  1037 }
  1038 my $stash = $cv->STASH;
  1039 if ($$stash) {
  1040 $stash->save;
  1041 $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
  1042 warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
  1043 $$stash, $$cv) if $debug_cv;
  1044 }
  1045 $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
  1046 $sv_ix, $xpvcv_ix, $cv->REFCNT +1*0 , $cv->FLAGS));
  1047 return $sym;
  1048 }
  1049
  1050 sub B::GV::save {
  1051 my ($gv) = @_;
  1052 my $sym = objsym($gv);
  1053 if (defined($sym)) {
  1054 #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
  1055 return $sym;
  1056 } else {
  1057 my $ix = $gv_index++;
  1058 $sym = savesym($gv, "gv_list[$ix]");
  1059 #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
  1060 }
  1061 my $is_empty = $gv->is_empty;
  1062 my $gvname = $gv->NAME;
  1063 my $fullname = $gv->STASH->NAME . "::" . $gvname;
  1064 my $name = cstring($fullname);
  1065 #warn "GV name is $name\n"; # debug
  1066 my $egvsym;
  1067 unless ($is_empty) {
  1068 my $egv = $gv->EGV;
  1069 if ($$gv != $$egv) {
  1070 #warn(sprintf("EGV name is %s, saving it now\n",
  1071 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
  1072 $egvsym = $egv->save;
  1073 }
  1074 }
  1075 $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
  1076 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS ),
  1077 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS));
  1078 $init->add(sprintf("GvLINE($sym) = %u;", $gv->LINE)) unless $is_empty;
  1079 # XXX hack for when Perl accesses PVX of GVs
  1080 $init->add("SvPVX($sym) = emptystring;\n");
  1081 # Shouldn't need to do save_magic since gv_fetchpv handles that
  1082 #$gv->save_magic;
  1083 # XXX will always be > 1!!!
  1084 my $refcnt = $gv->REFCNT + 1;
  1085 $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1 )) if $refcnt > 1;
  1086
  1087 return $sym if $is_empty;
  1088
  1089 # XXX B::walksymtable creates an extra reference to the GV
  1090 my $gvrefcnt = $gv->GvREFCNT;
  1091 if ($gvrefcnt > 1) {
  1092 $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
  1093 }
  1094 # some non-alphavetic globs require some parts to be saved
  1095 # ( ex. %!, but not $! )
  1096 sub Save_HV() { 1 }
  1097 sub Save_AV() { 2 }
  1098 sub Save_SV() { 4 }
  1099 sub Save_CV() { 8 }
  1100 sub Save_FORM() { 16 }
  1101 sub Save_IO() { 32 }
  1102 my $savefields = 0;
  1103 if( $gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/ ) {
  1104 $savefields = Save_HV|Save_AV|Save_SV|Save_CV|Save_FORM|Save_IO;
  1105 }
  1106 elsif( $gvname eq '!' ) {
  1107 $savefields = Save_HV;
  1108 }
  1109 # attributes::bootstrap is created in perl_parse
  1110 # saving it would overwrite it, because perl_init() is
  1111 # called after perl_parse()
  1112 $savefields&=~Save_CV if $fullname eq 'attributes::bootstrap';
  1113
  1114 # save it
  1115 # XXX is that correct?
  1116 if (defined($egvsym) && $egvsym !~ m/Null/ ) {
  1117 # Shared glob *foo = *bar
  1118 $init->add("gp_free($sym);",
  1119 "GvGP($sym) = GvGP($egvsym);");
  1120 } elsif ($savefields) {
  1121 # Don't save subfields of special GVs (*_, *1, *# and so on)
  1122 # warn "GV::save saving subfields\n"; # debug
  1123 my $gvsv = $gv->SV;
  1124 if ($$gvsv && $savefields&Save_SV) {
  1125 $gvsv->save;
  1126 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
  1127 # warn "GV::save \$$name\n"; # debug
  1128 }
  1129 my $gvav = $gv->AV;
  1130 if ($$gvav && $savefields&Save_AV) {
  1131 $gvav->save;
  1132 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
  1133 # warn "GV::save \@$name\n"; # debug
  1134 }
  1135 my $gvhv = $gv->HV;
  1136 if ($$gvhv && $savefields&Save_HV) {
  1137 $gvhv->save;
  1138 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
  1139 # warn "GV::save \%$name\n"; # debug
  1140 }
  1141 my $gvcv = $gv->CV;
  1142 if ($$gvcv && $savefields&Save_CV) {
  1143 my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
  1144 "::" . $gvcv->GV->EGV->NAME);
  1145 if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias
  1146 # must save as a 'stub' so newXS() has a CV to populate
  1147 $init->add("{ CV *cv;");
  1148 $init->add("\tcv=perl_get_cv($origname,TRUE);");
  1149 $init->add("\tGvCV($sym)=cv;");
  1150 $init->add("\tSvREFCNT_inc((SV *)cv);");
  1151 $init->add("}");
  1152 } else {
  1153 $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
  1154 # warn "GV::save &$name\n"; # debug
  1155 }
  1156 }
  1157 $init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE)));
  1158 # warn "GV::save GvFILE(*$name)\n"; # debug
  1159 my $gvform = $gv->FORM;
  1160 if ($$gvform && $savefields&Save_FORM) {
  1161 $gvform->save;
  1162 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
  1163 # warn "GV::save GvFORM(*$name)\n"; # debug
  1164 }
  1165 my $gvio = $gv->IO;
  1166 if ($$gvio && $savefields&Save_IO) {
  1167 $gvio->save;
  1168 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
  1169 if( $fullname =~ m/::DATA$/ && $save_data_fh ) {
  1170 no strict 'refs';
  1171 my $fh = *{$fullname}{IO};
  1172 use strict 'refs';
  1173 $gvio->save_data( $fullname, <$fh> ) if $fh->opened;
  1174 }
  1175 # warn "GV::save GvIO(*$name)\n"; # debug
  1176 }
  1177 }
  1178 return $sym;
  1179 }
  1180
  1181 sub B::AV::save {
  1182 my ($av) = @_;
  1183 my $sym = objsym($av);
  1184 return $sym if defined $sym;
  1185 my $line = "0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0";
  1186 $line .= sprintf(", 0x%x", $av->AvFLAGS) if $] < 5.009;
  1187 $xpvavsect->add($line);
  1188 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
  1189 $xpvavsect->index, $av->REFCNT , $av->FLAGS));
  1190 my $sv_list_index = $svsect->index;
  1191 my $fill = $av->FILL;
  1192 $av->save_magic;
  1193 if ($debug_av) {
  1194 $line = sprintf("saving AV 0x%x FILL=$fill", $$av);
  1195 $line .= sprintf(" AvFLAGS=0x%x", $av->AvFLAGS) if $] < 5.009;
  1196 warn $line;
  1197 }
  1198 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
  1199 #if ($fill > -1 && ($avflags & AVf_REAL)) {
  1200 if ($fill > -1) {
  1201 my @array = $av->ARRAY;
  1202 if ($debug_av) {
  1203 my $el;
  1204 my $i = 0;
  1205 foreach $el (@array) {
  1206 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
  1207 $$av, $i++, class($el), $$el);
  1208 }
  1209 }
  1210 # my @names = map($_->save, @array);
  1211 # XXX Better ways to write loop?
  1212 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
  1213 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
  1214
  1215 # micro optimization: op/pat.t ( and other code probably )
  1216 # has very large pads ( 20k/30k elements ) passing them to
  1217 # ->add is a performance bottleneck: passing them as a
  1218 # single string cuts runtime from 6min20sec to 40sec
  1219
  1220 # you want to keep this out of the no_split/split
  1221 # map("\t*svp++ = (SV*)$_;", @names),
  1222 my $acc = '';
  1223 foreach my $i ( 0..$#array ) {
  1224 $acc .= "\t*svp++ = (SV*)" . $array[$i]->save . ";\n\t";
  1225 }
  1226 $acc .= "\n";
  1227
  1228 $init->no_split;
  1229 $init->add("{",
  1230 "\tSV **svp;",
  1231 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
  1232 "\tav_extend(av, $fill);",
  1233 "\tsvp = AvARRAY(av);" );
  1234 $init->add($acc);
  1235 $init->add("\tAvFILLp(av) = $fill;",
  1236 "}");
  1237 $init->split;
  1238 # we really added a lot of lines ( B::C::InitSection->add
  1239 # should really scan for \n, but that would slow
  1240 # it down
  1241 $init->inc_count( $#array );
  1242 } else {
  1243 my $max = $av->MAX;
  1244 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
  1245 if $max > -1;
  1246 }
  1247 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
  1248 }
  1249
  1250 sub B::HV::save {
  1251 my ($hv) = @_;
  1252 my $sym = objsym($hv);
  1253 return $sym if defined $sym;
  1254 my $name = $hv->NAME;
  1255 if ($name) {
  1256 # It's a stash
  1257
  1258 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
  1259 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
  1260 # a trashed op but we look at the trashed op_type and segfault.
  1261 #my $adpmroot = ${$hv->PMROOT};
  1262 my $adpmroot = 0;
  1263 $decl->add("static HV *hv$hv_index;");
  1264 # XXX Beware of weird package names containing double-quotes, \n, ...?
  1265 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
  1266 if ($adpmroot) {
  1267 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
  1268 $adpmroot));
  1269 }
  1270 $sym = savesym($hv, "hv$hv_index");
  1271 $hv_index++;
  1272 return $sym;
  1273 }
  1274 # It's just an ordinary HV
  1275 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
  1276 $hv->MAX, $hv->RITER));
  1277 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
  1278 $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS));
  1279 my $sv_list_index = $svsect->index;
  1280 my @contents = $hv->ARRAY;
  1281 if (@contents) {
  1282 my $i;
  1283 for ($i = 1; $i < @contents; $i += 2) {
  1284 $contents[$i] = $contents[$i]->save;
  1285 }
  1286 $init->no_split;
  1287 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
  1288 while (@contents) {
  1289 my ($key, $value) = splice(@contents, 0, 2);
  1290 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
  1291 cstring($key),length(pack "a*",$key),
  1292 $value, hash($key)));
  1293 # $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
  1294 # cstring($key),length($key),$value, 0));
  1295 }
  1296 $init->add("}");
  1297 $init->split;
  1298 }
  1299 $hv->save_magic();
  1300 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
  1301 }
  1302
  1303 sub B::IO::save_data {
  1304 my( $io, $globname, @data ) = @_;
  1305 my $data = join '', @data;
  1306
  1307 # XXX using $DATA might clobber it!
  1308 my $sym = svref_2object( \\$data )->save;
  1309 $init->add( split /\n/, <<CODE );
  1310 {
  1311 GV* gv = (GV*)gv_fetchpv( "$globname", TRUE, SVt_PV );
  1312 SV* sv = $sym;
  1313 GvSV( gv ) = sv;
  1314 }
  1315 CODE
  1316 # for PerlIO::scalar
  1317 $use_xsloader = 1;
  1318 $init->add_eval( sprintf 'open(%s, "<", $%s)', $globname, $globname );
  1319 }
  1320
  1321 sub B::IO::save {
  1322 my ($io) = @_;
  1323 my $sym = objsym($io);
  1324 return $sym if defined $sym;
  1325 my $pv = $io->PV;
  1326 $pv = '' unless defined $pv;
  1327 my $len = length($pv);
  1328 $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",
  1329 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
  1330 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
  1331 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
  1332 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
  1333 cchar($io->IoTYPE), $io->IoFLAGS));
  1334 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
  1335 $xpviosect->index, $io->REFCNT , $io->FLAGS));
  1336 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
  1337 # deal with $x = *STDIN/STDOUT/STDERR{IO}
  1338 my $perlio_func;
  1339 foreach ( qw(stdin stdout stderr) ) {
  1340 $io->IsSTD($_) and $perlio_func = $_;
  1341 }
  1342 if( $perlio_func ) {
  1343 $init->add( "IoIFP(${sym})=PerlIO_${perlio_func}();" );
  1344 $init->add( "IoOFP(${sym})=PerlIO_${perlio_func}();" );
  1345 }
  1346
  1347 my ($field, $fsym);
  1348 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
  1349 $fsym = $io->$field();
  1350 if ($$fsym) {
  1351 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
  1352 $fsym->save;
  1353 }
  1354 }
  1355 $io->save_magic;
  1356 return $sym;
  1357 }
  1358
  1359 sub B::SV::save {
  1360 my $sv = shift;
  1361 # This is where we catch an honest-to-goodness Nullsv (which gets
  1362 # blessed into B::SV explicitly) and any stray erroneous SVs.
  1363 return 0 unless $$sv;
  1364 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
  1365 class($sv), $$sv);
  1366 }
  1367
  1368 sub output_all {
  1369 my $init_name = shift;
  1370 my $section;
  1371 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
  1372 $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect,
  1373 $loopsect, $copsect, $svsect, $xpvsect,
  1374 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
  1375 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
  1376 $symsect->output(\*STDOUT, "#define %s\n");
  1377 print "\n";
  1378 output_declarations();
  1379 foreach $section (@sections) {
  1380 my $lines = $section->index + 1;
  1381 if ($lines) {
  1382 my $name = $section->name;
  1383 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
  1384 print "Static $typename ${name}_list[$lines];\n";
  1385 }
  1386 }
  1387 # XXX hack for when Perl accesses PVX of GVs
  1388 print 'Static char emptystring[] = "\0";';
  1389
  1390 $decl->output(\*STDOUT, "%s\n");
  1391 print "\n";
  1392 foreach $section (@sections) {
  1393 my $lines = $section->index + 1;
  1394 if ($lines) {
  1395 my $name = $section->name;
  1396 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
  1397 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
  1398 $section->output(\*STDOUT, "\t{ %s }, /* %d */\n");
  1399 print "};\n\n";
  1400 }
  1401 }
  1402
  1403 $init->output(\*STDOUT, "\t%s\n", $init_name );
  1404 if ($verbose) {
  1405 warn compile_stats();
  1406 warn "NULLOP count: $nullop_count\n";
  1407 }
  1408 }
  1409
  1410 sub output_declarations {
  1411 print <<'EOT';
  1412 #ifdef BROKEN_STATIC_REDECL
  1413 #define Static extern
  1414 #else
  1415 #define Static static
  1416 #endif /* BROKEN_STATIC_REDECL */
  1417
  1418 #ifdef BROKEN_UNION_INIT
  1419 #error BROKEN_UNION_INIT no longer needed, as Perl requires an ANSI compiler
  1420 #endif
  1421
  1422 #define XPVCV_or_similar XPVCV
  1423 #define ANYINIT(i) {i}
  1424 #define Nullany ANYINIT(0)
  1425
  1426 #define UNUSED 0
  1427 #define sym_0 0
  1428 EOT
  1429 print "static GV *gv_list[$gv_index];\n" if $gv_index;
  1430 print "\n";
  1431 }
  1432
  1433
  1434 sub output_boilerplate {
  1435 print <<'EOT';
  1436 #include "EXTERN.h"
  1437 #include "perl.h"
  1438 #include "XSUB.h"
  1439
  1440 /* Workaround for mapstart: the only op which needs a different ppaddr */
  1441 #undef Perl_pp_mapstart
  1442 #define Perl_pp_mapstart Perl_pp_grepstart
  1443 #undef OP_MAPSTART
  1444 #define OP_MAPSTART OP_GREPSTART
  1445 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
  1446 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
  1447
  1448 static void xs_init (pTHX);
  1449 static void dl_init (pTHX);
  1450 static PerlInterpreter *my_perl;
  1451 EOT
  1452 }
  1453
  1454 sub init_op_addr {
  1455 my( $op_type, $num ) = @_;
  1456 my $op_list = $op_type."_list";
  1457
  1458 $init->add( split /\n/, <<EOT );
  1459 {
  1460 int i;
  1461
  1462 for( i = 0; i < ${num}; ++i )
  1463 {
  1464 ${op_list}\[i].op_ppaddr = PL_ppaddr[INT2PTR(int,${op_list}\[i].op_ppaddr)];
  1465 }
  1466 }
  1467 EOT
  1468 }
  1469
  1470 sub init_op_warn {
  1471 my( $op_type, $num ) = @_;
  1472 my $op_list = $op_type."_list";
  1473
  1474 # for resons beyond imagination, MSVC5 considers pWARN_ALL non-const
  1475 $init->add( split /\n/, <<EOT );
  1476 {
  1477 int i;
  1478
  1479 for( i = 0; i < ${num}; ++i )
  1480 {
  1481 switch( (int)(${op_list}\[i].cop_warnings) )
  1482 {
  1483 case 1:
  1484 ${op_list}\[i].cop_warnings = pWARN_ALL;
  1485 break;
  1486 case 2:
  1487 ${op_list}\[i].cop_warnings = pWARN_NONE;
  1488 break;
  1489 case 3:
  1490 ${op_list}\[i].cop_warnings = pWARN_STD;
  1491 break;
  1492 default:
  1493 break;
  1494 }
  1495 }
  1496 }
  1497 EOT
  1498 }
  1499
  1500 sub output_main {
  1501 print <<'EOT';
  1502 /* if USE_IMPLICIT_SYS, we need a 'real' exit */
  1503 #if defined(exit)
  1504 #undef exit
  1505 #endif
  1506
  1507 int
  1508 main(int argc, char **argv, char **env)
  1509 {
  1510 int exitstatus;
  1511 int i;
  1512 char **fakeargv;
  1513 GV* tmpgv;
  1514 SV* tmpsv;
  1515 int options_count;
  1516
  1517 PERL_SYS_INIT3(&argc,&argv,&env);
  1518
  1519 if (!PL_do_undump) {
  1520 my_perl = perl_alloc();
  1521 if (!my_perl)
  1522 exit(1);
  1523 perl_construct( my_perl );
  1524 PL_perl_destruct_level = 0;
  1525 }
  1526 EOT
  1527 if( $ithreads ) {
  1528 # XXX init free elems!
  1529 my $pad_len = regex_padav->FILL + 1 - 1; # first is an avref
  1530
  1531 print <<EOT;
  1532 #ifdef USE_ITHREADS
  1533 for( i = 0; i < $pad_len; ++i ) {
  1534 av_push( PL_regex_padav, newSViv(0) );
  1535 }
  1536 PL_regex_pad = AvARRAY( PL_regex_padav );
  1537 #endif
  1538 EOT
  1539 }
  1540
  1541 print <<'EOT';
  1542 #ifdef CSH
  1543 if (!PL_cshlen)
  1544 PL_cshlen = strlen(PL_cshname);
  1545 #endif
  1546
  1547 #ifdef ALLOW_PERL_OPTIONS
  1548 #define EXTRA_OPTIONS 3
  1549 #else
  1550 #define EXTRA_OPTIONS 4
  1551 #endif /* ALLOW_PERL_OPTIONS */
  1552 Newx(fakeargv, argc + EXTRA_OPTIONS + 1, char *);
  1553
  1554 fakeargv[0] = argv[0];
  1555 fakeargv[1] = "-e";
  1556 fakeargv[2] = "";
  1557 options_count = 3;
  1558 EOT
  1559 # honour -T
  1560 print <<EOT;
  1561 if( ${^TAINT} ) {
  1562 fakeargv[options_count] = "-T";
  1563 ++options_count;
  1564 }
  1565 EOT
  1566 print <<'EOT';
  1567 #ifndef ALLOW_PERL_OPTIONS
  1568 fakeargv[options_count] = "--";
  1569 ++options_count;
  1570 #endif /* ALLOW_PERL_OPTIONS */
  1571 for (i = 1; i < argc; i++)
  1572 fakeargv[i + options_count - 1] = argv[i];
  1573 fakeargv[argc + options_count - 1] = 0;
  1574
  1575 exitstatus = perl_parse(my_perl, xs_init, argc + options_count - 1,
  1576 fakeargv, NULL);
  1577
  1578 if (exitstatus)
  1579 exit( exitstatus );
  1580
  1581 TAINT;
  1582 EOT
  1583
  1584 if( $use_perl_script_name ) {
  1585 my $dollar_0 = $0;
  1586 $dollar_0 =~ s/\\/\\\\/g;
  1587 $dollar_0 = '"' . $dollar_0 . '"';
  1588
  1589 print <<EOT;
  1590 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */
  1591 tmpsv = GvSV(tmpgv);
  1592 sv_setpv(tmpsv, ${dollar_0});
  1593 SvSETMAGIC(tmpsv);
  1594 }
  1595 EOT
  1596 }
  1597 else {
  1598 print <<EOT;
  1599 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */
  1600 tmpsv = GvSV(tmpgv);
  1601 sv_setpv(tmpsv, argv[0]);
  1602 SvSETMAGIC(tmpsv);
  1603 }
  1604 EOT
  1605 }
  1606
  1607 print <<'EOT';
  1608 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
  1609 tmpsv = GvSV(tmpgv);
  1610 #ifdef WIN32
  1611 sv_setpv(tmpsv,"perl.exe");
  1612 #else
  1613 sv_setpv(tmpsv,"perl");
  1614 #endif
  1615 SvSETMAGIC(tmpsv);
  1616 }
  1617
  1618 TAINT_NOT;
  1619
  1620 /* PL_main_cv = PL_compcv; */
  1621 PL_compcv = 0;
  1622
  1623 exitstatus = perl_init();
  1624 if (exitstatus)
  1625 exit( exitstatus );
  1626 dl_init(aTHX);
  1627
  1628 exitstatus = perl_run( my_perl );
  1629
  1630 perl_destruct( my_perl );
  1631 perl_free( my_perl );
  1632
  1633 PERL_SYS_TERM();
  1634
  1635 exit( exitstatus );
  1636 }
  1637
  1638 /* yanked from perl.c */
  1639 static void
  1640 xs_init(pTHX)
  1641 {
  1642 char *file = __FILE__;
  1643 dTARG;
  1644 dSP;
  1645 EOT
  1646 print "\n#ifdef USE_DYNAMIC_LOADING";
  1647 print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
  1648 print "\n#endif\n" ;
  1649 # delete $xsub{'DynaLoader'};
  1650 delete $xsub{'UNIVERSAL'};
  1651 print("/* bootstrapping code*/\n\tSAVETMPS;\n");
  1652 print("\ttarg=sv_newmortal();\n");
  1653 print "#ifdef USE_DYNAMIC_LOADING\n";
  1654 print "\tPUSHMARK(sp);\n";
  1655 print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
  1656 print qq/\tPUTBACK;\n/;
  1657 print "\tboot_DynaLoader(aTHX_ NULL);\n";
  1658 print qq/\tSPAGAIN;\n/;
  1659 print "#endif\n";
  1660 foreach my $stashname (keys %xsub){
  1661 if ($xsub{$stashname} !~ m/Dynamic/ ) {
  1662 my $stashxsub=$stashname;
  1663 $stashxsub =~ s/::/__/g;
  1664 print "\tPUSHMARK(sp);\n";
  1665 print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
  1666 print qq/\tPUTBACK;\n/;
  1667 print "\tboot_$stashxsub(aTHX_ NULL);\n";
  1668 print qq/\tSPAGAIN;\n/;
  1669 }
  1670 }
  1671 print("\tFREETMPS;\n/* end bootstrapping code */\n");
  1672 print "}\n";
  1673
  1674 print <<'EOT';
  1675 static void
  1676 dl_init(pTHX)
  1677 {
  1678 char *file = __FILE__;
  1679 dTARG;
  1680 dSP;
  1681 EOT
  1682 print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
  1683 print("\ttarg=sv_newmortal();\n");
  1684 foreach my $stashname (@DynaLoader::dl_modules) {
  1685 warn "Loaded $stashname\n";
  1686 if (exists($xsub{$stashname}) && $xsub{$stashname} =~ m/Dynamic/) {
  1687 my $stashxsub=$stashname;
  1688 $stashxsub =~ s/::/__/g;
  1689 print "\tPUSHMARK(sp);\n";
  1690 print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
  1691 print qq/\tPUTBACK;\n/;
  1692 print "#ifdef USE_DYNAMIC_LOADING\n";
  1693 warn "bootstrapping $stashname added to xs_init\n";
  1694 if( $xsub{$stashname} eq 'Dynamic' ) {
  1695 print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
  1696 }
  1697 else {
  1698 print qq/\tperl_call_pv("XSLoader::load",G_DISCARD);\n/;
  1699 }
  1700 print "#else\n";
  1701 print "\tboot_$stashxsub(aTHX_ NULL);\n";
  1702 print "#endif\n";
  1703 print qq/\tSPAGAIN;\n/;
  1704 }
  1705 }
  1706 print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
  1707 print "}\n";
  1708 }
  1709 sub dump_symtable {
  1710 # For debugging
  1711 my ($sym, $val);
  1712 warn "----Symbol table:\n";
  1713 while (($sym, $val) = each %symtable) {
  1714 warn "$sym => $val\n";
  1715 }
  1716 warn "---End of symbol table\n";
  1717 }
  1718
  1719 sub save_object {
  1720 my $sv;
  1721 foreach $sv (@_) {
  1722 svref_2object($sv)->save;
  1723 }
  1724 }
  1725
  1726 sub Dummy_BootStrap { }
  1727
  1728 sub B::GV::savecv
  1729 {
  1730 my $gv = shift;
  1731 my $package=$gv->STASH->NAME;
  1732 my $name = $gv->NAME;
  1733 my $cv = $gv->CV;
  1734 my $sv = $gv->SV;
  1735 my $av = $gv->AV;
  1736 my $hv = $gv->HV;
  1737
  1738 my $fullname = $gv->STASH->NAME . "::" . $gv->NAME;
  1739
  1740 # We may be looking at this package just because it is a branch in the
  1741 # symbol table which is on the path to a package which we need to save
  1742 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
  1743 #
  1744 return unless ($unused_sub_packages{$package});
  1745 return unless ($$cv || $$av || $$sv || $$hv);
  1746 $gv->save;
  1747 }
  1748
  1749 sub mark_package
  1750 {
  1751 my $package = shift;
  1752 unless ($unused_sub_packages{$package})
  1753 {
  1754 no strict 'refs';
  1755 $unused_sub_packages{$package} = 1;
  1756 if (defined @{$package.'::ISA'})
  1757 {
  1758 foreach my $isa (@{$package.'::ISA'})
  1759 {
  1760 if ($isa eq 'DynaLoader')
  1761 {
  1762 unless (defined(&{$package.'::bootstrap'}))
  1763 {
  1764 warn "Forcing bootstrap of $package\n";
  1765 eval { $package->bootstrap };
  1766 }
  1767 }
  1768 # else
  1769 {
  1770 unless ($unused_sub_packages{$isa})
  1771 {
  1772 warn "$isa saved (it is in $package\'s \@ISA)\n";
  1773 mark_package($isa);
  1774 }
  1775 }
  1776 }
  1777 }
  1778 }
  1779 return 1;
  1780 }
  1781
  1782 sub should_save
  1783 {
  1784 no strict qw(vars refs);
  1785 my $package = shift;
  1786 $package =~ s/::$//;
  1787 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
  1788 # warn "Considering $package\n";#debug
  1789 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
  1790 {
  1791 # If this package is a prefix to something we are saving, traverse it
  1792 # but do not mark it for saving if it is not already
  1793 # e.g. to get to Getopt::Long we need to traverse Getopt but need
  1794 # not save Getopt
  1795 return 1 if ($u =~ /^$package\:\:/);
  1796 }
  1797 if (exists $unused_sub_packages{$package})
  1798 {
  1799 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
  1800 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
  1801 return $unused_sub_packages{$package};
  1802 }
  1803 # Omit the packages which we use (and which cause grief
  1804 # because of fancy "goto &$AUTOLOAD" stuff).
  1805 # XXX Surely there must be a nicer way to do this.
  1806 if ($package eq "FileHandle" || $package eq "Config" ||
  1807 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
  1808 {
  1809 delete_unsaved_hashINC($package);
  1810 return $unused_sub_packages{$package} = 0;
  1811 }
  1812 # Now see if current package looks like an OO class this is probably too strong.
  1813 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
  1814 {
  1815 if (UNIVERSAL::can($package, $m))
  1816 {
  1817 warn "$package has method $m: saving package\n";#debug
  1818 return mark_package($package);
  1819 }
  1820 }
  1821 delete_unsaved_hashINC($package);
  1822 return $unused_sub_packages{$package} = 0;
  1823 }
  1824 sub delete_unsaved_hashINC{
  1825 my $packname=shift;
  1826 $packname =~ s/\:\:/\//g;
  1827 $packname .= '.pm';
  1828 # warn "deleting $packname" if $INC{$packname} ;# debug
  1829 delete $INC{$packname};
  1830 }
  1831 sub walkpackages
  1832 {
  1833 my ($symref, $recurse, $prefix) = @_;
  1834 my $sym;
  1835 my $ref;
  1836 no strict 'vars';
  1837 $prefix = '' unless defined $prefix;
  1838 while (($sym, $ref) = each %$symref)
  1839 {
  1840 local(*glob);
  1841 *glob = $ref;
  1842 if ($sym =~ /::$/)
  1843 {
  1844 $sym = $prefix . $sym;
  1845 if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym))
  1846 {
  1847 walkpackages(\%glob, $recurse, $sym);
  1848 }
  1849 }
  1850 }
  1851 }
  1852
  1853
  1854 sub save_unused_subs
  1855 {
  1856 no strict qw(refs);
  1857 &descend_marked_unused;
  1858 warn "Prescan\n";
  1859 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
  1860 warn "Saving methods\n";
  1861 walksymtable(\%{"main::"}, "savecv", \&should_save);
  1862 }
  1863
  1864 sub save_context
  1865 {
  1866 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
  1867 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
  1868 my $inc_hv = svref_2object(\%INC)->save;
  1869 my $inc_av = svref_2object(\@INC)->save;
  1870 my $amagic_generate= amagic_generation;
  1871 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
  1872 "GvHV(PL_incgv) = $inc_hv;",
  1873 "GvAV(PL_incgv) = $inc_av;",
  1874 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
  1875 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
  1876 "PL_amagic_generation= $amagic_generate;" );
  1877 }
  1878
  1879 sub descend_marked_unused {
  1880 foreach my $pack (keys %unused_sub_packages)
  1881 {
  1882 mark_package($pack);
  1883 }
  1884 }
  1885
  1886 sub save_main {
  1887 # this is mainly for the test suite
  1888 my $warner = $SIG{__WARN__};
  1889 local $SIG{__WARN__} = sub { print STDERR @_ };
  1890
  1891 warn "Starting compile\n";
  1892 warn "Walking tree\n";
  1893 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
  1894 walkoptree(main_root, "save");
  1895 warn "done main optree, walking symtable for extras\n" if $debug_cv;
  1896 save_unused_subs();
  1897 # XSLoader was used, force saving of XSLoader::load
  1898 if( $use_xsloader ) {
  1899 my $cv = svref_2object( \&XSLoader::load );
  1900 $cv->save;
  1901 }
  1902 # save %SIG ( in case it was set in a BEGIN block )
  1903 if( $save_sig ) {
  1904 local $SIG{__WARN__} = $warner;
  1905 $init->no_split;
  1906 $init->add("{", "\tHV* hv = get_hv(\"main::SIG\",1);" );
  1907 foreach my $k ( keys %SIG ) {
  1908 next unless ref $SIG{$k};
  1909 my $cv = svref_2object( \$SIG{$k} );
  1910 my $sv = $cv->save;
  1911 $init->add('{',sprintf 'SV* sv = (SV*)%s;', $sv );
  1912 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
  1913 cstring($k),length(pack "a*",$k),
  1914 'sv', hash($k)));
  1915 $init->add('mg_set(sv);','}');
  1916 }
  1917 $init->add('}');
  1918 $init->split;
  1919 }
  1920 # honour -w
  1921 $init->add( sprintf " PL_dowarn = ( %s ) ? G_WARN_ON : G_WARN_OFF;", $^W );
  1922 #
  1923 my $init_av = init_av->save;
  1924 my $end_av = end_av->save;
  1925 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
  1926 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
  1927 "PL_initav = (AV *) $init_av;",
  1928 "PL_endav = (AV*) $end_av;");
  1929 save_context();
  1930 # init op addrs ( must be the last action, otherwise
  1931 # some ops might not be initialized
  1932 if( $optimize_ppaddr ) {
  1933 foreach my $i ( @op_sections ) {
  1934 my $section = $$i;
  1935 next unless $section->index >= 0;
  1936 init_op_addr( $section->name, $section->index + 1);
  1937 }
  1938 }
  1939 init_op_warn( $copsect->name, $copsect->index + 1)
  1940 if $optimize_warn_sv && $copsect->index >= 0;
  1941
  1942 warn "Writing output\n";
  1943 output_boilerplate();
  1944 print "\n";
  1945 output_all("perl_init");
  1946 print "\n";
  1947 output_main();
  1948 }
  1949
  1950 sub init_sections {
  1951 my @sections = (decl => \$decl, sym => \$symsect,
  1952 binop => \$binopsect, condop => \$condopsect,
  1953 cop => \$copsect, padop => \$padopsect,
  1954 listop => \$listopsect, logop => \$logopsect,
  1955 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
  1956 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
  1957 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
  1958 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
  1959 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
  1960 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
  1961 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
  1962 xpvio => \$xpviosect);
  1963 my ($name, $sectref);
  1964 while (($name, $sectref) = splice(@sections, 0, 2)) {
  1965 $$sectref = new B::C::Section $name, \%symtable, 0;
  1966 }
  1967 $init = new B::C::InitSection 'init', \%symtable, 0;
  1968 }
  1969
  1970 sub mark_unused
  1971 {
  1972 my ($arg,$val) = @_;
  1973 $unused_sub_packages{$arg} = $val;
  1974 }
  1975
  1976 sub compile {
  1977 my @options = @_;
  1978 my ($option, $opt, $arg);
  1979 my @eval_at_startup;
  1980 my %option_map = ( 'cog' => \$pv_copy_on_grow,
  1981 'save-data' => \$save_data_fh,
  1982 'ppaddr' => \$optimize_ppaddr,
  1983 'warn-sv' => \$optimize_warn_sv,
  1984 'use-script-name' => \$use_perl_script_name,
  1985 'save-sig-hash' => \$save_sig,
  1986 );
  1987 my %optimization_map = ( 0 => [ qw() ], # special case
  1988 1 => [ qw(-fcog) ],
  1989 2 => [ qw(-fwarn-sv -fppaddr) ],
  1990 );
  1991 OPTION:
  1992 while ($option = shift @options) {
  1993 if ($option =~ /^-(.)(.*)/) {
  1994 $opt = $1;
  1995 $arg = $2;
  1996 } else {
  1997 unshift @options, $option;
  1998 last OPTION;
  1999 }
  2000 if ($opt eq "-" && $arg eq "-") {
  2001 shift @options;
  2002 last OPTION;
  2003 }
  2004 if ($opt eq "w") {
  2005 $warn_undefined_syms = 1;
  2006 } elsif ($opt eq "D") {
  2007 $arg ||= shift @options;
  2008 foreach $arg (split(//, $arg)) {
  2009 if ($arg eq "o") {
  2010 B->debug(1);
  2011 } elsif ($arg eq "c") {
  2012 $debug_cops = 1;
  2013 } elsif ($arg eq "A") {
  2014 $debug_av = 1;
  2015 } elsif ($arg eq "C") {
  2016 $debug_cv = 1;
  2017 } elsif ($arg eq "M") {
  2018 $debug_mg = 1;
  2019 } else {
  2020 warn "ignoring unknown debug option: $arg\n";
  2021 }
  2022 }
  2023 } elsif ($opt eq "o") {
  2024 $arg ||= shift @options;
  2025 open(STDOUT, ">$arg") or return "$arg: $!\n";
  2026 } elsif ($opt eq "v") {
  2027 $verbose = 1;
  2028 } elsif ($opt eq "u") {
  2029 $arg ||= shift @options;
  2030 mark_unused($arg,undef);
  2031 } elsif ($opt eq "f") {
  2032 $arg ||= shift @options;
  2033 $arg =~ m/(no-)?(.*)/;
  2034 my $no = defined($1) && $1 eq 'no-';
  2035 $arg = $no ? $2 : $arg;
  2036 if( exists $option_map{$arg} ) {
  2037 ${$option_map{$arg}} = !$no;
  2038 } else {
  2039 die "Invalid optimization '$arg'";
  2040 }
  2041 } elsif ($opt eq "O") {
  2042 $arg = 1 if $arg eq "";
  2043 my @opt;
  2044 foreach my $i ( 1 .. $arg ) {
  2045 push @opt, @{$optimization_map{$i}}
  2046 if exists $optimization_map{$i};
  2047 }
  2048 unshift @options, @opt;
  2049 } elsif ($opt eq "e") {
  2050 push @eval_at_startup, $arg;
  2051 } elsif ($opt eq "l") {
  2052 $max_string_len = $arg;
  2053 }
  2054 }
  2055 init_sections();
  2056 foreach my $i ( @eval_at_startup ) {
  2057 $init->add_eval( $i );
  2058 }
  2059 if (@options) {
  2060 return sub {
  2061 my $objname;
  2062 foreach $objname (@options) {
  2063 eval "save_object(\\$objname)";
  2064 }
  2065 output_all();
  2066 }
  2067 } else {
  2068 return sub { save_main() };
  2069 }
  2070 }
  2071
  2072 1;
  2073
  2074 __END__
  2075
  2076 =head1 NAME
  2077
  2078 B::C - Perl compiler's C backend
  2079
  2080 =head1 SYNOPSIS
  2081
  2082 perl -MO=C[,OPTIONS] foo.pl
  2083
  2084 =head1 DESCRIPTION
  2085
  2086 This compiler backend takes Perl source and generates C source code
  2087 corresponding to the internal structures that perl uses to run
  2088 your program. When the generated C source is compiled and run, it
  2089 cuts out the time which perl would have taken to load and parse
  2090 your program into its internal semi-compiled form. That means that
  2091 compiling with this backend will not help improve the runtime
  2092 execution speed of your program but may improve the start-up time.
  2093 Depending on the environment in which your program runs this may be
  2094 either a help or a hindrance.
  2095
  2096 =head1 OPTIONS
  2097
  2098 If there are any non-option arguments, they are taken to be
  2099 names of objects to be saved (probably doesn't work properly yet).
  2100 Without extra arguments, it saves the main program.
  2101
  2102 =over 4
  2103
  2104 =item B<-ofilename>
  2105
  2106 Output to filename instead of STDOUT
  2107
  2108 =item B<-v>
  2109
  2110 Verbose compilation (currently gives a few compilation statistics).
  2111
  2112 =item B<-->
  2113
  2114 Force end of options
  2115
  2116 =item B<-uPackname>
  2117
  2118 Force apparently unused subs from package Packname to be compiled.
  2119 This allows programs to use eval "foo()" even when sub foo is never
  2120 seen to be used at compile time. The down side is that any subs which
  2121 really are never used also have code generated. This option is
  2122 necessary, for example, if you have a signal handler foo which you
  2123 initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
  2124 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
  2125 options. The compiler tries to figure out which packages may possibly
  2126 have subs in which need compiling but the current version doesn't do
  2127 it very well. In particular, it is confused by nested packages (i.e.
  2128 of the form C<A::B>) where package C<A> does not contain any subs.
  2129
  2130 =item B<-D>
  2131
  2132 Debug options (concatenated or separate flags like C<perl -D>).
  2133
  2134 =item B<-Do>
  2135
  2136 OPs, prints each OP as it's processed
  2137
  2138 =item B<-Dc>
  2139
  2140 COPs, prints COPs as processed (incl. file & line num)
  2141
  2142 =item B<-DA>
  2143
  2144 prints AV information on saving
  2145
  2146 =item B<-DC>
  2147
  2148 prints CV information on saving
  2149
  2150 =item B<-DM>
  2151
  2152 prints MAGIC information on saving
  2153
  2154 =item B<-f>
  2155
  2156 Force options/optimisations on or off one at a time. You can explicitly
  2157 disable an option using B<-fno-option>. All options default to
  2158 B<disabled>.
  2159
  2160 =over 4
  2161
  2162 =item B<-fcog>
  2163
  2164 Copy-on-grow: PVs declared and initialised statically.
  2165
  2166 =item B<-fsave-data>
  2167
  2168 Save package::DATA filehandles ( only available with PerlIO ).
  2169
  2170 =item B<-fppaddr>
  2171
  2172 Optimize the initialization of op_ppaddr.
  2173
  2174 =item B<-fwarn-sv>
  2175
  2176 Optimize the initialization of cop_warnings.
  2177
  2178 =item B<-fuse-script-name>
  2179
  2180 Use the script name instead of the program name as $0.
  2181
  2182 =item B<-fsave-sig-hash>
  2183
  2184 Save compile-time modifications to the %SIG hash.
  2185
  2186 =back
  2187
  2188 =item B<-On>
  2189
  2190 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
  2191
  2192 =over 4
  2193
  2194 =item B<-O0>
  2195
  2196 Disable all optimizations.
  2197
  2198 =item B<-O1>
  2199
  2200 Enable B<-fcog>.
  2201
  2202 =item B<-O2>
  2203
  2204 Enable B<-fppaddr>, B<-fwarn-sv>.
  2205
  2206 =back
  2207
  2208 =item B<-llimit>
  2209
  2210 Some C compilers impose an arbitrary limit on the length of string
  2211 constants (e.g. 2048 characters for Microsoft Visual C++). The
  2212 B<-llimit> options tells the C backend not to generate string literals
  2213 exceeding that limit.
  2214
  2215 =back
  2216
  2217 =head1 EXAMPLES
  2218
  2219 perl -MO=C,-ofoo.c foo.pl
  2220 perl cc_harness -o foo foo.c
  2221
  2222 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
  2223 library directory. The utility called C<perlcc> may also be used to
  2224 help make use of this compiler.
  2225
  2226 perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null
  2227
  2228 =head1 BUGS
  2229
  2230 Plenty. Current status: experimental.
  2231
  2232 =head1 AUTHOR
  2233
  2234 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
  2235
  2236 =cut
Powered by Google Project Hosting