]> git.vpit.fr Git - perl/modules/autovivification.git/blob - xsh/hints.h
Update VPIT::TestHelpers to 15e8aee3
[perl/modules/autovivification.git] / xsh / hints.h
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 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  if (val == XSH_HINTS_VAL_NONE)
269   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  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  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 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  hint_uv = xsh_hints_2uv(hint);
313  h       = INT2PTR(xsh_hints_t *, hint_uv);
314  if (!h)
315   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  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 static SV *xsh_hints_fetch(pTHX) {
356 #define xsh_hints_fetch() xsh_hints_fetch(aTHX)
357 #if XSH_HINTS_ONLY_COMPILE_TIME
358  if (IN_PERL_RUNTIME)
359   return NULL;
360 #endif
361
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);
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 */