4 #include "caps.h" /* XSH_HAS_PERL(), XSH_THREADSAFE, tTHX */
5 #include "mem.h" /* XSH_SHARED_*() */
8 # error threads.h must be loaded at the very end
11 #define XSH_HINTS_KEY XSH_PACKAGE
12 #define XSH_HINTS_KEY_LEN (sizeof(XSH_HINTS_KEY)-1)
14 #ifndef XSH_WORKAROUND_REQUIRE_PROPAGATION
15 # define XSH_WORKAROUND_REQUIRE_PROPAGATION !XSH_HAS_PERL(5, 10, 1)
18 #ifndef XSH_HINTS_ONLY_COMPILE_TIME
19 # define XSH_HINTS_ONLY_COMPILE_TIME 1
22 #ifdef XSH_HINTS_TYPE_UV
23 # ifdef XSH_HINTS_TYPE_VAL
24 # error hint type can only be set once
26 # undef XSH_HINTS_TYPE_UV
27 # define XSH_HINTS_TYPE_UV 1
28 # define XSH_HINTS_TYPE_STRUCT UV
29 # define XSH_HINTS_TYPE_COMPACT UV
30 # define XSH_HINTS_NEED_STRUCT 0
31 # define XSH_HINTS_VAL_STRUCT_REF 0
32 # define XSH_HINTS_VAL_NONE 0
33 # define XSH_HINTS_VAL_PACK(T, V) INT2PTR(T, (V))
34 # define XSH_HINTS_VAL_UNPACK(V) ((XSH_HINTS_TYPE_VAL) PTR2UV(V))
35 # define XSH_HINTS_VAL_INIT(HV, V) ((HV) = (V))
36 # undef XSH_HINTS_VAL_CLONE
37 # undef XSH_HINTS_VAL_DEINIT
40 #ifdef XSH_HINTS_TYPE_SV
41 # ifdef XSH_HINTS_TYPE_VAL
42 # error hint type can only be set once
44 # undef XSH_HINTS_TYPE_SV
45 # define XSH_HINTS_TYPE_SV 1
46 # define XSH_HINTS_TYPE_STRUCT SV *
47 # define XSH_HINTS_TYPE_COMPACT SV
48 # define XSH_HINTS_NEED_STRUCT 0
49 # define XSH_HINTS_VAL_STRUCT_REF 0
50 # define XSH_HINTS_VAL_NONE NULL
51 # define XSH_HINTS_VAL_PACK(T, V) (V)
52 # define XSH_HINTS_VAL_UNPACK(V) (V)
53 # define XSH_HINTS_VAL_INIT(HV, V) ((HV) = (((V) != XSH_HINTS_VAL_NONE) ? SvREFCNT_inc(V) : XSH_HINTS_VAL_NONE))
54 # define XSH_HINTS_VAL_CLONE(N, O) ((N) = xsh_dup_inc((O), ud->params))
55 # define XSH_HINTS_VAL_DEINIT(V) SvREFCNT_dec(V)
58 #ifdef XSH_HINTS_TYPE_USER
59 # ifdef XSH_HINTS_TYPE_VAL
60 # error hint type can only be set once
62 # undef XSH_HINTS_TYPE_USER
63 # define XSH_HINTS_TYPE_USER 1
64 # define XSH_HINTS_TYPE_STRUCT xsh_hints_user_t
65 # undef XSH_HINTS_TYPE_COMPACT /* not used */
66 # define XSH_HINTS_NEED_STRUCT 1
67 # define XSH_HINTS_VAL_STRUCT_REF 1
68 # define XSH_HINTS_VAL_NONE NULL
69 # define XSH_HINTS_VAL_PACK(T, V) (V)
70 # define XSH_HINTS_VAL_UNPACK(V) (V)
71 # define XSH_HINTS_VAL_INIT(HV, V) xsh_hints_user_init(aTHX_ (HV), (V))
72 # define XSH_HINTS_VAL_CLONE(NV, OV) xsh_hints_user_clone(aTHX_ (NV), (OV), ud->params)
73 # define XSH_HINTS_VAL_DEINIT(V) xsh_hints_user_deinit(aTHX_ (V))
76 #ifndef XSH_HINTS_TYPE_STRUCT
77 # error hint type was not set
80 #if XSH_HINTS_VAL_STRUCT_REF
81 # define XSH_HINTS_TYPE_VAL XSH_HINTS_TYPE_STRUCT *
83 # define XSH_HINTS_TYPE_VAL XSH_HINTS_TYPE_STRUCT
86 #if XSH_WORKAROUND_REQUIRE_PROPAGATION
87 # undef XSH_HINTS_NEED_STRUCT
88 # define XSH_HINTS_NEED_STRUCT 1
91 #if XSH_THREADSAFE && (defined(XSH_HINTS_VAL_CLONE) || XSH_WORKAROUND_REQUIRE_PROPAGATION)
92 # define XSH_HINTS_NEED_CLONE 1
94 # define XSH_HINTS_NEED_CLONE 0
97 #if XSH_WORKAROUND_REQUIRE_PROPAGATION
99 static UV xsh_require_tag(pTHX) {
100 #define xsh_require_tag() xsh_require_tag(aTHX)
101 const CV *cv, *outside;
106 /* If for some reason the pragma is operational at run-time, try to discover
107 * the current cv in use. */
110 for (si = PL_curstackinfo; si; si = si->si_prev) {
113 for (cxix = si->si_cxix; cxix >= 0; --cxix) {
114 const PERL_CONTEXT *cx = si->si_cxstack + cxix;
116 switch (CxTYPE(cx)) {
119 /* The propagation workaround is only needed up to 5.10.0 and at that
120 * time format and sub contexts were still identical. And even later the
121 * cv members offsets should have been kept the same. */
123 goto get_enclosing_cv;
125 cv = cx->blk_eval.cv;
126 goto get_enclosing_cv;
137 for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
143 #endif /* XSH_WORKAROUND_REQUIRE_PROPAGATION */
145 #if XSH_HINTS_NEED_STRUCT
148 XSH_HINTS_TYPE_STRUCT val;
149 #if XSH_WORKAROUND_REQUIRE_PROPAGATION
154 #if XSH_HINTS_VAL_STRUCT_REF
155 # define XSH_HINTS_VAL_GET(H) (&(H)->val)
157 # define XSH_HINTS_VAL_GET(H) ((H)->val)
160 #define XSH_HINTS_VAL_SET(H, V) XSH_HINTS_VAL_INIT(XSH_HINTS_VAL_GET(H), (V))
162 #ifdef XSH_HINTS_VAL_DEINIT
163 # define XSH_HINTS_FREE(H) \
164 if (H) XSH_HINTS_VAL_DEINIT(XSH_HINTS_VAL_GET(((xsh_hints_t *) (H)))); \
165 XSH_SHARED_FREE((H), 1, xsh_hints_t)
167 # define XSH_HINTS_FREE(H) XSH_SHARED_FREE((H), 1, xsh_hints_t)
170 #else /* XSH_HINTS_NEED_STRUCT */
172 typedef XSH_HINTS_TYPE_COMPACT xsh_hints_t;
174 #define XSH_HINTS_VAL_GET(H) XSH_HINTS_VAL_UNPACK(H)
175 #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
177 #undef XSH_HINTS_FREE
179 #endif /* !XSH_HINTS_NEED_STRUCT */
181 /* ... Thread safety ....................................................... */
183 #if XSH_HINTS_NEED_CLONE
185 #ifdef XSH_HINTS_FREE
186 # define PTABLE_NAME ptable_hints
187 # define PTABLE_VAL_FREE(V) XSH_HINTS_FREE(V)
189 # define PTABLE_USE_DEFAULT 1
192 #define PTABLE_NEED_WALK 1
193 #define PTABLE_NEED_DELETE 0
197 #if PTABLE_WAS_DEFAULT
198 # define ptable_hints_store(T, K, V) ptable_default_store(aPTBL_ (T), (K), (V))
199 # define ptable_hints_free(T) ptable_default_free(aPTBL_ (T))
201 # define ptable_hints_store(T, K, V) ptable_hints_store(aPTBL_ (T), (K), (V))
202 # define ptable_hints_free(T) ptable_hints_free(aPTBL_ (T))
205 #define XSH_THREADS_HINTS_CONTEXT 1
208 ptable *tbl; /* It really is a ptable_hints */
212 static xsh_hints_cxt_t *xsh_hints_get_cxt(pTHX);
214 static void xsh_hints_local_setup(pTHX_ xsh_hints_cxt_t *cxt) {
215 cxt->tbl = ptable_new(4);
219 static void xsh_hints_local_teardown(pTHX_ xsh_hints_cxt_t *cxt) {
220 ptable_hints_free(cxt->tbl);
225 ptable *tbl; /* It really is a ptable_hints */
226 CLONE_PARAMS *params;
227 } xsh_ptable_clone_ud;
229 static void xsh_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
230 xsh_ptable_clone_ud *ud = ud_;
231 xsh_hints_t *h1 = ent->val;
234 #if XSH_HINTS_NEED_STRUCT
235 XSH_SHARED_ALLOC(h2, 1, xsh_hints_t);
236 # if XSH_WORKAROUND_REQUIRE_PROPAGATION
237 h2->require_tag = PTR2UV(xsh_dup_inc(INT2PTR(SV *, h1->require_tag), ud->params));
239 #endif /* XSH_HINTS_NEED_STRUCT */
241 #ifdef XSH_HINTS_VAL_CLONE
242 XSH_HINTS_VAL_CLONE(XSH_HINTS_VAL_GET(h2), XSH_HINTS_VAL_GET(h1));
243 #endif /* defined(XSH_HINTS_VAL_CLONE) */
245 ptable_hints_store(ud->tbl, ent->key, h2);
248 static void xsh_hints_clone(pTHX_ const xsh_hints_cxt_t *old_cxt, xsh_hints_cxt_t *new_cxt, CLONE_PARAMS *params) {
249 xsh_ptable_clone_ud ud;
251 new_cxt->tbl = ptable_new(4);
252 new_cxt->owner = aTHX;
254 ud.tbl = new_cxt->tbl;
257 ptable_walk(old_cxt->tbl, xsh_ptable_clone, &ud);
260 #endif /* XSH_HINTS_NEED_CLONE */
262 /* ... tag hints ........................................................... */
264 static SV *xsh_hints_tag(pTHX_ XSH_HINTS_TYPE_VAL val) {
265 #define xsh_hints_tag(V) xsh_hints_tag(aTHX_ (V))
268 if (val == XSH_HINTS_VAL_NONE)
271 #if XSH_HINTS_NEED_STRUCT
272 XSH_SHARED_ALLOC(h, 1, xsh_hints_t);
273 # if XSH_WORKAROUND_REQUIRE_PROPAGATION
274 h->require_tag = xsh_require_tag();
276 #endif /* XSH_HINTS_NEED_STRUCT */
278 XSH_HINTS_VAL_SET(h, val);
280 #if XSH_HINTS_NEED_CLONE
281 /* We only need for the key to be an unique tag for looking up the value later
282 * Allocated memory provides convenient unique identifiers, so that's why we
283 * use the hint as the key itself. */
285 xsh_hints_cxt_t *cxt = xsh_hints_get_cxt(aTHX);
286 XSH_ASSERT(cxt->tbl);
287 ptable_hints_store(cxt->tbl, h, h);
289 #endif /* !XSH_HINTS_NEED_CLONE */
291 return newSVuv(PTR2UV(h));
294 /* ... detag hints ......................................................... */
296 #define xsh_hints_2uv(H) \
301 ? sv_2uv(SvLEN(H) ? (H) : sv_mortalcopy(H)) \
307 static XSH_HINTS_TYPE_VAL xsh_hints_detag(pTHX_ SV *hint) {
308 #define xsh_hints_detag(H) xsh_hints_detag(aTHX_ (H))
312 hint_uv = xsh_hints_2uv(hint);
313 h = INT2PTR(xsh_hints_t *, hint_uv);
315 return XSH_HINTS_VAL_NONE;
317 #if XSH_HINTS_NEED_CLONE
319 xsh_hints_cxt_t *cxt = xsh_hints_get_cxt(aTHX);
320 XSH_ASSERT(cxt->tbl);
321 h = ptable_fetch(cxt->tbl, h);
323 #endif /* XSH_HINTS_NEED_CLONE */
325 #if XSH_WORKAROUND_REQUIRE_PROPAGATION
326 if (xsh_require_tag() != h->require_tag)
327 return XSH_HINTS_VAL_NONE;
330 return XSH_HINTS_VAL_GET(h);
333 /* ... fetch hints ......................................................... */
335 #if !defined(cop_hints_fetch_pvn) && XSH_HAS_PERL(5, 9, 5)
336 # define cop_hints_fetch_pvn(COP, PKG, PKGLEN, PKGHASH, FLAGS) \
337 Perl_refcounted_he_fetch(aTHX_ (COP)->cop_hints_hash, NULL, \
338 (PKG), (PKGLEN), (FLAGS), (PKGHASH))
341 #ifdef cop_hints_fetch_pvn
343 static U32 xsh_hints_key_hash = 0;
344 # define xsh_hints_global_setup(my_perl) \
345 PERL_HASH(xsh_hints_key_hash, XSH_HINTS_KEY, XSH_HINTS_KEY_LEN)
347 #else /* defined(cop_hints_fetch_pvn) */
349 # define xsh_hints_global_setup(my_perl)
351 #endif /* !defined(cop_hints_fetch_pvn) */
353 #define xsh_hints_global_teardown(my_perl)
355 static SV *xsh_hints_fetch(pTHX) {
356 #define xsh_hints_fetch() xsh_hints_fetch(aTHX)
357 #if XSH_HINTS_ONLY_COMPILE_TIME
362 #ifdef cop_hints_fetch_pvn
363 return cop_hints_fetch_pvn(PL_curcop, XSH_HINTS_KEY, XSH_HINTS_KEY_LEN,
364 xsh_hints_key_hash, 0);
367 SV **val = hv_fetch(GvHV(PL_hintgv), XSH_HINTS_KEY, XSH_HINTS_KEY_LEN, 0);
368 return val ? *val : NULL;
373 #endif /* XSH_HINTS_H */