File Coverage

xsh/hints.h
Criterion Covered Total %
statement 13 15 86.6
branch 9 16 56.2
condition n/a
subroutine n/a
pod n/a
total 22 31 70.9


line stmt bran cond sub pod time code
1             #ifndef XSH_HINTS_H
2             #define XSH_HINTS_H 1
3              
4             #include "caps.h" /* XSH_HAS_PERL(), XSH_THREADSAFE, tTHX */
5             #include "mem.h" /* XSH_SHARED_*() */
6              
7             #ifdef XSH_THREADS_H
8             # error threads.h must be loaded at the very end
9             #endif
10              
11             #define XSH_HINTS_KEY XSH_PACKAGE
12             #define XSH_HINTS_KEY_LEN (sizeof(XSH_HINTS_KEY)-1)
13              
14             #ifndef XSH_WORKAROUND_REQUIRE_PROPAGATION
15             # define XSH_WORKAROUND_REQUIRE_PROPAGATION !XSH_HAS_PERL(5, 10, 1)
16             #endif
17              
18             #ifndef XSH_HINTS_ONLY_COMPILE_TIME
19             # define XSH_HINTS_ONLY_COMPILE_TIME 1
20             #endif
21              
22             #ifdef XSH_HINTS_TYPE_UV
23             # ifdef XSH_HINTS_TYPE_VAL
24             # error hint type can only be set once
25             # endif
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
38             #endif
39              
40             #ifdef XSH_HINTS_TYPE_SV
41             # ifdef XSH_HINTS_TYPE_VAL
42             # error hint type can only be set once
43             # endif
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)
56             #endif
57              
58             #ifdef XSH_HINTS_TYPE_USER
59             # ifdef XSH_HINTS_TYPE_VAL
60             # error hint type can only be set once
61             # endif
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))
74             #endif
75              
76             #ifndef XSH_HINTS_TYPE_STRUCT
77             # error hint type was not set
78             #endif
79              
80             #if XSH_HINTS_VAL_STRUCT_REF
81             # define XSH_HINTS_TYPE_VAL XSH_HINTS_TYPE_STRUCT *
82             #else
83             # define XSH_HINTS_TYPE_VAL XSH_HINTS_TYPE_STRUCT
84             #endif
85              
86             #if XSH_WORKAROUND_REQUIRE_PROPAGATION
87             # undef XSH_HINTS_NEED_STRUCT
88             # define XSH_HINTS_NEED_STRUCT 1
89             #endif
90              
91             #if XSH_THREADSAFE && (defined(XSH_HINTS_VAL_CLONE) || XSH_WORKAROUND_REQUIRE_PROPAGATION)
92             # define XSH_HINTS_NEED_CLONE 1
93             #else
94             # define XSH_HINTS_NEED_CLONE 0
95             #endif
96              
97             #if XSH_WORKAROUND_REQUIRE_PROPAGATION
98              
99             static UV xsh_require_tag(pTHX) {
100             #define xsh_require_tag() xsh_require_tag(aTHX)
101             const CV *cv, *outside;
102              
103             cv = PL_compcv;
104              
105             if (!cv) {
106             /* If for some reason the pragma is operational at run-time, try to discover
107             * the current cv in use. */
108             const PERL_SI *si;
109              
110             for (si = PL_curstackinfo; si; si = si->si_prev) {
111             I32 cxix;
112              
113             for (cxix = si->si_cxix; cxix >= 0; --cxix) {
114             const PERL_CONTEXT *cx = si->si_cxstack + cxix;
115              
116             switch (CxTYPE(cx)) {
117             case CXt_SUB:
118             case CXt_FORMAT:
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. */
122             cv = cx->blk_sub.cv;
123             goto get_enclosing_cv;
124             case CXt_EVAL:
125             cv = cx->blk_eval.cv;
126             goto get_enclosing_cv;
127             default:
128             break;
129             }
130             }
131             }
132              
133             cv = PL_main_cv;
134             }
135              
136             get_enclosing_cv:
137             for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
138             cv = outside;
139              
140             return PTR2UV(cv);
141             }
142              
143             #endif /* XSH_WORKAROUND_REQUIRE_PROPAGATION */
144              
145             #if XSH_HINTS_NEED_STRUCT
146              
147             typedef struct {
148             XSH_HINTS_TYPE_STRUCT val;
149             #if XSH_WORKAROUND_REQUIRE_PROPAGATION
150             UV require_tag;
151             #endif
152             } xsh_hints_t;
153              
154             #if XSH_HINTS_VAL_STRUCT_REF
155             # define XSH_HINTS_VAL_GET(H) (&(H)->val)
156             #else
157             # define XSH_HINTS_VAL_GET(H) ((H)->val)
158             #endif
159              
160             #define XSH_HINTS_VAL_SET(H, V) XSH_HINTS_VAL_INIT(XSH_HINTS_VAL_GET(H), (V))
161              
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)
166             #else
167             # define XSH_HINTS_FREE(H) XSH_SHARED_FREE((H), 1, xsh_hints_t)
168             #endif
169              
170             #else /* XSH_HINTS_NEED_STRUCT */
171              
172             typedef XSH_HINTS_TYPE_COMPACT xsh_hints_t;
173              
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
176              
177             #undef XSH_HINTS_FREE
178              
179             #endif /* !XSH_HINTS_NEED_STRUCT */
180              
181             /* ... Thread safety ....................................................... */
182              
183             #if XSH_HINTS_NEED_CLONE
184              
185             #ifdef XSH_HINTS_FREE
186             # define PTABLE_NAME ptable_hints
187             # define PTABLE_VAL_FREE(V) XSH_HINTS_FREE(V)
188             #else
189             # define PTABLE_USE_DEFAULT 1
190             #endif
191              
192             #define PTABLE_NEED_WALK 1
193             #define PTABLE_NEED_DELETE 0
194              
195             #include "ptable.h"
196              
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))
200             #else
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))
203             #endif
204              
205             #define XSH_THREADS_HINTS_CONTEXT 1
206              
207             typedef struct {
208             ptable *tbl; /* It really is a ptable_hints */
209             tTHX owner;
210             } xsh_hints_cxt_t;
211              
212             static xsh_hints_cxt_t *xsh_hints_get_cxt(pTHX);
213              
214             static void xsh_hints_local_setup(pTHX_ xsh_hints_cxt_t *cxt) {
215             cxt->tbl = ptable_new(4);
216             cxt->owner = aTHX;
217             }
218              
219             static void xsh_hints_local_teardown(pTHX_ xsh_hints_cxt_t *cxt) {
220             ptable_hints_free(cxt->tbl);
221             cxt->owner = NULL;
222             }
223              
224             typedef struct {
225             ptable *tbl; /* It really is a ptable_hints */
226             CLONE_PARAMS *params;
227             } xsh_ptable_clone_ud;
228              
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;
232             xsh_hints_t *h2;
233              
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));
238             # endif
239             #endif /* XSH_HINTS_NEED_STRUCT */
240              
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) */
244              
245             ptable_hints_store(ud->tbl, ent->key, h2);
246             }
247              
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;
250              
251             new_cxt->tbl = ptable_new(4);
252             new_cxt->owner = aTHX;
253              
254             ud.tbl = new_cxt->tbl;
255             ud.params = params;
256              
257             ptable_walk(old_cxt->tbl, xsh_ptable_clone, &ud);
258             }
259              
260             #endif /* XSH_HINTS_NEED_CLONE */
261              
262             /* ... tag hints ........................................................... */
263              
264 1039           static SV *xsh_hints_tag(pTHX_ XSH_HINTS_TYPE_VAL val) {
265             #define xsh_hints_tag(V) xsh_hints_tag(aTHX_ (V))
266             xsh_hints_t *h;
267              
268 1039 50         if (val == XSH_HINTS_VAL_NONE)
269 0           return newSVuv(0);
270              
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();
275             # endif
276             #endif /* XSH_HINTS_NEED_STRUCT */
277              
278 1039 50         XSH_HINTS_VAL_SET(h, val);
279              
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. */
284             {
285             xsh_hints_cxt_t *cxt = xsh_hints_get_cxt(aTHX);
286             XSH_ASSERT(cxt->tbl);
287             ptable_hints_store(cxt->tbl, h, h);
288             }
289             #endif /* !XSH_HINTS_NEED_CLONE */
290              
291 1039           return newSVuv(PTR2UV(h));
292             }
293              
294             /* ... detag hints ......................................................... */
295              
296             #define xsh_hints_2uv(H) \
297             ((H) \
298             ? (SvIOK(H) \
299             ? SvUVX(H) \
300             : (SvPOK(H) \
301             ? sv_2uv(SvLEN(H) ? (H) : sv_mortalcopy(H)) \
302             : 0 \
303             ) \
304             ) \
305             : 0)
306              
307 1112           static XSH_HINTS_TYPE_VAL xsh_hints_detag(pTHX_ SV *hint) {
308             #define xsh_hints_detag(H) xsh_hints_detag(aTHX_ (H))
309             xsh_hints_t *h;
310             UV hint_uv;
311              
312 1112 50         hint_uv = xsh_hints_2uv(hint);
    100          
    50          
    0          
313 1112           h = INT2PTR(xsh_hints_t *, hint_uv);
314 1112 100         if (!h)
315 9           return XSH_HINTS_VAL_NONE;
316              
317             #if XSH_HINTS_NEED_CLONE
318             {
319             xsh_hints_cxt_t *cxt = xsh_hints_get_cxt(aTHX);
320             XSH_ASSERT(cxt->tbl);
321             h = ptable_fetch(cxt->tbl, h);
322             }
323             #endif /* XSH_HINTS_NEED_CLONE */
324              
325             #if XSH_WORKAROUND_REQUIRE_PROPAGATION
326             if (xsh_require_tag() != h->require_tag)
327             return XSH_HINTS_VAL_NONE;
328             #endif
329              
330 1103           return XSH_HINTS_VAL_GET(h);
331             }
332              
333             /* ... fetch hints ......................................................... */
334              
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))
339             #endif
340              
341             #ifdef cop_hints_fetch_pvn
342              
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)
346              
347             #else /* defined(cop_hints_fetch_pvn) */
348              
349             # define xsh_hints_global_setup(my_perl)
350              
351             #endif /* !defined(cop_hints_fetch_pvn) */
352              
353             #define xsh_hints_global_teardown(my_perl)
354              
355 1112           static SV *xsh_hints_fetch(pTHX) {
356             #define xsh_hints_fetch() xsh_hints_fetch(aTHX)
357             #if XSH_HINTS_ONLY_COMPILE_TIME
358 1112 50         if (IN_PERL_RUNTIME)
359 0           return NULL;
360             #endif
361              
362             #ifdef cop_hints_fetch_pvn
363 1112           return cop_hints_fetch_pvn(PL_curcop, XSH_HINTS_KEY, XSH_HINTS_KEY_LEN,
364             xsh_hints_key_hash, 0);
365             #else
366             {
367             SV **val = hv_fetch(GvHV(PL_hintgv), XSH_HINTS_KEY, XSH_HINTS_KEY_LEN, 0);
368             return val ? *val : NULL;
369             }
370             #endif
371             }
372              
373             #endif /* XSH_HINTS_H */