In perl.git, the branch smueller/hash_vtable has been updated <http://perl5.git.perl.org/perl.git/commitdiff/b0cea599b731a826e4d9d9dd3fcc2640729dc125?hp=e854d9268d27d3194e7079943a767c4d0eba4cab>
- Log ----------------------------------------------------------------- commit b0cea599b731a826e4d9d9dd3fcc2640729dc125 Author: Steffen Mueller <[email protected]> Date: Wed Jan 25 20:04:44 2017 +0100 Hash vtables: Move vtable testing hook From newHV() to sv_upgrade() because that should now literally be the place all hash allocations go through. (Famous last...) M hv.h M sv.c commit aca8800db04c3ea789952e8bce3595172c7535f2 Author: Steffen Mueller <[email protected]> Date: Wed Jan 25 20:04:27 2017 +0100 Hash vtables: exists shim M hv.c M hv_vtbl.c M hv_vtbl.h commit b91bd5303e753e806c60bcb4e42a2931b17f8de8 Author: Steffen Mueller <[email protected]> Date: Wed Jan 25 16:19:20 2017 +0100 Hash vtables: Add hooks for init/destroy Also implements empty hooks in the mock example of the standard hash implementation. M hv.c M hv_vtbl.c M hv_vtbl.h M sv.c commit cd12cb85e6629538704c6a52e98b3626ed79a7d2 Author: Steffen Mueller <[email protected]> Date: Wed Jan 25 16:16:09 2017 +0100 Hash vtables: Regen for previous commit M embed.h M proto.h commit 2a66f22badde96dd439c22c42c8ee61a3e33c4d3 Author: Steffen Mueller <[email protected]> Date: Wed Jan 25 16:15:50 2017 +0100 Hash vtables: Fix warning: Introduce PERL_IN_HV_VTBL_C M embed.fnc M hv_vtbl.c ----------------------------------------------------------------------- Summary of changes: embed.fnc | 4 +++- embed.h | 4 +++- hv.c | 8 +++++++- hv.h | 4 +--- hv_vtbl.c | 51 ++++++++++++++++++++++++++++++++++++++++++++++++++- hv_vtbl.h | 15 +++++++++++++++ proto.h | 4 +++- sv.c | 14 ++++++++++++-- 8 files changed, 94 insertions(+), 10 deletions(-) diff --git a/embed.fnc b/embed.fnc index d6fc6c4bfd..a48851d8c7 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2083,10 +2083,12 @@ rs |void |hv_notallowed |int flags|NN const char *key|I32 klen|NN const char *ms in |U32|ptr_hash|PTRV u s |struct xpvhv_aux*|hv_auxinit|NN HV *hv sn |struct xpvhv_aux*|hv_auxinit_internal|NN struct xpvhv_aux *iter +sM |void |clear_placeholders |NN HV *hv|U32 items +#endif +#if defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_HV_VTBL_C) pM |SV* |hv_delete_common|NULLOK HV *hv|NULLOK SV *keysv \ |NULLOK const char *key|STRLEN klen|int k_flags|I32 d_flags \ |U32 hash -sM |void |clear_placeholders |NN HV *hv|U32 items #endif #if defined(PERL_IN_MG_C) diff --git a/embed.h b/embed.h index 530f93a6f4..8df48650f0 100644 --- a/embed.h +++ b/embed.h @@ -1576,7 +1576,6 @@ #define hsplit(a,b,c) S_hsplit(aTHX_ a,b,c) #define hv_auxinit(a) S_hv_auxinit(aTHX_ a) #define hv_auxinit_internal S_hv_auxinit_internal -#define hv_delete_common(a,b,c,d,e,f,g) Perl_hv_delete_common(aTHX_ a,b,c,d,e,f,g) #define hv_free_ent_ret(a,b) S_hv_free_ent_ret(aTHX_ a,b) #define hv_magic_check S_hv_magic_check #define hv_notallowed(a,b,c,d) S_hv_notallowed(aTHX_ a,b,c,d) @@ -1587,6 +1586,9 @@ #define share_hek_flags(a,b,c,d) S_share_hek_flags(aTHX_ a,b,c,d) #define unshare_hek_or_pvn(a,b,c,d) S_unshare_hek_or_pvn(aTHX_ a,b,c,d) # endif +# if defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_HV_VTBL_C) +#define hv_delete_common(a,b,c,d,e,f,g) Perl_hv_delete_common(aTHX_ a,b,c,d,e,f,g) +# endif # if defined(PERL_IN_LOCALE_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_MATHOMS_C) # if defined(USE_LOCALE_COLLATE) #define _mem_collxfrm(a,b,c,d) Perl__mem_collxfrm(aTHX_ a,b,c,d) diff --git a/hv.c b/hv.c index ab97d09624..d5f6b51dd7 100644 --- a/hv.c +++ b/hv.c @@ -229,13 +229,15 @@ hash type (thus C<newHV_type(NULL)> is equivalent to C<newHV()>. HV * Perl_newHV_type(pTHX_ HV_VTBL *type) { - /*HV *hv = newHV();*/ /* FIXME just temporary for testing: */ HV *hv = MUTABLE_HV(newSV_type(SVt_PVHV)); XPVHV *xhv = (XPVHV*)SvANY(hv); xhv->xhv_vtbl = type; + + type->hvt_init(aTHX_ hv); + return hv; } @@ -432,6 +434,10 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, return (void *)vtable->hvt_delete(hv, keysv, key, klen, flags, action, hash); } + else if (action & HV_FETCH_ISEXISTS) { + return (void *)vtable->hvt_exists(hv, keysv, key, klen, + flags, hash); + } } if (action & HV_DELETE) { diff --git a/hv.h b/hv.h index a80a135971..a7ccc6b685 100644 --- a/hv.h +++ b/hv.h @@ -655,9 +655,7 @@ Creates a new HV. The reference count is set to 1. */ /* regular newHV implementation */ -/*#define newHV() MUTABLE_HV(newSV_type(SVt_PVHV))*/ -/* FIXME just temporary for testing: newHV implementation for testing the no-op vtable logic */ -#define newHV() ({ HV *_p = newHV_type(&PL_mock_std_vtable); _p; }) +#define newHV() MUTABLE_HV(newSV_type(SVt_PVHV)) #include "hv_func.h" diff --git a/hv_vtbl.c b/hv_vtbl.c index dc6370dc1f..6266b96ccc 100644 --- a/hv_vtbl.c +++ b/hv_vtbl.c @@ -10,10 +10,24 @@ /* TODO: Insert LotR quote here. */ #include "EXTERN.h" -#define PERL_IN_HV_C +#define PERL_IN_HV_VTBL_C #define PERL_HASH_INTERNAL_ACCESS #include "perl.h" +STATIC void +S_hv_mock_std_vtable_init(pTHX_ HV *hv) +{ + PERL_UNUSED_CONTEXT; + PERL_UNUSED_ARG(hv); +} + +STATIC void +S_hv_mock_std_vtable_destroy(pTHX_ HV *hv) +{ + PERL_UNUSED_CONTEXT; + PERL_UNUSED_ARG(hv); +} + STATIC SV * S_hv_mock_std_vtable_delete(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, int key_flags, I32 delete_flags, @@ -23,7 +37,42 @@ S_hv_mock_std_vtable_delete(pTHX_ HV *hv, SV *keysv, const char *key, key_flags, delete_flags, hash); } +/* +STATIC SV ** +S_hv_mock_std_vtable_fetch(pTHX_ HV *hv, SV *keysv, const char *key, + STRLEN klen, int key_flags, + I32 is_lvalue_fetch, U32 hash) +{ + return NULL; +} +*/ + +STATIC bool +S_hv_mock_std_vtable_exists(pTHX_ HV *hv, SV *keysv, const char *key, + STRLEN klen, int key_flags, U32 hash) +{ + /* THIS IS PURELY FOR TESTING! */ + bool retval; + XPVHV* xhv = (XPVHV *)SvANY(hv); + HV_VTBL *vtable = xhv->xhv_vtbl; + ENTER; + SAVEPPTR(vtable); + xhv->xhv_vtbl = NULL; + if (keysv) + retval = hv_exists_ent(hv, keysv, hash); + else { + I32 my_klen = (key_flags & HVhek_UTF8) ? -(I32)klen : (I32)klen; + retval = hv_exists(hv, key, my_klen); + } + LEAVE; + return retval; +} + HV_VTBL PL_mock_std_vtable = { + S_hv_mock_std_vtable_init, + S_hv_mock_std_vtable_destroy, + /* S_hv_mock_std_vtable_fetch, */ + S_hv_mock_std_vtable_exists, S_hv_mock_std_vtable_delete }; diff --git a/hv_vtbl.h b/hv_vtbl.h index 18f8be3487..39558182e1 100644 --- a/hv_vtbl.h +++ b/hv_vtbl.h @@ -8,7 +8,22 @@ */ struct hv_vtbl { + /* Called when allocating a new HV of this type */ + void (*hvt_init)(pTHX_ HV *hv); + /* Called before deallocating the HV in the traditional HV implementation. */ + void (*hvt_destroy)(pTHX_ HV *hv); + + /* Implements the various forms of hv_fetch/etc */ + /* SV ** (*hvt_fetch)(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, int key_flags, I32 is_lvalue_fetch, U32 hash); */ + + /* store */ + + /* exists */ + bool (*hvt_exists)(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, int key_flags, U32 hash); + + /* Implements the various forms of hv_delete/etc */ SV * (*hvt_delete)(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, int key_flags, I32 delete_flags, U32 hash); + /* clear */ }; typedef struct hv_vtbl HV_VTBL; diff --git a/proto.h b/proto.h index ad804aa8d1..679f960070 100644 --- a/proto.h +++ b/proto.h @@ -4443,7 +4443,6 @@ STATIC struct xpvhv_aux* S_hv_auxinit(pTHX_ HV *hv); STATIC struct xpvhv_aux* S_hv_auxinit_internal(struct xpvhv_aux *iter); #define PERL_ARGS_ASSERT_HV_AUXINIT_INTERNAL \ assert(iter) -PERL_CALLCONV SV* Perl_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, int k_flags, I32 d_flags, U32 hash); STATIC SV* S_hv_free_ent_ret(pTHX_ HV *hv, HE *entry); #define PERL_ARGS_ASSERT_HV_FREE_ENT_RET \ assert(hv); assert(entry) @@ -4485,6 +4484,9 @@ PERL_CALLCONV SV* Perl_hfree_next_entry(pTHX_ HV *hv, STRLEN *indexp); #define PERL_ARGS_ASSERT_HFREE_NEXT_ENTRY \ assert(hv); assert(indexp) #endif +#if defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_HV_VTBL_C) +PERL_CALLCONV SV* Perl_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, int k_flags, I32 d_flags, U32 hash); +#endif #if defined(PERL_IN_LOCALE_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_MATHOMS_C) # if defined(USE_LOCALE_COLLATE) PERL_CALLCONV char* Perl__mem_collxfrm(pTHX_ const char* input_string, STRLEN len, STRLEN* xlen, bool utf8); diff --git a/sv.c b/sv.c index 42e34410ed..964321908b 100644 --- a/sv.c +++ b/sv.c @@ -1370,6 +1370,8 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) #endif /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */ HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX; + /* FIXME just temporary for testing: newHV implementation for testing the no-op vtable logic */ + ((XPVHV*) SvANY(sv))->xhv_vtbl = &PL_mock_std_vtable; } /* SVt_NULL isn't the only thing upgraded to AV or HV. @@ -6564,10 +6566,18 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) if (!curse(sv, 1)) goto get_next_sv; type = SvTYPE(sv); /* destructor may have changed it */ } - /* Free back-references before magic, in case the magic calls - * Perl code that has weak references to sv. */ if (type == SVt_PVHV) { + HV_VTBL *vtbl; + HV *hv = MUTABLE_HV(sv); + + /* Free back-references before magic, in case the magic calls + * Perl code that has weak references to sv. */ Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv)); + /* TODO: Before or after invoking magic on the HV? + * I think before. */ + vtbl = ( (XPVHV*)SvANY(hv) )->xhv_vtbl; + if (vtbl != NULL) + vtbl->hvt_destroy(aTHX_ hv); if (SvMAGIC(sv)) mg_free(sv); } -- Perl5 Master Repository
