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