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 <smuel...@cpan.org>
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 <smuel...@cpan.org>
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 <smuel...@cpan.org>
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 <smuel...@cpan.org>
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 <smuel...@cpan.org>
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
