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;
$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));
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);
my ($op, $level) = @_;
my $sym = objsym($op);
return $sym if defined $sym;
- $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x",
+ $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}));
my ($op, $level) = @_;
my $sym = objsym($op);
return $sym if defined $sym;
- $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
+ $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}));
my ($op, $level) = @_;
my $sym = objsym($op);
return $sym if defined $sym;
- $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u",
+ $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},
my ($op, $level) = @_;
my $sym = objsym($op);
return $sym if defined $sym;
- $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
+ $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}));
#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},
my ($op, $level) = @_;
my $sym = objsym($op);
return $sym if defined $sym;
- $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
+ $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)));
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"));
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));
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,
# 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,
#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));
}
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));
}
$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));
}
$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));
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));
$xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
$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));
$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),
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));
$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));
$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));
}
}
}
}
-
+sub Dummy_initxs{};
sub B::CV::save {
my ($cv) = @_;
my $sym = objsym($cv);
my $cvname = $gv->NAME;
my $root = $cv->ROOT;
my $cvxsub = $cv->XSUB;
- if ($cvxsub) {
+ #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;
- $xsub{$stashname}='Static' unless $xsub{$stashname};
+ 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");
$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;
+ 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
$$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
# warn "GV::save \%$name\n"; # debug
}
my $gvcv = $gv->CV;
- if ($$gvcv && !$skip_cv && !$gvcv->XSUB) { #not XSUB
- $gvcv->save;
- $init->add(sprintf("GvCV($sym) = (CV*)s\\_%x;", $$gvcv));
-# warn "GV::save &$name\n"; # debug
- }elsif ($$gvcv && $gvcv->XSUB && $name ne
- (my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
- "::" . $gvcv->GV->EGV->NAME))) { #XSUB alias
-
+ 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=GvCV(gv_fetchpv($origname,FALSE,SVt_PV));");
+ $init->add("\tcv=perl_get_cv($origname,TRUE);");
$init->add("\tGvCV($sym)=cv;");
$init->add("\tSvREFCNT_inc((SV *)cv);");
- $init->add("}");
-
+ $init->add("}");
+ } else {
+ $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
+# warn "GV::save &$name\n"; # debug
+ }
}
my $gvfilegv = $gv->FILEGV;
if ($$gvfilegv) {
$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;
$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) {
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)) {
EXTERN_C void boot_DynaLoader (CV* cv);
static void xs_init (void);
+static void dl_init (void);
static PerlInterpreter *my_perl;
EOT
}
exitstatus = perl_init();
if (exitstatus)
exit( exitstatus );
+ dl_init();
exitstatus = perl_run( my_perl );
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{'DynaLoader'};
delete $xsub{'UNIVERSAL'};
- print("/* bootstrapping code*/\nSAVETMPS;\n");
+ 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 (keys %xsub ){
- my $stashxsub=$stashname;
- $stashxsub =~ s/::/__/g;
- if ($xsub{$stashname} eq 'Dynamic') {
+ 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/\n\t{\n\tchar *args[]={"$stashxsub", NULL};/;
- print qq/\n\t\tperl_call_argv("${stashxsub}::bootstrap",G_DISCARD,args);\n\t}/;
+ print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
print "\n#else\n";
- }
- print "\tPUSHMARK(sp);\n";
- print qq/\tXPUSHp("$stashname",strlen("$stashname")+1);\n/;
- print "\tboot_$stashxsub(NULL);\n";
- print "#endif\n" if ($xsub{$stashname} eq 'Dynamic');
+ print "\tboot_$stashxsub(NULL);\n";
+ print "#endif\n";
+ print qq/\tSPAGAIN;\n/;
+ }
}
-
- print("\tFREETMPS;\n/* end bootstrapping code */\n");
- print "\n}";
+ print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
+ print "}\n";
}
sub dump_symtable {
# For debugging
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;
- my $name = $gv->STASH->NAME.'::'.$name;
- no strict 'refs';
- *{$name} = \&Dummy_BootStrap;
- $xsub{$gv->STASH->NAME}='Dynamic';
- $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
eval { $package->bootstrap };
}
}
- else
+# else
{
unless ($unused_sub_packages{$isa})
{
projects / p5sagit/p5-mst-13.2.git / blobdiff