X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FB%2FB%2FC.pm;h=b9e005bf419aa253b131c733db3ed58ac8951cbc;hb=932e9ff92dfdad82564fe7085f2cb398e628fac3;hp=bbf49cdfe3f52784c701f1607dfe6b13f607d879;hpb=7cf11ee8d252c02d41acd8632967ff94b86fa0de;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm index bbf49cd..b9e005b 100644 --- a/ext/B/B/C.pm +++ b/ext/B/B/C.pm @@ -49,12 +49,16 @@ use Exporter (); use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop class cstring cchar svref_2object compile_stats comppadlist hash - threadsv_names main_cv init_av opnumber); + threadsv_names main_cv init_av opnumber amagic_generation + AVf_REAL HEf_SVKEY); use B::Asmdata qw(@specialsv_name); use FileHandle; use Carp; use strict; +use Config; +my $handle_VC_problem = ""; +$handle_VC_problem="{0}," if $^O eq 'MSWin32' and $Config{cc} =~ /^cl/i; my $hv_index = 0; my $gv_index = 0; @@ -64,6 +68,7 @@ my $anonsub_index = 0; my $initsub_index = 0; my %symtable; +my %xsub; my $warn_undefined_syms; my $verbose; my %unused_sub_packages; @@ -81,7 +86,7 @@ my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, $gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect, $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect, - $xrvsect, $xpvbmsect, $xpviosect, $bootstrap); + $xrvsect, $xpvbmsect, $xpviosect ); sub walk_and_save_optree; my $saveoptree_callback = \&walk_and_save_optree; @@ -103,8 +108,6 @@ sub walk_and_save_optree { # to "know" that op_seq is a U16 and use 65535. Ugh. my $op_seq = 65535; -sub AVf_REAL () { 1 } - # Look this up here so we can do just a number compare # rather than looking up the name of every BASEOP in B::OP my $OP_THREADSV = opnumber('threadsv'); @@ -153,6 +156,8 @@ sub savepv { sub B::OP::save { my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; my $type = $op->type; $nullop_count++ unless $type; if ($type == $OP_THREADSV) { @@ -160,7 +165,7 @@ sub B::OP::save { $init->add(sprintf("(void)find_threadsv(%s);", cstring($threadsv_names[$op->targ]))); } - $opsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x", + $opsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x", ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $type, $op_seq, $op->flags, $op->private)); savesym($op, sprintf("&op_list[%d]", $opsect->index)); @@ -173,7 +178,7 @@ sub B::FAKEOP::new { sub B::FAKEOP::save { my ($op, $level) = @_; - $opsect->add(sprintf("%s, %s, %s, %u, %u, %u, 0x%x, 0x%x", + $opsect->add(sprintf("%s, %s, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x", $op->next, $op->sibling, $op->ppaddr, $op->targ, $op->type, $op_seq, $op->flags, $op->private)); return sprintf("&op_list[%d]", $opsect->index); @@ -189,7 +194,9 @@ sub B::FAKEOP::private { $_[0]->{private} || 0 } sub B::UNOP::save { my ($op, $level) = @_; - $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x", + my $sym = objsym($op); + return $sym if defined $sym; + $unopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, s\\_%x", ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op_seq, $op->flags, $op->private, ${$op->first})); @@ -198,7 +205,9 @@ sub B::UNOP::save { sub B::BINOP::save { my ($op, $level) = @_; - $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", + my $sym = objsym($op); + return $sym if defined $sym; + $binopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op_seq, $op->flags, $op->private, ${$op->first}, ${$op->last})); @@ -207,7 +216,9 @@ sub B::BINOP::save { sub B::LISTOP::save { my ($op, $level) = @_; - $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u", + my $sym = objsym($op); + return $sym if defined $sym; + $listopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u", ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op_seq, $op->flags, $op->private, ${$op->first}, ${$op->last}, @@ -217,29 +228,23 @@ sub B::LISTOP::save { sub B::LOGOP::save { my ($op, $level) = @_; - $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", + my $sym = objsym($op); + return $sym if defined $sym; + $logopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op_seq, $op->flags, $op->private, ${$op->first}, ${$op->other})); savesym($op, sprintf("(OP*)&logop_list[%d]", $logopsect->index)); } -sub B::CONDOP::save { - my ($op, $level) = @_; - $condopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->ppaddr, - $op->targ, $op->type, $op_seq, $op->flags, - $op->private, ${$op->first}, ${$op->true}, - ${$op->false})); - savesym($op, sprintf("(OP*)&condop_list[%d]", $condopsect->index)); -} - sub B::LOOP::save { my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n", # peekop($op->redoop), peekop($op->nextop), # peekop($op->lastop)); # debug - $loopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, s\\_%x, s\\_%x, s\\_%x", + $loopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, s\\_%x, s\\_%x, s\\_%x", ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op_seq, $op->flags, $op->private, ${$op->first}, ${$op->last}, @@ -250,7 +255,9 @@ sub B::LOOP::save { sub B::PVOP::save { my ($op, $level) = @_; - $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s", + my $sym = objsym($op); + return $sym if defined $sym; + $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, $handle_VC_problem %u, %u, %u, 0x%x, 0x%x, %s", ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op_seq, $op->flags, $op->private, cstring($op->pv))); @@ -259,8 +266,10 @@ sub B::PVOP::save { sub B::SVOP::save { my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; my $svsym = $op->sv->save; - $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s", + $svopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, %s", ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op_seq, $op->flags, $op->private, "(SV*)$svsym")); @@ -269,8 +278,10 @@ sub B::SVOP::save { sub B::GVOP::save { my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; my $gvsym = $op->gv->save; - $gvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullgv", + $gvopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, Nullgv", ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op_seq, $op->flags, $op->private)); @@ -280,11 +291,13 @@ sub B::GVOP::save { sub B::COP::save { my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; my $gvsym = $op->filegv->save; my $stashsym = $op->stash->save; warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV) if $debug_cops; - $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u", + $copsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u", ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op_seq, $op->flags, $op->private, cstring($op->label), $op->cop_seq, @@ -297,6 +310,8 @@ sub B::COP::save { sub B::PMOP::save { my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; my $replroot = $op->pmreplroot; my $replstart = $op->pmreplstart; my $replrootfield = sprintf("s\\_%x", $$replroot); @@ -307,7 +322,7 @@ sub B::PMOP::save { # OP_PUSHRE (a mutated version of OP_MATCH for the regexp # argument to a split) stores a GV in op_pmreplroot instead # of a substitution syntax tree. We don't want to walk that... - if ($ppaddr eq "pp_pushre") { + if ($op->name eq "pushre") { $gvsym = $replroot->save; # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug $replrootfield = 0; @@ -318,7 +333,7 @@ sub B::PMOP::save { # pmnext handling is broken in perl itself, I think. Bad op_pmnext # fields aren't noticed in perl's runtime (unless you try reset) but we # segfault when trying to dereference it to find op->op_pmnext->op_type - $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, %s, %s, 0, 0, 0x%x, 0x%x", + $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s,$handle_VC_problem %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, %s, %s, 0, 0, 0x%x, 0x%x", ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ, $op->type, $op_seq, $op->flags, $op->private, ${$op->first}, ${$op->last}, $op->children, @@ -360,7 +375,7 @@ sub B::NULL::save { #if ($$sv == 0) { # warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n"; #} - $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT + 1, $sv->FLAGS)); + $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS)); return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); } @@ -370,7 +385,7 @@ sub B::IV::save { return $sym if defined $sym; $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX)); $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x", - $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvivsect->index, $sv->REFCNT , $sv->FLAGS)); return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); } @@ -378,9 +393,11 @@ sub B::NV::save { my ($sv) = @_; my $sym = objsym($sv); return $sym if defined $sym; - $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $sv->NVX)); + my $val= $sv->NVX; + $val .= '.00' if $val =~ /^-?\d+$/; + $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val)); $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x", - $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS)); return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); } @@ -396,7 +413,7 @@ sub B::PVLV::save { $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX, $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE))); $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x", - $xpvlvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS)); if (!$pv_copy_on_grow) { $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);", $xpvlvsect->index, cstring($pv), $len)); @@ -414,7 +431,7 @@ sub B::PVIV::save { my ($pvsym, $pvmax) = savepv($pv); $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX)); $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x", - $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvivsect->index, $sv->REFCNT , $sv->FLAGS)); if (!$pv_copy_on_grow) { $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);", $xpvivsect->index, cstring($pv), $len)); @@ -430,10 +447,12 @@ sub B::PVNV::save { $pv = '' unless defined $pv; my $len = length($pv); my ($pvsym, $pvmax) = savepv($pv); + my $val= $sv->NVX; + $val .= '.00' if $val =~ /^-?\d+$/; $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s", - $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX)); + $pvsym, $len, $pvmax, $sv->IVX, $val)); $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x", - $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS)); if (!$pv_copy_on_grow) { $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);", $xpvnvsect->index, cstring($pv), $len)); @@ -451,7 +470,7 @@ sub B::BM::save { $len, $len + 258, $sv->IVX, $sv->NVX, $sv->USEFUL, $sv->PREVIOUS, $sv->RARE)); $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x", - $xpvbmsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS)); $sv->save_magic; $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);", $xpvbmsect->index, cstring($pv), $len), @@ -469,7 +488,7 @@ sub B::PV::save { my ($pvsym, $pvmax) = savepv($pv); $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax)); $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x", - $xpvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvsect->index, $sv->REFCNT , $sv->FLAGS)); if (!$pv_copy_on_grow) { $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);", $xpvsect->index, cstring($pv), $len)); @@ -487,7 +506,7 @@ sub B::PVMG::save { $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0", $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX)); $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x", - $xpvmgsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS)); if (!$pv_copy_on_grow) { $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);", $xpvmgsect->index, cstring($pv), $len)); @@ -501,6 +520,7 @@ sub B::PVMG::save_magic { my ($sv) = @_; #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug my $stash = $sv->SvSTASH; + $stash->save; if ($$stash) { warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash) if $debug_mg; @@ -508,19 +528,27 @@ sub B::PVMG::save_magic { $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash)); } my @mgchain = $sv->MAGIC; - my ($mg, $type, $obj, $ptr); + my ($mg, $type, $obj, $ptr,$len,$ptrsv); foreach $mg (@mgchain) { $type = $mg->TYPE; $obj = $mg->OBJ; $ptr = $mg->PTR; - my $len = defined($ptr) ? length($ptr) : 0; + $len=$mg->LENGTH; if ($debug_mg) { warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n", class($sv), $$sv, class($obj), $$obj, cchar($type), cstring($ptr)); } - $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);", + $obj->save; + if ($len == HEf_SVKEY){ + #The pointer is an SV* + $ptrsv=svref_2object($ptr)->save; + $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);", + $$sv, $$obj, cchar($type),$ptrsv,$len)); + }else{ + $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);", $$sv, $$obj, cchar($type),cstring($ptr),$len)); + } } } @@ -532,7 +560,7 @@ sub B::RV::save { $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/; $xrvsect->add($rv); $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x", - $xrvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xrvsect->index, $sv->REFCNT , $sv->FLAGS)); return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); } @@ -557,7 +585,7 @@ sub try_autoload { } } } - +sub Dummy_initxs{}; sub B::CV::save { my ($cv) = @_; my $sym = objsym($cv); @@ -566,18 +594,40 @@ sub B::CV::save { return $sym; } # Reserve a place in svsect and xpvcvsect and record indices + my $gv = $cv->GV; + my $cvstashname = $gv->STASH->NAME; + my $cvname = $gv->NAME; + my $root = $cv->ROOT; + my $cvxsub = $cv->XSUB; + #INIT is removed from the symbol table, so this call must come + # from PL_initav->save. Re-bootstrapping will push INIT back in + # so nullop should be sent. + if ($cvxsub && ($cvname ne "INIT")) { + my $egv = $gv->EGV; + my $stashname = $egv->STASH->NAME; + if ($cvname eq "bootstrap") + { + my $file = $cv->FILEGV->SV->PV; + $decl->add("/* bootstrap $file */"); + warn "Bootstrap $stashname $file\n"; + $xsub{$stashname}='Dynamic'; + # $xsub{$stashname}='Static' unless $xsub{$stashname}; + return qq/NULL/; + } + warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv; + return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/; + } + if ($cvxsub && $cvname eq "INIT") { + no strict 'refs'; + return svref_2object(\&Dummy_initxs)->save; + } my $sv_ix = $svsect->index + 1; $svsect->add("svix$sv_ix"); my $xpvcv_ix = $xpvcvsect->index + 1; $xpvcvsect->add("xpvcvix$xpvcv_ix"); # Save symbol now so that GvCV() doesn't recurse back to us via CvGV() $sym = savesym($cv, "&sv_list[$sv_ix]"); - warn sprintf("saving CV 0x%x as $sym\n", $$cv) if $debug_cv; - my $gv = $cv->GV; - my $cvstashname = $gv->STASH->NAME; - my $cvname = $gv->NAME; - my $root = $cv->ROOT; - my $cvxsub = $cv->XSUB; + warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv; if (!$$root && !$cvxsub) { if (try_autoload($cvstashname, $cvname)) { # Recalculate root and xsub @@ -626,17 +676,6 @@ sub B::CV::save { $$padlist, $$cv) if $debug_cv; } } - elsif ($cvxsub) { - $xsubany = sprintf("ANYINIT((void*)0x%x)", $cv->XSUBANY); - # Try to find out canonical name of XSUB function from EGV. - # XXX Doesn't work for XSUBs with PREFIX set (or anyone who - # calls newXS() manually with weird arguments). - my $egv = $gv->EGV; - my $stashname = $egv->STASH->NAME; - $stashname =~ s/::/__/g; - $xsub = sprintf("XS_%s_%s", $stashname, $egv->NAME); - $decl->add("void $xsub _((CV*));"); - } else { warn sprintf("No definition for sub %s::%s (unable to autoload)\n", $cvstashname, $cvname); # debug @@ -649,6 +688,7 @@ sub B::CV::save { if (${$cv->OUTSIDE} == ${main_cv()}){ $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv)); + $init->add(sprintf("SvREFCNT_inc(PL_main_cv);")); } if ($$gv) { @@ -672,12 +712,12 @@ sub B::CV::save { $$stash, $$cv) if $debug_cv; } $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x", - $sv_ix, $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS)); + $sv_ix, $xpvcv_ix, $cv->REFCNT +1 , $cv->FLAGS)); return $sym; } sub B::GV::save { - my ($gv,$skip_cv) = @_; + my ($gv) = @_; my $sym = objsym($gv); if (defined($sym)) { #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug @@ -718,45 +758,55 @@ sub B::GV::save { # warn "GV::save saving subfields\n"; # debug my $gvsv = $gv->SV; if ($$gvsv) { + $gvsv->save; $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv)); # warn "GV::save \$$name\n"; # debug - $gvsv->save; } my $gvav = $gv->AV; if ($$gvav) { + $gvav->save; $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav)); # warn "GV::save \@$name\n"; # debug - $gvav->save; } my $gvhv = $gv->HV; if ($$gvhv) { + $gvhv->save; $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv)); # warn "GV::save \%$name\n"; # debug - $gvhv->save; } my $gvcv = $gv->CV; - if ($$gvcv && !$skip_cv) { - $init->add(sprintf("GvCV($sym) = (CV*)s\\_%x;", $$gvcv)); -# warn "GV::save &$name\n"; # debug - $gvcv->save; - } + if ($$gvcv) { + my $origname=cstring($gvcv->GV->EGV->STASH->NAME . + "::" . $gvcv->GV->EGV->NAME); + if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias + # must save as a 'stub' so newXS() has a CV to populate + $init->add("{ CV *cv;"); + $init->add("\tcv=perl_get_cv($origname,TRUE);"); + $init->add("\tGvCV($sym)=cv;"); + $init->add("\tSvREFCNT_inc((SV *)cv);"); + $init->add("}"); + } else { + $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save)); +# warn "GV::save &$name\n"; # debug + } + } my $gvfilegv = $gv->FILEGV; if ($$gvfilegv) { + $gvfilegv->save; $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv)); # warn "GV::save GvFILEGV(*$name)\n"; # debug - $gvfilegv->save; } my $gvform = $gv->FORM; if ($$gvform) { + $gvform->save; $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform)); # warn "GV::save GvFORM(*$name)\n"; # debug - $gvform->save; } my $gvio = $gv->IO; if ($$gvio) { + $gvio->save; $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio)); # warn "GV::save GvIO(*$name)\n"; # debug - $gvio->save; } } return $sym; @@ -769,7 +819,7 @@ sub B::AV::save { $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x", $avflags)); $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x", - $xpvavsect->index, $av->REFCNT + 1, $av->FLAGS)); + $xpvavsect->index, $av->REFCNT , $av->FLAGS)); my $sv_list_index = $svsect->index; my $fill = $av->FILL; $av->save_magic; @@ -835,7 +885,7 @@ sub B::HV::save { $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0", $hv->MAX, $hv->RITER)); $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x", - $xpvhvsect->index, $hv->REFCNT + 1, $hv->FLAGS)); + $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS)); my $sv_list_index = $svsect->index; my @contents = $hv->ARRAY; if (@contents) { @@ -853,6 +903,7 @@ sub B::HV::save { } $init->add("}"); } + $hv->save_magic(); return savesym($hv, "(HV*)&sv_list[$sv_list_index]"); } @@ -870,7 +921,7 @@ sub B::IO::save { cstring($io->BOTTOM_NAME), $io->SUBPROCESS, cchar($io->IoTYPE), $io->IoFLAGS)); $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x", - $xpviosect->index, $io->REFCNT + 1, $io->FLAGS)); + $xpviosect->index, $io->REFCNT , $io->FLAGS)); $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index)); my ($field, $fsym); foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) { @@ -901,7 +952,6 @@ sub output_all { $loopsect, $copsect, $svsect, $xpvsect, $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect); - $bootstrap->output(\*STDOUT, "/* bootstrap %s */\n"); $symsect->output(\*STDOUT, "#define %s\n"); print "\n"; output_declarations(); @@ -930,6 +980,8 @@ sub output_all { static int $init_name() { dTHR; + dTARG; + djSP; EOT $init->output(\*STDOUT, "\t%s\n"); print "\treturn 0;\n}\n"; @@ -964,7 +1016,7 @@ typedef struct { HV * xcv_stash; OP * xcv_start; OP * xcv_root; - void (*xcv_xsub) _((CV*)); + void (*xcv_xsub) (CV*); void * xcv_xsubany; GV * xcv_gv; GV * xcv_filegv; @@ -997,15 +1049,15 @@ sub output_boilerplate { print <<'EOT'; #include "EXTERN.h" #include "perl.h" -#ifndef PATCHLEVEL -#include "patchlevel.h" -#endif /* Workaround for mapstart: the only op which needs a different ppaddr */ -#undef pp_mapstart -#define pp_mapstart pp_grepstart +#undef Perl_pp_mapstart +#define Perl_pp_mapstart Perl_pp_grepstart +#define XS_DynaLoader_boot_DynaLoader boot_DynaLoader +EXTERN_C void boot_DynaLoader (CV* cv); -static void xs_init _((void)); +static void xs_init (void); +static void dl_init (void); static PerlInterpreter *my_perl; EOT } @@ -1070,6 +1122,7 @@ main(int argc, char **argv, char **env) exitstatus = perl_init(); if (exitstatus) exit( exitstatus ); + dl_init(); exitstatus = perl_run( my_perl ); @@ -1079,13 +1132,72 @@ main(int argc, char **argv, char **env) exit( exitstatus ); } +/* yanked from perl.c */ static void xs_init() { -} + char *file = __FILE__; + dTARG; + djSP; EOT + print "\n#ifdef USE_DYNAMIC_LOADING"; + print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/; + print "\n#endif\n" ; + # delete $xsub{'DynaLoader'}; + delete $xsub{'UNIVERSAL'}; + print("/* bootstrapping code*/\n\tSAVETMPS;\n"); + print("\ttarg=sv_newmortal();\n"); + print "#ifdef DYNALOADER_BOOTSTRAP\n"; + print "\tPUSHMARK(sp);\n"; + print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/; + print qq/\tPUTBACK;\n/; + print "\tboot_DynaLoader(NULL);\n"; + print qq/\tSPAGAIN;\n/; + print "#endif\n"; + foreach my $stashname (keys %xsub){ + if ($xsub{$stashname} ne 'Dynamic') { + my $stashxsub=$stashname; + $stashxsub =~ s/::/__/g; + print "\tPUSHMARK(sp);\n"; + print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/; + print qq/\tPUTBACK;\n/; + print "\tboot_$stashxsub(NULL);\n"; + print qq/\tSPAGAIN;\n/; + } + } + print("\tFREETMPS;\n/* end bootstrapping code */\n"); + print "}\n"; + +print <<'EOT'; +static void +dl_init() +{ + char *file = __FILE__; + dTARG; + djSP; +EOT + print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n"); + print("\ttarg=sv_newmortal();\n"); + foreach my $stashname (@DynaLoader::dl_modules) { + warn "Loaded $stashname\n"; + if (exists($xsub{$stashname}) && $xsub{$stashname} eq 'Dynamic') { + my $stashxsub=$stashname; + $stashxsub =~ s/::/__/g; + print "\tPUSHMARK(sp);\n"; + print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/; + print qq/\tPUTBACK;\n/; + print "#ifdef DYNALOADER_BOOTSTRAP\n"; + warn "bootstrapping $stashname added to xs_init\n"; + print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/; + print "\n#else\n"; + print "\tboot_$stashxsub(NULL);\n"; + print "#endif\n"; + print qq/\tSPAGAIN;\n/; + } + } + print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n"); + print "}\n"; } - sub dump_symtable { # For debugging my ($sym, $val); @@ -1114,32 +1226,14 @@ sub B::GV::savecv my $sv = $gv->SV; my $av = $gv->AV; my $hv = $gv->HV; - my $skip_cv = 0; # We may be looking at this package just because it is a branch in the # symbol table which is on the path to a package which we need to save # e.g. this is 'Getopt' and we need to save 'Getopt::Long' # return unless ($unused_sub_packages{$package}); - if ($$cv) - { - if ($name eq "bootstrap" && $cv->XSUB) - { - my $file = $cv->FILEGV->SV->PV; - $bootstrap->add($file); - my $name = $gv->STASH->NAME.'::'.$name; - no strict 'refs'; - *{$name} = \&Dummy_BootStrap; - $cv = $gv->CV; - } - warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n", - $package, $name, $$cv, $$gv) if ($debug_cv); - } - else - { - return unless ($$av || $$sv || $$hv) - } - $gv->save($skip_cv); + return unless ($$cv || $$av || $$sv || $$hv); + $gv->save; } sub mark_package @@ -1149,7 +1243,7 @@ sub mark_package { no strict 'refs'; $unused_sub_packages{$package} = 1; - if (defined(@{$package.'::ISA'})) + if (@{$package.'::ISA'}) { foreach my $isa (@{$package.'::ISA'}) { @@ -1161,7 +1255,7 @@ sub mark_package eval { $package->bootstrap }; } } - else +# else { unless ($unused_sub_packages{$isa}) { @@ -1193,7 +1287,8 @@ sub should_save if (exists $unused_sub_packages{$package}) { # warn "Cached $package is ".$unused_sub_packages{$package}."\n"; - return $unused_sub_packages{$package} + delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ; + return $unused_sub_packages{$package}; } # Omit the packages which we use (and which cause grief # because of fancy "goto &$AUTOLOAD" stuff). @@ -1201,6 +1296,7 @@ sub should_save if ($package eq "FileHandle" || $package eq "Config" || $package eq "SelectSaver" || $package =~/^(B|IO)::/) { + delete_unsaved_hashINC($package); return $unused_sub_packages{$package} = 0; } # Now see if current package looks like an OO class this is probably too strong. @@ -1212,9 +1308,16 @@ sub should_save return mark_package($package); } } + delete_unsaved_hashINC($package); return $unused_sub_packages{$package} = 0; } - +sub delete_unsaved_hashINC{ + my $packname=shift; + $packname =~ s/\:\:/\//g; + $packname .= '.pm'; +# warn "deleting $packname" if $INC{$packname} ;# debug + delete $INC{$packname}; +} sub walkpackages { my ($symref, $recurse, $prefix) = @_; @@ -1254,11 +1357,13 @@ sub save_context my $curpad_sym = (comppadlist->ARRAY)[1]->save; my $inc_hv = svref_2object(\%INC)->save; my $inc_av = svref_2object(\@INC)->save; + my $amagic_generate= amagic_generation; $init->add( "PL_curpad = AvARRAY($curpad_sym);", "GvHV(PL_incgv) = $inc_hv;", "GvAV(PL_incgv) = $inc_av;", "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", - "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));"); + "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));", + "PL_amagic_generation= $amagic_generate;" ); } sub descend_marked_unused { @@ -1267,17 +1372,18 @@ sub descend_marked_unused { mark_package($pack); } } - + sub save_main { warn "Starting compile\n"; warn "Walking tree\n"; + seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output walkoptree(main_root, "save"); warn "done main optree, walking symtable for extras\n" if $debug_cv; save_unused_subs(); my $init_av = init_av->save; $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), sprintf("PL_main_start = s\\_%x;", ${main_start()}), - "PL_initav = $init_av;"); + "PL_initav = (AV *) $init_av;"); save_context(); warn "Writing output\n"; output_boilerplate(); @@ -1299,7 +1405,7 @@ sub init_sections { xpviv => \$xpvivsect, xpvnv => \$xpvnvsect, xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect, xrv => \$xrvsect, xpvbm => \$xpvbmsect, - xpvio => \$xpviosect, bootstrap => \$bootstrap); + xpvio => \$xpviosect); my ($name, $sectref); while (($name, $sectref) = splice(@sections, 0, 2)) { $$sectref = new B::C::Section $name, \%symtable, 0;