1#      C.pm
2#
3#      Copyright (c) 1996, 1997, 1998 Malcolm Beattie
4#      Copyright (c) 2008, 2009, 2010, 2011 Reini Urban
5#      Copyright (c) 2010 Nick Koston
6#      Copyright (c) 2011, 2012, 2013, 2014, 2015, 2016, 2017 cPanel Inc
7#      Copyright (c) 2017, 2018, 2019 Reini Urban
8#
9#      You may distribute under the terms of either the GNU General Public
10#      License or the Artistic License, as specified in the README file.
11#
12
13package B::C;
14use strict;
15
16our $VERSION = '1.57';
17our (%debug, $check, %Config, %Cross, %OriConfig, $cross);
18BEGIN {
19  require B::C::Config;
20  *Config = \%B::C::Config::Config;
21  if (!keys %Config) { #or !exists $Config{usecperl}
22    warn "Empty \%B::C::Config::Config";
23    require Config;
24    Config->import;
25  }
26  # make it a restricted hash
27  Internals::SvREADONLY(%Config, 1) if $] >= 5.008004;
28}
29
30# Thanks to Mattia Barbon for the C99 tip to init any union members
31my $C99 = $Config{d_c99_variadic_macros}; # http://docs.sun.com/source/819-3688/c99.app.html#pgfId-1003962
32
33package B::C::Section;
34use strict;
35
36my %sections;
37
38sub new {
39  my ($class, $section, $symtable, $default) = @_;
40  my $o = bless [-1, $section, $symtable, $default], $class;
41  $sections{$section} = $o;
42
43  push @$o, { values => [] };
44
45  # if sv add a dummy sv_arenaroot to support global destruction
46  if ($section eq 'sv') {
47    # 0 refcnt placeholder for the static arenasize later adjusted
48    $o->add( "NULL, 0, SVTYPEMASK|0x01000000".($] >= 5.009005?", {0}":'')); # SVf_FAKE
49    $o->[-1]{dbg}->[0] = "PL_sv_arenaroot";
50  }
51  return $o;
52}
53
54sub get {
55  my ($class, $section) = @_;
56  return $sections{$section};
57}
58
59sub add {
60  my $section = shift;
61  push( @{ $section->[-1]{values} }, @_ );
62}
63
64sub remove {
65  my $section = shift;
66  pop @{ $section->[-1]{values} };
67}
68
69sub index {
70  my $section = shift;
71  return scalar( @{ $section->[-1]{values} } ) - 1;
72}
73
74sub name {
75  my $section = shift;
76  return $section->[1];
77}
78
79sub symtable {
80  my $section = shift;
81  return $section->[2];
82}
83
84sub default {
85  my $section = shift;
86  return $section->[3];
87}
88
89sub typename {
90  my $section = shift;
91  my $name = $section->name;
92  my $typename = uc($name);
93  # -fcog hack to statically initialize PVs (SVPV for 5.10-5.11 only)
94  $typename = 'SVPV' if $typename eq 'SV' and $] > 5.009005 and $] < 5.012 and !$C99;
95  # $typename = 'const '.$typename if $name !~ /^(cop_|sv_)/;
96  $typename = 'UNOP_AUX' if $typename eq 'UNOPAUX';
97  $typename = 'SV*' if $typename =~ /^AVCO[WG]_/;
98  #$typename = 'MyPADNAME' if $typename eq 'PADNAME' and $] >= 5.018;
99  return $typename;
100}
101
102sub comment {
103  my $section = shift;
104  $section->[-1]{comment} = join( "", @_ ) if @_;
105  $section->[-1]{comment};
106}
107
108# add debugging info - stringified flags on -DF
109sub debug {
110  my $section = shift;
111  my $dbg = join( " ", @_ );
112  $section->[-1]{dbg}->[ $section->index ] = $dbg if $dbg;
113}
114
115sub output {
116  my ( $section, $fh, $format ) = @_;
117  my $sym = $section->symtable || {};
118  my $default = $section->default;
119  return if $B::C::check;
120  my $i = 0;
121  my $dodbg = 1 if $debug{flags} and $section->[-1]{dbg};
122  if ($section->name eq 'sv') { #fixup arenaroot refcnt
123    my $len = scalar @{ $section->[-1]{values} };
124    $section->[-1]{values}->[0] =~ s/^NULL, 0/NULL, $len/;
125  }
126  foreach ( @{ $section->[-1]{values} } ) {
127    my $dbg = "";
128    my $ref = "";
129    if (m/(s\\_[0-9a-f]+)/) {
130      if (!exists($sym->{$1}) and $1 ne 's\_0') {
131        $ref = $1;
132        $B::C::unresolved_count++;
133        if ($B::C::verbose) {
134          my $caller = caller(1);
135          warn "Warning: unresolved ".$section->name." symbol $ref\n"
136            if $caller eq 'B::C';
137        }
138      }
139    }
140    s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
141    if ($dodbg and $section->[-1]{dbg}->[$i]) {
142      $dbg = " /* ".$section->[-1]{dbg}->[$i]." ".$ref." */";
143    }
144    if ($format eq "\t{ %s }, /* %s_list[%d] %s */%s\n") {
145      printf $fh $format, $_, $section->name, $i, $ref, $dbg;
146    } else {
147      printf $fh $format, $_;
148    }
149    ++$i;
150  }
151}
152
153package B::C::InitSection;
154use strict;
155
156# avoid use vars
157@B::C::InitSection::ISA = qw(B::C::Section);
158
159sub new {
160  my $class     = shift;
161  my $max_lines = 10000;                    #pop;
162  my $section   = $class->SUPER::new(@_);
163
164  $section->[-1]{evals}     = [];
165  $section->[-1]{initav}    = [];
166  $section->[-1]{chunks}    = [];
167  $section->[-1]{nosplit}   = 0;
168  $section->[-1]{current}   = [];
169  $section->[-1]{count}     = 0;
170  $section->[-1]{size}      = 0;
171  $section->[-1]{max_lines} = $max_lines;
172
173  return $section;
174}
175
176sub split {
177  my $section = shift;
178  $section->[-1]{nosplit}--
179    if $section->[-1]{nosplit} > 0;
180}
181
182sub no_split {
183  shift->[-1]{nosplit}++;
184}
185
186sub inc_count {
187  my $section = shift;
188
189  $section->[-1]{count} += $_[0];
190
191  # this is cheating
192  $section->add();
193}
194
195sub add {
196  my $section = shift->[-1];
197  my $current = $section->{current};
198  my $nosplit = $section->{nosplit};
199
200  push @$current, @_;
201  $section->{count} += scalar(@_);
202  if ( !$nosplit && $section->{count} >= $section->{max_lines} ) {
203    push @{ $section->{chunks} }, $current;
204    $section->{current} = [];
205    $section->{count}   = 0;
206  }
207}
208
209sub add_eval {
210  my $section = shift;
211  my @strings = @_;
212
213  foreach my $i (@strings) {
214    $i =~ s/\"/\\\"/g;
215  }
216  push @{ $section->[-1]{evals} }, @strings;
217}
218
219sub pre_destruct {
220  my $section = shift;
221  push @{ $section->[-1]{pre_destruct} }, @_;
222}
223
224sub add_initav {
225  my $section = shift;
226  push @{ $section->[-1]{initav} }, @_;
227}
228
229sub output {
230  my ( $section, $fh, $format, $init_name ) = @_;
231  my $sym = $section->symtable || {};
232  my $default = $section->default;
233  return if $B::C::check;
234  push @{ $section->[-1]{chunks} }, $section->[-1]{current};
235
236  my $name = "aaaa";
237  foreach my $i ( @{ $section->[-1]{chunks} } ) {
238    # dTARG and dSP unused -nt
239    print $fh <<"EOT";
240static void ${init_name}_${name}(pTHX)
241{
242	dVAR;
243EOT
244    foreach my $i ( @{ $section->[-1]{initav} } ) {
245      print $fh "\t",$i,"\n";
246    }
247    foreach my $j (@$i) {
248      $j =~ s{(s\\_[0-9a-f]+)}
249                   { exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
250      print $fh "\t$j\n";
251    }
252    if (@{ $section->[-1]{evals} }) {
253      # We need to output evals after dl_init, in init2
254      if ($section->name ne 'init2') {
255        die "Invalid section ".$section->name."->add_eval, use init2";
256      } else {
257        foreach my $s ( @{ $section->[-1]{evals} } ) {
258          print $fh "\teval_pv(\"$s\",1);\n";
259        }
260      }
261    }
262    print $fh "}\n";
263
264    $section->SUPER::add("${init_name}_${name}(aTHX);");
265    ++$name;
266  }
267
268  print $fh <<"EOT";
269PERL_STATIC_INLINE int ${init_name}(pTHX)
270{
271EOT
272  if ($section->name eq 'init') {
273    print $fh "\tperl_init0(aTHX);\n";
274  }
275  $section->SUPER::output( $fh, $format );
276  print $fh "\treturn 0;\n}\n";
277}
278
279package B::C;
280use strict;
281use Exporter ();
282use Errno (); #needed since 5.14
283our %Regexp;
284
285{ # block necessary for caller to work
286  my $caller = caller;
287  if ( $caller eq 'O' or $caller eq 'Od' ) {
288    require XSLoader;
289    XSLoader::load('B::C'); # for r-magic and for utf8-keyed B::HV->ARRAY
290  }
291}
292
293our @ISA        = qw(Exporter);
294our @EXPORT_OK =
295  qw(output_all output_boilerplate output_main output_main_rest mark_unused mark_skip
296     init_sections set_callback save_unused_subs objsym save_context fixup_ppaddr
297     save_sig svop_or_padop_pv inc_cleanup ivx nvx curcv set_curcv cross_config);
298
299# for 5.6.[01] better use the native B::C
300# but 5.6.2 works fine
301use B
302  qw(minus_c sv_undef walkoptree walkoptree_slow main_root main_start peekop
303     cchar svref_2object compile_stats comppadlist hash
304     threadsv_names main_cv init_av end_av opnumber cstring
305     HEf_SVKEY SVf_POK SVp_POK SVf_ROK SVf_IOK SVf_NOK SVf_IVisUV SVf_READONLY);
306
307# usually 0x400000, but can be as low as 0x10000
308# http://docs.embarcadero.com/products/rad_studio/delphiAndcpp2009/HelpUpdate2/EN/html/devcommon/compdirsimagebaseaddress_xml.html
309# called mapped_base on linux (usually 0xa38000)
310sub LOWEST_IMAGEBASE() {0x10000}
311
312sub _load_mro {
313    eval q/require mro; 1/ or die if $] >= 5.010;
314    *_load_mro = sub {};
315}
316
317sub is_using_mro {
318  return keys %{mro::} > 10 ? 1 : 0;
319}
320
321BEGIN {
322  if ($] >=  5.008) {
323    @B::NV::ISA = 'B::IV';		  # add IVX to nv. This fixes test 23 for Perl 5.8
324    B->import(qw(regex_padav SVp_NOK SVp_IOK CVf_CONST CVf_ANON
325                 SVf_FAKE)); # both unsupported for 5.6
326    eval q[
327      sub SVs_OBJECT() {0x00100000}
328      sub SVf_AMAGIC() {0x10000000}
329     ];
330  } else {
331    eval q[
332      sub SVp_NOK() {0}; # unused
333      sub SVp_IOK() {0};
334      sub CVf_ANON() {4};
335      sub CVf_CONST() {0}; # unused
336      sub PMf_ONCE() {0xff}; # unused
337      sub SVf_FAKE() {0x00100000}; # unused
338      sub SVs_OBJECT() {0x00001000}
339      sub SVf_AMAGIC() {0x10000000}
340     ];
341    @B::PVMG::ISA = qw(B::PVNV B::RV);
342  }
343  # used since 5.27.3/5.27.2c only
344  sub SVt_PVLV()  { 13 }
345  sub SVf_UTF8 { 0x20000000 }
346  if ($] >=  5.008001) {
347    B->import(qw(SVt_PVGV CVf_WEAKOUTSIDE)); # added with 5.8.1
348  } else {
349    eval q[sub SVt_PVGV() {13}];
350    eval q[sub CVf_WEAKOUTSIDE() { 0x0 }]; # unused
351  }
352  if ($] >= 5.010) {
353    #require mro; # mro->import();
354    # not exported:
355    sub SVf_OOK { 0x02000000 }
356    eval q[sub SVs_GMG() { 0x00200000 }
357           sub SVs_SMG() { 0x00400000 }];
358    if ($] >= 5.018) {
359      B->import(qw(PMf_EVAL RXf_EVAL_SEEN));
360      eval q[sub PMf_ONCE(){ 0x10000 }]; # PMf_ONCE also not exported
361    } elsif ($] >= 5.014) {
362      eval q[sub PMf_ONCE(){ 0x8000 }];
363    } elsif ($] >= 5.012) {
364      eval q[sub PMf_ONCE(){ 0x0080 }];
365    } else { # 5.10. not used with <= 5.8
366      eval q[sub PMf_ONCE(){ 0x0002 }];
367    }
368    if ($] > 5.021006) {
369      B->import(qw(SVf_PROTECT CVf_ANONCONST SVs_PADSTALE));
370    } else {
371      eval q[sub SVf_PROTECT()  { 0x0 }
372             sub CVf_ANONCONST(){ 0x0 }
373             sub SVs_PADSTALE() { 0x0 }
374            ]; # unused
375    }
376  } else {
377    eval q[sub SVs_GMG()    { 0x00002000 }
378           sub SVs_SMG()    { 0x00004000 }
379           sub SVf_PROTECT(){ 0x0 }
380           sub CVf_ANONCONST(){ 0x0 }
381           sub SVs_PADSTALE() { 0x0 }
382          ]; # unused
383  }
384  if ($] < 5.018) {
385    eval q[sub RXf_EVAL_SEEN() { 0x0 }
386           sub PMf_EVAL()      { 0x0 }
387           sub SVf_IsCOW()     { 0x0 }
388           ]; # unused
389  } else {
390    # 5.18
391    B->import(qw(SVf_IsCOW));
392    #if (exists ${B::}{PADNAME::}) {
393      @B::PADNAME::ISA = qw(B::PV);
394    #}
395    #if (exists ${B::}{PADLIST::}) {
396      @B::PADLIST::ISA = qw(B::AV);
397    #}
398    #if (exists ${B::}{PADNAMELIST::}) {
399    if ($] > 5.021005) { # 5.22
400      @B::PADNAME::ISA = ();
401      @B::PADNAMELIST::ISA = qw(B::AV);
402    }
403    if ($Config{usecperl} and $] >= 5.022002) {
404      eval q[sub SVpav_REAL () { 0x40000000 }
405             sub SVpav_REIFY (){ 0x80000000 }
406            ];
407    }
408  }
409}
410use B::Asmdata qw(@specialsv_name);
411
412use FileHandle;
413
414my $hv_index      = 0;
415my $gv_index      = 0;
416my $re_index      = 0;
417my $pv_index      = 0;
418my $cv_index      = 0;
419my $hek_index     = 0;
420my $anonsub_index = 0;
421my $initsub_index = 0;
422my $padlist_index = 0;
423my $padname_index = 0;
424my $padnl_index = 0;
425
426# exclude all not B::C:: prefixed subs
427my %all_bc_subs = map {$_=>1}
428  qw(B::AV::save B::BINOP::save B::BM::save B::COP::save B::CV::save
429     B::FAKEOP::fake_ppaddr B::FAKEOP::flags B::FAKEOP::new B::FAKEOP::next
430     B::FAKEOP::ppaddr B::FAKEOP::private B::FAKEOP::save B::FAKEOP::sibling
431     B::FAKEOP::targ B::FAKEOP::type B::GV::save B::GV::savecv B::HV::save
432     B::IO::save B::IO::save_data B::IV::save B::LISTOP::save B::LOGOP::save
433     B::LOOP::save B::NULL::save B::NV::save B::OBJECT::save
434     B::OP::_save_common B::OP::fake_ppaddr B::OP::isa B::OP::save
435     B::PADOP::save B::PMOP::save B::PV::save
436     B::PVIV::save B::PVLV::save B::PVMG::save B::PVMG::save_magic B::PVNV::save
437     B::PVOP::save B::REGEXP::save B::RV::save B::SPECIAL::save B::SPECIAL::savecv
438     B::SV::save B::SVOP::save B::UNOP::save B::UV::save B::REGEXP::EXTFLAGS);
439
440# track all internally used packages. all other may not be deleted automatically
441# - hidden methods
442# uses now @B::C::Config::deps
443our %all_bc_deps = map {$_=>1}
444  @B::C::Config::deps ? @B::C::Config::deps
445  : qw(AnyDBM_File AutoLoader B B::AV B::Asmdata B::BINOP B::BM B::C B::C::Config B::C::InitSection B::C::Section B::CC B::COP B::CV B::FAKEOP B::FM B::GV B::HE B::HV B::IO B::IV B::LEXWARN B::LISTOP B::LOGOP B::LOOP B::MAGIC B::NULL B::NV B::OBJECT B::OP B::PADLIST B::PADNAME B::PADNAMELIST B::PADOP B::PMOP B::PV B::PVIV B::PVLV B::PVMG B::PVNV B::PVOP B::REGEXP B::RHE B::RV B::SPECIAL B::STASHGV B::SV B::SVOP B::UNOP B::UV CORE CORE::GLOBAL Carp DB DynaLoader Errno Exporter Exporter::Heavy ExtUtils ExtUtils::Constant ExtUtils::Constant::ProxySubs Fcntl FileHandle IO IO::File IO::Handle IO::Poll IO::Seekable IO::Socket Internals O POSIX PerlIO PerlIO::Layer PerlIO::scalar Regexp SelectSaver Symbol UNIVERSAL XSLoader __ANON__ arybase arybase::mg base fields main maybe maybe::next mro next overload re strict threads utf8 vars version warnings warnings::register);
446$all_bc_deps{Socket} = 1 if !@B::C::Config::deps and $] > 5.021;
447$all_bc_deps{overloading} = 1 if !@B::C::Config::deps and $] >= 5.027003;
448
449# B::C stash footprint: mainly caused by blib, warnings, and Carp loaded with DynaLoader
450# perl5.15.7d-nt -MO=C,-o/dev/null -MO=Stash -e0
451# -umain,-ure,-umro,-ustrict,-uAnyDBM_File,-uFcntl,-uRegexp,-uoverload,-uErrno,-uExporter,-uExporter::Heavy,-uConfig,-uwarnings,-uwarnings::register,-uDB,-unext,-umaybe,-umaybe::next,-uFileHandle,-ufields,-uvars,-uAutoLoader,-uCarp,-uSymbol,-uPerlIO,-uPerlIO::scalar,-uSelectSaver,-uExtUtils,-uExtUtils::Constant,-uExtUtils::Constant::ProxySubs,-uthreads,-ubase
452# perl5.15.7d-nt -MErrno -MO=Stash -e0
453# -umain,-ure,-umro,-ustrict,-uRegexp,-uoverload,-uErrno,-uExporter,-uExporter::Heavy,-uwarnings,-uwarnings::register,-uConfig,-uDB,-uvars,-uCarp,-uPerlIO,-uthreads
454# perl5.15.7d-nt -Mblib -MO=Stash -e0
455# -umain,-ure,-umro,-ustrict,-uCwd,-uRegexp,-uoverload,-uFile,-uFile::Spec,-uFile::Spec::Unix,-uDos,-uExporter,-uExporter::Heavy,-uConfig,-uwarnings,-uwarnings::register,-uDB,-uEPOC,-ublib,-uScalar,-uScalar::Util,-uvars,-uCarp,-uVMS,-uVMS::Filespec,-uVMS::Feature,-uWin32,-uPerlIO,-uthreads
456# perl -MO=Stash -e0
457# -umain,-uTie,-uTie::Hash,-ure,-umro,-ustrict,-uRegexp,-uoverload,-uExporter,-uExporter::Heavy,-uwarnings,-uDB,-uCarp,-uPerlIO,-uthreads
458# pb -MB::Stash -e0
459# -umain,-ure,-umro,-uRegexp,-uPerlIO,-uExporter,-uDB
460
461my ($prev_op, $package_pv, @package_pv); # global stash for methods since 5.13
462my (%symtable, %cvforward, %lexwarnsym);
463my (%strtable, %stashtable, %hektable, %statichektable, %gptable, %cophhtable, %copgvtable);
464my (%xsub, %init2_remap);
465my ($warn_undefined_syms, $swash_init, $swash_ToCf);
466my ($staticxs, $outfile);
467my (%include_package, %dumped_package, %skip_package, %isa_cache, %static_ext);
468my ($use_xsloader, $Devel_Peek_Dump_added);
469my $nullop_count         = 0;
470my $unresolved_count     = 0;
471# options and optimizations shared with B::CC
472our ($module, $init_name, %savINC, %curINC, $mainfile, @static_free);
473our ($use_av_undef_speedup, $use_svpop_speedup) = (1, 1);
474our ($optimize_ppaddr, $optimize_warn_sv, $use_perl_script_name,
475    $save_data_fh, $save_sig, $optimize_cop, $av_init, $av_init2, $ro_inc, $destruct,
476    $fold, $warnings, $const_strings, $stash, $can_delete_pkg, $pv_copy_on_grow, $dyn_padlist,
477    $walkall, $cow);
478our $verbose = 0;
479our %option_map = (
480    #ignored until IsCOW has a seperate COWREFCNT field (5.22 maybe)
481    'cog'             => \$B::C::pv_copy_on_grow,
482    'const-strings'   => \$B::C::const_strings,
483    'save-data'       => \$B::C::save_data_fh,
484    'ppaddr'          => \$B::C::optimize_ppaddr,
485    'walkall'         => \$B::C::walkall,
486    'warn-sv'         => \$B::C::optimize_warn_sv,
487    'av-init'         => \$B::C::av_init,
488    'av-init2'        => \$B::C::av_init2,
489    'delete-pkg'      => \$B::C::can_delete_pkg,
490    'ro-inc'          => \$B::C::ro_inc,
491    # if to disable the COW flag since 5.18
492    'cow'             => \$B::C::cow,      # enable with -O2
493    'stash'           => \$B::C::stash,    # enable with -fstash
494    'destruct'        => \$B::C::destruct, # disable with -fno-destruct
495    'fold'            => \$B::C::fold,     # disable with -fno-fold
496    'warnings'        => \$B::C::warnings, # disable with -fno-warnings
497    'use-script-name' => \$use_perl_script_name,
498    'save-sig-hash'   => \$B::C::save_sig,
499    'dyn-padlist'     => \$B::C::dyn_padlist, # with -O4, needed for cv cleanup with
500	                                      # non-local exits since 5.18
501    'cop'             => \$optimize_cop, # XXX very unsafe!
502					 # Better do it in CC, but get rid of
503					 # NULL cops also there.
504);
505our %optimization_map = (
506    0 => [qw()],                    # special case
507    1 => [qw(-fppaddr -fav-init2)], # falls back to -fav-init
508    2 => [qw(-fro-inc -fsave-data)],
509    3 => [qw(-fno-destruct -fconst-strings -fno-fold -fno-warnings)],
510    4 => [qw(-fcop -fno-dyn-padlist)],
511);
512push @{$optimization_map{2}}, '-fcow' if $] >= 5.020;
513# skipping here: oFr which need extra logic
514our %debug_map = (
515    'O' => 'op',
516    'A' => 'av',
517    'H' => 'hv',
518    'C' => 'cv',
519    'M' => 'mg',
520    'R' => 'rx',
521    'G' => 'gv',
522    'S' => 'sv',
523    'P' => 'pv',
524    'W' => 'walk',
525    'c' => 'cops',
526    's' => 'sub',
527    'p' => 'pkg',
528#   'm' => 'meth',
529    'u' => 'unused',
530);
531
532my @xpvav_sizes;
533my ($max_string_len, $in_endav);
534my %static_core_pkg; # = map {$_ => 1} static_core_packages();
535
536my $MULTI = $Config{usemultiplicity} || $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT/;
537my $ITHREADS = $Config{useithreads};
538my $DEBUGGING = ($Config{ccflags} =~ m/-DDEBUGGING/);
539my $DEBUG_LEAKING_SCALARS = $Config{ccflags} =~ m/-DDEBUG_LEAKING_SCALARS/;
540my $GLOBAL_STRUCT = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT/; # includes _PRIVATE
541my $CPERL56  = ( $Config{usecperl} and $] >= 5.025003 ); #sibparent, VALID
542my $CPERL55  = ( $Config{usecperl} and $] >= 5.025001 ); #HVMAX_T, RITER_T, ...
543my $CPERL52  = ( $Config{usecperl} and $] >= 5.022002 ); #sv_objcount, AvSTATIC, sigs
544my $CPERL51  = ( $Config{usecperl} );
545my $PERL5257 = ( $CPERL56 or $] >= 5.025007 ); # VALID/TAIL, sibparent, ...
546my $PERL524  = ( $] >= 5.023005 ); #xpviv sharing assertion
547my $PERL522  = ( $] >= 5.021006 ); #PADNAMELIST, IsCOW, padname_with_str, compflags
548my $PERL518  = ( $] >= 5.017010 );
549my $PERL514  = ( $] >= 5.013002 );
550my $PERL512  = ( $] >= 5.011 );
551my $PERL510  = ( $] >= 5.009005 );
552my $PERL56   = ( $] <  5.008001 ); # yes. 5.8.0 is a 5.6.x
553#my $C99 = $Config{d_c99_variadic_macros}; # http://docs.sun.com/source/819-3688/c99.app.html#pgfId-1003962
554my $MAD      = $Config{mad};
555my $MYMALLOC = $Config{usemymalloc} eq 'define';
556my $HAVE_DLFCN_DLOPEN = $Config{i_dlfcn} && $Config{d_dlopen};
557# %Lu is not supported on older 32bit systems
558my $u32fmt = $Config{ivsize} == 4 ? "%lu" : "%u";
559sub IS_MSVC () { $^O eq 'MSWin32' and $Config{cc} eq 'cl' }
560my $have_sibparent = ($PERL5257 or $Config{ccflags} =~ /-DPERL_OP_PARENT/) ? 1 : 0;
561
562my @threadsv_names;
563
564BEGIN {
565  @threadsv_names = threadsv_names();
566  # This the Carp free workaround for DynaLoader::bootstrap
567  eval 'sub DynaLoader::croak {die @_}' unless $CPERL51;
568}
569
570sub cross_config { # overrides %B::C::Config::Config
571  my ($file) = @_;
572  -e $file or die("-cross \"$file\" not found");
573  open my $fh, "<", $file or
574    die("Could not open -cross \"$file\": $!");
575  while (<$fh>) {
576    my ($k,$v) = /^(\w+)=(.+)$/; # startperl for $^X, osname for $^O
577    next unless $k;
578    $OriConfig{$k} = $Config{$k} if exists $Config{$k};
579    if (exists $Config{$k}) {
580      if ($v =~ /^'(.*)'$/) {
581        $v = $1;
582      } elsif ($v =~ /^"(.*)"$/) {
583        $v = $1;
584      }
585      $v = '' if $v eq 'undef';
586      if ($Config{$k} ne $v) {
587        if ($k =~ /^(version|usemultiplicity|useithreads)$/) {
588          die "Invalid cross $k $v. Require $Config{$k}";
589        }
590        warn "\$Config{$k}: $Config{$k} => $v\n" if $verbose;
591        $Cross{$k} = $v;
592        $Config{$k} = $v;
593      }
594    }
595  }
596  close $fh;
597}
598
599# needed for init2 remap and Dynamic annotation
600sub dl_module_to_sofile {
601  my $module = shift
602    or die 'dl_module_to_sofile($module, $path) missing module name';
603  my $modlibname = shift
604    or die 'dl_module_to_sofile($module, $path): missing module path for '.$module;
605  my @modparts = split(/::/,$module);
606  my $modfname = $modparts[-1];
607  my $modpname = join('/',@modparts);
608  my $c = @modparts;
609  $modlibname =~ s,[\\/][^\\/]+$,, while $c--;    # Q&D basename
610  die "dl_module_to_sofile: empty modlibname" unless $modlibname;
611  my $sofile = "$modlibname/auto/$modpname/$modfname.".$Config{dlext};
612  return $sofile;
613}
614
615# 5.15.3 workaround [perl #101336], without .bs support
616# XSLoader::load_file($module, $modlibname, ...)
617my $dlext = $Config{dlext};
618eval q|
619sub XSLoader::load_file {
620  #package DynaLoader;
621  my $module = shift or die "missing module name";
622  my $modlibname = shift or die "missing module filepath";
623  print STDOUT "XSLoader::load_file(\"$module\", \"$modlibname\" @_)\n"
624      if ${DynaLoader::dl_debug};
625
626  push @_, $module;
627  # works with static linking too
628  my $boots = "$module\::bootstrap";
629  goto &$boots if defined &$boots;
630
631  my @modparts = split(/::/,$module); # crashes threaded, issue 100
632  my $modfname = $modparts[-1];
633  my $modpname = join('/',@modparts);
634  my $c = @modparts;
635  $modlibname =~ s,[\\/][^\\/]+$,, while $c--;    # Q&D basename
636  die "missing module filepath" unless $modlibname;
637  my $file = "$modlibname/auto/$modpname/$modfname."|.qq(."$dlext").q|;
638
639  # skip the .bs "bullshit" part, needed for some old solaris ages ago
640
641  print STDOUT "goto DynaLoader::bootstrap_inherit\n"
642      if ${DynaLoader::dl_debug} and not -f $file;
643  goto \&DynaLoader::bootstrap_inherit if not -f $file;
644  my $modxsname = $module;
645  $modxsname =~ s/\W/_/g;
646  my $bootname = "boot_".$modxsname;
647  @DynaLoader::dl_require_symbols = ($bootname);
648
649  my $boot_symbol_ref;
650  if ($boot_symbol_ref = DynaLoader::dl_find_symbol(0, $bootname)) {
651    print STDOUT "dl_find_symbol($bootname) ok => goto boot\n"
652      if ${DynaLoader::dl_debug};
653    goto boot; #extension library has already been loaded, e.g. darwin
654  }
655  # Many dynamic extension loading problems will appear to come from
656  # this section of code: XYZ failed at line 123 of DynaLoader.pm.
657  # Often these errors are actually occurring in the initialisation
658  # C code of the extension XS file. Perl reports the error as being
659  # in this perl code simply because this was the last perl code
660  # it executed.
661
662  my $libref = DynaLoader::dl_load_file($file, 0) or do {
663    die("Can't load '$file' for module $module: " . DynaLoader::dl_error());
664  };
665  push(@DynaLoader::dl_librefs,$libref);  # record loaded object
666
667  my @unresolved = DynaLoader::dl_undef_symbols();
668  if (@unresolved) {
669    die("Undefined symbols present after loading $file: @unresolved\n");
670  }
671
672  $boot_symbol_ref = DynaLoader::dl_find_symbol($libref, $bootname) or do {
673    die("Can't find '$bootname' symbol in $file\n");
674  };
675  print STDOUT "dl_find_symbol($libref, $bootname) ok => goto boot\n"
676    if ${DynaLoader::dl_debug};
677  push(@DynaLoader::dl_modules, $module); # record loaded module
678
679 boot:
680  my $xs = DynaLoader::dl_install_xsub($boots, $boot_symbol_ref, $file);
681  print STDOUT "dl_install_xsub($boots, $boot_symbol_ref, $file)\n"
682    if ${DynaLoader::dl_debug};
683  # See comment block above
684  push(@DynaLoader::dl_shared_objects, $file); # record files loaded
685  return &$xs(@_);
686}
687| if $] >= 5.015003 and !$CPERL51;
688# Note: cperl uses a different API: the 2nd arg is the sofile directly
689
690# Code sections
691my (
692    $init,      $decl,      $symsect,    $binopsect, $condopsect,
693    $copsect,   $padopsect, $listopsect, $logopsect, $loopsect,
694    $opsect,    $pmopsect,  $pvopsect,   $svopsect,  $unopsect,
695    $methopsect, $unopauxsect,
696    $svsect,    $xpvsect,    $xpvavsect, $xpvhvsect, $xpvcvsect,
697    $xpvivsect, $xpvuvsect,  $xpvnvsect, $xpvmgsect, $xpvlvsect,
698    $xrvsect,   $xpvbmsect, $xpviosect,  $heksect,   $free,
699    $padlistsect, $padnamesect, $padnlsect, $init0, $init1, $init2
700   );
701my (%padnamesect, %avcowsect, %avcogsect);
702my @padnamesect_sizes = (8, 16, 24, 32, 40, 48, 56, 64);
703
704my @op_sections =
705  \(
706    $binopsect,  $condopsect, $copsect,  $padopsect,
707    $listopsect, $logopsect,  $loopsect, $opsect,
708    $pmopsect,   $pvopsect,   $svopsect, $unopsect,
709    $methopsect, $unopauxsect
710);
711# push @op_sections, ($resect) if $PERL512;
712sub walk_and_save_optree;
713my $saveoptree_callback = \&walk_and_save_optree;
714sub set_callback { $saveoptree_callback = shift }
715sub saveoptree { &$saveoptree_callback(@_) }
716sub save_main_rest;
717sub verbose { if (@_) { $verbose = shift; } else { $verbose; } }
718sub module  { if (@_) { $module = shift; } else { $module; } }
719
720sub walk_and_save_optree {
721  my ( $name, $root, $start ) = @_;
722  if ($root) {
723    # B.xs: walkoptree does more, reifying refs. rebless or recreating it.
724    # TODO: add walkoptree_debug support.
725    $verbose ? walkoptree_slow( $root, "save" ) : walkoptree( $root, "save" );
726  }
727  return objsym($start);
728}
729
730# Look this up here so we can do just a number compare
731# rather than looking up the name of every BASEOP in B::OP
732my $OP_THREADSV = opnumber('threadsv');
733my $OP_DBMOPEN = opnumber('dbmopen');
734my $OP_FORMLINE = opnumber('formline');
735my $OP_UCFIRST = opnumber('ucfirst');
736my $OP_CUSTOM = opnumber('custom');
737
738# special handling for nullified COP's.
739my %OP_COP = ( opnumber('nextstate') => 1 );
740$OP_COP{ opnumber('setstate') } = 1 if $] > 5.005003 and $] < 5.005062;
741$OP_COP{ opnumber('dbstate') }  = 1 unless $PERL512;
742warn %OP_COP if $debug{cops};
743
744# 1. called from method_named, so hashp should be defined
745# 2. called from svop before method_named to cache the $package_pv
746sub svop_or_padop_pv {
747  my $op = shift;
748  my $sv;
749  if (!$op->can("sv")) {
750    if ($op->can('name') and $op->name eq 'padsv') {
751      my @c = comppadlist->ARRAY;
752      my @pad = $c[1]->ARRAY;
753      return $pad[$op->targ]->PV if $pad[$op->targ] and $pad[$op->targ]->can("PV");
754      # This might fail with B::NULL (optimized ex-const pv) entries in the pad.
755    }
756    # $op->can('pmreplroot') fails for 5.14
757    if (ref($op) eq 'B::PMOP' and $op->pmreplroot->can("sv")) {
758      $sv = $op->pmreplroot->sv;
759    } else {
760      return $package_pv unless $op->flags & 4;
761      # op->first is disallowed for !KIDS and OPpCONST_BARE
762      return $package_pv if $op->name eq 'const' and $op->flags & 64;
763      return $package_pv unless $op->first->can("sv");
764      $sv = $op->first->sv;
765    }
766  } else {
767    $sv = $op->sv;
768  }
769  # XXX see SvSHARED_HEK_FROM_PV for the stash in S_method_common pp_hot.c
770  # In this hash the CV is stored directly
771  if ($sv and $$sv) {
772    #if ($PERL510) { # PVX->hek_hash - STRUCT_OFFSET(struct hek, hek_key)
773    #} else {        # UVX
774    #}
775    return $sv->PV if $sv->can("PV");
776    if (ref($sv) eq "B::SPECIAL") { # DateTime::TimeZone
777      # XXX null -> method_named
778      warn "NYI S_method_common op->sv==B::SPECIAL, keep $package_pv\n" if $debug{gv};
779      return $package_pv;
780    }
781    if ($sv->FLAGS & SVf_ROK) {
782      goto missing if $sv->isa("B::NULL");
783      my $rv = $sv->RV;
784      if ($rv->isa("B::PVGV")) {
785	my $o = $rv->IO;
786	return $o->STASH->NAME if $$o;
787      }
788      goto missing if $rv->isa("B::PVMG");
789      return $rv->STASH->NAME;
790    } else {
791  missing:
792      if ($op->name ne 'method_named') {
793	# Called from first const/padsv before method_named. no magic pv string, so a method arg.
794	# The first const pv as method_named arg is always the $package_pv.
795	return $package_pv;
796      } elsif ($sv->isa("B::IV")) {
797        warn sprintf("Experimentally try method_cv(sv=$sv,$package_pv) flags=0x%x",
798                     $sv->FLAGS);
799        # XXX untested!
800        return svref_2object(method_cv($$sv, $package_pv));
801      }
802    }
803  } else {
804    my @c = comppadlist->ARRAY;
805    my @pad = $c[1]->ARRAY;
806    return $pad[$op->targ]->PV if $pad[$op->targ] and $pad[$op->targ]->can("PV");
807  }
808}
809
810sub IsCOW {
811  if ($PERL522) {
812    return $_[0]->FLAGS & SVf_IsCOW;
813  }
814  return ($] >= 5.017008 and $_[0]->FLAGS & SVf_IsCOW); # since 5.17.8
815}
816sub IsCOW_hek {
817  return IsCOW($_[0]) && !$_[0]->LEN;
818}
819
820if ($Config{usecperl} and $] >= 5.022002) {
821  eval q[sub isAvSTATIC {
822    my $flags = shift->FLAGS;
823    return !($flags & SVpav_REAL) && !($flags & SVpav_REIFY)
824  }];
825} else {
826  eval q[sub isAvSTATIC () { 0 }];
827}
828
829sub canAvSTATIC {
830  my ($av, $fullname) = @_;
831  my $flags = $av->FLAGS;
832  return 1;
833}
834
835sub savesym {
836  my ( $obj, $value ) = @_;
837  no strict 'refs';
838  my $sym = sprintf( "s\\_%x", $$obj );
839  $symtable{$sym} = $value;
840  return $value;
841}
842
843sub objsym {
844  my $obj = shift;
845  no strict 'refs';
846  return $symtable{ sprintf( "s\\_%x", $$obj ) };
847}
848
849sub getsym {
850  my $sym = shift;
851  my $value;
852
853  return 0 if $sym eq "sym_0";    # special case
854  $value = $symtable{$sym};
855  if ( defined($value) ) {
856    return $value;
857  }
858  else {
859    warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
860    return "UNUSED";
861  }
862}
863
864sub delsym {
865  my ( $obj ) = @_;
866  my $sym = sprintf( "s\\_%x", $$obj );
867  delete $symtable{$sym};
868}
869
870sub curcv { $B::C::curcv }
871sub set_curcv($) { $B::C::curcv = shift; }
872
873# returns cstring, len, utf8 flags of a string
874sub strlen_flags {
875  my $s = shift;
876  my ($len, $flags) = (0,"0");
877  if (!$PERL56 and utf8::is_utf8($s)) {
878    my $us = $s;
879    $flags = 'SVf_UTF8';
880    $len = utf8::upgrade($us);
881  } else {
882    $len = length $s;
883  }
884  return (cstring($s), $len, $flags);
885}
886
887sub savestash_flags {
888  my ($name, $cstring, $len, $flags) = @_;
889  return $stashtable{$name} if exists $stashtable{$name};
890  #return '(HV*)&PL_sv_undef' if $name =~ /^(|B::CC?)$/; # protect against empty stashes
891  $flags = $flags ? "$flags|GV_ADD" : "GV_ADD";
892  my $sym = "hv$hv_index";
893  $decl->add("Static HV *$sym;");
894  $hv_index++;
895  if ($PERL518 and $name) { # since 5.18 save @ISA before calling stashpv
896    my @isa = get_isa($name);
897    no strict 'refs';
898    if (@isa and exists ${$name.'::'}{ISA} ) {
899      svref_2object( \@{"$name\::ISA"} )->save("$name\::ISA");
900    }
901  }
902  my $pvsym = $len ? constpv($name) : '""';
903  $stashtable{$name} = $sym;
904  $init->add( sprintf( "%s = gv_stashpvn(%s, %u, %s); /* $name */",
905                       $sym, $pvsym, $len, $flags));
906  return $sym;
907}
908
909sub savestashpv {
910  my $name = shift;
911  return savestash_flags($name, strlen_flags($name));
912}
913
914sub savere {
915  my $re = shift;
916  my $flags = shift || 0;
917  my $sym;
918  my $pv  = $re;
919  my ($cstring, $cur, $utf8) = strlen_flags($pv);
920  my $len = 0; # static buffer
921  if ($PERL514) {
922    $xpvsect->add( sprintf( "Nullhv, {0}, %u, %u", $cur, $len ) );
923    $svsect->add( sprintf( "&xpv_list[%d], 1, %x, {%s}", $xpvsect->index,
924                           0x4405, ($C99?".svu_pv=":"").'(char*)'.savepv($pv) ) );
925    $sym = sprintf( "&sv_list[%d]", $svsect->index );
926  }
927  elsif ($PERL510) {
928    # BUG! Should be the same as newSVpvn($resym, $relen) but is not
929    #$sym = sprintf("re_list[%d]", $re_index++);
930    #$resect->add(sprintf("0,0,0,%s", $cstring));
931    my $s1 = ($PERL514 ? "NULL," : "") . "{0}, %u, %u";
932    $xpvsect->add( sprintf( $s1, $cur, $len ) );
933    $svsect->add( sprintf( "&xpv_list[%d], 1, %x, {%s}", $xpvsect->index,
934                           0x4405, ($C99?".svu_pv=":"").'(char*)'.savepv($pv) ) );
935    my $s = "sv_list[".$svsect->index."]";
936    $sym = "&$s";
937    push @B::C::static_free, $s if $len; # and $B::C::pv_copy_on_grow;
938    # $resect->add(sprintf("&xpv_list[%d], $u32fmt, 0x%x", $xpvsect->index, 1, 0x4405));
939  }
940  else {
941    $sym = sprintf( "re%d", $re_index++ );
942    $decl->add( sprintf( "Static const char *%s = %s;", $sym, $cstring ) );
943  }
944  return ( $sym, $cur );
945}
946
947sub constpv {
948  return savepv(shift, 1);
949}
950
951sub savepv {
952  my $pv    = shift;
953  my $const = shift;
954  my ($cstring, $cur, $utf8) = strlen_flags($pv);
955  # $decl->add( sprintf( "/* %s */", $cstring) ) if $debug{pv};
956  return $strtable{$cstring} if defined $strtable{$cstring};
957  my $pvsym = sprintf( "pv%d", $pv_index++ );
958  $const = $const ? " const" : "";
959  if ( defined $max_string_len && $cur > $max_string_len ) {
960    my $chars = join ', ', map { cchar $_ } split //, pack("a*", $pv);
961    $decl->add( sprintf( "Static%s char %s[] = { %s };", $const, $pvsym, $chars ) );
962    $strtable{$cstring} = $pvsym;
963  } else {
964    if ( $cstring ne "0" ) {    # sic
965      $decl->add( sprintf( "Static%s char %s[] = %s;", $const, $pvsym, $cstring ) );
966      $strtable{$cstring} = $pvsym;
967    }
968  }
969  return $pvsym;
970}
971
972sub save_rv {
973  my ($sv, $fullname) = @_;
974  if (!$fullname) {
975    $fullname = '(unknown)';
976  }
977  # confess "Can't save RV: not ROK" unless $sv->FLAGS & SVf_ROK;
978  # 5.6: Can't locate object method "RV" via package "B::PVMG"
979  # since 5.11 it must be a PV, the RV was removed from the IV
980  my $rv;
981  #if ($] >= 5.011 and ref($sv) =~ /^B::[IP]V$/) {
982  #  warn "$sv is no IV nor PV\n" if $debug{sv};
983  #  $sv = bless $sv, 'B::PV'; # only observed with DB::args[0]
984  #}
985  #elsif ($] < 5.011 and ref($sv) =~ /^B::[RP]V$/) {
986  #  warn "$sv is no RV nor PV\n" if $debug{sv};
987  #  $sv = bless $sv, 'B::RV';
988  #}
989  $rv = $sv->RV->save($fullname);
990  $rv =~ s/^\(([AGHS]V|IO)\s*\*\)\s*(\&sv_list.*)$/$2/;
991
992  return $rv;
993}
994
995# => savesym, cur, len, pv, static, flags
996sub save_pv_or_rv {
997  my ($sv, $fullname) = @_;
998
999  my $flags = $sv->FLAGS;
1000  my $rok = $flags & SVf_ROK;
1001  my $pok = $flags & SVf_POK;
1002  my $gmg = $flags & SVs_GMG;
1003  my $iscow = (IsCOW($sv) or ($B::C::cow and $PERL518)) ? 1 : 0;
1004  #my $wascow = IsCOW($sv) ? 1 : 0;
1005  my ( $cur, $len, $savesym, $pv ) = ( 0, 1, 'NULL', "" );
1006  my ($static, $shared_hek);
1007  # overloaded VERSION symbols fail to xs boot: ExtUtils::CBuilder with Fcntl::VERSION (i91)
1008  # 5.6: Can't locate object method "RV" via package "B::PV" Carp::Clan
1009  if ($rok and !$PERL56) {
1010    # this returns us a SV*. 5.8 expects a char* in xpvmg.xpv_pv
1011    warn "save_pv_or_rv: save_rv(",$sv,")\n" if $debug{sv};
1012    $savesym = ($PERL510 ? "" : "(char*)") . save_rv($sv, $fullname);
1013    $static = 1; # avoid run-time overwrite of the PV/RV slot (#273)
1014    if ($savesym =~ /get_cv/) { # Moose::Util::TypeConstraints::Builtins::_RegexpRef
1015      $static = 0;
1016      $pv = $savesym;
1017      $savesym = 'NULL';
1018    }
1019  }
1020  else {
1021    if ($pok) {
1022      $pv = pack "a*", $sv->PV; # XXX!
1023      $cur = ($sv and $sv->can('CUR') and ref($sv) ne 'B::GV') ? $sv->CUR : length($pv);
1024      # comppadname bug with overlong strings
1025      if ($] < 5.008008 and $cur > 100 and $fullname =~ m/ :pad\[0\]/ and $pv =~ m/\0\0/) {
1026        my $i = index($pv,"\0");
1027        if ($i > -1) {
1028          $pv = substr($pv,0,$i);
1029          $cur = $i;
1030          warn "Warning: stripped wrong comppad name for $fullname to ".cstring($pv)."\n"
1031            if $verbose;
1032        }
1033      }
1034    } else {
1035      if ($gmg && $fullname) {
1036	no strict 'refs';
1037	$pv = ($fullname and ref($fullname)) ? "${$fullname}" : '';
1038	$cur = length (pack "a*", $pv);
1039	$pok = 1;
1040      } else {
1041	($pv,$cur) = ("",0);
1042      }
1043    }
1044    $shared_hek = $PERL510 ? (($flags & 0x09000000) == 0x09000000) : undef;
1045    $shared_hek = $shared_hek ? 1 : IsCOW_hek($sv);
1046    $static = ($B::C::const_strings or $iscow or ($flags & SVf_READONLY))
1047              ? 1 : 0;
1048    $static = 0 if $shared_hek
1049      or ($fullname and ($fullname =~ m/ :pad/
1050                         or ($fullname =~ m/^DynaLoader/ and $pv =~ m/^boot_/)));
1051    $static = 0 if $static and $pv =~ /::bootstrap$/;
1052    $static = 0 if $static and $] > 5.017 and ref($sv) eq 'B::PVMG'; # 242: e.g. $1
1053    $static = 0 if $static and $B::C::const_strings and $fullname and
1054      ($fullname =~ /^warnings::(Dead)?Bits/ or $fullname =~ /::AUTOLOAD$/);
1055    if ($shared_hek and $pok and !$cur) { #272 empty key
1056      warn "use emptystring for empty shared key $fullname\n" if $debug{pv} or $debug{hv};
1057      $savesym = "emptystring" unless $fullname =~ /unopaux_item.* const/;
1058      $static = 0;
1059    }
1060    if ($static and $PERL510) { # force dynamic PADNAME strings
1061      if ($] < 5.016) { $static = 0 if $flags & 0x40000000; } # SVpad_NAME
1062      # w. 5.18 even const and VERSION
1063      elsif ($] < 5.020 and $fullname =~ /(^svop const|::VERSION)$/) {
1064        warn "static=0 for $fullname\n" if $debug{pv};
1065        $static = 0;
1066      }
1067      elsif ($] < 5.022 and ($flags & 0x40008000 == 0x40008000)) { # SVpad_NAME
1068        warn "static=0 for SVpad_NAME $fullname\n" if $debug{pv};
1069        $static = 0;
1070      }
1071    }
1072    if ($pok) {
1073      my $s = "sv_list[" . ($svsect->index + 1) . "]";
1074      # static pv (!SvLEN) only valid since cd84013aab030da47b76a44fb3 (sv.c: !SvLEN does not mean undefined)
1075      # i.e. since v5.17.6. because conversion to IV would fail.
1076      # But a "" or "0" or "[a-z]+" string can have SvLEN=0
1077      # since its is converted to 0.
1078      # Only a readonly "" or "0" string can have SvLEN=0 since it's
1079      # converted to 0, which leads to the same result.
1080      # perlcc -O3 -r -e'print "ok" if 1 == "1"'
1081      # vs
1082      # perlcc -O2 -r -e'print "ok" if 1 == "1"'
1083      # ok
1084      if ($static and $] < 5.017006 and $pv !~ /^0?$/) {
1085        $static = 0;
1086      }
1087      # but we can optimize static set-magic ISA entries. #263, #91
1088      if ($B::C::const_strings and ref($sv) eq 'B::PVMG'
1089          and $flags & SVs_SMG and $fullname =~ /ISA/) {
1090        $static = 1; # warn "static $fullname";
1091      }
1092      if ($static) {
1093	$len = 0;
1094        #warn cstring($sv->PV)." $iscow $wascow";
1095        if ($iscow and $PERL518) { # 5.18 COW logic
1096          if ($B::C::Config::have_HEK_STATIC) {
1097            $iscow = 1;
1098            $shared_hek = 1;
1099            # $pv .= "\000\001";
1100            $savesym = save_hek($pv,$fullname,0);
1101            # warn "static shared hek: $savesym";
1102            # $savesym =~ s/&\(HEK\)(hek\d+)/&($1.hek_key)/;
1103          } elsif ($B::C::cow) {
1104            # wrong in many cases but saves a lot of memory, only do this with -O2
1105            $len = $cur+2;
1106            $pv .= "\000\001";
1107            $savesym = savepv($pv);
1108          } else {
1109            $iscow = 0;
1110            $savesym = constpv($pv);
1111          }
1112        } else {
1113          $savesym = constpv($pv);
1114        }
1115        if ($savesym =~ /\)?get_cv/) { # Moose::Util::TypeConstraints::Builtins::_RegexpRef
1116          $static = 0;
1117	  $len = $cur +1;
1118          $pv = $savesym;
1119          $savesym = 'NULL';
1120        }
1121        if ($iscow) {
1122          $flags |= SVf_IsCOW;
1123        } else {
1124          $flags &= ~SVf_IsCOW;
1125        }
1126        #push @B::C::static_free, $savesym if $len and $savesym =~ /^pv/ and !$B::C::in_endav;
1127      } else {
1128	$len = $cur+1;
1129        if ($shared_hek) {
1130          if ($savesym eq "emptystring") {
1131            $free->add("    SvLEN(&$s) = 0;");
1132            $len = 0 if $PERL518;
1133          } else {
1134            $len = 0;
1135          }
1136          $free->add("    SvFAKE_off(&$s);");
1137        } else {
1138          if ($iscow and $cur and $PERL518) {
1139            $len++;
1140            $pv .= "\000\001";
1141            $flags |= SVf_IsCOW;
1142          }
1143        }
1144      }
1145    } else {
1146      $len = 0;
1147    }
1148  }
1149  #if ($iscow and $len and $PERL518) { # 5.18 COW logic
1150  #  my $offset = $len % $Config{ptrsize};
1151  #  $len += $Config{ptrsize} - $offset if $offset;
1152  #}
1153  warn sprintf("Saving pv as %s %s cur=%d, len=%d, static=%d cow=%d %s flags=0x%x\n",
1154               $savesym, cstring($pv), $cur, $len,
1155               $static, $iscow, $shared_hek ? "shared, $fullname" : $fullname, $flags)
1156    if $debug{pv};
1157  return ( $savesym, $cur, $len, $pv, $static, $flags );
1158}
1159
1160# Shared global string in PL_strtab.
1161# Mostly GvNAME and GvFILE, but also CV prototypes or bareword hash keys.
1162# Note: currently not used in list context
1163sub save_hek {
1164  my ($str, $fullname, $dynamic) = @_; # not cstring'ed
1165  # $dynamic: see lexsub CvNAME in CV::save
1166  # force empty string for CV prototypes
1167  return "NULL" unless defined $str;
1168  return "NULL" if $dynamic and !length $str and !@_
1169    and $fullname !~ /unopaux_item.* const/;
1170  # The first assigment is already refcount bumped, we have to manually
1171  # do it for all others
1172  my ($cstr, $cur, $utf8) = strlen_flags($str);
1173  my $hek_key = $str.":".$utf8;
1174  if ($dynamic and defined $hektable{$hek_key}) {
1175    return sprintf("share_hek_hek(%s)", $hektable{$hek_key});
1176  }
1177  if (!$dynamic and defined $statichektable{$hek_key}) {
1178    return $statichektable{$hek_key};
1179  }
1180  $cur = - $cur if $utf8;
1181  $cstr = '""' if $cstr eq "0";
1182  my $sym = sprintf( "hek%d", $hek_index++ );
1183  if (!$dynamic) {
1184    $statichektable{$hek_key} = $sym;
1185    my $key = $cstr;
1186    my $len = abs($cur);
1187    # strip CowREFCNT
1188    if ($key =~ /\\000\\001"$/) {
1189      $key =~ s/\\000\\001"$/"/;
1190      $len -= 2;
1191    }
1192    # add the flags. a static hek is unshared
1193    if (!$utf8) { # 0x88: HVhek_STATIC + HVhek_UNSHARED
1194      $key =~ s/"$/\\000\\210"/;
1195    } else {      # 0x89: + HVhek_UTF8
1196      $key =~ s/"$/\\000\\211"/;
1197    }
1198    #warn sprintf("Saving static hek %s %s cur=%d\n", $sym, $cstr, $cur)
1199    #  if $debug{pv};
1200    # not const because we need to set the HASH at init
1201    $decl->add(sprintf("Static struct hek_ptr %s = { %u, %d, %s};",
1202                       $sym, 0, $len, $key));
1203    $init->add(sprintf("PERL_HASH(%s.hek_hash, %s.hek_key, %u);", $sym, $sym, $len));
1204  } else {
1205    $hektable{$hek_key} = $sym;
1206    $decl->add(sprintf("Static HEK *%s;", $sym));
1207    warn sprintf("Saving hek %s %s cur=%d\n", $sym, $cstr, $cur)
1208      if $debug{pv};
1209    # randomized global shared hash keys:
1210    #   share_hek needs a non-zero hash parameter, unlike hv_store.
1211    #   Vulnerable to oCERT-2011-003 style DOS attacks?
1212    #   user-input (object fields) do not affect strtab, it is pretty safe.
1213    # But we need to randomize them to avoid run-time conflicts
1214    #   e.g. "Prototype mismatch: sub bytes::length (_) vs (_)"
1215    #if (0 and $PERL510) { # no refcount
1216    #  $init->add(sprintf("%s = my_share_hek_0(%s, %d);", $sym, $cstr, $cur));
1217    #} else { # vs. bump the refcount
1218    $init->add(sprintf("%s = share_hek(%s, %d);", $sym, $cstr, $cur));
1219    #}
1220    # protect against Unbalanced string table refcount warning with PERL_DESTRUCT_LEVEL=2
1221    # $free->add("    $sym = NULL;");
1222  }
1223  return $sym;
1224}
1225
1226sub gv_fetchpvn {
1227  my ($name, $flags, $type) = @_;
1228  warn 'undefined flags' unless defined $flags;
1229  warn 'undefined type' unless defined $type;
1230  my ($cname, $cur, $utf8) = strlen_flags($name);
1231  if ($] >= 5.009002) {
1232    $flags .= length($flags) ? "|$utf8" : $utf8 if $utf8;
1233    return "gv_fetchpvn_flags($cname, $cur, $flags, $type)";
1234  } else {
1235    return "gv_fetchpv($cname, $flags, $type)";
1236  }
1237}
1238
1239# get_cv() returns a CV*
1240sub get_cv {
1241  my ($name, $flags) = @_;
1242  $name = "" if $name eq "__ANON__";
1243  my ($cname, $cur, $utf8) = strlen_flags($name);
1244  warn 'undefined flags' unless defined $flags;
1245  if ($] >= 5.009002) {
1246    $flags .= length($flags) ? "|$utf8" : $utf8 if $utf8;
1247    return qq[get_cvn_flags($cname, $cur, $flags)];
1248  } else {
1249    return qq[get_cv($cname, $flags)];
1250  }
1251}
1252
1253sub ivx ($) {
1254  my $ivx = shift;
1255  my $ivdformat = $Config{ivdformat};
1256  $ivdformat =~ s/["\0]//g; #" poor editor
1257  $ivdformat =~ s/".$/"/;  # cperl bug 5.22.2 #61 (never released)
1258  unless ($ivdformat) {
1259    $ivdformat = $Config{ivsize} == 4 ? 'd' : 'ld';
1260  }
1261  my $POW    = ( $Config{ivsize} * 4 - 1 );    # poor editor
1262  my $intmax = (1 << $POW) - 1;
1263  my $L = 'L';
1264  # LL for 32bit -2147483648L or 64bit -9223372036854775808L
1265  $L = 'LL' if $Config{ivsize} == 2*$Config{ptrsize};
1266  # UL if > INT32_MAX = 2147483647
1267  my $sval = sprintf("%${ivdformat}%s", $ivx, $ivx > $intmax ? "U$L" : "");
1268  if ($ivx < -$intmax) {
1269    $sval = sprintf("%${ivdformat}%s", $ivx, 'LL'); # DateTime
1270  }
1271  if ($INC{'POSIX.pm'}) {
1272    # i262: LONG_MIN -9223372036854775808L integer constant is so large that it is unsigned
1273    if ($ivx == POSIX::LONG_MIN()) {
1274      $sval = "PERL_LONG_MIN";
1275    }
1276    elsif ($ivx == POSIX::LONG_MAX()) {
1277      $sval = "PERL_LONG_MAX";
1278    }
1279    #elsif ($ivx == POSIX::HUGE_VAL()) {
1280    #  $sval = "HUGE_VAL";
1281    #}
1282  }
1283  $sval = '0' if $sval =~ /(NAN|inf)$/i;
1284  return $sval;
1285  #return $C99 ? ".xivu_uv = $sval" : $sval; # this is version dependent
1286}
1287
1288# protect from warning: floating constant exceeds range of ‘double’ [-Woverflow]
1289sub nvx ($) {
1290  my $nvx = shift;
1291
1292  # Handle infinite and NaN values
1293  if ( defined $nvx ) {
1294      if ( $Config{d_isinf} or $] < 5.012 ) {
1295        return 'INFINITY' if $nvx =~ /^Inf/i;
1296        return '-INFINITY' if $nvx =~ /^-Inf/i;
1297      }
1298      return 'NAN' if $nvx =~ /^NaN/i and ($Config{d_isnan} or $] < 5.012);
1299      # TODO NANL for long double
1300  }
1301
1302  my $nvgformat = $Config{nvgformat};
1303  $nvgformat =~ s/["\0]//g; #" poor editor
1304  $nvgformat =~ s/".$/"/;  # cperl bug 5.22.2 #61
1305  unless ($nvgformat) {
1306    $nvgformat = 'g';
1307  }
1308  my $dblmax = "1.79769313486232e+308";
1309  my $ll = $Config{d_longdbl} ? "LL" : "L";
1310  my $ldblmax = "1.18973149535723176502e+4932";
1311  if ($nvgformat eq 'g') { # a very poor choice to keep precision
1312    # on intel 17-18, on ppc 31, on sparc64/s390 34
1313    # TODO: rather use the binary representation of our union
1314    $nvgformat = $Config{uselongdouble} ? '.18Lg' : '.17g';
1315  }
1316  my $sval = sprintf("%${nvgformat}%s", $nvx, $nvx > $dblmax ? $ll : "");
1317  if ($nvx < -$dblmax) {
1318    $sval = sprintf("%${nvgformat}%s", $nvx, $ll);
1319  }
1320  if ($INC{'POSIX.pm'}) {
1321    if ($nvx == POSIX::DBL_MIN()) {
1322      $sval = "DBL_MIN";
1323    }
1324    elsif ($nvx == POSIX::DBL_MAX()) { #1.797693134862316e+308
1325      $sval = "DBL_MAX";
1326    }
1327  }
1328  else {
1329    if ($nvx == $dblmax) {
1330      $sval = "DBL_MAX";
1331    }
1332  }
1333
1334  if ($Config{d_longdbl}) {
1335    my $posix;
1336    if ($INC{'POSIX.pm'}) {
1337      eval { $posix = POSIX::LDBL_MIN(); };
1338    }
1339    if ($posix) { # linux does not have these, darwin does
1340      if ($nvx == $posix) {
1341        $sval = "NV_MIN";
1342      }
1343      elsif ($nvx == POSIX::LDBL_MAX()) {
1344        $sval = "NV_MAX";
1345      }
1346    } elsif ($nvx == $ldblmax) {
1347      $sval = "NV_MAX";
1348    }
1349  }
1350  $sval = '0' if $sval =~ /(NAN|inf)$/i;
1351  $sval .= '.00' if $sval =~ /^-?\d+$/;
1352  return $sval;
1353}
1354
1355sub mg_RC_off {
1356  my ($mg, $sym, $type) = @_;
1357  warn "MG->FLAGS ",$mg->FLAGS," turn off MGf_REFCOUNTED\n" if $debug{mg};
1358  if (!ref $sym) {
1359    $init->add(sprintf("my_mg_RC_off(aTHX_ (SV*)$sym, %s);", cchar($type)));
1360  } else {
1361    $init->add(sprintf("my_mg_RC_off(aTHX_ (SV*)s\\_%x, %s);", $$sym, cchar($type)));
1362  }
1363}
1364
1365# for bytes and utf8 only
1366# TODO: Carp::Heavy, Exporter::Heavy
1367# special case: warnings::register via -fno-warnings
1368sub force_heavy {
1369  my $pkg = shift;
1370  my $pkg_heavy = $pkg."_heavy.pl";
1371  no strict 'refs';
1372  if (!$include_package{$pkg_heavy} and !exists $savINC{$pkg_heavy}) {
1373    #eval qq[sub $pkg\::AUTOLOAD {
1374    #    require '$pkg_heavy';
1375    #    goto &\$AUTOLOAD if defined &\$AUTOLOAD;
1376    #    warn("Undefined subroutine \$AUTOLOAD called");
1377    #  }];
1378    #warn "Redefined $pkg\::AUTOLOAD to omit Carp\n" if $debug{gv};
1379    warn "Forcing early $pkg_heavy\n" if $debug{pkg};
1380    require $pkg_heavy;
1381    mark_package($pkg_heavy, 1);
1382    #walk_syms($pkg); #before we stub unloaded CVs
1383  }
1384  return svref_2object( \*{$pkg."::AUTOLOAD"} );
1385}
1386
1387# See also init_op_ppaddr below; initializes the ppaddr to the
1388# OpTYPE; init_op_ppaddr iterates over the ops and sets
1389# op_ppaddr to PL_ppaddr[op_ppaddr]; this avoids an explicit assignment
1390# in perl_init ( ~10 bytes/op with GCC/i386 )
1391sub B::OP::fake_ppaddr {
1392  my $op = shift;
1393  return "NULL" unless $op->can('name');
1394  if ($op->type == $OP_CUSTOM) {
1395    return ( $verbose ? sprintf( "/*XOP %s*/NULL", $op->name) : "NULL" );
1396  }
1397  return $B::C::optimize_ppaddr
1398    ? sprintf( "INT2PTR(void*,OP_%s)", uc( $op->name ) )
1399    : ( $verbose ? sprintf( "/*OP_%s*/NULL", uc( $op->name ) ) : "NULL" );
1400}
1401sub B::FAKEOP::fake_ppaddr { "NULL" }
1402# XXX HACK! duct-taping around compiler problems
1403sub B::OP::isa { UNIVERSAL::isa(@_) } # walkoptree_slow misses that
1404sub B::OP::can { UNIVERSAL::can(@_) }
1405sub B::OBJECT::name  { "" }           # B misses that
1406$isa_cache{'B::OBJECT::can'} = 'UNIVERSAL';
1407
1408# This pair is needed because B::FAKEOP::save doesn't scalar dereference
1409# $op->next and $op->sibling
1410my $opsect_common =
1411  "next, sibling, ppaddr, " . ( $MAD ? "madprop, " : "" ) . "targ, type, ";
1412#$opsect_common =~ s/, sibling/, _OP_SIBPARENT_FIELDNAME/ if $] > 5.021007;
1413$opsect_common =~ s/, sibling/, sibparent/ if $have_sibparent;
1414{
1415
1416  # For 5.8:
1417  # Current workaround/fix for op_free() trying to free statically
1418  # defined OPs is to set op_seq = -1 and check for that in op_free().
1419  # Instead of hardwiring -1 in place of $op->seq, we use $op_seq
1420  # so that it can be changed back easily if necessary. In fact, to
1421  # stop compilers from moaning about a U16 being initialised with an
1422  # uncast -1 (the printf format is %d so we can't tweak it), we have
1423  # to "know" that op_seq is a U16 and use 65535. Ugh.
1424
1425  # For 5.9 the hard coded text is the values for op_opt and op_static in each
1426  # op.  The value of op_opt is irrelevant, and the value of op_static needs to
1427  # be 1 to tell op_free that this is a statically defined op and that is
1428  # shouldn't be freed.
1429
1430  # For 5.10 op_seq = -1 is gone, the temp. op_static also, but we
1431  # have something better, we can set op_latefree to 1, which frees the children
1432  # (e.g. savepvn), but not the static op.
1433
1434# 5.8: U16 op_seq;
1435# 5.9.4: unsigned op_opt:1; unsigned op_static:1; unsigned op_spare:5;
1436# 5.10: unsigned op_opt:1; unsigned op_latefree:1; unsigned op_latefreed:1; unsigned op_attached:1; unsigned op_spare:3;
1437# 5.18: unsigned op_opt:1; unsigned op_slabbed:1; unsigned op_savefree:1; unsigned op_static:1; unsigned op_spare:3;
1438# 5.19: unsigned op_opt:1; unsigned op_slabbed:1; unsigned op_savefree:1; unsigned op_static:1; unsigned op_folded:1; unsigned op_spare:2;
1439# 5.21.2: unsigned op_opt:1; unsigned op_slabbed:1; unsigned op_savefree:1; unsigned op_static:1; unsigned op_folded:1; unsigned op_lastesib:1; unsigned op_spare:1;
1440# 5.21.11: unsigned op_opt:1; unsigned op_slabbed:1; unsigned op_savefree:1; unsigned op_static:1; unsigned op_folded:1; unsigned op_moresib:1; unsigned op_spare:1;
1441  my $static;
1442  if ( $] < 5.009004 ) {
1443    $static = sprintf "%u", 65535;
1444    $opsect_common .= "seq";
1445  }
1446  elsif ( $] < 5.010 ) {
1447    $static = '0, 1, 0';
1448    $opsect_common .= "opt, static, spare";
1449  }
1450  elsif ($] < 5.017002) {
1451    $static = '0, 1, 0, 0, 0';
1452    $opsect_common .= "opt, latefree, latefreed, attached, spare";
1453  }
1454  elsif ($] < 5.017004) {
1455    $static = '0, 1, 0, 0, 0, 0, 0';
1456    $opsect_common .= "opt, latefree, latefreed, attached, slabbed, savefree, spare";
1457  }
1458  elsif ($] < 5.017006) {
1459    $static = '0, 1, 0, 0, 0, 0, 0';
1460    $opsect_common .= "opt, latefree, latefreed, attached, slabbed, savefree, spare";
1461  }
1462  elsif ($] < 5.019002) { # 90840c5d1d 5.17.6
1463    $static = '0, 0, 0, 1, 0';
1464    $opsect_common .= "opt, slabbed, savefree, static, spare";
1465  }
1466  elsif ($] < 5.021002) {
1467    $static = '0, 0, 0, 1, 0, 0';
1468    $opsect_common .= "opt, slabbed, savefree, static, folded, spare";
1469  }
1470  elsif ($] < 5.0210011) {
1471    $static = '0, 0, 0, 1, 0, %d, 0';
1472    $opsect_common .= "opt, slabbed, savefree, static, folded, lastsib, spare";
1473  }
1474  else {
1475    $static = '0, 0, 0, 1, 0, %d, 0';
1476    $opsect_common .= "opt, slabbed, savefree, static, folded, moresib, spare";
1477  }
1478
1479  sub B::OP::_save_common_middle {
1480    my $op = shift;
1481    my $madprop = $MAD ? "0," : "";
1482    my $ret;
1483    if ($static =~ / %d,/) {
1484      my $has_sib;
1485      if (ref($op) eq 'B::FAKEOP') {
1486        $has_sib = 0;
1487      } elsif ($] < 5.0210011) {
1488        $has_sib = $op->lastsib;
1489      } else {
1490        $has_sib = $op->moresib;
1491      }
1492      $ret = sprintf( "%s, %s %u, %u, $static, 0x%x, 0x%x",
1493                      $op->fake_ppaddr, $madprop, $op->targ, $op->type,
1494                      $has_sib,
1495                      $op->flags, $op->private );
1496    } else {
1497      $ret = sprintf( "%s, %s %u, %u, $static, 0x%x, 0x%x",
1498                      $op->fake_ppaddr, $madprop, $op->targ, $op->type,
1499                      $op->flags, $op->private );
1500    }
1501    # XXX maybe add a ix=opindex string for debugging if $debug{flags}
1502    if ($B::C::Config::have_op_rettype) {
1503      $ret .= sprintf(", 0x%x", $op->rettype);
1504    }
1505    $ret;
1506  }
1507  $opsect_common .= ", flags, private";
1508  if ($B::C::Config::have_op_rettype) {
1509    $opsect_common .= ", rettype";
1510  }
1511}
1512
1513sub B::OP::_save_common {
1514  my $op = shift;
1515  # compile-time method_named packages are always const PV sM/BARE, they should be optimized.
1516  # run-time packages are in gvsv/padsv. This is difficult to optimize.
1517  #   my Foo $obj = shift; $obj->bar(); # TODO typed $obj
1518  # entersub -> pushmark -> package -> args...
1519  # See perl -MO=Terse -e '$foo->bar("var")'
1520  # See also http://www.perl.com/pub/2000/06/dougpatch.html
1521  # XXX TODO 5.8 ex-gvsv
1522  # XXX TODO Check for method_named as last argument
1523  if ($op->type > 0 and
1524      $op->name eq 'entersub' and $op->first and $op->first->can('name') and
1525      $op->first->name eq 'pushmark' and
1526      # Foo->bar()  compile-time lookup, 34 = BARE in all versions
1527      (($op->first->next->name eq 'const' and $op->first->next->flags == 34)
1528       or $op->first->next->name eq 'padsv'      # or $foo->bar() run-time lookup
1529       or ($] < 5.010 and $op->first->next->name eq 'gvsv' and !$op->first->next->type  # 5.8 ex-gvsv
1530	   and $op->first->next->next->name eq 'const' and $op->first->next->next->flags == 34))
1531     ) {
1532    my $pkgop = $op->first->next;
1533    if ($] < 5.010 and !$op->first->next->type) { # 5.8 ex-gvsv
1534      $pkgop = $op->first->next->next;
1535    }
1536    warn "check package_pv ".$pkgop->name." for method_name\n" if $debug{cv};
1537    my $pv = svop_or_padop_pv($pkgop); # 5.13: need to store away the pkg pv
1538    if ($pv and $pv !~ /[! \(]/) {
1539      $package_pv = $pv;
1540      push_package($package_pv);
1541    } else {
1542      # mostly optimized-away padsv NULL pads with 5.8
1543      warn "package_pv for method_name not found\n" if $debug{cv};
1544    }
1545  }
1546  if ($op->type == $OP_CUSTOM) {
1547    warn sprintf("CUSTOM OP %s $op\n", $op->name) if $verbose;
1548  }
1549  $prev_op = $op;
1550  my $sibling;
1551  if ($have_sibparent and !$op->moresib) { # HAS_SIBLING
1552    $sibling = $op->parent;
1553    warn "sibparent ",$op->name," $sibling\n" if $verbose and $debug{op};
1554  } else {
1555    $sibling = $op->sibling;
1556  }
1557  return sprintf( "s\\_%x, s\\_%x, %s",
1558                  ${ $op->next },
1559                  $$sibling,
1560                  $op->_save_common_middle
1561                );
1562}
1563
1564sub B::OP::save {
1565  my ( $op, $level ) = @_;
1566  my $sym = objsym($op);
1567  return $sym if defined $sym;
1568  $level = 0 unless $level;
1569  my $type = $op->type;
1570  $nullop_count++ unless $type;
1571  if ( $type == $OP_THREADSV ) {
1572    # saves looking up ppaddr but it's a bit naughty to hard code this
1573    $init->add(sprintf( "(void)find_threadsv(%s);", cstring( $threadsv_names[ $op->targ ])));
1574  }
1575  if ( $type == $OP_UCFIRST ) {
1576    $B::C::fold = 1;
1577    if ($] >= 5.013009) {
1578      warn "enabling -ffold with ucfirst\n" if $verbose;
1579      require "utf8.pm" unless $savINC{"utf8.pm"};
1580      mark_package("utf8");
1581      load_utf8_heavy();
1582    }
1583  }
1584  if (ref($op) eq 'B::OP') { # check wrong BASEOPs
1585    # [perl #80622] Introducing the entrytry hack, needed since 5.12, fixed with 5.13.8 a425677
1586    #   ck_eval upgrades the UNOP entertry to a LOGOP, but B gets us just a B::OP (BASEOP).
1587    #   op->other points to the leavetry op, which is needed for the eval scope.
1588    if ($op->name eq 'entertry') {
1589      warn "[perl #80622] Upgrading entertry from BASEOP to LOGOP...\n" if $verbose;
1590      bless $op, 'B::LOGOP';
1591      return $op->save($level);
1592    }
1593  }
1594
1595  # since 5.10 nullified cops free their additional fields
1596  if ( $PERL510 and !$type and $OP_COP{ $op->targ } ) {
1597    warn sprintf( "Null COP: %d\n", $op->targ ) if $debug{cops};
1598    if (0 and $optimize_cop) {
1599      # XXX when is the NULL COP save to skip?
1600      # unsafe after entersub, entereval, anoncode, sort block (pushmark pushmark)
1601      # Rather skip this with CC not with C because we need the context.
1602      # XXX we dont have the prevop, it can be any op type.
1603      if ($verbose or $debug{cops}) {
1604        my $prevop = getsym(sprintf("&op_list[%d]", $opsect->index));
1605        warn sprintf( "Skip Null COP: %d, prev=\\s%x\n", $op->targ, $prevop);
1606      }
1607      return savesym( $op, $op->next->save );
1608    }
1609    if ($ITHREADS and $] >= 5.017) {
1610      $copsect->comment(
1611	      "$opsect_common, line, stashoff, file, hints, seq, warnings, hints_hash");
1612      $copsect->add(sprintf("%s, 0, 0, (char *)NULL, 0, 0, NULL, NULL",
1613			    $op->_save_common));
1614    }
1615    elsif ($ITHREADS and $] >= 5.016) {
1616      $copsect->comment(
1617        "$opsect_common, line, stashpv, file, stashlen, hints, seq, warnings, hints_hash");
1618      $copsect->add(sprintf("%s, 0, (char *)NULL, NULL, 0, 0, 0, NULL, NULL",
1619			    $op->_save_common));
1620    }
1621    elsif ($ITHREADS and $] >= 5.015004) {
1622      $copsect->comment(
1623        "$opsect_common, line, stash, file, hints, seq, warnings, hints_hash");
1624      $copsect->add(sprintf("%s, 0, (char *)NULL, NULL, 0, 0, NULL, NULL",
1625			    $op->_save_common));
1626    }
1627    elsif ($PERL512) {
1628      $copsect->comment(
1629        "$opsect_common, line, stash, file, hints, seq, warnings, hints_hash");
1630      $copsect->add(sprintf("%s, 0, %s, NULL, 0, 0, NULL, NULL",
1631			    $op->_save_common, $ITHREADS ? "(char *)NULL" : "Nullhv"));
1632    }
1633    elsif ($PERL510) {
1634      $copsect->comment("$opsect_common, line, label, seq, warn_int, hints_hash");
1635      $copsect->add(sprintf("%s, %u, NULL, " . "NULL, NULL, 0, " . "%u, %d, NULL",
1636			    $op->_save_common, 0, 0, 0));
1637    }
1638    else {
1639      $copsect->comment(
1640        "$opsect_common, label, seq, arybase, line, warnings, hints_hash");
1641      $copsect->add(
1642        sprintf( "%s, NULL, NULL, NULL, 0, 0, 0, NULL", $op->_save_common ) );
1643    }
1644    my $ix = $copsect->index;
1645    $init->add( sprintf( "cop_list[%d].op_ppaddr = %s;", $ix, $op->ppaddr ) )
1646      unless $B::C::optimize_ppaddr;
1647    savesym( $op, "(OP*)&cop_list[$ix]" );
1648  }
1649  else {
1650    $opsect->comment($opsect_common);
1651    $opsect->add( $op->_save_common );
1652
1653    $opsect->debug( $op->name, $op->flagspv ) if $debug{flags};
1654    my $ix = $opsect->index;
1655    $init->add( sprintf( "op_list[%d].op_ppaddr = %s;", $ix, $op->ppaddr ) )
1656      unless $B::C::optimize_ppaddr;
1657    warn( sprintf( "  OP=%s targ=%d flags=0x%x private=0x%x\n",
1658		   peekop($op), $op->targ, $op->flags, $op->private ) ) if $debug{op};
1659    savesym( $op, "&op_list[$ix]" );
1660  }
1661}
1662
1663# needed for special GV logic: save only stashes for stashes
1664package B::STASHGV;
1665our @ISA = ('B::GV');
1666
1667package B::FAKEOP;
1668
1669our @ISA = qw(B::OP);
1670
1671sub new {
1672  my ( $class, %objdata ) = @_;
1673  bless \%objdata, $class;
1674}
1675
1676sub save {
1677  my ( $op, $level ) = @_;
1678  $opsect->add(
1679    sprintf( "%s, %s, %s", $op->next, $op->sibling, $op->_save_common_middle )
1680  );
1681  my $ix = $opsect->index;
1682  $init->add( sprintf( "op_list[%d].op_ppaddr = %s;", $ix, $op->ppaddr ) )
1683    unless $B::C::optimize_ppaddr;
1684  return "&op_list[$ix]";
1685}
1686
1687*_save_common_middle = \&B::OP::_save_common_middle;
1688sub next    { $_[0]->{"next"}  || 0 }
1689sub type    { $_[0]->{type}    || 0 }
1690sub sibling { $_[0]->{sibling} || 0 }
1691sub moresib { $_[0]->{moresib} || 0 }
1692sub parent  { $_[0]->{parent}  || 0 }
1693sub ppaddr  { $_[0]->{ppaddr}  || 0 }
1694sub targ    { $_[0]->{targ}    || 0 }
1695sub flags   { $_[0]->{flags}   || 0 }
1696sub private { $_[0]->{private} || 0 }
1697sub rettype { $_[0]->{rettype} || 0 }
1698
1699package B::C;
1700
1701# dummy for B::C, only needed for B::CC
1702sub label {}
1703
1704# save alternate ops if defined, and also add labels (needed for B::CC)
1705sub do_labels ($$@) {
1706  my $op = shift;
1707  my $level = shift;
1708  for my $m (@_) {
1709    no strict 'refs';
1710    my $mo = $op->$m if $m;
1711    if ( $mo and $$mo ) {
1712      label($mo);
1713      $mo->save($level) if $m ne 'first'
1714        or ($op->flags & 4
1715            and !($op->name eq 'const' and $op->flags & 64)); #OPpCONST_BARE has no first
1716    }
1717  }
1718}
1719
1720sub B::UNOP::save {
1721  my ( $op, $level ) = @_;
1722  my $sym = objsym($op);
1723  return $sym if defined $sym;
1724  $level = 0 unless $level;
1725  $unopsect->comment("$opsect_common, first");
1726  $unopsect->add( sprintf( "%s, s\\_%x", $op->_save_common, ${ $op->first } ) );
1727  $unopsect->debug( $op->name, $op->flagspv ) if $debug{flags};
1728  my $ix = $unopsect->index;
1729  $init->add( sprintf( "unop_list[%d].op_ppaddr = %s;", $ix, $op->ppaddr ) )
1730    unless $B::C::optimize_ppaddr;
1731  $sym = savesym( $op, "(OP*)&unop_list[$ix]" );
1732  if ($op->name eq 'method' and $op->first and $op->first->name eq 'const') {
1733    my $method = svop_name($op->first);
1734    if (!$method and $ITHREADS) {
1735      $method = padop_name($op->first, curcv); # XXX (curpad[targ])
1736    }
1737    warn "method -> const $method\n" if $debug{pkg} and $ITHREADS;
1738    #324,#326 need to detect ->(maybe::next|maybe|next)::(method|can)
1739    if ($method =~ /^(maybe::next|maybe|next)::(method|can)$/) {
1740      warn "mark \"$1\" for method $method\n" if $debug{pkg};
1741      mark_package($1, 1);
1742      mark_package("mro", 1);
1743    } # and also the old 5.8 NEXT|EVERY with non-fixed method names und subpackages
1744    elsif ($method =~ /^(NEXT|EVERY)::/) {
1745      warn "mark \"$1\" for method $method\n" if $debug{pkg};
1746      mark_package($1, 1);
1747      mark_package("NEXT", 1) if $1 ne "NEXT";
1748    }
1749  }
1750  do_labels ($op, $level+1, 'first');
1751  $sym;
1752}
1753
1754sub is_constant {
1755  my $s = shift;
1756  return 1 if $s =~ /^(&sv_list|\-?\d+|Nullsv)/; # not gv_list, hek
1757  return 0;
1758}
1759
1760sub B::UNOP_AUX::save {
1761  my ( $op, $level ) = @_;
1762  my $sym = objsym($op);
1763  return $sym if defined $sym;
1764  $level = 0 unless $level;
1765  my $cvref = B::main_cv;
1766  my @aux_list = $op->name eq 'multideref'
1767    ? $op->aux_list_thr # our own version. GH#283, GH#341
1768    : $op->aux_list($cvref);
1769  my $auxlen = scalar @aux_list;
1770  $auxlen = $aux_list[0] + 6 if $op->name eq 'multiconcat';
1771  $unopauxsect->comment("$opsect_common, first, aux");
1772  my $ix = $unopauxsect->index + 1;
1773  $unopauxsect->add(
1774    sprintf("%s, s\\_%x, %s+1",
1775            $op->_save_common, ${ $op->first }, "unopaux_item${ix}"));
1776  $unopauxsect->debug( $op->name, $op->flagspv ) if $debug{flags};
1777  # This cannot be a section, as the number of elements is variable
1778  my $i = 1;
1779  my $s = "Static UNOP_AUX_item unopaux_item".$ix."[] = { /* ".$op->name." */\n\t"
1780    .($C99?"{.uv=$auxlen}":$auxlen). " \t/* length prefix */\n";
1781  my $action = 0;
1782  my ($nargs);
1783  for my $item (@aux_list) {
1784    unless (ref $item) {
1785      # symbolize MDEREF, SIGNATURE, MCONCAT actions and flags, just for the comments
1786      my $cmt = 'action';
1787      if ($op->name eq 'multiconcat') {
1788        # TODO: test 27
1789        # nargs, consts, len 0, 1, ...
1790        if ($i == 1) {
1791          $nargs = $item;
1792        }
1793        elsif ($i == 2) {
1794          my ($pv,$len,$utf8) = strlen_flags($item);
1795          if ($utf8) {
1796            $s .= ($C99 ? sprintf("\t,{.pv=NULL} \t/* plain_pv */\n")
1797                   : sprintf("\t,NULL \t/* plain_pv */\n"));
1798            $s .= ($C99 ? sprintf("\t,{.uv=0} \t/* plain_len */\n")
1799                   : sprintf("\t,0 \t/* plain_len */\n"));
1800            $s .= ($C99 ? sprintf("\t,{.pv=%s} \t/* utf8_pv */\n", $pv)
1801                   : sprintf("\t,%s \t/* utf8_pv */\n", $pv));
1802            $s .= ($C99 ? sprintf("\t,{.uv=%u} \t/* utf8_len */\n", $len)
1803                   : sprintf("\t,%u \t/* utf8_len */\n", $len));
1804          } else {
1805            $s .= ($C99 ? sprintf("\t,{.pv=%s} \t/* plain_pv */\n", $pv)
1806                   : sprintf("\t,%s \t/* plain_pv */\n", $pv));
1807            $s .= ($C99 ? sprintf("\t,{.uv=%u} \t/* plain_len */\n", $len)
1808                   : sprintf("\t,%u \t/* plain_len */\n", $len));
1809            $s .= ($C99 ? sprintf("\t,{.pv=NULL} \t/* utf8_pv */\n")
1810                   : sprintf("\t,NULL \t/* utf8_pv */\n"));
1811            $s .= ($C99 ? sprintf("\t,{.uv=0} \t/* utf8_len */\n")
1812                   : sprintf("\t,0 \t/* utf8_len */\n"));
1813          }
1814          $i++;
1815          next;
1816        }
1817        elsif ($i > 2) {
1818          die "Overflow multiconcat nargs $nargs" if $i-3 > $nargs;
1819        }
1820      }
1821      if ($verbose) {
1822        if ($op->name eq 'multideref') {
1823          my $act = $item & 0xf;  # MDEREF_ACTION_MASK
1824          $cmt = 'AV_pop_rv2av_aelem'          if $act == 1;
1825          $cmt = 'AV_gvsv_vivify_rv2av_aelem'  if $act == 2;
1826          $cmt = 'AV_padsv_vivify_rv2av_aelem' if $act == 3;
1827          $cmt = 'AV_vivify_rv2av_aelem'       if $act == 4;
1828          $cmt = 'AV_padav_aelem'              if $act == 5;
1829          $cmt = 'AV_gvav_aelem'               if $act == 6;
1830          $cmt = 'HV_pop_rv2hv_helem'          if $act == 8;
1831          $cmt = 'HV_gvsv_vivify_rv2hv_helem'  if $act == 9;
1832          $cmt = 'HV_padsv_vivify_rv2hv_helem' if $act == 10;
1833          $cmt = 'HV_vivify_rv2hv_helem'       if $act == 11;
1834          $cmt = 'HV_padhv_helem'              if $act == 12;
1835          $cmt = 'HV_gvhv_helem'               if $act == 13;
1836          my $idx = $item & 0x30; # MDEREF_INDEX_MASK
1837          #$cmt .= ''             if $idx == 0x0;
1838          $cmt .= ' INDEX_const'  if $idx == 0x10;
1839          $cmt .= ' INDEX_padsv'  if $idx == 0x20;
1840          $cmt .= ' INDEX_gvsv'   if $idx == 0x30;
1841        }
1842        elsif ($op->name eq 'signature') {
1843          my $act = $item & 0xf;  # SIGNATURE_ACTION_MASK
1844          $cmt = 'reload' 		if $act == 0;
1845          $cmt = 'end' 			if $act == 1;
1846          $cmt = 'padintro' 		if $act == 2;
1847          $cmt = 'arg' 			if $act == 3;
1848          $cmt = 'arg_default_none'  	if $act == 4;
1849          $cmt = 'arg_default_undef' 	if $act == 5;
1850          $cmt = 'arg_default_0' 	if $act == 6;
1851          $cmt = 'arg_default_1' 	if $act == 7;
1852          $cmt = 'arg_default_iv' 	if $act == 8;
1853          $cmt = 'arg_default_const' 	if $act == 9;
1854          $cmt = 'arg_default_padsv' 	if $act == 10;
1855          $cmt = 'arg_default_gvsv' 	if $act == 11;
1856          $cmt = 'arg_default_op' 	if $act == 12;
1857          $cmt = 'array' 		if $act == 13;
1858          $cmt = 'hash' 		if $act == 14;
1859          my $idx = $item & 0x3F; # SIGNATURE_MASK
1860          $cmt .= '' 		if $idx == 0x0;
1861          $cmt .= ' flag skip'  if $idx == 0x10;
1862          $cmt .= ' flag ref'   if $idx == 0x20;
1863        }
1864        elsif ($op->name eq 'multiconcat') {
1865          # nargs, consts, len 0, 1, ...
1866          if ($i == 1) {
1867            $cmt = 'nargs';
1868          }
1869          elsif ($i > 2) {
1870            $cmt = sprintf "lengths[%d]", $i-3;
1871          }
1872        } else {
1873          die "Unknown UNOP_AUX op ".$op->name;
1874        }
1875      }
1876      $action = $item;
1877      warn "{$op->name} action $action $cmt\n" if $debug{hv};
1878      $s .= ($C99 ? sprintf("\t,{.uv=0x%x} \t/* %s: %d */\n", $item, $cmt, $item)
1879                  : sprintf("\t,0x%x \t/* %s: %d */\n", $item, $cmt, $item));
1880    } else {
1881      # const and sv already at compile-time, gv deferred to init-time.
1882      # testcase: $a[-1] -1 as B::IV not as -1
1883      # hmm, if const ensure that candidate CONSTs have been HEKified. (pp_multideref assertion)
1884      # || SvTYPE(keysv) >= SVt_PVMG
1885      # || !SvOK(keysv)
1886      # || SvROK(keysv)
1887      # || SvIsCOW_shared_hash(keysv));
1888      my $constkey = ($action & 0x30) == 0x10 ? 1 : 0;
1889      my $itemsym = $item->save("unopaux_item".$ix."[".$i."]" . ($constkey ? " const" : ""));
1890      if (is_constant($itemsym)) {
1891        if (ref $item eq 'B::IV') {
1892          my $iv = $item->IVX;
1893          $s .= ($C99 ? "\t,{.iv=$iv}\n"
1894                 : "\t,PTR2IV($iv)\n");
1895        } elsif (ref $item eq 'B::UV') { # also for PAD_OFFSET
1896          my $uv = $item->UVX;
1897          $s .= ($C99 ? "\t,{.uv=$uv}\n"
1898                 : "\t,PTR2IV($uv)\n");
1899        } else { # SV
1900          $s .= ($C99 ? "\t,{.sv=$itemsym}\n"
1901                 : "\t,PTR2UV($itemsym)\n");
1902        }
1903      } else {
1904        # gv or other late inits
1905        $s .= ($C99 ? "\t,{.sv=Nullsv} \t/* $itemsym */\n"
1906                    : "\t,0 \t/* $itemsym */\n");
1907        $init->add("unopaux_item".$ix."[".$i."].sv = (SV*)$itemsym;");
1908      }
1909    }
1910    $i++;
1911  }
1912  $decl->add($s."};");
1913  $init->add( sprintf( "unopaux_list[%d].op_ppaddr = %s;", $ix, $op->ppaddr ) )
1914    unless $B::C::optimize_ppaddr;
1915  $sym = savesym( $op, "(OP*)&unopaux_list[$ix]" );
1916  push @B::C::static_free, $sym;
1917  # $free->add("    ($sym)->op_type = OP_NULL;");
1918  do_labels ($op, $level+1, 'first');
1919  $sym;
1920}
1921
1922# cannot save it statically in a sect. need the class (ref) and the ppaddr
1923#sub B::XOP::save {
1924#  my ( $op, $level ) = @_;
1925#  my $sym = objsym($op);
1926#  return $sym if defined $sym;
1927#  # which class
1928#  $binopsect->comment("$opsect_common, first, last");
1929#  $binopsect->add(
1930#    sprintf( "%s, s\\_%x, s\\_%x",
1931#             $op->_save_common,
1932#             ${ $op->first },
1933#             ${ $op->last } ));
1934#  $binopsect->debug( $op->name, $op->flagspv ) if $debug{flags};
1935#  my $ix = $binopsect->index;
1936#  $init->add( sprintf( "binop_list[%d].op_ppaddr = %s;", $ix, $op->ppaddr ) )
1937#    unless $B::C::optimize_ppaddr;
1938#  $sym = savesym( $op, "(OP*)&binop_list[$ix]" );
1939#  do_labels ($op, $level+1, 'first', 'last');
1940#  $sym;
1941#}
1942
1943sub B::BINOP::save {
1944  my ( $op, $level ) = @_;
1945  my $sym = objsym($op);
1946  return $sym if defined $sym;
1947  #return B::XOP::save(@_) if $op->type == $OP_CUSTOM;
1948
1949  $level = 0 unless $level;
1950  $binopsect->comment("$opsect_common, first, last");
1951  $binopsect->add(
1952    sprintf( "%s, s\\_%x, s\\_%x",
1953             $op->_save_common,
1954             ${ $op->first },
1955             ${ $op->last } ));
1956  $binopsect->debug( $op->name, $op->flagspv ) if $debug{flags};
1957  my $ix = $binopsect->index;
1958  my $ppaddr = $op->ppaddr;
1959  if ($op->type == $OP_CUSTOM) {
1960    my $ptr = $$op;
1961    if ($] >= 5.019003 and ($op->name eq 'Devel_Peek_Dump' or $op->name eq 'Dump')){
1962      warn "custom op Devel_Peek_Dump\n" if $verbose;
1963      $decl->add('
1964static void
1965S_do_dump(pTHX_ SV *const sv, I32 lim)
1966{
1967    dVAR;
1968    SV *pv_lim_sv = get_svs("Devel::Peek::pv_limit", 0);
1969    const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0;
1970    SV *dumpop = get_svs("Devel::Peek::dump_ops", 0);
1971    const U16 save_dumpindent = PL_dumpindent;
1972    PL_dumpindent = 2;
1973    do_sv_dump(0, Perl_debug_log, sv, 0, lim,
1974	       (bool)(dumpop && SvTRUE(dumpop)), pv_lim);
1975    PL_dumpindent = save_dumpindent;
1976}
1977static OP *
1978S_pp_dump(pTHX)
1979{
1980    dSP;
1981    const I32 lim = PL_op->op_private == 2 ? (I32)POPi : 4;
1982    dPOPss;
1983    S_do_dump(aTHX_ sv, lim);
1984    RETPUSHUNDEF;
1985  }') unless $B::C::Devel_Peek_Dump_added;
1986      $ppaddr = 'S_pp_dump';
1987      $B::C::Devel_Peek_Dump_added++;
1988      $init->add( sprintf( "binop_list[%d].op_ppaddr = %s;", $ix, $ppaddr ));
1989    } else {
1990      warn "Warning: Unknown custom op ".$op->name."\n" if $verbose;
1991      $ppaddr = sprintf('Perl_custom_op_xop(aTHX_ INT2PTR(OP*, 0x%x))', $$op);
1992      $init->add( sprintf( "binop_list[%d].op_ppaddr = %s;", $ix, $ppaddr ));
1993    }
1994  } else {
1995    $init->add( sprintf( "binop_list[%d].op_ppaddr = %s;", $ix, $ppaddr ) )
1996      unless $B::C::optimize_ppaddr;
1997  }
1998  $sym = savesym( $op, "(OP*)&binop_list[$ix]" );
1999  do_labels ($op, $level+1, 'first', 'last');
2000  $sym;
2001}
2002
2003sub B::LISTOP::save {
2004  my ( $op, $level ) = @_;
2005  my $sym = objsym($op);
2006  return $sym if defined $sym;
2007  $level = 0 unless $level;
2008  $listopsect->comment("$opsect_common, first, last");
2009  $listopsect->add(
2010    sprintf( "%s, s\\_%x, s\\_%x",
2011             $op->_save_common,
2012             ${ $op->first },
2013             ${ $op->last } ));
2014  $listopsect->debug( $op->name, $op->flagspv ) if $debug{flags};
2015  my $ix = $listopsect->index;
2016  $init->add( sprintf( "listop_list[%d].op_ppaddr = %s;", $ix, $op->ppaddr ) )
2017    unless $B::C::optimize_ppaddr;
2018  $sym = savesym( $op, "(OP*)&listop_list[$ix]" );
2019  if ($op->type == $OP_DBMOPEN) {
2020    # resolves it at compile-time, not at run-time
2021    mark_package('AnyDBM_File'); # to save $INC{AnyDBM_File}
2022    require AnyDBM_File unless $savINC{'AnyDBM_File.pm'};
2023    $curINC{'AnyDBM_File.pm'} = $INC{'AnyDBM_File.pm'};
2024    AnyDBM_File->import;            # strip the @ISA
2025    my $dbm = $AnyDBM_File::ISA[0]; # take the winner (only)
2026    svref_2object( \&{"$dbm\::bootstrap"} )->save;
2027    svref_2object( \&{"$dbm\::TIEHASH"} )->save; # called by pp_dbmopen
2028    $curINC{$dbm.".pm"} = $INC{$dbm.".pm"};
2029  } elsif ($op->type == $OP_FORMLINE and $B::C::const_strings) { # -O3 ~
2030    # non-static only for all const strings containing ~ #277
2031    my $sv;
2032    my $fop = $op;
2033    my $svop = $op->first;
2034    while ($svop != $op and ref($svop) ne 'B::NULL') {
2035      if ($svop->name eq 'const' and $svop->can('sv')) {
2036        $sv = $svop->sv;
2037      }
2038      if ($sv and $sv->can("PV") and $sv->PV and $sv->PV =~ /~/m) {
2039        local $B::C::const_strings;
2040        warn "force non-static formline arg ",cstring($sv->PV),"\n" if $debug{pv};
2041        $svop->save($level, "svop const");
2042      }
2043      $svop = $svop->next;
2044    }
2045  }
2046  do_labels ($op, $level+1, 'first', 'last');
2047  $sym;
2048}
2049
2050sub B::LOGOP::save {
2051  my ( $op, $level ) = @_;
2052  my $sym = objsym($op);
2053  return $sym if defined $sym;
2054  $level = 0 unless $level;
2055  $logopsect->comment("$opsect_common, first, other");
2056  $logopsect->add(
2057    sprintf( "%s, s\\_%x, s\\_%x",
2058             $op->_save_common,
2059             ${ $op->first },
2060             ${ $op->other } ));
2061  $logopsect->debug( $op->name, $op->flagspv ) if $debug{flags};
2062  my $ix = $logopsect->index;
2063  $init->add( sprintf( "logop_list[%d].op_ppaddr = %s;", $ix, $op->ppaddr ) )
2064    unless $B::C::optimize_ppaddr;
2065  $sym = savesym( $op, "(OP*)&logop_list[$ix]" );
2066  do_labels ($op, $level+1, 'first', 'other');
2067  $sym;
2068}
2069
2070sub B::LOOP::save {
2071  my ( $op, $level ) = @_;
2072  my $sym = objsym($op);
2073  return $sym if defined $sym;
2074
2075  $level = 0 unless $level;
2076  #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
2077  #		 peekop($op->redoop), peekop($op->nextop),
2078  #		 peekop($op->lastop)) if $debug{op};
2079  $loopsect->comment("$opsect_common, first, last, redoop, nextop, lastop");
2080  $loopsect->add(
2081    sprintf(
2082      "%s, s\\_%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x",
2083      $op->_save_common,
2084      ${ $op->first },
2085      ${ $op->last },
2086      ${ $op->redoop },
2087      ${ $op->nextop },
2088      ${ $op->lastop }
2089    )
2090  );
2091  $loopsect->debug( $op->name, $op->flagspv ) if $debug{flags};
2092  my $ix = $loopsect->index;
2093  $init->add( sprintf( "loop_list[%d].op_ppaddr = %s;", $ix, $op->ppaddr ) )
2094    unless $B::C::optimize_ppaddr;
2095  $sym = savesym( $op, "(OP*)&loop_list[$ix]" );
2096  do_labels($op, $level+1, qw(first last redoop nextop lastop));
2097  $sym;
2098}
2099
2100sub B::METHOP::save {
2101  my ( $op, $level ) = @_;
2102  my $sym = objsym($op);
2103  return $sym if defined $sym;
2104  $level = 0 unless $level;
2105  $methopsect->comment("$opsect_common, first, rclass");
2106  my $union = $op->name eq 'method' ? "{.op_first=(OP*)%s}" : "{.op_meth_sv=(SV*)%s}";
2107  $union = "%s" unless $C99;
2108  my $s = "%s, $union, ". ($ITHREADS ? "(PADOFFSET)%s" : "(SV*)%s"); # rclass
2109  my $ix = $methopsect->index + 1;
2110  my $rclass = $ITHREADS ? $op->rclass : $op->rclass->save("op_rclass_sv");
2111  if ($rclass =~ /^&sv_list/) {
2112    $init->add( sprintf( "SvREFCNT_inc_simple_NN(%s); /* methop_list[%d].op_rclass_sv */",
2113                         $rclass, $ix ));
2114    # Put this simple PV into the PL_stashcache, it has no STASH,
2115    # and initialize the method cache.
2116    # TODO: backref magic for next, init the next::method cache
2117    $init->add( sprintf( "Perl_mro_method_changed_in(aTHX_ gv_stashsv(%s, GV_ADD));",
2118                         $rclass ));
2119  }
2120  my $first = $op->name eq 'method' ? $op->first->save : $op->meth_sv->save;
2121  if ($first =~ /^&sv_list/) {
2122    $init->add( sprintf( "SvREFCNT_inc_simple_NN(%s); /* methop_list[%d].op_meth_sv */",
2123                         $first, $ix ));
2124  }
2125  $first = 'NULL' if !$C99 and $first eq 'Nullsv';
2126  $methopsect->add(sprintf($s, $op->_save_common, $first, $rclass));
2127  $methopsect->debug( $op->name, $op->flagspv ) if $debug{flags};
2128  $init->add( sprintf( "methop_list[%d].op_ppaddr = %s;", $ix, $op->ppaddr ) )
2129    unless $B::C::optimize_ppaddr;
2130  $sym = savesym( $op, "(OP*)&methop_list[$ix]" );
2131  if ($op->name eq 'method') {
2132    do_labels($op, $level+1, 'first', 'rclass');
2133  } else {
2134    do_labels($op, $level+1, 'meth_sv', 'rclass');
2135  }
2136  $sym;
2137}
2138
2139sub B::PVOP::save {
2140  my ( $op, $level ) = @_;
2141  my $sym = objsym($op);
2142  return $sym if defined $sym;
2143  $level = 0 unless $level;
2144  # op_pv must be dynamic
2145  $pvopsect->comment("$opsect_common, pv");
2146  $pvopsect->add( sprintf( "%s, NULL", $op->_save_common ) );
2147  $pvopsect->debug( $op->name, $op->flagspv ) if $debug{flags};
2148  my $ix = $pvopsect->index;
2149  $init->add( sprintf( "pvop_list[%d].op_ppaddr = %s;", $ix, $op->ppaddr ) )
2150    unless $B::C::optimize_ppaddr;
2151  my ($cstring,$cur,$utf8) = strlen_flags($op->pv); # utf8 in op_private as OPpPV_IS_UTF8 (0x80)
2152  # do not use savepvn here #362
2153  $init->add( sprintf( "pvop_list[%d].op_pv = savesharedpvn(%s, %u);", $ix, $cstring, $cur ));
2154  savesym( $op, "(OP*)&pvop_list[$ix]" );
2155}
2156
2157# XXX Until we know exactly the package name for a method_call
2158# we improve the method search heuristics by maintaining this mru list.
2159sub push_package ($) {
2160  my $p = shift or return;
2161  warn "save package_pv \"$package_pv\" for method_name from @{[(caller(1))[3]]}\n"
2162    if $debug{cv} or $debug{pkg} and !grep { $p eq $_ } @package_pv;
2163  @package_pv = grep { $p ne $_ } @package_pv if @package_pv; # remove duplicates at the end
2164  unshift @package_pv, $p; 		       # prepend at the front
2165  mark_package($p);
2166}
2167
2168# method_named is in 5.6.1
2169sub method_named {
2170  my $name = shift;
2171  return unless $name;
2172  my $cop = shift;
2173  my $loc = $cop ? " at ".$cop->file." line ".$cop->line : "";
2174  # Note: the pkg PV is unacessible(?) at PL_stack_base+TOPMARK+1.
2175  # But it is also at the const or padsv after the pushmark, before all args.
2176  # See L<perloptree/"Call a method">
2177  # We check it in op->_save_common
2178  if (ref($name) eq 'B::CV') {
2179    warn $name;
2180    return $name;
2181  }
2182  my $method;
2183  for ($package_pv, @package_pv, 'main') {
2184    no strict 'refs';
2185    next unless defined $_;
2186    $method = $_ . '::' . $name;
2187    if (defined(&$method)) {
2188      warn sprintf( "Found &%s::%s\n", $_, $name ) if $debug{cv};
2189      $include_package{$_} = 1; # issue59
2190      mark_package($_, 1);
2191      last;
2192    } else {
2193      if (my $parent = try_isa($_,$name)) {
2194	warn sprintf( "Found &%s::%s\n", $parent, $name ) if $debug{cv};
2195	$method = $parent . '::' . $name;
2196	$include_package{$parent} = 1;
2197	last;
2198      }
2199      warn "no definition for method_name \"$method\"\n" if $debug{cv};
2200    }
2201  }
2202  #my $b = $Config{archname}."/B\.pm";
2203  #if ($name !~ /^tid|can|isa|pmreplroot$/ and $loc !~ m/$b line / and $package_pv !~ /^B::/) {
2204  #  return undef if $ITHREADS;
2205  #}
2206  $method = $name unless $method;
2207  if (exists &$method) { # Do not try to save non-existing methods
2208    warn "save method_name \"$method\"$loc\n" if $debug{cv};
2209    return svref_2object( \&{$method} );
2210  } else {
2211    return 0;
2212  }
2213}
2214
2215
2216# scalar: pv. list: (stash,pv,sv)
2217# pads are not named, but may be typed
2218sub padop_name {
2219  my $op = shift;
2220  my $cv = shift;
2221  if ($op->can('name')
2222      and ($op->name eq 'padsv' or $op->name eq 'method_named'
2223	   or ref($op) eq 'B::SVOP')) #threaded
2224  {
2225    return () if $cv and ref($cv->PADLIST) eq 'B::SPECIAL';
2226    my @c = ($cv and ref($cv) eq 'B::CV' and ref($cv->PADLIST) ne 'B::NULL')
2227             ? $cv->PADLIST->ARRAY : comppadlist->ARRAY;
2228    my @types = $c[0]->ARRAY;
2229    my @pad  = $c[1]->ARRAY;
2230    my $ix = $op->can('padix') ? $op->padix : $op->targ;
2231    my $sv = $pad[$ix];
2232    my $t = $types[$ix];
2233    if (defined($t) and ref($t) ne 'B::SPECIAL') {
2234      my $pv = $sv->can("PV") ? $sv->PV : ($t->can('PVX') ? $t->PVX : '');
2235      # need to fix B for SVpad_TYPEDI without formal STASH
2236      my $stash = (ref($t) eq 'B::PVMG' and ref($t->SvSTASH) ne 'B::SPECIAL') ? $t->SvSTASH->NAME : '';
2237      return wantarray ? ($stash,$pv,$sv) : $pv;
2238    } elsif ($sv) {
2239      my $pv = $sv->PV if $sv->can("PV");
2240      my $stash = $sv->STASH->NAME if $sv->can("STASH");
2241      return wantarray ? ($stash,$pv,$sv) : $pv;
2242    }
2243  }
2244}
2245
2246sub svop_name {
2247  my $op = shift;
2248  my $cv = shift;
2249  my $sv;
2250  if ($op->can('name') and $op->name eq 'padsv') {
2251    my @r = padop_name($op, $cv);
2252    return wantarray ? @r : ($r[1] ? $r[1] : $r[0]);
2253  } else {
2254    if (!$op->can("sv")) {
2255      if (ref($op) eq 'B::PMOP' and $op->pmreplroot->can("sv")) {
2256	$sv = $op->pmreplroot->sv;
2257      } else {
2258	$sv = $op->first->sv unless $op->flags & 4
2259	  or ($op->name eq 'const' and $op->flags & 34) or $op->first->can("sv");
2260      }
2261    } else {
2262      $sv = $op->sv;
2263    }
2264    if ($sv and $$sv) {
2265      if ($sv->FLAGS & SVf_ROK) {
2266	return '' if $sv->isa("B::NULL");
2267	my $rv = $sv->RV;
2268	if ($rv->isa("B::PVGV")) {
2269	  my $o = $rv->IO;
2270	  return $o->STASH->NAME if $$o;
2271	}
2272	return '' if $rv->isa("B::PVMG");
2273	return $rv->STASH->NAME;
2274      } else {
2275	if ($op->name eq 'gvsv') {
2276	  return wantarray ? ($sv->STASH->NAME, $sv->NAME) : $sv->STASH->NAME.'::'.$sv->NAME;
2277	} elsif ($op->name eq 'gv') {
2278	  return wantarray ? ($sv->STASH->NAME, $sv->NAME) : $sv->STASH->NAME.'::'.$sv->NAME;
2279	} else {
2280	  return $sv->can('STASH') ? $sv->STASH->NAME
2281	    : $sv->can('NAME') ? $sv->NAME : $sv->PV;
2282	}
2283      }
2284    }
2285  }
2286}
2287
2288# return the next COP for file and line info
2289sub nextcop {
2290  my $op = shift;
2291  while ($op and ref($op) ne 'B::COP' and ref($op) ne 'B::NULL') { $op = $op->next; }
2292  return ($op and ref($op) eq 'B::COP') ? $op : undef;
2293}
2294
2295sub svimmortal {
2296  my $sym = shift;
2297  if ($sym =~ /(\(SV\*\))?\&PL_sv_(yes|no|undef|placeholder|zero)/) {
2298    return 1;
2299  }
2300  return undef;
2301}
2302
2303sub B::SVOP::save {
2304  my ( $op, $level, $fullname ) = @_;
2305  my $sym = objsym($op);
2306  return $sym if defined $sym;
2307  $level = 0 unless $level;
2308  my $svsym = 'Nullsv';
2309  # XXX moose1 crash with 5.8.5-nt, Cwd::_perl_abs_path also
2310  if ($op->name eq 'aelemfast' and $op->flags & 128) { #OPf_SPECIAL
2311    $svsym = '&PL_sv_undef'; # pad does not need to be saved
2312    warn sprintf("SVOP->sv aelemfast pad %d\n", $op->flags) if $debug{sv};
2313  } elsif ($op->name eq 'gv' and $op->next and $op->next->name eq 'rv2cv'
2314	   and $op->next->next and $op->next->next->name eq 'defined' ) {
2315    # 96 do not save a gvsv->cv if just checked for defined'ness
2316    my $gv = $op->sv;
2317    my $gvsv = svop_name($op);
2318    if ($gvsv !~ /^DynaLoader::/) {
2319      warn "skip saving defined(&$gvsv)\n" if $debug{gv}; # defer to run-time
2320      $svsym  = '(SV*)' . $gv->save( 8 ); # ~Save_CV in B::GV::save
2321    } else {
2322      $svsym  = '(SV*)' . $gv->save();
2323    }
2324  } else {
2325    my $sv  = $op->sv;
2326    $svsym  = $sv->save("svop ".$op->name);
2327    if ($svsym =~ /^(gv_|PL_.*gv)/) {
2328      $svsym = '(SV*)' . $svsym;
2329    } elsif ($svsym =~ /^\([SAHC]V\*\)\&sv_list/) {
2330      $svsym =~ s/^\([SAHC]V\*\)//;
2331    } else {
2332      $svsym =~ s/^\([GAPH]V\*\)/(SV*)/;
2333    }
2334    warn "Error: SVOP: ".$op->name." $sv $svsym" if $svsym =~ /^\(SV\*\)lexwarn/; #322
2335  }
2336  if ($op->name eq 'method_named') {
2337    my $cv = method_named(svop_or_padop_pv($op), nextcop($op));
2338    $cv->save if $cv;
2339  }
2340  my $is_const_addr = $svsym =~ m/Null|\&/;
2341  if ($MULTI and svimmortal($svsym)) { # dVAR access. e.g. t/testm.sh Test::Pod
2342    $is_const_addr = 0;
2343  }
2344  $svopsect->comment("$opsect_common, sv");
2345  $svopsect->add(sprintf( "%s, %s",
2346      $op->_save_common, ( $is_const_addr ? $svsym : "Nullsv /* $svsym */" ) )
2347  );
2348  $svopsect->debug( $op->name, $op->flagspv ) if $debug{flags};
2349  my $ix = $svopsect->index;
2350  $init->add( sprintf( "svop_list[%d].op_ppaddr = %s;", $ix, $op->ppaddr ) )
2351    unless $B::C::optimize_ppaddr;
2352  $init->add("svop_list[$ix].op_sv = $svsym;")
2353    unless $is_const_addr;
2354  savesym( $op, "(OP*)&svop_list[$ix]" );
2355}
2356
2357sub B::PADOP::save {
2358  my ( $op, $level ) = @_;
2359  my $sym = objsym($op);
2360  return $sym if defined $sym;
2361  $level = 0 unless $level;
2362  my $skip_defined;
2363  if ($op->name eq 'method_named') {
2364    my $cv = method_named(svop_or_padop_pv($op), nextcop($op));
2365    $cv->save if $cv;
2366  } elsif ($op->name eq 'gv' and $op->next and $op->next->name eq 'rv2cv'
2367	   and $op->next->next and $op->next->next->name eq 'defined' ) {
2368    # 96 do not save a gvsv->cv if just checked for defined'ness
2369    $skip_defined++;
2370  }
2371  # This is saved by curpad syms at the end. But with __DATA__ handles it is better to save earlier
2372  if ($op->name eq 'padsv' or $op->name eq 'gvsv' or $op->name eq 'gv') {
2373    my @c = comppadlist->ARRAY;
2374    my @pad = $c[1]->ARRAY;
2375    my $ix = $op->can('padix') ? $op->padix : $op->targ;
2376    my $sv = $pad[$ix];
2377    if ($sv and $$sv) {
2378      my $name = padop_name($op, curcv);
2379      if ($skip_defined and $name !~ /^DynaLoader::/) {
2380	warn "skip saving defined(&$name)\n" if $debug{gv}; # defer to run-time
2381      } else {
2382	$sv->save("padop ". ($name ? $name : ''));
2383      }
2384    }
2385  }
2386  $padopsect->comment("$opsect_common, padix");
2387  $padopsect->add( sprintf( "%s, %d", $op->_save_common, $op->padix ) );
2388  $padopsect->debug( $op->name, $op->flagspv ) if $debug{flags};
2389  my $ix = $padopsect->index;
2390  $init->add( sprintf( "padop_list[%d].op_ppaddr = %s;", $ix, $op->ppaddr ) )
2391    unless $B::C::optimize_ppaddr;
2392  savesym( $op, "(OP*)&padop_list[$ix]" );
2393}
2394
2395sub B::COP::save {
2396  my ( $op, $level ) = @_;
2397  my $sym = objsym($op);
2398  return $sym if defined $sym;
2399
2400  $level = 0 unless $level;
2401  # we need to keep CvSTART cops, so check $level == 0
2402  # what a COP needs to do is to reset the stack, and restore locals
2403  if ($optimize_cop and $level and !$op->label
2404      and ref($prev_op) ne 'B::LISTOP') { # XXX very unsafe!
2405    my $sym = savesym( $op, $op->next->save );
2406    warn sprintf( "Skip COP (0x%x) => %s (0x%x), line %d file %s\n",
2407                  $$op, $sym, $op->next, $op->line, $op->file ) if $debug{cops};
2408    return $sym;
2409  }
2410
2411  # TODO: if it is a nullified COP we must save it with all cop fields!
2412  warn sprintf( "COP: line %d file %s\n", $op->line, $op->file )
2413    if $debug{cops};
2414
2415  # shameless cut'n'paste from B::Deparse
2416  my ($warn_sv, $isint);
2417  my $warnings   = $op->warnings;
2418  my $is_special = ref($warnings) eq 'B::SPECIAL';
2419  my $warnsvcast = $PERL510 ? "(STRLEN*)" : "(SV*)";
2420  if ( $is_special && $$warnings == 4 ) { # use warnings 'all';
2421    $warn_sv = 'pWARN_ALL';
2422  }
2423  elsif ( $is_special && $$warnings == 5 ) { # no warnings 'all';
2424    $warn_sv = 'pWARN_NONE';
2425  }
2426  elsif ($is_special) { # use warnings;
2427    $warn_sv = 'pWARN_STD';
2428  }
2429  else {
2430    # LEXWARN_on: Original $warnings->save from 5.8.9 was wrong,
2431    # DUP_WARNINGS copied length PVX bytes.
2432    my $warn = bless $warnings, "B::LEXWARN";
2433    # TODO: isint here misses already seen lexwarn symbols
2434    ($warn_sv, $isint) = $warn->save;
2435    my $ix = $copsect->index + 1;
2436    # XXX No idea how a &sv_list[] came up here, a re-used object. Anyway.
2437    $warn_sv = substr($warn_sv,1) if substr($warn_sv,0,3) eq '&sv';
2438    $warn_sv = $warnsvcast.'&'.$warn_sv;
2439    $free->add( sprintf( "    cop_list[%d].cop_warnings = NULL;", $ix ) )
2440      if !$B::C::optimize_warn_sv or !$PERL510;
2441    #push @B::C::static_free, sprintf("cop_list[%d]", $ix);
2442  }
2443
2444  my $dynamic_copwarn = ($PERL510 and !$is_special) ? 1 : !$B::C::optimize_warn_sv;
2445  # branch feature/gh70-static-lexwarn with PERL_SUPPORT_STATIC_COP
2446  $dynamic_copwarn = 0 if $Config{usecperl} and $] >= 5.022002;
2447
2448  # Trim the .pl extension, to print the executable name only.
2449  my $file = $op->file;
2450  # $file =~ s/\.pl$/.c/;
2451  my $add_label = 0;
2452  if ($PERL512) {
2453    if ($ITHREADS and $] >= 5.017) {
2454      $copsect->comment(
2455	      "$opsect_common, line, stashoff, file, hints, seq, warnings, hints_hash");
2456      $copsect->add(
2457	sprintf( "%s, %u, " . "%d, %s, %u, " . "%s, %s, NULL",
2458                 $op->_save_common, $op->line,
2459                 $op->stashoff, "NULL", #hints=0
2460                 $op->hints,
2461                 ivx($op->cop_seq), !$dynamic_copwarn ? $warn_sv : 'NULL'
2462	       ));
2463    } elsif ($ITHREADS and $] >= 5.016) {
2464      # [perl #113034] [PATCH] 2d8d7b1 replace B::COP::stashflags by B::COP::stashlen (5.16.0 only)
2465      $copsect->comment(
2466	      "$opsect_common, line, stashpv, file, stashlen, hints, seq, warnings, hints_hash");
2467      $copsect->add(
2468	sprintf( "%s, %u, " . "%s, %s, %d, %u, " . "%s, %s, NULL",
2469                 $op->_save_common, $op->line,
2470                 "NULL", "NULL",
2471                 # XXX at broken 5.16.0 with B-1.34 we do non-utf8, non-null only (=> negative len),
2472                 # 5.16.0 B-1.35 has stashlen, 5.16.1 we will see.
2473                 $op->can('stashlen') ? $op->stashlen : length($op->stashpv),
2474                 $op->hints,
2475                 ivx($op->cop_seq), !$dynamic_copwarn ? $warn_sv : 'NULL'
2476	       ));
2477    } elsif ($ITHREADS and $] >= 5.015004 and $] < 5.016) {
2478      $copsect->comment(
2479	      "$opsect_common, line, stashpv, file, stashflags, hints, seq, warnings, hints_hash");
2480      $copsect->add(
2481        sprintf( "%s, %u, " . "%s, %s, %d, %u, " . "%s, %s, NULL",
2482                 $op->_save_common, $op->line,
2483                 "NULL", "NULL",
2484                 $op->stashflags, $op->hints,
2485                 ivx($op->cop_seq), !$dynamic_copwarn ? $warn_sv : 'NULL'
2486	       ));
2487    } else {
2488      # cop_label now in hints_hash (Change #33656)
2489      $copsect->comment(
2490	      "$opsect_common, line, stash, file, hints, seq, warn_sv, hints_hash");
2491      $copsect->add(
2492	sprintf( "%s, %u, " . "%s, %s, %u, " . "%s, %s, NULL",
2493                 $op->_save_common, $op->line,
2494                 $ITHREADS ? "NULL" : "Nullhv",# we cannot store this static (attribute exit)
2495                 $ITHREADS ? "NULL" : "Nullgv",
2496                 $op->hints, ivx($op->cop_seq), !$dynamic_copwarn ? $warn_sv : 'NULL'
2497	       ));
2498    }
2499    if ( $op->label ) {
2500      $add_label = 1;
2501    }
2502  }
2503  elsif ($PERL510) {
2504    $copsect->comment("$opsect_common, line, label, stash, file, hints, seq, warnings, hints_hash");
2505    $copsect->add(sprintf("%s, %u, %s, " . "%s, %s, %u, " . "%u, %s, NULL",
2506			  $op->_save_common,     $op->line, 'NULL',
2507			  "NULL", "NULL",
2508                          $op->hints, $op->cop_seq, !$dynamic_copwarn ? $warn_sv : 'NULL'
2509                         ));
2510    if ($op->label) {
2511      $init->add(sprintf( "CopLABEL_set(&cop_list[%d], CopLABEL_alloc(%s));",
2512			  $copsect->index, cstring( $op->label ) ));
2513    }
2514  }
2515  else {
2516    # 5.8 misses cop_io
2517    $copsect->comment("$opsect_common, label, stash, file, seq, arybase, line, warn_sv, io");
2518    $copsect->add(
2519      sprintf( "%s, %s, %s, %s, %s, %d, %u, %s %s",
2520               $op->_save_common, cstring( $op->label ),
2521               "NULL", "NULL",
2522               ivx($op->cop_seq), $op->arybase,
2523               $op->line, !$dynamic_copwarn ? $warn_sv : 'NULL',
2524               ( $PERL56 ? "" : ", 0" )
2525	     ));
2526  }
2527  $copsect->debug( $op->name, $op->flagspv ) if $debug{flags};
2528  my $ix = $copsect->index;
2529  $init->add( sprintf( "cop_list[%d].op_ppaddr = %s;", $ix, $op->ppaddr ) )
2530    unless $B::C::optimize_ppaddr;
2531
2532  my $i = 0;
2533  if ($PERL510 and $op->hints_hash) {
2534    my $hints = $op->hints_hash;
2535    if ($$hints) {
2536      if (exists $cophhtable{$$hints}) {
2537        my $cophh = $cophhtable{$$hints};
2538        $init->add(sprintf("CopHINTHASH_set(&cop_list[%d], %s);", $ix, $cophh));
2539      } else {
2540        my $hint_hv = $hints->HASH if ref $hints eq 'B::RHE';
2541        my $cophh = sprintf( "cophh%d", scalar keys %cophhtable );
2542        $cophhtable{$$hints} = $cophh;
2543        $decl->add(sprintf("Static COPHH *%s;", $cophh));
2544        for my $k (keys %$hint_hv) {
2545          my ($ck, $kl, $utf8) = strlen_flags($k);
2546          my $v = $hint_hv->{$k};
2547          next if $k eq ':'; #skip label, see below
2548          my $val = B::svref_2object( \$v )->save("\$^H{$k}");
2549          if ($utf8) {
2550            $init->add(sprintf("%s = cophh_store_pvn(%s, %s, %d, 0, %s, COPHH_KEY_UTF8);",
2551                               $cophh, $i ? $cophh : 'NULL', $ck, $kl, $val));
2552          } else {
2553            $init->add(sprintf("%s = cophh_store_pvs(%s, %s, %s, 0);",
2554                               $cophh, $i ? $cophh : 'NULL', $ck, $val));
2555          }
2556          #$init->add(sprintf("%s->refcounted_he_refcnt--;", $cophh));
2557          #if (!$ITHREADS) {
2558          #  $init->add(sprintf("HEK_FLAGS(%s->refcounted_he_hek) |= HVhek_STATIC;", $cophh));
2559          #}
2560          #if ($PERL522 and !$ITHREADS) { # breaks issue220
2561          #  $init->add(sprintf("unshare_hek_hek(%s->refcounted_he_hek);", $cophh));
2562          #}
2563          $i++;
2564        }
2565        $init->add(sprintf("CopHINTHASH_set(&cop_list[%d], %s);", $ix, $cophh));
2566      }
2567    }
2568  }
2569  if ($add_label) {
2570    # test 29 and 15,16,21. 44,45
2571    my ($cstring, $cur, $utf8) = strlen_flags($op->label);
2572    if ($] >= 5.015001) { # officially added with 5.15.1 aebc0cbee
2573      warn "utf8 label $cstring" if $utf8 and $verbose;
2574      $init->add(sprintf("Perl_cop_store_label(aTHX_ &cop_list[%d], %s, %u, %s);",
2575                         $copsect->index, $cstring, $cur, $utf8));
2576    } elsif ($] > 5.013004) {
2577      $init->add(sprintf("Perl_store_cop_label(aTHX_ &cop_list[%d], %s, %u, %s);",
2578                         $copsect->index, $cstring, $cur, $utf8));
2579    } elsif (!($^O =~ /^(MSWin32|AIX)$/ or $ENV{PERL_DL_NONLAZY})) {
2580      warn "Warning: Overwrote hints_hash with label\n" if $i;
2581      my $ix = $copsect->index;
2582      $init->add(
2583        sprintf("cop_list[%d].cop_hints_hash = Perl_store_cop_label(aTHX_ cop_list[%d].cop_hints_hash, %s);",
2584                $ix, $ix, $cstring));
2585    }
2586  }
2587
2588  if ($PERL510 and !$is_special and !$isint) {
2589    my $copw = $warn_sv;
2590    $copw =~ s/^\(STRLEN\*\)&//;
2591    # on cv_undef (scope exit, die, Attribute::Handlers, ...) CvROOT and kids are freed.
2592    # so lexical cop_warnings need to be dynamic.
2593    if ($copw) {
2594      my $dest = "cop_list[$ix].cop_warnings";
2595      # with DEBUGGING savepvn returns ptr + PERL_MEMORY_DEBUG_HEADER_SIZE
2596      # which is not the address which will be freed in S_cop_free.
2597      # Need to use old-style PerlMemShared_, see S_cop_free in op.c (#362)
2598      # lexwarn<n> might be also be STRLEN* 0
2599      $init->no_split;
2600      $init->add("#ifdef PERL_SUPPORT_STATIC_COP  /* so far cperl only */",
2601                 "$dest = $warn_sv;",
2602                 "#else",
2603                 sprintf("%s = (STRLEN*)savesharedpvn((const char*)%s, sizeof(%s));",
2604                         $dest, $copw, $copw),
2605                 "#endif");
2606      $init->split;
2607    }
2608  } else {
2609    $init->add( sprintf( "cop_list[%d].cop_warnings = %s;", $ix, $warn_sv ) )
2610      unless $B::C::optimize_warn_sv;
2611  }
2612  #push @B::C::static_free, "cop_list[$ix]" if $ITHREADS;
2613  if (!$B::C::optimize_cop) {
2614    my $stash = savestashpv($op->stashpv);
2615    $init->add(sprintf( "CopSTASH_set(&cop_list[%d], %s);", $ix, $stash ));
2616    if (!$ITHREADS) {
2617      if ($B::C::const_strings) {
2618        my $constpv = constpv($file);
2619        # define CopFILE_set(c,pv)	CopFILEGV_set((c), gv_fetchfile(pv))
2620        # cache gv_fetchfile
2621        if ( !$copgvtable{$constpv} ) {
2622          $copgvtable{$constpv} = $gv_index++;
2623          $init->add( sprintf( "gv_list[%d] = gv_fetchfile(%s);", $copgvtable{$constpv}, $constpv ) );
2624        }
2625        $init->add( sprintf( "CopFILEGV_set(&cop_list[%d], gv_list[%d]); /* %s */",
2626                            $ix, $copgvtable{$constpv}, cstring($file) ) );
2627        #$init->add(sprintf( "CopFILE_set(&cop_list[%d], %s);", $ix, constpv($file) ));
2628      } else {
2629        $init->add(sprintf( "CopFILE_set(&cop_list[%d], %s);", $ix, cstring($file) ));
2630      }
2631    } else { # cv_undef e.g. in bproto.t and many more core tests with threads
2632      $init->add(sprintf( "CopFILE_set(&cop_list[%d], %s);", $ix, cstring($file) ));
2633    }
2634  }
2635
2636  # our root: store all packages from this file
2637  if (!$mainfile) {
2638    $mainfile = $op->file
2639      if $op->stashpv eq ($module ? $module : 'main');
2640  } else {
2641    mark_package($op->stashpv)
2642      if $mainfile eq $op->file and $op->stashpv ne ($module ? $module : 'main');
2643  }
2644  savesym( $op, "(OP*)&cop_list[$ix]" );
2645}
2646
2647# if REGCOMP can be called in init or deferred in init1
2648sub re_does_swash {
2649  my ($qstr, $pmflags) = @_;
2650  # SWASHNEW, now needing a multideref GV. 0x5000000 is just a hack. can be more
2651  if (($] >= 5.021006 and ($pmflags & 0x5000000 == 0x5000000))
2652      # or any unicode property (#253). Note: \p{} breaks #242
2653      or ($qstr =~ /\\P\{/)
2654     )
2655  {
2656    return 1;
2657  } else {
2658    return 0;
2659  }
2660}
2661
2662sub B::PMOP::save {
2663  my ( $op, $level, $fullname ) = @_;
2664  my ($replrootfield, $replstartfield, $gvsym) = ('NULL', 'NULL');
2665  my $sym = objsym($op);
2666  return $sym if defined $sym;
2667  # 5.8.5-thr crashes here (7) at pushre
2668  my $pushre = $PERL5257 ? "split" : "pushre";
2669  if ($] < 5.008008 and $ITHREADS and $$op < 256) { # B bug. split->first->pmreplroot = 0x1
2670    die "Internal B::walkoptree error: invalid PMOP for pushre\n";
2671    return;
2672  }
2673  $level = 0 unless $level;
2674  my $replroot  = $op->pmreplroot;
2675  my $replstart = $op->pmreplstart;
2676  my $ppaddr = $op->ppaddr;
2677
2678  # under ithreads, OP_PUSHRE.op_replroot is an integer. multi not.
2679  $replrootfield = sprintf( "s\\_%x", $$replroot ) if ref $replroot;
2680  if ( $ITHREADS && $op->name eq $pushre ) {
2681    warn "PMOP::save saving a pp_$pushre as int ${replroot}\n" if $debug{gv};
2682    $replrootfield = "INT2PTR(OP*,${replroot})";
2683  }
2684  elsif (ref $replroot && $$replroot) {
2685    # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
2686    # argument to a split) stores a GV in op_pmreplroot instead
2687    # of a substitution syntax tree. We don't want to walk that...
2688    if ( $op->name eq $pushre ) {
2689      warn "PMOP::save saving a pp_$pushre with GV $gvsym\n" if $debug{gv};
2690      $gvsym = $replroot->save;
2691      $replrootfield = "NULL";
2692      $replstartfield = $replstart->save if $replstart;
2693    }
2694    else {
2695      $replstart->save if $replstart;
2696      $replstartfield = saveoptree( "*ignore*", $replroot, $replstart );
2697      $replstartfield =~ s/^hv/(OP*)hv/;
2698    }
2699  }
2700
2701  # pmnext handling is broken in perl itself, we think. Bad op_pmnext
2702  # fields aren't noticed in perl's runtime (unless you try reset) but we
2703  # segfault when trying to dereference it to find op->op_pmnext->op_type
2704  if ($PERL510) {
2705    $pmopsect->comment(
2706      "$opsect_common, first, last, pmoffset, pmflags, pmreplroot, pmreplstart"
2707    );
2708    $pmopsect->add(
2709      sprintf( "%s, s\\_%x, s\\_%x, %u, 0x%x, {%s}, {%s}",
2710               $op->_save_common, ${ $op->first },
2711               ${ $op->last }, ( $ITHREADS ? $op->pmoffset : 0 ),
2712               $op->pmflags, $replrootfield, $replstartfield
2713             ));
2714    if ($] >= 5.017) {
2715      my $code_list = $op->code_list;
2716      if ($code_list and $$code_list) {
2717        warn sprintf("saving pmop_list[%d] code_list $code_list (?{})\n", $pmopsect->index)
2718          if $debug{gv};
2719        my $code_op = $code_list->save;
2720        $init->add(sprintf("pmop_list[%d].op_code_list = %s;", # (?{}) code blocks
2721                           $pmopsect->index, $code_op)) if $code_op;
2722        warn sprintf("done saving pmop_list[%d] code_list $code_list (?{})\n", $pmopsect->index)
2723          if $debug{gv};
2724      }
2725    }
2726  }
2727  elsif ($PERL56) {
2728    # pmdynflags does not exist as B method. It is only used for PMdf_UTF8 dynamically,
2729    # if static we set this already in pmflags.
2730    $pmopsect->comment(
2731"$opsect_common, first, last, pmreplroot, pmreplstart, pmnext, pmregexp, pmflags, pmpermflags, pmdynflags"
2732    );
2733    $pmopsect->add(
2734      sprintf( "%s, s\\_%x, s\\_%x, %s, %s, 0, 0, 0x%x, 0x%x",
2735               $op->_save_common,
2736               ${ $op->first }, ${ $op->last },
2737               $replrootfield,  $replstartfield,
2738               $op->pmflags, $op->pmpermflags, 0 # XXX original 5.6 B::C misses pmdynflags
2739             ));
2740  } else { # perl5.8.x
2741    $pmopsect->comment(
2742"$opsect_common, first, last, pmreplroot, pmreplstart, pmoffset, pmflags, pmpermflags, pmdynflags, pmstash"
2743    );
2744    $pmopsect->add(
2745      sprintf( "%s, s\\_%x, s\\_%x, %s, %s, 0, %u, 0x%x, 0x%x, 0x%x, %s",
2746               $op->_save_common, ${ $op->first },
2747               ${ $op->last },    $replrootfield,
2748               $replstartfield,   $ITHREADS ? $op->pmoffset : 0,
2749               $op->pmflags,      $op->pmpermflags,
2750               $op->pmdynflags,   $MULTI ? cstring($op->pmstashpv) : "0"
2751             ));
2752    if (!$MULTI and $op->pmstash) {
2753      my $stash = $op->pmstash->save;
2754      $init->add( sprintf( "pmop_list[%d].op_pmstash = %s;", $pmopsect->index, $stash ) );
2755    }
2756  }
2757  $pmopsect->debug( $op->name, $op->flagspv ) if $debug{flags};
2758  my $pm = sprintf( "pmop_list[%d]", $pmopsect->index );
2759  $init->add( sprintf( "%s.op_ppaddr = %s;", $pm, $ppaddr ) )
2760    unless $B::C::optimize_ppaddr;
2761  my $re = $op->precomp;
2762  if ( defined($re) ) {
2763    my $initpm = $init;
2764    $Regexp{$$op} = $op;
2765    if ($PERL510) {
2766      # TODO minor optim: fix savere( $re ) to avoid newSVpvn;
2767      # precomp did not set the utf8 flag (#333, #338), fixed with 1.52_01
2768      my ($qre, $relen, $utf8) = strlen_flags($re);
2769      my $pmflags = $op->pmflags;
2770      warn "pregcomp $pm $qre:$relen:$utf8".sprintf(" 0x%x\n",$pmflags)
2771        if $debug{pv} or $debug{gv};
2772      # Since 5.13.10 with PMf_FOLD (i) we need to swash_init("utf8::Cased").
2773      if ($] >= 5.013009 and $pmflags & 4) {
2774        # Note: in CORE utf8::SWASHNEW is demand-loaded from utf8 with Perl_load_module()
2775        load_utf8_heavy();
2776        if ($PERL518 and !$swash_init and $swash_ToCf) {
2777          $init->add("PL_utf8_tofold = $swash_ToCf;");
2778          $swash_init++;
2779        }
2780      }
2781      # some pm need early init (242), SWASHNEW needs some late GVs (GH#273)
2782      # esp with 5.22 multideref init. i.e. all \p{} \N{}, \U, /i, ...
2783      # But XSLoader and utf8::SWASHNEW itself needs to be early.
2784      if (($utf8 and $] >= 5.013009 and ($pmflags & 4 == 4)) # needs SWASHNEW (case fold)
2785          or re_does_swash($qre, $pmflags))
2786      {
2787        $initpm = $init1;
2788        warn sprintf("deferred PMOP %s %s 0x%x\n", $qre, $fullname, $pmflags) if $debug{sv};
2789      } else {
2790        warn sprintf("normal PMOP %s %s 0x%x\n", $qre, $fullname, $pmflags) if $debug{sv};
2791      }
2792      if ($PERL518 and $op->reflags & RXf_EVAL_SEEN) { # set HINT_RE_EVAL on
2793        $pmflags |= PMf_EVAL;
2794        $initpm->no_split;
2795        $initpm->add("{",
2796                   "  U32 hints_sav = PL_hints;",
2797                   "  PL_hints |= HINT_RE_EVAL;");
2798      }
2799      if ($] > 5.008008) { # can do utf8 qr
2800        $initpm->add( # XXX Modification of a read-only value attempted. use DateTime - threaded
2801          sprintf("PM_SETRE(&%s, CALLREGCOMP(newSVpvn_flags(%s, %s, SVs_TEMP|$utf8), 0x%x));",
2802                  $pm, $qre, $relen, $pmflags),
2803          sprintf("RX_EXTFLAGS(PM_GETRE(&%s)) = 0x%x;", $pm, $op->reflags ));
2804      } else {
2805        $initpm->add
2806          ("PM_SETRE(&$pm,",
2807           "  CALLREGCOMP(newSVpvn($qre, $relen), ".sprintf("0x%x));", $pmflags),
2808           sprintf("RX_EXTFLAGS(PM_GETRE(&%s)) = 0x%x;", $pm, $op->reflags ));
2809        $initpm->add("SvUTF8_on(PM_GETRE(&$pm));") if $utf8;
2810      }
2811      if ($] >= 5.018 and $op->reflags & RXf_EVAL_SEEN) { # set HINT_RE_EVAL off
2812        $initpm->add("  PL_hints = hints_sav;",
2813                   "}");
2814        $initpm->split();
2815      }
2816      # See toke.c:8964
2817      # set in the stash the PERL_MAGIC_symtab PTR to the PMOP: ((PMOP**)mg->mg_ptr) [elements++] = pm;
2818      if ($PERL510 and $op->pmflags & PMf_ONCE()) {
2819        my $stash = $MULTI ? $op->pmstashpv
2820          : ref $op->pmstash eq 'B::HV' ? $op->pmstash->NAME : '__ANON__';
2821        $Regexp{$$op} = $op; #188: restore PMf_ONCE, set PERL_MAGIC_symtab in $stash
2822      }
2823    }
2824    elsif ($PERL56) {
2825      my ( $resym, $relen ) = savere( $re, 0 );
2826      $init->add(
2827        "$pm.op_pmregexp = pregcomp((char*)$resym, (char*)$resym + $relen, &$pm);"
2828      );
2829    }
2830    else { # 5.8
2831      my ( $resym, $relen ) = savere( $re, 0 );
2832      $init->add(
2833          "PM_SETRE(&$pm, CALLREGCOMP(aTHX_ (char*)$resym, (char*)$resym + $relen, &$pm));"
2834      );
2835    }
2836  }
2837  if ( $gvsym ) {
2838    if ($PERL510) {
2839      # XXX need that for subst
2840      $init->add("$pm.op_pmreplrootu.op_pmreplroot = (OP*)$gvsym;");
2841    } else {
2842      $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
2843    }
2844  }
2845  savesym( $op, "(OP*)&$pm" );
2846}
2847
2848sub B::SPECIAL::save {
2849  my ($sv, $fullname) = @_;
2850  # special case: $$sv is not the address but an index into specialsv_list
2851  #   warn "SPECIAL::save specialsv $$sv\n"; # debug
2852  @specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no pWARN_ALL pWARN_NONE)
2853    unless @specialsv_name; # 5.6.2 Exporter quirks. pWARN_STD was added to B with 5.8.9
2854  # &PL_sv_zero was added with 5.27.2 and was imported
2855  my $sym = $specialsv_name[$$sv];
2856  if ( !defined($sym) ) {
2857    warn "unknown specialsv index $$sv passed to B::SPECIAL::save";
2858  }
2859  return $sym;
2860}
2861
2862sub B::OBJECT::save { }
2863
2864sub B::NULL::save {
2865  my ($sv, $fullname) = @_;
2866  my $sym = objsym($sv);
2867  return $sym if defined $sym;
2868
2869  # debug
2870  if ( $$sv == 0 ) {
2871    warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n" if $verbose;
2872    return savesym( $sv, "(void*)Nullsv" );
2873  }
2874
2875  my $i = $svsect->index + 1;
2876  warn "Saving SVt_NULL sv_list[$i]\n" if $debug{sv};
2877  $svsect->add( sprintf( "NULL, $u32fmt, 0x%x".($PERL510?", {0}":''),
2878                         $sv->REFCNT, $sv->FLAGS ) );
2879  #$svsect->debug( $fullname, $sv->flagspv ) if $debug{flags}; # XXX where is this possible?
2880  if ($debug{flags} and (!$ITHREADS or $PERL514) and $DEBUG_LEAKING_SCALARS) { # add index to sv_debug_file to easily find the Nullsv
2881    # $svsect->debug( "ix added to sv_debug_file" );
2882    $init->add(sprintf(qq(sv_list[%d].sv_debug_file = savesharedpv("NULL sv_list[%d] 0x%x");),
2883		       $svsect->index, $svsect->index, $sv->FLAGS));
2884  }
2885  savesym( $sv, sprintf( "&sv_list[%d]", $svsect->index ) );
2886}
2887
2888sub B::UV::save {
2889  my ($sv, $fullname) = @_;
2890  my $sym = objsym($sv);
2891  return $sym if defined $sym;
2892  my $uvuformat = $Config{uvuformat};
2893  $uvuformat =~ s/["\0]//g; #" poor editor
2894  $uvuformat =~ s/".$/"/;  # cperl bug 5.22.2 #61
2895  my $uvx = $sv->UVX;
2896  my $suff = 'U';
2897  $suff .= 'L' if $uvx > 2147483647;
2898  my $i = $svsect->index + 1;
2899  if ($PERL524) {
2900    # since 5.24 we need to point the xpvuv to the head
2901  } elsif ($PERL514) {
2902    # issue 145 warn $sv->UVX, " ", sprintf($u32fmt, $sv->UVX);
2903    $xpvuvsect->comment( "stash, magic, cur, len, xuv_u" );
2904    $xpvuvsect->add( sprintf( "Nullhv, {0}, 0, 0, {%".$uvuformat."$suff}", $uvx ) );
2905  } elsif ($PERL510) {
2906    $xpvuvsect->comment( "stash, magic, cur, len, xuv_u" );
2907    $xpvuvsect->add( sprintf( "{0}, 0, 0, {%".$uvuformat."$suff}", $uvx ) );
2908  } else {
2909    $xpvuvsect->comment( "pv, cur, len, uv" );
2910    $xpvuvsect->add( sprintf( "0, 0, 0, %".$uvuformat.$suff, $uvx ) );
2911  }
2912  if ($PERL524) {
2913    $svsect->add(sprintf( "NULL, $u32fmt, 0x%x".
2914                          ($PERL510?', {'.($C99?".svu_uv=":"").$uvx."$suff}":''),
2915                          $sv->REFCNT, $sv->FLAGS));
2916    #32bit  - sizeof(void*), 64bit: - 2*ptrsize
2917    if ($Config{ptrsize} == 4 and !IS_MSVC) {
2918      $init->add(sprintf( "sv_list[%d].sv_any = (void*)&sv_list[%d] - sizeof(void*);", $i, $i));
2919    } else {
2920      $init->add(sprintf( "sv_list[%d].sv_any = (char*)&sv_list[%d] - %d;", $i, $i,
2921                          2*$Config{ptrsize}));
2922    }
2923  } else {
2924    $svsect->add(sprintf( "&xpvuv_list[%d], $u32fmt, 0x%x".
2925                          ($PERL510?', {'.($C99?".svu_uv=":"").$uvx."$suff}":''),
2926             $xpvuvsect->index, $sv->REFCNT, $sv->FLAGS));
2927  }
2928  $svsect->debug( $fullname, $sv->flagspv ) if $debug{flags};
2929  warn sprintf( "Saving IV(UV) 0x%x to xpvuv_list[%d], sv_list[%d], called from %s:%s\n",
2930    $sv->UVX, $xpvuvsect->index, $i, @{[(caller(1))[3]]}, @{[(caller(0))[2]]} )
2931    if $debug{sv};
2932  savesym( $sv, sprintf( "&sv_list[%d]", $i ) );
2933}
2934
2935sub B::IV::save {
2936  my ($sv, $fullname) = @_;
2937  my $sym = objsym($sv);
2938  return $sym if defined $sym;
2939  # Since 5.11 the RV is no special SV object anymore, just a IV (test 16)
2940  my $svflags = $sv->FLAGS;
2941  if ($PERL512 and $svflags & SVf_ROK) {
2942    return $sv->B::RV::save($fullname);
2943  }
2944  if ($svflags & SVf_IVisUV) {
2945    return $sv->B::UV::save;
2946  }
2947  my $ivx = ivx($sv->IVX);
2948  my $i = $svsect->index + 1;
2949  if ($svflags & 0xff and !($svflags & (SVf_IOK|SVp_IOK))) { # Not nullified
2950    unless (($PERL510 and $svflags & 0x00010000) # PADSTALE - out of scope lexical is !IOK
2951	    or (!$PERL510 and $svflags & 0x00000100) # PADBUSY
2952	    or ($] > 5.015002 and $svflags & 0x60002)) { # 5.15.3 changed PAD bits
2953      warn sprintf("Internal warning: IV !IOK $fullname sv_list[$i] 0x%x\n",$svflags);
2954    }
2955  }
2956  if ($PERL524) {
2957    # since 5.24 we need to point the xpviv to the head
2958  } elsif ($PERL514) {
2959    $xpvivsect->comment( "stash, magic, cur, len, xiv_u" );
2960    $xpvivsect->add( sprintf( "Nullhv, {0}, 0, 0, {%s}", $ivx ) );
2961  } elsif ($PERL510) {
2962    $xpvivsect->comment( "stash, magic, cur, len, xiv_u" );
2963    $xpvivsect->add( sprintf( "{0}, 0, 0, {%s}", $ivx ) );
2964  } else {
2965    $xpvivsect->comment( "pv, cur, len, iv" );
2966    $xpvivsect->add( sprintf( "0, 0, 0, %s", $ivx ) );
2967  }
2968  if ($PERL524) {
2969    $svsect->add(sprintf( "NULL, $u32fmt, 0x%x, {".($C99?".svu_iv=":"").$ivx.'}',
2970                          $sv->REFCNT, $svflags ));
2971    #32bit  - sizeof(void*), 64bit: - 2*ptrsize
2972    if ($Config{ptrsize} == 4 and !IS_MSVC) {
2973      $init->add(sprintf( "sv_list[%d].sv_any = (void*)&sv_list[%d] - sizeof(void*);", $i, $i));
2974    } else {
2975      $init->add(sprintf( "sv_list[%d].sv_any = (char*)&sv_list[%d] - %d;", $i, $i,
2976                          2*$Config{ptrsize}));
2977    }
2978  } else {
2979    $svsect->add(sprintf( "&xpviv_list[%d], $u32fmt, 0x%x".($PERL510?', {'.($C99?".svu_iv=":"").$ivx.'}':''),
2980                          $xpvivsect->index, $sv->REFCNT, $svflags ));
2981  }
2982  $svsect->debug( $fullname, $sv->flagspv ) if $debug{flags};
2983  warn sprintf( "Saving IV 0x%x to xpviv_list[%d], sv_list[%d], called from %s:%s\n",
2984    $sv->IVX, $xpvivsect->index, $i, @{[(caller(1))[3]]}, @{[(caller(0))[2]]} )
2985    if $debug{sv};
2986  savesym( $sv, sprintf( "&sv_list[%d]", $i ) );
2987}
2988
2989sub B::NV::save {
2990  my ($sv, $fullname) = @_;
2991  my $sym = objsym($sv);
2992  return $sym if defined $sym;
2993  my $nv = nvx($sv->NV);
2994  $nv .= '.00' if $nv =~ /^-?\d+$/;
2995  # IVX is invalid in B.xs and unused
2996  my $iv = $sv->FLAGS & SVf_IOK ? $sv->IVX : 0;
2997  $nv = '0.00' if IS_MSVC and !$nv;
2998  if ($PERL514) {
2999    $xpvnvsect->comment('STASH, MAGIC, cur, len, IVX, NVX');
3000    $xpvnvsect->add( sprintf( "Nullhv, {0}, 0, 0, {%ld}, {%s}", $iv, $nv ) );
3001  } elsif ($PERL510) { # not fixed by NV isa IV >= 5.8
3002    $xpvnvsect->comment('NVX, cur, len, IVX');
3003    $xpvnvsect->add( sprintf( "{%s}, 0, 0, {%ld}", $nv, $iv ) );
3004  }
3005  else {
3006    $xpvnvsect->comment('PVX, cur, len, IVX, NVX');
3007    $xpvnvsect->add( sprintf( "0, 0, 0, %ld, %s", $iv, $nv ) );
3008  }
3009  $svsect->add(
3010    sprintf( "&xpvnv_list[%d], $u32fmt, 0x%x %s",
3011             $xpvnvsect->index, $sv->REFCNT, $sv->FLAGS, $PERL510 ? ', {0}' : '' ));
3012  $svsect->debug( $fullname, $sv->flagspv ) if $debug{flags};
3013  warn sprintf( "Saving NV %s to xpvnv_list[%d], sv_list[%d]\n",
3014    $nv, $xpvnvsect->index, $svsect->index )
3015    if $debug{sv};
3016  savesym( $sv, sprintf( "&sv_list[%d]", $svsect->index ) );
3017}
3018
3019sub savepvn {
3020  my ( $dest, $pv, $sv, $cur ) = @_;
3021  my @init;
3022
3023  # work with byte offsets/lengths
3024  $pv = pack "a*", $pv if defined $pv;
3025  if ( defined $max_string_len && length($pv) > $max_string_len ) {
3026    push @init, sprintf( "Newx(%s, %u, char);", $dest, length($pv) + 2 );
3027    my $offset = 0;
3028    while ( length $pv ) {
3029      my $str = substr $pv, 0, $max_string_len, '';
3030      push @init,
3031        sprintf( "Copy(%s, %s+%d, %u, char);",
3032                 cstring($str), $dest, $offset, length($str) );
3033      $offset += length $str;
3034    }
3035    push @init, sprintf( "%s[%u] = '\\0';", $dest, $offset );
3036    warn sprintf( "Copying overlong PV %s to %s\n", cstring($pv), $dest )
3037      if $debug{sv} or $debug{pv};
3038  }
3039  else {
3040    # If READONLY and FAKE use newSVpvn_share instead. (test 75)
3041    # XXX IsCOW forgotten here. rather use a helper is_shared_hek()
3042    if ($PERL510 and $sv and (($sv->FLAGS & 0x09000000) == 0x09000000)) {
3043      warn sprintf( "Saving shared HEK %s to %s\n", cstring($pv), $dest ) if $debug{sv};
3044      my $hek = save_hek($pv,'',1);
3045      push @init, sprintf( "%s = HEK_KEY(%s);", $dest, $hek ) unless $hek eq 'NULL';
3046      if ($DEBUGGING) { # we have to bypass a wrong HE->HEK assert in hv.c
3047	push @B::C::static_free, $dest;
3048      }
3049    } else {
3050      my $cstr = cstring($pv);
3051      if (!$cstr and $cstr == 0) {
3052        $cstr = '""';
3053      }
3054      if ($sv and IsCOW($sv)) { # and ($B::C::cow or IsCOW_hek($sv)))
3055        # This cannot be savepvn allocated. TODO: READONLY COW => static hek?
3056        if ($cstr !~ /\\000\\00\d"$/) {
3057          $cstr = substr($cstr,0,-1) . '\0\001"';
3058          $cur += 2;
3059        }
3060        warn sprintf( "Saving COW PV %s to %s\n", $cstr, $dest ) if $debug{sv};
3061        return (sprintf( "Newx(%s, sizeof(%s)-1, char);", $dest, $cstr ),
3062                sprintf( "Copy(%s, %s, sizeof(%s)-1, char);", $cstr, $dest, $cstr ));
3063      }
3064      warn sprintf( "Saving PV %s to %s\n", $cstr, $dest ) if $debug{sv};
3065      push @init, sprintf( "%s = Perl_savepvn(aTHX_ STR_WITH_LEN(%s));", $dest, $cstr );
3066    }
3067  }
3068  return @init;
3069}
3070
3071sub B::PVLV::save {
3072  my ($sv, $fullname) = @_;
3073  my $sym = objsym($sv);
3074  if (defined $sym) {
3075    if ($in_endav) {
3076      warn "in_endav: static_free without $sym\n" if $debug{av};
3077      @B::C::static_free = grep {$_ ne $sym} @B::C::static_free;
3078    }
3079    return $sym;
3080  }
3081  my ($pvsym, $cur, $len, $pv, $static, $flags) = save_pv_or_rv ($sv, $fullname);
3082  my ( $lvtarg, $lvtarg_sym ); # XXX missing
3083  my $tmp_pvsym = $pvsym;
3084  if ($PERL514) {
3085    $xpvlvsect->comment('STASH, MAGIC, CUR, LEN, GvNAME, xnv_u, TARGOFF, TARGLEN, TARG, TYPE');
3086    $xpvlvsect->add(
3087       sprintf("Nullhv, {0}, %u, %d, 0/*GvNAME later*/, %s, %u, %u, Nullsv, %s",
3088	       $cur, $len, nvx($sv->NVX),
3089	       $sv->TARGOFF, $sv->TARGLEN, cchar( $sv->TYPE ) ));
3090    $tmp_pvsym = 'NULL' if $tmp_pvsym =~ /^hek/ and $static; # cannot init static
3091    $svsect->add(sprintf("&xpvlv_list[%d], $u32fmt, 0x%x, {(char*)%s}",
3092                         $xpvlvsect->index, $sv->REFCNT, $sv->FLAGS, $tmp_pvsym));
3093  } elsif ($PERL510) {
3094    $xpvlvsect->comment('xnv_u, CUR, LEN, GvNAME, MAGIC, STASH, TARGOFF, TARGLEN, TARG, TYPE');
3095    $xpvlvsect->add(
3096       sprintf("%s, %u, %d, 0/*GvNAME later*/, 0, Nullhv, %u, %u, Nullsv, %s",
3097	       nvx($sv->NVX), $cur, $len,
3098	       $sv->TARGOFF, $sv->TARGLEN, cchar( $sv->TYPE ) ));
3099    $svsect->add(sprintf("&xpvlv_list[%d], $u32fmt, 0x%x, {%s}",
3100                         $xpvlvsect->index, $sv->REFCNT, $flags,
3101                         ($C99?".svu_pv = (char*)":"(char*)").$tmp_pvsym));
3102  } else {
3103    $xpvlvsect->comment('PVX, CUR, LEN, IVX, NVX, TARGOFF, TARGLEN, TARG, TYPE');
3104    $xpvlvsect->add(
3105       sprintf("(char*)%s, %u, %u, %s, %s, 0, 0, %u, %u, Nullsv, %s",
3106	       $pvsym, $cur, $len, ivx($sv->IVX), nvx($sv->NVX),
3107	       $sv->TARGOFF, $sv->TARGLEN, cchar( $sv->TYPE ) ));
3108    $svsect->add(sprintf("&xpvlv_list[%d], $u32fmt, 0x%x",
3109                         $xpvlvsect->index, $sv->REFCNT, $flags));
3110  }
3111  $svsect->debug( $fullname, $sv->flagspv ) if $debug{flags};
3112  my $s = "sv_list[".$svsect->index."]";
3113  if ( !$static ) {
3114    if ($PERL510) {
3115      $init->add( savepvn( "$s.sv_u.svu_pv", $pv, $sv, $cur ) );
3116    }
3117    else {
3118      $init->add( savepvn( sprintf( "xpvlv_list[%d].xpv_pv", $xpvlvsect->index ), $pv, $cur ) );
3119    }
3120  } elsif ($tmp_pvsym eq 'NULL' and $pvsym =~ /^hek/) {
3121    $init->add( sprintf("%s.sv_u.svu_pv = %s.hek_key;", $s, $pvsym ));
3122  }
3123  $sv->save_magic($fullname);
3124  savesym( $sv, "&".$s );
3125}
3126
3127sub B::PVIV::save {
3128  my ($sv, $fullname) = @_;
3129  my $sym = objsym($sv);
3130  if (defined $sym) {
3131    if ($in_endav) {
3132      warn "in_endav: static_free without $sym\n" if $debug{av};
3133      @B::C::static_free = grep {$_ ne $sym} @B::C::static_free;
3134    }
3135    return $sym;
3136  }
3137  my ( $pvsym, $cur, $len, $pv, $static, $flags ) = save_pv_or_rv($sv, $fullname);
3138  my $tmp_pvsym = $pvsym;
3139  if ($PERL514) {
3140    $xpvivsect->comment('STASH, MAGIC, cur, len, IVX');
3141    $xpvivsect->add( sprintf( "Nullhv, {0}, %u, %u, {%s}", $cur, $len, ivx($sv->IVX) ) ); # IVTYPE long
3142    $tmp_pvsym = 'NULL' if $tmp_pvsym =~ /^hek/ and $static; # cannot init static
3143  } elsif ($PERL510) {
3144    $xpvivsect->comment('xnv_u, cur, len, IVX');
3145    $xpvivsect->add( sprintf( "{0}, %u, %u, {%s}", $cur, $len, ivx($sv->IVX) ) ); # IVTYPE long
3146  } else {
3147    #$iv = 0 if $sv->FLAGS & (SVf_IOK|SVp_IOK);
3148    $xpvivsect->comment('PVX, cur, len, IVX');
3149    $xpvivsect->add( sprintf( "(char*)%s, %u, %u, %s",
3150			      $pvsym, $cur, $len, ivx($sv->IVX) ) ); # IVTYPE long
3151  }
3152  $svsect->add(
3153    sprintf("&xpviv_list[%d], $u32fmt, 0x%x %s",
3154            $xpvivsect->index, $sv->REFCNT, $flags,
3155	    $PERL510 ? ", {".($C99?".svu_pv=":"")."(char*)$tmp_pvsym}" : '' ) );
3156  $svsect->debug( $fullname, $sv->flagspv ) if $debug{flags};
3157  my $s = "sv_list[".$svsect->index."]";
3158  if ( defined($pv) ) {
3159    if ( !$static ) {
3160      if ($PERL510) {
3161	$init->add( savepvn( "$s.sv_u.svu_pv", $pv, $sv, $cur ) );
3162      } else {
3163	$init->add( savepvn( sprintf( "xpviv_list[%d].xpv_pv", $xpvivsect->index ), $pv, $cur ) );
3164      }
3165    } elsif ($tmp_pvsym eq 'NULL' and $pvsym =~ /^hek/) {
3166      $init->add( sprintf("%s.sv_u.svu_pv = %s.hek_key;", $s, $pvsym ));
3167    }
3168  }
3169  savesym( $sv, "&".$s );
3170}
3171
3172sub B::PVNV::save {
3173  my ($sv, $fullname) = @_;
3174  my $sym = objsym($sv);
3175  if (defined $sym) {
3176    if ($in_endav) {
3177      warn "in_endav: static_free without $sym\n" if $debug{av};
3178     @B::C::static_free = grep {$_ ne $sym} @B::C::static_free;
3179    }
3180    return $sym;
3181  }
3182  my ( $pvsym, $cur, $len, $pv, $static, $flags ) = save_pv_or_rv($sv, $fullname);
3183  my $tmp_pvsym = $pvsym;
3184  my $nvx = '0.0';
3185  my $ivx = ivx($sv->IVX); # here must be IVX!
3186  if ($flags & (SVf_NOK|SVp_NOK)) {
3187    # it could be a double, or it could be 2 ints - union xpad_cop_seq
3188    $nvx = nvx($sv->NV);
3189  } else {
3190    if ($PERL510 and $C99 and !$PERL522) {
3191      $nvx = sprintf(".xpad_cop_seq.xlow = %s, .xpad_cop_seq.xhigh = %s",
3192                     ivx($sv->COP_SEQ_RANGE_LOW), ivx($sv->COP_SEQ_RANGE_HIGH),
3193		    );
3194    } elsif (!$PERL522) {
3195      $nvx = nvx($sv->NVX);
3196    }
3197  }
3198  if ($PERL510) {
3199    # For some time the stringification works of NVX double to two ints worked ok.
3200    if ($PERL514) {
3201      $tmp_pvsym = 'NULL' if $tmp_pvsym =~ /^hek/ and $static; # cannot init static
3202      $xpvnvsect->comment('STASH, MAGIC, cur, len, IVX, NVX');
3203      $xpvnvsect->add(sprintf( "Nullhv, {0}, %u, %u, {%s}, {%s}", $cur, $len, $ivx, $nvx) );
3204    } else {
3205      $xpvnvsect->comment('NVX, cur, len, IVX');
3206      $xpvnvsect->add(sprintf( "{%s}, %u, %u, {%s}", $nvx, $cur, $len, $ivx ) );
3207    }
3208    if (!($sv->FLAGS & (SVf_NOK|SVp_NOK)) and !$PERL522) {
3209      warn "NV => run-time union xpad_cop_seq init\n" if $debug{sv};
3210      $init->add(sprintf("xpvnv_list[%d].xnv_u.xpad_cop_seq.xlow = %s;",
3211                         $xpvnvsect->index, ivx($sv->COP_SEQ_RANGE_LOW)),
3212                 # pad.c: PAD_MAX = I32_MAX (4294967295)
3213                 # U suffix <= "warning: this decimal constant is unsigned only in ISO C90"
3214                 sprintf("xpvnv_list[%d].xnv_u.xpad_cop_seq.xhigh = %s;",
3215                         $xpvnvsect->index, ivx($sv->COP_SEQ_RANGE_HIGH)));
3216    }
3217  }
3218  else {
3219    $xpvnvsect->comment('PVX, cur, len, IVX, NVX');
3220    $xpvnvsect->add(sprintf( "(char*)%s, %u, %u, %s, %s", $pvsym, $cur, $len, $ivx, $nvx ) );
3221  }
3222  $svsect->add(
3223    sprintf("&xpvnv_list[%d], $u32fmt, 0x%x %s",
3224            $xpvnvsect->index, $sv->REFCNT, $flags,
3225            $PERL510 ? ", {".($C99?".svu_pv=":"")."(char*)$tmp_pvsym}" : '' ) );
3226  $svsect->debug( $fullname, $sv->flagspv ) if $debug{flags};
3227  my $s = "sv_list[".$svsect->index."]";
3228  if ( defined($pv) ) {
3229    if ( !$static ) {
3230      if ($PERL510) {
3231	$init->add( savepvn( "$s.sv_u.svu_pv", $pv, $sv, $cur ) );
3232      }
3233      else {
3234        $init->add( savepvn( sprintf( "xpvnv_list[%d].xpv_pv", $xpvnvsect->index ), $pv, $cur ) );
3235      }
3236    } elsif ($tmp_pvsym eq 'NULL' and $pvsym =~ /^hek/) {
3237      $init->add( sprintf("%s.sv_u.svu_pv = %s.hek_key;", $s, $pvsym ));
3238    }
3239  }
3240  push @B::C::static_free, "&".$s if $PERL518 and $sv->FLAGS & SVs_OBJECT;
3241  savesym( $sv, "&".$s );
3242}
3243
3244sub B::BM::save {
3245  my ($sv, $fullname) = @_;
3246  my $sym = objsym($sv);
3247  return $sym if !$PERL510 and defined $sym;
3248  $sv = bless $sv, "B::BM" if $PERL510;
3249  my $pv  = pack "a*", ( $sv->PV . "\0" . $sv->TABLE );
3250  my $cur = $sv->CUR;
3251  my $len = $cur + length($sv->TABLE) + 1;
3252  my $s;
3253  if ($PERL510) {
3254    warn "Saving FBM for GV $sym\n" if $debug{gv};
3255    $init->add( sprintf( "%s = (GV*)newSV_type(SVt_PVGV);", $sym ),
3256		sprintf( "SvFLAGS(%s) = 0x%x;", $sym, $sv->FLAGS),
3257		sprintf( "SvREFCNT(%s) = $u32fmt;", $sym, $sv->REFCNT + 1 ),
3258		sprintf( "SvPVX(%s) = %s;", $sym, cstring($pv) ),
3259		sprintf( "SvCUR_set(%s, %d);", $sym, $cur ),
3260		sprintf( "SvLEN_set(%s, %d);", $sym, $len ),
3261                sprintf( "BmRARE(%s) = %d;", $sym, $sv->RARE ),
3262                sprintf( "BmPREVIOUS(%s) = %d;", $sym, $sv->PREVIOUS ),
3263                sprintf( "BmUSEFUL(%s) = %d;", $sym, $sv->USEFUL )
3264              );
3265  } else {
3266    my $static;
3267    $xpvbmsect->comment('pvx,cur,len(+258),IVX,NVX,MAGIC,STASH,USEFUL,PREVIOUS,RARE');
3268    $xpvbmsect->add(
3269       sprintf("%s, %u, %u, %s, %s, 0, 0, %d, %u, 0x%x",
3270	       defined($pv) && $static ? cstring($pv) : "NULL",
3271	       $cur, $len, ivx($sv->IVX), nvx($sv->NVX),
3272	       $sv->USEFUL, $sv->PREVIOUS, $sv->RARE
3273	      ));
3274    $svsect->add(sprintf("&xpvbm_list[%d], $u32fmt, 0x%x",
3275                         $xpvbmsect->index, $sv->REFCNT, $sv->FLAGS));
3276    $svsect->debug( $fullname, $sv->flagspv ) if $debug{flags};
3277    $s = "sv_list[".$svsect->index."]";
3278    if (!$static) {
3279      $init->add(savepvn( sprintf( "xpvbm_list[%d].xpv_pv", $xpvbmsect->index ), $pv, 0, $len ) );
3280    } else {
3281      push @B::C::static_free, $s if defined($pv) and !$in_endav;
3282    }
3283  }
3284  # Restore possible additional magic. fbm_compile adds just 'B'.
3285  $sv->save_magic($fullname);
3286
3287  if ($PERL510) {
3288    return $sym;
3289  } else {
3290    if ($] == 5.008009) { # XXX 5.8.9 needs more. TODO test 5.8.0 - 5.8.7
3291      $init->add( sprintf( "fbm_compile(&sv_list[%d], 0);", $svsect->index ) );
3292    }
3293    # cur+len was broken on all B::C versions
3294    #$init->add(sprintf( "xpvbm_list[%d].xpv_cur = %u;", $xpvbmsect->index, $len ) );
3295    return savesym( $sv, "&".$s );
3296  }
3297}
3298
3299sub B::PV::save {
3300  my ($sv, $fullname) = @_;
3301  my $sym = objsym($sv);
3302  if (defined $sym) {
3303    if ($in_endav) {
3304      warn "in_endav: static_free without $sym\n" if $debug{av};
3305      @B::C::static_free = grep {$_ ne $sym} @B::C::static_free;
3306    }
3307    return $sym;
3308  }
3309  #my $flags = $sv->FLAGS;
3310  my ( $pvsym, $cur, $len, $pv, $static, $flags ) = save_pv_or_rv($sv, $fullname);
3311  my $shared_hek = $PERL510 ? (($flags & 0x09000000) == 0x09000000) : undef;
3312  if (!$shared_hek and (IsCOW_hek($sv) or ($len==0 and $flags & SVf_IsCOW))) {
3313    $shared_hek = 1;
3314  }
3315  my $tmp_pvsym = $pvsym;
3316  # $static = 0 if !($flags & SVf_ROK) and $sv->PV and $sv->PV =~ /::bootstrap$/;
3317  my $refcnt = $sv->REFCNT;
3318  my $svix;
3319  # sv_free2 problem with !SvIMMORTAL and del_SV
3320  # repro with -O0 .. -O2 for all testcases
3321  if ($PERL518 and $fullname && $fullname eq 'svop const') {
3322    $refcnt = $DEBUGGING ? 1000 : 0x7fffffff;
3323  }
3324  #if (!$shared_hek and !$B::C::cow and IsCOW($sv)) {
3325  #  $flags &= ~SVf_IsCOW;
3326  #  warn sprintf("turn off SVf_IsCOW %s %s %s\n", $sym, cstring($pv), $fullname)
3327  #    if $debug{pv};
3328  #}
3329  if ($PERL510) {
3330    # static pv, do not destruct. test 13 with pv0 "3".
3331    if ($B::C::const_strings and !$shared_hek and $flags & SVf_READONLY and !$len) {
3332      $flags &= ~0x01000000;
3333      warn sprintf("constpv turn off SVf_FAKE %s %s %s\n", $sym, cstring($pv), $fullname)
3334        if $debug{pv};
3335    }
3336    $tmp_pvsym = 'NULL' if $tmp_pvsym =~ /^hek/ and $static; # cannot init static
3337    $xpvsect->comment( $PERL514 ? "stash, magic, cur, len" :  "xnv_u, cur, len");
3338    $xpvsect->add( sprintf( "%s{0}, %u, %u", $PERL514 ? "Nullhv, " : "", $cur, $len ) );
3339    $svsect->comment( "any, refcnt, flags, sv_u" );
3340    $svsect->add( sprintf( "&xpv_list[%d], $u32fmt, 0x%x, {%s}",
3341                           $xpvsect->index, $refcnt, $flags,
3342			   $tmp_pvsym eq 'NULL' ? '0' :
3343                           ($C99?".svu_pv=(char*)":"(char*)").$pvsym ));
3344    $svix = $svsect->index;
3345    if ( defined($pv) and !$static ) {
3346      if ($shared_hek) {
3347        my $hek = save_hek($pv, $fullname, 1);
3348        $init->add( sprintf( "sv_list[%d].sv_u.svu_pv = HEK_KEY(%s);", $svix, $hek ))
3349          unless $hek eq 'NULL';
3350      } else {
3351        $init->add( savepvn( sprintf( "sv_list[%d].sv_u.svu_pv", $svix ), $pv, $sv, $cur ) );
3352      }
3353    } elsif ($shared_hek and $static and $pvsym =~ /^hek/) {
3354      $init->add( sprintf( "sv_list[%d].sv_u.svu_pv = %s.hek_key;", $svix, $pvsym ));
3355    }
3356    if ($debug{flags} and (!$ITHREADS or $PERL514) and $DEBUG_LEAKING_SCALARS) { # add sv_debug_file
3357      $init->add(sprintf(qq(sv_list[%d].sv_debug_file = %s" sv_list[%d] 0x%x";),
3358			 $svix, cstring($pv) eq '0' ? '"NULL"' : cstring($pv),
3359			 $svix, $flags));
3360    }
3361  }
3362  else {
3363    $xpvsect->comment( "pv, cur, len");
3364    $xpvsect->add(sprintf( "(char*)%s, %u, %u", $pvsym, $cur, $len ) );
3365    $svsect->comment( "any, refcnt, flags" );
3366    $svsect->add(sprintf( "&xpv_list[%d], $u32fmt, 0x%x",
3367		 	  $xpvsect->index, $refcnt, $flags));
3368    $svix = $svsect->index;
3369    if ( defined($pv) and !$static ) {
3370      $init->add( savepvn( sprintf( "xpv_list[%d].xpv_pv", $xpvsect->index ), $pv, 0, $cur ) );
3371    }
3372  }
3373  my $s = "sv_list[$svix]";
3374  $svsect->debug( $fullname, $sv->flagspv ) if $debug{flags};
3375  push @B::C::static_free, "&".$s if $PERL518 and $flags & SVs_OBJECT;
3376  savesym( $sv, "&".$s );
3377}
3378
3379# 5.18-5.20 => PV::save, since 5.22 native using this method
3380sub B::PADNAME::save {
3381  my ($pn, $fullname) = @_;
3382  my $sym = objsym($pn);
3383  if (defined $sym) {
3384    if ($in_endav) {
3385      warn "in_endav: static_free without $sym\n" if $debug{av};
3386      @B::C::static_free = grep {$_ ne $sym} @B::C::static_free;
3387    }
3388    return $sym;
3389  }
3390  my $flags = $pn->FLAGS; # U8 + FAKE if OUTER. OUTER,STATE,LVALUE,TYPED,OUR
3391  $flags = $flags & 0xff;
3392  my $gen    = $pn->GEN;
3393  my $stash  = $pn->OURSTASH;
3394  my $type   = $pn->TYPE;
3395  my $sn = $stash->save($fullname);
3396  my $tn = $type->save($fullname);
3397  my $refcnt = $pn->REFCNT;
3398  $refcnt++ if $refcnt < 1000; # XXX protect from free, but allow SvREFCOUNT_IMMORTAL
3399  my $str = $pn->PVX;
3400  my $cstr = cstring($str); # a 5.22 padname is always utf8
3401  my $len = $pn->LEN;
3402  my $alignedlen = 8*(int($len / 8)+1); # 5 -> 8, 9 -> 16
3403  my $struct_name = "my_padname_with_str_".$alignedlen;
3404  my $pnsect = $padnamesect{$alignedlen};
3405  if (!$pnsect) {
3406    my $name = "padname_$alignedlen";
3407    warn "dynamically created oversized $name section\n" if $verbose;
3408    $padnamesect{$alignedlen} = new B::C::Section $name, \%symtable, 0;
3409  }
3410  my $ix = $pnsect->index + 1;
3411  my $name = $pnsect->name;
3412  my $s = "&".$name."_list[$ix]";
3413  # 5.22 needs the buffer to be at the end, and the pv pointing to it.
3414  # We allocate a static buffer of different sizes.
3415  $pnsect->comment( "pv, ourstash, type, low, high, refcnt, gen, len, flags, str");
3416  my $pnstr = "((char*)$s)+STRUCT_OFFSET(struct $struct_name, xpadn_str[0])";
3417  if (IS_MSVC) {
3418    $pnstr = sprintf("((char*)$s)+%d", $Config{ptrsize} * 3 + 5);
3419  }
3420  $pnsect->add( sprintf
3421      ( "%s, %s, {%s}, %u, %u, %s, %i, %u, 0x%x, %s",
3422        ($ix or $len) ? $pnstr : 'NULL',
3423        is_constant($sn) ? "(HV*)$sn" : 'Nullhv',
3424        is_constant($tn) ? "(HV*)$tn" : 'Nullhv',
3425        $pn->COP_SEQ_RANGE_LOW,
3426        $pn->COP_SEQ_RANGE_HIGH,
3427        $refcnt >= 1000 ? sprintf("0x%x", $refcnt) : "$refcnt /* +1 */",
3428        $gen, $len, $flags, $cstr));
3429  #if ( $len > 64 ) {
3430    # Houston we have a problem, need to allocate this padname dynamically. Not done yet
3431    # either dynamic or seperate structs per size MyPADNAME(5)
3432  #  die "Internal Error: Overlong name of lexical variable $cstr for $fullname [#229]";
3433  #}
3434  $pnsect->debug( $fullname." ".$str, $pn->flagspv ) if $debug{flags};
3435  $init->add("SvOURSTASH_set($s, $sn);") unless is_constant($sn);
3436  $init->add("PadnameTYPE($s) = (HV*)$tn;") unless is_constant($tn);
3437  push @B::C::static_free, $s;
3438  savesym( $pn, $s );
3439}
3440
3441sub lexwarnsym {
3442  my $pv = shift;
3443  if ($lexwarnsym{$pv}) {
3444    return @{$lexwarnsym{$pv}};
3445  } else {
3446    my $sym = sprintf( "lexwarn%d", $pv_index++ );
3447    my ($cstring, $cur, $utf8) = strlen_flags($pv);
3448    my $isint = 0;
3449    if ($] < 5.009) { # need a SV->PV
3450      $decl->add( sprintf( "Static SV* %s;", $sym ));
3451      $init->add( sprintf( "%s = newSVpvn(%s, %u);", $sym, $cstring, $cur));
3452    } else {
3453      # if 8 use UVSIZE, if 4 use LONGSIZE
3454      my $t = ($Config{sizesize} == 8) ? "J" : "L";
3455      my ($iv) = unpack($t, $pv); # size_t
3456      if ($iv >= 0 and $iv <= 2) { # specialWARN: single STRLEN
3457        $decl->add( sprintf( "Static const STRLEN* %s = %d;", $sym, $iv ));
3458        $isint = 1;
3459      } else { # sizeof(STRLEN) + (WARNsize)
3460        my $packedpv = pack("$t a*",length($pv), $pv);
3461        $decl->add( sprintf( "Static const char %s[] = %s;", $sym, cstring($packedpv) ));
3462      }
3463    }
3464    $lexwarnsym{$pv} = [$sym,$isint];
3465    return ($sym, $isint);
3466  }
3467}
3468
3469# pre vs. post 5.8.9/5.9.4 logic for lexical warnings
3470@B::LEXWARN::ISA = qw(B::PV B::IV);
3471sub B::LEXWARN::save {
3472  my ($sv, $fullname) = @_;
3473  my $pv = $] >= 5.008009 ? $sv->PV : $sv->IV;
3474  return lexwarnsym($pv); # look for shared const int's
3475}
3476
3477# post 5.11: When called from save_rv not from PMOP::save precomp
3478sub B::REGEXP::save {
3479  my ($sv, $fullname) = @_;
3480  my $sym = objsym($sv);
3481  return $sym if defined $sym;
3482  my $pv = $sv->PV;
3483  my $cur = $sv->CUR;
3484  my $is_utf8 = $sv->FLAGS & SVf_UTF8;
3485  # construct original PV
3486  $pv =~ s/^(\(\?\^[adluimsx-]*\:)(.*)\)$/$2/;
3487  $cur -= length($sv->PV) - length($pv);
3488  my $cstr = cstring($pv);
3489  # The SvPV field: since df6b4bd56551f2d39f7c again the PV, before the RX
3490  my $rx_or_pv = (!$CPERL51 and $] < 5.027003) or ($CPERL51 and $] < 5.027002) ? 1 : 0;
3491  # Unfortunately this XPV is needed temp. Later replaced by struct regexp.
3492  $xpvsect->add(sprintf("%s{0}, %u, %u", $PERL514 ? "Nullhv, " : "", $cur, 0 ) );
3493  $svsect->add(sprintf("&xpv_list[%d], $u32fmt, 0x%x, {%s}",
3494                       $xpvsect->index, $sv->REFCNT, $sv->FLAGS, $] > 5.017006 ? "NULL" : $cstr));
3495  my $ix = $svsect->index;
3496  warn "Saving RX $cstr to sv_list[$ix]\n" if $debug{rx} or $debug{sv};
3497  my $initpm = $init;
3498  if ($] > 5.011) {
3499    my $pmflags = $PERL522 ? $sv->compflags : $sv->EXTFLAGS;
3500    $initpm = $init1 if re_does_swash($cstr, $pmflags);
3501    if ($PERL518 and $sv->EXTFLAGS & RXf_EVAL_SEEN) {
3502      $initpm->add("PL_hints |= HINT_RE_EVAL;");
3503    }
3504    $initpm->add("{",
3505                 sprintf("  SV* sv = newSVpvn_flags(%s, %d, %d);", $cstr, $cur, $is_utf8),
3506                 # need pv and extflags
3507                 sprintf("  REGEXP *re = CALLREGCOMP(sv, 0x%x);", $pmflags),
3508                 # replace sv_any->XPV with struct regexp or pv.
3509                 ((!$rx_or_pv and $sv->FLAGS & SVt_PVLV)
3510                  ? "  Copy(re, &sv_list[$ix], sizeof(REGEXP), char);"
3511                  : "  struct regexp *rx = (struct regexp *)SvANY(re);\n\t"
3512                  . ($] < 5.017006
3513                     ? "  SvANY(&sv_list[$ix]) = rx;"
3514                     : "  SvANY(&sv_list[$ix]) = (&sv_list[$ix])->sv_u.svu_rx = rx;")),
3515                 "}");
3516    if ($PERL518 and $sv->EXTFLAGS & RXf_EVAL_SEEN) {
3517      $initpm->add("PL_hints &= ~HINT_RE_EVAL;");
3518    }
3519  }
3520  if ($] < 5.017006) {
3521    # since 5.17.6 the SvLEN stores RX_WRAPPED(rx)
3522    $init->add(sprintf("SvCUR(&sv_list[%d]) = %d;", $ix, $cur),
3523                       "SvLEN(&sv_list[$ix]) = 0;");
3524  }
3525  $svsect->debug( $fullname, $sv->flagspv ) if $debug{flags};
3526  $sym = savesym( $sv, sprintf( "&sv_list[%d]", $ix ) );
3527  $sv->save_magic($fullname);
3528  return $sym;
3529}
3530
3531sub save_remap {
3532  my ($key, $pkg, $name, $ivx, $mandatory) = @_;
3533  my $id = $xpvmgsect->index + 1;
3534  #my $svid = $svsect->index + 1;
3535  warn "init remap for $key\: $name $ivx in xpvmg_list[$id]\n" if $verbose;
3536  my $props = { NAME => $name, ID   => $id, MANDATORY => $mandatory };
3537  $init2_remap{$key}{MG} = [] unless $init2_remap{$key}{'MG'};
3538  push @{$init2_remap{$key}{MG}}, $props;
3539}
3540
3541sub patch_dlsym {
3542  my ($sv, $fullname, $ivx) = @_;
3543  my $pkg = '';
3544  if (ref($sv) eq 'B::PVMG') {
3545    my $stash = $sv->SvSTASH;
3546    $pkg = $stash->can('NAME') ? $stash->NAME : '';
3547  }
3548  my $name = $sv->FLAGS & SVp_POK ? $sv->PVX : "";
3549  my $ivx_s = $ivx;
3550  $ivx_s =~ s/U?L?$//g;
3551  my $ivxhex = sprintf("0x%x", $ivx_s);
3552  # Encode RT #94221
3553  if ($name =~ /encoding$/ and $name =~ /^(ascii|ascii_ctrl|iso8859_1|null)/ and $Encode::VERSION eq '2.58') {
3554    $name =~ s/-/_/g;
3555    $pkg = 'Encode' if $pkg eq 'Encode::XS'; # TODO foreign classes
3556    mark_package($pkg) if $fullname eq '(unknown)' and $ITHREADS;
3557    warn "$pkg $Encode::VERSION with remap support for $name\n" if $verbose;
3558  }
3559  elsif ($pkg eq 'Encode::XS') {
3560    $pkg = 'Encode';
3561    if ($fullname eq 'Encode::Encoding{iso-8859-1}') {
3562      $name = "iso8859_1_encoding";
3563    }
3564    elsif ($fullname eq 'Encode::Encoding{null}') {
3565      $name = "null_encoding";
3566    }
3567    elsif ($fullname eq 'Encode::Encoding{ascii-ctrl}') {
3568      $name = "ascii_ctrl_encoding";
3569    }
3570    elsif ($fullname eq 'Encode::Encoding{ascii}') {
3571      $name = "ascii_encoding";
3572    }
3573
3574    if ($name and $name =~ /^(ascii|ascii_ctrl|iso8859_1|null)/ and $Encode::VERSION gt '2.58') {
3575      my $enc = Encode::find_encoding($name);
3576      $name .= "_encoding" unless $name =~ /_encoding$/;
3577      $name =~ s/-/_/g;
3578      warn "$pkg $Encode::VERSION with remap support for $name (find 1)\n" if $verbose;
3579      mark_package($pkg);
3580      if ($pkg ne 'Encode') {
3581        svref_2object( \&{"$pkg\::bootstrap"} )->save;
3582        mark_package('Encode');
3583      }
3584    }
3585    else {
3586      for my $n (Encode::encodings()) { # >=5.16 constsub without name
3587        my $enc = Encode::find_encoding($n);
3588        if ($enc and ref($enc) ne 'Encode::XS') { # resolve alias such as Encode::JP::JIS7=HASH(0x292a9d0)
3589          $pkg = ref($enc);
3590          $pkg =~ s/^(Encode::\w+)(::.*)/$1/; # collapse to the @dl_module name
3591          $enc = Encode->find_alias($n);
3592        }
3593        if ($enc and ref($enc) eq 'Encode::XS' and $sv->IVX == $$enc) {
3594          $name = $n;
3595          $name =~ s/-/_/g;
3596          $name .= "_encoding" if $name !~ /_encoding$/;
3597          mark_package($pkg) ;
3598          if ($pkg ne 'Encode') {
3599            svref_2object( \&{"$pkg\::bootstrap"} )->save;
3600            mark_package('Encode');
3601          }
3602          last;
3603        }
3604      }
3605      if ($name) {
3606        warn "$pkg $Encode::VERSION remap found for constant $name\n" if $verbose;
3607      } else {
3608        warn "Warning: Possible missing remap for compile-time XS symbol in $pkg $fullname $ivxhex [#305]\n";
3609      }
3610    }
3611  }
3612  # Encode-2.59 uses a different name without _encoding
3613  elsif ($Encode::VERSION ge '2.58' and Encode::find_encoding($name)) {
3614    my $enc = Encode::find_encoding($name);
3615    $pkg = ref($enc) if ref($enc) ne 'Encode::XS';
3616    $name .= "_encoding";
3617    $name =~ s/-/_/g;
3618    $pkg = 'Encode' unless $pkg;
3619    warn "$pkg $Encode::VERSION with remap support for $name (find 2)\n" if $verbose;
3620  }
3621  # now that is a weak heuristic, which misses #305
3622  elsif (defined $Net::DNS::VERSION
3623         and $Net::DNS::VERSION =~ /^0\.(6[789]|7[1234])/) {
3624    if ($fullname eq 'svop const') {
3625      $name = "ascii_encoding";
3626      $pkg = 'Encode' unless $pkg;
3627      warn "Warning: Patch Net::DNS external XS symbol $pkg\::$name $ivxhex [RT #94069]\n";
3628    }
3629  }
3630  elsif ($pkg eq 'Net::LibIDN') {
3631    $name = "idn_to_ascii"; # ??
3632  }
3633
3634  # new API (only Encode so far)
3635  if ($pkg and $name and $name =~ /^[a-zA-Z_0-9-]+$/) { # valid symbol name
3636    warn "Remap IOK|POK $pkg with $name\n" if $verbose;
3637    save_remap($pkg, $pkg, $name, $ivxhex, 0);
3638    $ivx = "0UL /* $ivxhex => $name */";
3639    mark_package($pkg, 1) if $fullname =~ /^(svop const|padop)/;
3640  }
3641  else {
3642    warn "Warning: Possible missing remap for compile-time XS symbol in $pkg $fullname $ivxhex [#305]\n";
3643  }
3644  return $ivx;
3645}
3646
3647sub B::PVMG::save {
3648  my ($sv, $fullname) = @_;
3649  my $sym = objsym($sv);
3650  if (defined $sym) {
3651    if ($in_endav) {
3652      warn "in_endav: static_free without $sym\n" if $debug{av};
3653      @B::C::static_free = grep {$_ ne $sym} @B::C::static_free;
3654    }
3655    return $sym;
3656  }
3657  my ( $pvsym, $cur, $len, $pv, $static, $flags ) = save_pv_or_rv($sv, $fullname);
3658  #warn sprintf( "PVMG %s (0x%x) $pvsym, $len, $cur, $pv\n", $sym, $$sv ) if $debug{mg};
3659
3660  my ($ivx,$nvx);
3661  # since 5.11 REGEXP isa PVMG, but has no IVX and NVX methods
3662  if ($] >= 5.011 and ref($sv) eq 'B::REGEXP') {
3663    return B::REGEXP::save($sv, $fullname);
3664  }
3665  else {
3666    $ivx = ivx($sv->IVX); # XXX How to detect HEK* namehek?
3667    $nvx = nvx($sv->NVX); # it cannot be xnv_u.xgv_stash ptr (BTW set by GvSTASH later)
3668
3669    # See #305 Encode::XS: XS objects are often stored as SvIV(SvRV(obj)). The real
3670    # address needs to be patched after the XS object is initialized.
3671    # But how detect them properly?
3672    # Detect ptr to extern symbol in shared library and remap it in init2
3673    # Safe and mandatory currently only Net-DNS-0.67 - 0.74.
3674    # svop const or pad OBJECT,IOK
3675    if (((!$ITHREADS
3676          and $fullname
3677          and $fullname =~ /^svop const|^padop|^Encode::Encoding| :pad\[1\]/)
3678         or $ITHREADS)
3679        and $sv->IVX > LOWEST_IMAGEBASE # some crazy heuristic for a sharedlibrary ptr in .data (> image_base)
3680        and ref($sv->SvSTASH) ne 'B::SPECIAL')
3681    {
3682      $ivx = patch_dlsym($sv, $fullname, $ivx);
3683    }
3684  }
3685
3686  my $tmp_pvsym = $pvsym;
3687  if ($PERL510) {
3688    if ($sv->FLAGS & SVf_ROK) {  # sv => sv->RV cannot be initialized static.
3689      $init->add(sprintf("SvRV_set(&sv_list[%d], (SV*)%s);", $svsect->index+1, $pvsym))
3690	if $pvsym ne '';
3691      $pvsym = 'NULL';
3692      $static = 1;
3693    }
3694    if ($PERL514) {
3695      $tmp_pvsym = 'NULL' if $tmp_pvsym =~ /^hek/ and $static; # cannot init static
3696      $xpvmgsect->comment("STASH, MAGIC, cur, len, xiv_u, xnv_u");
3697      $xpvmgsect->add(sprintf("Nullhv, {0}, %u, %u, {%s}, {%s}",
3698			      $cur, $len, $ivx, $nvx));
3699    } else {
3700      $xpvmgsect->comment("xnv_u, cur, len, xiv_u, xmg_u, xmg_stash");
3701      $xpvmgsect->add(sprintf("{%s}, %u, %u, {%s}, {0}, Nullhv",
3702			    $nvx, $cur, $len, $ivx));
3703    }
3704    $svsect->add(sprintf("&xpvmg_list[%d], $u32fmt, 0x%x, {%s}",
3705                         $xpvmgsect->index, $sv->REFCNT, $flags,
3706			 $tmp_pvsym eq 'NULL' ? '0' :
3707                           ($C99?".svu_pv=(char*)":"(char*)").$tmp_pvsym));
3708  }
3709  else {
3710    if ($pvsym =~ /PL_sv_undef/ and $ITHREADS) {
3711      $pvsym = 'NULL'; # Moose 5.8.9d
3712    }
3713    $xpvmgsect->add(sprintf("(char*)%s, %u, %u, %s, %s, 0, 0",
3714                            $pvsym, $cur, $len, $ivx, $nvx));
3715    $svsect->add(sprintf("&xpvmg_list[%d], $u32fmt, 0x%x",
3716			 $xpvmgsect->index, $sv->REFCNT, $flags));
3717  }
3718  $svsect->debug( $fullname, $sv->flagspv ) if $debug{flags};
3719  my $s = "sv_list[".$svsect->index."]";
3720  if ( !$static ) { # do not overwrite RV slot (#273)
3721    # XXX comppadnames need &PL_sv_undef instead of 0 (?? which testcase?)
3722    if ($PERL510) {
3723      $init->add( savepvn( "$s.sv_u.svu_pv", $pv, $sv, $cur ) );
3724    } else {
3725      $init->add( savepvn( sprintf( "xpvmg_list[%d].xpv_pv", $xpvmgsect->index ),
3726                          $pv, $sv, $cur ) );
3727    }
3728  } elsif ($tmp_pvsym eq 'NULL' and $pvsym =~ /^hek/) {
3729    $init->add( sprintf("%s.sv_u.svu_pv = %s.hek_key;", $s, $pvsym ));
3730  }
3731  $sym = savesym( $sv, "&".$s );
3732  $sv->save_magic($fullname);
3733  return $sym;
3734}
3735
3736# mark threads::shared to be xs-loaded
3737sub mark_threads {
3738  if ( $INC{'threads.pm'} ) {
3739    my $stash = 'threads';
3740    mark_package($stash);
3741    $use_xsloader = 1;
3742    $xsub{$stash} = 'Dynamic-' . $INC{'threads.pm'};
3743    warn "mark threads for 'P' magic\n" if $debug{mg};
3744  } else {
3745    warn "ignore to mark threads for 'P' magic\n" if $debug{mg};
3746  }
3747  if ( $INC{'threads/shared.pm'} ) {
3748    my $stash = 'threads::shared';
3749    mark_package($stash);
3750    # XXX why is this needed? threads::shared should be initialized automatically
3751    $use_xsloader = 1; # ensure threads::shared is initialized
3752    $xsub{$stash} = 'Dynamic-' . $INC{'threads/shared.pm'};
3753    warn "mark threads::shared for 'P' magic\n" if $debug{mg};
3754  } else {
3755    warn "ignore to mark threads::shared for 'P' magic\n" if $debug{mg};
3756  }
3757}
3758
3759sub B::PVMG::save_magic {
3760  my ($sv, $fullname) = @_;
3761  my $sv_flags = $sv->FLAGS;
3762  my $pkg;
3763  return if $fullname and $fullname eq '%B::C::';
3764  if ($debug{mg}) {
3765    my $flagspv = "";
3766    $fullname = '' unless $fullname;
3767    $flagspv = $sv->flagspv if $debug{flags} and $PERL510 and !$sv->MAGICAL;
3768    warn sprintf( "saving magic for %s %s (0x%x) flags=0x%x%s  - called from %s:%s\n",
3769		B::class($sv), $fullname, $$sv, $sv_flags, $debug{flags} ? "(".$flagspv.")" : "",
3770		@{[(caller(1))[3]]}, @{[(caller(1))[2]]});
3771  }
3772
3773  # crashes on STASH=0x18 with HV PERL_MAGIC_overload_table stash %version:: flags=0x3280000c
3774  # issue267 GetOpt::Long SVf_AMAGIC|SVs_RMG|SVf_OOK
3775  # crashes with %Class::MOP::Instance:: flags=0x2280000c also
3776  if (ref($sv) eq 'B::HV' and $] > 5.018 and $sv->MAGICAL and $fullname =~ /::$/) {
3777    warn sprintf("skip SvSTASH for overloaded HV %s flags=0x%x\n", $fullname, $sv_flags)
3778      if $verbose;
3779  # [cperl #60] not only overloaded, version also
3780  } elsif (ref($sv) eq 'B::HV' and $] > 5.018 and $fullname =~ /(version|File)::$/) {
3781    warn sprintf("skip SvSTASH for %s flags=0x%x\n", $fullname, $sv_flags)
3782      if $verbose;
3783  } else {
3784    my $pkgsym;
3785    $pkg = $sv->SvSTASH;
3786    if ($pkg and $$pkg) {
3787      my $pkgname =  $pkg->can('NAME') ? $pkg->NAME : $pkg->NAME_HEK."::DESTROY";
3788      warn sprintf("stash isa class \"%s\" (%s)\n", $pkgname, ref $pkg)
3789        if $debug{mg} or $debug{gv};
3790      # 361 do not force dynaloading IO via IO::Handle upon us
3791      # core already initialized this stash for us
3792      unless ($fullname eq 'main::STDOUT' and $] >= 5.018) {
3793        if (ref $pkg eq 'B::HV') {
3794          if ($fullname !~ /::$/ or $B::C::stash) {
3795            $pkgsym = $pkg->save($fullname);
3796          } else {
3797            $pkgsym = savestashpv($pkgname);
3798          }
3799        } else {
3800          $pkgsym = 'NULL';
3801        }
3802
3803        warn sprintf( "xmg_stash = \"%s\" as %s\n", $pkgname, $pkgsym )
3804          if $debug{mg} or $debug{gv};
3805        # Q: Who is initializing our stash from XS? ->save is missing that.
3806        # A: We only need to init it when we need a CV
3807        # defer for XS loaded stashes with AMT magic
3808        if (ref $pkg eq 'B::HV') {
3809          $init->add( sprintf( "SvSTASH_set(s\\_%x, (HV*)s\\_%x);", $$sv, $$pkg ) );
3810          $init->add( sprintf( "SvREFCNT((SV*)s\\_%x) += 1;", $$pkg ) );
3811          $init->add("++PL_sv_objcount;") unless ref($sv) eq "B::IO";
3812          # XXX
3813          #push_package($pkg->NAME);  # correct code, but adds lots of new stashes
3814        }
3815      }
3816    }
3817  }
3818  $init->add(sprintf("SvREADONLY_off((SV*)s\\_%x);", $$sv))
3819    if $sv_flags & SVf_READONLY and ref($sv) ne 'B::HV';
3820
3821  # Protect our SVs against non-magic or SvPAD_OUR. Fixes tests 16 and 14 + 23
3822  if ($PERL510 and !($sv->MAGICAL or $sv_flags & SVf_AMAGIC)) {
3823    warn sprintf("Skipping non-magical PVMG type=%d, flags=0x%x%s\n",
3824                 $sv_flags && 0xff, $sv_flags, $debug{flags} ? "(".$sv->flagspv.")" : "")
3825      if $debug{mg};
3826    return '';
3827  }
3828
3829  # disabled. testcase: t/testm.sh Path::Class
3830  if (0 and $PERL518 and $sv_flags & SVf_AMAGIC) {
3831    my $name = $fullname;
3832    $name =~ s/^%(.*)::$/$1/;
3833    $name = $pkg->NAME if $pkg and $$pkg;
3834    warn sprintf("initialize overload cache for %s\n", $fullname )
3835      if $debug{mg} or $debug{gv};
3836    # This is destructive, it removes the magic instead of adding it.
3837    #$init1->add(sprintf("Gv_AMG(%s); /* init overload cache for %s */", savestashpv($name),
3838    #                    $fullname));
3839  }
3840
3841  my @mgchain = $sv->MAGIC;
3842  my ( $mg, $type, $obj, $ptr, $len, $ptrsv );
3843  my $magic = '';
3844  foreach $mg (@mgchain) {
3845    $type = $mg->TYPE;
3846    $ptr  = $mg->PTR;
3847    $len  = $mg->LENGTH;
3848    $magic .= $type;
3849    if ( $debug{mg} ) {
3850      warn sprintf( "%s %s magic 0x%x\n", $fullname, cchar($type), $mg->FLAGS );
3851      #eval {
3852      #  warn sprintf( "magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
3853      #                B::class($sv), $$sv, B::class($obj), $$obj, cchar($type),
3854      #		      cstring($ptr) );
3855      #};
3856    }
3857
3858    unless ( $type =~ /^[rDn]$/ ) { # r - test 23 / D - Getopt::Long
3859      # 5.10: Can't call method "save" on unblessed reference
3860      #warn "Save MG ". $obj . "\n" if $PERL510;
3861      # 5.11 'P' fix in B::IV::save, IV => RV
3862      $obj = $mg->OBJ;
3863      $obj->save($fullname)
3864        unless $PERL510 and ref $obj eq 'SCALAR';
3865      mark_threads if $type eq 'P';
3866    }
3867
3868    if ( $len == HEf_SVKEY ) {
3869      # The pointer is an SV* ('s' sigelem e.g.)
3870      # XXX On 5.6 ptr might be a SCALAR ref to the PV, which was fixed later
3871      if (ref($ptr) eq 'SCALAR') {
3872	$ptrsv = svref_2object($ptr)->save($fullname);
3873      } elsif ($ptr and ref $ptr) {
3874	$ptrsv = $ptr->save($fullname);
3875      } else {
3876	$ptrsv = 'NULL';
3877      }
3878      warn "MG->PTR is an SV*\n" if $debug{mg};
3879      $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, (char *)%s, %d);",
3880                         $$sv, $$obj, cchar($type), $ptrsv, $len));
3881      if (!($mg->FLAGS & 2)) {
3882        mg_RC_off($mg, $sv, $type);
3883      }
3884    }
3885    # coverage $Template::Stash::PRIVATE
3886    elsif ( $type eq 'r' ) { # qr magic, for 5.6 done in C.xs. test 20
3887      my $rx   = $PERL56 ? ${$mg->OBJ} : $mg->REGEX;
3888      # stored by some PMOP *pm = cLOGOP->op_other (pp_ctl.c) in C.xs
3889      my $pmop = $Regexp{$rx};
3890      if (!$pmop) {
3891	warn "Warning: C.xs PMOP missing for QR\n";
3892      } else {
3893	my ($resym, $relen);
3894	if ($PERL56) {
3895	  ($resym, $relen) = savere( $pmop->precomp ); # 5.6 has precomp only in PMOP
3896	  ($resym, $relen) = savere( $mg->precomp ) unless $relen;
3897	} else {
3898	  ($resym, $relen) = savere( $mg->precomp );
3899	}
3900	my $pmsym = $pmop->save(0, $fullname);
3901	if ($PERL510) {
3902          push @B::C::static_free, $resym;
3903	  $init->add( split /\n/,
3904		    sprintf <<CODE1, $resym, $pmop->pmflags, $$sv, cchar($type), cstring($ptr), $len );
3905{
3906    REGEXP* rx = CALLREGCOMP((SV* const)%s, %d);
3907    sv_magic((SV*)s\\_%x, (SV*)rx, %s, %s, %d);
3908}
3909CODE1
3910	}
3911	else {
3912	  $pmsym =~ s/\(OP\*\)\&pmop_list/&pmop_list/;
3913	  $init->add( split /\n/,
3914		      sprintf <<CODE2, $$sv, cchar($type), cstring($ptr), $len );
3915{
3916    REGEXP* rx = pregcomp((char*)$resym,(char*)($resym + $relen), (PMOP*)$pmsym);
3917    sv_magic((SV*)s\\_%x, (SV*)rx, %s, %s, %d);
3918}
3919CODE2
3920        }
3921      }
3922    }
3923    elsif ( $type eq 'D' ) { # XXX regdata AV - coverage? i95, 903
3924      # see Perl_mg_copy() in mg.c
3925      $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
3926                         $$sv, $fullname eq 'main::-' ? 0 : $$sv, "'D'", cstring($ptr), $len ));
3927    }
3928    elsif ( $type eq 'n' ) { # shared_scalar is from XS dist/threads-shared
3929      # XXX check if threads is loaded also? otherwise it is only stubbed
3930      mark_threads;
3931      $init->add(sprintf("sv_magic((SV*)s\\_%x, Nullsv, %s, %s, %d);",
3932			   $$sv, "'n'", cstring($ptr), $len ));
3933    }
3934    elsif ( $type eq 'c' ) { # and !$PERL518
3935      $init->add(sprintf(
3936          "/* AMT overload table for the stash %s s\\_%x is generated dynamically */",
3937          $fullname, $$sv ));
3938    }
3939    elsif ( $type eq ':' ) { # symtab magic
3940      # search $ptr in list of pmops and replace it. e.g. (char*)&pmop_list[0]
3941      my $pmop_ptr = unpack("J", $mg->PTR);
3942      my $pmop;
3943      $pmop = $B::C::Regexp{$pmop_ptr} if defined $pmop_ptr;
3944      my $pmsym = $pmop ? $pmop->save(0, $fullname)
3945                        : ''; #sprintf('&pmop_list[%u]', $pmopsect->index);
3946      warn sprintf("pmop 0x%x not found in our B::C Regexp hash\n", $pmop_ptr || 'undef')
3947        if !$pmop and $verbose;
3948      $init->add("{\tU32 elements;", # toke.c: PL_multi_open == '?'
3949         sprintf("\tMAGIC *mg = sv_magicext((SV*)s\\_%x, 0, ':', 0, 0, 0);", $$sv),
3950                 "\telements = mg->mg_len / sizeof(PMOP**);",
3951                 "\tRenewc(mg->mg_ptr, elements + 1, PMOP*, char);",
3952         ($pmop
3953         ? (sprintf("\t((OP**)mg->mg_ptr) [elements++] = (OP*)%s;", $pmsym))
3954          : ( defined $pmop_ptr
3955              ? sprintf( "\t((OP**)mg->mg_ptr) [elements++] = (OP*)s\\_%x;", $pmop_ptr ) : '' )),
3956                 "\tmg->mg_len = elements * sizeof(PMOP**);", "}");
3957    }
3958    else {
3959      $init->add(sprintf(
3960          "sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
3961          $$sv, $$obj, cchar($type), cstring($ptr), $len));
3962      if (!($mg->FLAGS & 2)) {
3963        mg_RC_off($mg, $sv, $type);
3964      }
3965    }
3966  }
3967  $init->add(sprintf("SvREADONLY_on((SV*)s\\_%x);", $$sv))
3968    if $sv_flags & SVf_READONLY and ref($sv) ne 'B::HV';
3969  $magic;
3970}
3971
3972# Since 5.11 also called by IV::save (SV -> IV)
3973sub B::RV::save {
3974  my ($sv, $fullname) = @_;
3975  my $sym = objsym($sv);
3976  return $sym if defined $sym;
3977  warn sprintf( "Saving RV %s (0x%x) - called from %s:%s\n",
3978		B::class($sv), $$sv, @{[(caller(1))[3]]}, @{[(caller(1))[2]]})
3979    if $debug{sv};
3980
3981  my $rv = save_rv($sv, $fullname);
3982  return '0' unless $rv;
3983  if ($PERL510) {
3984    $svsect->comment( "any, refcnt, flags, sv_u" );
3985    # 5.22 has a wrong RV->FLAGS (https://github.com/perl11/cperl/issues/63)
3986    my $flags = $sv->FLAGS;
3987    $flags = 0x801 if $flags & 9 and $PERL522; # not a GV but a ROK IV (21)
3988    # 5.10 has no struct xrv anymore, just sv_u.svu_rv. static or dynamic?
3989    # initializer element is computable at load time
3990    $svsect->add( sprintf( "ptr_undef, $u32fmt, 0x%x, {%s}", $sv->REFCNT, $flags,
3991                           (($C99 && is_constant($rv)) ? ".svu_rv=$rv" : "0 /*-> $rv */")));
3992    $svsect->debug( $fullname, $sv->flagspv ) if $debug{flags};
3993    my $s = "sv_list[".$svsect->index."]";
3994    # 354 defined needs SvANY
3995    $init->add( sprintf("$s.sv_any = (char*)&$s - %d;", $Config{ptrsize}))
3996      if $] > 5.019 or $ITHREADS;
3997    unless ($C99 && is_constant($rv)) {
3998      if ( $rv =~ /get_cv/ ) {
3999        $init2->add( "$s.sv_u.svu_rv = (SV*)$rv;" ) ;
4000      } else {
4001        $init->add( "$s.sv_u.svu_rv = (SV*)$rv;" ) ;
4002      }
4003    }
4004    return savesym( $sv, "&".$s );
4005  }
4006  else {
4007    # GVs need to be handled at runtime
4008    if ( ref( $sv->RV ) eq 'B::GV' or $rv =~ /^gv_list/) {
4009      $xrvsect->add("Nullsv /* $rv */");
4010      $init->add(
4011        sprintf( "xrv_list[%d].xrv_rv = (SV*)%s;", $xrvsect->index, $rv ) );
4012    }
4013    # and stashes, too
4014    elsif ( $sv->RV->isa('B::HV') && $sv->RV->NAME ) {
4015      $xrvsect->add("Nullsv /* $rv */");
4016      $init->add(
4017        sprintf( "xrv_list[%d].xrv_rv = (SV*)%s;", $xrvsect->index, $rv ) );
4018    }
4019    # one more: bootstrapped XS CVs (test Class::MOP, no simple testcase yet)
4020    # dynamic; so we need to inc it
4021    elsif ( $rv =~ /get_cv/ ) {
4022      $xrvsect->add("Nullsv /* $rv */");
4023      $init2->add(
4024        sprintf( "xrv_list[%d].xrv_rv = (SV*)SvREFCNT_inc(%s);", $xrvsect->index, $rv ) );
4025    }
4026    else {
4027      #$xrvsect->add($rv); # not static initializable (e.g. cv160 for ExtUtils::Install)
4028      $xrvsect->add("Nullsv /* $rv */");
4029      $init->add(
4030        sprintf( "xrv_list[%d].xrv_rv = (SV*)SvREFCNT_inc(%s);", $xrvsect->index, $rv ) );
4031    }
4032    $svsect->comment( "any, refcnt, flags" );
4033    $svsect->add(sprintf("&xrv_list[%d], $u32fmt, 0x%x",
4034			 $xrvsect->index, $sv->REFCNT, $sv->FLAGS));
4035    $svsect->debug( $fullname, $sv->flagspv ) if $debug{flags};
4036    my $s = "sv_list[".$svsect->index."]";
4037    return savesym( $sv, "&".$s );
4038  }
4039}
4040
4041sub get_isa ($) {
4042  my $name = shift;
4043  if ($PERL510) {
4044    if (is_using_mro()) { # mro.xs loaded. c3 or dfs
4045      return @{mro::get_linear_isa($name)};
4046    } else { # dfs only, without loading mro
4047      return @{B::C::get_linear_isa($name)};
4048    }
4049  } else {
4050    no strict 'refs';
4051    my $s = "$name\::";
4052    if (exists(${$s}{ISA})) {
4053      if (exists(${$s}{ISA}{ARRAY})) {
4054        return @{ "$s\::ISA" };
4055      }
4056    }
4057  }
4058}
4059
4060# try_isa($pkg,$name) returns the found $pkg for the method $pkg::$name
4061# If a method can be called (via UNIVERSAL::can) search the ISA's. No AUTOLOAD needed.
4062# XXX issue 64, empty @ISA if a package has no subs. in Bytecode ok
4063sub try_isa {
4064  my ( $cvstashname, $cvname ) = @_;
4065  return 0 unless defined $cvstashname && defined $cvname;
4066  if (my $found = $isa_cache{"$cvstashname\::$cvname"}) {
4067    return $found;
4068  }
4069  no strict 'refs';
4070  # XXX theoretically a valid shortcut. In reality it fails when $cvstashname is not loaded.
4071  # return 0 unless $cvstashname->can($cvname);
4072  my @isa = get_isa($cvstashname);
4073  warn sprintf( "No definition for sub %s::%s. Try \@%s::ISA=(%s)\n",
4074		$cvstashname, $cvname, $cvstashname, join(",",@isa))
4075    if $debug{cv};
4076  for (@isa) { # global @ISA or in pad
4077    next if $_ eq $cvstashname;
4078    warn sprintf( "Try &%s::%s\n", $_, $cvname ) if $debug{cv};
4079    if (defined(&{$_ .'::'. $cvname})) {
4080      if (exists(${$cvstashname.'::'}{ISA})) {
4081        svref_2object( \@{$cvstashname . '::ISA'} )->save("$cvstashname\::ISA");
4082      }
4083      $isa_cache{"$cvstashname\::$cvname"} = $_;
4084      mark_package($_, 1); # force
4085      return $_;
4086    } else {
4087      $isa_cache{"$_\::$cvname"} = 0;
4088      if (get_isa($_)) {
4089	my $parent = try_isa($_, $cvname);
4090	if ($parent) {
4091	  $isa_cache{"$_\::$cvname"} = $parent;
4092	  $isa_cache{"$cvstashname\::$cvname"} = $parent;
4093	  warn sprintf( "Found &%s::%s\n", $parent, $cvname ) if $debug{gv};
4094	  if (exists(${$parent.'::'}{ISA})) {
4095	    warn "save \@$parent\::ISA\n" if $debug{pkg};
4096	    svref_2object( \@{$parent . '::ISA'} )->save("$parent\::ISA");
4097          }
4098	  if (exists(${$_.'::'}{ISA})) {
4099            warn "save \@$_\::ISA\n" if $debug{pkg};
4100	    svref_2object( \@{$_ . '::ISA'} )->save("$_\::ISA");
4101          }
4102	  return $parent;
4103	}
4104      }
4105    }
4106  }
4107  return 0; # not found
4108}
4109
4110sub load_utf8_heavy {
4111    return if $savINC{"utf8_heavy.pl"};
4112
4113    require 'utf8_heavy.pl';
4114    mark_package('utf8_heavy.pl');
4115    $curINC{'utf8_heavy.pl'} = $INC{'utf8_heavy.pl'};
4116    $savINC{"utf8_heavy.pl"} = 1;
4117    add_hashINC("utf8");
4118
4119    # FIXME: we want to use add_hashINC for utf8_heavy, inc_packname should return an array
4120    # add_hashINC("utf8_heavy.pl");
4121
4122    # In CORE utf8::SWASHNEW is demand-loaded from utf8 with Perl_load_module()
4123    # It adds about 1.6MB exe size 32-bit.
4124    svref_2object( \&{"utf8\::SWASHNEW"} )->save;
4125
4126    return 1;
4127}
4128
4129# If the sub or method is not found:
4130# 1. try @ISA, mark_package and return.
4131# 2. try UNIVERSAL::method
4132# 3. try compile-time expansion of AUTOLOAD to get the goto &sub addresses
4133sub try_autoload {
4134  my ( $cvstashname, $cvname ) = @_;
4135  no strict 'refs';
4136  return unless defined $cvstashname && defined $cvname;
4137  return 1 if try_isa($cvstashname, $cvname);
4138
4139  no strict 'refs';
4140  if (defined(*{'UNIVERSAL::'. $cvname}{CODE})) {
4141    warn "Found UNIVERSAL::$cvname\n" if $debug{cv};
4142    return svref_2object( \&{'UNIVERSAL::'.$cvname} );
4143  }
4144  my $fullname = $cvstashname . '::' . $cvname;
4145  warn sprintf( "No definition for sub %s. Try %s::AUTOLOAD\n",
4146		$fullname, $cvstashname ) if $debug{cv};
4147  if ($fullname eq 'utf8::SWASHNEW') {
4148    # utf8_heavy was loaded so far, so defer to a demand-loading stub
4149    # always require utf8_heavy, do not care if it s already in
4150    my $stub = sub { require 'utf8_heavy.pl'; goto &utf8::SWASHNEW };
4151    return svref_2object( $stub );
4152  }
4153
4154  # Handle AutoLoader classes. Any more general AUTOLOAD
4155  # use should be handled by the class itself.
4156  my @isa = get_isa($cvstashname);
4157  if ( $cvstashname =~ /^POSIX|Storable|DynaLoader|Net::SSLeay|Class::MethodMaker$/
4158    or (exists ${$cvstashname.'::'}{AUTOLOAD} and grep( $_ eq "AutoLoader", @isa ) ) )
4159  {
4160    # Tweaked version of AutoLoader::AUTOLOAD
4161    my $dir = $cvstashname;
4162    $dir =~ s(::)(/)g;
4163    warn "require \"auto/$dir/$cvname.al\"\n" if $debug{cv};
4164    eval { local $SIG{__DIE__}; require "auto/$dir/$cvname.al" unless $INC{"auto/$dir/$cvname.al"} };
4165    unless ($@) {
4166      warn "Forced load of \"auto/$dir/$cvname.al\"\n" if $verbose;
4167      return svref_2object( \&$fullname )
4168	if defined &$fullname;
4169    }
4170  }
4171
4172  # XXX Still not found, now it's getting dangerous (until 5.10 only)
4173  # Search and call ::AUTOLOAD (=> ROOT and XSUB) (test 27, 5.8)
4174  # Since 5.10 AUTOLOAD xsubs are already resolved
4175  if (exists ${$cvstashname.'::'}{AUTOLOAD} and !$PERL510) {
4176    my $auto = \&{$cvstashname.'::AUTOLOAD'};
4177    # Tweaked version of __PACKAGE__::AUTOLOAD
4178    $AutoLoader::AUTOLOAD = ${$cvstashname.'::AUTOLOAD'} = "$cvstashname\::$cvname";
4179
4180    # Prevent eval from polluting STDOUT,STDERR and our c code.
4181    # With a debugging perl STDERR is written
4182    local *REALSTDOUT;
4183    local *REALSTDERR unless $DEBUGGING;
4184    open(REALSTDOUT,">&STDOUT");
4185    open(REALSTDERR,">&STDERR") unless $DEBUGGING;
4186    open(STDOUT,">","/dev/null");
4187    open(STDERR,">","/dev/null") unless $DEBUGGING;
4188    warn "eval \&$cvstashname\::AUTOLOAD\n" if $debug{cv};
4189    eval { &$auto };
4190    open(STDOUT,">&REALSTDOUT");
4191    open(STDERR,">&REALSTDERR") unless $DEBUGGING;
4192
4193    unless ($@) {
4194      # we need just the empty auto GV, $cvname->ROOT and $cvname->XSUB,
4195      # but not the whole CV optree. XXX This still fails with 5.8
4196      my $cv = svref_2object( \&{$fullname} );
4197      return $cv;
4198    }
4199  }
4200
4201  # XXX TODO Check Selfloader (test 31?)
4202  svref_2object( \*{$cvstashname.'::AUTOLOAD'} )->save
4203    if $cvstashname and exists ${$cvstashname.'::'}{AUTOLOAD};
4204  svref_2object( \*{$cvstashname.'::CLONE'} )->save
4205    if $cvstashname and exists ${$cvstashname.'::'}{CLONE};
4206}
4207sub Dummy_initxs { }
4208
4209# A lexical sub contains no CvGV, just a NAME_HEK, thus the name CvNAMED.
4210# More problematically $cv->GV vivifies the GV of a NAMED cv from an RV, so avoid !$cv->GV
4211# See https://github.com/perl11/cperl/issues/63
4212sub B::CV::is_named {
4213  my ($cv) = @_;
4214  return 0 unless $PERL518;
4215  return $cv->NAME_HEK if $cv->can('NAME_HEK');
4216  return 0;
4217  # my $gv = $cv->GV;
4218  # return (!$gv or ref($gv) eq 'B::SPECIAL')) ? 1 : 0;
4219}
4220
4221sub is_phase_name {
4222  $_[0] =~ /^(BEGIN|INIT|UNITCHECK|CHECK|END)$/ ? 1 : 0;
4223}
4224
4225sub B::CV::save {
4226  my ($cv, $origname) = @_;
4227  my $sym = objsym($cv);
4228  if ( defined($sym) ) {
4229    warn sprintf( "CV 0x%x already saved as $sym\n", $$cv ) if $$cv and $debug{cv};
4230    return $sym;
4231  }
4232  my $gv = $cv->is_named ? undef : $cv->GV;
4233  my ( $cvname, $cvstashname, $fullname, $isutf8 );
4234  $fullname = '';
4235  my $CvFLAGS = $cv->CvFLAGS;
4236  if (!$gv and $cv->is_named) {
4237    $fullname = $cv->NAME_HEK;
4238    $fullname = '' unless defined $fullname;
4239    $isutf8   = $cv->FLAGS & SVf_UTF8;
4240    warn sprintf( "CV lexsub NAME_HEK $fullname\n") if $debug{cv};
4241    if ($fullname =~ /^(.*)::(.*?)$/) {
4242      $cvstashname = $1;
4243      $cvname      = $2;
4244    }
4245  }
4246  elsif ($gv and $$gv) {
4247    $cvstashname = $gv->STASH->NAME;
4248    $cvname      = $gv->NAME;
4249    $isutf8      = ($gv->FLAGS & SVf_UTF8) || ($gv->STASH->FLAGS & SVf_UTF8);
4250    $fullname    = $cvstashname.'::'.$cvname;
4251    # XXX gv->EGV does not really help here
4252    if ($PERL522 and $cvname eq '__ANON__') {
4253      if ($origname) {
4254        warn sprintf( "CV with empty PVGV %s -> %s\n",
4255                      $fullname, $origname) if $debug{cv};
4256        $cvname = $fullname = $origname;
4257        $cvname =~ s/^\Q$cvstashname\E::(.*)( :pad\[.*)?$/$1/ if $cvstashname;
4258        $cvname =~ s/^.*:://;
4259        if ($cvname =~ m/ :pad\[.*$/) {
4260          $cvname =~ s/ :pad\[.*$//;
4261          $cvname = '__ANON__' if is_phase_name($cvname);
4262          $fullname  = $cvstashname.'::'.$cvname;
4263        }
4264        warn sprintf( "empty -> %s\n", $cvname) if $debug{cv};
4265      } else {
4266        $cvname = $gv->EGV->NAME;
4267        warn sprintf( "CV with empty PVGV %s -> %s::%s\n",
4268                      $fullname, $cvstashname, $cvname) if $debug{cv};
4269        $fullname  = $cvstashname.'::'.$cvname;
4270      }
4271    }
4272    warn sprintf( "CV 0x%x as PVGV 0x%x %s CvFLAGS=0x%x\n",
4273                  $$cv, $$gv, $fullname, $CvFLAGS ) if $debug{cv};
4274    # XXX not needed, we already loaded utf8_heavy
4275    #return if $fullname eq 'utf8::AUTOLOAD';
4276    return '0' if $all_bc_subs{$fullname} or skip_pkg($cvstashname);
4277    $CvFLAGS &= ~0x400 if $PERL514; # no CVf_CVGV_RC otherwise we cannot set the GV
4278    mark_package($cvstashname, 1) unless $include_package{$cvstashname};
4279  }
4280  $cvstashname = '' unless defined $cvstashname;
4281
4282  # XXX TODO need to save the gv stash::AUTOLOAD if exists
4283  my $root    = $cv->ROOT;
4284  my $cvxsub  = $cv->XSUB;
4285  my $isconst;
4286  { no strict 'subs';
4287    $isconst = $PERL56 ? 0 : $CvFLAGS & CVf_CONST;
4288  }
4289
4290  if ( !$isconst && $cvxsub && ( $cvname ne "INIT" ) ) {
4291    my $egv       = $gv->EGV;
4292    my $stashname = $egv->STASH->NAME;
4293    $fullname = $stashname.'::'.$cvname;
4294    if ( $cvname eq "bootstrap" and !$xsub{$stashname} ) {
4295      my $file = $gv->FILE;
4296      $decl->add("/* bootstrap $file */");
4297      warn "Bootstrap $stashname $file\n" if $verbose;
4298      mark_package($stashname);
4299
4300      # Without DynaLoader we must boot and link static
4301      if ( !$Config{usedl} ) {
4302        $xsub{$stashname} = 'Static';
4303      }
4304      # if it not isa('DynaLoader'), it should hopefully be XSLoaded
4305      # ( attributes being an exception, of course )
4306      elsif ( !UNIVERSAL::isa( $stashname, 'DynaLoader' )
4307              and ($stashname ne 'attributes' || $] >= 5.011))
4308      {
4309	my $stashfile = $stashname;
4310        $stashfile =~ s/::/\//g;
4311	if ($file =~ /XSLoader\.pm$/) { # almost always the case
4312	  $file = $INC{$stashfile . ".pm"};
4313	}
4314	unless ($file) { # do the reverse as DynaLoader: soname => pm
4315          my ($laststash) = $stashname =~ /::([^:]+)$/;
4316          $laststash = $stashname unless $laststash;
4317          my $sofile = "auto/" . $stashfile . '/' . $laststash . '\.' . $Config{dlext};
4318	  for (@DynaLoader::dl_shared_objects) {
4319	    if (m{^(.+/)$sofile$}) {
4320	      $file = $1. $stashfile.".pm"; last;
4321	    }
4322	  }
4323	}
4324	$xsub{$stashname} = 'Dynamic-'.$file;
4325        force_saving_xsloader();
4326      }
4327      else {
4328        $xsub{$stashname} = 'Dynamic';
4329        # DynaLoader was for sure loaded, before so we execute the branch which
4330        # does walk_syms and add_hashINC
4331        mark_package('DynaLoader', 1);
4332      }
4333
4334      # INIT is removed from the symbol table, so this call must come
4335      # from PL_initav->save. Re-bootstrapping  will push INIT back in,
4336      # so nullop should be sent.
4337      warn $fullname."\n" if $debug{sub};
4338      return qq/NULL/;
4339    }
4340    else {
4341      # XSUBs for IO::File, IO::Handle, IO::Socket, IO::Seekable and IO::Poll
4342      # are defined in IO.xs, so let's bootstrap it
4343      my @IO = qw(IO::File IO::Handle IO::Socket IO::Seekable IO::Poll);
4344      if (grep { $stashname eq $_ } @IO) {
4345	# mark_package('IO', 1);
4346	# $xsub{IO} = 'Dynamic-'. $INC{'IO.pm'}; # XSLoader (issue59)
4347	svref_2object( \&IO::bootstrap )->save;
4348	mark_package('IO::Handle', 1);
4349	mark_package('SelectSaver', 1);
4350	#for (@IO) { # mark all IO packages
4351	#  mark_package($_, 1);
4352	#}
4353      }
4354    }
4355    warn $fullname."\n" if $debug{sub};
4356    unless ( in_static_core($stashname, $cvname) ) {
4357      no strict 'refs';
4358      warn sprintf( "XSUB $fullname CV 0x%x\n", $$cv )
4359    	if $debug{cv};
4360      svref_2object( \*{"$stashname\::bootstrap"} )->save
4361        if $stashname;# and defined ${"$stashname\::bootstrap"};
4362      # delsym($cv);
4363      return get_cv($fullname, 0);
4364    } else {  # Those cvs are already booted. Reuse their GP.
4365      # Esp. on windows it is impossible to get at the XS function ptr
4366      warn sprintf( "core XSUB $fullname CV 0x%x\n", $$cv ) if $debug{cv};
4367      return get_cv($fullname, 0);
4368    }
4369  }
4370  if ( !$isconst && $cvxsub && $cvname eq "INIT" ) {
4371    no strict 'refs';
4372    warn $fullname."\n" if $debug{sub};
4373    return svref_2object( \&Dummy_initxs )->save;
4374  }
4375
4376  # XXX how is ANON with CONST handled? CONST uses XSUBANY [GH #246]
4377  if ($isconst and $cvxsub and !is_phase_name($cvname) and
4378    (
4379      (
4380       $PERL522
4381       and !( $CvFLAGS & SVs_PADSTALE )
4382       and !( $CvFLAGS & CVf_WEAKOUTSIDE )
4383       and !( $fullname && $fullname =~ qr{^File::Glob::GLOB}
4384              and ( $CvFLAGS & (CVf_ANONCONST|CVf_CONST) )  )
4385      )
4386      or (!$PERL522 and !($CvFLAGS & CVf_ANON)) )
4387    ) # skip const magic blocks (Attribute::Handlers)
4388  {
4389    my $stash = $gv->STASH;
4390    #warn sprintf("$cvstashname\::$cvname 0x%x -> XSUBANY", $CvFLAGS) if $debug{cv};
4391    my $sv    = $cv->XSUBANY;
4392    warn sprintf( "CV CONST 0x%x %s::%s -> 0x%x as %s\n", $$gv, $cvstashname, $cvname,
4393                  $sv, ref $sv) if $debug{cv};
4394    # warn sprintf( "%s::%s\n", $cvstashname, $cvname) if $debug{sub};
4395    my $stsym = $stash->save;
4396    my $name  = cstring($cvname);
4397    if ($] >= 5.016) { # need to check 'Encode::XS' constant encodings
4398      # warn "$sv CONSTSUB $name";
4399      if ((ref($sv) eq 'B::IV' or ref($sv) eq 'B::PVMG') and $sv->FLAGS & SVf_ROK) {
4400        my $rv = $sv->RV;
4401        if ($rv->FLAGS & (SVp_POK|SVf_IOK) and $rv->IVX > LOWEST_IMAGEBASE) {
4402          patch_dlsym($rv, $fullname, $rv->IVX);
4403        }
4404      }
4405    }
4406    # scalarref: t/CORE/v5.22/t/op/const-optree.t at curpad_syms[6]
4407    # main::__ANON__ -> CxPOPSUB_DONE=SCALAR
4408    # TODO Attribute::Handlers #171, test 176
4409    if ($sv and ref($sv) and ref($sv) =~ /^(SCALAR|ARRAY|HASH|CODE|REF)$/) {
4410      # Save XSUBANY, maybe ARRAY or HASH also?
4411      warn "SCALAR const sub $cvstashname\::$cvname -> $sv\n" if $debug{cv};
4412      my $vsym = svref_2object( \$sv )->save;
4413      my $cvi = "cv".$cv_index++;
4414      $decl->add("Static CV* $cvi;");
4415      $init->add("$cvi = newCONSTSUB( $stsym, $name, (SV*)$vsym );");
4416      return savesym( $cv, $cvi );
4417    }
4418    elsif ($sv and ref($sv) =~ /^B::[ANRPI]/) { # use constant => ()
4419      my $vsym  = $sv->save;
4420      my $cvi = "cv".$cv_index++;
4421      $decl->add("Static CV* $cvi;");
4422      $init->add("$cvi = newCONSTSUB( $stsym, $name, (SV*)$vsym );");
4423      return savesym( $cv, $cvi );
4424    } else {
4425      warn "Warning: Undefined const sub $cvstashname\::$cvname -> $sv\n" if $verbose;
4426    }
4427  }
4428
4429  # This define is forwarded to the real sv below
4430  # The new method, which saves a SV only works since 5.10 (? Does not work in newer perls)
4431  my $sv_ix = $svsect->index + 1;
4432  my $xpvcv_ix;
4433  my $new_cv_fw = 0;#$PERL510; # XXX this does not work yet
4434  if ($new_cv_fw) {
4435    $sym = savesym( $cv, "CVIX$sv_ix" );
4436  } else {
4437    $svsect->add("CVIX$sv_ix");
4438    $svsect->debug( "&".$fullname, $cv->flagspv ) if $debug{flags};
4439    $xpvcv_ix = $xpvcvsect->index + 1;
4440    $xpvcvsect->add("XPVCVIX$xpvcv_ix");
4441    # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
4442    $sym = savesym( $cv, "&sv_list[$sv_ix]" );
4443  }
4444
4445  warn sprintf( "saving %s CV 0x%x as %s\n", $fullname, $$cv, $sym )
4446    if $debug{cv};
4447  if (!$$root and $] < 5.010) {
4448    $package_pv = $cvstashname;
4449    push_package($package_pv);
4450  }
4451  if ($fullname eq 'utf8::SWASHNEW') { # bypass utf8::AUTOLOAD, a new 5.13.9 mess
4452    load_utf8_heavy();
4453  }
4454
4455  if ($fullname eq 'IO::Socket::SSL::SSL_Context::new') {
4456    if ($IO::Socket::SSL::VERSION ge '1.956' and $IO::Socket::SSL::VERSION lt '1.995') {
4457      # See https://code.google.com/p/perl-compiler/issues/detail?id=317
4458      # https://rt.cpan.org/Ticket/Display.html?id=95452
4459      warn "Warning: Your IO::Socket::SSL version $IO::Socket::SSL::VERSION is unsupported to create\n".
4460           "  a server. You need to upgrade IO::Socket::SSL to at least 1.995 [CPAN #95452]\n";
4461    }
4462  }
4463
4464  if (!$$root && !$cvxsub) {
4465    my $reloaded;
4466    if ($cvstashname =~ /^(bytes|utf8)$/) { # no autoload, force compile-time
4467      force_heavy($cvstashname);
4468      $cv = svref_2object( \&{$cvstashname."::".$cvname} );
4469      $reloaded = 1;
4470    } elsif ($fullname eq 'Coro::State::_jit') { # 293
4471      # need to force reload the jit src
4472      my ($pl) = grep { m|^Coro/jit-| } keys %INC;
4473      if ($pl) {
4474        delete $INC{$pl};
4475        require $pl;
4476        $cv = svref_2object( \&{$fullname} );
4477        $reloaded = 1;
4478      }
4479    }
4480    if ($reloaded) {
4481      if (!$cv->is_named) {
4482        $gv = $cv->GV;
4483        warn sprintf( "Redefined CV 0x%x as PVGV 0x%x %s CvFLAGS=0x%x\n",
4484                      $$cv, $$gv, $fullname, $CvFLAGS ) if $debug{cv};
4485      } else {
4486        $fullname = $cv->NAME_HEK;
4487        $fullname = '' unless defined $fullname;
4488        if ($fullname =~ /^(.*)::(.*?)$/) {
4489          $cvstashname = $1;
4490          $cvname      = $2;
4491        }
4492        warn sprintf( "Redefined CV 0x%x as NAMED %s CvFLAGS=0x%x\n",
4493                      $$cv, $fullname, $CvFLAGS ) if $debug{cv};
4494      }
4495      $sym = savesym( $cv, $sym );
4496      $root    = $cv->ROOT;
4497      $cvxsub  = $cv->XSUB;
4498    }
4499  }
4500  if ( !$$root && !$cvxsub ) {
4501    if ( my $auto = try_autoload( $cvstashname, $cvname ) ) {
4502      if (ref $auto eq 'B::CV') { # explicit goto or UNIVERSAL
4503        $root   = $auto->ROOT;
4504        $cvxsub = $auto->XSUB;
4505	if ($$auto) {
4506	  # XXX This has now created a wrong GV name!
4507	  my $oldcv = $cv;
4508	  $cv  = $auto ; # This is new. i.e. via AUTOLOAD or UNIVERSAL, in another stash
4509	  my $gvnew = $cv->GV;
4510	  if ($$gvnew) {
4511	    if ($cvstashname ne $gvnew->STASH->NAME or $cvname ne $gvnew->NAME) { # UNIVERSAL or AUTOLOAD
4512	      my $newname = $gvnew->STASH->NAME."::".$gvnew->NAME;
4513	      warn " New $newname autoloaded. remove old cv\n" if $debug{sub}; # and wrong GV?
4514	      unless ($new_cv_fw) {
4515		$svsect->remove;
4516		$xpvcvsect->remove;
4517	      }
4518	      delsym($oldcv);
4519	      return $cv->save($newname) if !$PERL510;
4520
4521	      no strict 'refs';
4522	      my $newsym = svref_2object( \*{$newname} )->save;
4523	      my $cvsym = defined objsym($cv) ? objsym($cv) : $cv->save($newname);
4524	      if (my $oldsym = objsym($gv)) {
4525		warn "Alias polluted $oldsym to $newsym\n" if $debug{gv};
4526		$init->add("$oldsym = $newsym;");
4527		delsym($gv);
4528	      }# else {
4529		#$init->add("GvCV_set(gv_fetchpv(\"$fullname\", GV_ADD, SVt_PV), (CV*)NULL);");
4530	      #}
4531	      return $cvsym;
4532	    }
4533	  }
4534	  $sym = savesym( $cv, "&sv_list[$sv_ix]" ); # GOTO
4535	  warn "$fullname GOTO\n" if $verbose;
4536	}
4537      } else {
4538        # Recalculated root and xsub
4539        $root   = $cv->ROOT;
4540        $cvxsub = $cv->XSUB;
4541	my $gv = $cv->GV;
4542	if ($$gv) {
4543	  if ($cvstashname ne $gv->STASH->NAME or $cvname ne $gv->NAME) { # UNIVERSAL or AUTOLOAD
4544	    my $newname = $gv->STASH->NAME."::".$gv->NAME;
4545	    warn "Recalculated root and xsub $newname. remove old cv\n" if $verbose;
4546	    $svsect->remove;
4547	    $xpvcvsect->remove;
4548	    delsym($cv);
4549	    return $cv->save($newname);
4550	  }
4551	}
4552      }
4553      if ( $$root || $cvxsub ) {
4554        warn "Successful forced autoload\n" if $verbose and $debug{cv};
4555      }
4556    }
4557  }
4558  if (!$$root) {
4559    if ($fullname ne 'threads::tid'
4560        and $fullname ne 'main::main::'
4561        and ($PERL510 and !defined(&{$cvstashname."::AUTOLOAD"})))
4562    {
4563      # XXX What was here?
4564    }
4565    if (exists &$fullname) {
4566      warn "Warning: Empty &".$fullname."\n" if $debug{sub};
4567      $init->add( "/* empty CV $fullname */" ) if $verbose or $debug{sub};
4568    } elsif ($cv->is_named) {
4569      # need to find the attached lexical sub (#130 + #341) at run-time
4570      # in the PadNAMES array. So keep the empty PVCV
4571      warn "lexsub &".$fullname." saved as empty $sym\n" if $debug{sub};
4572    } else {
4573      warn "Warning: &".$fullname." not found\n" if $fullname and $debug{sub};
4574      $init->add( "/* CV $fullname not found */" ) if $verbose or $debug{sub};
4575      # This block broke test 15, disabled
4576      if ($sv_ix == $svsect->index and !$new_cv_fw) { # can delete, is the last SV
4577        warn "No definition for sub $fullname (unable to autoload), skip CV[$sv_ix]\n"
4578          if $debug{cv};
4579        $svsect->remove;
4580        $xpvcvsect->remove;
4581        delsym( $cv );
4582        # Empty CV (methods) must be skipped not to disturb method resolution
4583        # (e.g. t/testm.sh POSIX)
4584        return '0';
4585      } else {
4586        # interim &AUTOLOAD saved, cannot delete. e.g. Fcntl, POSIX
4587        warn "No definition for sub $fullname (unable to autoload), stub CV[$sv_ix]\n"
4588          if $debug{cv} or $verbose;
4589        # continue, must save the 2 symbols from above
4590      }
4591    }
4592  }
4593
4594  my $startfield = 0;
4595  my $padlist    = $cv->PADLIST;
4596  set_curcv $cv;
4597  my $padlistsym = 'NULL';
4598  my $pv         = $cv->PV;
4599  my $xsub       = 0;
4600  my $xsubany    = "{0}";
4601  if ($$root) {
4602    warn sprintf( "saving op tree for CV 0x%x, root=0x%x\n",
4603                  $$cv, $$root )
4604      if $debug{cv} and $debug{gv};
4605    my $ppname = "";
4606    if ($cv->is_named) {
4607      my $name = $cv->can('NAME_HEK') ? $cv->NAME_HEK : "anonlex";
4608      $ppname = "pp_lexsub_".$name;
4609      $fullname = "<lex>".$name;
4610    }
4611    elsif ($gv and $$gv) {
4612      my ($stashname, $gvname);
4613      $stashname = $gv->STASH->NAME;
4614      $gvname    = $gv->NAME;
4615      $fullname = $stashname.'::'.$gvname;
4616      $ppname = ( ${ $gv->FORM } == $$cv ) ? "pp_form_" : "pp_sub_";
4617      if ( $gvname ne "__ANON__" ) {
4618        $ppname .= ( $stashname eq "main" ) ? $gvname : "$stashname\::$gvname";
4619        $ppname =~ s/::/__/g;
4620        $ppname =~ s/(\W)/sprintf("0x%x", ord($1))/ge;
4621        if ( $gvname eq "INIT" ) {
4622          $ppname .= "_$initsub_index";
4623          $initsub_index++;
4624        }
4625      }
4626    }
4627    if ( !$ppname ) {
4628      $ppname = "pp_anonsub_$anonsub_index";
4629      $anonsub_index++;
4630    }
4631    $startfield = saveoptree( $ppname, $root, $cv->START, $padlist->ARRAY ); # XXX padlist is ignored
4632    #warn sprintf( "done saving op tree for CV 0x%x, flags (%s), name %s, root=0x%x => start=%s\n",
4633    #  $$cv, $debug{flags}?$cv->flagspv:sprintf("0x%x",$cv->FLAGS), $ppname, $$root, $startfield )
4634    #  if $debug{cv};
4635    # XXX missing cv_start for AUTOLOAD on 5.8
4636    $startfield = objsym($root->next) unless $startfield; # 5.8 autoload has only root
4637    $startfield = "0" unless $startfield; # XXX either CONST ANON or empty body
4638    if ($$padlist) {
4639      # XXX readonly comppad names and symbols invalid
4640      #local $B::C::pv_copy_on_grow = 1 if $B::C::ro_inc;
4641      warn sprintf( "saving PADLIST 0x%x for CV 0x%x\n", $$padlist, $$cv )
4642        if $debug{cv} and $debug{gv};
4643      # XXX avlen 2
4644      $padlistsym = $padlist->save($fullname.' :pad', $cv);
4645      warn sprintf( "done saving %s 0x%x for CV 0x%x\n",
4646		    $padlistsym, $$padlist, $$cv )
4647        if $debug{cv} and $debug{gv};
4648      # do not record a forward for the pad only
4649
4650      # issue 298: dynamic CvPADLIST(&END) since 5.18 - END{} blocks
4651      # and #169 and #304 Attribute::Handlers
4652      if ($] > 5.017 and
4653          ($B::C::dyn_padlist or $fullname =~ /^(main::END|main::INIT|Attribute::Handlers)/))
4654      {
4655        $init->add("{ /* &$fullname needs a dynamic padlist */",
4656                   "  PADLIST *pad;",
4657                   "  Newxz(pad, sizeof(PADLIST), PADLIST);",
4658                   "  Copy($padlistsym, pad, sizeof(PADLIST), char);",
4659                   "  CvPADLIST($sym) = pad;",
4660                   "}");
4661      } else {
4662        $init->add( "CvPADLIST($sym) = $padlistsym;" );
4663      }
4664    }
4665    warn $fullname."\n" if $debug{sub};
4666  }
4667  elsif ($cv->is_named) {
4668    ;
4669  }
4670  elsif (!exists &$fullname) {
4671    warn $fullname." not found\n" if $debug{sub};
4672    warn "No definition for sub $fullname (unable to autoload)\n"
4673      if $debug{cv};
4674    $init->add( "/* $fullname not found */" ) if $verbose or $debug{sub};
4675    # XXX empty CV should not be saved. #159, #235
4676    # $svsect->remove( $sv_ix );
4677    # $xpvcvsect->remove( $xpvcv_ix );
4678    # delsym( $cv );
4679    if (!$new_cv_fw) {
4680      $symsect->add("XPVCVIX$xpvcv_ix\t0");
4681    }
4682    $CvFLAGS &= ~0x1000 if $PERL514; # CVf_DYNFILE
4683    $CvFLAGS &= ~0x400 if $gv and $$gv and $PERL514; #CVf_CVGV_RC
4684    $symsect->add(sprintf(
4685      "CVIX%d\t(XPVCV*)&xpvcv_list[%u], $u32fmt, 0x%x".($PERL510?", {0}":''),
4686      $sv_ix, $xpvcv_ix, $cv->REFCNT, $CvFLAGS));
4687    return get_cv($fullname, 0);
4688  }
4689
4690  # Now it is time to record the CV
4691  if ($new_cv_fw) {
4692    $sv_ix = $svsect->index + 1;
4693    if (!$cvforward{$sym}) { # avoid duplicates
4694      $symsect->add(sprintf("%s\t&sv_list[%d]", $sym, $sv_ix )); # forward the old CVIX to the new CV
4695      $cvforward{$sym}++;
4696    }
4697    $sym = savesym( $cv, "&sv_list[$sv_ix]" );
4698  }
4699
4700  # $pv = '' unless defined $pv;    # Avoid use of undef warnings
4701  #warn sprintf( "CV prototype %s for CV 0x%x\n", cstring($pv), $$cv )
4702  #  if $pv and $debug{cv};
4703  my $proto = defined $pv ? cstring($pv) : 'NULL';
4704  my $pvsym = 'NULL';
4705  my $cur = defined $pv ? $cv->CUR : 0;
4706  my $len = $cur + 1;
4707  $len++ if IsCOW($cv) and !$B::C::cow;
4708  $len = 0 if $B::C::const_strings;
4709  # need to survive cv_undef as there is no protection against static CVs
4710  my $refcnt = $cv->REFCNT + ($PERL510 ? 1 : 0);
4711  # GV cannot be initialized statically
4712  my $xcv_outside = ${ $cv->OUTSIDE };
4713  if ($xcv_outside == ${ main_cv() }) {
4714    # Provide a temp. debugging hack for CvOUTSIDE. The address of the symbol &PL_main_cv
4715    # is known to the linker, the address of the value PL_main_cv not. This is set later
4716    # (below) at run-time.
4717    $xcv_outside = $MULTI ? '0' : '&PL_main_cv';
4718  } elsif (ref($cv->OUTSIDE) eq 'B::CV') {
4719    $xcv_outside = 0; # just a placeholder for a run-time GV
4720  }
4721  if ($PERL510) {
4722    $pvsym = save_hek($pv,$fullname,1);
4723    # XXX issue 84: we need to check the cv->PV ptr not the value.
4724    # "" is different to NULL for prototypes
4725    $len = $cur ? $cur+1 : 0;
4726    # TODO:
4727    # my $ourstash = "0";  # TODO stash name to bless it (test 16: "main::")
4728    if ($PERL522) {
4729      $CvFLAGS &= ~0x1000; # CVf_DYNFILE off
4730      $CvFLAGS |= 0x200000 if $CPERL52; # CVf_STATIC on
4731      my $xpvc = sprintf
4732	# stash magic cur {len} cvstash {start} {root} {cvgv} cvfile {cvpadlist}     outside outside_seq cvflags cvdepth
4733	("Nullhv, {0}, %u, {%u}, %s, {%s}, {s\\_%x}, {%s}, %s, {%s}, (CV*)%s, %s, 0x%x, %d",
4734	 $cur, $len, "Nullhv",#CvSTASH later
4735	 $startfield, $$root,
4736	 "0",    #GV later
4737	 "NULL", #cvfile later (now a HEK)
4738	 $padlistsym,
4739	 $xcv_outside, #if main_cv set later
4740	 ivx($cv->OUTSIDE_SEQ),
4741	 $CvFLAGS,
4742	 $cv->DEPTH);
4743      # repro only with 5.15.* threaded -q (70c0620) Encode::Alias::define_alias
4744      warn "lexwarnsym in XPVCV OUTSIDE: $xpvc" if $xpvc =~ /, \(CV\*\)iv\d/; # t/testc.sh -q -O3 227
4745      if (!$new_cv_fw) {
4746	$symsect->add("XPVCVIX$xpvcv_ix\t$xpvc");
4747	#$symsect->add
4748	#  (sprintf("CVIX%d\t(XPVCV*)&xpvcv_list[%u], $u32fmt, 0x%x, {0}"),
4749	#	   $sv_ix, $xpvcv_ix, $cv->REFCNT, $cv->FLAGS
4750	#	  ));
4751      } else {
4752	$xpvcvsect->comment('STASH mg_u cur len CV_STASH START_U ROOT_U GV file PADLIST OUTSIDE outside_seq flags depth');
4753	$xpvcvsect->add($xpvc);
4754	$svsect->add(sprintf("&xpvcv_list[%d], $u32fmt, 0x%x, {%s}",
4755			     $xpvcvsect->index, $cv->REFCNT, $cv->FLAGS,
4756                             $CPERL52 ? $proto : "0"));
4757	$svsect->debug( $fullname, $cv->flagspv ) if $debug{flags};
4758      }
4759    } elsif ($PERL514) {
4760      # cv_undef wants to free it when CvDYNFILE(cv) is true.
4761      # E.g. DateTime: boot_POSIX. newXS reuses cv if autoloaded. So turn it off globally.
4762      $CvFLAGS &= ~0x1000; # CVf_DYNFILE off
4763      my $xpvc = sprintf
4764	# stash magic cur len cvstash start root cvgv cvfile cvpadlist     outside outside_seq cvflags cvdepth
4765	("Nullhv, {0}, %u, %u, %s, {%s}, {s\\_%x}, %s, %s, %s, (CV*)%s, %s, 0x%x, %d",
4766	 $cur, $len, "Nullhv",#CvSTASH later
4767	 $startfield, $$root,
4768	 "0",    #GV later
4769	 "NULL", #cvfile later (now a HEK)
4770	 $padlistsym,
4771	 $xcv_outside, #if main_cv set later
4772	 ivx($cv->OUTSIDE_SEQ),
4773	 $CvFLAGS,
4774	 $cv->DEPTH);
4775      #warn "lexwarnsym in XPVCV OUTSIDE: $xpvc" if $xpvc =~ /, \(CV\*\)iv\d/; # t/testc.sh -q -O3 227
4776      if (!$new_cv_fw) {
4777	$symsect->add("XPVCVIX$xpvcv_ix\t$xpvc");
4778	#$symsect->add
4779	#  (sprintf("CVIX%d\t(XPVCV*)&xpvcv_list[%u], $u32fmt, 0x%x, {0}"),
4780	#	   $sv_ix, $xpvcv_ix, $cv->REFCNT, $cv->FLAGS
4781	#	  ));
4782      } else {
4783	$xpvcvsect->comment('STASH mg_u cur len CV_STASH START_U ROOT_U GV file PADLIST OUTSIDE outside_seq flags depth');
4784	$xpvcvsect->add($xpvc);
4785	$svsect->add(sprintf("&xpvcv_list[%d], $u32fmt, 0x%x, {0}",
4786			     $xpvcvsect->index, $cv->REFCNT, $cv->FLAGS));
4787	$svsect->debug( $fullname, $cv->flagspv ) if $debug{flags};
4788      }
4789    } else { # 5.10-5.13
4790      # Note: GvFORM ends also here. #149 (B::FM), t/testc.sh -O3 -DGCF,-v 149
4791      my $depth = ref($cv) eq 'B::CV' ? $cv->DEPTH : 0;
4792      my $outside_seq = ref($cv) eq 'B::CV' ? $cv->OUTSIDE_SEQ : '0'; # XXX? #238
4793      my $xpvc = sprintf
4794	("{%d}, %u, %u, {%s}, {%s}, %s,"
4795	 ." %s, {%s}, {s\\_%x}, %s, %s, %s,"
4796	 ." (CV*)%s, %s, 0x%x",
4797	 0, # GvSTASH later. test 29 or Test::Harness
4798	 $cur, $len,
4799	 $depth,
4800	 "NULL", "Nullhv", #MAGIC + STASH later
4801	 "Nullhv",#CvSTASH later
4802	 $startfield,
4803	 $$root,
4804	 "0",    #GV later
4805	 "NULL", #cv_file later (now a HEK)
4806	 $padlistsym,
4807	 $xcv_outside, #if main_cv set later
4808	 $outside_seq,
4809	 $CvFLAGS
4810	);
4811      if (!$new_cv_fw) {
4812	$symsect->add("XPVCVIX$xpvcv_ix\t$xpvc");
4813	#$symsect->add
4814	#  (sprintf("CVIX%d\t(XPVCV*)&xpvcv_list[%u], $u32fmt, 0x%x, {0}",
4815	#	   $sv_ix, $xpvcv_ix, $cv->REFCNT, $cv->FLAGS
4816	#	  ));
4817      } else {
4818	$xpvcvsect->comment('GvSTASH cur len  depth mg_u MG_STASH CV_STASH START_U ROOT_U CV_GV cv_file PADLIST OUTSIDE outside_seq cv_flags');
4819	$xpvcvsect->add($xpvc);
4820	$svsect->add(sprintf("&xpvcv_list[%d], $u32fmt, 0x%x, {0}",
4821			     $xpvcvsect->index, $cv->REFCNT, $cv->FLAGS));
4822        $svsect->debug( $fullname, $cv->flagspv ) if $debug{flags};
4823      }
4824    }
4825    if ($$cv) {
4826      if ($PERL518 and (!$gv or ref($gv) eq 'B::SPECIAL')) {
4827        my $lexsub  = $cv->can('NAME_HEK') ? $cv->NAME_HEK : "_anonlex_";
4828        $lexsub = '' unless defined $lexsub;
4829        warn "lexsub name $lexsub" if $debug{gv};
4830        my ($cstring, $cur, $utf8) = strlen_flags($lexsub);
4831        if (!$PERL56 and $utf8) {
4832          $cur = -$cur;
4833        }
4834        $init->add( "{ /* need a dynamic name hek */",
4835                    sprintf("  HEK *lexhek = share_hek(savepvn(%s, %d), %d);",
4836                            $cstring, abs($cur), $cur),
4837                    sprintf("  CvNAME_HEK_set(s\\_%x, lexhek);", $$cv),
4838                    "}");
4839      } else {
4840        my $gvstash = $gv->STASH;
4841        # defer GvSTASH because with DEBUGGING it checks for GP but
4842        # there's no GP yet.
4843        # But with -fstash the gvstash is set later
4844        $init->add( sprintf( "GvXPVGV(s\\_%x)->xnv_u.xgv_stash = s\\_%x;",
4845                             $$cv, $$gvstash ) ) if $gvstash and !$B::C::stash;
4846        warn sprintf( "done saving GvSTASH 0x%x for CV 0x%x\n", $$gvstash, $$cv )
4847          if $gvstash and $debug{cv} and $debug{gv};
4848      }
4849    }
4850    if ( $cv->OUTSIDE_SEQ ) {
4851      my $cop = $symtable{ sprintf( "s\\_%x", $cv->OUTSIDE_SEQ ) };
4852      $init->add( sprintf( "CvOUTSIDE_SEQ(%s) = %s;", $sym, $cop ) ) if $cop;
4853    }
4854  }
4855  elsif ($PERL56) {
4856    my $xpvc = sprintf("%s, %u, %u, %s, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, "
4857		       ."$xsubany, Nullgv, \"\", %d, s\\_%x, (CV*)%s, 0x%x",
4858	       $proto, $cur, $len, ivx($cv->IVX),
4859	       nvx($cv->NVX),  $startfield,       $$root, $cv->DEPTH,
4860	       $$padlist, $xcv_outside, $cv->CvFLAGS
4861	      );
4862    if ($new_cv_fw) {
4863      $xpvcvsect->comment('pv cur len off nv magic mg_stash cv_stash start root xsub '
4864                          .'xsubany cv_gv cv_file cv_depth cv_padlist cv_outside cv_flags');
4865      $xpvcvsect->add($xpvc);
4866      $svsect->add(sprintf("&xpvcv_list[%d], $u32fmt, 0x%x"),
4867		   $xpvcvsect->index, $cv->REFCNT, $cv->FLAGS);
4868      $svsect->debug( $fullname, $cv->flagspv ) if $debug{flags};
4869    } else {
4870      $symsect->add("XPVCVIX$xpvcv_ix\t$xpvc");
4871    }
4872  }
4873  else { #5.8
4874    my $xpvc = sprintf("%s, %u, %u, %s, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub,"
4875		       ." $xsubany, Nullgv, \"\", %d, s\\_%x, (CV*)s\\_%x, 0x%x, 0x%x",
4876	       $proto, $cur, $len, ivx($cv->IVX),
4877	       nvx($cv->NVX),  $startfield,       $$root, $cv->DEPTH,
4878	       $$padlist, $xcv_outside, $cv->CvFLAGS, $cv->OUTSIDE_SEQ
4879	      );
4880    if ($new_cv_fw) {
4881      $xpvcvsect->comment('pv cur len off nv           magic mg_stash cv_stash '
4882                         .'start root xsub xsubany cv_gv cv_file cv_depth cv_padlist '
4883                         .'cv_outside cv_flags outside_seq');
4884      $xpvcvsect->add($xpvc);
4885      $svsect->add(sprintf("&xpvcv_list[%d], $u32fmt, 0x%x"),
4886		   $xpvcvsect->index, $cv->REFCNT, $cv->FLAGS);
4887      $svsect->debug( $fullname, $cv->flagspv ) if $debug{flags};
4888    } else {
4889      $symsect->add("XPVCVIX$xpvcv_ix\t$xpvc");
4890    }
4891  }
4892
4893  if ($CPERL52 and $Config{uselongdouble}) {
4894    # some very odd static struct init bug: CvOUTSIDE is pointing to CvROOT, CvROOT is corrupt.
4895    # CvPADLIST also pointing somewhere else. with gcc-5 and 4.8.
4896    $init->add(sprintf("xpvcv_list[$xpvcv_ix].xcv_root_u.xcv_root = s\\_%x;", $$root));
4897    $init->add("xpvcv_list[$xpvcv_ix].xcv_padlist_u.xcv_padlist = $padlistsym;");
4898  }
4899
4900  $xcv_outside = ${ $cv->OUTSIDE };
4901  if ($xcv_outside == ${ main_cv() } or ref($cv->OUTSIDE) eq 'B::CV') {
4902    # patch CvOUTSIDE at run-time
4903    if ( $xcv_outside == ${ main_cv() } ) {
4904      $init->add( "CvOUTSIDE($sym) = PL_main_cv;",
4905                  "SvREFCNT_inc(PL_main_cv);" );
4906      if ($$padlist) {
4907        if ($PERL522) {
4908          $init->add( "CvPADLIST($sym)->xpadl_outid = CvPADLIST(PL_main_cv)->xpadl_id;");
4909        } elsif ($] >= 5.017005) {
4910          $init->add( "CvPADLIST($sym)->xpadl_outid = PadlistNAMES(CvPADLIST(PL_main_cv));");
4911        }
4912      }
4913    } else {
4914      $init->add( sprintf("CvOUTSIDE(%s) = (CV*)s\\_%x;", $sym, $xcv_outside) );
4915      #if ($PERL522) {
4916      #  $init->add( sprintf("CvPADLIST(%s)->xpadl_outid = CvPADLIST(s\\_%x)->xpadl_id;",
4917      #                      $sym, $xcv_outside));
4918      #}
4919    }
4920  }
4921  elsif ($] >= 5.017005 and $xcv_outside and $$padlist) {
4922    my $padl = $cv->OUTSIDE->PADLIST->save;
4923    if ($PERL522) {
4924      $init->add( sprintf("CvPADLIST(%s)->xpadl_outid = CvPADLIST(s\\_%x)->xpadl_id;",
4925                          $sym, $xcv_outside));
4926    } else {
4927      # Make sure that the outer padlist is allocated before PadlistNAMES is accessed.
4928      # This needs to be postponed (test 227)
4929      $init1->add( sprintf( "CvPADLIST(%s)->xpadl_outid = PadlistNAMES(%s);", $sym, $padl) );
4930    }
4931  }
4932  if ($gv and $$gv) {
4933    #test 16: Can't call method "FETCH" on unblessed reference. gdb > b S_method_common
4934    warn sprintf( "Saving GV 0x%x for CV 0x%x\n", $$gv, $$cv ) if $debug{cv} and $debug{gv};
4935    $gv->save;
4936    if ($PERL514) { # FIXME 5.18.0 with lexsubs
4937      # XXX gvcv might be PVMG
4938      $init->add( sprintf( "CvGV_set((CV*)%s, (GV*)%s);", $sym, objsym($gv)) );
4939      # Since 5.13.3 and CvGV_set there are checks that the CV is not RC (refcounted).
4940      # Assertion "!CvCVGV_RC(cv)" failed: file "gv.c", line 219, function: Perl_cvgv_set
4941      # We init with CvFLAGS = 0 and set it later, as successfully done in the Bytecode compiler
4942      if ($CvFLAGS & 0x0400) { # CVf_CVGV_RC
4943        warn sprintf( "CvCVGV_RC turned off. CV flags=0x%x %s CvFLAGS=0x%x \n",
4944                      $cv->FLAGS, $debug{flags}?$cv->flagspv:"", $CvFLAGS & ~0x400)
4945          if $debug{cv};
4946        $init->add( sprintf( "CvFLAGS((CV*)%s) = 0x%x; %s", $sym, $CvFLAGS,
4947                             $debug{flags}?"/* ".$cv->flagspv." */":"" ) );
4948      }
4949      $init->add("CvSTART($sym) = $startfield;"); # XXX TODO someone is overwriting CvSTART also
4950    } else {
4951      $init->add( sprintf( "CvGV(%s) = %s;", $sym, objsym($gv) ) );
4952    }
4953    warn sprintf("done saving GV 0x%x for CV 0x%x\n",
4954		 $$gv, $$cv) if $debug{cv} and $debug{gv};
4955  }
4956  unless ($optimize_cop) {
4957    my $file = $cv->FILE();
4958    if ($MULTI) {
4959      $init->add( savepvn( "CvFILE($sym)", $file ) );
4960    } elsif ($B::C::const_strings && length $file) {
4961      $init->add( sprintf( "CvFILE(%s) = (char *) %s;", $sym, constpv( $file ) ) );
4962    } else {
4963      $init->add( sprintf( "CvFILE(%s) = %s;", $sym, cstring( $file ) ) );
4964    }
4965  }
4966  my $stash = $cv->STASH;
4967  if ($$stash and ref($stash)) {
4968    # $init->add("/* saving STASH $fullname */\n" if $debug{cv};
4969    $stash->save($fullname);
4970    # $sym fixed test 27
4971    $init->add( sprintf( "CvSTASH_set((CV*)%s, s\\_%x);", $sym, $$stash ) );
4972    # 5.18 bless does not inc sv_objcount anymore. broken by ddf23d4a1ae (#208)
4973    # We workaround this 5.18 de-optimization by adding it if at least a DESTROY
4974    # method exists.
4975    $init->add("++PL_sv_objcount;") if $cvname eq 'DESTROY' and $] >= 5.017011;
4976    warn sprintf( "done saving STASH 0x%x for CV 0x%x\n", $$stash, $$cv )
4977      if $debug{cv} and $debug{gv};
4978  }
4979  my $magic = $cv->MAGIC;
4980  if ($magic and $$magic) {
4981    $cv->save_magic($fullname); # XXX will this work?
4982  }
4983  if (!$new_cv_fw) {
4984    $symsect->add(sprintf(
4985      "CVIX%d\t(XPVCV*)&xpvcv_list[%u], $u32fmt, 0x%x".($PERL510?", {0}":''),
4986      $sv_ix, $xpvcv_ix, $cv->REFCNT, $cv->FLAGS
4987      )
4988    );
4989  }
4990  if ($cur) {
4991    warn sprintf( "Saving CV proto %s for CV $sym 0x%x\n", cstring($pv), $$cv ) if $debug{cv};
4992  }
4993  # issue 84: empty prototypes sub xx(){} vs sub xx{}
4994  if (defined $pv) {
4995    if ($PERL510 and $cur) {
4996      $init->add( sprintf("SvPVX(&sv_list[%d]) = HEK_KEY(%s);", $sv_ix, $pvsym));
4997    } elsif (!$B::C::const_strings) { # not static, they are freed when redefined
4998      $init->add( sprintf("SvPVX(&sv_list[%d]) = savepvn(%s, %u);",
4999                          $sv_ix, $proto, $cur));
5000    } else {
5001      $init->add( sprintf("SvPVX(&sv_list[%d]) = %s;",
5002                          $sv_ix, $proto));
5003    }
5004  }
5005  $cv->OUTSIDE->save if $xcv_outside;
5006  return $sym;
5007}
5008
5009package B::C;
5010my @_v = Internals::V() if $] >= 5.011;
5011sub __ANON__::_V { @_v };
5012
5013sub B::GV::save {
5014  my ($gv, $filter) = @_;
5015  my $sym = objsym($gv);
5016  if ( defined($sym) ) {
5017    warn sprintf( "GV 0x%x already saved as $sym\n", $$gv ) if $debug{gv};
5018    return $sym;
5019  }
5020  else {
5021    my $ix = $gv_index++;
5022    $sym = savesym( $gv, "gv_list[$ix]" );
5023    warn sprintf( "Saving GV 0x%x as $sym\n", $$gv ) if $debug{gv};
5024  }
5025  warn sprintf( "  GV *%s $sym type=%d, flags=0x%x %s\n", $gv->NAME,
5026                # B::SV::SvTYPE not with 5.6
5027                B::SV::SvTYPE($gv), $gv->FLAGS) if $debug{gv} and !$PERL56;
5028  if ($PERL510 and !$PERL5257 and $gv->FLAGS & 0x40000000) { # SVpbm_VALID
5029    warn sprintf( "  GV $sym isa FBM\n") if $debug{gv};
5030    return B::BM::save($gv);
5031  }
5032  # since 5.25.7 VALID is just a B magic at a gv->SV->PVMG. See below.
5033
5034  my $gvname   = $gv->NAME;
5035  my $package;
5036  if (ref($gv->STASH) eq 'B::SPECIAL') {
5037    $package = '__ANON__';
5038    warn sprintf( "GV STASH = SPECIAL $gvname\n") if $debug{gv};
5039  } else {
5040    $package = $gv->STASH->NAME;
5041  }
5042  return q/(SV*)&PL_sv_undef/ if skip_pkg($package);
5043
5044  my $fullname = $package . "::" . $gvname;
5045  my $fancyname;
5046  sub Save_HV()   { 1 }
5047  sub Save_AV()   { 2 }
5048  sub Save_SV()   { 4 }
5049  sub Save_CV()   { 8 }
5050  sub Save_FORM() { 16 }
5051  sub Save_IO()   { 32 }
5052  sub Save_ALL()  { 63 }
5053  if ( $filter and $filter =~ m/ :pad/ ) {
5054    $fancyname = cstring($filter);
5055    $filter = 0;
5056  } else {
5057    $fancyname = cstring($fullname);
5058  }
5059  # checked for defined'ness in Carp. So the GV must exist, the CV not
5060  if ($fullname =~ /^threads::(tid|AUTOLOAD)$/ and !$ITHREADS) {
5061    $filter = Save_CV;
5062  }
5063  # no need to assign any SV/AV/HV to them (172)
5064  if ($PERL518 and $fullname =~ /^DynaLoader::dl_(
5065                                   require_symbols|
5066                                   modules|
5067                                   shared_objects|
5068                                   resolve_using|
5069                                   librefs)/x)
5070  {
5071    $filter = Save_SV + Save_AV + Save_HV;
5072  }
5073  # skip static %Encode::Encoding since 5.20. GH #200.
5074  # Let it be initialized by boot_Encode/Encode_XSEncoding
5075  #if ($] >= 5.020 and $fullname eq 'Encode::Encoding') {
5076  #  warn "skip %Encode::Encoding - XS initialized\n" if $debug{gv};
5077  #  $filter = Save_HV;
5078  #}
5079
5080  my $is_empty = $gv->is_empty;
5081  if (!defined $gvname and $is_empty) { # 5.8 curpad name
5082    return q/(SV*)&PL_sv_undef/;
5083  }
5084  my $name    = $package eq 'main' ? $gvname : $fullname;
5085  my $cname   = cstring($name);
5086  my $notqual = ($] >= 5.008009 and $package eq 'main') ? 'GV_NOTQUAL' : '0';
5087  warn "  GV name is $fancyname\n" if $debug{gv};
5088  my $egvsym;
5089  my $is_special = ref($gv) eq 'B::SPECIAL';
5090
5091  # If we come across a stash, we therefore have code using this symbol.
5092  # But this does not mean that we need to save the package then.
5093  # if (defined %Exporter::) should not import Exporter, it should return undef.
5094  #if ( $gvname =~ m/::$/ ) {
5095  #  my $package = $gvname;
5096  #  $package =~ s/::$//;
5097  #  mark_package($package); #wrong
5098  #}
5099  if ($fullname =~ /^(bytes|utf8)::AUTOLOAD$/) {
5100    $gv = force_heavy($package); # defer to run-time autoload, or compile it in?
5101    $sym = savesym( $gv, $sym ); # override new gv ptr to sym
5102  }
5103  if ( !$is_empty ) {
5104    my $egv = $gv->EGV;
5105    unless (ref($egv) eq 'B::SPECIAL' or ref($egv->STASH) eq 'B::SPECIAL') {
5106      my $estash = $egv->STASH->NAME;
5107      if ( $$gv != $$egv ) {
5108        warn(sprintf( "EGV name is %s, saving it now\n",
5109                      $estash . "::" . $egv->NAME )
5110            ) if $debug{gv};
5111        $egvsym = $egv->save;
5112      }
5113    }
5114  }
5115  #if ($fullname eq 'threads::tid' and !$ITHREADS) { # checked for defined'ness in Carp
5116  #  $init->add(qq[$sym = (GV*)&PL_sv_undef;]);
5117  #  return $sym;
5118  #}
5119  if ($fullname =~ /^main::STDOUT$/i and $PERL56) {
5120    return 'Nullgv'; # perl.c: setdefout(Nullgv)
5121  }
5122  my $core_syms = {ENV    => 'PL_envgv',
5123                   ARGV   => 'PL_argvgv',
5124                   INC    => 'PL_incgv',
5125                   STDIN  => 'PL_stdingv',
5126                   STDERR => 'PL_stderrgv',
5127                   "\010" => 'PL_hintgv',  # ^H
5128                   "_"    => 'PL_defgv',
5129                   "@"    => 'PL_errgv',
5130                   "\022" => 'PL_replgv',  # ^R
5131                  };
5132  my $is_coresym;
5133  # those are already initialized in init_predump_symbols()
5134  # and init_main_stash()
5135  for my $s (sort keys %$core_syms) {
5136    if ($fullname eq 'main::'.$s) {
5137      $sym = savesym( $gv, $core_syms->{$s} );
5138      # $init->add( sprintf( "SvREFCNT($sym) = $u32fmt;", $gv->REFCNT ) );
5139      # return $sym;
5140      $is_coresym++;
5141    }
5142  }
5143  if ($fullname =~ /^main::std(in|out|err)$/) { # same as uppercase above
5144    $init->add(qq[$sym = gv_fetchpv($cname, $notqual, SVt_PVGV);]);
5145    $init->add( sprintf( "SvREFCNT(%s) = $u32fmt;", $sym, $gv->REFCNT ) );
5146    return $sym;
5147  }
5148  elsif ($fullname eq 'main::0') { # dollar_0 already handled before, so don't overwrite it
5149    # only the $0 part, not @0 &0 ...
5150    #$init->add(qq[$sym = gv_fetchpv($cname, $notqual, SVt_PV);]);
5151    #$init->add( sprintf( "SvREFCNT(%s) = $u32fmt;", $sym, $gv->REFCNT ) );
5152    $filter = Save_SV;
5153    #return $sym;
5154  }
5155  elsif ($B::C::ro_inc and $fullname =~ /^main::([0-9])$/) { # ignore PV regexp captures with -O2
5156    $filter = Save_SV;
5157  }
5158  # gv_fetchpv loads Errno resp. Tie::Hash::NamedCapture, but needs *INC #90
5159  #elsif ( $fullname eq 'main::!' or $fullname eq 'main::+' or $fullname eq 'main::-') {
5160  #  $init1->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PVGV);]); # defer until INC is setup
5161  #  $init1->add( sprintf( "SvREFCNT(%s) = $u32fmt;", $sym, $gv->REFCNT ) );
5162  #  return $sym;
5163  #}
5164  my $svflags    = $gv->FLAGS;
5165  my $savefields = 0;
5166
5167  my $gp;
5168  my $gvadd = $notqual ? "$notqual|GV_ADD" : "GV_ADD";
5169  if ( $PERL510 and $gv->isGV_with_GP and !$is_coresym) {
5170    $gp = $gv->GP;    # B limitation
5171    # warn "XXX EGV='$egvsym' for IMPORTED_HV" if $gv->GvFLAGS & 0x40;
5172    if ( defined($egvsym) && $egvsym !~ m/Null/ ) {
5173      warn(sprintf("Shared GV alias for *$fullname 0x%x%s %s to $egvsym\n",
5174                   $svflags, $debug{flags} ? "(".$gv->flagspv.")" : "",
5175                  )) if $debug{gv};
5176      # Shared glob *foo = *bar
5177      $init->add("$sym = ".gv_fetchpvn($package eq 'main' ? $gvname : $fullname,
5178                                       "$gvadd|GV_ADDMULTI", "SVt_PVGV").";");
5179      $init->add( "GvGP_set($sym, GvGP($egvsym));" );
5180      $is_empty = 1;
5181    }
5182    elsif ( $gp and exists $gptable{0+$gp} ) {
5183      warn(sprintf("Shared GvGP for *$fullname 0x%x%s %s GP:0x%x\n",
5184                   $svflags, $debug{flags} ? "(".$gv->flagspv.")" : "",
5185                   $gv->FILE, $gp
5186                  )) if $debug{gv};
5187      $init->add("$sym = ".gv_fetchpvn($name, $notqual, "SVt_PVGV").";");
5188      $init->add( sprintf("GvGP_set(%s, %s);", $sym, $gptable{0+$gp}) );
5189      $is_empty = 1;
5190    }
5191    elsif ( $gp and !$is_empty and $gvname =~ /::$/) {
5192      warn(sprintf("Shared GvGP for stash %$fullname 0x%x%s %s GP:0x%x\n",
5193                   $svflags, $debug{flags} ? "(".$gv->flagspv.")" : "",
5194                   $gv->FILE, $gp
5195                  )) if $debug{gv};
5196      $init->add("$sym = ".gv_fetchpvn($name, "GV_ADD", "SVt_PVHV").";");
5197      $gptable{0+$gp} = "GvGP($sym)" if 0+$gp;
5198    }
5199    elsif ( $gp and !$is_empty ) {
5200      warn(sprintf("New GV for *$fullname 0x%x%s %s GP:0x%x\n",
5201                   $svflags, $debug{flags} ? "(".$gv->flagspv.")" : "",
5202                   $gv->FILE, $gp
5203                  )) if $debug{gv};
5204      # XXX !PERL510 and OPf_COP_TEMP we need to fake PL_curcop for gp_file hackery
5205      $init->add("$sym = ".gv_fetchpvn($name, $gvadd, "SVt_PV").";");
5206      $savefields = Save_ALL;
5207      $gptable{0+$gp} = "GvGP($sym)";
5208    }
5209    else {
5210      $init->add("$sym = ".gv_fetchpvn($name, $gvadd, "SVt_PVGV").";");
5211    }
5212  } elsif (!$is_coresym) {
5213    $init->add("$sym = ".gv_fetchpvn($name, $gvadd, "SVt_PV").";");
5214  }
5215  my $gvflags = $gv->GvFLAGS;
5216  if ($gvflags > 256 and !$PERL510) { # $gv->GvFLAGS as U8 single byte only
5217    $gvflags = $gvflags & 255;
5218  }
5219  $init->add( sprintf( "SvFLAGS(%s) = 0x%x;%s", $sym, $svflags,
5220                     $debug{flags}?" /* ".$gv->flagspv." */":"" ),
5221	           sprintf( "GvFLAGS(%s) = 0x%x; %s", $sym, $gvflags,
5222                     $debug{flags}?"/* ".$gv->flagspv(SVt_PVGV)." */":"" ));
5223  $init->add( sprintf( "GvLINE(%s) = %d;", $sym,
5224		       ($gv->LINE > 2147483647  # S32 INT_MAX
5225			? 4294967294 - $gv->LINE
5226			: $gv->LINE )))
5227	      unless $is_empty;
5228
5229  # XXX hack for when Perl accesses PVX of GVs, only if SvPOK
5230  #if (!($svflags && 0x400)) { # defer to run-time (0x400 -> SvPOK) for convenience
5231  # XXX also empty "main::" destruction accesses a PVX, so do not check if_empty
5232  if ( !$PERL510 ) {
5233    $init->add("if (SvPOK($sym) && !SvPVX($sym)) SvPVX($sym) = (char*)emptystring;");
5234  }
5235
5236  # walksymtable creates an extra reference to the GV (#197)
5237  if ( $gv->REFCNT > 1 ) {
5238    $init->add( sprintf( "SvREFCNT(%s) = $u32fmt;", $sym, $gv->REFCNT) );
5239  }
5240  return $sym if $is_empty;
5241
5242  my $gvrefcnt = $gv->GvREFCNT;
5243  if ( $gvrefcnt > 1 ) {
5244    $init->add( sprintf( "GvREFCNT(%s) += $u32fmt;", $sym, $gvrefcnt - 1) );
5245  }
5246
5247  warn "check which savefields for \"$gvname\"\n" if $debug{gv};
5248  # some non-alphabetic globs require some parts to be saved
5249  # ( ex. %!, but not $! )
5250  if ( $gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/ ) {
5251    $savefields = Save_HV | Save_AV | Save_SV | Save_CV | Save_FORM | Save_IO;
5252  }
5253  elsif ( $fullname eq 'main::!' ) { #Errno
5254    $savefields = Save_HV | Save_SV | Save_CV;
5255  }
5256  elsif ( $fullname eq 'main::ENV' or $fullname eq 'main::SIG' ) {
5257    $savefields = Save_AV | Save_SV | Save_CV | Save_FORM | Save_IO;
5258  }
5259  elsif ( $fullname eq 'main::ARGV' ) {
5260    $savefields = Save_HV | Save_SV | Save_CV | Save_FORM | Save_IO;
5261  }
5262  elsif ( $fullname =~ /^main::STD(IN|OUT|ERR)$/ ) {
5263    $savefields = Save_FORM | Save_IO;
5264  }
5265  $savefields &= ~$filter if ($filter and $filter !~ m/ :pad/
5266                              and $filter =~ m/^\d+$/ and $filter > 0 and $filter < 64);
5267  # issue 79: Only save stashes for stashes.
5268  # But not other values to avoid recursion into unneeded territory.
5269  # We walk via savecv, not via stashes.
5270  if (ref($gv) eq 'B::STASHGV' and $gvname !~ /::$/) {
5271    return $sym;
5272  }
5273
5274  # attributes::bootstrap is created in perl_parse.
5275  # Saving it would overwrite it, because perl_init() is
5276  # called after perl_parse(). But we need to xsload it.
5277  if ($fullname eq 'attributes::bootstrap') {
5278    unless ( defined( &{ $package . '::bootstrap' } ) ) {
5279      warn "Forcing bootstrap of $package\n" if $verbose;
5280      eval { $package->bootstrap };
5281    }
5282    mark_package('attributes', 1);
5283    if ($] >= 5.011) {
5284      $savefields &= ~Save_CV;
5285      $xsub{attributes} = 'Dynamic-'. $INC{'attributes.pm'}; # XSLoader
5286      $use_xsloader = 1;
5287    } else {
5288      $xsub{attributes} = 'Static';
5289    }
5290  }
5291
5292  # avoid overly dynamic POSIX redefinition warnings: GH #335, #345
5293  if ($PERL522 and $fullname =~ /^POSIX::M/) {
5294    $savefields &= ~Save_CV;
5295  }
5296  my $gvsv;
5297  if ($savefields) {
5298    # Don't save subfields of special GVs (*_, *1, *# and so on)
5299    warn "GV::save saving subfields $savefields\n" if $debug{gv};
5300    $gvsv = $gv->SV;
5301    if ( $$gvsv && $savefields & Save_SV ) {
5302      warn "GV::save \$".$sym." $gvsv\n" if $debug{gv};
5303      my $core_svs = { # special SV syms to assign to the right GvSV
5304         "\\"   => 'PL_ors_sv',
5305         "/"    => 'PL_rs',
5306         "@"    => 'PL_errors',
5307      };
5308      for my $s (sort keys %$core_svs) {
5309        if ($fullname eq 'main::'.$s) {
5310          savesym( $gvsv, $core_svs->{$s} ); # TODO: This could bypass BEGIN settings (->save is ignored)
5311        }
5312      }
5313      if ($PERL5257 and $gvsv->MAGICAL) {
5314        my @magic = $gvsv->MAGIC;
5315        foreach my $mg (@magic) {
5316          if ($mg->TYPE eq 'B') {
5317            warn sprintf( "  GvSV $sym isa FBM\n") if $debug{gv};
5318            savesym($gvsv, B::BM::save($gvsv));
5319          }
5320        }
5321      }
5322      if ($gvname eq 'VERSION' and $xsub{$package} and $gvsv->FLAGS & SVf_ROK and !$PERL56) {
5323	warn "Strip overload from $package\::VERSION, fails to xs boot (issue 91)\n" if $debug{gv};
5324	my $rv = $gvsv->object_2svref();
5325	my $origsv = $$rv;
5326	no strict 'refs';
5327	${$fullname} = "$origsv";
5328	svref_2object(\${$fullname})->save($fullname);
5329	$init->add( sprintf( "GvSVn(%s) = (SV*)s\\_%x;", $sym, $$gvsv ) );
5330      } else {
5331	$gvsv->save($fullname); #even NULL save it, because of gp_free nonsense
5332        # we need sv magic for the core_svs (PL_rs -> gv) (#314)
5333        if (exists $core_svs->{$gvname}) {
5334          if ($gvname eq "\\") {  # ORS special case #318 (initially NULL)
5335            return $sym;
5336          } else {
5337            $gvsv->save_magic($fullname) if ref($gvsv) eq 'B::PVMG';
5338            $init->add( sprintf( "SvREFCNT(s\\_%x) += 1;", $$gvsv ) );
5339          }
5340        }
5341	$init->add( sprintf( "GvSVn(%s) = (SV*)s\\_%x;", $sym, $$gvsv ) );
5342      }
5343      if ($fullname eq 'main::$') { # $$ = PerlProc_getpid() issue #108
5344        warn sprintf( "  GV $sym \$\$ perlpid\n") if $debug{gv};
5345        $init->add( "sv_setiv(GvSV($sym), (IV)PerlProc_getpid());" );
5346      }
5347      warn "GV::save \$$fullname\n" if $debug{gv};
5348    }
5349    my $gvav = $gv->AV;
5350    if ( $$gvav && $savefields & Save_AV ) {
5351      warn "GV::save \@$fullname\n" if $debug{gv};
5352      $gvav->save($fullname);
5353      $init->add( sprintf( "GvAV(%s) = s\\_%x;", $sym, $$gvav ) );
5354      if ($fullname eq 'main::-') {
5355        $init->add( sprintf("AvFILLp(s\\_%x) = -1;", $$gvav),
5356                    sprintf("AvMAX(s\\_%x) = -1;", $$gvav));
5357      }
5358    }
5359    my $gvhv = $gv->HV;
5360    if ( $$gvhv && $savefields & Save_HV ) {
5361      if ($fullname ne 'main::ENV') {
5362	warn "GV::save \%$fullname\n" if $debug{gv};
5363        if (!$module) {
5364          if ($fullname eq 'main::!') { # force loading Errno
5365            $init->add("/* \%! force saving of Errno */");
5366            mark_package('Config', 1);  # Errno needs Config to set the EGV
5367            walk_syms('Config');
5368            mark_package('Errno', 1);   # B::C needs Errno but does not import $!
5369          } elsif ($fullname eq 'main::+' or $fullname eq 'main::-') {
5370            $init->add("/* \%$gvname force saving of Tie::Hash::NamedCapture */");
5371            if ($PERL514) {
5372              mark_package('Config', 1);  # DynaLoader needs Config to set the EGV
5373              walk_syms('Config');
5374              svref_2object(\&{'Tie::Hash::NamedCapture::bootstrap'})->save;
5375            }
5376            mark_package('Tie::Hash::NamedCapture', 1);
5377          }
5378        }
5379        # skip static %Encode::Encoding since 5.20. GH #200. sv_upgrade cannot upgrade itself.
5380        # Let it be initialized by boot_Encode/Encode_XSEncodingm with exceptions.
5381        # GH #200 and t/testc.sh 75
5382        if ($] >= 5.020 and $fullname eq 'Encode::Encoding') {
5383          warn "skip some %Encode::Encoding - XS initialized\n" if $debug{gv};
5384          my %tmp_Encode_Encoding = %Encode::Encoding;
5385          %Encode::Encoding = (); # but we need some non-XS encoding keys
5386          for my $k (qw(utf8 utf-8-strict Unicode Internal Guess)) {
5387            $Encode::Encoding{$k} = $tmp_Encode_Encoding{$k} if exists $tmp_Encode_Encoding{$k};
5388          }
5389	  $gvhv->save($fullname);
5390	  $init->add( "/* deferred some XS enc pointers for \%Encode::Encoding */",
5391              sprintf("GvHV(%s) = s\\_%x;", $sym, $$gvhv ) );
5392          %Encode::Encoding = %tmp_Encode_Encoding;
5393        }
5394	# XXX TODO 49: crash at BEGIN { %warnings::Bits = ... }
5395	elsif ($fullname ne 'main::INC') {
5396	  $gvhv->save($fullname);
5397	  $init->add( sprintf( "GvHV(%s) = s\\_%x;", $sym, $$gvhv ) );
5398	}
5399      }
5400    }
5401    my $gvcv = $gv->CV;
5402    if ( !$$gvcv and $savefields & Save_CV ) {
5403      warn "Empty CV $fullname, AUTOLOAD and try again\n" if $debug{gv};
5404      no strict 'refs';
5405      # Fix test 31, catch unreferenced AUTOLOAD. The downside:
5406      # It stores the whole optree and all its children.
5407      # Similar with test 39: re::is_regexp
5408      svref_2object( \*{"$package\::AUTOLOAD"} )->save
5409        if $package and exists ${"$package\::"}{AUTOLOAD};
5410      svref_2object( \*{"$package\::CLONE"} )->save
5411        if $package and exists ${"$package\::"}{CLONE};
5412      $gvcv = $gv->CV; # try again
5413    }
5414    # This will autovivify the CvGV of a named CV
5415    if ( $$gvcv and $savefields & Save_CV
5416         and ref($gvcv) eq 'B::CV'
5417         #and !is_named($gvcv)
5418         and ref($gvcv->GV->EGV) ne 'B::SPECIAL'
5419         and !skip_pkg($package) )
5420    {
5421      my $package  = $gvcv->GV->EGV->STASH->NAME;
5422      my $oname    = $gvcv->GV->EGV->NAME;
5423      my $origname = $package . "::" . $oname;
5424      my $cvsym;
5425      if ( $gvcv->XSUB and $oname ne '__ANON__' and $fullname ne $origname ) {    #XSUB CONSTSUB alias
5426        warn "Boot $package, XS CONSTSUB alias of $fullname to $origname\n"
5427          if $debug{pkg};
5428        mark_package($package, 1);
5429        {
5430          no strict 'refs';
5431          svref_2object( \&{"$package\::bootstrap"} )->save
5432            if $package and defined &{"$package\::bootstrap"};
5433        }
5434        # XXX issue 57: incomplete xs dependency detection
5435        my %hack_xs_detect =
5436          ('Scalar::Util'  => 'List::Util',
5437           'Sub::Exporter' => 'Params::Util',
5438          );
5439        if (my $dep = $hack_xs_detect{$package}) {
5440          svref_2object( \&{"$dep\::bootstrap"} )->save;
5441        }
5442        # must save as a 'stub' so newXS() has a CV to populate
5443        warn "save stub CvGV for $sym GP assignments $origname\n" if $debug{gv};
5444        $init2->add(
5445          sprintf("if ((sv = (SV*)%s))", get_cv($origname, "GV_ADD")),
5446          sprintf("    GvCV_set(%s, (CV*)SvREFCNT_inc_simple_NN(sv));", $sym));
5447          # TODO: add evtl. to SvRV also.
5448      }
5449      elsif (!$PERL510 or $gp) {
5450	if ($fullname eq 'Internals::V') { # local_patches if $] >= 5.011
5451	  $gvcv = svref_2object( \&__ANON__::_V );
5452	}
5453	# TODO: may need fix CvGEN if >0 to re-validate the CV methods
5454	# on PERL510 (>0 + <subgeneration)
5455	warn "GV::save &$fullname...\n" if $debug{gv};
5456        $cvsym = $gvcv->save($fullname);
5457        # backpatch "$sym = gv_fetchpv($name, GV_ADD, SVt_PV)" to SVt_PVCV
5458        if ($cvsym =~ /get_cv/) {
5459	  if (!$xsub{$package} and in_static_core($package, $gvname)) {
5460	    my $in_gv;
5461	    for (@{ $init->[-1]{current} }) {
5462	      if ($in_gv) {
5463		s/^.*\Q$sym\E.*=.*;//;
5464		s/GvGP_set\(\Q$sym\E.*;//;
5465	      }
5466              my $gv_get     = gv_fetchpvn($name, "GV_ADD", "SVt_PV");
5467              my $new_gv_get = gv_fetchpvn($name, "GV_ADD", "SVt_PVCV");
5468	      if (/^\Q$sym = $gv_get;\E/) {
5469		s/^\Q$sym = $gv_get;\E/$sym = $new_gv_get;/;
5470		$in_gv++;
5471		warn "removed $sym GP assignments $origname (core CV)\n" if $debug{gv};
5472	      }
5473	    }
5474	    $init->add( sprintf( "GvCV_set(%s, (CV*)SvREFCNT_inc(%s));", $sym, $cvsym ));
5475	  }
5476	  elsif ($xsub{$package}) {
5477            # must save as a 'stub' so newXS() has a CV to populate later in dl_init()
5478            warn "save stub CvGV for $sym GP assignments $origname (XS CV)\n" if $debug{gv};
5479            my $get_cv = get_cv($oname ne "__ANON__" ? $origname : $fullname, "GV_ADD");
5480            $init2->add(sprintf("if ((sv = (SV*)%s))", $get_cv),
5481                        sprintf("    GvCV_set(%s, (CV*)SvREFCNT_inc_simple_NN(sv));", $sym));
5482	  }
5483	  else {
5484            $init->add( sprintf( "GvCV_set(%s, (CV*)(%s));", $sym, $cvsym ));
5485	  }
5486          if ($gvcv->XSUBANY) {
5487            # some XSUB's set this field. but which part?
5488            my $xsubany = $gvcv->XSUBANY;
5489            if ($package =~ /^DBI::(common|db|dr|st)/) {
5490              # DBI uses the any_ptr for dbi_ima_t *ima, and all dr,st,db,fd,xx handles
5491              # for which several ptrs need to be patched. #359
5492              # the ima is internal only
5493              my $dr = $1;
5494              warn sprintf("eval_pv: DBI->_install_method(%s-) (XSUBANY=0x%x)\n",
5495                           $fullname, $xsubany) if $verbose and $debug{cv};
5496              $init2->add_eval(sprintf("DBI->_install_method('%s', 'DBI.pm', \$DBI::DBI_methods{%s}{%s})",
5497                                       $fullname, $dr, $fullname));
5498            } elsif ($package eq 'Tie::Hash::NamedCapture') {
5499              # pretty high _ALIAS CvXSUBANY.any_i32 values
5500            } else {
5501              # try if it points to an already registered symbol
5502              my $anyptr = $symtable{ sprintf( "s\\_%x", $xsubany ) };
5503              if ($anyptr and $xsubany > 1000) { # not a XsubAliases
5504                $init2->add( sprintf( "CvXSUBANY(GvCV(%s)).any_ptr = &%s;", $sym, $anyptr ));
5505              } # some heuristics TODO. long or ptr? TODO 32bit
5506              elsif ($xsubany > 0x100000
5507                     and ($xsubany < 0xffffff00 or $xsubany > 0xffffffff))
5508              {
5509                if ($package eq 'POSIX' and $gvname =~ /^is/) {
5510                  # need valid XSANY.any_dptr
5511                  $init2->add( sprintf( "CvXSUBANY(GvCV(%s)).any_dptr = (void*)&%s;", $sym, $gvname));
5512                } elsif ($package eq 'List::MoreUtils' and $gvname =~ /_iterator$/) {
5513                  # should be only the 2 iterators
5514                  $init2->add( sprintf( "CvXSUBANY(GvCV(%s)).any_ptr = (void*)&%s;", $sym,
5515                                        "XS_List__MoreUtils__".$gvname));
5516                } else {
5517                  warn sprintf("TODO: Skipping %s->XSUBANY = 0x%x\n", $fullname, $xsubany ) if $verbose;
5518                  $init2->add( sprintf( "/* TODO CvXSUBANY(GvCV(%s)).any_ptr = 0x%lx; */", $sym, $xsubany ));
5519                }
5520              } elsif ($package eq 'Fcntl') {
5521                # S_ macro values
5522              } else {
5523                # most likely any_i32 values for the XsubAliases provided by xsubpp
5524                $init2->add( sprintf( "/* CvXSUBANY(GvCV(%s)).any_i32 = 0x%x; XSUB Alias */", $sym, $xsubany ));
5525              }
5526            }
5527          }
5528	}
5529	elsif ($cvsym =~ /^(cv|&sv_list)/) {
5530          $init->add( sprintf( "GvCV_set(%s, (CV*)(%s));", $sym, $cvsym ));
5531        }
5532	else {
5533            warn "wrong CvGV for $sym $origname: $cvsym\n" if $debug{gv} or $verbose;
5534        }
5535      }
5536      # special handling for backref magic
5537      if ($PERL514 and $cvsym and $cvsym !~ /(get_cv|NULL|lexwarn)/ and $gv->MAGICAL) {
5538        my @magic = $gv->MAGIC;
5539        foreach my $mg (@magic) {
5540          if ($mg->TYPE eq '<') {
5541            $init->add( "sv_magic((SV*)$sym, (SV*)$cvsym, '<', 0, 0);",
5542                        "CvCVGV_RC_off($cvsym);");
5543            if (!($mg->FLAGS & 2)) {
5544              mg_RC_off($mg, $sym, '<'); # 390
5545            }
5546          }
5547        }
5548      }
5549    }
5550    if (!$PERL510 or $gp) {
5551      if ( $] > 5.009 ) {
5552	# TODO implement heksect to place all heks at the beginning
5553	#$heksect->add($gv->FILE);
5554	#$init->add(sprintf("GvFILE_HEK($sym) = hek_list[%d];", $heksect->index));
5555
5556        # XXX Maybe better leave it NULL or asis, than fighting broken
5557        if ($B::C::stash and $fullname =~ /::$/) {
5558          # ignore stash hek asserts when adding the stash
5559          # he->shared_he_he.hent_hek == hek assertions (#46 with IO::Poll::)
5560        } else {
5561          my $file = save_hek($gv->FILE,$fullname,1);
5562          $init->add(sprintf("GvFILE_HEK(%s) = %s;", $sym, $file))
5563            if $file ne 'NULL' and !$optimize_cop;
5564        }
5565	# $init->add(sprintf("GvNAME_HEK($sym) = %s;", save_hek($gv->NAME))) if $gv->NAME;
5566      } else {
5567	# XXX ifdef USE_ITHREADS and PL_curcop->op_flags & OPf_COP_TEMP
5568	# GvFILE is at gp+1
5569	$init->add( sprintf( "GvFILE(%s) = %s;", $sym, cstring( $gv->FILE ) ))
5570	  unless $optimize_cop;
5571	warn "GV::save GvFILE(*$fullname) " . cstring( $gv->FILE ) . "\n"
5572	  if $debug{gv} and !$ITHREADS;
5573      }
5574      my $gvform = $gv->FORM;
5575      if ( $$gvform && $savefields & Save_FORM ) {
5576	warn "GV::save GvFORM(*$fullname) ...\n" if $debug{gv};
5577	$gvform->save($fullname);
5578	$init->add( sprintf( "GvFORM(%s) = (CV*)s\\_%x;", $sym, $$gvform ));
5579        # glob_assign_glob analog to CV
5580	$init->add( sprintf( "SvREFCNT_inc(s\\_%x);", $$gvform )) if $PERL510;
5581	warn "GV::save GvFORM(*$fullname) done\n" if $debug{gv};
5582      }
5583      my $gvio = $gv->IO;
5584      if ( $$gvio && $savefields & Save_IO ) {
5585	warn "GV::save GvIO(*$fullname)...\n" if $debug{gv};
5586	if ( $fullname =~ m/::DATA$/ &&
5587	     ( $fullname eq 'main::DATA' or $B::C::save_data_fh) ) # -O2 or 5.8
5588	{
5589	  no strict 'refs';
5590	  my $fh = *{$fullname}{IO};
5591	  use strict 'refs';
5592	  warn "GV::save_data $sym, $fullname ...\n" if $debug{gv};
5593          $gvio->save($fullname, 'is_DATA');
5594          $init->add( sprintf( "GvIOp(%s) = s\\_%x;", $sym, $$gvio ) );
5595	  $gvio->save_data( $sym, $fullname, <$fh> ) if $fh->opened;
5596	} elsif ( $fullname =~ m/::DATA$/ && !$B::C::save_data_fh ) {
5597          $gvio->save($fullname, 'is_DATA');
5598          $init->add( sprintf( "GvIOp(%s) = s\\_%x;", $sym, $$gvio ) );
5599	  warn "Warning: __DATA__ handle $fullname not stored. Need -O2 or -fsave-data.\n";
5600	} else {
5601          $gvio->save($fullname);
5602          $init->add( sprintf( "GvIOp(%s) = s\\_%x;", $sym, $$gvio ) );
5603        }
5604	warn "GV::save GvIO(*$fullname) done\n" if $debug{gv};
5605      }
5606      $init->add("");
5607    }
5608  }
5609  # Shouldn't need to do save_magic since gv_fetchpv handles that. Esp. < and IO not
5610  # $gv->save_magic($fullname) if $PERL510;
5611  warn "GV::save *$fullname done\n" if $debug{gv};
5612  return $sym;
5613}
5614
5615sub B::AV::save {
5616  my ($av, $fullname, $cv) = @_;
5617  my $sym = objsym($av);
5618  return $sym if defined $sym;
5619
5620  $fullname = '' unless $fullname;
5621  my ($fill, $avreal, $max, $static_av, $av_cow, $av_cog);
5622  my $ispadlist = ref($av) eq 'B::PADLIST';
5623  my $ispadnamelist = ref($av) eq 'B::PADNAMELIST';
5624  if ($ispadnamelist or $ispadlist) {
5625    $fill = $av->MAX;
5626  } else {
5627    # cornercase: tied array without FETCHSIZE
5628    eval { $fill = $av->FILL; };
5629    $fill = -1 if $@;    # catch error in tie magic
5630  }
5631  $max = $fill;
5632  my $svpcast = $ispadlist ? "(PAD*)" : "(SV*)";
5633  $svpcast = "(PADNAME*)" if $ispadnamelist;
5634
5635  if ($PERL522 and $ispadnamelist) {
5636    $padnlsect->comment("xpadnl_fill, xpadnl_alloc, xpadnl_max, xpadnl_max_named, xpadnl_refcnt");
5637    # TODO: max_named walk all names and look for non-empty names
5638    my $refcnt = $av->REFCNT + 1; # XXX defer free to global destruction: 28
5639    my $maxnamed = $av->MAXNAMED;
5640    $padnlsect->add("$fill, NULL, $fill, $maxnamed, $refcnt /* +1 */");
5641    $padnl_index = $padnlsect->index;
5642    $sym = savesym( $av, "&padnamelist_list[$padnl_index]" );
5643    push @B::C::static_free, $sym;
5644  }
5645  elsif ($ispadlist and $] >= 5.021008) { # id+outid as U32 (PL_padlist_generation++)
5646    $padlistsect->comment("xpadl_max, xpadl_alloc, xpadl_id, xpadl_outid");
5647    my ($id, $outid) = ($av->id, $av->outid);
5648    $padlistsect->add("$fill, NULL, $id, $outid");
5649    $padlist_index = $padlistsect->index;
5650    $sym = savesym( $av, "&padlist_list[$padlist_index]" );
5651  }
5652  elsif ($ispadlist and $] >= 5.017006 and $] < 5.021008) { # id added again with b4db586814
5653    $padlistsect->comment("xpadl_max, xpadl_alloc, xpadl_outid");
5654    $padlistsect->add("$fill, NULL, NULL"); # Perl_pad_new(0)
5655    $padlist_index = $padlistsect->index;
5656    $sym = savesym( $av, "&padlist_list[$padlist_index]" );
5657    if ($cv and $cv->OUTSIDE and ref($cv->OUTSIDE) ne 'B::SPECIAL' and $cv->OUTSIDE->PADLIST) {
5658      my $outid = $cv->OUTSIDE->PADLIST->save();
5659      $init->add("($sym)->xpadl_outid = (PADNAMELIST*)$outid;") if $outid;
5660    }
5661  }
5662  elsif ($ispadlist and $] >= 5.017004) {
5663    $padlistsect->comment("xpadl_max, xpadl_alloc, xpadl_id, xpadl_outid");
5664    $padlistsect->add("$fill, NULL, 0, 0"); # Perl_pad_new(0)
5665    $padlist_index = $padlistsect->index;
5666    $sym = savesym( $av, "&padlist_list[$padlist_index]" );
5667    if ($cv and $cv->OUTSIDE and ref($cv->OUTSIDE) ne 'B::SPECIAL' and $cv->OUTSIDE->PADLIST) {
5668      my $outid = $cv->OUTSIDE->PADLIST->save();
5669      $init->add("($sym)->xpadl_outid = (PADNAMELIST*)$outid;") if $outid;
5670    }
5671  }
5672  # we set it static, not perl. (c)perl only observes it.
5673  # decide if to store the array static (with run-time cow overhead) or dynamic
5674  elsif ($CPERL52 and $B::C::av_init and $fill > -1
5675         and (isAvSTATIC($av) or canAvSTATIC($av, $fullname)))
5676  {
5677    $xpvavsect->comment( "stash, magic, fill, max, static alloc" );
5678    my $alloc = "";
5679    my $count = 0;
5680    my $flags = $av->FLAGS;
5681    # decide upon cow (const array, SVf_READONLY) or just cog (forbid av_extend)
5682    my $av_cow = ($flags & SVf_READONLY or $fullname =~ /(::ISA|::INC|curpad_name)$/) ? 1 : 0;
5683    my $magic = ''; # need to skip ->ARRAY with 'D' magic, test 90
5684    foreach my $mg ($av->MAGIC) {
5685      $magic = $mg->TYPE;
5686      if ($magic eq 'D') {
5687        last;
5688      }
5689    }
5690    my @array = $magic eq 'D' ? () : $av->ARRAY;
5691    my $n = scalar @array;
5692    my $name = ($av_cow ? "avcow_" : "avcog_") . $n;
5693    my $avstaticsect;
5694    if ($av_cow) {
5695      $avcowsect{ $n } = new B::C::Section($name, \%symtable, 0) unless exists $avcowsect{ $n };
5696      $avstaticsect = $avcowsect{ $n };
5697    } else {
5698      $avcogsect{ $n } = new B::C::Section($name, \%symtable, 0) unless exists $avcogsect{ $n };
5699      $avstaticsect = $avcogsect{ $n };
5700    }
5701    my $sect = sprintf("&%s_list[%u]", $name, $avstaticsect->index + 1);
5702    # protect against duplicates
5703    $sym = savesym( $av, sprintf("(AV*)&sv_list[%u]", $svsect->index + 1));
5704
5705    # $B::C::const_strings = 0 if $flags & 0x40008000 == 0x40008000; # SVp_SCREAM|SVpbm_VALID
5706    my @values = map { $_->save($fullname."[".$count++."]") || () } @array;
5707    for (my $i=0; $i <= $#array; $i++) {
5708      # if any value is non-static (GV), fall back to dynamic AV::save
5709      if (!is_constant($values[$i])) {
5710        $alloc = '';
5711        last;
5712      }
5713      $alloc .= $values[$i].", ";
5714    }
5715    if ($alloc and $n) {
5716      $static_av = 1;
5717      warn sprintf("turn on %s %s\n", $av_cow ? "AvIsCOW" : "AvSTATIC", $sym, $fullname)
5718        if $debug{av};
5719      $flags |= SVf_IsCOW;               # turn on AvSTATIC
5720      # $flags |= SVf_READONLY if $av_cow; # and turn on COW
5721      $alloc = substr($alloc,0,-2);
5722      $avstaticsect->add( $alloc );
5723      $xpvavsect->add("Nullhv, {0}, $fill, $max, (SV**)$sect");
5724      $svsect->add(sprintf("&xpvav_list[%d], $u32fmt, 0x%x, {%s}",
5725                           $xpvavsect->index, $av->REFCNT, $flags,
5726                           ($C99?".svu_array=(SV**)":"(char*)").$sect));
5727      $sym = savesym( $av, sprintf("(AV*)&sv_list[%u]", $svsect->index));
5728    } else {
5729      warn sprintf("turn off AvSTATIC %s %s\n", $sym, $fullname)
5730        if $debug{av};
5731      $flags &= ~SVf_IsCOW; # turn off AvSTATIC
5732      my $line = "Nullhv, {0}, -1, -1, 0";
5733      $line = "Nullhv, {0}, $fill, $max, 0" if $B::C::av_init or $B::C::av_init2;
5734      $xpvavsect->add($line);
5735      $svsect->add(sprintf("&xpvav_list[%d], $u32fmt, 0x%x, {0}",
5736                           $xpvavsect->index, $av->REFCNT, $flags));
5737    }
5738  }
5739  elsif ($PERL514) {
5740    $xpvavsect->comment( "stash, magic, fill, max, alloc" );
5741    # 5.13.3: STASH, MAGIC, fill max ALLOC
5742    my $line = "Nullhv, {0}, -1, -1, 0";
5743    $line = "Nullhv, {0}, $fill, $max, 0" if $B::C::av_init or $B::C::av_init2;
5744    $xpvavsect->add($line);
5745    $svsect->add(sprintf("&xpvav_list[%d], $u32fmt, 0x%x, {%s}",
5746                         $xpvavsect->index, $av->REFCNT, $av->FLAGS,
5747                         '0'));
5748    #$avreal = $av->FLAGS & 0x40000000; # SVpav_REAL (unused)
5749  }
5750  elsif ($PERL510) {
5751    $xpvavsect->comment( "xnv_u, fill, max, xiv_u, magic, stash" );
5752    # 5.9.4+: nvu fill max iv MG STASH
5753    my $line = "{0}, -1, -1, {0}, {0}, Nullhv";
5754    $line = "{0}, $fill, $max, {0}, {0}, Nullhv" if $B::C::av_init or $B::C::av_init2;
5755    $line = "Nullhv, {0}, $fill, $max, NULL" if $PERL514;
5756    $xpvavsect->add($line);
5757    $svsect->add(sprintf("&xpvav_list[%d], $u32fmt, 0x%x, {%s}",
5758                         $xpvavsect->index, $av->REFCNT, $av->FLAGS,
5759                         '0'));
5760    #$avreal = $av->FLAGS & 0x40000000; # SVpav_REAL (unused)
5761  }
5762  else {
5763    $xpvavsect->comment( "array, fill, max, off, nv, magic, stash, alloc, arylen, flags" );
5764    # 5.8: ARRAY fill max off nv MG STASH ALLOC arylen flags
5765    my $line = "0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0";
5766    $line = "0, $fill, $max, 0, 0.0, 0, Nullhv, 0, 0" if $B::C::av_init or $B::C::av_init2;
5767    $line .= sprintf( ", 0x%x", $av->AvFLAGS ) if $] < 5.009;
5768    #$avreal = $av->AvFLAGS & 1; # AVf_REAL
5769    $xpvavsect->add($line);
5770    $svsect->add(sprintf("&xpvav_list[%d], $u32fmt, 0x%x",
5771                         $xpvavsect->index, $av->REFCNT, $av->FLAGS));
5772  }
5773
5774  my ($magic, $av_index) = ('');
5775  $svsect->debug($fullname, $av->flagspv) if $debug{flags};
5776  if (!$ispadlist and !$ispadnamelist) {
5777    my $sv_ix = $svsect->index;
5778    $av_index = $xpvavsect->index;
5779    # protect against recursive self-references (Getopt::Long)
5780    $sym = savesym( $av, "(AV*)&sv_list[$sv_ix]" );
5781    $magic = $av->save_magic($fullname);
5782    push @B::C::static_free, $sym if $PERL518 and $av->FLAGS & SVs_OBJECT;
5783  }
5784
5785  if ( $debug{av} ) {
5786    my $line = sprintf( "saving AV %s 0x%x [%s] FILL=%d", $fullname, $$av, B::class($av), $fill);
5787    $line .= sprintf( " AvFLAGS=0x%x", $av->AvFLAGS ) if $] < 5.009;
5788    warn "$line\n";
5789  }
5790
5791  # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
5792  if ($fill > -1 and $magic !~ /D/ and !$static_av) {
5793    my @array = $av->ARRAY; # crashes with D magic (Getopt::Long)
5794    if ( $debug{av} ) {
5795      my $i = 0;
5796      foreach my $el (@array) {
5797	my $val = '';
5798	# if SvIOK print iv, POK pv
5799	if ($el->can('FLAGS')) {
5800	  $val = $el->IVX if $el->FLAGS & SVf_IOK;
5801	  $val = cstring($el->PV) if $el->FLAGS & SVf_POK;
5802	}
5803        warn sprintf( "AV $av \[%d] = %s $val\n", $i++, B::class($el) );
5804      }
5805    }
5806
5807    #	my @names = map($_->save, @array);
5808    # XXX Better ways to write loop?
5809    # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
5810    # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
5811
5812    # micro optimization: op/pat.t ( and other code probably )
5813    # has very large pads ( 20k/30k elements ) passing them to
5814    # ->add is a performance bottleneck: passing them as a
5815    # single string cuts runtime from 6min20sec to 40sec
5816
5817    # you want to keep this out of the no_split/split
5818    # map("\t*svp++ = (SV*)$_;", @names),
5819    my $acc = '';
5820    # Init optimization by Nick Koston
5821    # The idea is to create loops so there is less C code. In the real world this seems
5822    # to reduce the memory usage ~ 3% and speed up startup time by about 8%.
5823    my ($count, @values);
5824    {
5825      local $B::C::const_strings = $B::C::const_strings;
5826      if ($PERL510 and !$ispadlist) { # force dynamic PADNAME strings
5827        if ($] < 5.016) { $B::C::const_strings = 0 if $av->FLAGS & 0x40000000; }      # SVpad_NAME
5828        else { $B::C::const_strings = 0 if ($av->FLAGS & 0x40008000 == 0x40008000); } # SVp_SCREAM|SVpbm_VALID
5829      }
5830      @values = map { $_->save($fullname."[".$count++."]") || () } @array;
5831    }
5832    $count = 0;
5833    for (my $i=0; $i <= $#array; $i++) {
5834      if ($fullname =~ m/^(INIT|END)$/ and $values[$i] and ref $array[$i] eq 'B::CV') {
5835        if ($array[$i]->XSUB) {
5836          $values[$i] =~ s/, 0\)/, GV_ADD\)/; # GvCV filled in later
5837        }
5838        $values[$i] = sprintf("SvREFCNT_inc(%s);", $values[$i]);
5839      }
5840      if ( $use_svpop_speedup
5841           && defined $values[$i]
5842           && defined $values[$i+1]
5843           && defined $values[$i+2]
5844	   && $values[$i] =~ /^\&sv_list\[(\d+)\]/
5845	   && $values[$i+1] eq "&sv_list[" . ($1+1) . "]"
5846	   && $values[$i+2] eq "&sv_list[" . ($1+2) . "]" )
5847      {
5848	$count=0;
5849	while (defined($values[$i+$count+1]) and $values[$i+$count+1] eq "&sv_list[" . ($1+$count+1) . "]") {
5850	  $count++;
5851	}
5852	$acc .= "\tfor (gcount=" . $1 . "; gcount<" . ($1+$count+1) . "; gcount++) {"
5853	  ." *svp++ = $svpcast&sv_list[gcount]; };\n\t";
5854	$i += $count;
5855      } elsif ($use_av_undef_speedup
5856	       && defined $values[$i]
5857	       && defined $values[$i+1]
5858	       && defined $values[$i+2]
5859	       && $values[$i]   =~ /^ptr_undef|&PL_sv_undef$/
5860	       && $values[$i+1] =~ /^ptr_undef|&PL_sv_undef$/
5861	       && $values[$i+2] =~ /^ptr_undef|&PL_sv_undef$/)
5862      {
5863	$count=0;
5864	while (defined $values[$i+$count+1] and $values[$i+$count+1] =~ /^ptr_undef|&PL_sv_undef$/) {
5865	  $count++;
5866	}
5867	$acc .= "\tfor (gcount=0; gcount<" . ($count+1) . "; gcount++) {"
5868	  ." *svp++ = $svpcast&PL_sv_undef; };\n\t";
5869	$i += $count;
5870      } else { # XXX 5.8.9d Test::NoWarnings has empty values
5871	$acc .= "\t*svp++ = $svpcast" . ($values[$i] ? $values[$i] : '&PL_sv_undef') . ";\n\t";
5872      }
5873    }
5874    $init->no_split;
5875
5876    if ($ispadnamelist) {
5877      my $fill1 = $fill+1;
5878      $init->add("{", "\tPADNAME **svp;");
5879      $init->add("\tregister int gcount;") if $count;
5880      $init->add(
5881                 "\tPADNAMELIST *padnl = $sym;",
5882         sprintf("\tNewxz(svp, %d, PADNAME *);", $fill+1),
5883                 "\tPadnamelistARRAY(padnl) = svp;",
5884                );
5885      $init->add( substr( $acc, 0, -2 ) );
5886      $init->add("}");
5887    }
5888    elsif ($ispadlist) {
5889      my $fill1 = $fill+1;
5890      $init->add("{", "\tPAD **svp;");
5891      $init->add("\tregister int gcount;") if $count;
5892      $init->add(
5893                 "\tPADLIST *padl = $sym;",
5894         sprintf("\tNewxz(svp, %d, PAD *);", $fill+1),
5895                 "\tPadlistARRAY(padl) = svp;",
5896                );
5897      $init->add( substr( $acc, 0, -2 ) );
5898      $init->add("}");
5899    }
5900    # With -fav-init2 use independent_comalloc()
5901    elsif ($B::C::av_init2) {
5902      my $i = $av_index;
5903      $xpvav_sizes[$i] = $fill;
5904      my $init_add = "{ SV **svp = avchunks[$i]; AV *av = $sym;\n";
5905      $init_add .= "\tregister int gcount;\n" if $count;
5906      if ($fill > -1) {
5907        if ($PERL510) {
5908          $init_add .= "\tAvALLOC(av) = svp;\n".
5909                       "\tAvARRAY(av) = svp;\n";
5910        } else {
5911          $init_add .= "\tAvALLOC(av) = svp;\n" .
5912                       # XXX Dirty hack from av.c:Perl_av_extend()
5913                       "\tSvPVX(av) = (char*)svp;";
5914        }
5915      }
5916      $init_add .= substr( $acc, 0, -2 );
5917      $init->add( $init_add . "}" );
5918    }
5919    # With -fav-init faster initialize the array as the initial av_extend()
5920    # is very expensive.
5921    # The problem was calloc, not av_extend.
5922    # Since we are always initializing every single element we don't need
5923    # calloc, only malloc. wmemset'ting the pointer to PL_sv_undef
5924    # might be faster also.
5925    elsif ($B::C::av_init) {
5926      $init->add(
5927                 "{", "\tSV **svp;",
5928                 "\tAV *av = $sym;");
5929      $init->add("\tregister int gcount;") if $count;
5930      my $fill1 = $fill < 3 ? 3 : $fill+1;
5931      if ($fill > -1) {
5932        $fill1 = $fill+1 if $fullname eq 'END';
5933        # Perl_safesysmalloc (= calloc => malloc) or Perl_malloc (= mymalloc)?
5934	if ($MYMALLOC) {
5935          $init->add(sprintf("\tNewx(svp, %d, SV*);", $fill1),
5936                     "\tAvALLOC(av) = svp;");
5937        } else {
5938	  # Bypassing Perl_safesysmalloc on darwin fails with "free from wrong pool", test 25.
5939	  # So with DEBUGGING perls we have to track memory and use calloc.
5940	  $init->add("#ifdef PERL_TRACK_MEMPOOL",
5941		     sprintf("\tsvp = (SV**)Perl_safesysmalloc(%d * sizeof(SV*));", $fill1),
5942		     "#else",
5943		     sprintf("\tsvp = (SV**)malloc(%d * sizeof(SV*));", $fill1),
5944		     "#endif",
5945          	     "\tAvALLOC(av) = svp;");
5946	}
5947        if ($PERL510) {
5948	  $init->add("\tAvARRAY(av) = svp;");
5949        } else { # read-only AvARRAY macro
5950	  # XXX Dirty hack from av.c:Perl_av_extend()
5951          $init->add("\tSvPVX(av) = (char*)svp;");
5952        }
5953      }
5954      $init->add( substr( $acc, 0, -2 ) ); # AvFILLp already in XPVAV
5955      $init->add( "}" );
5956    }
5957    else { # unoptimized with the full av_extend()
5958      my $fill1 = $fill < 3 ? 3 : $fill+1;
5959      $init->add("{", "\tSV **svp;");
5960      $init->add("\tregister int gcount;") if $count;
5961      $init->add("\tAV *av = $sym;\t/* $fullname */",
5962                 "\tav_extend(av, $fill1);",
5963                 "\tsvp = AvARRAY(av);");
5964      $init->add( substr( $acc, 0, -2 ) );
5965      $init->add( "\tAvFILLp(av) = $fill;" );
5966      $init->add( "}" );
5967    }
5968    $init->split;
5969
5970    # we really added a lot of lines ( B::C::InitSection->add
5971    # should really scan for \n, but that would slow
5972    # it down
5973    $init->inc_count($#array);
5974  }
5975  else {
5976    my $max = $av->MAX;
5977    $init->add("av_extend($sym, $max);")
5978      if $max > -1 and !$static_av;
5979  }
5980  $init->add("SvREADONLY_on($sym);") if $av_cow;
5981  return $sym;
5982}
5983
5984sub B::HV::save {
5985  my ($hv, $fullname) = @_;
5986  $fullname = '' unless $fullname;
5987  my $sym = objsym($hv);
5988  return $sym if defined $sym;
5989  my $name = $hv->NAME;
5990  my $is_stash = $name;
5991  my $magic;
5992  if ($name) {
5993    # It's a stash. See issue 79 + test 46
5994    warn sprintf( "Saving stash HV \"%s\" from \"$fullname\" 0x%x MAX=%d\n",
5995                  $name, $$hv, $hv->MAX ) if $debug{hv};
5996
5997    # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
5998    # the only symptom is that sv_reset tries to reset the PMf_USED flag of
5999    # a trashed op but we look at the trashed op_type and segfault.
6000    #my $adpmroot = ${$hv->PMROOT}; # XXX When was this fixed?
6001    my $adpmroot = 0;
6002    $sym = savestashpv($name);
6003    savesym( $hv, $sym );
6004    if ($adpmroot) {
6005      $init->add(sprintf( "HvPMROOT(hv%d) = (PMOP*)s\\_%x;",
6006			  $hv_index, $adpmroot ) );
6007    }
6008    if ($PERL518 and $hv->FLAGS & SVf_AMAGIC and length($name)) {
6009      # fix overload stringify
6010      if ($hv->Gv_AMG) { # potentially removes the AMG flag
6011        $init2->add( sprintf("mro_isa_changed_in(%s);  /* %s */", $sym, $name));
6012      }
6013    }
6014    # Add aliases if namecount > 1 (GH #331)
6015    # There was no B API for the count or multiple enames, so I added one.
6016    my @enames = ($PERL514 ? $hv->ENAMES : ());
6017    if (@enames > 1) {
6018      warn "Saving for $name multiple enames: ", join(" ",@enames), "\n" if $debug{hv};
6019      my $name_count = $hv->name_count;
6020      # If the stash name is empty xhv_name_count is negative, and names[0] should
6021      # be already set. but we rather write it.
6022      $init->no_split;
6023      my $hv_max = $hv->MAX + 1;
6024      # unshift @enames, $name if $name_count < 0; # stashpv has already set names[0]
6025      $init->add( "if (!SvOOK($sym)) {", # hv_auxinit is not exported
6026                  "  HE **a;",
6027                  "#ifdef PERL_USE_LARGE_HV_ALLOC",
6028         sprintf( "  Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(%d) + sizeof(struct xpvhv_aux), HE*);",
6029                  $hv_max),
6030                  "#else",
6031         sprintf( "  Newxz(a, %d + sizeof(struct xpvhv_aux), HE*);", $hv_max),
6032                  "#endif",
6033                  "  SvOOK_on($sym);",
6034                  "}",
6035                  "{",
6036                  "  struct xpvhv_aux *aux = HvAUX($sym);",
6037         sprintf( "  Newx(aux->xhv_name_u.xhvnameu_names, %d, HEK*);", scalar @enames),
6038         sprintf( "  aux->xhv_name_count = %d;", $name_count));
6039      my $i = 0;
6040      while (@enames) {
6041        my ($cstring, $cur, $utf8) = strlen_flags(shift @enames);
6042        $init->add(
6043         sprintf( "  aux->xhv_name_u.xhvnameu_names[%u] = share_hek(%s, %d);",
6044                  $i++, $cstring, $utf8 ? -$cur : $cur));
6045      }
6046      $init->add( "}" );
6047      $init->split;
6048    }
6049
6050    # issue 79, test 46: save stashes to check for packages.
6051    # and via B::STASHGV we only save stashes for stashes.
6052    # For efficiency we skip most stash symbols unless -fstash.
6053    # However it should be now safe to save all stash symbols.
6054    # $fullname !~ /::$/ or
6055    if (!$B::C::stash) { # -fno-stash: do not save stashes
6056      $magic = $hv->save_magic('%'.$name.'::'); #symtab magic set in PMOP #188 (#267)
6057      if ($PERL510 and is_using_mro() && mro::get_mro($name) eq 'c3') {
6058        B::C::make_c3($name);
6059      }
6060      if ($magic and $magic =~ /c/) {
6061        warn "defer AMT magic of $name\n" if $debug{mg};
6062        # defer AMT magic of XS loaded hashes. #305 Encode::XS with tiehash magic
6063        #  $init1->add(qq[$sym = gv_stashpvn($cname, $len, GV_ADDWARN|GV_ADDMULTI);]);
6064      }
6065      return $sym;
6066    }
6067    return $sym if skip_pkg($name) or $name eq 'main';
6068    $init->add( "SvREFCNT_inc($sym);" );
6069    warn "Saving stash keys for HV \"$name\" from \"$fullname\"\n" if $debug{hv};
6070  }
6071
6072  # Ordinary HV or Stash
6073  # KEYS = 0, inc. dynamically below with hv_store. TODO: HvSTATIC readonly tables,
6074  # without hv_store
6075  if ($PERL510) {
6076    my $flags = $hv->FLAGS & ~SVf_READONLY;
6077    $flags &= ~SVf_PROTECT if $PERL522;
6078    if ($PERL514) { # fill removed with 5.13.1
6079      $xpvhvsect->comment( "stash mgu max keys" );
6080      $xpvhvsect->add(sprintf( "Nullhv, {0}, %u, %d",
6081			       $hv->MAX, 0 ));
6082    } else {
6083      $xpvhvsect->comment( "GVSTASH fill max keys MG STASH" );
6084      $xpvhvsect->add(sprintf( "{0}, %d, %u, {%d}, {0}, Nullhv",
6085			       0, $hv->MAX, 0 ));
6086    }
6087    $svsect->add(sprintf("&xpvhv_list[%d], $u32fmt, 0x%x, {0}",
6088			 $xpvhvsect->index, $hv->REFCNT, $flags));
6089    # XXX failed at 16 (tied magic) for %main::
6090    if (!$is_stash and ($] >= 5.010 and $hv->FLAGS & SVf_OOK)) {
6091      $sym = sprintf("&sv_list[%d]", $svsect->index);
6092      my $hv_max = $hv->MAX + 1;
6093      # riter required, new _aux struct at the end of the HvARRAY. allocate ARRAY also.
6094      my $riter = ivx($hv->RITER);
6095      $init->add("{\tHE **a;",
6096                 "#ifdef PERL_USE_LARGE_HV_ALLOC",
6097                 sprintf("\tNewxz(a, PERL_HV_ARRAY_ALLOC_BYTES(%d) + sizeof(struct xpvhv_aux), HE*);",
6098                         $hv_max),
6099                 "#else",
6100                 sprintf("\tNewxz(a, %d + sizeof(struct xpvhv_aux), HE*);", $hv_max),
6101                 "#endif",
6102		 "\tHvARRAY($sym) = a;",
6103		 sprintf("\tHvRITER_set($sym, %s);", $riter),"}");
6104    }
6105  } # !5.10
6106  else {
6107    $xpvhvsect->comment( "array fill max keys nv mg stash riter eiter pmroot name" );
6108    $xpvhvsect->add(sprintf( "0, 0, %d, 0, 0.0, 0, Nullhv, %u, 0, 0, 0",
6109			     $hv->MAX, $hv->RITER));
6110    $svsect->add(sprintf( "&xpvhv_list[%d], $u32fmt, 0x%x",
6111			  $xpvhvsect->index, $hv->REFCNT, $hv->FLAGS));
6112  }
6113  $svsect->debug($fullname, $hv->flagspv) if $debug{flags};
6114  my $sv_list_index = $svsect->index;
6115  warn sprintf( "saving HV %s &sv_list[%d] 0x%x MAX=%d KEYS=%d\n",
6116                "%".$fullname, $sv_list_index, $$hv, $hv->MAX, $hv->KEYS ) if $debug{hv};
6117  # XXX B does not keep the UTF8 flag [RT 120535] #200
6118  # shared heks only since 5.10, our fixed C.xs variant
6119  my @contents = ($PERL510 && $hv->can('ARRAY_utf8')) ? $hv->ARRAY_utf8 : $hv->ARRAY;
6120  # protect against recursive self-reference
6121  # i.e. with use Moose at stash Class::MOP::Class::Immutable::Trait
6122  # value => rv => cv => ... => rv => same hash
6123  $sym = savesym( $hv, "(HV*)&sv_list[$sv_list_index]" ) unless $is_stash;
6124  push @B::C::static_free, $sym if $PERL518 and $hv->FLAGS & SVs_OBJECT;
6125
6126  if (@contents) {
6127    local $B::C::const_strings = $B::C::const_strings;
6128    my ($i, $length);
6129    $length = scalar(@contents);
6130    for ( $i = 1 ; $i < @contents ; $i += 2 ) {
6131      my $key = $contents[$i - 1]; # string only
6132      my $sv = $contents[$i];
6133      warn sprintf("HV recursion? with $fullname\{$key\} -> %s\n", $sv->RV)
6134        if ref($sv) eq 'B::RV'
6135          #and $sv->RV->isa('B::CV')
6136          and defined objsym($sv)
6137          and $debug{hv};
6138      if ($is_stash) {
6139	if (ref($sv) eq "B::GV" and $sv->NAME =~ /::$/) {
6140	  $sv = bless $sv, "B::STASHGV"; # do not expand stash GV's only other stashes
6141	  warn "saving STASH $fullname".'{'.$key."}\n" if $debug{hv};
6142	  $contents[$i] = $sv->save($fullname.'{'.$key.'}');
6143	} else {
6144	  warn "skip STASH symbol *",$fullname.$key,"\n" if $debug{hv};
6145	  $contents[$i] = undef;
6146	  $length -= 2;
6147	  # warn "(length=$length)\n" if $debug{hv};
6148	}
6149      } else {
6150	warn "saving HV \$".$fullname.'{'.$key."} $sv\n" if $debug{hv};
6151	$contents[$i] = $sv->save($fullname.'{'.$key.'}');
6152	#if ($key eq "" and $] >= 5.010) {
6153	#  warn "  turn off HvSHAREKEYS with empty keysv\n" if $debug{hv};
6154	#  $init->add("HvSHAREKEYS_off(&sv_list[$sv_list_index]);");
6155	#}
6156      }
6157    }
6158    if ($length) { # there may be skipped STASH symbols
6159      $init->no_split;
6160      $init->add( "{",
6161		  sprintf("\tHV *hv = %s%s;", $sym=~/^hv|\(HV/ ? '' : '(HV*)', $sym ));
6162      while (@contents) {
6163	my ( $key, $value ) = splice( @contents, 0, 2 );
6164	if ($value) {
6165          $value = "(SV*)$value" if $value !~ /^&sv_list/ or ($PERL510 and $] < 5.012);
6166          my ($cstring, $cur, $utf8) = strlen_flags($key);
6167	  # issue 272: if SvIsCOW(sv) && SvLEN(sv) == 0 => sharedhek (key == "")
6168	  # >= 5.10: SvSHARED_HASH: PV offset to hek_hash
6169          $cur = -$cur if $utf8;
6170	  $init->add(sprintf( "\thv_store(hv, %s, %d, %s, 0);",
6171			      $cstring, $cur, $value )); # !! randomized hash keys
6172	  warn sprintf( "  HV key \"%s\" = %s\n", $key, $value) if $debug{hv};
6173          if (!$swash_ToCf and $fullname =~ /^utf8::SWASHNEW/
6174              and $cstring eq '"utf8\034unicore/To/Cf.pl\0340"' and $cur == 23)
6175          {
6176            $swash_ToCf = $value;
6177            warn sprintf( "Found PL_utf8_tofold ToCf swash $value\n") if $verbose;
6178          }
6179	}
6180      }
6181      $init->add("}");
6182      $init->split;
6183      $init->add( sprintf("HvTOTALKEYS(%s) = %d;", $sym, $length / 2)) if !$PERL56;
6184    }
6185  } elsif ($PERL514) { # empty contents still needs to set keys=0
6186    # test 36, 140
6187    $init->add( "HvTOTALKEYS($sym) = 0;");
6188  }
6189  $magic = $hv->save_magic($fullname);
6190  $init->add( "SvREADONLY_on($sym);") if $hv->FLAGS & SVf_READONLY;
6191  if ($magic =~ /c/) {
6192    # defer AMT magic of XS loaded stashes
6193    my ($cname, $len, $utf8) = strlen_flags($name);
6194    $init2->add(qq[$sym = gv_stashpvn($cname, $len, GV_ADDWARN|GV_ADDMULTI|$utf8);]);
6195  }
6196  if ($PERL510 and $name and is_using_mro() and mro::get_mro($name) eq 'c3') {
6197    B::C::make_c3($name);
6198  }
6199  return $sym;
6200}
6201
6202sub B::IO::save_data {
6203  my ( $io, $sym, $globname, @data ) = @_;
6204  my $data = join '', @data;
6205  # XXX using $DATA might clobber it!
6206  my $ref = svref_2object( \\$data )->save;
6207  $init->add("/* save $globname in RV ($ref) */") if $verbose;
6208  $init->add( "GvSVn( $sym ) = (SV*)$ref;");
6209
6210  if ($PERL56) {
6211    # Pseudo FileHandle
6212    $init2->add_eval( sprintf 'open(%s, \'<\', $%s);', $globname, $globname );
6213  } else { # force inclusion of PerlIO::scalar as it was loaded in BEGIN.
6214    $init2->add_eval( sprintf 'open(%s, \'<:scalar\', $%s);', $globname, $globname );
6215    # => eval_pv("open(main::DATA, '<:scalar', $main::DATA);",1); DATA being a ref to $data
6216    $init->pre_destruct( sprintf 'eval_pv("close %s;", 1);', $globname );
6217    $use_xsloader = 1; # layers are not detected as XSUB CV, so force it
6218    require PerlIO unless $savINC{'PerlIO.pm'};
6219    require PerlIO::scalar unless $savINC{'PerlIO/scalar.pm'};
6220    mark_package("PerlIO", 1);
6221    $curINC{'PerlIO.pm'} = $INC{'PerlIO.pm'};  # as it was loaded from BEGIN
6222    mark_package("PerlIO::scalar", 1);
6223    $curINC{'PerlIO/scalar.pm'} = $INC{'PerlIO/scalar.pm'};
6224    $xsub{'PerlIO::scalar'} = 'Dynamic-'.$INC{'PerlIO/scalar.pm'}; # force dl_init boot
6225  }
6226}
6227
6228sub B::IO::save {
6229  my ($io, $fullname, $is_DATA) = @_;
6230  my $sym = objsym($io);
6231  return $sym if defined $sym;
6232  my $pv = $io->PV;
6233  $pv = '' unless defined $pv;
6234  my ( $pvsym, $len, $cur );
6235  if ($pv) {
6236    $pvsym = savepv($pv);
6237    $cur = $io->CUR;
6238  } else {
6239    $pvsym = 'NULL';
6240    $cur = 0;
6241  }
6242  if ($cur) {
6243    $len = $cur + 1;
6244    $len++ if IsCOW($io) and !$B::C::cow;
6245  } else {
6246    $len = 0;
6247  }
6248  warn sprintf( "IO $fullname sv_list[%d] 0x%x (%s) = '%s'\n", $svsect->index+1, $$io, $io->SvTYPE, $pv )
6249    if $debug{sv} and $] > 5.008; # no method "SvTYPE" via package "B::IO"
6250  if ($PERL514) {
6251    # IFP in sv.sv_u.svu_fp
6252    $xpviosect->comment("STASH, xmg_u, cur, len, xiv_u, xio_ofp, xio_dirpu, page, page_len, ..., type, flags");
6253    my $tmpl = "Nullhv, /*STASH later*/\n\t{0}, /*MAGIC later*/\n\t%u, /*cur*/\n\t%u, /*len*/\n\t{%d}, /*LINES*/\n\t0, /*OFP later*/\n\t{0}, /*dirp_u later*/\n\t%d, /*PAGE*/\n\t%d, /*PAGE_LEN*/\n\t%d, /*LINES_LEFT*/\n\t%s, /*TOP_NAME*/\n\tNullgv, /*top_gv later*/\n\t%s, /*fmt_name*/\n\tNullgv, /*fmt_gv later*/\n\t%s, /*bottom_name*/\n\tNullgv, /*bottom_gv later*/\n\t%s, /*type*/\n\t0x%x /*flags*/";
6254    $tmpl =~ s{ /\*.+?\*/\n\t}{}g unless $verbose;
6255    $tmpl =~ s{ /\*flags\*/$}{} unless $verbose;
6256    $xpviosect->add(
6257      sprintf($tmpl,
6258        $cur,                     $len,
6259	$io->LINES, 		  # moved to IVX with 5.11.1
6260        $io->PAGE,                $io->PAGE_LEN,
6261        $io->LINES_LEFT,          "NULL",
6262        "NULL",                   "NULL",
6263        cchar( $io->IoTYPE ),     $io->IoFLAGS
6264      )
6265    );
6266    $svsect->add(sprintf("&xpvio_list[%d], $u32fmt, 0x%x, {%s}",
6267                         $xpviosect->index, $io->REFCNT, $io->FLAGS,
6268			 $B::C::pv_copy_on_grow ? $pvsym : 0));
6269  }
6270  elsif ($] > 5.011000) {
6271    $xpviosect->comment("xnv_u, cur, len, lines, xmg_u, xmg_stash, xio_ifp, xio_ofp, xio_dirpu, ..., type, flags");
6272    my $tmpl = "{0}, /*xnv_u*/\n\t%u, /*cur*/\n\t%u, /*len*/\n\t{%d}, /*LINES*/\n\t{0}, /*MAGIC later*/\n\t(HV*)NULL, /*STASH  later*/\n\t0, /*IFP later*/\n\t0, /*OFP later*/\n\t{0}, /*dirp_u later*/\n\t%d, /*PAGE*/\n\t%d, /*PAGE_LEN*/\n\t%d, /*LINES_LEFT*/\n\t%s, /*TOP_NAME*/\n\tNullgv, /*top_gv later*/\n\t%s, /*fmt_name*/\n\tNullgv, /*fmt_gv later*/\n\t%s, /*bottom_name*/\n\tNullgv, /*bottom_gv later*/\n\t%s, /*type*/\n\t0x%x /*flags*/";
6273    $tmpl =~ s{ /\*.+?\*/\n\t}{}g unless $verbose;
6274    $tmpl =~ s{ /\*flags\*/$}{} unless $verbose;
6275    $xpviosect->add(
6276      sprintf($tmpl,
6277        $cur,                     $len,
6278	$io->LINES, 		  # moved to IVX with 5.11.1
6279        $io->PAGE,                $io->PAGE_LEN,
6280        $io->LINES_LEFT,          "NULL",
6281        "NULL",                   "NULL",
6282        cchar( $io->IoTYPE ),     $io->IoFLAGS
6283      )
6284    );
6285    $svsect->add(sprintf("&xpvio_list[%d], $u32fmt, 0x%x, {%s}",
6286                         $xpviosect->index, $io->REFCNT, $io->FLAGS,
6287			 $B::C::pv_copy_on_grow ? $pvsym : 0));
6288  }
6289  elsif ($PERL510) {
6290    $xpviosect->comment("xnv_u, cur, len, xiv_u, xmg_u, xmg_stash, xio_ifp, xio_ofp, xio_dirpu, lines, ..., type, flags");
6291    my $tmpl = "{0}, /*xnv_u*/\n\t%u, /*cur*/\n\t%u, /*len*/\n\t{%ld}, /*IVX*/\n\t{0}, /*MAGIC later*/\n\t(HV*)NULL, /*STASH  later*/\n\t0, /*IFP later*/\n\t0, /*OFP later*/\n\t{0}, /*dirp_u later*/\n\t%d, /*LINES*/\n\t%d, /*PAGE*/\n\t%d, /*PAGE_LEN*/\n\t%d, /*LINES_LEFT*/\n\t%s, /*TOP_NAME*/\n\tNullgv, /*top_gv later*/\n\t%s, /*fmt_name*/\n\tNullgv, /*fmt_gv later*/\n\t%s, /*bottom_name*/\n\tNullgv, /*bottom_gv later*/\n\t%s, /*type*/\n\t0x%x /*flags*/";
6292    $tmpl =~ s{ /\*[^\*]+?\*/\n\t}{}g unless $verbose;
6293    $tmpl =~ s{ /\*flags\*/$}{} unless $verbose;
6294    $xpviosect->add(
6295      sprintf($tmpl,
6296        $cur,                     $len,
6297        $io->IVX,
6298	$io->LINES,
6299        $io->PAGE,                $io->PAGE_LEN,
6300        $io->LINES_LEFT,          "NULL",
6301        "NULL",                   "NULL",
6302        cchar( $io->IoTYPE ),     $io->IoFLAGS
6303      )
6304    );
6305    $svsect->add(sprintf("&xpvio_list[%d], $u32fmt, 0x%x, {%s}",
6306                         $xpviosect->index, $io->REFCNT, $io->FLAGS,
6307			 $B::C::pv_copy_on_grow ? $pvsym : 0));
6308  }
6309  else { # 5.6 and 5.8
6310    $xpviosect->comment("xpv_pv, cur, len, iv, nv, magic, stash, xio_ifp, xio_ofp, xio_dirpu, ..., subprocess, type, flags");
6311    $xpviosect->add(
6312      sprintf("%s, %u, %u, %ld, %s, 0, 0, 0, 0, {0}, %d, %d, %d, %d, %s, Nullgv, %s, Nullgv, %s, Nullgv, %d, %s, 0x%x",
6313              $pvsym, 			   $cur, $len,
6314              $io->IVX,                    $io->NVX,
6315              $io->LINES,                  $io->PAGE,
6316              $io->PAGE_LEN,               $io->LINES_LEFT,
6317              "NULL",                      "NULL",
6318              "NULL",                      $io->SUBPROCESS,
6319              cchar( $io->IoTYPE ),        $io->IoFLAGS
6320      )
6321    );
6322    $svsect->add(sprintf("&xpvio_list[%d], $u32fmt, 0x%x",
6323                         $xpviosect->index, $io->REFCNT, $io->FLAGS));
6324  }
6325  $svsect->debug($fullname, $io->flagspv) if $debug{flags};
6326  $sym = savesym( $io, sprintf( "(IO*)&sv_list[%d]", $svsect->index ) );
6327
6328  if ($PERL510 and !$B::C::pv_copy_on_grow and $cur) {
6329    $init->add(sprintf("SvPVX(sv_list[%d]) = %s;", $svsect->index, $pvsym));
6330  }
6331  my ( $field );
6332  foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
6333    my $fsym = $io->$field();
6334    if ($$fsym) {
6335      $init->add( sprintf( "Io%s(%s) = (GV*)s\\_%x;", $field, $sym, $$fsym ) );
6336      $fsym->save;
6337    }
6338  }
6339  foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) {
6340    my $fsym = $io->$field;
6341    $init->add(sprintf("Io%s(%s) = savepvn(%s, %u);", $field, $sym,
6342                       cstring( $fsym ), length $fsym)) if $fsym;
6343  }
6344  $io->save_magic($fullname); # This handle the stash also (we need to inc the refcnt)
6345  if (!$PERL56 and !$is_DATA) { # PerlIO
6346    # deal with $x = *STDIN/STDOUT/STDERR{IO} and aliases
6347    my $perlio_func;
6348    # Note: all single-direction fp use IFP, just bi-directional pipes and
6349    # sockets use OFP also. But we need to set both, pp_print checks OFP.
6350    my $o = $io->object_2svref();
6351    eval "require ".ref($o).";";
6352    my $fd = $o->fileno();
6353    # use IO::Handle ();
6354    # my $fd = IO::Handle::fileno($o);
6355    my $i = 0;
6356    foreach (qw(stdin stdout stderr)) {
6357      if ($io->IsSTD($_) or (defined($fd) and $fd == -$i)) {
6358	$perlio_func = $_;
6359      }
6360      $i++;
6361    }
6362    if ($perlio_func) {
6363      $init->add("IoIFP(${sym}) = IoOFP(${sym}) = PerlIO_${perlio_func}();");
6364      #if ($fd < 0) { # fd=-1 signals an error
6365	# XXX print may fail at flush == EOF, wrong init-time?
6366      #}
6367    } else {
6368      my $iotype = $io->IoTYPE;
6369      my $ioflags = $io->IoFLAGS;
6370      # If an IO handle was opened at BEGIN, we try to re-init it, based on fd and IoTYPE.
6371      # IOTYPE:
6372      #  -    STDIN/OUT           HANDLE IoIOFP alias
6373      #  I    STDIN/OUT/ERR       HANDLE IoIOFP alias
6374      #  <    read-only           HANDLE fdopen
6375      #  >    write-only          HANDLE if fd<3 or IGNORE warn and comment
6376      #  a    append              HANDLE     -"-
6377      #  +    read and write      HANDLE fdopen
6378      #  s    socket              DIE
6379      #  |    pipe                DIE
6380      #  #    NUMERIC             HANDLE fdopen
6381      #  space closed             IGNORE
6382      #  \0   ex/closed?          IGNORE
6383      if ($iotype eq "\c@" or $iotype eq " ") {
6384	warn sprintf("Ignore closed IO Handle %s %s (%d)\n",
6385		     cstring($iotype), $fullname, $ioflags)
6386	  if $debug{gv};
6387      }
6388      elsif ($iotype =~ /[a>]/) { # write-only
6389	warn "Warning: Write BEGIN-block $fullname to FileHandle $iotype \&$fd\n"
6390	  if $fd >= 3 or $verbose;
6391	my $mode = $iotype eq '>' ? 'w' : 'a';
6392	#$init->add( sprintf("IoIFP($sym) = IoOFP($sym) = PerlIO_openn(aTHX_ NULL,%s,%d,0,0,NULL,0,NULL);",
6393	#		    cstring($mode), $fd));
6394	$init->add(sprintf( "%sIoIFP(%s) = IoOFP(%s) = PerlIO_fdopen(%d, %s);%s",
6395			    $fd<3?'':'/*', $sym, $sym, $fd, cstring($mode), $fd<3?'':'*/'));
6396      }
6397      elsif ($iotype =~ /[<#\+]/) {
6398        # skips warning if it's one of our PerlIO::scalar __DATA__ handles
6399	warn "Warning: Read BEGIN-block $fullname from FileHandle $iotype \&$fd\n"
6400	  if $fd >= 3 or $verbose; # need to setup it up before
6401	$init->add("/* XXX WARNING: Read BEGIN-block $fullname from FileHandle */",
6402		   "IoIFP($sym) = IoOFP($sym) = PerlIO_fdopen($fd, \"r\");");
6403	my $tell;
6404	if ($io->can("tell") and $tell = $io->tell()) {
6405	  $init->add("PerlIO_seek(IoIFP($sym), $tell, SEEK_SET);")
6406	}
6407      } else {
6408	# XXX We should really die here
6409	warn sprintf("ERROR: Unhandled BEGIN-block IO Handle %s\&%d (%d) from %s\n",
6410		     cstring($iotype), $fd, $ioflags, $fullname);
6411	$init->add("/* XXX WARNING: Unhandled BEGIN-block IO Handle ",
6412		   "IoTYPE=$iotype SYMBOL=$fullname, IoFLAGS=$ioflags */",
6413		   "IoIFP($sym) = IoOFP($sym) = PerlIO_fdopen($fd, \"$iotype\");");
6414      }
6415    }
6416  }
6417
6418  if ( $PERL518 ) {
6419    my $stash = $io->SvSTASH;
6420    if ($stash and $$stash) {
6421        my $stsym = $stash->save("%".$stash->NAME);
6422        $init->add(
6423              sprintf( "SvREFCNT(%s) += 1;", $stsym ),
6424              sprintf( "SvSTASH_set(%s, %s);", $sym, $stsym )
6425        );
6426        warn sprintf( "done saving STASH %s %s for IO %s\n", $stash->NAME, $stsym, $sym )
6427          if $debug{gv};
6428    }
6429  }
6430
6431  return $sym;
6432}
6433
6434sub B::SV::save {
6435  my $sv = shift;
6436
6437  # This is where we catch an honest-to-goodness Nullsv (which gets
6438  # blessed into B::SV explicitly) and any stray erroneous SVs.
6439  return 0 unless $$sv;
6440  warn sprintf( "cannot save that type of SV: %s (0x%x)\n", B::class($sv), $$sv );
6441}
6442
6443sub output_all {
6444  my $init_name = shift;
6445  my $section;
6446  return if $check;
6447
6448  my @sections =
6449    (
6450     $copsect,    $opsect,     $unopsect,  $binopsect, $logopsect, $condopsect,
6451     $listopsect, $pmopsect,   $svopsect,  $padopsect, $pvopsect,  $loopsect,
6452     $methopsect, $unopauxsect,
6453     $xpvsect,    $xpvavsect,  $xpvhvsect, $xpvcvsect, $padlistsect,
6454     $padnlsect,  $xpvivsect,  $xpvuvsect, $xpvnvsect, $xpvmgsect,   $xpvlvsect,
6455     $xrvsect,    $xpvbmsect,  $xpviosect, $svsect,    $padnamesect,
6456    );
6457  if ($PERL522) {
6458    pop @sections;
6459    for my $n (sort keys %padnamesect) {
6460      push @sections, $padnamesect{$n};
6461    }
6462  }
6463  if ($CPERL52) {
6464    for my $n (sort keys %avcowsect) {
6465      push @sections, $avcowsect{$n};
6466    }
6467    for my $n (sort keys %avcogsect) {
6468      push @sections, $avcogsect{$n};
6469    }
6470  }
6471  printf "\t/* %s */", $symsect->comment if $symsect->comment and $verbose;
6472  $symsect->output( \*STDOUT, "#define %s\n" );
6473  print "\n";
6474  output_declarations();
6475  # XXX add debug versions with ix=opindex if $debug{flags}
6476  foreach $section (@sections) {
6477    my $lines = $section->index + 1;
6478    if ($lines) {
6479      my $name = $section->name;
6480      my $typename = $section->typename;
6481      # static SV** arrays for AvSTATIC, HvSTATIC, ...
6482      if ($typename eq 'SV*' and $name =~ /^(?:avco[gw])_(\d+)$/) {
6483        my $n = $1;
6484        $typename = 'const SV*' if $name =~ /^avcow_/;
6485        print "Static $typename ${name}_list[$lines][$n];\n";
6486      } else {
6487        print "Static $typename ${name}_list[$lines];\n";
6488      }
6489    }
6490  }
6491  # avoid stack allocation of the cur_env chain, esp. for CC. use only one global PL_top_env
6492  print "dJMPENV;\n";
6493  # hack for when Perl accesses PVX of GVs
6494  print 'Static const char emptystring[] = "\0";',"\n";
6495  # newXS for core XS needs a filename
6496  print 'Static const char xsfile[] = "universal.c";',"\n";
6497  if ($MULTI) {
6498    print "#define ptr_undef 0\n";
6499  } else {
6500    if ($] > 5.01903) {
6501      print "#define ptr_undef NULL\n";
6502    } else {
6503      print "#define ptr_undef &PL_sv_undef\n";
6504    }
6505    if ($PERL510) { # XXX const sv SIGSEGV
6506      print "#undef CopFILE_set\n";
6507      print "#define CopFILE_set(c,pv)  CopFILEGV_set((c), gv_fetchfile(pv))\n";
6508    }
6509  }
6510  # print "#define MyPVX(sv) ".($] < 5.010 ? "SvPVX(sv)" : "((sv)->sv_u.svu_pv)")."\n";
6511  if ($] < 5.008008 ) {
6512    print <<'EOT';
6513#ifndef SvSTASH_set
6514#  define SvSTASH_set(sv,hv) SvSTASH((sv)) = (hv)
6515#endif
6516#ifndef Newxz
6517#  define Newxz(v,n,t) Newz(0,v,n,t)
6518#endif
6519EOT
6520  }
6521  if ($] < 5.008009 ) {
6522    print <<'EOT';
6523#ifndef SvREFCNT_inc_simple_NN
6524#  define SvREFCNT_inc_simple_NN(sv)     (++SvREFCNT(sv), (SV*)(sv))
6525#endif
6526#ifndef STR_WITH_LEN
6527  #define STR_WITH_LEN(s)  ("" s ""), (sizeof(s)-1)
6528#endif
6529EOT
6530  }
6531  if ($] < 5.013007 ) {
6532    print <<'EOT';
6533#ifndef CvSTASH_set
6534#  define CvSTASH_set(cv,hv) CvSTASH((cv)) = (hv)
6535#endif
6536EOT
6537  }
6538  if ($] < 5.013010 ) { # added with c43ae56ff9cd before 5.13.10 at 2011-01-21
6539    print <<'EOT';
6540#ifndef GvCV_set
6541#  define GvCV_set(gv,cv)   (GvCV(gv) = (cv))
6542#endif
6543#ifndef GvGP_set
6544#  define GvGP_set(gv,gp)   (GvGP(gv) = (gp))
6545#endif
6546EOT
6547  }
6548  if ($] >= 5.021005 and $] < 5.023) {
6549    print <<'EOT';
6550/* PadlistNAMES broken as lvalue with v5.21.6-197-g0f94cb1,
6551   fixed with 5.22.1 and 5.23.0 */
6552#if (PERL_VERSION == 22) || ( PERL_VERSION == 21 && PERL_SUBVERSION > 5)
6553# undef PadlistNAMES
6554# define PadlistNAMES(pl)       *((PADNAMELIST **)PadlistARRAY(pl))
6555#endif
6556EOT
6557  }
6558  # handy accessors only in cperl for now:
6559  print <<'EOT';
6560#ifndef get_svs
6561#  define get_svs(str, flags) get_sv((str), (flags))
6562#  define get_avs(str, flags) get_av((str), (flags))
6563#  define get_hvs(str, flags) get_hv((str), (flags))
6564#endif
6565EOT
6566  if (%init2_remap and !$HAVE_DLFCN_DLOPEN) {
6567    print <<'EOT';
6568XS(XS_DynaLoader_dl_load_file);
6569XS(XS_DynaLoader_dl_find_symbol);
6570EOT
6571  }
6572  printf "\t/* %s */\n", $decl->comment if $decl->comment and $verbose;
6573  $decl->output( \*STDOUT, "%s\n" );
6574  print "\n";
6575
6576  foreach $section (@sections) {
6577    my $lines = $section->index + 1;
6578    if ($lines) {
6579      my $name = $section->name;
6580      my $typename = $section->typename;
6581      # static SV** arrays for AvSTATIC, HvSTATIC, ...
6582      if ($typename eq 'SV*' and $name =~ /^(?:avco[wg])_(\d+)$/) {
6583        my $n = $1;
6584        $typename = 'const SV*' if $name =~ /^avcow_/;
6585        printf "Static %s %s_list[%u][%u] = {\n", $typename, $name, $lines, $n;
6586      } else {
6587        printf "Static %s %s_list[%u] = {\n", $typename, $name, $lines;
6588      }
6589      printf "\t/* %s */\n", $section->comment
6590        if $section->comment and $verbose;
6591      $section->output( \*STDOUT, "\t{ %s }, /* %s_list[%d] %s */%s\n" );
6592      print "};\n\n";
6593    }
6594  }
6595
6596  output_functions();
6597  fixup_ppaddr();
6598  print "static void perl_init0(pTHX) /* fixup_ppaddr */\n{\n\t";
6599  print "dVAR; register int i;\n" if @{ $init0->[-1]{values} };
6600  $init0->output( \*STDOUT, "\t%s\n" );
6601  print "};\n\n";
6602
6603  printf "\t/* %s */\n", $init->comment if $init->comment and $verbose;
6604  $init->output( \*STDOUT, "\t%s\n", $init_name );
6605  printf "/* deferred init1 of regexp */\n" if $verbose;
6606  printf "/* %s */\n", $init1->comment if $init1->comment and $verbose;
6607  $init1->output( \*STDOUT, "\t%s\n", 'perl_init1' );
6608  my $init2_name = 'perl_init2';
6609  printf "/* deferred init of XS/Dyna loaded modules */\n" if $verbose;
6610  printf "/* %s */\n", $init2->comment if $init2->comment and $verbose;
6611  my $remap = 0;
6612  for my $pkg (sort keys %init2_remap) {
6613    if (exists $xsub{$pkg}) { # check if not removed in between
6614      my ($stashfile) = $xsub{$pkg} =~ /^Dynamic-(.+)$/;
6615      # get so file from pm. Note: could switch prefix from vendor/site//
6616      if ($stashfile) {
6617        $init2_remap{$pkg}{FILE} = dl_module_to_sofile($pkg, $stashfile);
6618        $remap++;
6619      }
6620    }
6621  }
6622  if ($remap) {
6623    # XXX now emit arch-specific dlsym code
6624    $init2->no_split;
6625    $init2->add("{");
6626    if ($HAVE_DLFCN_DLOPEN) {
6627      $init2->add("  #include <dlfcn.h>");
6628      $init2->add("  void *handle;");
6629    } else {
6630      $init2->add("  void *handle;");
6631      $init2->add("  dTARG; dSP;",
6632                  "  targ=sv_newmortal();");
6633    }
6634    for my $pkg (sort keys %init2_remap) {
6635      if (exists $xsub{$pkg}) {
6636        if ($HAVE_DLFCN_DLOPEN) {
6637          my $ldopt = 'RTLD_NOW|RTLD_NOLOAD';
6638          $ldopt = 'RTLD_NOW' if $Config{osname} =~ /bsd/i; # 351 (only on solaris and linux, not any bsd)
6639          $init2->add( "", sprintf("  handle = dlopen(%s, %s);", cstring($init2_remap{$pkg}{FILE}), $ldopt));
6640        }
6641        else {
6642          $init2->add("  PUSHMARK(SP);",
6643              sprintf("  XPUSHs(newSVpvs(%s));", cstring($init2_remap{$pkg}{FILE})),
6644                      "  PUTBACK;",
6645                      "  XS_DynaLoader_dl_load_file(aTHX_ NULL);",
6646                      "  SPAGAIN;",
6647                      "  handle = INT2PTR(void*,POPi);",
6648                      "  PUTBACK;",
6649                     );
6650        }
6651        for my $mg (@{$init2_remap{$pkg}{MG}}) {
6652          warn "init2 remap xpvmg_list[$mg->{ID}].xiv_iv to dlsym of $pkg\: $mg->{NAME}\n"
6653            if $verbose;
6654          if ($HAVE_DLFCN_DLOPEN) {
6655            $init2->add(sprintf("  xpvmg_list[%d].xiv_iv = PTR2IV( dlsym(handle, %s) );",
6656                                $mg->{ID}, cstring($mg->{NAME})));
6657          } else {
6658            $init2->add("  PUSHMARK(SP);",
6659                        "  XPUSHi(PTR2IV(handle));",
6660                sprintf("  XPUSHs(newSVpvs(%s));", cstring($mg->{NAME})),
6661                        "  PUTBACK;",
6662                        "  XS_DynaLoader_dl_find_symbol(aTHX_ NULL);",
6663                        "  SPAGAIN;",
6664                sprintf("  xpvmg_list[%d].xiv_iv = POPi;", $mg->{ID}),
6665                        "  PUTBACK;",
6666                       );
6667          }
6668        }
6669      }
6670    }
6671    $init2->add("}");
6672    $init2->split;
6673  }
6674  $init2->output( \*STDOUT, "\t%s\n", $init2_name );
6675  if ($verbose) {
6676    my $caller = caller;
6677    warn $caller eq 'B::CC' ? B::CC::compile_stats() : compile_stats();
6678    warn "NULLOP count: $nullop_count\n";
6679  }
6680}
6681
6682sub output_declarations {
6683  print <<'EOT';
6684#define UNUSED 0
6685#define sym_0 0
6686
6687static void
6688my_mg_RC_off(pTHX_ SV* sv, int type) {
6689  MAGIC *mg;
6690  for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
6691    if (mg->mg_type == type && (mg->mg_flags | MGf_REFCOUNTED))
6692      mg->mg_flags &= ~MGf_REFCOUNTED;
6693  }
6694}
6695
6696EOT
6697  if ($PERL510 and IS_MSVC) {
6698    # initializing char * differs in levels of indirection from int
6699    print "#pragma warning( disable : 4047 )\n";
6700    # targ: unreferenced local variable
6701    print "#pragma warning( disable : 4101 )\n";
6702  }
6703
6704  # Need fresh re-hash of strtab. share_hek does not allow hash = 0
6705  if ( $PERL510 ) {
6706     print <<'_EOT0';
6707PERL_STATIC_INLINE HEK *
6708my_share_hek( pTHX_ const char *str, I32 len );
6709#undef share_hek
6710#define share_hek(str, len) my_share_hek( aTHX_ str, len );
6711
6712PERL_STATIC_INLINE HEK *
6713my_share_hek_0( pTHX_ const char *str, I32 len);
6714
6715#define HEK_HE(hek)							\
6716    ((struct shared_he *)(((char *)(hek))				\
6717			      - STRUCT_OFFSET(struct shared_he,		\
6718					      shared_he_hek)))
6719#define HEK_shared_he(hek)						\
6720    ((struct shared_he *)(((char *)(hek))				\
6721			      - STRUCT_OFFSET(struct shared_he,		\
6722					      shared_he_hek)))		\
6723	->shared_he_he
6724
6725#define hek_hek_refcount(hek)						\
6726    HEK_shared_he(hek).he_valu.hent_refcount
6727
6728#define unshare_hek_hek(hek)   --(hek_hek_refcount(hek))
6729
6730_EOT0
6731
6732  }
6733  if ($PERL522) {
6734    print <<'EOF';
6735/* unfortunately we have to override this perl5.22 struct.
6736   The Padname string buffer in xpadn_str is pointed by xpadn_pv.
6737    */
6738#define _PADNAME_BASE \
6739    char *	xpadn_pv;		\
6740    HV *	xpadn_ourstash;		\
6741    union {				\
6742	HV *	xpadn_typestash;	\
6743	CV *	xpadn_protocv;		\
6744    } xpadn_type_u;			\
6745    U32		xpadn_low;		\
6746    U32		xpadn_high;		\
6747    U32		xpadn_refcnt;		\
6748    int		xpadn_gen;		\
6749    U8		xpadn_len;		\
6750    U8		xpadn_flags
6751
6752#ifdef PERL_PADNAME_MINIMAL
6753#define MY_PADNAME_BASE _PADNAME_BASE
6754#else
6755#define MY_PADNAME_BASE struct padname	xpadn_padname
6756#endif
6757
6758EOF
6759
6760    for my $s (sort keys %padnamesect) {
6761      if ($padnamesect{$s}->index >= 0) {
6762        print <<"EOF";
6763struct my_padname_with_str_$s {
6764    MY_PADNAME_BASE;
6765    char	xpadn_str[$s];
6766};
6767typedef struct my_padname_with_str_$s PADNAME_$s;
6768EOF
6769      }
6770    }
6771  #} elsif ($PERL518) {
6772  #  print "typedef PADNAME MyPADNAME;\n";
6773  }
6774  if ($PERL510 and !$PERL514) {
6775    print "typedef struct refcounted_he COPHH;\n";
6776    print <<'EOF';
6777#define cophh_store_pvn(cophh, keypv, keylen, hash, value, flags) \
6778    Perl_refcounted_he_new(aTHX_ cophh, newSVpvn_flags(keypv, keylen, flags), value)
6779#define cophh_store_pvs(cophh, key, value, flags) \
6780    Perl_refcounted_he_new(aTHX_ cophh, Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN(key), SVs_TEMP), value)
6781#define CopHINTHASH_set(c,h)	((c)->cop_hints_hash = (h))
6782EOF
6783  }
6784  if ($B::C::Config::have_HEK_STATIC) {
6785    print "/* store full char[] to avoid excess elements in array\n";
6786    print "   (HEK only declared as char[1]) */\n";
6787    print "struct hek_ptr { U32 hek_hash; I32 hek_len; char hek_key[]; };\n";
6788  }
6789  # Tricky hack for -fcog since 5.10 on !c99 compilers required. We need a char* as
6790  # *first* sv_u element to be able to statically initialize it. A int does not allow it.
6791  # gcc error: initializer element is not computable at load time
6792  # We introduce a SVPV as SV.
6793  # In core since 5.12
6794  if ($PERL510 and $] < 5.012 and !$C99) {
6795    print <<'EOT0';
6796typedef struct svpv {
6797    void *	sv_any;
6798    U32		sv_refcnt;
6799    U32		sv_flags;
6800    union {
6801	char*   svu_pv;
6802	IV      svu_iv;
6803	UV      svu_uv;
6804	SV*     svu_rv;
6805	SV**    svu_array;
6806	HE**	svu_hash;
6807	GP*	svu_gp;
6808    } sv_u;
6809#ifdef DEBUG_LEAKING_SCALARS
6810    PERL_BITFIELD32 sv_debug_optype:9;
6811    PERL_BITFIELD32 sv_debug_inpad:1;
6812    PERL_BITFIELD32 sv_debug_cloned:1;
6813    PERL_BITFIELD32 sv_debug_line:16;
6814# if PERL_VERSION < 11
6815    U32		sv_debug_serial;	/* 5.10 only */
6816# endif
6817# if PERL_VERSION > 8
6818    char *	sv_debug_file;
6819# endif
6820#endif
6821} SVPV;
6822EOT0
6823
6824  }
6825  if ($PERL512) {
6826    print "typedef struct p5rx RE;\n";
6827  }
6828  elsif ($PERL510) {
6829    print "typedef SV * RE;\n";
6830  }
6831  else {
6832    print "typedef char * RE;\n";
6833  }
6834  if ($] == 5.010000) {
6835    print "#ifndef RX_EXTFLAGS\n";
6836    print "# define RX_EXTFLAGS(rx) ((rx)->extflags)\n";
6837    print "#endif\n";
6838  }
6839  if ($] >= 5.021001 and !$CPERL52) {
6840    print "Static IV PL_sv_objcount = 0; /* deprecated with 5.21.1 but still needed and used */\n";
6841  }
6842  print "SV* sv;\n";
6843  print "Static GV *gv_list[$gv_index];\n" if $gv_index;
6844}
6845
6846sub output_boilerplate {
6847  my $name = shift;
6848  $name = 'main' unless defined $name;
6849  my $creator = "created at ".scalar localtime()." with B::C $B::C::VERSION";
6850  $creator .= $B::C::REVISION if $B::C::REVISION;
6851  $creator .= " for $Config{perlpath}";
6852  $creator .= " for cross target $Config{archname}" if $cross;
6853  print "/* $creator */\n";
6854  # Store the sv_list index in sv_debug_file when debugging
6855  print "#define DEBUG_LEAKING_SCALARS 1\n" if $debug{flags} and $DEBUG_LEAKING_SCALARS;
6856  if ($B::C::Config::have_independent_comalloc) {
6857    print <<'_EOT1';
6858#ifdef NEED_MALLOC_283
6859# include "malloc-2.8.3.h"
6860#endif
6861_EOT1
6862
6863  }
6864  print <<'_EOT2';
6865#define PERL_CORE
6866#include "EXTERN.h"
6867#include "perl.h"
6868#include "XSUB.h"
6869
6870/* Workaround for mapstart: the only op which needs a different ppaddr */
6871#undef Perl_pp_mapstart
6872#define Perl_pp_mapstart Perl_pp_grepstart
6873#undef OP_MAPSTART
6874#define OP_MAPSTART OP_GREPSTART
6875
6876#ifdef BROKEN_STATIC_REDECL
6877#define Static extern
6878#else
6879#define Static static
6880#endif /* BROKEN_STATIC_REDECL */
6881
6882#ifdef BROKEN_UNION_INIT
6883#error BROKEN_UNION_INIT no longer needed, as Perl requires an ANSI compiler
6884#endif
6885
6886/* No longer available when C<PERL_CORE> is defined. */
6887#ifndef Nullsv
6888#  define Null(type) ((type)NULL)
6889#  define Nullsv Null(SV*)
6890#  define Nullhv Null(HV*)
6891#  define Nullgv Null(GV*)
6892#  define Nullop Null(OP*)
6893#endif
6894#ifndef GV_NOTQUAL
6895#  define GV_NOTQUAL 0
6896#endif
6897/* Since 5.8.8 */
6898#ifndef Newx
6899#  define Newx(v,n,t)    New(0,v,n,t)
6900#endif
6901/* Since 5.14 */
6902#if !defined(PERL_STATIC_INLINE)
6903#  ifdef HAS_STATIC_INLINE
6904#    define PERL_STATIC_INLINE static inline
6905#  else
6906#    define PERL_STATIC_INLINE static
6907#  endif
6908#endif
6909/* cperl compat */
6910#ifndef HEK_STATIC
6911# define HEK_STATIC(hek) 0
6912#endif
6913
6914#if defined(PERL_GLOBAL_STRUCT_PRIVATE)
6915 static struct perl_vars* my_plvarsp;
6916 struct perl_vars* Perl_GetVarsPrivate(void) { return my_plvarsp; }
6917#endif
6918
6919_EOT2
6920
6921  if ($] < 5.008008) {
6922    print "#define GvSVn(s) GvSV(s)\n";
6923  }
6924
6925  # XXX boot_DynaLoader is exported only >=5.8.9
6926  # does not compile on darwin with EXTERN_C declaration
6927  # See branch `boot_DynaLoader`
6928  print <<'_EOT4';
6929
6930#define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
6931EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
6932
6933static void xs_init (pTHX);
6934static void dl_init (pTHX);
6935_EOT4
6936
6937  print <<'_EOT' if $CPERL51 and $^O ne 'MSWin32';
6938EXTERN_C void dl_boot (pTHX);
6939_EOT
6940
6941  if ($B::C::av_init2 and $B::C::Config::use_declare_independent_comalloc) {
6942    print "void** dlindependent_comalloc(size_t, size_t*, void**);\n";
6943  }
6944  if ($B::C::av_init2) {
6945    my $last = $xpvavsect->index;
6946    my $size = $last + 1;
6947    if ($last) {
6948      $decl->add("Static void* avchunks[$size];");
6949      $decl->add("Static size_t avsizes[$size] = ");
6950      my $ptrsize = $Config{ptrsize};
6951      my $acc = "";
6952      for (0..$last) {
6953	if ($xpvav_sizes[$_] > 0) {
6954	  $acc .= $xpvav_sizes[$_] * $ptrsize;
6955	} else {
6956	  $acc .= 3 * $ptrsize;
6957	}
6958	$acc .= "," if $_ != $last;
6959	$acc .= "\n\t" unless ($_+1) % 30;
6960      }
6961      $decl->add("\t{$acc};");
6962      $init->add_initav("if (!independent_comalloc( $size, avsizes, avchunks ))");
6963      $init->add_initav("    Perl_die(aTHX_ \"panic: AV alloc failed\");");
6964    }
6965  }
6966  # XXX boot_DynaLoader is exported only >=5.8.9
6967  # does not compile on darwin with EXTERN_C declaration
6968  # See branch `boot_DynaLoader`
6969  print <<'_EOT4';
6970#define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
6971EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
6972
6973static void xs_init (pTHX);
6974static void dl_init (pTHX);
6975
6976_EOT4
6977
6978  print <<'_EOT' if $CPERL51;
6979EXTERN_C void dl_boot (pTHX);
6980_EOT
6981
6982  if ( !$B::C::destruct ) {
6983    print <<'_EOT4';
6984static int fast_perl_destruct( PerlInterpreter *my_perl );
6985static void my_curse( pTHX_ SV* const sv );
6986
6987#ifndef dVAR
6988# if defined(PERL_GLOBAL_STRUCT) || defined(PERL_GLOBAL_STRUCT_PRIVATE)
6989#  define dVAR		pVAR    = (struct perl_vars*)PERL_GET_VARS()
6990# else
6991#  define dVAR		dNOOP
6992# endif
6993#endif
6994_EOT4
6995
6996  } else {
6997    if (defined $module and !$ITHREADS) {
6998      print "EXTERN_C void destruct_$name( );\n";
6999    } else {
7000      print "EXTERN_C void destruct_$name( PerlInterpreter *my_perl );\n";
7001    }
7002  }
7003}
7004
7005sub output_functions {
7006
7007  if ($] < 5.008009) {
7008    print <<'_EOT3';
7009
7010#ifndef savesharedpvn
7011PERL_STATIC_INLINE char *savesharedpvn(const char *const s, const STRLEN len);
7012
7013PERL_STATIC_INLINE char *
7014savesharedpvn(const char *const s, const STRLEN len) {
7015  char *const d = (char*)PerlMemShared_malloc(len + 1);
7016  if (!d) { exit(1); }
7017  d[len] = '\0';
7018  return (char *)memcpy(d, s, len);
7019}
7020#endif
7021_EOT3
7022
7023  }
7024
7025  # Need fresh re-hash of strtab. share_hek does not allow hash = 0
7026  if ( $PERL510 ) {
7027    print <<'_EOT7';
7028/* The first assignment got already refcount bumped */
7029PERL_STATIC_INLINE HEK *
7030my_share_hek( pTHX_ const char *str, I32 len) {
7031    U32 hash;
7032    dVAR;
7033    PERL_HASH(hash, str, abs(len));
7034    return share_hek_hek(Perl_share_hek(aTHX_ str, len, hash));
7035}
7036
7037_EOT7
7038  }
7039  if ( $PERL510 ) {
7040    print <<'_EOT7';
7041PERL_STATIC_INLINE HEK *
7042my_share_hek_0( pTHX_ const char *str, I32 len) {
7043    U32 hash;
7044    dVAR;
7045    PERL_HASH(hash, str, abs(len));
7046    return Perl_share_hek(aTHX_ str, len, hash);
7047}
7048
7049_EOT7
7050  }
7051
7052  # -fno-destruct only >=5.8
7053  if ( !$module and !$B::C::destruct ) {
7054    print <<'_EOT8';
7055
7056#ifndef SvDESTROYABLE
7057#define SvDESTROYABLE(sv) 1
7058#endif
7059/* 5.8 */
7060#ifndef CvISXSUB
7061#define CvISXSUB(sv) CvXSUB(sv)
7062#endif
7063#ifndef SvRV_set
7064#define SvRV_set(a,b) SvRV(a) = (b)
7065#endif
7066/* 5.6 */
7067#ifndef PERL_EXIT_DESTRUCT_END
7068#define PERL_EXIT_DESTRUCT_END 2
7069#endif
7070
7071static void
7072my_curse( pTHX_ SV* const sv ) {
7073    dSP;
7074    dVAR;
7075    HV* stash;
7076
7077#if PERL_VERSION > 7
7078    assert(SvOBJECT(sv));
7079    do {
7080        stash = SvSTASH(sv);
7081        assert(SvTYPE(stash) == SVt_PVHV);
7082	if (HvNAME(stash)) {
7083	    CV* destructor = NULL;
7084	    if (!SvOBJECT(stash)) destructor = (CV *)SvSTASH(stash);
7085	    if (!destructor
7086#if (PERL_VERSION > 18) || (PERL_VERSION == 18 && PERL_SUBVERSION > 1)
7087                || HvMROMETA(stash)->destroy_gen != PL_sub_generation
7088#endif
7089	    ) {
7090		GV * const gv = gv_fetchmeth_autoload(stash, "DESTROY", 7, 0);
7091		if (gv) {
7092                    destructor = GvCV(gv);
7093		    if (!SvOBJECT(stash)) {
7094		        SvSTASH(stash) =
7095			    destructor ? (HV *)destructor : ((HV *)0)+1;
7096#if (PERL_VERSION > 18) || (PERL_VERSION == 18 && PERL_SUBVERSION > 1)
7097		        HvAUX(stash)->xhv_mro_meta->destroy_gen = PL_sub_generation;
7098#endif
7099                    }
7100		}
7101	    }
7102	    assert(!destructor || destructor == ((CV *)0)+1
7103		   || SvTYPE(destructor) == SVt_PVCV);
7104	    if (destructor && destructor != ((CV *)0)+1
7105		/* A constant subroutine can have no side effects, so
7106		   don't bother calling it.  */
7107		&& !CvCONST(destructor)
7108		/* Don't bother calling an empty destructor or one that
7109		   returns immediately. */
7110		&& (CvISXSUB(destructor)
7111		|| (CvSTART(destructor)
7112		    && (CvSTART(destructor)->op_next->op_type != OP_LEAVESUB)
7113		    && (CvSTART(destructor)->op_next->op_type != OP_PUSHMARK
7114			|| CvSTART(destructor)->op_next->op_next->op_type != OP_RETURN
7115		       )
7116		   ))
7117	       )
7118	    {
7119		SV* const tmpref = newRV(sv);
7120		DEBUG_D(PerlIO_printf(Perl_debug_log, "Calling %s::DESTROY\n", HvNAME(stash)));
7121		SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
7122		ENTER;
7123		PUSHSTACKi(PERLSI_DESTROY);
7124		EXTEND(SP, 2);
7125		PUSHMARK(SP);
7126		PUSHs(tmpref);
7127		PUTBACK;
7128		call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
7129		POPSTACK;
7130		SPAGAIN;
7131		LEAVE;
7132		if(SvREFCNT(tmpref) < 2) {
7133		    /* tmpref is not kept alive! */
7134		    SvREFCNT(sv)--;
7135		    SvRV_set(tmpref, NULL);
7136		    SvROK_off(tmpref);
7137		}
7138		SvREFCNT_dec(tmpref);
7139	    }
7140	}
7141    } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
7142
7143    if (SvOBJECT(sv)) {
7144	/* Curse before freeing the stash, as freeing the stash could cause
7145	   a recursive call into S_curse. */
7146	SvOBJECT_off(sv);	/* Curse the object. */
7147	SvSTASH_set(sv,0);	/* SvREFCNT_dec may try to read this */
7148    }
7149#endif
7150}
7151
7152static int fast_perl_destruct( PerlInterpreter *my_perl ) {
7153    dVAR;
7154    volatile signed char destruct_level;  /* see possible values in intrpvar.h */
7155    HV *hv;
7156#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
7157    pid_t child;
7158#endif
7159
7160#ifndef MULTIPLICITY
7161#   ifndef PERL_UNUSED_ARG
7162#     define PERL_UNUSED_ARG(x) ((void)x)
7163#   endif
7164    PERL_UNUSED_ARG(my_perl);
7165#endif
7166
7167    assert(PL_scopestack_ix == 1);
7168
7169    /* wait for all pseudo-forked children to finish */
7170#if !defined(WIN32) || (defined(USE_CPERL) && PERL_VERSION >= 24)
7171    PERL_WAIT_FOR_CHILDREN;
7172#endif
7173
7174    destruct_level = PL_perl_destruct_level;
7175#ifdef DEBUGGING
7176    {
7177	const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
7178	if (s) {
7179            const int i = atoi(s);
7180#ifdef DEBUGGING
7181	    if (destruct_level < i) destruct_level = i;
7182#endif
7183#ifdef PERL_TRACK_MEMPOOL
7184            /* RT #114496, for perl_free */
7185            PL_perl_destruct_level = i;
7186#endif
7187	}
7188    }
7189#endif
7190
7191    if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
7192        int x = 0;
7193
7194        JMPENV_PUSH(x);
7195        if (PL_endav && !PL_minus_c) {
7196#if PERL_VERSION > 13
7197	    PL_phase = PERL_PHASE_END;
7198#endif
7199            call_list(PL_scopestack_ix, PL_endav);
7200        }
7201        JMPENV_POP;
7202    }
7203_EOT8
7204
7205    for (0 .. $#B::C::static_free) {
7206      # set static op members to NULL
7207      my $s = $B::C::static_free[$_];
7208      if ($s =~ /\(OP\*\)&unopaux_list/) {
7209	print "    ($s)->op_type = OP_NULL;\n";
7210      }
7211    }
7212
7213    print <<'_EOT9';
7214    LEAVE;
7215    FREETMPS;
7216    assert(PL_scopestack_ix == 0);
7217
7218    /* Need to flush since END blocks can produce output */
7219    my_fflush_all();
7220
7221    PL_main_start = NULL;
7222    PL_main_cv = NULL;
7223    PL_curcop = &PL_compiling;
7224#if PERL_VERSION >= 13
7225    PL_phase = PERL_PHASE_DESTRUCT;
7226#endif
7227
7228#if PERL_VERSION > 7
7229    if (PL_threadhook(aTHX)) {
7230        /* Threads hook has vetoed further cleanup */
7231#if (PERL_VERSION > 8) || ((PERL_VERSION == 8) && (PERL_SUBVERSION > 8))
7232	PL_veto_cleanup = TRUE;
7233        return STATUS_EXIT;
7234#else
7235        return STATUS_NATIVE_EXPORT;
7236#endif
7237    }
7238#if defined(PERLIO_LAYERS)
7239# if !defined(WIN32) || (defined(USE_CPERL) && PERL_VERSION >= 24)
7240    PerlIO_destruct(aTHX);
7241# endif
7242#endif
7243
7244    /* B::C -O3 specific: first curse (i.e. call DESTROY) all our static SVs */
7245    if (PL_sv_objcount) {
7246        int i = 1;
7247        DEBUG_D(PerlIO_printf(Perl_debug_log, "\nCursing named global static sv_arena:\n"));
7248        PL_in_clean_all = 1;
7249        for (; i < SvREFCNT(&sv_list[0]); i++) {
7250            SV *sv = &sv_list[i];
7251            if (SvREFCNT(sv)) {
7252#if PERL_VERSION > 11
7253                if (SvTYPE(sv) == SVt_IV && SvROK(sv))
7254#else
7255                if (SvTYPE(sv) == SVt_RV)
7256#endif
7257                    sv = SvRV(sv);
7258                if (sv && SvOBJECT(sv) && SvTYPE(sv) >= SVt_PVMG && SvSTASH(sv)
7259                    && SvTYPE(sv) != SVt_PVCV && SvTYPE(sv) != SVt_PVIO
7260                    && PL_defstash /* Still have a symbol table? */
7261                    && SvDESTROYABLE(sv))
7262                {
7263	            SvREFCNT(sv) = 0;
7264                    my_curse(aTHX_ sv);
7265                }
7266            }
7267        }
7268    }
7269    if (DEBUG_D_TEST) {
7270        SV* sva;
7271        PerlIO_printf(Perl_debug_log, "sv[0]: 0x%p, sv_arenaroot: 0x%p, sva->any: 0x%p\n",
7272                      SvANY(&sv_list[0]), PL_sv_arenaroot, SvANY(PL_sv_arenaroot));
7273        for (sva = PL_sv_arenaroot;
7274             sva;
7275             sva = (sva == (SV*)SvANY(sva)) ? NULL : (SV*)SvANY(sva))
7276        {
7277            PerlIO_printf(Perl_debug_log, "sv_arena: 0x%p - 0x%p (%lu)\n",
7278              sva, sva+SvREFCNT(sva), (long)SvREFCNT(sva));
7279        }
7280    }
7281#endif
7282
7283#if PERL_VERSION > 7
7284    PL_stashcache = (HV*)&PL_sv_undef; /* sometimes corrupted */
7285#endif
7286#if !defined(WIN32) || (defined(USE_CPERL) && PERL_VERSION >= 24)
7287    if (PL_sv_objcount) {
7288# if PERL_VERSION > 7
7289        PL_stashcache = newHV(); /* Hack: sometimes corrupted, holding a GV */
7290# endif
7291	PL_in_clean_all = 1;
7292	sv_clean_objs();         /* and now curse the rest */
7293	PL_sv_objcount = 0;
7294    }
7295#endif
7296
7297    PL_warnhook = NULL;
7298    PL_diehook = NULL;
7299    /* call exit list functions */
7300    while (PL_exitlistlen-- > 0)
7301	PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
7302    PL_exitlist = NULL;
7303
7304#if defined(PERLIO_LAYERS)
7305# if !defined(WIN32) || (defined(USE_CPERL) && PERL_VERSION >= 24)
7306    PerlIO_cleanup(aTHX);
7307# endif
7308#endif
7309
7310#if PERL_VERSION > 7
7311    PL_stashcache = (HV*)&PL_sv_undef;
7312#endif
7313    /* Silence strtab refcnt warnings during global destruction */
7314    Zero(HvARRAY(PL_strtab), HvMAX(PL_strtab), HE*);
7315    /* NULL the HEK "dfs" */
7316#if PERL_VERSION > 10
7317    PL_registered_mros = (HV*)&PL_sv_undef;
7318    CopHINTHASH_set(&PL_compiling, NULL);
7319#endif
7320
7321    return 0;
7322}
7323_EOT9
7324
7325  }
7326}
7327
7328sub init_op_addr {
7329  my ( $op_type, $num ) = @_;
7330  my $op_list = $op_type . "_list";
7331
7332  $init0->add( split /\n/, <<_EOT6 );
7333for (i = 0; i < ${num}; ++i) {
7334	${op_list}\[i].op_ppaddr = PL_ppaddr[PTR2IV(${op_list}\[i].op_ppaddr)];
7335}
7336_EOT6
7337
7338}
7339
7340# local destruction code
7341sub save_destruct {
7342  my $name = shift;
7343  $name = 'main' unless defined $name;
7344  # special COW handling for 5.10 because of S_unshare_hek_or_pvn limitations
7345  # XXX This fails in S_doeval SAVEFREEOP(PL_eval_root): test 15
7346  # if ( $PERL510 and (@B::C::static_free or $free->index > -1))
7347  if ( $B::C::destruct ) {
7348    print "
7349EXTERN_C void destruct_${name} ( PerlInterpreter *my_perl ) {
7350";
7351    print <<'_EOT7';
7352    volatile signed char destruct_level = PL_perl_destruct_level;
7353    const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
7354    dVAR;
7355
7356    /* set all our static pv and hek to &PL_sv_undef for perl_destruct() */
7357_EOT7
7358
7359    #for (0 .. $hek_index-1) {
7360    #  # TODO: non-static only, seperate data structures please
7361    #  printf "    memset(HEK_HE(hek%d), 0, sizeof(struct shared_he));\n", $_;
7362    #}
7363    for (0 .. $#B::C::static_free) {
7364      # set the sv/xpv to &PL_sv_undef, not the pv itself.
7365      # If set to NULL pad_undef will fail in SvPVX_const(namesv) == '&'
7366      # XXX Another idea >5.10 is SvFLAGS(pv) = SVTYPEMASK
7367      my $s = $B::C::static_free[$_];
7368      if ($s =~ /^sv_list\[\d+\]\./) { # pv directly (unused)
7369	print "    $s = NULL;\n";
7370      } elsif ($s =~ /^sv_list/) {
7371        print "    SvLEN(&$s) = 0;\n";
7372        print "    SvPV_set(&$s, (char*)&PL_sv_undef);\n";
7373      } elsif ($s =~ /^&sv_list/) {
7374        print "    SvLEN($s) = 0;\n";
7375        print "    SvPV_set($s, (char*)&PL_sv_undef);\n";
7376      } elsif ($s =~ /^\(HV\*\)&sv_list/) {
7377	print "    SvREADONLY_on((SV*)$s);\n";
7378        print "    SvREFCNT($s) = SvREFCNT_IMMORTAL;\n";
7379      } elsif ($s =~ /^\(AV\*\)&sv_list/) { # SVs_OBJECT flag, as the HV
7380	#print "    SvREADONLY_on((SV*)$s);\n";
7381        #print "    SvREFCNT($s) = SvREFCNT_IMMORTAL;\n";
7382      } elsif ($s =~ /^&padnamelist_list/) {
7383        print "    Safefree(PadnamelistARRAY($s));\n";
7384        print "    PadnamelistMAX($s) = 0;\n";
7385        print "    PadnamelistREFCNT($s) = 0;\n";
7386      } elsif ($s =~ /^&padname(_\d+)?_list/) {
7387        print "    PadnameREFCNT($s) = 0;\n";
7388        # dead code ---
7389      } elsif ($s =~ /^cop_list/) {
7390	if ($ITHREADS or !$MULTI) {
7391	  print "    CopFILE_set(&$s, NULL);";
7392        }
7393        if ($] >= 5.017) {
7394          print " CopSTASH_set(&$s, NULL);\n";
7395        } elsif ($] < 5.016 and $ITHREADS) {
7396          print " CopSTASHPV(&$s) = NULL;\n";
7397        } elsif ($] < 5.016 and !$ITHREADS) {
7398          print " CopSTASH(&$s) = NULL;\n";
7399        } else { # 5.16 experiment
7400          print " CopSTASHPV_set(&$s, NULL, 0);\n";
7401        }
7402      } elsif ($s =~ /\(OP\*\)&unopaux_list/) {
7403	print "    ($s)->op_type = OP_NULL;\n";
7404      # end dead code ---
7405      #} elsif ($s =~ /^pv\d/) {
7406      #	print "    $s = \"\";\n";
7407      } elsif ($s ne 'ptr_undef') {
7408	warn("unknown $s at \@static_free[$_]");
7409      }
7410    }
7411    $free->output( \*STDOUT, "%s\n" );
7412
7413    print "}\n";
7414  }
7415}
7416
7417sub output_main_rest {
7418  save_destruct("main");
7419  print <<'_EOT8';
7420
7421/* yanked from perl.c */
7422static void
7423xs_init(pTHX)
7424{
7425	char *file = __FILE__;
7426	dTARG; dSP; dVAR; CV * cv;
7427_EOT8
7428  if ($CPERL51 and $debug{cv}) {
7429    print q{
7430        /* -DC set dl_debug to 3 */
7431        SV* sv = get_svs("DynaLoader::dl_debug", GV_ADD);
7432        sv_upgrade(sv, SVt_IV);
7433        SvIV_set(sv, 3);};
7434  }
7435  #if ($staticxs) { #FIXME!
7436  #  print "\n#undef USE_DYNAMIC_LOADING
7437  #}
7438
7439  delete $xsub{'DynaLoader'};
7440  delete $xsub{'UNIVERSAL'};
7441  print("/* XS bootstrapping code*/\n");
7442  print("\tSAVETMPS;\n");
7443  print("\ttarg=sv_newmortal();\n");
7444  foreach my $stashname ( sort keys %static_ext ) {
7445    my $stashxsub = $stashname;
7446    $stashxsub =~ s/::/__/g;
7447    #if ($stashxsub =~ m/\/(\w+)\.\w+$/ {$stashxsub = $1;}
7448    # cygwin has Win32CORE in static_ext
7449    warn "bootstrapping static $stashname added to xs_init\n" if $verbose;
7450    print "\tnewXS(\"$stashname\::bootstrap\", boot_$stashxsub, file);\n";
7451  }
7452  print "#ifdef USE_DYNAMIC_LOADING\n";
7453  print "\tPUSHMARK(sp);\n";
7454  printf "\tXPUSHp(\"DynaLoader\", %d);\n", length("DynaLoader");
7455  print "\tPUTBACK;\n";
7456  warn "bootstrapping DynaLoader added to xs_init\n" if $verbose;
7457  print "\tcv = newXS(\"DynaLoader::boot_DynaLoader\", boot_DynaLoader, file);\n";
7458  print "\tboot_DynaLoader(aTHX_ cv);\n";
7459  print "\tSPAGAIN;\n";
7460  if ($CPERL51 and $^O ne 'MSWin32') {
7461    print "\tdl_boot(aTHX);\n";
7462  }
7463  print "#endif\n";
7464
7465  # my %core = map{$_ => 1} core_packages();
7466  foreach my $stashname ( sort keys %xsub ) {
7467    my $incpack = inc_packname($stashname);
7468    unless (exists $curINC{$incpack}) { # skip deleted packages
7469      warn "skip xs_init for $stashname !\$INC{$incpack}\n" if $debug{pkg};
7470      delete $include_package{$stashname};
7471      delete $xsub{$stashname} unless $static_ext{$stashname};
7472      next;
7473    }
7474    if ( $xsub{$stashname} !~ m/^Dynamic/ and !$static_ext{$stashname}) {
7475      my $stashxsub = $stashname;
7476      warn "bootstrapping $stashname added to xs_init\n" if $verbose;
7477      $stashxsub =~ s/::/__/g;
7478      print "\tPUSHMARK(sp);\n";
7479      printf "\tXPUSHp(\"%s\", %d);\n", # "::bootstrap" gets appended, TODO
7480	0 ? "strdup($stashname)" : $stashname, length($stashname);
7481      print "\tPUTBACK;\n";
7482      print "\tboot_$stashxsub(aTHX_ NULL);\n";
7483      print "\tSPAGAIN;\n";
7484    }
7485  }
7486  print "\tFREETMPS;\n/* end XS bootstrapping code */\n";
7487  print "}\n\n";
7488
7489  my ($dl, $xs);
7490  my @dl_modules = @DynaLoader::dl_modules;
7491  my @PERLMODS = split(/\,/, $ENV{'PERLMODS'}) if $ENV{'PERLMODS'}; # from cpanel
7492  foreach my $perlmod (@PERLMODS) {
7493    warn "Extra module ${perlmod}\n";
7494    push @dl_modules, $perlmod unless grep { $_ ne $perlmod } @dl_modules;
7495  }
7496  # filter out unused dynaloaded B modules, used within the compiler only.
7497  for my $c (qw(B B::C)) {
7498    if (!$xsub{$c} and !$include_package{$c}) {
7499      # (hopefully, see test 103)
7500      warn "no dl_init for $c, not marked\n" if $verbose and !$skip_package{$c};
7501      # RT81332 pollute
7502      @dl_modules = grep { $_ ne $c } @dl_modules;
7503      # XXX Be sure to store the new @dl_modules
7504    }
7505  }
7506  for my $c (sort keys %skip_package) {
7507    warn "no dl_init for $c, skipped\n" if $verbose and $xsub{$c};
7508    delete $xsub{$c};
7509    $include_package{$c} = undef;
7510    @dl_modules = grep { $_ ne $c } @dl_modules;
7511  }
7512  @DynaLoader::dl_modules = @dl_modules;
7513  warn "\@dl_modules: ",join(" ",@dl_modules),"\n" if $verbose;
7514  foreach my $stashname (@dl_modules) {
7515    my $incpack = inc_packname($stashname);
7516    #unless (exists $INC{$incpack}) { # skip deleted packages
7517    #  warn "XXX skip dl_init for $stashname !\$INC{$incpack}\n" if $debug{pkg};
7518    #  delete $xsub{$stashname};
7519    #  @dl_modules = grep { $_ ne $stashname } @dl_modules;
7520    #}
7521    if ($stashname eq 'attributes' and $] > 5.011) {
7522      $xsub{$stashname} = 'Dynamic-' . $INC{'attributes.pm'};
7523    }
7524    # actually boot all non-b-c dependent modules here. we assume XSLoader (Moose, List::MoreUtils)
7525    if (!exists( $xsub{$stashname} ) and $include_package{$stashname}) {
7526      $xsub{$stashname} = 'Dynamic-' . $INC{$incpack};
7527      # Class::MOP without Moose: find Moose.pm
7528      $xsub{$stashname} = 'Dynamic-' . $savINC{$incpack} unless $INC{$incpack};
7529      if (!$savINC{$incpack}) {
7530        eval "require $stashname;";
7531        $xsub{$stashname} = 'Dynamic-' . $INC{$incpack};
7532      }
7533      warn "Assuming xs loaded $stashname with $xsub{$stashname}\n" if $verbose;
7534    }
7535    if ( exists( $xsub{$stashname} ) && $xsub{$stashname} =~ m/^Dynamic/ ) {
7536      # XSLoader.pm: $modlibname = (caller())[1]; needs a path at caller[1] to find auto,
7537      # otherwise we only have -e
7538      $xs++ if $xsub{$stashname} ne 'Dynamic';
7539      $dl++;
7540    }
7541    my $stashxsub = $stashname;
7542    $stashxsub =~ s/::/__/g;
7543    if ( exists( $xsub{$stashname} ) && $xsub{$stashname} =~ m/^Dynamic-/
7544         and ($PERL522 or $staticxs)) {
7545      print "EXTERN_C void boot_$stashxsub(pTHX_ CV* cv);\n";
7546    }
7547  }
7548  warn "\%xsub: ",join(" ",sort keys %xsub),"\n" if $verbose and $debug{cv};
7549  # XXX Adding DynaLoader is too late here! The sections like $init are already dumped (#125)
7550  if ($dl and ! $curINC{'DynaLoader.pm'}) {
7551    die "Error: DynaLoader required but not dumped. Too late to add it.\n";
7552  } elsif ($xs and ! $curINC{'XSLoader.pm'}) {
7553    die "Error: XSLoader required but not dumped. Too late to add it.\n";
7554  }
7555  print <<'_EOT9';
7556
7557static void
7558dl_init(pTHX)
7559{
7560	char *file = __FILE__;
7561_EOT9
7562
7563  if ($dl) {
7564    # enforce attributes at the front of dl_init, #259
7565    # also Encode should be booted before PerlIO::encoding
7566    for my $front (qw(Encode attributes)) {
7567      if (grep { $_ eq $front } @dl_modules) {
7568        @dl_modules = grep { $_ ne $front } @dl_modules;
7569        unshift @dl_modules, $front;
7570      }
7571    }
7572    if ($staticxs) {open( XS, ">", $outfile.".lst" ) or return "$outfile.lst: $!\n"}
7573    print "\tdTARG; dSP; dVAR;\n";
7574    print "/* DynaLoader bootstrapping */\n";
7575    print "\tENTER;\n";
7576    print "\t++cxstack_ix; cxstack[cxstack_ix].blk_oldcop = PL_curcop;\n" if $xs;
7577    print "\t/* assert(cxstack_ix == 0); */\n" if $xs;
7578    print "\tSAVETMPS;\n";
7579    print "\ttarg = sv_newmortal();\n" if $] < 5.008008;
7580
7581    if (exists $xsub{"Coro::State"} and grep { $_ eq "Coro::State" } @dl_modules) {
7582      # Coro readonly symbols in BOOT (#293)
7583      # needed before dl_init, and after init
7584      print "\t{\n\t  GV *sym;\n";
7585      for my $s (qw(Coro Coro::API Coro::current)) {
7586        print "\t  sym = gv_fetchpv(\"$s\",0,SVt_PV);\n";
7587        print "\t  if (sym && GvSVn(sym)) SvREADONLY_off(GvSVn(sym));\n";
7588      }
7589      print "\t  sym = gv_fetchpv(\"Coro::pool_handler)\",0,SVt_PVCV);\n";
7590      print "\t  if (sym && GvCV(sym)) SvREADONLY_off(GvCV(sym));\n";
7591      print "\t}\n";
7592    }
7593    if (exists $xsub{"EV"} and grep { $_ eq "EV" } @dl_modules) {
7594      # EV readonly symbols in BOOT (#368)
7595      print "\t{\n\t  GV *sym;\n";
7596      for my $s (qw(EV::API)) {
7597        print "\t  sym = gv_fetchpv(\"$s\",0,SVt_PV);\n";
7598        print "\t  if (sym && GvSVn(sym)) SvREADONLY_off(GvSVn(sym));\n";
7599      }
7600      print "\t}\n";
7601    }
7602    foreach my $stashname (@dl_modules) {
7603      if ( exists( $xsub{$stashname} ) && $xsub{$stashname} =~ m/^Dynamic/ ) {
7604	$use_xsloader = 1;
7605        print "\n\tPUSHMARK(sp);\n";
7606	# XXX -O1 or -O2 needs XPUSHs with dynamic pv
7607	printf "\t%s(%s, %d);\n", # "::bootstrap" gets appended
7608	  $] < 5.008008 ? "XPUSHp" : "mXPUSHp", "\"$stashname\"", length($stashname);
7609        if ( $xsub{$stashname} eq 'Dynamic' ) {
7610          no strict 'refs';
7611          warn "dl_init $stashname\n" if $verbose;
7612          # just in case we missed it. DynaLoader really needs the @ISA (#308)
7613          B::svref_2object( \@{$stashname."::ISA"} ) ->save;
7614	  print "#ifndef STATICXS\n";
7615	  print "\tPUTBACK;\n";
7616          print qq/\tcall_method("DynaLoader::bootstrap_inherit", G_VOID|G_DISCARD);\n/;
7617        }
7618        else { # XS: need to fix cx for caller[1] to find auto/...
7619	  my ($stashfile) = $xsub{$stashname} =~ /^Dynamic-(.+)$/;
7620	  print "#ifndef STATICXS\n";
7621	  if ($] >= 5.015003 and $stashfile) {
7622            if ($CPERL51) {
7623              my $sofile;
7624              # search stashname in loaded sofiles
7625              my @modparts = split(/::/,$stashname);
7626              my $modfname = $modparts[-1];
7627              my $modpname = join('/',@modparts);
7628              my $needle = "auto/$modpname/$modfname\\.".$Config{dlext};
7629              #warn " load_file: @DynaLoader::dl_shared_objects";
7630              #warn " sofile?: $needle";
7631              for (@DynaLoader::dl_shared_objects) {
7632                if (m{$needle}) {
7633                  #warn " load_file: found $_";
7634                  $sofile = $_; last;
7635                }
7636              }
7637              unless ($sofile) {
7638                my $modlibname = $stashfile;
7639                my $c = scalar @modparts;
7640                if ($stashname eq 'Cwd' and $stashfile !~ /Cwd/) {
7641                  warn "load_file: fixup Cwd vs $stashfile";
7642                  $c = 3;
7643                }
7644                $modlibname =~ s,[\\/][^\\/]+$,, while $c--;  # Q&D basename
7645                $sofile = "$modlibname/auto/$modpname/$modfname.".$Config{dlext};
7646              }
7647              #warn "load_file: $stashname, $stashfile, $sofile";
7648              $stashfile = $sofile;
7649            }
7650            my $stashfile_len = length($stashfile);
7651            $stashfile =~ s/(\\[^nrftacx"' ])/\\$1/g; # windows paths: \\ => \\\\
7652            printf "\tmXPUSHp(\"%s\", %d);\n", $stashfile, $stashfile_len;
7653	  }
7654	  print "\tPUTBACK;\n";
7655	  warn "bootstrapping $stashname added to XSLoader dl_init\n" if $verbose;
7656	  # XSLoader has the 2nd insanest API in whole Perl, right after make_warnings_object()
7657	  # 5.15.3 workaround for [perl #101336]
7658	  if ($] >= 5.015003) {
7659	    no strict 'refs';
7660	    unless (grep /^DynaLoader$/, get_isa($stashname)) {
7661              my $ro = Internals::SvREADONLY(@{$stashname."::ISA"});
7662              Internals::SvREADONLY(@{$stashname."::ISA"}, 0) if $ro;
7663	      push @{$stashname."::ISA"}, 'DynaLoader';
7664              Internals::SvREADONLY(@{$stashname."::ISA"}, 1) if $ro;
7665	      svref_2object( \@{$stashname."::ISA"} ) ->save;
7666	    }
7667	    warn '@',$stashname,"::ISA=(",join(",",@{$stashname."::ISA"}),")\n" if $debug{gv};
7668            # TODO #364: if a VERSION was provided need to add it here
7669	    print qq/\tcall_pv("XSLoader::load_file", G_VOID|G_DISCARD);\n/;
7670	  } else {
7671	    printf qq/\tCopFILE_set(cxstack[cxstack_ix].blk_oldcop, "%s");\n/,
7672	      $stashfile if $stashfile;
7673            # TODO #364: if a VERSION was provided need to add it here
7674	    print qq/\tcall_pv("XSLoader::load", G_VOID|G_DISCARD);\n/;
7675	  }
7676        }
7677        if ($staticxs) {
7678          my ($laststash) = $stashname =~ /::([^:]+)$/;
7679          my $path = $stashname;
7680          $path =~ s/::/\//g;
7681          $path .= "/" if $path; # can be empty
7682          $laststash = $stashname unless $laststash; # without ::
7683          my $sofile = "auto/" . $path . $laststash . '\.' . $Config{dlext};
7684          #warn "staticxs search $sofile in @DynaLoader::dl_shared_objects\n"
7685          #  if $verbose and $debug{pkg};
7686          for (@DynaLoader::dl_shared_objects) {
7687            if (m{^(.+/)$sofile$}) {
7688              print XS $stashname,"\t",$_,"\n";
7689              warn "staticxs $stashname\t$_\n" if $verbose;
7690              $sofile = '';
7691              last;
7692            }
7693          }
7694          print XS $stashname,"\n" if $sofile; # error case
7695          warn "staticxs $stashname\t - $sofile not loaded\n" if $sofile and $verbose;
7696        }
7697        print "#else\n";
7698        print "\tPUTBACK;\n";
7699        my $stashxsub = $stashname;
7700        $stashxsub =~ s/::/__/g;
7701        if ($PERL522 or $staticxs) {
7702	  # CvSTASH(CvGV(cv)) is invalid without (issue 86)
7703          # TODO: utf8 stashname (does make sense when loading from the fs?)
7704          if ($PERL522 and $staticxs) { # GH 333
7705            print "\t{
7706		CV* cv = (CV*)SvREFCNT_inc_simple_NN(get_cv(\"$stashname\::bootstrap\", GV_ADD));
7707		CvISXSUB_on(cv); /* otherwise a perl assertion fails. */
7708		cv->sv_any->xcv_padlist_u.xcv_hscxt = &PL_stack_sp; /* xs_handshake */
7709		boot_$stashxsub(aTHX_ cv);
7710	}\n";
7711          } else {
7712            print "\tboot_$stashxsub(aTHX_ get_cv(\"$stashname\::bootstrap\", GV_ADD));\n";
7713          }
7714	} else {
7715	  print "\tboot_$stashxsub(aTHX_ NULL);\n";
7716	}
7717        print "#endif\n";
7718        print "\tSPAGAIN;\n";
7719        #print "\tPUTBACK;\n";
7720      } else {
7721        warn "no dl_init for $stashname, ".
7722          (!$xsub{$stashname} ? "not bootstrapped\n" : "bootstrapped as $xsub{$stashname}\n")
7723	    if $verbose;
7724	# XXX Too late. This might fool run-time DynaLoading.
7725	# We really should remove this via init from @DynaLoader::dl_modules
7726	@DynaLoader::dl_modules = grep { $_ ne $stashname } @DynaLoader::dl_modules;
7727
7728      }
7729    }
7730    print "\tFREETMPS;\n";
7731    print "\tcxstack_ix--;\n" if $xs;  	# i.e. POPBLOCK
7732    print "\tLEAVE;\n";
7733    print "/* end DynaLoader bootstrapping */\n";
7734    close XS if $staticxs;
7735  }
7736  print "}\n";
7737}
7738
7739sub output_main {
7740  return if defined $module;
7741  print <<'_EOT10';
7742
7743/* if USE_IMPLICIT_SYS, we need a 'real' exit */
7744#if defined(exit)
7745#undef exit
7746#endif
7747
7748int
7749main(int argc, char **argv, char **env)
7750{
7751    int exitstatus;
7752    int i;
7753    char **fakeargv;
7754    int options_count;
7755    PerlInterpreter *my_perl;
7756
7757#ifdef PERL_GLOBAL_STRUCT
7758    struct perl_vars *my_vars = Perl_init_global_struct(aTHX);
7759#  ifdef PERL_GLOBAL_STRUCT_PRIVATE
7760    int veto;
7761    my_plvarsp = my_vars;
7762#  endif
7763#endif
7764
7765    PERL_SYS_INIT3(&argc,&argv,&env);
7766
7767#ifdef WIN32
7768#define PL_do_undump 0
7769#endif
7770    if (!PL_do_undump) {
7771	my_perl = perl_alloc();
7772	if (!my_perl)
7773	    exit(1);
7774	perl_construct( my_perl );
7775	PL_perl_destruct_level = 0;
7776    }
7777_EOT10
7778    if ($ITHREADS and $] > 5.007) {
7779      # XXX init free elems!
7780      my $pad_len = regex_padav->FILL;    # first is an empty avref
7781      print <<_EOT11;
7782#ifdef USE_ITHREADS
7783    if (!*PL_regex_pad) {
7784      /* Someone is overwriting regex_pad since 5.15, but not on -fno-warnings */
7785      PL_regex_padav = newAV();
7786#if PERL_VERSION > 10
7787      av_push(PL_regex_padav, newSVpvs("")); /* First entry is empty */
7788#else
7789      av_push(PL_regex_padav, newSViv(0));
7790#endif
7791      PL_regex_pad = AvARRAY(PL_regex_padav);
7792    }
7793    for( i = 0; i < $pad_len; ++i ) {
7794        av_push( PL_regex_padav, newSViv(0) );
7795    }
7796    PL_regex_pad = AvARRAY( PL_regex_padav );
7797#endif
7798_EOT11
7799
7800    }
7801    print "    PL_exit_flags |= PERL_EXIT_DESTRUCT_END;\n" unless $PERL56;
7802    if ($] >= 5.008009) {
7803      print <<'_SAFE_PUTENV';
7804#ifndef PERL_USE_SAFE_PUTENV
7805    PL_use_safe_putenv = 0;
7806#endif
7807_SAFE_PUTENV
7808    }
7809    if (!$PERL510) {
7810      print <<'_EOT12';
7811#if defined(CSH)
7812    if (!PL_cshlen)
7813      PL_cshlen = strlen(PL_cshname);
7814#endif
7815_EOT12
7816    }
7817
7818    # XXX With -e "" we need to fake parse_body() scriptname = BIT_BUCKET
7819    print <<'_EOT13';
7820#ifdef ALLOW_PERL_OPTIONS
7821#define EXTRA_OPTIONS 3
7822#else
7823#define EXTRA_OPTIONS 4
7824#endif /* ALLOW_PERL_OPTIONS */
7825    Newx(fakeargv, argc + EXTRA_OPTIONS + 1, char *);
7826    fakeargv[0] = argv[0];
7827    fakeargv[1] = "-e";
7828    fakeargv[2] = "";
7829    options_count = 3;
7830_EOT13
7831
7832    # honour -T
7833    if (!$PERL56 and ${^TAINT}) {
7834      print <<'_EOT14';
7835    fakeargv[options_count] = "-T";
7836    ++options_count;
7837_EOT14
7838
7839    }
7840    print <<'_EOT15';
7841#ifndef ALLOW_PERL_OPTIONS
7842    fakeargv[options_count] = "--";
7843    ++options_count;
7844#endif /* ALLOW_PERL_OPTIONS */
7845    for (i = 1; i < argc; i++)
7846	fakeargv[i + options_count - 1] = argv[i];
7847    fakeargv[argc + options_count - 1] = 0;
7848
7849    exitstatus = perl_parse(my_perl, xs_init, argc + options_count - 1,
7850			    fakeargv, env);
7851    if (exitstatus)
7852	exit( exitstatus );
7853
7854    TAINT;
7855_EOT15
7856
7857    if ($use_perl_script_name) {
7858      my $dollar_0 = cstring($0);
7859      print sprintf(qq{    sv_setpv_mg(get_svs("0", GV_ADD|GV_NOTQUAL), %s);\n}, $dollar_0);
7860      print sprintf(qq{    CopFILE_set(&PL_compiling, %s);\n}, $dollar_0);
7861    }
7862    else {
7863      #print q{    warn("PL_origalen=%d\n", PL_origalen);},"\n";
7864      print qq{    sv_setpv_mg(get_svs("0", GV_ADD|GV_NOTQUAL), argv[0]);\n};
7865      print qq{    CopFILE_set(&PL_compiling, argv[0]);\n};
7866    }
7867    # more global vars
7868    print "    PL_hints = $^H;\n" if $^H;
7869    print "    PL_unicode = ${^UNICODE};\n" if ${^UNICODE};
7870    # system-specific needs to be skipped: is set during init_i18nl10n if PerlIO
7871    # is compiled in and on a utf8 locale.
7872    #print "    PL_utf8locale = ${^UTF8LOCALE};\n" if ${^UTF8LOCALE};
7873    #print "    PL_utf8cache = ${^UTF8CACHE};\n" if ${^UTF8CACHE};
7874    # nomg
7875    print sprintf(qq{    sv_setpv(get_svs(";", GV_ADD|GV_NOTQUAL), %s);\n}, cstring($;)) if $; ne "\34";
7876    print sprintf(qq{    sv_setpv(get_svs("\\"", GV_NOTQUAL), %s); /* \$" */\n}, cstring($")) if $" ne " ";
7877    # global IO vars
7878    if ($PERL56) {
7879      print sprintf(qq{    PL_ofs = %s; PL_ofslen = %u; /* \$, */\n}, cstring($,), length $,) if $,;
7880      print sprintf(qq{    PL_ors = %s; PL_orslen = %u; /* \$\\ */\n}, cstring($\), length $\) if $\;
7881    } else {
7882      print sprintf(qq{    sv_setpv_mg(GvSVn(PL_ofsgv), %s); /* \$, */\n}, cstring($,)) if $,;
7883      print sprintf(qq{    sv_setpv_mg(get_svs("\\\\", GV_ADD|GV_NOTQUAL), %s); /* \$\\ */\n}, cstring($\)) if $\; #ORS
7884    }
7885    print sprintf(qq{    sv_setpv_mg(get_svs("/", GV_NOTQUAL), %s);\n}, cstring($/)) if $/ ne "\n"; #RS
7886    print         qq{    sv_setiv_mg(get_svs("|", GV_ADD|GV_NOTQUAL), $|);\n} if $|; #OUTPUT_AUTOFLUSH
7887    # global format vars
7888    print sprintf(qq{    sv_setpv_mg(get_svs("^A", GV_ADD|GV_NOTQUAL), %s);\n}, cstring($^A)) if $^A; #ACCUMULATOR
7889    print sprintf(qq{    sv_setpv_mg(get_svs("^L", GV_ADD|GV_NOTQUAL), %s);\n}, cstring($^L)) if $^L ne "\f"; #FORMFEED
7890    print sprintf(qq{    sv_setpv_mg(get_svs(":", GV_ADD|GV_NOTQUAL), %s);\n}, cstring($:)) if $: ne " \n-"; #LINE_BREAK_CHARACTERS
7891    print sprintf(qq/    sv_setpv_mg(get_svs("^", GV_ADD|GV_NOTQUAL), savepvn(%s, %u));\n/, cstring($^), length($^))
7892      if $^ ne "STDOUT_TOP";
7893    print sprintf(qq/    sv_setpv_mg(get_svs("~", GV_ADD|GV_NOTQUAL), savepvn(%s, %u));\n/, cstring($~), length($~))
7894      if $~ ne "STDOUT";
7895    print         qq{    sv_setiv_mg(get_svs("%", GV_ADD|GV_NOTQUAL), $%);\n} if $%; #PAGE_NUMBER
7896    print         qq{    sv_setiv_mg(get_svs("-", GV_ADD|GV_NOTQUAL), $-);\n} unless ($- == 0 or $- == 60); #LINES_LEFT
7897    print         qq{    sv_setiv_mg(get_svs("=", GV_ADD|GV_NOTQUAL), $=);\n} if $= != 60; #LINES_PER_PAGE
7898
7899    # deprecated global vars
7900    print qq{    {SV* s = get_svs("[",GV_NOTQUAL); sv_setiv(s, $[); mg_set(s);}\n} if $[; #ARRAY_BASE
7901    if ($] < 5.010) { # OFMT and multiline matching
7902      eval q[
7903            print sprintf(qq{    sv_setpv(GvSVn(gv_fetchpv("\$#", GV_ADD|GV_NOTQUAL, SVt_PV)), %s);\n},
7904                          cstring($#)) if $#;
7905            print sprintf(qq{    sv_setiv(GvSVn(gv_fetchpv("\$*", GV_ADD|GV_NOTQUAL, SVt_IV)), %d);\n}, $*) if $*;
7906           ];
7907    }
7908
7909    print sprintf(qq{    sv_setpv_mg(get_svs("\030", GV_ADD|GV_NOTQUAL), %s); /* \$^X */\n},
7910                  cstring($Config{perlpath}));
7911    print <<'EOT';
7912    TAINT_NOT;
7913
7914    #if PERL_VERSION < 10 || ((PERL_VERSION == 10) && (PERL_SUBVERSION < 1))
7915      PL_compcv = 0;
7916    #else
7917      PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
7918      CvUNIQUE_on(PL_compcv);
7919      CvPADLIST(PL_compcv) = pad_new(0);
7920    #endif
7921EOT
7922
7923  output_init();
7924  print "    exitstatus = perl_run( my_perl );\n";
7925  output_local_destruct("main");
7926  output_global_destruct();
7927
7928  # XXX endav is called via call_list and so it is freed right after usage.
7929  # Setting dirty here is useless.
7930  # Protect against pad undef in END block
7931  #print "    PL_dirty = 1;\n" unless $B::C::pv_copy_on_grow;
7932
7933  print <<'EOT1';
7934    perl_free( my_perl );
7935
7936    PERL_SYS_TERM();
7937
7938    exit( exitstatus );
7939}
7940EOT1
7941
7942}
7943
7944sub output_init {
7945  print <<'EOT';
7946  /* our special compiled init */
7947    perl_init(aTHX);
7948EOT
7949
7950  print "    perl_init1(aTHX);\n" if $init1->index >= 0;
7951  # XXX maybe we need dl_init for a module, esp. when it's XS loading.
7952  print "    dl_init(aTHX);\n";
7953  print "    perl_init2(aTHX);\n" if $init2->index >= 0;
7954}
7955
7956sub output_local_destruct {
7957  my $name = shift;
7958  $name = 'main' unless defined $name;
7959  foreach my $s ( @{ $init->[-1]{pre_destruct} } ) {
7960    print "    ".$s."\n";
7961  }
7962  if ( $B::C::destruct ) {
7963    if (defined $module and !$ITHREADS) {
7964      print "    destruct_$name( NULL );\n";
7965    } else {
7966      print "    destruct_$name( my_perl );\n";
7967    }
7968  }
7969}
7970
7971sub output_global_destruct {
7972  if ( !$B::C::destruct ) {
7973    warn "fast_perl_destruct (-fno-destruct)\n" if $verbose;
7974    print "    fast_perl_destruct( my_perl );\n";
7975  }
7976  else {
7977
7978    print <<'_EOT7';
7979  {
7980    volatile signed char destruct_level = PL_perl_destruct_level;
7981    const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
7982_EOT7
7983
7984    my $riter_type = "I32";
7985    if ($CPERL51) {
7986      $riter_type = $CPERL55 ? "U32" : "SSize_t";
7987    }
7988    my $hvmax_type = "STRLEN";
7989    if ($CPERL51) {
7990      $hvmax_type = $CPERL55 ? "U32" : "SSize_t";
7991    }
7992    print "#define RITER_T $riter_type\n";
7993    print "#define HVMAX_T $hvmax_type\n";
7994
7995    print <<'_EOT7a';
7996    /* Avoid Unbalanced string table refcount warning with PERL_DESTRUCT_LEVEL=2 */
7997    if (s) {
7998        const int i = atoi(s);
7999        if (destruct_level < i) destruct_level = i;
8000    }
8001    if (destruct_level >= 1) {
8002        const HVMAX_T max = HvMAX(PL_strtab);
8003	HE * const * const array = HvARRAY(PL_strtab);
8004	RITER_T riter = 0;
8005	HE *hent = array[0];
8006	for (;;) {
8007	    if (hent) {
8008		HE * const next = HeNEXT(hent);
8009                if (!HEK_STATIC(&((struct shared_he*)hent)->shared_he_hek))
8010                    Safefree(hent);
8011		hent = next;
8012	    }
8013	    if (!hent) {
8014		if (++riter > max)
8015		    break;
8016		hent = array[riter];
8017	    }
8018        }
8019        /* Silence strtab refcnt warnings during global destruction */
8020        Zero(HvARRAY(PL_strtab), max, HE*);
8021        /* NULL the HEK "dfs" */
8022#if PERL_VERSION > 10
8023        PL_registered_mros = (HV*)&PL_sv_undef;
8024        CopHINTHASH_set(&PL_compiling, NULL);
8025#endif
8026    }
8027
8028#if PERL_VERSION > 7
8029    if (DEBUG_D_TEST) {
8030        SV* sva;
8031        PerlIO_printf(Perl_debug_log, "sv[0]: 0x%p, sv_arenaroot: 0x%p, sva->any: 0x%p\n",
8032                      SvANY(&sv_list[0]), PL_sv_arenaroot, SvANY(PL_sv_arenaroot));
8033        for (sva = PL_sv_arenaroot;
8034             sva;
8035	     /* avoid cycles */
8036             sva = (sva == (SV*)SvANY(sva)) ? NULL : (SV*)SvANY(sva))
8037        {
8038            PerlIO_printf(Perl_debug_log, "sv_arena: 0x%p - 0x%p (%lu)\n",
8039              sva, sva+SvREFCNT(sva), (long)SvREFCNT(sva));
8040        }
8041    }
8042#endif
8043  }
8044_EOT7a
8045    if (defined $module and !$ITHREADS) {
8046      print "    perl_destruct( NULL );\n";
8047    } else {
8048      print "    perl_destruct( my_perl );\n";
8049    }
8050  }
8051}
8052
8053sub dump_symtable {
8054  # For debugging
8055  my ( $sym, $val );
8056  warn "----Symbol table:\n";
8057  #while ( ( $sym, $val ) = each %symtable )
8058  for $sym (sort keys %symtable) {
8059    $val = $symtable{$sym};
8060    warn "$sym => $val\n";
8061  }
8062  warn "---End of symbol table\n";
8063}
8064
8065sub save_object {
8066  my $sv;
8067  foreach $sv (@_) {
8068    svref_2object($sv)->save;
8069  }
8070}
8071
8072sub Dummy_BootStrap { }
8073
8074#ignore nullified cv
8075sub B::SPECIAL::savecv {}
8076
8077sub B::GV::savecv {
8078  my $gv      = shift;
8079  my $package = $gv->STASH->NAME;
8080  my $name    = $gv->NAME;
8081  my $cv      = $gv->CV;
8082  my $sv      = $gv->SV;
8083  my $av      = $gv->AV;
8084  my $hv      = $gv->HV;
8085
8086  my $fullname = $package . "::" . $name;
8087  warn sprintf( "Checking GV *%s 0x%x\n", cstring($fullname), $$gv )
8088    if $debug{gv} and $verbose;
8089  # We may be looking at this package just because it is a branch in the
8090  # symbol table which is on the path to a package which we need to save
8091  # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
8092  #
8093  return if ( $package ne 'main' and !$include_package{$package} );
8094  return if ( $package eq 'main' and
8095	      $name =~ /^([^\w].*|_\<.*|INC|ARGV|SIG|ENV|BEGIN|main::|!)$/ );
8096
8097  warn sprintf( "Used GV \*$fullname 0x%x\n", $$gv ) if $debug{gv};
8098  return unless ( $$cv || $$av || $$sv || $$hv || $gv->IO || $gv->FORM );
8099  if ($$cv and $name eq 'bootstrap' and $cv->XSUB) {
8100    #return $cv->save($fullname);
8101    warn sprintf( "Skip XS \&$fullname 0x%x\n", $$cv ) if $debug{gv};
8102    return;
8103  }
8104  if ( $$cv and in_static_core($package, $name) and ref($cv) eq 'B::CV' # 5.8,4 issue32
8105       and $cv->XSUB ) {
8106    warn("Skip internal XS $fullname\n") if $debug{gv};
8107    # but prevent it from being deleted
8108    unless ($dumped_package{$package}) {
8109      #$dumped_package{$package} = 1;
8110      mark_package($package, 1);
8111    }
8112    return;
8113  }
8114  if ($package eq 'B::C') {
8115    warn sprintf( "Skip XS \&$fullname 0x%x\n", $$cv ) if $debug{gv};
8116    return;
8117  }
8118  if ($fullname =~ /^(bytes|utf8)::AUTOLOAD$/) {
8119    $gv = force_heavy($package);
8120  }
8121  # XXX fails and should not be needed. The B::C part should be skipped 9 lines above, but be defensive
8122  return if $fullname eq 'B::walksymtable' or $fullname eq 'B::C::walksymtable';
8123  # Config is marked on any Config symbol. TIE and DESTROY are exceptions,
8124  # used by the compiler itself
8125  if ($name eq 'Config') {
8126    mark_package('Config', 1) if !$include_package{'Config'};
8127  }
8128  $dumped_package{$package} = 1 if !exists $dumped_package{$package} and $package !~ /::$/;
8129  warn sprintf( "Saving GV \*$fullname 0x%x\n", $$gv ) if $debug{gv};
8130  $gv->save($fullname);
8131}
8132
8133# Fixes bug #307: use foreach, not each
8134# each is not safe to use (at all). walksymtable is called recursively which might add
8135# symbols to the stash, which might cause re-ordered rehashes, which will fool the hash
8136# iterator, leading to missing symbols in the binary.
8137# Old perl5 bug: The iterator should really be stored in the op, not the hash.
8138sub walksymtable {
8139  my ($symref, $method, $recurse, $prefix) = @_;
8140  my ($sym, $ref, $fullname);
8141  $prefix = '' unless defined $prefix;
8142
8143# If load_utf8_heavy doesn't happen before we walk utf8::
8144# (when utf8_heavy has already been called) then the stored CV for utf8::S
8145# WASHNEW could be wrong.
8146  load_utf8_heavy() if ( $prefix eq 'utf8::' && defined $symref->{'SWASHNEW'} );
8147
8148  my @list = sort {
8149    # we want these symbols to be saved last to avoid incomplete saves
8150    # +/- reverse is to defer + - to fix Tie::Hash::NamedCapturespecial cases. GH #247
8151    # _loose_name redefined from utf8_heavy.pl GH #364
8152    foreach my $v (qw{- + utf8:: bytes::}) {
8153        $a eq $v and return 1;
8154        $b eq $v and return -1;
8155    }
8156    # reverse order for now to preserve original behavior before improved patch
8157    $b cmp $a
8158  } keys %$symref;
8159
8160  foreach my $sym ( @list ) {
8161    no strict 'refs';
8162    $ref = $symref->{$sym};
8163    $fullname = "*main::".$prefix.$sym;
8164    if ($sym =~ /::$/) {
8165      $sym = $prefix . $sym;
8166      if (svref_2object(\*$sym)->NAME ne "main::" && $sym ne "<none>::" && &$recurse($sym)) {
8167        walksymtable(\%$fullname, $method, $recurse, $sym);
8168      }
8169    } else {
8170      svref_2object(\*$fullname)->$method();
8171    }
8172  }
8173}
8174
8175sub walk_syms {
8176  my $package = shift;
8177  no strict 'refs';
8178  return if $dumped_package{$package};
8179  warn "walk_syms $package\n" if $debug{pkg} and $verbose;
8180  $dumped_package{$package} = 1;
8181  walksymtable( \%{$package.'::'}, "savecv", sub { 1 }, $package.'::' );
8182}
8183
8184# simplified walk_syms
8185# needed to populate @B::C::Config::deps from Makefile.PL from within this %INC context
8186sub walk_stashes {
8187  my ($symref, $prefix) = @_;
8188  no strict 'refs';
8189  $prefix = '' unless defined $prefix;
8190  foreach my $sym ( sort keys %$symref ) {
8191    if ($sym =~ /::$/) {
8192      $sym = $prefix . $sym;
8193      $B::C::deps{ substr($sym,0,-2) }++;
8194      if ($sym ne "main::" && $sym ne "<none>::") {
8195        walk_stashes(\%$sym, $sym);
8196      }
8197    }
8198  }
8199}
8200
8201sub collect_deps {
8202  %B::C::deps = ();
8203  walk_stashes(\%main::);
8204  print join " ",(sort keys %B::C::deps);
8205}
8206
8207sub mark_package {
8208  my $package = shift;
8209  my $force = shift;
8210  $force = 0 if $] < 5.010;
8211  return if $module or skip_pkg($package); # or $package =~ /^B::C(C?)::/;
8212  if ( !$include_package{$package} or $force ) {
8213    no strict 'refs';
8214    warn "mark_package($package, $force)\n" if $verbose and $debug{pkg};
8215    my @IO = qw(IO::File IO::Handle IO::Socket IO::Seekable IO::Poll);
8216    mark_package('IO') if grep { $package eq $_ } @IO;
8217    mark_package("DynaLoader") if $package eq 'XSLoader';
8218    $use_xsloader = 1 if $package =~ /^B|Carp$/; # to help CC a bit (49)
8219    # i.e. if force
8220    if (exists $include_package{$package}
8221	and !$include_package{$package}
8222	and $savINC{inc_packname($package)})
8223    {
8224      warn sprintf("$package previously deleted, save now%s\n",
8225		   $force?" (forced)":"") if $verbose;
8226      # $include_package{$package} = 1;
8227      add_hashINC( $package );
8228      walk_syms( $package );
8229    } else {
8230      warn sprintf("mark $package%s\n", $force?" (forced)":"")
8231	if !$include_package{$package} and $verbose and $debug{pkg};
8232      $include_package{$package} = 1;
8233      push_package($package) if $] < 5.010;
8234      walk_syms( $package ) if !$B::C::walkall; # fixes i27-1
8235    }
8236    my @isa = get_isa($package);
8237    if ( @isa ) {
8238      # XXX walking the ISA is often not enough.
8239      # we should really check all new packages since the last full scan.
8240      foreach my $isa ( @isa ) {
8241	next if $isa eq $package;
8242        if ( $isa eq 'DynaLoader' ) {
8243          unless ( defined( &{ $package . '::bootstrap' } ) ) {
8244            warn "Forcing bootstrap of $package\n" if $verbose;
8245            eval { $package->bootstrap };
8246          }
8247        }
8248	if ( !$include_package{$isa} and !$skip_package{$isa} ) {
8249          no strict 'refs';
8250	  warn "$isa saved (it is in $package\'s \@ISA)\n" if $verbose;
8251          B::svref_2object( \@{$isa."::ISA"} ) ->save; #308
8252	  if (exists $include_package{$isa} ) {
8253	    warn "$isa previously deleted, save now\n" if $verbose; # e.g. Sub::Name
8254	    mark_package($isa);
8255            walk_syms($isa); # avoid deep recursion
8256          } else {
8257	    #warn "isa $isa save\n" if $verbose;
8258            mark_package($isa);
8259          }
8260        }
8261      }
8262    }
8263  }
8264  return 1;
8265}
8266
8267# XS in CORE which do not need to be bootstrapped extra.
8268# There are some specials like mro,re,UNIVERSAL.
8269sub in_static_core {
8270  my ($stashname, $cvname) = @_;
8271  if ($stashname eq 'UNIVERSAL') {
8272    return $cvname =~ /^(isa|can|DOES|VERSION)$/;
8273  }
8274  %static_core_pkg = map {$_ => 1} static_core_packages()
8275    unless %static_core_pkg;
8276  return 1 if $static_core_pkg{$stashname};
8277  if ($stashname eq 'mro') {
8278    return $cvname eq 'method_changed_in';
8279  }
8280  if ($stashname eq 're') {
8281    return $cvname =~ /^(is_regexp|regname|regnames|regnames_count|regexp_pattern)$/;;
8282  }
8283  if ($stashname eq 'PerlIO') {
8284    return $cvname eq 'get_layers';
8285  }
8286  if ($stashname eq 'PerlIO::Layer') {
8287    return $cvname =~ /^(find|NoWarnings)$/;
8288  }
8289  return 0;
8290}
8291
8292# XS modules in CORE. Reserved namespaces.
8293# Note: mro,re,UNIVERSAL have both, static core and dynamic/static XS
8294# version has an external ::vxs
8295sub static_core_packages {
8296  my @pkg  = qw(Internals utf8 UNIVERSAL);
8297  push @pkg, qw(strict coretypes DynaLoader XSLoader) if $CPERL51;
8298  push @pkg, 'attributes'             if $] <  5.011; # partially static and dynamic
8299  push @pkg, 'version'                if $] >= 5.010; # partially static and dynamic
8300  push @pkg, 'Tie::Hash::NamedCapture' if !$PERL514; # dynamic since 5.14
8301  #push @pkg, 'DynaLoader'	      if $Config{usedl};
8302  # Win32CORE only in official cygwin pkg. And it needs to be bootstrapped,
8303  # handled by static_ext.
8304  push @pkg, 'Cygwin'		if $^O eq 'cygwin';
8305  push @pkg, 'NetWare'		if $^O eq 'NetWare';
8306  push @pkg, 'OS2'		if $^O eq 'os2';
8307  push @pkg, qw(VMS VMS::Filespec vmsish) if $^O eq 'VMS';
8308  #push @pkg, 'PerlIO' if $] >= 5.008006; # get_layers only
8309  push @pkg, split(/ /,$Config{static_ext});
8310  return @pkg;
8311}
8312
8313sub skip_pkg {
8314  my $package = shift;
8315  if ( $package =~ /^(main::)?(Internals|O)::/
8316       #or $package =~ /::::/ #  CORE/base/lex.t 54
8317       or $package =~ /^B::C::/
8318       or $package eq '__ANON__'
8319       or index($package, " ") != -1 # XXX skip invalid package names
8320       or index($package, "(") != -1 # XXX this causes the compiler to abort
8321       or index($package, ")") != -1 # XXX this causes the compiler to abort
8322       or exists $skip_package{$package}
8323       or ($DB::deep and $package =~ /^(DB|Term::ReadLine)/)) {
8324    return 1;
8325  }
8326  return 0;
8327}
8328
8329# Do not delete/ignore packages which were brought in from the script,
8330# i.e. not defined in B::C or O. Just to be on the safe side.
8331sub can_delete {
8332  my $pkg = shift;
8333  if (exists $all_bc_deps{$pkg} and $B::C::can_delete_pkg) { return 1 };
8334  return undef;
8335}
8336
8337sub should_save {
8338  no strict qw(vars refs);
8339  my $package = shift;
8340  $package =~ s/::$//;
8341  if ( skip_pkg($package) ) {
8342    delete_unsaved_hashINC($package) if can_delete($package);
8343    return 0;
8344  }
8345  return $include_package{$package} = 0
8346    if ( $package =~ /::::/ );    # skip ::::ISA::CACHE etc.
8347  warn "Considering $package\n" if $debug{pkg}; #$include_package{$package}
8348  return if index($package, " ") != -1; # XXX skip invalid package names
8349  return if index($package, "(") != -1; # XXX this causes the compiler to abort
8350  return if index($package, ")") != -1; # XXX this causes the compiler to abort
8351  # core static mro has exactly one member, ext/mro has more
8352  if ($package eq 'mro') {
8353    # B::C is setting %mro:: to 3, make sure we have at least 10
8354    if (!is_using_mro()) { # core or ext?
8355      warn "ext/mro not loaded - skip\n" if $debug{pkg};
8356      return;
8357    } else {
8358      warn "ext/mro already loaded\n" if $debug{pkg};
8359      # $include_package{mro} = 1 if grep { $_ eq 'mro' } @DynaLoader::dl_modules;
8360      return $include_package{mro};
8361    }
8362  }
8363  if ($package eq 'attributes' and $] > 5.011
8364      and grep { $_ eq 'attributes' } @DynaLoader::dl_modules)
8365  {
8366    mark_package($package, 1);
8367    return 1;
8368  }
8369  if (exists $all_bc_deps{$package}) {
8370    foreach my $u ( grep( $include_package{$_}, sort keys %include_package ) ) {
8371      # If this package is a prefix to something we are saving, traverse it
8372      # but do not mark it for saving if it is not already
8373      # e.g. to get to B::OP we need to traverse B:: but need not save B
8374      my $p = $package;
8375      $p =~ s/(\W)/\\$1/g;
8376      return 1 if ( $u =~ /^$p\:\:/ ) && $include_package{$package};
8377    }
8378  }
8379  # Needed since 5.12.2: Check already if deleted
8380  my $incpack = inc_packname($package);
8381  if ( $] > 5.015001 and exists $all_bc_deps{$package}
8382       and !exists $curINC{$incpack} and $savINC{$incpack} ) {
8383    $include_package{$package} = 0;
8384    warn "Cached $package not in \%INC, already deleted (early)\n" if $debug{pkg};
8385    return 0;
8386  }
8387  # issue348: only drop B::C packages, not any from user code.
8388  if (($package =~ /^DynaLoader|XSLoader$/ and $use_xsloader)
8389      or (!exists $all_bc_deps{$package})) {
8390    $include_package{$package} = 1;
8391  }
8392  # If this package is in the same file as main:: or our source, save it. (72, 73)
8393  if ($mainfile) {
8394    # Find the first cv in this package for CV->FILE
8395    no strict 'refs';
8396    for my $sym (sort keys %{$package.'::'}) {
8397      if (defined &{$package.'::'.$sym}) {
8398	# compare cv->FILE to $mainfile
8399	my $cv = svref_2object(\&{$package.'::'.$sym});
8400	if ($cv and $cv->can('FILE') and $cv->FILE) {
8401	  $include_package{$package} = 1 if $mainfile eq $cv->FILE;
8402	  last;
8403	}
8404      }
8405    }
8406  }
8407  if ($module and $package ne $module) {
8408    $include_package{$package} = 0;
8409    warn "Skip $package not in $mainfile\n" if $debug{pkg};
8410    return 0;
8411  }
8412  # add overloaded but otherwise empty packages (#172)
8413  if ($savINC{'overload.pm'} and exists ${$package.'::'}{OVERLOAD} and exists ${$package.'::'}{'()'}) {
8414    mark_package($package, 1);
8415    mark_package('overload', 1);
8416    return 1;
8417  }
8418  # Omit the packages which we use (and which cause grief
8419  # because of fancy "goto &$AUTOLOAD" stuff).
8420  # XXX Surely there must be a nicer way to do this.
8421  if ( exists $include_package{$package} ) {
8422    if (! exists $all_bc_deps{$package}) {
8423      $include_package{$package} = 1;
8424      $curINC{$incpack} = $savINC{$incpack};
8425      warn "Cached new $package is kept\n" if $debug{pkg};
8426    }
8427    elsif (!$include_package{$package}) {
8428      delete_unsaved_hashINC($package) if can_delete($package);
8429      warn "Cached $package is already deleted\n" if $debug{pkg};
8430    } else {
8431      warn "Cached $package is cached\n" if $debug{pkg};
8432    }
8433    return $include_package{$package};
8434  }
8435
8436  # Now see if current package looks like an OO class. This is probably too strong.
8437  if (!$all_bc_deps{$package}) {
8438    foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE)) {
8439      # 5.10 introduced version and Regexp::DESTROY, which we dont want automatically.
8440      # XXX TODO This logic here is wrong and unstable. Fixes lead to more failures.
8441      # The walker deserves a rewrite.
8442      if ( UNIVERSAL::can( $package, $m ) and $package !~ /^(B::C|version|Regexp|utf8|SelectSaver)$/ ) {
8443        next if $package eq 'utf8' and $m eq 'DESTROY'; # utf8::DESTROY is empty
8444        # we load Errno by ourself to avoid double Config warnings [perl #]
8445        # and we have special logic to detect and include it
8446        next if $package =~ /^(Errno|Tie::Hash::NamedCapture)$/ and $m eq 'TIEHASH';
8447        # XXX Config and FileHandle should not just return. If unneeded skip em.
8448        return 0 if $package eq 'Config' and $m =~ /DESTROY|TIEHASH/; # Config detected in GV
8449        # IO::File|IO::Handle added for B::CC only
8450        return 0 if $package =~ /^(FileHandle|IO::File|IO::Handle)/ and $m eq 'new';
8451        warn "$package has method $m: saving package\n" if $debug{pkg};
8452        return mark_package($package);
8453      }
8454    }
8455  }
8456  if ($package !~ /^PerlIO/ and can_delete($package)) {
8457    delete_unsaved_hashINC($package);
8458  }
8459  if (can_delete($package)) {
8460    warn "Delete $package\n" if $debug{pkg};
8461    return $include_package{$package} = 0;
8462  } elsif (! exists $all_bc_deps{$package}) { # and not in @deps
8463    warn "Keep $package\n" if $debug{pkg};
8464    return $include_package{$package} = 1;
8465  } else { # in @deps
8466    # warn "Ignore $package\n" if $debug{pkg};
8467    return;
8468  }
8469}
8470
8471sub inc_packname {
8472  my $package = shift;
8473  # See below at the reverse packname_inc: utf8 => utf8.pm + utf8_heavy.pl
8474  $package =~ s/\:\:/\//g;
8475  $package .= '.pm';
8476  return $package;
8477}
8478
8479sub packname_inc {
8480  my $package = shift;
8481  $package =~ s/\//::/g;
8482  if ($package =~ /^(Config_git\.pl|Config_heavy.pl)$/) {
8483    return 'Config';
8484  }
8485  if ($package eq 'utf8_heavy.pl') {
8486    return 'utf8';
8487  }
8488  $package =~ s/\.p[lm]$//;
8489  return $package;
8490}
8491
8492sub delete_unsaved_hashINC {
8493  my $package = shift;
8494  my $incpack = inc_packname($package);
8495  # Not already saved package, so it is not loaded again at run-time.
8496  return if $dumped_package{$package};
8497  # Never delete external packages, but this check is done before
8498  return if $package =~ /^DynaLoader|XSLoader$/
8499    and defined $use_xsloader
8500    and $use_xsloader == 0;
8501  return if $^O eq 'MSWin32' and $package =~ /^Carp|File::Basename$/;
8502  $include_package{$package} = 0;
8503  if ($curINC{$incpack}) {
8504    #warn "Deleting $package from \%INC\n" if $debug{pkg};
8505    $savINC{$incpack} = $curINC{$incpack} if !$savINC{$incpack};
8506    $curINC{$incpack} = undef;
8507    delete $curINC{$incpack};
8508  }
8509}
8510
8511sub add_hashINC {
8512  my $package = shift;
8513  my $incpack = inc_packname($package);
8514  $include_package{$package} = 1;
8515  unless ($curINC{$incpack}) {
8516    if ($savINC{$incpack}) {
8517      warn "Adding $package to \%INC (again)\n" if $debug{pkg};
8518      $curINC{$incpack} = $savINC{$incpack};
8519      # need to check xsub
8520      $use_xsloader = 1 if $package =~ /^DynaLoader|XSLoader$/;
8521    } else {
8522      warn "Adding $package to \%INC\n" if $debug{pkg};
8523      for (@INC) {
8524        my $p = $_.'/'.$incpack;
8525        if (-e $p) { $curINC{$incpack} = $p; last; }
8526      }
8527      $curINC{$incpack} = $incpack unless $curINC{$incpack};
8528    }
8529  }
8530}
8531
8532sub walkpackages {
8533  my ( $symref, $recurse, $prefix ) = @_;
8534  no strict 'vars';
8535  $prefix = '' unless defined $prefix;
8536  # check if already deleted - failed since 5.15.2
8537  return if $savINC{inc_packname(substr($prefix,0,-2))};
8538  for my $sym (sort keys %$symref) {
8539    my $ref = $symref->{$sym};
8540    next unless $ref;
8541    local (*glob);
8542    *glob = $ref;
8543    if ( $sym =~ /::$/ ) {
8544      $sym = $prefix . $sym;
8545      warn("Walkpackages $sym\n") if $debug{pkg} and $debug{walk};
8546      # This walker skips main subs to avoid recursion into O compiler subs again
8547      # and main syms are already handled
8548      if ( $sym ne "main::" && $sym ne "<none>::" && &$recurse($sym) ) {
8549        walkpackages( \%glob, $recurse, $sym );
8550      }
8551    }
8552  }
8553}
8554
8555sub save_unused_subs {
8556  no strict qw(refs);
8557  my %sav_debug;
8558  if ( $debug{unused} ) {
8559    %sav_debug = %debug;
8560    %debug = ();
8561  }
8562  my $main = $module ? $module."::" : "main::";
8563
8564  # -fwalkall: better strategy for compile-time added and required packages:
8565  # loop savecv and check pkg cache for new pkgs.
8566  # if so loop again with those new pkgs only, until the list of new pkgs is empty
8567  my ($walkall_cnt, @init_unused, @unused, @dumped) = (0);
8568  #do
8569  @init_unused = grep { $include_package{$_} } keys %include_package;
8570  if ($verbose) {
8571    warn "Prescan for unused subs in $main " . ($sav_debug{unused} ? " (silent)\n" : "\n");
8572  }
8573  # XXX TODO better strategy for compile-time added and required packages:
8574  # loop savecv and check pkg cache for new pkgs.
8575  # if so loop again with those new pkgs only, until the list of new pkgs is empty
8576  descend_marked_unused();
8577  walkpackages( \%{$main}, \&should_save, $main eq 'main::' ? undef : $main );
8578  warn "Saving unused subs in $main" . ($sav_debug{unused} ? " (silent)\n" : "\n")
8579    if $verbose;
8580  walksymtable( \%{$main}, "savecv", \&should_save );
8581  @unused = grep { $include_package{$_} } keys %include_package;
8582  @dumped = grep { $dumped_package{$_} and $_ ne 'main' } keys %dumped_package;
8583  warn sprintf("old unused: %d, new: %d, dumped: %d\n", scalar @init_unused, scalar @unused, scalar @dumped)
8584    if $verbose;
8585  if (!$B::C::walkall) {
8586    @unused = @init_unused = ();
8587  } else {
8588    my $done;
8589    do {
8590      $done = dump_rest();
8591      @unused = grep { $include_package{$_} } keys %include_package;
8592      @dumped = grep { $dumped_package{$_} and $_ ne 'main' } keys %dumped_package;
8593    } while @unused > @dumped and $done;
8594    last if $walkall_cnt++ > 3;
8595  }
8596  #} while @unused > @init_unused;
8597
8598  if ( $sav_debug{unused} ) {
8599    %debug = %sav_debug;
8600  }
8601
8602  # If any m//i is run-time loaded we'll get a "Undefined subroutine utf8::SWASHNEW"
8603  # With -fno-fold we don't insist on loading utf8_heavy and Carp.
8604  # Until it is compile-time required.
8605  if (exists($INC{'unicore/To/Title.pl'})
8606      or exists($INC{'unicore/To/Tc.pl'}) #242
8607      or exists($INC{'unicore/Heavy.pl'}) #242
8608      or ($savINC{'utf8_heavy.pl'} and ($B::C::fold or exists($savINC{'utf8.pm'})))) {
8609    require "utf8.pm" unless $savINC{"utf8.pm"};
8610    mark_package('utf8');
8611    load_utf8_heavy();
8612  }
8613  # run-time Carp
8614  # With -fno-warnings we don't insist on initializing warnings::register_categories and Carp.
8615  # Until it is compile-time required.
8616  # 68KB exe size 32-bit
8617  if ($] >= 5.013005 and ($B::C::warnings and exists $dumped_package{Carp})) {
8618    svref_2object( \&{"warnings\::register_categories"} )->save; # 68Kb 32bit
8619    add_hashINC("warnings");
8620    add_hashINC("warnings::register");
8621  }
8622  #196 missing INIT
8623  if ($xsub{EV} and $dumped_package{EV} and $EV::VERSION le '4.21') {
8624    $init2->add_eval
8625      (
8626       q(EV::default_loop() or )
8627       .q(die 'EV: cannot initialise libev backend. bad $ENV{LIBEV_FLAGS}?';)
8628      );
8629  }
8630  if ($use_xsloader) {
8631    force_saving_xsloader();
8632    mark_package('Config', 1); # required by Dynaloader and special cased previously
8633  }
8634}
8635
8636sub inc_cleanup {
8637  my $rec_cnt = shift;
8638  # %INC sanity check issue 89:
8639  # omit unused, unsaved packages, so that at least run-time require will pull them in.
8640  my @deleted_inc;
8641  if ($CPERL51) {
8642    for (qw(strict coretypes DynaLoader XSLoader)) {
8643      $dumped_package{$_}++;
8644      $curINC{$_.".pm"} = $INC{$_.".pm"};
8645    }
8646  }
8647  for my $package (sort keys %INC) {
8648    my $pkg = packname_inc($package);
8649    if ($package =~ /^(Config_git\.pl|Config_heavy.pl)$/ and !$dumped_package{'Config'}) {
8650      delete $curINC{$package};
8651    } elsif ($package eq 'utf8_heavy.pl' and !$include_package{'utf8'}) {
8652      delete $curINC{$package};
8653      delete_unsaved_hashINC('utf8');
8654    } elsif (!$B::C::walkall and !exists $dumped_package{$pkg}) {
8655      delete_unsaved_hashINC($pkg);
8656      push @deleted_inc, $pkg;
8657    }
8658  }
8659  # sync %curINC deletions back to %INC
8660  for my $p (sort keys %INC) {
8661    if (!exists $curINC{$p}) {
8662      delete $INC{$p};
8663      push @deleted_inc, $p;
8664    }
8665  }
8666  if ($debug{pkg} and $verbose) {
8667    warn "\%include_package: ".join(" ",grep{$include_package{$_}} sort keys %include_package)."\n";
8668    warn "\%dumped_package:  ".join(" ",grep{$dumped_package{$_}} sort keys %dumped_package)."\n";
8669  }
8670  # issue 340,350: do only on -fwalkall? do it in the main walker step
8671  # as in branch walkall-early?
8672  if ($B::C::walkall) {
8673    my $again = dump_rest();
8674    inc_cleanup($rec_cnt++) if $again and $rec_cnt < 2; # maximal 3 times
8675  }
8676  # final cleanup
8677  for my $p (sort keys %INC) {
8678    my $pkg = packname_inc($p);
8679    delete_unsaved_hashINC($pkg) unless exists $dumped_package{$pkg};
8680    # sync %curINC deletions back to %INC
8681    if (!exists $curINC{$p} and exists $INC{$p}) {
8682      delete $INC{$p};
8683      push @deleted_inc, $p;
8684    }
8685  }
8686  if ($debug{pkg} and $verbose) {
8687    warn "Deleted from \%INC: ".join(" ",@deleted_inc)."\n" if @deleted_inc;
8688    my @inc = grep !/auto\/.+\.(al|ix)$/, sort keys %INC;
8689    warn "\%INC: ".join(" ",@inc)."\n";
8690  }
8691}
8692
8693sub dump_rest {
8694  my $again;
8695  warn "dump_rest:\n" if $verbose or $debug{pkg};
8696  #for my $p (sort keys %INC) {
8697  #}
8698  for my $p (sort keys %include_package) {
8699    $p =~ s/^main:://;
8700    if ($include_package{$p} and !exists $dumped_package{$p}
8701        and !$static_core_pkg{$p}
8702        and $p !~ /^(threads|main|__ANON__|PerlIO)$/
8703       )
8704    {
8705      next if $module and $p ne $module;
8706      if ($p eq 'warnings::register' and !$B::C::warnings) {
8707        delete_unsaved_hashINC('warnings::register');
8708        next;
8709      }
8710      $again++;
8711      warn "$p marked but not saved, save now\n" if $verbose or $debug{pkg};
8712      # mark_package( $p, 1);
8713      #eval {
8714      #  require(inc_packname($p)) && add_hashINC( $p );
8715      #} unless $savINC{inc_packname($p)};
8716      walk_syms( $p );
8717    }
8718  }
8719  $again;
8720}
8721
8722my @made_c3;
8723
8724sub make_c3 {
8725  my $package = shift or die;
8726
8727  return if ( grep { $_ eq $package } @made_c3 );
8728  push @made_c3, $package;
8729
8730  mark_package( 'mro', 1 );
8731  mark_package($package);
8732  my $isa_packages = mro::get_linear_isa($package) || [];
8733  foreach my $isa (@$isa_packages) {
8734    mark_package($isa);
8735  }
8736  warn "set c3 for $package\n" if $verbose or $debug{pkg};
8737
8738  ## from setmro.xs:
8739  # classname = ST(0);
8740  # class_stash = gv_stashsv(classname, GV_ADD);
8741  # meta = HvMROMETA(class_stash);
8742  # Perl_mro_set_mro(aTHX_ meta, ST(1));
8743
8744  $init2->add( sprintf( 'Perl_mro_set_mro(aTHX_ HvMROMETA(%s), newSVpvs("c3"));',
8745                        savestashpv($package) ) );
8746}
8747
8748# global state only, unneeded for modules
8749sub save_context {
8750  # forbid run-time extends of curpad syms, names and INC
8751  warn "save context:\n" if $verbose;
8752  my $warner = $SIG{__WARN__};
8753  save_sig($warner) if $B::C::save_sig;
8754  # honour -w and %^H
8755  $init->add( "/* honor -w */",
8756    sprintf "PL_dowarn = ( %s ) ? G_WARN_ON : G_WARN_OFF;", $^W );
8757  if ($^{TAINT}) {
8758    $init->add( "/* honor -Tt */",
8759                "PL_tainting = TRUE;",
8760                # -T -1 false, -t 1 true
8761                "PL_taint_warn = ".($^{TAINT} < 0 ? "FALSE" : "TRUE").";");
8762  }
8763
8764  if ($PERL510) {
8765    # need to mark assign c3 to %main::. no need to assign the default dfs
8766    if (is_using_mro() && mro::get_mro("main") eq 'c3') {
8767        make_c3('main');
8768    }
8769    # Tie::Hash::NamedCapture is added for *+ *-, Errno for *!
8770    #no strict 'refs';
8771    #if ( defined(objsym(svref_2object(\*{'main::+'}))) or defined(objsym(svref_2object(\*{'main::-'}))) ) {
8772    #  use strict 'refs';
8773    #  if (!$include_package{'Tie::Hash::NamedCapture'}) {
8774    #	$init->add("/* force saving of Tie::Hash::NamedCapture */");
8775    #    if ($] >= 5.014) {
8776    #      mark_package('Config', 1);  # DynaLoader needs Config to set the EGV
8777    #      walk_syms('Config');
8778    #      svref_2object(\&{'Tie::Hash::NamedCapture::bootstrap'})->save;
8779    #    }
8780    #	mark_package('Tie::Hash::NamedCapture', 1);
8781    #  } # else already included
8782    #} else {
8783    #  use strict 'refs';
8784    #  delete_unsaved_hashINC('Tie::Hash::NamedCapture');
8785    #}
8786    no strict 'refs';
8787    if ( defined(objsym(svref_2object(\*{'main::!'}))) ) {
8788      use strict 'refs';
8789      if (!$module and !$include_package{'Errno'}) {
8790	$init->add("/* force saving of Errno */");
8791	mark_package('Config', 1);
8792        walk_syms('Config');
8793	mark_package('Errno', 1);
8794        svref_2object(\&{'Errno::bootstrap'})->save;
8795      } # else already included
8796    } else {
8797      use strict 'refs';
8798      delete_unsaved_hashINC('Errno');
8799    }
8800  }
8801
8802  my ($curpad_nam, $curpad_sym);
8803  {
8804    # Record comppad sv's names, may not be static
8805    local $B::C::const_strings = 0;
8806    $init->add("/* curpad names */");
8807    warn "curpad names:\n" if $verbose;
8808    $curpad_nam      = ( comppadlist->ARRAY )[0]->save('curpad_name');
8809    warn "curpad syms:\n" if $verbose;
8810    $init->add("/* curpad syms */");
8811    $curpad_sym      = ( comppadlist->ARRAY )[1]->save('curpad_syms');
8812  }
8813  my ($inc_hv, $inc_av);
8814  {
8815    local $B::C::const_strings = 1 if $B::C::ro_inc;
8816    warn "\%INC and \@INC:\n" if $verbose;
8817    $init->add('/* %INC */');
8818    inc_cleanup(0);
8819    my $inc_gv = svref_2object( \*main::INC );
8820    $inc_hv    = $inc_gv->HV->save('main::INC');
8821    if ($cross) {
8822      $init->add('/* cross @INC */');
8823      my @crossinc = ($Config{archlib});
8824      if ($Config{archlib} ne $Config{privlib}) {
8825        push @crossinc, $Config{privlib};
8826      }
8827      if (exists $Config{sitearch} and $Config{sitearch}) {
8828        unshift @crossinc, $Config{sitearch};
8829        unshift @crossinc, $Config{sitelib}
8830          if $Config{sitearch} ne $Config{sitelib};
8831      }
8832      if (exists $Config{vendorarch} and $Config{vendorarch}) {
8833        push @crossinc, $Config{vendorarch};
8834        push @crossinc, $Config{vendorlib}
8835          if $Config{vendorarch} ne $Config{vendorlib};
8836      }
8837      if ($] < 5.026 and !$Config{usecperl}) {
8838        push @crossinc, '.';
8839      }
8840      $inc_av    = svref_2object(\@crossinc)->save('main::INC');
8841    } else {
8842      $init->add('/* @INC */');
8843      $inc_av    = $inc_gv->AV->save('main::INC');
8844    }
8845  }
8846  # ensure all included @ISA's are stored (#308), and also assign c3 (#325)
8847  my @saved_isa;
8848  for my $p (sort keys %include_package) {
8849    no strict 'refs';
8850    if ($include_package{$p} and exists(${$p.'::'}{ISA}) and ${$p.'::'}{ISA}) {
8851      push @saved_isa, $p;
8852      svref_2object( \@{$p.'::ISA'} )->save($p.'::ISA');
8853      if ($PERL510 and is_using_mro() && mro::get_mro($p) eq 'c3') {
8854        make_c3($p);
8855      }
8856    }
8857  }
8858  warn "Saved \@ISA for: ".join(" ",@saved_isa)."\n" if @saved_isa and ($verbose or $debug{pkg});
8859  $init->add(
8860    "GvHV(PL_incgv) = $inc_hv;",
8861    "GvAV(PL_incgv) = $inc_av;",
8862    "PL_curpad = AvARRAY($curpad_sym);",
8863    "PL_comppad = $curpad_sym;",    # fixed "panic: illegal pad"
8864    "PL_stack_sp = PL_stack_base;"  # reset stack (was 1++)
8865  );
8866  if ($] < 5.017005) {
8867    $init->add(
8868      "av_store((AV*)CvPADLIST(PL_main_cv), 0, SvREFCNT_inc_simple_NN($curpad_nam)); /* namepad */",
8869      "av_store((AV*)CvPADLIST(PL_main_cv), 1, SvREFCNT_inc_simple_NN($curpad_sym)); /* curpad */");
8870  } elsif ($] < 5.019003) {
8871    $init->add(
8872      "PadlistARRAY(CvPADLIST(PL_main_cv))[0] = PL_comppad_name = (PAD*)SvREFCNT_inc_simple_NN($curpad_nam); /* namepad */",
8873      "PadlistARRAY(CvPADLIST(PL_main_cv))[1] = (PAD*)SvREFCNT_inc_simple_NN($curpad_sym); /* curpad */");
8874  } elsif ($] < 5.022) {
8875    $init->add(
8876      "PadlistARRAY(CvPADLIST(PL_main_cv))[0] = PL_comppad_name = (PAD*)SvREFCNT_inc_simple_NN($curpad_nam); /* namepad */",
8877      "PadnamelistMAXNAMED(PL_comppad_name) = AvFILL($curpad_nam);",
8878      "PadlistARRAY(CvPADLIST(PL_main_cv))[1] = (PAD*)SvREFCNT_inc_simple_NN($curpad_sym); /* curpad */");
8879  } else {
8880    $init->add(
8881      "PadlistNAMES(CvPADLIST(PL_main_cv)) = PL_comppad_name = $curpad_nam; /* namepad */",
8882      "PadlistARRAY(CvPADLIST(PL_main_cv))[1] = (PAD*)$curpad_sym; /* curpad */");
8883  }
8884  if ($] < 5.017) {
8885    my $amagic_generate = B::amagic_generation();
8886    warn "amagic_generation = $amagic_generate\n" if $verbose;
8887    $init->add("PL_amagic_generation = $amagic_generate;");
8888  };
8889}
8890
8891sub descend_marked_unused {
8892  #if ($B::C::walkall) {
8893  #  for my $pack (keys %all_bc_deps) {
8894  #    mark_unused($pack, 0) if !exists $include_package{$pack} and !skip_pkg($pack);
8895  #  }
8896  #}
8897  foreach my $pack ( sort keys %INC ) {
8898    my $p = packname_inc($pack);
8899    mark_package($p) if !skip_pkg($p) and !$all_bc_deps{$p} and $pack !~ /(autosplit\.ix|\.al)$/;
8900  }
8901  if ($debug{pkg} and $verbose) {
8902    warn "\%include_package: ".join(" ",grep{$include_package{$_}} sort keys %include_package)."\n";
8903    warn "\%skip_package: ".join(" ",sort keys %skip_package)."\n";
8904  }
8905  foreach my $pack ( sort keys %include_package ) {
8906    mark_package($pack) unless skip_pkg($pack);
8907  }
8908  warn "descend_marked_unused: "
8909    .join(" ",sort keys %include_package)."\n" if $debug{pkg};
8910}
8911
8912sub save_main {
8913
8914  warn "Starting compile\n" if $verbose;
8915  warn "Walking tree\n"     if $verbose;
8916  %Exporter::Cache = (); # avoid B::C and B symbols being stored
8917  _delete_macros_vendor_undefined() if $PERL512;
8918  set_curcv B::main_cv;
8919  seek( STDOUT, 0, 0 );    #exclude print statements in BEGIN{} into output
8920  binmode( STDOUT, ':utf8' ) unless $PERL56;
8921
8922  $verbose
8923    ? walkoptree_slow( main_root, "save" )
8924    : walkoptree( main_root, "save" );
8925  save_main_rest();
8926}
8927
8928sub _delete_macros_vendor_undefined {
8929  foreach my $class (qw(POSIX IO Fcntl Socket Exporter Errno)) {
8930    no strict 'refs';
8931    no strict 'subs';
8932    no warnings 'uninitialized';
8933    my $symtab = $class . '::';
8934    for my $symbol ( sort keys %$symtab ) {
8935      next if $symbol !~ m{^[0-9A-Z_]+$} || $symbol =~ m{(?:^ISA$|^EXPORT|^DESTROY|^TIE|^VERSION|^AUTOLOAD|^BEGIN|^INIT|^__|^DELETE|^CLEAR|^STORE|^NEXTKEY|^FIRSTKEY|^FETCH|^EXISTS)};
8936      next if ref $symtab->{$symbol};
8937      local $@;
8938      my $code = "$class\:\:$symbol();";
8939      eval $code;
8940      if ( $@ =~ m{vendor has not defined} ) {
8941        delete $symtab->{$symbol};
8942        next;
8943      }
8944    }
8945  }
8946  return 1;
8947}
8948
8949sub fixup_ppaddr {
8950  # init op addrs must be the last action, otherwise
8951  # some ops might not be initialized
8952  # but it needs to happen before CALLREGCOMP, as a /i calls a compiled utf8::SWASHNEW
8953  if ($B::C::optimize_ppaddr) {
8954    foreach my $i (@op_sections) {
8955      my $section = $$i;
8956      my $num = $section->index;
8957      next unless $num >= 0;
8958      init_op_addr( $section->name, $num + 1 );
8959    }
8960  }
8961}
8962
8963# save %SIG ( in case it was set in a BEGIN block )
8964sub save_sig {
8965  # local $SIG{__WARN__} = shift;
8966  $init->no_split;
8967  my @save_sig;
8968  foreach my $k ( sort keys %SIG ) {
8969    next unless ref $SIG{$k};
8970    my $cvref = svref_2object( \$SIG{$k} );
8971    next if ref($cvref) eq 'B::CV' and $cvref->FILE =~ m|B/C\.pm$|; # ignore B::C SIG warn handler
8972    push @save_sig, [$k, $cvref];
8973  }
8974  unless (@save_sig) {
8975    $init->add( "/* no %SIG in BEGIN block */" ) if $verbose;
8976    warn "no %SIG in BEGIN block\n" if $verbose;
8977    return;
8978  }
8979  $init->add( "/* save %SIG */" ) if $verbose;
8980  warn "save %SIG\n" if $verbose;
8981  $init->add( "{", "\tHV* hv = get_hvs(\"main::SIG\", GV_ADD);" );
8982  foreach my $x ( @save_sig ) {
8983    my ($k, $cvref) = @$x;
8984    my $sv = $cvref->save;
8985    my ($cstring, $cur, $utf8) = strlen_flags($k);
8986    $init->add( '{', sprintf "\t".'SV* sv = (SV*)%s;', $sv );
8987    $init->add( sprintf("\thv_store(hv, %s, %u, %s, %d);",
8988                        $cstring, $cur, 'sv', 0 ) );
8989    $init->add( "\t".'mg_set(sv);', '}' );
8990  }
8991  $init->add('}');
8992  $init->split;
8993}
8994
8995sub force_saving_xsloader {
8996  mark_package("XSLoader", 1);
8997  # mark_package("DynaLoader", 1);
8998  if ($] < 5.015003) {
8999    $init->add("/* force saving of XSLoader::load */");
9000    eval { XSLoader::load; };
9001    # does this really save the whole packages?
9002    $dumped_package{XSLoader} = 1;
9003    svref_2object( \&XSLoader::load )->save;
9004  } elsif ($CPERL51) {
9005    $init->add("/* XSLoader::load_file already builtin into cperl */");
9006    $dumped_package{XSLoader} = 1;
9007    $dumped_package{DynaLoader} = 1;
9008    add_hashINC("XSLoader"); # builtin
9009  } else {
9010    $init->add("/* custom XSLoader::load_file */");
9011    # does this really save the whole packages?
9012    $dumped_package{DynaLoader} = 1;
9013    svref_2object( \&XSLoader::load_file )->save;
9014    svref_2object( \&DynaLoader::dl_load_flags )->save; # not saved as XSUB constant?
9015  }
9016  add_hashINC("XSLoader") if $] < 5.015003;
9017  add_hashINC("DynaLoader");
9018  $use_xsloader = 0; # do not load again
9019}
9020
9021sub save_main_rest {
9022  # this is mainly for the test suite
9023  # local $SIG{__WARN__} = sub { print STDERR @_ } unless $debug{runtime};
9024
9025  warn "done main optree, walking symtable for extras\n"
9026    if $verbose or $debug{cv};
9027  $init->add("");
9028  $init->add("/* done main optree, extra subs which might be unused */");
9029  save_unused_subs();
9030  $init->add("/* done extras */");
9031
9032  # startpoints: XXX TODO push BEGIN/END blocks to modules code.
9033  warn "Writing init_av\n" if $debug{av};
9034  my $init_av = init_av->save('INIT');
9035  my $end_av;
9036  {
9037    # >=5.10 need to defer nullifying of all vars in END, not only new ones.
9038    local ($B::C::pv_copy_on_grow, $B::C::const_strings);
9039    $in_endav = 1;
9040    warn "Writing end_av\n" if $debug{av};
9041    $init->add("/* END block */");
9042    $end_av = end_av->save('END');
9043    $in_endav = 0;
9044  }
9045  if ( !defined($module) ) {
9046    $init->add(
9047      "/* startpoints */",
9048      sprintf( "PL_main_root = s\\_%x;",  ${ main_root() } ),
9049      sprintf( "PL_main_start = s\\_%x;", ${ main_start() } ),
9050    );
9051    $init->add(index($init_av,'(AV*)')>=0
9052               ? "PL_initav = $init_av;"
9053               : "PL_initav = (AV*)$init_av;");
9054    $init->add(index($end_av,'(AV*)')>=0
9055               ? "PL_endav = $end_av;"
9056               : "PL_endav = (AV*)$end_av;");
9057
9058    save_context();
9059    # warn "use_xsloader=$use_xsloader\n" if $verbose;
9060    # If XSLoader was forced later, e.g. in curpad, INIT or END block
9061    force_saving_xsloader() if $use_xsloader;
9062  }
9063  $init->add('/* B::C specific: prepend static svs to arena for sv_clean_objs */',
9064             'if (&sv_list != (void *)PL_sv_arenaroot)',
9065             '    SvANY(&sv_list[0]) = (void *)PL_sv_arenaroot;',
9066             'PL_sv_arenaroot = &sv_list[0];');
9067
9068  return if $check;
9069  warn "Writing output\n" if $verbose;
9070  my $cmodule = defined $module ? $module : "main";
9071  $cmodule =~ s/::/__/g;
9072  output_boilerplate($cmodule);
9073
9074  # add static modules like " Win32CORE"
9075  foreach my $stashname ( split /\s+/, $Config{static_ext} ) {
9076    next if $stashname =~ /^\s*$/;    # often a leading space
9077    $static_ext{$stashname}++;
9078    my $stashxsub = $stashname;
9079    $stashxsub =~ s/::/__/g;
9080    print "EXTERN_C void boot_$stashxsub (pTHX_ CV* cv);\n" unless defined $module;
9081  }
9082  print "\n";
9083  output_all($init_name || "perl_init");
9084  print "\n";
9085
9086  if ( defined($module) ) {
9087    save_destruct($cmodule);
9088
9089    my $start = "&op_list[0]";
9090    warn "curpad syms:\n" if $verbose;
9091    $init->add("/* curpad syms */");
9092    my $curpad_sym = ( comppadlist->ARRAY )[1]->save;
9093
9094    print <<"EOT";
9095
9096XS(boot_$cmodule)
9097{
9098    int exitstatus;
9099    dXSARGS;
9100    dVAR;
9101EOT
9102    print <<'EOT' if $PERL510 and ($ITHREADS or $MULTI);
9103  {
9104    MY_CXT_INIT;
9105    dMY_CXT;
9106EOT
9107    print <<'EOT';
9108
9109    ENTER;
9110    SAVETMPS;
9111    SAVEVPTR(PL_curpad);
9112    SAVEVPTR(PL_op);
9113
9114EOT
9115
9116    output_init();
9117
9118    print <<"EOT";
9119
9120    PL_curpad = AvARRAY($curpad_sym);
9121    PL_comppad = $curpad_sym;
9122    PL_op = $start;
9123EOT
9124
9125    print $DEBUGGING
9126      ? "    Perl_runops_debug(aTHX);\n"
9127      : "    Perl_runops_standard(aTHX);\n";
9128    output_local_destruct($cmodule);
9129
9130    print <<'EOT';
9131
9132    FREETMPS;
9133    LEAVE;
9134    ST(0) = &PL_sv_yes;
9135    XSRETURN(1);
9136EOT
9137    print <<"EOT" if $PERL510 and ($ITHREADS or $MULTI);
9138  }
9139EOT
9140    print <<'EOT';
9141}
9142EOT
9143
9144  } else {
9145    output_main_rest();
9146    output_main();
9147  }
9148}
9149
9150sub init_sections {
9151  my @sections = (
9152    decl   => \$decl,
9153    init0  => \$init0,
9154    free   => \$free,
9155    sym    => \$symsect,
9156    hek    => \$heksect,
9157    binop  => \$binopsect,
9158    condop => \$condopsect,
9159    cop    => \$copsect,
9160    padop  => \$padopsect,
9161    listop => \$listopsect,
9162    logop  => \$logopsect,
9163    loop   => \$loopsect,
9164    op     => \$opsect,
9165    pmop   => \$pmopsect,
9166    pvop   => \$pvopsect,
9167    svop   => \$svopsect,
9168    unop   => \$unopsect,
9169    unopaux => \$unopauxsect,
9170    methop => \$methopsect,
9171    sv     => \$svsect,
9172    xpv    => \$xpvsect,
9173    xpvav  => \$xpvavsect,
9174    xpvhv  => \$xpvhvsect,
9175    xpvcv  => \$xpvcvsect,
9176    xpviv  => \$xpvivsect,
9177    xpvuv  => \$xpvuvsect,
9178    xpvnv  => \$xpvnvsect,
9179    xpvmg  => \$xpvmgsect,
9180    xpvlv  => \$xpvlvsect,
9181    xrv    => \$xrvsect,
9182    xpvbm  => \$xpvbmsect,
9183    xpvio  => \$xpviosect,
9184    padlist => \$padlistsect,
9185    padnamelist => \$padnlsect,
9186    padname => \$padnamesect,
9187  );
9188  if ($PERL522) {
9189    pop @sections;
9190  }
9191  my ( $name, $sectref );
9192  while ( ( $name, $sectref ) = splice( @sections, 0, 2 ) ) {
9193    $$sectref = new B::C::Section $name, \%symtable, 0;
9194  }
9195  if ($PERL522) {
9196    for my $size (@padnamesect_sizes) {
9197      my $name = "padname_$size";
9198      $padnamesect{$size} = new B::C::Section $name, \%symtable, 0;
9199    }
9200  }
9201  $init  = new B::C::InitSection 'init', \%symtable, 0;
9202  $init1 = new B::C::InitSection 'init1', \%symtable, 0;
9203  $init2 = new B::C::InitSection 'init2', \%symtable, 0;
9204  %savINC = %curINC = %INC;
9205}
9206
9207sub mark_unused {
9208  my ( $pkg, $val ) = @_;
9209  $include_package{$pkg} = $val;
9210}
9211
9212sub mark_skip {
9213  for (@_) {
9214    delete_unsaved_hashINC($_);
9215    # $include_package{$_} = 0;
9216    $skip_package{$_} = 1 unless $include_package{$_};
9217  }
9218}
9219
9220sub compile {
9221  my @options = @_;
9222  # Allow debugging in CHECK blocks without Od
9223  $DB::single = 1 if defined &DB::DB;
9224  my ( $option, $opt, $arg );
9225  my @eval_at_startup;
9226  $B::C::can_delete_pkg = 1;
9227  $B::C::save_sig = 1;
9228  $B::C::destruct = 1;
9229  $B::C::stash    = 0;
9230  $B::C::cow      = 0;
9231  $B::C::fold     = 1 if $] >= 5.013009; # always include utf8::Cased tables
9232  $B::C::warnings = 1 if $] >= 5.013005; # always include Carp warnings categories and B
9233  $B::C::optimize_warn_sv = 1 if $^O ne 'MSWin32' or $Config{cc} !~ m/^cl/i;
9234  $B::C::dyn_padlist = 1 if $] >= 5.017; # default is dynamic and safe, disable with -O4
9235  $B::C::walkall  = 1;
9236
9237  mark_skip qw(B::C B::C::Config B::CC B::Asmdata B::FAKEOP O
9238	       B::Pseudoreg B::Shadow B::C::InitSection);
9239  #mark_skip('DB', 'Term::ReadLine') if defined &DB::DB;
9240
9241OPTION:
9242  while ( $option = shift @options ) {
9243    if ( $option =~ /^-(cross)=(.*)/ ) {
9244      $opt = $1;
9245      $arg = $2;
9246    }
9247    elsif ( $option =~ /^-(.)(.*)/ ) {
9248      $opt = $1;
9249      $arg = $2;
9250    }
9251    else {
9252      unshift @options, $option;
9253      last OPTION;
9254    }
9255    if ( $opt eq "-" && $arg eq "-" ) {
9256      shift @options;
9257      last OPTION;
9258    }
9259    if ( $opt eq "w" ) {
9260      $warn_undefined_syms = 1;
9261    }
9262    if ( $opt eq "c" ) {
9263      $check = 1;
9264    }
9265    elsif ( $opt eq "D" ) {
9266      $arg ||= shift @options;
9267      if ($arg eq 'full') {
9268        $arg = 'OcAHCMGSPpsWF';
9269        $all_bc_deps{'B::Flags'}++;
9270      }
9271      elsif ($arg eq 'ufull') {
9272        $arg = 'uOcAHCMGSPpsWF';
9273        $all_bc_deps{'B::Flags'}++;
9274      }
9275      foreach my $arg ( split( //, $arg ) ) {
9276        if (exists $debug_map{$arg}) {
9277          $debug{ $debug_map{$arg} }++;
9278        }
9279        elsif ( $arg eq "o" ) {
9280	  $verbose++;
9281	  B->debug(1);
9282        }
9283        elsif ( $arg eq "F" ) {
9284          $debug{flags}++ if $] > 5.008 and eval "require B::Flags;";
9285          $all_bc_deps{'B::Flags'}++;
9286          # $debug{flags}++ if require B::Flags;
9287        }
9288        elsif ( $arg eq "r" ) {
9289          $debug{runtime}++;
9290	  $SIG{__WARN__} = sub {
9291	    warn @_;
9292	    my $s = join(" ", @_);
9293	    chomp $s;
9294	    $init->add("/* ".$s." */") if $init;
9295	  };
9296        }
9297        else {
9298          warn "ignoring unknown debug option: $arg\n";
9299        }
9300      }
9301    }
9302    elsif ( $opt eq "o" ) {
9303      $arg ||= shift @options;
9304      $outfile = $arg;
9305      if ($check) {
9306	warn "Warning: -o argument ignored with -c\n";
9307      } else {
9308	open( STDOUT, ">", $arg ) or return "$arg: $!\n";
9309      }
9310    }
9311    elsif ( $opt eq "s" and $arg eq "taticxs" ) {
9312      $outfile = "perlcc" unless $outfile;
9313      $staticxs = 1;
9314    }
9315    elsif ( $opt eq "n" ) {
9316      $arg ||= shift @options;
9317      $init_name = $arg;
9318    }
9319    elsif ( $opt eq "m" ) {
9320      # $arg ||= shift @options;
9321      $module = $arg;
9322      mark_unused( $arg, 1 );
9323    }
9324    elsif ( $opt eq "v" ) {
9325      $verbose = 1;
9326    }
9327    elsif ( $opt eq "u" ) {
9328      $arg ||= shift @options;
9329      if ($arg =~ /\.p[lm]$/) {
9330	eval "require(\"$arg\");"; # path as string
9331      } else {
9332	eval "require $arg;";      # package as bareword with ::
9333      }
9334      mark_unused( $arg, 1 );
9335    }
9336    elsif ( $opt eq "U" ) {
9337      $arg ||= shift @options;
9338      mark_skip( $arg );
9339    }
9340    elsif ( $opt eq "f" ) {
9341      $arg ||= shift @options;
9342      $arg =~ m/(no-)?(.*)/;
9343      my $no = defined($1) && $1 eq 'no-';
9344      $arg = $no ? $2 : $arg;
9345      if ( exists $option_map{$arg} ) {
9346        ${ $option_map{$arg} } = !$no;
9347      }
9348      else {
9349        die "Invalid optimization '$arg'";
9350      }
9351    }
9352    elsif ( $opt eq "O" ) {
9353      $arg = 1 if $arg eq "";
9354      my @opt;
9355      foreach my $i ( 1 .. $arg ) {
9356        push @opt, @{ $optimization_map{$i} }
9357          if exists $optimization_map{$i};
9358      }
9359      unshift @options, @opt;
9360      warn "options : ".(join " ",@opt)."\n" if $verbose;
9361    }
9362    elsif ( $opt eq "e" ) {
9363      push @eval_at_startup, $arg;
9364    }
9365    elsif ( $opt eq "l" ) {
9366      $max_string_len = $arg;
9367    }
9368    elsif ( $opt eq "cross" ) {
9369      $cross = $arg;
9370      cross_config($cross); # overrides %B::C::Config::Config
9371    }
9372  }
9373  if (!$B::C::Config::have_independent_comalloc) {
9374    if ($B::C::av_init2) {
9375      $B::C::av_init = 1;
9376      $B::C::av_init2 = 0;
9377    } elsif ($B::C::av_init) {
9378      $B::C::av_init2 = 0;
9379    }
9380  } elsif ($B::C::av_init2 and $B::C::av_init) {
9381    $B::C::av_init = 0;
9382  }
9383  $B::C::save_data_fh = 1 if $] >= 5.008 and (($] < 5.009004) or $MULTI);
9384  $B::C::destruct = 1 if $] < 5.008 or $^O eq 'MSWin32'; # skip -ffast-destruct there
9385
9386  init_sections();
9387  foreach my $i (@eval_at_startup) {
9388    $init2->add_eval($i);
9389  }
9390  if (@options) { # modules or main?
9391    return sub {
9392      my $objname;
9393      foreach $objname (@options) {
9394        eval "save_object(\\$objname)";
9395      }
9396      output_all($init_name || "init_module");
9397    }
9398  }
9399  else {
9400    return sub { save_main() };
9401  }
9402}
9403
94041;
9405
9406__END__
9407
9408=head1 NAME
9409
9410B::C - Perl compiler's C backend
9411
9412=head1 SYNOPSIS
9413
9414	perl -MO=C[,OPTIONS] foo.pl
9415
9416=head1 DESCRIPTION
9417
9418This compiler backend takes Perl source and generates C source code
9419corresponding to the internal structures that perl uses to run
9420your program. When the generated C source is compiled and run, it
9421cuts out the time which perl would have taken to load and parse
9422your program into its internal semi-compiled form. That means that
9423compiling with this backend will not help improve the runtime
9424execution speed of your program but may improve the start-up time.
9425Depending on the environment in which your program runs this may be
9426either a help or a hindrance.
9427
9428=head1 OPTIONS
9429
9430If there are any non-option arguments, they are taken to be
9431names of objects to be saved (probably doesn't work properly yet).
9432Without extra arguments, it saves the main program.
9433
9434=over 4
9435
9436=item B<-o>I<filename>
9437
9438Output to filename instead of STDOUT
9439
9440=item B<-c>
9441
9442Check and abort.
9443
9444Compiles and prints only warnings, but does not emit C code.
9445
9446=item B<-m>I<Packagename> I<(NYI)>
9447
9448Prepare to compile a module with all dependent code to a single shared
9449library rather than to standalone program.
9450
9451Currently this just means that the code for initialising C<main_start>,
9452C<main_root> and C<curpad> are omitted.
9453The F<.pm> stub to bootstrap the shared lib is not generated.
9454This option should be used via C<perlcc -m>.
9455
9456Not yet implemented.
9457
9458=item B<-n>I<init_name>
9459
9460Default: "perl_init" and "init_module"
9461
9462=item B<-v>
9463
9464Verbose compilation. Currently gives a few compilation statistics.
9465
9466=item B<-->
9467
9468Force end of options
9469
9470=item B<-u>I<Package> "use Package"
9471
9472Force all subs from Package to be compiled.
9473
9474This allows programs to use eval "foo()" even when sub foo is never
9475seen to be used at compile time. The down side is that any subs which
9476really are never used also have code generated. This option is
9477necessary, for example, if you have a signal handler foo which you
9478initialise with C<$SIG{BAR} = "foo">.  A better fix, though, is just
9479to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
9480options. The compiler tries to figure out which packages may possibly
9481have subs in which need compiling but the current version doesn't do
9482it very well. In particular, it is confused by nested packages (i.e.
9483of the form C<A::B>) where package C<A> does not contain any subs.
9484
9485=item B<-U>I<Package> "unuse" skip Package
9486
9487Ignore all subs from Package to be compiled.
9488
9489Certain packages might not be needed at run-time, even if the pessimistic
9490walker detects it.
9491
9492=item B<-staticxs>
9493
9494Dump a list of bootstrapped XS package names to F<outfile.lst>
9495needed for C<perlcc --staticxs>.
9496Add code to DynaLoader to add the .so/.dll path to PATH.
9497
9498=item B<-D>C<[OPTIONS]>
9499
9500Debug options, concatenated or separate flags like C<perl -D>.
9501Verbose debugging options are crucial, because the interactive
9502debugger L<Od> adds a lot of ballast to the resulting code.
9503
9504=item B<-Dfull>
9505
9506Enable all full debugging, as with C<-DoOcAHCMGSpWF>.
9507All but C<-Du>.
9508
9509=item B<-Do>
9510
9511All Walkop'ed OPs
9512
9513=item B<-DO>
9514
9515OP Type,Flags,Private
9516
9517=item B<-DS>
9518
9519Scalar SVs, prints B<SV/RE/RV> information on saving.
9520
9521=item B<-DP>
9522
9523Extra PV information on saving. (static, len, hek, fake_off, ...)
9524
9525=item B<-Dc>
9526
9527B<COPs>, prints COPs as processed (incl. file & line num)
9528
9529=item B<-DA>
9530
9531prints B<AV> information on saving.
9532
9533=item B<-DH>
9534
9535prints B<HV> information on saving.
9536
9537=item B<-DC>
9538
9539prints B<CV> information on saving.
9540
9541=item B<-DG>
9542
9543prints B<GV> information on saving.
9544
9545=item B<-DM>
9546
9547prints B<MAGIC> information on saving.
9548
9549=item B<-DR>
9550
9551prints B<REGEXP> information on saving.
9552
9553=item B<-Dp>
9554
9555prints cached B<package> information, if used or not.
9556
9557=item B<-Ds>
9558
9559prints all compiled sub names, optionally with " not found".
9560
9561=item B<-DF>
9562
9563Add Flags info to the code.
9564
9565=item B<-DW>
9566
9567Together with B<-Dp> also prints every B<walked> package symbol.
9568
9569=item B<-Du>
9570
9571do not print B<-D> information when parsing for the unused subs.
9572
9573=item B<-Dr>
9574
9575Writes debugging output to STDERR and to the program's generated C file.
9576Otherwise writes debugging info to STDERR only.
9577
9578=item B<-f>I<OPTIM>
9579
9580Force options/optimisations on or off one at a time. You can explicitly
9581disable an option using B<-fno-option>. All options default to
9582B<disabled>.
9583
9584=over 4
9585
9586=item B<-fcog> I<(Ignored)>
9587
9588Future flag to enable Copy-on-grow, i.e Copy-on-write, when perl
9589will store the COWREFCNT in a seperate field and not in the string buffer.
9590
9591Some strings are declared and initialised statically independent
9592of C<-fcog>, see C<-fconst-strings> instead.
9593
9594=item B<-fav-init>
9595
9596Faster pre-initialization of AVs (arrays and pads).
9597Also used if -fav-init2 is used and independent_comalloc() is not detected.
9598
9599Enabled with C<-O1>.
9600
9601=item B<-fav-init2>
9602
9603Even more faster pre-initialization of AVs with B<independent_comalloc()> if supported.
9604Excludes C<-fav_init> if so; uses C<-fav_init> if C<independent_comalloc()> is not supported.
9605
9606C<independent_comalloc()> is recommended from B<ptmalloc3>, but also included in
9607C<ptmalloc>, C<dlmalloc> and C<nedmalloc>.
9608Download C<ptmalloc3> here: L<http://www.malloc.de/en/>
9609Note: C<independent_comalloc()> is not included in C<google-perftools> C<tcmalloc>.
9610
9611Enabled with C<-O1>.
9612
9613=item B<-fppaddr>
9614
9615Optimize the initialization of C<op_ppaddr>.
9616
9617Enabled with C<-O1>.
9618
9619=item B<-fwarn-sv>
9620
9621Use static initialization for cop_warnings. Automatically disabled for MSVC 5.
9622
9623Disable with C<-fno-warn-sv>.
9624
9625=item B<-fro-inc>
9626
9627Set read-only B<@INC> and B<%INC> pathnames (C<-fconst-string>, not the AV)
9628to store them const and statically, not via malloc at run-time.
9629
9630This forbids run-time extends of INC path strings,
9631the run-time will crash then.
9632
9633It will also skip storing string values of internal regexp capture groups
9634C<$1> - C<$9>, which were used internally by the compiler or some module. They
9635are considered volatile.
9636
9637Enabled with C<-O2>.
9638
9639=item B<-fsave-data>
9640
9641Save package::DATA filehandles ( only available with PerlIO ).
9642Does not work yet on Perl 5.6, 5.12 and non-threaded 5.10, and is
9643enabled automatically where it is known to work.
9644
9645Enabled with C<-O2>.
9646
9647=item B<-fcow>
9648
9649Enforce static COW strings since 5.18 for most strings.
9650
9651Enabled with C<-O2> since 5.20.
9652
9653=item B<-fconst-strings>
9654
9655Declares static readonly strings as const.
9656Note that readonly strings in eval'd string code will
9657cause a run-time failure.
9658
9659Enabled with C<-O3>.
9660
9661=item B<-fno-destruct>
9662
9663Does no global C<perl_destruct()> at the end of the process, leaving
9664the memory cleanup to operating system.
9665
9666This will cause problems if used embedded or as shared library/module,
9667but not in long-running processes.
9668
9669This helps with destruction problems of static data in the
9670default perl destructor, and enables C<-fcog> since 5.10.
9671
9672Enabled with C<-O3>.
9673
9674=item B<-fno-walkall>
9675
9676C<-fno-walkall> uses the simple old algorithm to detect which packages
9677needs to be stored.
9678C<-fwalkall> was introduced to catch previously uncompiled packages for
9679computed methods or undetected deeper run-time dependencies.
9680
9681=item B<-fno-save-sig-hash>
9682
9683Disable compile-time modifications to the %SIG hash.
9684
9685=item B<-fno-fold> I<(since 5.14)>
9686
9687m//i since 5.13.10 requires the whole unicore/To/Fold table in memory,
9688which is about 1.6MB on 32-bit. In CORE this is demand-loaded from F<utf8.pm>.
9689
9690If you are sure not to use or require any case-insensitive
9691matching you can strip this table from memory with C<-fno-fold>.
9692
9693Enabled with C<-O3>.
9694
9695=item B<-fno-warnings> I<(since 5.14)>
9696
9697Run-time warnings since 5.13.5 require some C<warnings::register_categories>
9698in memory, which is about 68kB on 32-bit. In CORE this is demand-loaded
9699from F<warnings.pm>.
9700
9701You can strip this table from memory with C<-fno-warnings>.
9702
9703Enabled with C<-O3>.
9704
9705=item B<-fstash>
9706
9707Add dynamic creation of stashes, which are nested hashes of symbol tables,
9708names ending with C<::>, starting at C<%main::>.
9709
9710These are rarely needed, sometimes for checking of existance of packages,
9711which could be better done by checking C<%INC>, and cost about 10% space and
9712startup-time.
9713
9714If an explicit stash member or the stash itself C<%package::> is used in
9715the source code, the requested stash member(s) is/are automatically created.
9716
9717C<-fno-stash> is the default.
9718
9719=item B<-fno-delete-pkg>
9720
9721Do not delete compiler-internal and dependent packages which appear to be
9722nowhere used automatically. This might miss run-time called stringified methods.
9723See L<B::C::Config> for C<@deps> which packages are affected.
9724
9725C<-fdelete-pkg> is the default.
9726
9727=item B<-fuse-script-name>
9728
9729Use the script name instead of the program name as C<$0>.
9730
9731Not enabled with any C<-O> option.
9732
9733=item B<-fno-dyn-padlist>
9734
9735Disable dynamic padlists since 5.17.6.  Dynamic padlists are needed to prevent
9736from C<cv_undef> crashes on static padlists when cleaning up the stack on non-local
9737exits, like C<die> or C<exit>.
9738
9739All functions in END blocks and all Attribute::Handler function padlists
9740are automatically dynamic.
9741
9742Enabled with C<-O4>.
9743
9744=item B<-fcop>
9745
9746DO NOT USE YET!
9747
9748Omit COP info (nextstate without labels, unneeded NULL ops,
9749files, linenumbers) for ~10% faster execution and less space,
9750but warnings and errors will have no file and line infos.
9751
9752It will most likely not work yet. I<(was -fbypass-nullops in earlier
9753compilers)>
9754
9755Enabled with C<-O4>.
9756
9757=back
9758
9759=item B<-On>
9760
9761Optimisation level (n = 0, 1, 2, 3, 4). B<-O> means B<-O1>.
9762
9763=over 4
9764
9765=item B<-O0>
9766
9767Disable all optimizations.
9768
9769=item B<-O1>
9770
9771Enable B<-fcog>, B<-fav-init2>/B<-fav-init>, B<-fppaddr> and B<-fwarn-sv>.
9772
9773Note that C<-fcog> without C<-fno-destruct> will be disabled >= 5.10.
9774
9775=item B<-O2>
9776
9777Enable B<-O1> plus B<-fro-inc>, B<-fsave-data> and B<fcow>.
9778
9779=item B<-O3>
9780
9781Enable B<-O2> plus B<-fno-destruct> and B<-fconst-strings>.
9782
9783=item B<-O4>
9784
9785Enable B<-O3> plus B<-fcop> and B<-fno-dyn-padlist>.
9786Very unsafe, rarely works, 10% faster, 10% smaller.
9787
9788=back
9789
9790=item B<-l>I<limit>
9791
9792"line length limit".
9793
9794Some C compilers impose an arbitrary limit on the length of string
9795constants (e.g. 2048 characters for Microsoft Visual C++).
9796B<-l2048> tells the C backend not to generate string literals
9797exceeding that limit.
9798
9799=item B<-e ARG>
9800
9801Evaluate ARG at startup
9802
9803=item B<-cross=pathto/config.sh>
9804
9805Use a different C<%Config> from another F<config.sh> for
9806cross-compilation.
9807C<%INC> will still have the host paths, but C<@INC> and C<$^X>
9808the target paths. See L<B::C::Config>.
9809
9810=back
9811
9812=head1 EXAMPLES
9813
9814    perl -MO=C,-ofoo.c foo.pl
9815    perl cc_harness -o foo foo.c
9816
9817Note that C<cc_harness> lives in the C<B> subdirectory of your perl
9818library directory. The utility called C<perlcc> may also be used to
9819help make use of this compiler.
9820
9821    perlcc foo.pl
9822
9823    perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null
9824
9825=head1 CAVEAT
9826
9827With 5.6 it is not possible to use the __DATA__ filehandle, because
9828compatible access via PerlIO::scalar was added with 5.8.1
9829
9830It is generally not possible to restore all of the compiled BEGIN-time state.
9831Esp. problematic are non-standard filehandles (i.e. fd>2), process ids,
9832environment specific knowledge, because only with the compiler BEGIN blocks
9833are not executed in the client environment.
9834
9835The compiler produces some warnings, which might need source code changes
9836or changed compiler options.
9837
9838=over
9839
9840=item Warning: Problem with require "$name" - $INC{file.pm}
9841
9842Dynamic load of $name did not add the expected %INC key.
9843
9844=item Warning: C.xs PMOP missing for QR
9845
9846In an initial C.xs runloop all QR regex ops are stored, so that they
9847can matched later to PMOPs.
9848
9849=item Warning: DynaLoader broken with 5.15.2-5.15.3.
9850
9851[perl #100138] DynaLoader symbols were XS_INTERNAL. Strict linking
9852could not resolve it. Usually libperl was patched to overcome this
9853for these two versions.
9854Setting the environment variable NO_DL_WARN=1 omits this warning.
9855
9856=item Warning: __DATA__ handle $fullname not stored. Need -O2 or -fsave-data.
9857
9858Since processing the __DATA__ filehandle involves some overhead, requiring
9859PerlIO::scalar with all its dependencies, you must use -O2 or -fsave-data.
9860
9861=item Warning: Write BEGIN-block $fullname to FileHandle $iotype \&$fd
9862
9863Critical problem. This must be fixed in the source.
9864
9865=item Warning: Read BEGIN-block $fullname from FileHandle $iotype \&$fd
9866
9867Critical problem. This must be fixed in the source.
9868
9869=item Warning: -o argument ignored with -c
9870
9871-c does only check, but not accumulate C output lines.
9872
9873=item Warning: unresolved $section symbol s\\xxx
9874
9875This symbol was not resolved during compilation, and replaced by 0.
9876
9877With B::C this is most likely a critical internal compiler bug, esp. if in
9878an op section. See [issue #110].
9879
9880With B::CC it can be caused by valid optimizations, e.g. when op->next
9881pointers were inlined or inlined GV or CONST ops were optimized away.
9882
9883=back
9884
9885=head1 BUGS
9886
9887Current status: A few known bugs, but usable in production
9888
98895.6:
9890    reading from __DATA__ handles (15)
9891    AUTOLOAD xsubs (27)
9892
9893>=5.10:
9894    Attribute::Handlers and run-time attributes
9895    @- (#281)
9896    compile-time perlio layers
9897    run-time loading of DynaLoader packages which use AutoLoad
9898      i.e. BSD::Resource. (#308)
9899    format STDOUT or STDERR (#285)
9900
9901=head1 AUTHOR
9902
9903Malcolm Beattie C<MICB at cpan.org> I<(1996-1998, retired)>,
9904Nick Ing-Simmons <nik at tiuk.ti.com> I(1998-1999),
9905Vishal Bhatia <vishal at deja.com> I(1999),
9906Gurusamy Sarathy <gsar at cpan.org> I(1998-2001),
9907Mattia Barbon <mbarbon at dsi.unive.it> I(2002),
9908Reini Urban C<perl-compiler@googlegroups.com> I(2008-)
9909
9910=head1 SEE ALSO
9911
9912L<perlcompiler> for a general overview,
9913L<B::CC> for the optimising C compiler,
9914L<B::Bytecode> + L<ByteLoader> for the bytecode compiler,
9915L<Od> for source level debugging in the L<B::Debugger>,
9916L<illguts> for the illustrated Perl guts,
9917L<perloptree> for the Perl optree.
9918
9919=cut
9920
9921# Local Variables:
9922#   mode: cperl
9923#   cperl-indent-level: 2
9924#   fill-column: 78
9925# End:
9926# vim: expandtab shiftwidth=2:
9927