From: Brandon L Black Date: Thu, 14 Dec 2006 06:17:57 +0000 (+0000) Subject: adding c3.patch (current dev progress on the core support) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f8b2ed66f360d777f8b9f1ad2024371c9d922d22;p=gitmo%2FClass-C3.git adding c3.patch (current dev progress on the core support) --- diff --git a/c3.patch b/c3.patch new file mode 100644 index 0000000..7e13c5e --- /dev/null +++ b/c3.patch @@ -0,0 +1,893 @@ +=== embed.h +================================================================== +--- embed.h (/local/perl-current) (revision 12336) ++++ embed.h (/local/perl-c3) (revision 12336) +@@ -266,6 +266,11 @@ + #define gv_efullname Perl_gv_efullname + #define gv_efullname4 Perl_gv_efullname4 + #define gv_fetchfile Perl_gv_fetchfile ++#ifdef PERL_CORE ++#define linear_isa Perl_linear_isa ++#define linear_isa_c3 Perl_linear_isa_c3 ++#define linear_isa_dfs Perl_linear_isa_dfs ++#endif + #define gv_fetchmeth Perl_gv_fetchmeth + #define gv_fetchmeth_autoload Perl_gv_fetchmeth_autoload + #define gv_fetchmethod_autoload Perl_gv_fetchmethod_autoload +@@ -2470,6 +2475,11 @@ + #define gv_efullname(a,b) Perl_gv_efullname(aTHX_ a,b) + #define gv_efullname4(a,b,c,d) Perl_gv_efullname4(aTHX_ a,b,c,d) + #define gv_fetchfile(a) Perl_gv_fetchfile(aTHX_ a) ++#ifdef PERL_CORE ++#define linear_isa(a) Perl_linear_isa(aTHX_ a) ++#define linear_isa_c3(a) Perl_linear_isa_c3(aTHX_ a) ++#define linear_isa_dfs(a,b) Perl_linear_isa_dfs(aTHX_ a,b) ++#endif + #define gv_fetchmeth(a,b,c,d) Perl_gv_fetchmeth(aTHX_ a,b,c,d) + #define gv_fetchmeth_autoload(a,b,c,d) Perl_gv_fetchmeth_autoload(aTHX_ a,b,c,d) + #define gv_fetchmethod_autoload(a,b,c) Perl_gv_fetchmethod_autoload(aTHX_ a,b,c) +=== embedvar.h +================================================================== +--- embedvar.h (/local/perl-current) (revision 12336) ++++ embedvar.h (/local/perl-c3) (revision 12336) +@@ -229,6 +229,7 @@ + #define PL_incgv (vTHX->Iincgv) + #define PL_initav (vTHX->Iinitav) + #define PL_inplace (vTHX->Iinplace) ++#define PL_isa_generation (vTHX->Iisa_generation) + #define PL_known_layers (vTHX->Iknown_layers) + #define PL_last_lop (vTHX->Ilast_lop) + #define PL_last_lop_op (vTHX->Ilast_lop_op) +@@ -527,6 +528,7 @@ + #define PL_Iincgv PL_incgv + #define PL_Iinitav PL_initav + #define PL_Iinplace PL_inplace ++#define PL_Iisa_generation PL_isa_generation + #define PL_Iknown_layers PL_known_layers + #define PL_Ilast_lop PL_last_lop + #define PL_Ilast_lop_op PL_last_lop_op +=== gv.c +================================================================== +--- gv.c (/local/perl-current) (revision 12336) ++++ gv.c (/local/perl-c3) (revision 12336) +@@ -283,6 +283,325 @@ + } + + /* ++=for apidoc linear_isa_dfs ++ ++Returns the Depth-First Search linearization of @ISA ++the given stash. The return value is a read-only AV*, ++and is cached based on C. ++ ++=cut ++*/ ++AV* ++Perl_linear_isa_dfs(pTHX_ HV *stash, I32 level) { ++ AV* retval; ++ GV** gvp; ++ GV* gv; ++ AV* av; ++ SV** svp; ++ I32 items; ++ AV* subrv; ++ SV** subrv_p; ++ I32 subrv_items; ++ const char* stashname; ++ ++ assert(stash); ++ assert(HvAUX(stash)); ++ ++ stashname = HvNAME_get(stash); ++ if (!stashname) ++ Perl_croak(aTHX_ ++ "Can't linearize anonymous symbol table"); ++ ++ if (level > 100) ++ Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", ++ stashname); ++ ++ /* return the cached linearization if valid */ ++ if((retval = HvAUX(stash)->xhv_dfs_linear_isa) ++ && HvAUX(stash)->xhv_dfs_isa_gen == PL_isa_generation) { ++ SvREFCNT_inc_simple_void_NN(retval); ++ return retval; ++ } ++ ++ /* make a new one */ ++ ++ if(retval) SvREFCNT_dec(retval); ++ HvAUX(stash)->xhv_dfs_linear_isa = retval = newAV(); ++ HvAUX(stash)->xhv_dfs_isa_gen = PL_isa_generation; ++ av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */ ++ ++ gvp = (GV**)hv_fetchs(stash, "ISA", FALSE); ++ av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL; ++ ++ if(av) { ++ svp = AvARRAY(av); ++ items = AvFILLp(av) + 1; ++ while (items--) { ++ SV* const sv = *svp++; ++ HV* const basestash = gv_stashsv(sv, FALSE); ++ if (!basestash) { ++ if (ckWARN(WARN_MISC)) ++ Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA", ++ (void*)sv, stashname); ++ continue; ++ } ++ subrv = linear_isa_dfs(basestash, level + 1); ++ subrv_p = AvARRAY(subrv); ++ subrv_items = AvFILLp(subrv) + 1; ++ while(subrv_items--) { ++ SV* subsv = *subrv_p++; ++ SvREFCNT_inc_simple_void_NN(subsv); ++ av_push(retval, subsv); ++ } ++ SvREFCNT_dec(subrv); ++ } ++ } ++ ++ SvREADONLY_on(retval); ++ SvREFCNT_inc_simple_void_NN(retval); ++ return retval; ++} ++ ++AV* __av_shallow_copy(AV* inav) { ++ AV* outav = newAV(); ++ SV** inptr = AvARRAY(inav); ++ I32 items = AvFILLp(inav) + 1; ++ while(items--) { ++ SV* tempsv = *inptr++; ++ SvREFCNT_inc_simple_void_NN(tempsv); ++ av_push(outav, tempsv); ++ } ++ return outav; ++} ++ ++/* increment the numeric value of a key in a hash, ++ creating at 1 if neccesary */ ++void __hv_incr(HV* inhash, SV* inkey) { ++ HE* he = hv_fetch_ent(inhash, inkey, 0, 0); ++ SV* val; ++ if(!he) { ++ val = newSViv(1); ++ hv_store_ent(inhash, inkey, val, 0); ++ } ++ else { ++ val = HeVAL(he); ++ sv_inc(val); ++ } ++} ++ ++/* ++=for apidoc linear_isa_c3 ++ ++Returns the C3 linearization of @ISA ++the given stash. The return value is a read-only AV*, ++and is cached based on C. ++ ++=cut ++*/ ++AV* ++Perl_linear_isa_c3(pTHX_ HV *root) { ++ AV* retval; ++ GV** gvp; ++ GV* gv; ++ AV* crisa; ++ SV** svp; ++ const char* rootname; ++ AV* C3STACK; ++ HV* current_root; ++ AV* recurse_mergeout; ++ SV* isv; ++ HV* seen; ++ ++ assert(root); ++ assert(HvAUX(root)); ++ ++ rootname = HvNAME_get(root); ++ if (!rootname) ++ Perl_croak(aTHX_ ++ "Can't linearize anonymous symbol table"); ++ ++ /* shortcut in the case root's linear isa is already cached */ ++ if((retval = HvAUX(root)->xhv_c3_linear_isa) ++ && (HvAUX(root)->xhv_c3_isa_gen == PL_isa_generation)) { ++ SvREFCNT_inc_simple_void_NN(retval); ++ return retval; ++ } ++ ++ C3STACK = newAV(); ++ current_root = root; ++ recurse_mergeout = newAV(); ++ isv = newSViv(0); ++ seen = newHV(); ++ hv_store(seen, rootname, strlen(rootname), &PL_sv_yes, 0); ++ ++ while(1) { ++ gvp = (GV**)hv_fetchs(current_root, "ISA", FALSE); ++ crisa = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL; ++ ++ if(crisa && SvIVX(isv) <= av_len(crisa)) { ++ AV* new_stack_entry; ++ SV* new_root_sv; ++ HV* new_root; ++ const char* new_root_name; ++ int new_root_len; ++ svp = av_fetch(crisa, SvIVX(isv), 0); ++ assert(svp); ++ new_root_sv = *svp; ++ new_root = gv_stashsv(new_root_sv, FALSE); ++ assert(new_root); ++ sv_inc(isv); ++ ++ new_root_name = HvNAME_get(new_root); ++ new_root_len = HvNAMELEN_get(new_root); ++ if(hv_exists(seen, new_root_name, new_root_len)) { ++ Perl_croak(aTHX_ "infinite recursion detected"); ++ } ++ hv_store(seen, new_root_name, new_root_len, &PL_sv_yes, 0); ++ ++ new_stack_entry = newAV(); ++ av_push(new_stack_entry, (SV*)current_root); ++ av_push(new_stack_entry, (SV*)recurse_mergeout); ++ av_push(new_stack_entry, isv); ++ av_push(C3STACK, (SV*)new_stack_entry); ++ ++ current_root = new_root; ++ recurse_mergeout = newAV(); ++ isv = newSViv(0); ++ continue; ++ } ++ ++ const char* current_root_name = HvNAME_get(current_root); ++ int current_root_len = HvNAMELEN_get(current_root); ++ SV* current_root_name_sv = newSVpv(current_root_name, current_root_len); ++ hv_delete(seen, current_root_name, current_root_len, G_DISCARD); ++ ++ AV* res = HvAUX(current_root)->xhv_c3_linear_isa; ++ if(!res || HvAUX(current_root)->xhv_c3_isa_gen != PL_isa_generation) { ++ if(res) SvREFCNT_dec(res); ++ res = newAV(); ++ HV* tails = newHV(); ++ AV* seqs = newAV(); ++ av_push(res, current_root_name_sv); ++ ++ SV** avptr = AvARRAY(recurse_mergeout); ++ I32 items = AvFILLp(recurse_mergeout) + 1; ++ while(items--) { ++ SV** seqptr; ++ I32 seqitems; ++ AV* oseq = (AV*)*avptr++; ++ AV* seq = __av_shallow_copy(oseq); ++ av_push(seqs, (SV*)seq); ++ seqptr = AvARRAY(seq) + 1; ++ seqitems = AvFILLp(seq); ++ while(seqitems--) { ++ __hv_incr(tails, *(seqptr++)); ++ } ++ } ++ ++ if(crisa) { ++ AV* crisa_seq = __av_shallow_copy(crisa); ++ I32 seqitems = AvFILLp(crisa_seq); ++ if(seqitems >= 0) av_push(seqs, (SV*)crisa_seq); ++ if(seqitems > 0) { ++ SV** seqptr = AvARRAY(crisa_seq) + 1; ++ while(seqitems--) { ++ __hv_incr(tails, *(seqptr++)); ++ } ++ } ++ } ++ ++ while(1) { ++ SV* seqhead = NULL; ++ SV* cand = NULL; ++ SV* winner = NULL; ++ SV* val; ++ HE* tail_entry; ++ AV* seq; ++ avptr = AvARRAY(seqs); ++ items = AvFILLp(seqs)+1; ++ while(items--) { ++ seq = (AV*)*avptr++; ++ if(AvFILLp(seq) < 0) continue; ++ svp = av_fetch(seq, 0, 0); ++ seqhead = *svp; ++ if(!winner) { ++ cand = seqhead; ++ if((tail_entry = hv_fetch_ent(tails, cand, 0, 0)) ++ && (val = HeVAL(tail_entry)) ++ && SvIVx(val) > 0) ++ continue; ++ winner = cand; ++ SvREFCNT_inc_simple_void_NN(cand); ++ av_push(res, cand); ++ } ++ if(!sv_cmp(seqhead, winner)) { ++ av_shift(seq); ++ if(AvFILLp(seq) < 0) continue; ++ svp = av_fetch(seq, 0, 0); ++ seqhead = *svp; ++ tail_entry = hv_fetch_ent(tails, seqhead, 0, 0); ++ val = HeVAL(tail_entry); ++ sv_dec(val); ++ } ++ } ++ if(!cand) break; ++ if(!winner) Perl_croak(aTHX_ "Inconsistent hierarchy XXX"); ++ } ++ SvREADONLY_on(res); ++ HvAUX(current_root)->xhv_c3_isa_gen = PL_isa_generation; ++ HvAUX(current_root)->xhv_c3_linear_isa = res; ++ SvREFCNT_dec(tails); ++ SvREFCNT_dec(seqs); ++ } ++ ++ SvREFCNT_dec(recurse_mergeout); ++ SvREFCNT_dec(isv); ++ ++ if(AvFILLp(C3STACK) < 0) { ++ /* clean up our temporaries */ ++ SvREFCNT_dec(C3STACK); ++ SvREFCNT_dec(seen); ++ SvREFCNT_inc_simple_void_NN(res); ++ return res; ++ } ++ ++ AV* tempav = (AV*)av_pop(C3STACK); ++ svp = av_fetch(tempav, 0, 0); ++ current_root = (HV*)*svp; ++ svp = av_fetch(tempav, 1, 0); ++ recurse_mergeout = (AV*)*svp; ++ svp = av_fetch(tempav, 2, 0); ++ isv = *svp; ++ SvREFCNT_inc_simple_void_NN(current_root); ++ SvREFCNT_inc_simple_void_NN(recurse_mergeout); ++ SvREFCNT_inc_simple_void_NN(isv); ++ SvREFCNT_dec(tempav); ++ ++ SvREFCNT_inc_simple_void_NN(res); ++ av_push(recurse_mergeout, (SV*)res); ++ } ++} ++ ++/* ++=for apidoc linear_isa ++ ++Returns either C or C for ++the given stash, dependant upon which MRO is in effect ++for that stash. The return value is a read-only AV*, ++and is cached based on C. ++ ++=cut ++*/ ++AV* ++Perl_linear_isa(pTHX_ HV *stash) ++{ ++ assert(stash); ++ assert(HvAUX(stash)); ++ return HvC3MRO(stash) ? linear_isa_c3(stash) ++ : linear_isa_dfs(stash, 0); ++} ++ ++/* + =for apidoc gv_fetchmeth + + Returns the glob with the given C and a defined subroutine or +@@ -292,7 +611,7 @@ + The argument C should be either 0 or -1. If C, as a + side-effect creates a glob with the given C in the given C + which in the case of success contains an alias for the subroutine, and sets +-up caching info for this glob. Similarly for all the searched stashes. ++up caching info for this glob. + + This function grants C<"SUPER"> token as a postfix of the stash name. The + GV returned from C may be a method cache entry, which is not +@@ -303,133 +622,139 @@ + =cut + */ + ++/* NOTE: No support for tied ISA */ ++ + GV * + Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) + { + dVAR; +- AV* av; +- GV* topgv; +- GV* gv; + GV** gvp; +- CV* cv; ++ AV* linear_isa_av; ++ SV** linear_isa_svp; ++ SV* linear_isa_sv; ++ HV* curstash; ++ GV* candidate = NULL; ++ CV* cand_cv = NULL; ++ CV* old_cv; ++ GV* topgv = NULL; + const char *hvname; +- HV* lastchance = NULL; ++ I32 create = (level >= 0) ? 1 : 0; ++ I32 items; ++ STRLEN packlen; + + /* UNIVERSAL methods should be callable without a stash */ + if (!stash) { +- level = -1; /* probably appropriate */ ++ create = 0; /* probably appropriate */ + if(!(stash = gv_stashpvs("UNIVERSAL", FALSE))) + return 0; + } + ++ assert(stash); ++ + hvname = HvNAME_get(stash); + if (!hvname) +- Perl_croak(aTHX_ +- "Can't use anonymous symbol table for method lookup"); ++ Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); + +- if ((level > 100) || (level < -100)) +- Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'", +- name, hvname); ++ assert(hvname); ++ assert(name); ++ assert(len >= 0); + + DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) ); + +- gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); +- if (!gvp) +- topgv = NULL; ++ /* check locally for a real method or a cache entry */ ++ gvp = (GV**)hv_fetch(stash, name, len, create); ++ if(gvp) { ++ topgv = *gvp; ++ assert(topgv); ++ if (SvTYPE(topgv) != SVt_PVGV) ++ gv_init(topgv, stash, name, len, TRUE); ++ if ((cand_cv = GvCV(topgv))) { ++ /* If genuine method or valid cache entry, use it */ ++ if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation) { ++ return topgv; ++ } ++ else { ++ /* stale cache entry, junk it and move on */ ++ SvREFCNT_dec(cand_cv); ++ GvCV(topgv) = cand_cv = NULL; ++ GvCVGEN(topgv) = 0; ++ } ++ } ++ else if (GvCVGEN(topgv) == PL_sub_generation) { ++ /* cache indicates no such method definitively */ ++ return 0; ++ } ++ } ++ ++ packlen = HvNAMELEN_get(stash); ++ if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) { ++ HV* basestash; ++ packlen -= 7; ++ basestash = gv_stashpvn(hvname, packlen, TRUE); ++ linear_isa_av = linear_isa(basestash); ++ } + else { +- topgv = *gvp; +- if (SvTYPE(topgv) != SVt_PVGV) +- gv_init(topgv, stash, name, len, TRUE); +- if ((cv = GvCV(topgv))) { +- /* If genuine method or valid cache entry, use it */ +- if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation) +- return topgv; +- /* Stale cached entry: junk it */ +- SvREFCNT_dec(cv); +- GvCV(topgv) = cv = NULL; +- GvCVGEN(topgv) = 0; +- } +- else if (GvCVGEN(topgv) == PL_sub_generation) +- return 0; /* cache indicates sub doesn't exist */ ++ linear_isa_av = linear_isa(stash); /* has ourselves at the top of the list */ + } + +- gvp = (GV**)hv_fetchs(stash, "ISA", FALSE); +- av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL; ++ linear_isa_svp = AvARRAY(linear_isa_av) + 1; /* skip over self */ ++ items = AvFILLp(linear_isa_av); /* no +1, to skip over self */ ++ while (items--) { ++ linear_isa_sv = *linear_isa_svp++; ++ assert(linear_isa_sv); ++ curstash = gv_stashsv(linear_isa_sv, FALSE); + +- /* create and re-create @.*::SUPER::ISA on demand */ +- if (!av || !SvMAGIC(av)) { +- STRLEN packlen = HvNAMELEN_get(stash); ++ if (!curstash) { ++ if (ckWARN(WARN_MISC)) ++ Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA", ++ (void*)linear_isa_sv, hvname); ++ continue; ++ } + +- if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) { +- HV* basestash; ++ assert(curstash); + +- packlen -= 7; +- basestash = gv_stashpvn(hvname, packlen, TRUE); +- gvp = (GV**)hv_fetchs(basestash, "ISA", FALSE); +- if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { +- gvp = (GV**)hv_fetchs(stash, "ISA", TRUE); +- if (!gvp || !(gv = *gvp)) +- Perl_croak(aTHX_ "Cannot create %s::ISA", hvname); +- if (SvTYPE(gv) != SVt_PVGV) +- gv_init(gv, stash, "ISA", 3, TRUE); +- SvREFCNT_dec(GvAV(gv)); +- GvAV(gv) = (AV*)SvREFCNT_inc_simple(av); +- } +- } ++ gvp = (GV**)hv_fetch(curstash, name, len, 0); ++ if (!gvp) continue; ++ candidate = *gvp; ++ assert(candidate); ++ if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, curstash, name, len, TRUE); ++ if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { ++ /* ++ * Found real method, cache method in topgv if: ++ * 1. topgv has no synonyms (else inheritance crosses wires) ++ * 2. method isn't a stub (else AUTOLOAD fails spectacularly) ++ */ ++ if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { ++ if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv); ++ SvREFCNT_inc_simple_void_NN(cand_cv); ++ GvCV(topgv) = cand_cv; ++ GvCVGEN(topgv) = PL_sub_generation; ++ } ++ SvREFCNT_dec(linear_isa_av); ++ return candidate; ++ } + } + +- if (av) { +- SV** svp = AvARRAY(av); +- /* NOTE: No support for tied ISA */ +- I32 items = AvFILLp(av) + 1; +- while (items--) { +- SV* const sv = *svp++; +- HV* const basestash = gv_stashsv(sv, FALSE); +- if (!basestash) { +- if (ckWARN(WARN_MISC)) +- Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA", +- (void*)sv, hvname); +- continue; +- } +- gv = gv_fetchmeth(basestash, name, len, +- (level >= 0) ? level + 1 : level - 1); +- if (gv) +- goto gotcha; +- } ++ SvREFCNT_dec(linear_isa_av); ++ ++ /* Check UNIVERSAL without caching */ ++ if(level == 0 || level == -1) { ++ candidate = gv_fetchmeth(NULL, name, len, 1); ++ if(candidate) { ++ cand_cv = GvCV(candidate); ++ if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { ++ if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv); ++ SvREFCNT_inc_simple_void_NN(cand_cv); ++ GvCV(topgv) = cand_cv; ++ GvCVGEN(topgv) = PL_sub_generation; ++ } ++ return candidate; ++ } + } + +- /* if at top level, try UNIVERSAL */ +- +- if (level == 0 || level == -1) { +- lastchance = gv_stashpvs("UNIVERSAL", FALSE); +- +- if (lastchance) { +- if ((gv = gv_fetchmeth(lastchance, name, len, +- (level >= 0) ? level + 1 : level - 1))) +- { +- gotcha: +- /* +- * Cache method in topgv if: +- * 1. topgv has no synonyms (else inheritance crosses wires) +- * 2. method isn't a stub (else AUTOLOAD fails spectacularly) +- */ +- if (topgv && +- GvREFCNT(topgv) == 1 && +- (cv = GvCV(gv)) && +- (CvROOT(cv) || CvXSUB(cv))) +- { +- if ((cv = GvCV(topgv))) +- SvREFCNT_dec(cv); +- GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv)); +- GvCVGEN(topgv) = PL_sub_generation; +- } +- return gv; +- } +- else if (topgv && GvREFCNT(topgv) == 1) { +- /* cache the fact that the method is not defined */ +- GvCVGEN(topgv) = PL_sub_generation; +- } +- } ++ if (topgv && GvREFCNT(topgv) == 1) { ++ /* cache the fact that the method is not defined */ ++ GvCVGEN(topgv) = PL_sub_generation; + } + + return 0; +=== lib/c3mro.pm +================================================================== +--- lib/c3mro.pm (/local/perl-current) (revision 12336) ++++ lib/c3mro.pm (/local/perl-c3) (revision 12336) +@@ -0,0 +1,5 @@ ++package c3mro; ++use B qw/ enable_c3mro disable_c3mro /; ++sub import { enable_c3mro(scalar(caller)) } ++sub unimport { disable_c3mro(scalar(caller)) } ++1; +=== perlapi.h +================================================================== +--- perlapi.h (/local/perl-current) (revision 12336) ++++ perlapi.h (/local/perl-c3) (revision 12336) +@@ -336,6 +336,8 @@ + #define PL_initav (*Perl_Iinitav_ptr(aTHX)) + #undef PL_inplace + #define PL_inplace (*Perl_Iinplace_ptr(aTHX)) ++#undef PL_isa_generation ++#define PL_isa_generation (*Perl_Iisa_generation_ptr(aTHX)) + #undef PL_known_layers + #define PL_known_layers (*Perl_Iknown_layers_ptr(aTHX)) + #undef PL_last_lop +=== proto.h +================================================================== +--- proto.h (/local/perl-current) (revision 12336) ++++ proto.h (/local/perl-c3) (revision 12336) +@@ -624,6 +624,15 @@ + PERL_CALLCONV GV* Perl_gv_fetchfile(pTHX_ const char* name) + __attribute__nonnull__(pTHX_1); + ++PERL_CALLCONV AV* Perl_linear_isa(pTHX_ HV* stash) ++ __attribute__nonnull__(pTHX_1); ++ ++PERL_CALLCONV AV* Perl_linear_isa_c3(pTHX_ HV* stash) ++ __attribute__nonnull__(pTHX_1); ++ ++PERL_CALLCONV AV* Perl_linear_isa_dfs(pTHX_ HV* stash, I32 level) ++ __attribute__nonnull__(pTHX_1); ++ + PERL_CALLCONV GV* Perl_gv_fetchmeth(pTHX_ HV* stash, const char* name, STRLEN len, I32 level) + __attribute__nonnull__(pTHX_2); + +=== ext/B/t/concise-xs.t +================================================================== +--- ext/B/t/concise-xs.t (/local/perl-current) (revision 12336) ++++ ext/B/t/concise-xs.t (/local/perl-c3) (revision 12336) +@@ -117,7 +117,7 @@ + use Carp; + use Test::More tests => ( # per-pkg tests (function ct + require_ok) + 40 + 16 # Data::Dumper, Digest::MD5 +- + 517 + 236 # B::Deparse, B ++ + 517 + 243 # B::Deparse, B + + 595 + 190 # POSIX, IO::Socket + + 3 * ($] > 5.009) + + 16 * ($] >= 5.009003) +@@ -157,7 +157,8 @@ + formfeed end_av dowarn diehook defstash curstash + cstring comppadlist check_av cchar cast_I32 bootstrap + begin_av amagic_generation sub_generation address +- unitcheck_av ++ unitcheck_av isa_generation enable_c3mro disable_c3mro ++ is_c3mro get_linear_isa get_linear_isa_c3 get_linear_isa_dfs + )], + }, + +=== ext/B/B.xs +================================================================== +--- ext/B/B.xs (/local/perl-current) (revision 12336) ++++ ext/B/B.xs (/local/perl-c3) (revision 12336) +@@ -604,6 +604,7 @@ + #define B_main_start() PL_main_start + #define B_amagic_generation() PL_amagic_generation + #define B_sub_generation() PL_sub_generation ++#define B_isa_generation() PL_isa_generation + #define B_defstash() PL_defstash + #define B_curstash() PL_curstash + #define B_dowarn() PL_dowarn +@@ -656,6 +657,9 @@ + long + B_sub_generation() + ++long ++B_isa_generation() ++ + B::AV + B_comppadlist() + +@@ -709,6 +713,70 @@ + OUTPUT: + RETVAL + ++AV* ++get_linear_isa(classname) ++ SV* classname ++ CODE: ++ HV* class_stash; ++ class_stash = gv_stashsv(classname, 0); ++ if(!class_stash) Perl_croak(aTHX_ "No such class!"); ++ RETVAL = Perl_linear_isa(class_stash); ++ OUTPUT: ++ RETVAL ++ ++AV* ++get_linear_isa_dfs(classname) ++ SV* classname ++ CODE: ++ HV* class_stash; ++ class_stash = gv_stashsv(classname, 0); ++ if(!class_stash) Perl_croak(aTHX_ "No such class!"); ++ RETVAL = Perl_linear_isa_dfs(class_stash, 0); ++ OUTPUT: ++ RETVAL ++ ++AV* ++get_linear_isa_c3(classname) ++ SV* classname ++ CODE: ++ HV* class_stash; ++ class_stash = gv_stashsv(classname, 0); ++ if(!class_stash) Perl_croak(aTHX_ "No such class!"); ++ RETVAL = Perl_linear_isa_c3(class_stash); ++ OUTPUT: ++ RETVAL ++ ++void ++enable_c3mro(classname) ++ SV* classname ++ CODE: ++ HV* class_stash; ++ class_stash = gv_stashsv(classname, 1); ++ if(!class_stash) Perl_croak(aTHX_ "Cannot create class!"); ++ HvAUX(class_stash)->xhv_c3mro = TRUE; ++ PL_sub_generation++; ++ ++void ++disable_c3mro(classname) ++ SV* classname ++ CODE: ++ HV* class_stash; ++ class_stash = gv_stashsv(classname, 1); ++ if(!class_stash) Perl_croak(aTHX_ "Cannot create class!"); ++ HvAUX(class_stash)->xhv_c3mro = FALSE; ++ PL_sub_generation++; ++ ++bool ++is_c3mro(classname) ++ SV* classname ++ CODE: ++ HV* class_stash; ++ class_stash = gv_stashsv(classname, 0); ++ if(!class_stash) Perl_croak(aTHX_ "No such class!"); ++ RETVAL = HvC3MRO(class_stash); ++ OUTPUT: ++ RETVAL ++ + #define address(sv) PTR2IV(sv) + + IV +=== ext/B/B.pm +================================================================== +--- ext/B/B.pm (/local/perl-current) (revision 12336) ++++ ext/B/B.pm (/local/perl-c3) (revision 12336) +@@ -23,6 +23,8 @@ + parents comppadlist sv_undef compile_stats timing_info + begin_av init_av unitcheck_av check_av end_av regex_padav + dowarn defstash curstash warnhook diehook inc_gv ++ isa_generation enable_c3mro disable_c3mro is_c3mro ++ get_linear_isa get_linear_isa_c3 get_linear_isa_dfs + ); + + sub OPf_KIDS (); +=== hv.c +================================================================== +--- hv.c (/local/perl-current) (revision 12336) ++++ hv.c (/local/perl-c3) (revision 12336) +@@ -1895,6 +1895,11 @@ + iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ + iter->xhv_name = 0; + iter->xhv_backreferences = 0; ++ iter->xhv_dfs_linear_isa = NULL; ++ iter->xhv_dfs_isa_gen = 0; ++ iter->xhv_c3_linear_isa = NULL; ++ iter->xhv_c3_isa_gen = 0; ++ iter->xhv_c3mro = 0; + return iter; + } + +=== hv.h +================================================================== +--- hv.h (/local/perl-current) (revision 12336) ++++ hv.h (/local/perl-c3) (revision 12336) +@@ -44,6 +44,11 @@ + AV *xhv_backreferences; /* back references for weak references */ + HE *xhv_eiter; /* current entry of iterator */ + I32 xhv_riter; /* current root of iterator */ ++ AV *xhv_dfs_linear_isa; /* cached dfs @ISA linearization */ ++ AV *xhv_c3_linear_isa; /* cached c3 @ISA linearization */ ++ U32 xhv_dfs_isa_gen; /* PL_isa_generation for above */ ++ U32 xhv_c3_isa_gen; /* PL_isa_generation for above */ ++ bool xhv_c3mro; /* use c3 mro for this class */ + }; + + /* hash structure: */ +@@ -235,6 +240,7 @@ + #define HvRITER_get(hv) (SvOOK(hv) ? HvAUX(hv)->xhv_riter : -1) + #define HvEITER_get(hv) (SvOOK(hv) ? HvAUX(hv)->xhv_eiter : 0) + #define HvNAME(hv) HvNAME_get(hv) ++#define HvC3MRO(hv) (SvOOK(hv) ? HvAUX(hv)->xhv_c3mro : 0) + /* FIXME - all of these should use a UTF8 aware API, which should also involve + getting the length. */ + /* This macro may go away without notice. */ +=== mg.c +================================================================== +--- mg.c (/local/perl-current) (revision 12336) ++++ mg.c (/local/perl-c3) (revision 12336) +@@ -1511,6 +1511,7 @@ + PERL_UNUSED_ARG(sv); + PERL_UNUSED_ARG(mg); + PL_sub_generation++; ++ PL_isa_generation++; + return 0; + } + +=== intrpvar.h +================================================================== +--- intrpvar.h (/local/perl-current) (revision 12336) ++++ intrpvar.h (/local/perl-c3) (revision 12336) +@@ -560,6 +560,7 @@ + PERLVARI(Iutf8cache, I8, 1) /* Is the utf8 caching code enabled? */ + #endif + ++PERLVARI(Iisa_generation,U32,1) /* incr to invalidate @ISA linearization cache */ + /* New variables must be added to the very end, before this comment, + * for binary compatibility (the offsets of the old members must not change). + * (Don't forget to add your variable also to perl_clone()!) +=== sv.c +================================================================== +--- sv.c (/local/perl-current) (revision 12336) ++++ sv.c (/local/perl-c3) (revision 12336) +@@ -10983,6 +10983,7 @@ + PL_initav = av_dup_inc(proto_perl->Iinitav, param); + + PL_sub_generation = proto_perl->Isub_generation; ++ PL_isa_generation = proto_perl->Iisa_generation; + + /* funky return mechanisms */ + PL_forkprocess = proto_perl->Iforkprocess; +=== embed.fnc +================================================================== +--- embed.fnc (/local/perl-current) (revision 12336) ++++ embed.fnc (/local/perl-c3) (revision 12336) +@@ -278,6 +278,9 @@ + Apmb |void |gv_efullname3 |NN SV* sv|NN const GV* gv|NULLOK const char* prefix + Ap |void |gv_efullname4 |NN SV* sv|NN const GV* gv|NULLOK const char* prefix|bool keepmain + Ap |GV* |gv_fetchfile |NN const char* name ++pM |AV* |linear_isa |NN HV* stash ++pM |AV* |linear_isa_c3 |NN HV* stash ++pM |AV* |linear_isa_dfs |NN HV* stash|I32 level + Apd |GV* |gv_fetchmeth |NULLOK HV* stash|NN const char* name|STRLEN len|I32 level + Apd |GV* |gv_fetchmeth_autoload |NULLOK HV* stash|NN const char* name|STRLEN len|I32 level + Apdmb |GV* |gv_fetchmethod |NULLOK HV* stash|NN const char* name + +Property changes on: +___________________________________________________________________ +Name: svk:merge + +2679d79f-d018-0410-a353-0f906ad2929c:/local/perl-current:12331 +