X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FLexical-Types.git;a=blobdiff_plain;f=xsh%2Fhints.h;fp=xsh%2Fhints.h;h=458b1170f06c9655bfcae6f58918ea01ea8c891a;hp=0000000000000000000000000000000000000000;hb=30d9da627f7321ff834ee9a53ef8fb508eda2be5;hpb=12b1d673a4194d57b87cf9e5d9c0b96c9da28ba6

diff --git a/xsh/hints.h b/xsh/hints.h
new file mode 100644
index 0000000..458b117
--- /dev/null
+++ b/xsh/hints.h
@@ -0,0 +1,372 @@
+#ifndef XSH_HINTS_H
+#define XSH_HINTS_H 1
+
+#include "caps.h" /* XSH_HAS_PERL(), XSH_THREADSAFE, tTHX */
+
+#ifdef XSH_THREADS_H
+# error threads.h must be loaded at the very end
+#endif
+
+#define XSH_HINTS_KEY     XSH_PACKAGE
+#define XSH_HINTS_KEY_LEN (sizeof(XSH_HINTS_KEY)-1)
+
+#ifndef XSH_WORKAROUND_REQUIRE_PROPAGATION
+# define XSH_WORKAROUND_REQUIRE_PROPAGATION !XSH_HAS_PERL(5, 10, 1)
+#endif
+
+#ifndef XSH_HINTS_ONLY_COMPILE_TIME
+# define XSH_HINTS_ONLY_COMPILE_TIME 1
+#endif
+
+#ifdef XSH_HINTS_TYPE_UV
+# ifdef XSH_HINTS_TYPE_VAL
+#  error hint type can only be set once
+# endif
+# undef  XSH_HINTS_TYPE_UV
+# define XSH_HINTS_TYPE_UV         1
+# define XSH_HINTS_TYPE_STRUCT     UV
+# define XSH_HINTS_TYPE_COMPACT    UV
+# define XSH_HINTS_NEED_STRUCT     0
+# define XSH_HINTS_VAL_STRUCT_REF  0
+# define XSH_HINTS_VAL_NONE        0
+# define XSH_HINTS_VAL_PACK(T, V)  INT2PTR(T, (V))
+# define XSH_HINTS_VAL_UNPACK(V)   ((XSH_HINTS_TYPE_VAL) PTR2UV(V))
+# define XSH_HINTS_VAL_INIT(HV, V) ((HV) = (V))
+# undef  XSH_HINTS_VAL_CLONE
+# undef  XSH_HINTS_VAL_DEINIT
+#endif
+
+#ifdef XSH_HINTS_TYPE_SV
+# ifdef XSH_HINTS_TYPE_VAL
+#  error hint type can only be set once
+# endif
+# undef  XSH_HINTS_TYPE_SV
+# define XSH_HINTS_TYPE_SV         1
+# define XSH_HINTS_TYPE_STRUCT     SV *
+# define XSH_HINTS_TYPE_COMPACT    SV
+# define XSH_HINTS_NEED_STRUCT     0
+# define XSH_HINTS_VAL_STRUCT_REF  0
+# define XSH_HINTS_VAL_NONE        NULL
+# define XSH_HINTS_VAL_PACK(T, V)  (V)
+# define XSH_HINTS_VAL_UNPACK(V)   (V)
+# define XSH_HINTS_VAL_INIT(HV, V) ((HV) = (((V) != XSH_HINTS_VAL_NONE) ? SvREFCNT_inc(V) : XSH_HINTS_VAL_NONE))
+# define XSH_HINTS_VAL_CLONE(N, O) ((N) = xsh_dup_inc((O), ud->params))
+# define XSH_HINTS_VAL_DEINIT(V)   SvREFCNT_dec(V)
+#endif
+
+#ifdef XSH_HINTS_TYPE_USER
+# ifdef XSH_HINTS_TYPE_VAL
+#  error hint type can only be set once
+# endif
+# undef  XSH_HINTS_TYPE_USER
+# define XSH_HINTS_TYPE_USER         1
+# define XSH_HINTS_TYPE_STRUCT       xsh_hints_user_t
+# undef  XSH_HINTS_TYPE_COMPACT      /* not used */
+# define XSH_HINTS_NEED_STRUCT       1
+# define XSH_HINTS_VAL_STRUCT_REF    1
+# define XSH_HINTS_VAL_NONE          NULL
+# define XSH_HINTS_VAL_PACK(T, V)    (V)
+# define XSH_HINTS_VAL_UNPACK(V)     (V)
+# define XSH_HINTS_VAL_INIT(HV, V)   xsh_hints_user_init(aTHX_ (HV), (V))
+# define XSH_HINTS_VAL_CLONE(NV, OV) xsh_hints_user_clone(aTHX_ (NV), (OV), ud->params)
+# define XSH_HINTS_VAL_DEINIT(V)     xsh_hints_user_deinit(aTHX_ (V))
+#endif
+
+#ifndef XSH_HINTS_TYPE_STRUCT
+# error hint type was not set
+#endif
+
+#if XSH_HINTS_VAL_STRUCT_REF
+# define XSH_HINTS_TYPE_VAL XSH_HINTS_TYPE_STRUCT *
+#else
+# define XSH_HINTS_TYPE_VAL XSH_HINTS_TYPE_STRUCT
+#endif
+
+#if XSH_WORKAROUND_REQUIRE_PROPAGATION
+# undef  XSH_HINTS_NEED_STRUCT
+# define XSH_HINTS_NEED_STRUCT 1
+#endif
+
+#if XSH_THREADSAFE && (defined(XSH_HINTS_VAL_CLONE) || XSH_WORKAROUND_REQUIRE_PROPAGATION)
+# define XSH_HINTS_NEED_CLONE 1
+#else
+# define XSH_HINTS_NEED_CLONE 0
+#endif
+
+#if XSH_WORKAROUND_REQUIRE_PROPAGATION
+
+static UV xsh_require_tag(pTHX) {
+#define xsh_require_tag() xsh_require_tag(aTHX)
+ const CV *cv, *outside;
+
+ cv = PL_compcv;
+
+ if (!cv) {
+  /* If for some reason the pragma is operational at run-time, try to discover
+   * the current cv in use. */
+  const PERL_SI *si;
+
+  for (si = PL_curstackinfo; si; si = si->si_prev) {
+   I32 cxix;
+
+   for (cxix = si->si_cxix; cxix >= 0; --cxix) {
+    const PERL_CONTEXT *cx = si->si_cxstack + cxix;
+
+    switch (CxTYPE(cx)) {
+     case CXt_SUB:
+     case CXt_FORMAT:
+      /* The propagation workaround is only needed up to 5.10.0 and at that
+       * time format and sub contexts were still identical. And even later the
+       * cv members offsets should have been kept the same. */
+      cv = cx->blk_sub.cv;
+      goto get_enclosing_cv;
+     case CXt_EVAL:
+      cv = cx->blk_eval.cv;
+      goto get_enclosing_cv;
+     default:
+      break;
+    }
+   }
+  }
+
+  cv = PL_main_cv;
+ }
+
+get_enclosing_cv:
+ for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
+  cv = outside;
+
+ return PTR2UV(cv);
+}
+
+#endif /* XSH_WORKAROUND_REQUIRE_PROPAGATION */
+
+#if XSH_HINTS_NEED_STRUCT
+
+typedef struct {
+ XSH_HINTS_TYPE_STRUCT val;
+#if XSH_WORKAROUND_REQUIRE_PROPAGATION
+ UV                    require_tag;
+#endif
+} xsh_hints_t;
+
+#if XSH_HINTS_VAL_STRUCT_REF
+# define XSH_HINTS_VAL_GET(H) (&(H)->val)
+#else
+# define XSH_HINTS_VAL_GET(H) ((H)->val)
+#endif
+
+#define XSH_HINTS_VAL_SET(H, V) XSH_HINTS_VAL_INIT(XSH_HINTS_VAL_GET(H), (V))
+
+#ifdef XSH_HINTS_VAL_DEINIT
+# define XSH_HINTS_FREE(H) \
+   if (H) XSH_HINTS_VAL_DEINIT(XSH_HINTS_VAL_GET(H)); \
+   PerlMemShared_free(H)
+#else
+# define XSH_HINTS_FREE(H) PerlMemShared_free(H)
+#endif
+
+#else  /*  XSH_HINTS_NEED_STRUCT */
+
+typedef XSH_HINTS_TYPE_COMPACT xsh_hints_t;
+
+#define XSH_HINTS_VAL_GET(H)    XSH_HINTS_VAL_UNPACK(H)
+#define XSH_HINTS_VAL_SET(H, V) STMT_START { XSH_HINTS_TYPE_VAL tmp; XSH_HINTS_VAL_INIT(tmp, (V)); (H) = XSH_HINTS_VAL_PACK(xsh_hints_t *, tmp); } STMT_END
+
+#undef XSH_HINTS_FREE
+
+#endif /* !XSH_HINTS_NEED_STRUCT */
+
+/* ... Thread safety ....................................................... */
+
+#if XSH_HINTS_NEED_CLONE
+
+#ifdef XSH_HINTS_FREE
+# define PTABLE_NAME        ptable_hints
+# define PTABLE_VAL_FREE(V) XSH_HINTS_FREE((xsh_hints_t *) (V))
+#else
+# define PTABLE_USE_DEFAULT 1
+#endif
+
+#define PTABLE_NEED_WALK    1
+#define PTABLE_NEED_DELETE  0
+
+#include "ptable.h"
+
+#if PTABLE_WAS_DEFAULT
+# define ptable_hints_store(T, K, V) ptable_default_store(aPTBL_ (T), (K), (V))
+# define ptable_hints_free(T)        ptable_default_free(aPTBL_ (T))
+#else
+# define ptable_hints_store(T, K, V) ptable_hints_store(aPTBL_ (T), (K), (V))
+# define ptable_hints_free(T)        ptable_hints_free(aPTBL_ (T))
+#endif
+
+#define XSH_THREADS_HINTS_CONTEXT 1
+
+typedef struct {
+ ptable *tbl; /* It really is a ptable_hints */
+ tTHX    owner;
+} xsh_hints_cxt_t;
+
+static xsh_hints_cxt_t *xsh_hints_get_cxt(pTHX);
+
+static void xsh_hints_local_setup(pTHX_ xsh_hints_cxt_t *cxt) {
+ cxt->tbl   = ptable_new(4);
+ cxt->owner = aTHX;
+}
+
+static void xsh_hints_local_teardown(pTHX_ xsh_hints_cxt_t *cxt) {
+ ptable_hints_free(cxt->tbl);
+ cxt->owner = NULL;
+}
+
+typedef struct {
+ ptable       *tbl; /* It really is a ptable_hints */
+ CLONE_PARAMS *params;
+} xsh_ptable_clone_ud;
+
+static void xsh_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
+ xsh_ptable_clone_ud *ud = ud_;
+ xsh_hints_t         *h1 = ent->val;
+ xsh_hints_t         *h2;
+
+#if XSH_HINTS_NEED_STRUCT
+ h2              = PerlMemShared_malloc(sizeof *h2);
+# if XSH_WORKAROUND_REQUIRE_PROPAGATION
+ h2->require_tag = PTR2UV(xsh_dup_inc(INT2PTR(SV *, h1->require_tag), ud->params));
+# endif
+#endif  /*  XSH_HINTS_NEED_STRUCT */
+
+#ifdef XSH_HINTS_VAL_CLONE
+ XSH_HINTS_VAL_CLONE(XSH_HINTS_VAL_GET(h2), XSH_HINTS_VAL_GET(h1));
+#endif /* defined(XSH_HINTS_VAL_CLONE) */
+
+ ptable_hints_store(ud->tbl, ent->key, h2);
+}
+
+static void xsh_hints_clone(pTHX_ const xsh_hints_cxt_t *old_cxt, xsh_hints_cxt_t *new_cxt, CLONE_PARAMS *params) {
+ xsh_ptable_clone_ud ud;
+
+ new_cxt->tbl   = ptable_new(4);
+ new_cxt->owner = aTHX;
+
+ ud.tbl    = new_cxt->tbl;
+ ud.params = params;
+
+ ptable_walk(old_cxt->tbl, xsh_ptable_clone, &ud);
+}
+
+#endif /* XSH_HINTS_NEED_CLONE */
+
+/* ... tag hints ........................................................... */
+
+static SV *xsh_hints_tag(pTHX_ XSH_HINTS_TYPE_VAL val) {
+#define xsh_hints_tag(V) xsh_hints_tag(aTHX_ (V))
+ xsh_hints_t *h;
+
+ if (val == XSH_HINTS_VAL_NONE)
+  return newSVuv(0);
+
+#if XSH_HINTS_NEED_STRUCT
+ h              = PerlMemShared_malloc(sizeof *h);
+# if XSH_WORKAROUND_REQUIRE_PROPAGATION
+ h->require_tag = xsh_require_tag();
+# endif
+#endif /* XSH_HINTS_NEED_STRUCT */
+
+ XSH_HINTS_VAL_SET(h, val);
+
+#if XSH_HINTS_NEED_CLONE
+ /* We only need for the key to be an unique tag for looking up the value later
+  * Allocated memory provides convenient unique identifiers, so that's why we
+  * use the hint as the key itself. */
+ {
+  xsh_hints_cxt_t *cxt = xsh_hints_get_cxt(aTHX);
+  XSH_ASSERT(cxt->tbl);
+  ptable_hints_store(cxt->tbl, h, h);
+ }
+#endif /* !XSH_HINTS_NEED_CLONE */
+
+ return newSVuv(PTR2UV(h));
+}
+
+/* ... detag hints ......................................................... */
+
+#define xsh_hints_2uv(H) \
+    ((H) \
+     ? (SvIOK(H) \
+        ? SvUVX(H) \
+        : (SvPOK(H) \
+           ? sv_2uv(SvLEN(H) ? (H) : sv_mortalcopy(H)) \
+           : 0 \
+          ) \
+       ) \
+     : 0)
+
+static XSH_HINTS_TYPE_VAL xsh_hints_detag(pTHX_ SV *hint) {
+#define xsh_hints_detag(H) xsh_hints_detag(aTHX_ (H))
+ xsh_hints_t *h;
+ UV           hint_uv;
+
+ hint_uv = xsh_hints_2uv(hint);
+ h       = INT2PTR(xsh_hints_t *, hint_uv);
+ if (!h)
+  return XSH_HINTS_VAL_NONE;
+
+#if XSH_HINTS_NEED_CLONE
+ {
+  xsh_hints_cxt_t *cxt = xsh_hints_get_cxt(aTHX);
+  XSH_ASSERT(cxt->tbl);
+  h = ptable_fetch(cxt->tbl, h);
+ }
+#endif /* XSH_HINTS_NEED_CLONE */
+
+#if XSH_WORKAROUND_REQUIRE_PROPAGATION
+ if (xsh_require_tag() != h->require_tag)
+  return XSH_HINTS_VAL_NONE;
+#endif
+
+ return XSH_HINTS_VAL_GET(h);
+}
+
+/* ... fetch hints ......................................................... */
+
+#if !defined(cop_hints_fetch_pvn) && XSH_HAS_PERL(5, 9, 5)
+# define cop_hints_fetch_pvn(COP, PKG, PKGLEN, PKGHASH, FLAGS) \
+   Perl_refcounted_he_fetch(aTHX_ (COP)->cop_hints_hash, NULL, \
+                                  (PKG), (PKGLEN), (FLAGS), (PKGHASH))
+#endif
+
+#ifdef cop_hints_fetch_pvn
+
+static U32 xsh_hints_key_hash = 0;
+# define xsh_hints_global_setup(my_perl) \
+         PERL_HASH(xsh_hints_key_hash, XSH_HINTS_KEY, XSH_HINTS_KEY_LEN)
+
+#else /* defined(cop_hints_fetch_pvn) */
+
+# define xsh_hints_global_setup(my_perl)
+
+#endif /* !defined(cop_hints_fetch_pvn) */
+
+#define xsh_hints_global_teardown(my_perl)
+
+static SV *xsh_hints_fetch(pTHX) {
+#define xsh_hints_fetch() xsh_hints_fetch(aTHX)
+#if XSH_HINTS_ONLY_COMPILE_TIME
+ if (IN_PERL_RUNTIME)
+  return NULL;
+#endif
+
+#ifdef cop_hints_fetch_pvn
+ return cop_hints_fetch_pvn(PL_curcop, XSH_HINTS_KEY, XSH_HINTS_KEY_LEN,
+                                       xsh_hints_key_hash, 0);
+#else
+ {
+  SV **val = hv_fetch(GvHV(PL_hintgv), XSH_HINTS_KEY, XSH_HINTS_KEY_LEN, 0);
+  return val ? *val : NULL;
+ }
+#endif
+}
+
+#endif /* XSH_HINTS_H */