X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FClass-C3-XS.git;a=blobdiff_plain;f=XS.xs;h=19340c2bd99aeb475046ea2234e41d025ea53067;hp=7dd3695931ef481cce8fbb9d1cc1b135a678f9df;hb=ff94166e91692aaaab9cc8b493cd753d88e56b2c;hpb=b34605d048d08a93a7b93bc3428a1e2f00df5f9b diff --git a/XS.xs b/XS.xs index 7dd3695..19340c2 100644 --- a/XS.xs +++ b/XS.xs @@ -3,14 +3,58 @@ #include "perl.h" #include "XSUB.h" +/* *********** ppport stuff */ + +#ifndef PERL_UNUSED_VAR +# define PERL_UNUSED_VAR(x) ((void)x) +#endif + +#if defined(PERL_GCC_PEDANTIC) +# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN +# define PERL_GCC_BRACE_GROUPS_FORBIDDEN +# endif +#endif + +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) +# ifndef PERL_USE_GCC_BRACE_GROUPS +# define PERL_USE_GCC_BRACE_GROUPS +# endif +#endif + +#ifndef SvREFCNT_inc +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (SvREFCNT(_sv))++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc(sv) \ + ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) +# endif +#endif + +#ifndef dAX +# define dAX I32 ax = MARK - PL_stack_base + 1 +#endif + +#ifndef dVAR +# define dVAR dNOOP +#endif + +#ifndef packWARN +# define packWARN(a) (a) +#endif + +/* *********** end ppport.h stuff */ + /* Most of this code is backported from the bleadperl patch's mro.c, and then modified to work with Class::C3's internals. */ -/* This is %next::METHOD_CACHE */ -STATIC HV* nmcache; - AV* __mro_linear_isa_c3(pTHX_ HV* stash, HV* cache, I32 level) { @@ -20,9 +64,9 @@ __mro_linear_isa_c3(pTHX_ HV* stash, HV* cache, I32 level) AV* isa; const char* stashname; STRLEN stashname_len; + I32 made_mortal_cache = 0; assert(stash); - assert(HvAUX(stash)); stashname = HvNAME(stash); stashname_len = strlen(stashname); @@ -36,6 +80,7 @@ __mro_linear_isa_c3(pTHX_ HV* stash, HV* cache, I32 level) if(!cache) { cache = (HV*)sv_2mortal((SV*)newHV()); + made_mortal_cache = 1; } else { SV** cache_entry = hv_fetch(cache, stashname, stashname_len, 0); @@ -45,100 +90,170 @@ __mro_linear_isa_c3(pTHX_ HV* stash, HV* cache, I32 level) /* not in cache, make a new one */ - retval = (AV*)sv_2mortal((SV*)newAV()); - av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */ - gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE); isa = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL; - if(isa && AvFILLp(isa) >= 0) { SV** seqs_ptr; I32 seqs_items; - HV* tails = (HV*)sv_2mortal((SV*)newHV()); - AV* seqs = (AV*)sv_2mortal((SV*)newAV()); + HV* const tails = (HV*)sv_2mortal((SV*)newHV()); + AV* const seqs = (AV*)sv_2mortal((SV*)newAV()); + I32* heads; + + /* This builds @seqs, which is an array of arrays. + The members of @seqs are the MROs of + the members of @ISA, followed by @ISA itself. + */ I32 items = AvFILLp(isa) + 1; SV** isa_ptr = AvARRAY(isa); while(items--) { - AV* isa_lin; - SV* isa_item = *isa_ptr++; - HV* isa_item_stash = gv_stashsv(isa_item, 0); + SV* const isa_item = *isa_ptr++; + HV* const isa_item_stash = gv_stashsv(isa_item, 0); if(!isa_item_stash) { - isa_lin = newAV(); + /* if no stash, make a temporary fake MRO + containing just itself */ + AV* const isa_lin = newAV(); av_push(isa_lin, newSVsv(isa_item)); + av_push(seqs, (SV*)isa_lin); } else { - isa_lin = (AV*)sv_2mortal((SV*)__mro_linear_isa_c3(aTHX_ isa_item_stash, cache, level + 1)); /* recursion */ + /* recursion */ + AV* const isa_lin = __mro_linear_isa_c3(aTHX_ isa_item_stash, cache, level + 1); + av_push(seqs, (SV*)isa_lin); } - av_push(seqs, (SV*)av_make(AvFILLp(isa_lin)+1, AvARRAY(isa_lin))); } - av_push(seqs, (SV*)av_make(AvFILLp(isa)+1, AvARRAY(isa))); - + av_push(seqs, SvREFCNT_inc((SV*)isa)); + + /* This builds "heads", which as an array of integer array + indices, one per seq, which point at the virtual "head" + of the seq (initially zero) */ + Newz(0xdead, heads, AvFILLp(seqs)+1, I32); + + /* This builds %tails, which has one key for every class + mentioned in the tail of any sequence in @seqs (tail meaning + everything after the first class, the "head"). The value + is how many times this key appears in the tails of @seqs. + */ seqs_ptr = AvARRAY(seqs); seqs_items = AvFILLp(seqs) + 1; while(seqs_items--) { - AV* seq = (AV*)*seqs_ptr++; + AV* const seq = (AV*)*seqs_ptr++; I32 seq_items = AvFILLp(seq); if(seq_items > 0) { SV** seq_ptr = AvARRAY(seq) + 1; while(seq_items--) { - SV* seqitem = *seq_ptr++; - HE* he = hv_fetch_ent(tails, seqitem, 0, 0); + SV* const seqitem = *seq_ptr++; + HE* const he = hv_fetch_ent(tails, seqitem, 0, 0); if(!he) { hv_store_ent(tails, seqitem, newSViv(1), 0); } else { - SV* val = HeVAL(he); + SV* const val = HeVAL(he); sv_inc(val); } } } } + /* Initialize retval to build the return value in */ + retval = newAV(); + av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */ + + /* This loop won't terminate until we either finish building + the MRO, or get an exception. */ while(1) { - SV* seqhead = NULL; SV* cand = NULL; SV* winner = NULL; - SV* val; - HE* tail_entry; - AV* seq; - SV** avptr = AvARRAY(seqs); - items = AvFILLp(seqs)+1; - while(items--) { + int s; + + /* "foreach $seq (@seqs)" */ + SV** const avptr = AvARRAY(seqs); + for(s = 0; s <= AvFILLp(seqs); s++) { SV** svp; - seq = (AV*)*avptr++; - if(AvFILLp(seq) < 0) continue; - svp = av_fetch(seq, 0, 0); - seqhead = *svp; + AV * const seq = (AV*)(avptr[s]); + SV* seqhead; + if(!seq) continue; /* skip empty seqs */ + svp = av_fetch(seq, heads[s], 0); + seqhead = *svp; /* seqhead = head of this seq */ if(!winner) { + HE* tail_entry; + SV* val; + /* if we haven't found a winner for this round yet, + and this seqhead is not in tails (or the count + for it in tails has dropped to zero), then this + seqhead is our new winner, and is added to the + final MRO immediately */ cand = seqhead; if((tail_entry = hv_fetch_ent(tails, cand, 0, 0)) && (val = HeVAL(tail_entry)) - && (SvIVx(val) > 0)) + && (SvIVX(val) > 0)) continue; winner = newSVsv(cand); av_push(retval, winner); + /* note however that even when we find a winner, + we continue looping over @seqs to do housekeeping */ } if(!sv_cmp(seqhead, winner)) { - sv_2mortal(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); + /* Once we have a winner (including the iteration + where we first found him), inc the head ptr + for any seq which had the winner as a head, + NULL out any seq which is now empty, + and adjust tails for consistency */ + + const int new_head = ++heads[s]; + if(new_head > AvFILLp(seq)) { + SvREFCNT_dec(avptr[s]); + avptr[s] = NULL; + } + else { + HE* tail_entry; + SV* val; + /* Because we know this new seqhead used to be + a tail, we can assume it is in tails and has + a positive value, which we need to dec */ + svp = av_fetch(seq, new_head, 0); + seqhead = *svp; + tail_entry = hv_fetch_ent(tails, seqhead, 0, 0); + val = HeVAL(tail_entry); + sv_dec(val); + } } } - if(!cand) break; - if(!winner) + + /* if we found no candidates, we are done building the MRO. + !cand means no seqs have any entries left to check */ + if(!cand) { + Safefree(heads); + break; + } + + /* If we had candidates, but nobody won, then the @ISA + hierarchy is not C3-incompatible */ + if(!winner) { + /* we have to do some cleanup before we croak */ + + SvREFCNT_dec(retval); + Safefree(heads); + Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': " "merging failed on parent '%s'", stashname, SvPV_nolen(cand)); + } } } + else { /* @ISA was undefined or empty */ + /* build a retval containing only ourselves */ + retval = newAV(); + av_push(retval, newSVpvn(stashname, stashname_len)); + } + /* we don't want anyone modifying the cache entry but us, + and we do so by replacing it completely */ SvREADONLY_on(retval); - SvREFCNT_inc(retval); /* for cache storage */ - SvREFCNT_inc(retval); /* for return */ - hv_store(cache, stashname, stashname_len, (SV*)retval, 0); + + if(!made_mortal_cache) { + SvREFCNT_inc(retval); + hv_store(cache, stashname, stashname_len, (SV*)retval, 0); + } + return retval; } @@ -151,9 +266,13 @@ __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) { return i; } -STATIC SV* -__nextcan(pTHX_ SV* self, I32 throw_nomethod) +XS(XS_Class_C3_XS_nextcan); +XS(XS_Class_C3_XS_nextcan) { + dVAR; dXSARGS; + + SV* self = ST(0); + const I32 throw_nomethod = SvIVX(ST(1)); register I32 cxix; register const PERL_CONTEXT *ccstack = cxstack; const PERL_SI *top_si = PL_curstackinfo; @@ -169,15 +288,17 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod) GV** gvp; AV* linear_av; SV** linear_svp; - SV* linear_sv; HV* cstash; GV* candidate = NULL; CV* cand_cv = NULL; const char *hvname; - I32 items; + I32 entries; + HV* nmcache; HE* cache_entry; SV* cachekey; + SP -= items; + if(sv_isobject(self)) selfstash = SvSTASH(SvRV(self)); else @@ -187,9 +308,10 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod) hvname = HvNAME(selfstash); if (!hvname) - croak("Can't use anonymous symbol table for method lookup"); + Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); cxix = __dopoptosub_at(cxstack, cxstack_ix); + cxix = __dopoptosub_at(ccstack, cxix - 1); /* skip next::method, etc */ /* This block finds the contextually-enclosing fully-qualified subname, much like looking at (caller($i))[3] until you find a real sub that @@ -198,7 +320,7 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod) /* we may be in a higher stacklevel, so dig down deeper */ while (cxix < 0) { if(top_si->si_type == PERLSI_MAIN) - croak("next::method/next::can/maybe::next::method must be used in method context"); + Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context"); top_si = top_si->si_prev; ccstack = top_si->si_cxstack; cxix = __dopoptosub_at(ccstack, top_si->si_cxix); @@ -237,7 +359,7 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod) subname = strrchr(fq_subname, ':'); if(!subname) - croak("next::method/next::can/maybe::next::method cannot find enclosing method"); + Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method"); subname++; subname_len = fq_subname_len - (subname - fq_subname); @@ -255,14 +377,16 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod) sv_catpvn(cachekey, "|", 1); sv_catsv(cachekey, sv); + nmcache = get_hv("next::METHOD_CACHE", 1); if((cache_entry = hv_fetch_ent(nmcache, cachekey, 0, 0))) { SV* val = HeVAL(cache_entry); if(val == &PL_sv_undef) { if(throw_nomethod) - croak("No next::method '%s' found for %s", subname, hvname); - return &PL_sv_undef; + Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname); + XSRETURN_EMPTY; } - return SvREFCNT_inc(val); + XPUSHs(sv_2mortal(newRV_inc(val))); + XSRETURN(1); } /* beyond here is just for cache misses, so perf isn't as critical */ @@ -270,35 +394,41 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod) stashname_len = subname - fq_subname - 2; stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len)); - linear_av = (AV*)sv_2mortal((SV*)__mro_linear_isa_c3(aTHX_ selfstash, NULL, 0)); + linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0); linear_svp = AvARRAY(linear_av); - items = AvFILLp(linear_av) + 1; + entries = AvFILLp(linear_av) + 1; - while (items--) { - linear_sv = *linear_svp++; + while (entries--) { + SV* const linear_sv = *linear_svp++; assert(linear_sv); if(sv_eq(linear_sv, stashname)) break; } - if(items > 0) { + if(entries > 0) { SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len)); HV* cc3_mro = get_hv("Class::C3::MRO", 0); - while (items--) { - linear_sv = *linear_svp++; + while (entries--) { + SV* const linear_sv = *linear_svp++; assert(linear_sv); if(cc3_mro) { HE* he_cc3_mro_class = hv_fetch_ent(cc3_mro, linear_sv, 0, 0); if(he_cc3_mro_class) { - HV* cc3_mro_class = (HV*)SvRV(HeVAL(he_cc3_mro_class)); - SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0); - if(svp_cc3_mro_class_methods) { - HV* cc3_mro_class_methods = (HV*)SvRV(*svp_cc3_mro_class_methods); - if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0)) - continue; + SV* cc3_mro_class_sv = HeVAL(he_cc3_mro_class); + if(SvROK(cc3_mro_class_sv)) { + HV* cc3_mro_class = (HV*)SvRV(cc3_mro_class_sv); + SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0); + if(svp_cc3_mro_class_methods) { + SV* cc3_mro_class_methods_sv = *svp_cc3_mro_class_methods; + if(SvROK(cc3_mro_class_methods_sv)) { + HV* cc3_mro_class_methods = (HV*)SvRV(cc3_mro_class_methods_sv); + if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0)) + continue; + } + } } } } @@ -323,27 +453,26 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod) if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, subname, subname_len, TRUE); if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { + SvREFCNT_dec(linear_av); SvREFCNT_inc((SV*)cand_cv); hv_store_ent(nmcache, newSVsv(cachekey), (SV*)cand_cv, 0); - return (SV*)cand_cv; + XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv))); + XSRETURN(1); } } } + SvREFCNT_dec(linear_av); hv_store_ent(nmcache, newSVsv(cachekey), &PL_sv_undef, 0); if(throw_nomethod) - croak("No next::method '%s' found for %s", subname, hvname); - return &PL_sv_undef; + Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname); + XSRETURN_EMPTY; } XS(XS_Class_C3_XS_calculateMRO); XS(XS_Class_C3_XS_calculateMRO) { -#ifdef dVAR dVAR; dXSARGS; -#else - dXSARGS; -#endif SV* classname; HV* class_stash; @@ -360,9 +489,10 @@ XS(XS_Class_C3_XS_calculateMRO) if(items == 2) cache = (HV*)SvRV(ST(1)); class_stash = gv_stashsv(classname, 0); - if(!class_stash) croak("No such class: '%s'!", SvPV_nolen(classname)); + if(!class_stash) + Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname)); - res = (AV*)sv_2mortal((SV*)__mro_linear_isa_c3(aTHX_ class_stash, cache, 0)); + res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0); res_items = ret_items = AvFILLp(res) + 1; res_ptr = AvARRAY(res); @@ -371,72 +501,121 @@ XS(XS_Class_C3_XS_calculateMRO) while(res_items--) { SV* res_item = *res_ptr++; - XPUSHs(res_item); + XPUSHs(sv_2mortal(newSVsv(res_item))); } + SvREFCNT_dec(res); PUTBACK; return; } -XS(XS_next_can); -XS(XS_next_can) +XS(XS_Class_C3_XS_plsubgen); +XS(XS_Class_C3_XS_plsubgen) { -#ifdef dVAR dVAR; dXSARGS; -#else - dXSARGS; -#endif - SV* self = ST(0); - SV* methcv = __nextcan(aTHX_ self, 0); + SP -= items; + XPUSHs(sv_2mortal(newSViv(PL_sub_generation))); + PUTBACK; + return; +} - PERL_UNUSED_VAR(items); +XS(XS_Class_C3_XS_calc_mdt); +XS(XS_Class_C3_XS_calc_mdt) +{ + dVAR; dXSARGS; - if(methcv == &PL_sv_undef) { - ST(0) = &PL_sv_undef; - } - else { - ST(0) = sv_2mortal(newRV_inc(methcv)); - } + SV* classname; + HV* cache; + HV* class_stash; + AV* class_mro; + HV* our_c3mro; /* $Class::C3::MRO{classname} */ + SV* has_ovf = NULL; + HV* methods; + I32 mroitems; - XSRETURN(1); -} + /* temps */ + HV* hv; + HE* he; + SV** svp; -XS(XS_next_method); -XS(XS_next_method) -{ - dMARK; - dAX; - SV* self = ST(0); - SV* methcv = __nextcan(aTHX_ self, 1); + if(items < 1 || items > 2) + croak("Usage: calculate_method_dispatch_table(classname[, cache])"); - PL_markstack_ptr++; - call_sv(methcv, GIMME_V); -} + classname = ST(0); + class_stash = gv_stashsv(classname, 0); + if(!class_stash) + Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname)); -XS(XS_maybe_next_method); -XS(XS_maybe_next_method) -{ - dMARK; - dAX; - SV* self = ST(0); - SV* methcv = __nextcan(aTHX_ self, 0); + if(items == 2) cache = (HV*)SvRV(ST(1)); - if(methcv == &PL_sv_undef) { - ST(0) = &PL_sv_undef; - XSRETURN(1); + class_mro = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0); + + our_c3mro = newHV(); + hv_store(our_c3mro, "MRO", 3, (SV*)newRV_noinc((SV*)class_mro), 0); + + hv = get_hv("Class::C3::MRO", 1); + hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0); + + methods = newHV(); + + /* skip first entry */ + mroitems = AvFILLp(class_mro); + svp = AvARRAY(class_mro) + 1; + while(mroitems--) { + SV* mro_class = *svp++; + HV* mro_stash = gv_stashsv(mro_class, 0); + + if(!mro_stash) continue; + + if(!has_ovf) { + SV** ovfp = hv_fetch(mro_stash, "()", 2, 0); + if(ovfp) has_ovf = *ovfp; + } + + hv_iterinit(mro_stash); + while(he = hv_iternext(mro_stash)) { + CV* code; + SV* mskey; + SV* msval; + HE* ourent; + HV* meth_hash; + SV* orig; + + mskey = hv_iterkeysv(he); + if(hv_exists_ent(methods, mskey, 0)) continue; + + msval = hv_iterval(mro_stash, he); + if(SvTYPE(msval) != SVt_PVGV || !(code = GvCVu(msval))) + continue; + + if((ourent = hv_fetch_ent(class_stash, mskey, 0, 0))) { + SV* val = HeVAL(ourent); + if(val && SvTYPE(val) == SVt_PVGV && GvCVu(val)) + continue; + } + + meth_hash = newHV(); + orig = newSVsv(mro_class); + sv_catpvn(orig, "::", 2); + sv_catsv(orig, mskey); + hv_store(meth_hash, "orig", 4, orig, 0); + hv_store(meth_hash, "code", 4, newRV_inc((SV*)code), 0); + hv_store_ent(methods, mskey, newRV_noinc((SV*)meth_hash), 0); + } } - PL_markstack_ptr++; - call_sv(methcv, GIMME_V); + hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0); + if(has_ovf) hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0); + XSRETURN_EMPTY; } MODULE = Class::C3::XS PACKAGE = Class::C3::XS BOOT: - nmcache = get_hv("next::METHOD_CACHE", 1); newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__); - newXS("next::can", XS_next_can, __FILE__); - newXS("next::method", XS_next_method, __FILE__); - newXS("maybe::next::method", XS_maybe_next_method, __FILE__); + newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__); + newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__); + newXS("Class::C3::XS::_nextcan", XS_Class_C3_XS_nextcan, __FILE__); +