]> git.vpit.fr Git - perl/modules/re-engine-Plugin.git/blob - xsh/hints.h
A few more declarations adjustments
[perl/modules/re-engine-Plugin.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
6 #ifdef XSH_THREADS_H
7 # error threads.h must be loaded at the very end
8 #endif
9
10 #define XSH_HINTS_KEY     XSH_PACKAGE
11 #define XSH_HINTS_KEY_LEN (sizeof(XSH_HINTS_KEY)-1)
12
13 #ifndef XSH_WORKAROUND_REQUIRE_PROPAGATION
14 # define XSH_WORKAROUND_REQUIRE_PROPAGATION !XSH_HAS_PERL(5, 10, 1)
15 #endif
16
17 #ifndef XSH_HINTS_ONLY_COMPILE_TIME
18 # define XSH_HINTS_ONLY_COMPILE_TIME 1
19 #endif
20
21 #ifdef XSH_HINTS_TYPE_UV
22 # ifdef XSH_HINTS_TYPE_VAL
23 #  error hint type can only be set once
24 # endif
25 # undef  XSH_HINTS_TYPE_UV
26 # define XSH_HINTS_TYPE_UV         1
27 # define XSH_HINTS_TYPE_STRUCT     UV
28 # define XSH_HINTS_TYPE_COMPACT    UV
29 # define XSH_HINTS_NEED_STRUCT     0
30 # define XSH_HINTS_VAL_STRUCT_REF  0
31 # define XSH_HINTS_VAL_NONE        0
32 # define XSH_HINTS_VAL_PACK(T, V)  INT2PTR(T, (V))
33 # define XSH_HINTS_VAL_UNPACK(V)   ((XSH_HINTS_TYPE_VAL) PTR2UV(V))
34 # define XSH_HINTS_VAL_INIT(HV, V) ((HV) = (V))
35 # undef  XSH_HINTS_VAL_CLONE
36 # undef  XSH_HINTS_VAL_DEINIT
37 #endif
38
39 #ifdef XSH_HINTS_TYPE_SV
40 # ifdef XSH_HINTS_TYPE_VAL
41 #  error hint type can only be set once
42 # endif
43 # undef  XSH_HINTS_TYPE_SV
44 # define XSH_HINTS_TYPE_SV         1
45 # define XSH_HINTS_TYPE_STRUCT     SV *
46 # define XSH_HINTS_TYPE_COMPACT    SV
47 # define XSH_HINTS_NEED_STRUCT     0
48 # define XSH_HINTS_VAL_STRUCT_REF  0
49 # define XSH_HINTS_VAL_NONE        NULL
50 # define XSH_HINTS_VAL_PACK(T, V)  (V)
51 # define XSH_HINTS_VAL_UNPACK(V)   (V)
52 # define XSH_HINTS_VAL_INIT(HV, V) ((HV) = (((V) != XSH_HINTS_VAL_NONE) ? SvREFCNT_inc(V) : XSH_HINTS_VAL_NONE))
53 # define XSH_HINTS_VAL_CLONE(N, O) ((N) = xsh_dup_inc((O), ud->params))
54 # define XSH_HINTS_VAL_DEINIT(V)   SvREFCNT_dec(V)
55 #endif
56
57 #ifdef XSH_HINTS_TYPE_USER
58 # ifdef XSH_HINTS_TYPE_VAL
59 #  error hint type can only be set once
60 # endif
61 # undef  XSH_HINTS_TYPE_USER
62 # define XSH_HINTS_TYPE_USER         1
63 # define XSH_HINTS_TYPE_STRUCT       xsh_hints_user_t
64 # undef  XSH_HINTS_TYPE_COMPACT      /* not used */
65 # define XSH_HINTS_NEED_STRUCT       1
66 # define XSH_HINTS_VAL_STRUCT_REF    1
67 # define XSH_HINTS_VAL_NONE          NULL
68 # define XSH_HINTS_VAL_PACK(T, V)    (V)
69 # define XSH_HINTS_VAL_UNPACK(V)     (V)
70 # define XSH_HINTS_VAL_INIT(HV, V)   xsh_hints_user_init(aTHX_ (HV), (V))
71 # define XSH_HINTS_VAL_CLONE(NV, OV) xsh_hints_user_clone(aTHX_ (NV), (OV), ud->params)
72 # define XSH_HINTS_VAL_DEINIT(V)     xsh_hints_user_deinit(aTHX_ (V))
73 #endif
74
75 #ifndef XSH_HINTS_TYPE_STRUCT
76 # error hint type was not set
77 #endif
78
79 #if XSH_HINTS_VAL_STRUCT_REF
80 # define XSH_HINTS_TYPE_VAL XSH_HINTS_TYPE_STRUCT *
81 #else
82 # define XSH_HINTS_TYPE_VAL XSH_HINTS_TYPE_STRUCT
83 #endif
84
85 #if XSH_WORKAROUND_REQUIRE_PROPAGATION
86 # undef  XSH_HINTS_NEED_STRUCT
87 # define XSH_HINTS_NEED_STRUCT 1
88 #endif
89
90 #if XSH_THREADSAFE && (defined(XSH_HINTS_VAL_CLONE) || XSH_WORKAROUND_REQUIRE_PROPAGATION)
91 # define XSH_HINTS_NEED_CLONE 1
92 #else
93 # define XSH_HINTS_NEED_CLONE 0
94 #endif
95
96 #if XSH_WORKAROUND_REQUIRE_PROPAGATION
97
98 static UV xsh_require_tag(pTHX) {
99 #define xsh_require_tag() xsh_require_tag(aTHX)
100  const CV *cv, *outside;
101
102  cv = PL_compcv;
103
104  if (!cv) {
105   /* If for some reason the pragma is operational at run-time, try to discover
106    * the current cv in use. */
107   const PERL_SI *si;
108
109   for (si = PL_curstackinfo; si; si = si->si_prev) {
110    I32 cxix;
111
112    for (cxix = si->si_cxix; cxix >= 0; --cxix) {
113     const PERL_CONTEXT *cx = si->si_cxstack + cxix;
114
115     switch (CxTYPE(cx)) {
116      case CXt_SUB:
117      case CXt_FORMAT:
118       /* The propagation workaround is only needed up to 5.10.0 and at that
119        * time format and sub contexts were still identical. And even later the
120        * cv members offsets should have been kept the same. */
121       cv = cx->blk_sub.cv;
122       goto get_enclosing_cv;
123      case CXt_EVAL:
124       cv = cx->blk_eval.cv;
125       goto get_enclosing_cv;
126      default:
127       break;
128     }
129    }
130   }
131
132   cv = PL_main_cv;
133  }
134
135 get_enclosing_cv:
136  for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
137   cv = outside;
138
139  return PTR2UV(cv);
140 }
141
142 #endif /* XSH_WORKAROUND_REQUIRE_PROPAGATION */
143
144 #if XSH_HINTS_NEED_STRUCT
145
146 typedef struct {
147  XSH_HINTS_TYPE_STRUCT val;
148 #if XSH_WORKAROUND_REQUIRE_PROPAGATION
149  UV                    require_tag;
150 #endif
151 } xsh_hints_t;
152
153 #if XSH_HINTS_VAL_STRUCT_REF
154 # define XSH_HINTS_VAL_GET(H) (&(H)->val)
155 #else
156 # define XSH_HINTS_VAL_GET(H) ((H)->val)
157 #endif
158
159 #define XSH_HINTS_VAL_SET(H, V) XSH_HINTS_VAL_INIT(XSH_HINTS_VAL_GET(H), (V))
160
161 #ifdef XSH_HINTS_VAL_DEINIT
162 # define XSH_HINTS_FREE(H) \
163    if (H) XSH_HINTS_VAL_DEINIT(XSH_HINTS_VAL_GET(H)); \
164    PerlMemShared_free(H)
165 #else
166 # define XSH_HINTS_FREE(H) PerlMemShared_free(H)
167 #endif
168
169 #else  /*  XSH_HINTS_NEED_STRUCT */
170
171 typedef XSH_HINTS_TYPE_COMPACT xsh_hints_t;
172
173 #define XSH_HINTS_VAL_GET(H)    XSH_HINTS_VAL_UNPACK(H)
174 #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
175
176 #undef XSH_HINTS_FREE
177
178 #endif /* !XSH_HINTS_NEED_STRUCT */
179
180 /* ... Thread safety ....................................................... */
181
182 #if XSH_HINTS_NEED_CLONE
183
184 #ifdef XSH_HINTS_FREE
185 # define PTABLE_NAME        ptable_hints
186 # define PTABLE_VAL_FREE(V) XSH_HINTS_FREE((xsh_hints_t *) (V))
187 #else
188 # define PTABLE_USE_DEFAULT 1
189 #endif
190
191 #define PTABLE_NEED_WALK    1
192 #define PTABLE_NEED_DELETE  0
193
194 #include "ptable.h"
195
196 #if PTABLE_WAS_DEFAULT
197 # define ptable_hints_store(T, K, V) ptable_default_store(aPTBL_ (T), (K), (V))
198 # define ptable_hints_free(T)        ptable_default_free(aPTBL_ (T))
199 #else
200 # define ptable_hints_store(T, K, V) ptable_hints_store(aPTBL_ (T), (K), (V))
201 # define ptable_hints_free(T)        ptable_hints_free(aPTBL_ (T))
202 #endif
203
204 #define XSH_THREADS_HINTS_CONTEXT 1
205
206 typedef struct {
207  ptable *tbl; /* It really is a ptable_hints */
208  tTHX    owner;
209 } xsh_hints_cxt_t;
210
211 static xsh_hints_cxt_t *xsh_hints_get_cxt(pTHX);
212
213 static void xsh_hints_local_setup(pTHX_ xsh_hints_cxt_t *cxt) {
214  cxt->tbl   = ptable_new(4);
215  cxt->owner = aTHX;
216 }
217
218 static void xsh_hints_local_teardown(pTHX_ xsh_hints_cxt_t *cxt) {
219  ptable_hints_free(cxt->tbl);
220  cxt->owner = NULL;
221 }
222
223 typedef struct {
224  ptable       *tbl; /* It really is a ptable_hints */
225  CLONE_PARAMS *params;
226 } xsh_ptable_clone_ud;
227
228 static void xsh_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
229  xsh_ptable_clone_ud *ud = ud_;
230  xsh_hints_t         *h1 = ent->val;
231  xsh_hints_t         *h2;
232
233 #if XSH_HINTS_NEED_STRUCT
234  h2              = PerlMemShared_malloc(sizeof *h2);
235 # if XSH_WORKAROUND_REQUIRE_PROPAGATION
236  h2->require_tag = PTR2UV(xsh_dup_inc(INT2PTR(SV *, h1->require_tag), ud->params));
237 # endif
238 #endif  /*  XSH_HINTS_NEED_STRUCT */
239
240 #ifdef XSH_HINTS_VAL_CLONE
241  XSH_HINTS_VAL_CLONE(XSH_HINTS_VAL_GET(h2), XSH_HINTS_VAL_GET(h1));
242 #endif /* defined(XSH_HINTS_VAL_CLONE) */
243
244  ptable_hints_store(ud->tbl, ent->key, h2);
245 }
246
247 static void xsh_hints_clone(pTHX_ const xsh_hints_cxt_t *old_cxt, xsh_hints_cxt_t *new_cxt, CLONE_PARAMS *params) {
248  xsh_ptable_clone_ud ud;
249
250  new_cxt->tbl   = ptable_new(4);
251  new_cxt->owner = aTHX;
252
253  ud.tbl    = new_cxt->tbl;
254  ud.params = params;
255
256  ptable_walk(old_cxt->tbl, xsh_ptable_clone, &ud);
257 }
258
259 #endif /* XSH_HINTS_NEED_CLONE */
260
261 /* ... tag hints ........................................................... */
262
263 static SV *xsh_hints_tag(pTHX_ XSH_HINTS_TYPE_VAL val) {
264 #define xsh_hints_tag(V) xsh_hints_tag(aTHX_ (V))
265  xsh_hints_t *h;
266
267  if (val == XSH_HINTS_VAL_NONE)
268   return newSVuv(0);
269
270 #if XSH_HINTS_NEED_STRUCT
271  h              = PerlMemShared_malloc(sizeof *h);
272 # if XSH_WORKAROUND_REQUIRE_PROPAGATION
273  h->require_tag = xsh_require_tag();
274 # endif
275 #endif /* XSH_HINTS_NEED_STRUCT */
276
277  XSH_HINTS_VAL_SET(h, val);
278
279 #if XSH_HINTS_NEED_CLONE
280  /* We only need for the key to be an unique tag for looking up the value later
281   * Allocated memory provides convenient unique identifiers, so that's why we
282   * use the hint as the key itself. */
283  {
284   xsh_hints_cxt_t *cxt = xsh_hints_get_cxt(aTHX);
285   XSH_ASSERT(cxt->tbl);
286   ptable_hints_store(cxt->tbl, h, h);
287  }
288 #endif /* !XSH_HINTS_NEED_CLONE */
289
290  return newSVuv(PTR2UV(h));
291 }
292
293 /* ... detag hints ......................................................... */
294
295 #define xsh_hints_2uv(H) \
296     ((H) \
297      ? (SvIOK(H) \
298         ? SvUVX(H) \
299         : (SvPOK(H) \
300            ? sv_2uv(SvLEN(H) ? (H) : sv_mortalcopy(H)) \
301            : 0 \
302           ) \
303        ) \
304      : 0)
305
306 static XSH_HINTS_TYPE_VAL xsh_hints_detag(pTHX_ SV *hint) {
307 #define xsh_hints_detag(H) xsh_hints_detag(aTHX_ (H))
308  xsh_hints_t *h;
309  UV           hint_uv;
310
311  hint_uv = xsh_hints_2uv(hint);
312  h       = INT2PTR(xsh_hints_t *, hint_uv);
313  if (!h)
314   return XSH_HINTS_VAL_NONE;
315
316 #if XSH_HINTS_NEED_CLONE
317  {
318   xsh_hints_cxt_t *cxt = xsh_hints_get_cxt(aTHX);
319   XSH_ASSERT(cxt->tbl);
320   h = ptable_fetch(cxt->tbl, h);
321  }
322 #endif /* XSH_HINTS_NEED_CLONE */
323
324 #if XSH_WORKAROUND_REQUIRE_PROPAGATION
325  if (xsh_require_tag() != h->require_tag)
326   return XSH_HINTS_VAL_NONE;
327 #endif
328
329  return XSH_HINTS_VAL_GET(h);
330 }
331
332 /* ... fetch hints ......................................................... */
333
334 #if !defined(cop_hints_fetch_pvn) && XSH_HAS_PERL(5, 9, 5)
335 # define cop_hints_fetch_pvn(COP, PKG, PKGLEN, PKGHASH, FLAGS) \
336    Perl_refcounted_he_fetch(aTHX_ (COP)->cop_hints_hash, NULL, \
337                                   (PKG), (PKGLEN), (FLAGS), (PKGHASH))
338 #endif
339
340 #ifdef cop_hints_fetch_pvn
341
342 static U32 xsh_hints_key_hash = 0;
343 # define xsh_hints_global_setup(my_perl) \
344          PERL_HASH(xsh_hints_key_hash, XSH_HINTS_KEY, XSH_HINTS_KEY_LEN)
345
346 #else /* defined(cop_hints_fetch_pvn) */
347
348 # define xsh_hints_global_setup(my_perl)
349
350 #endif /* !defined(cop_hints_fetch_pvn) */
351
352 #define xsh_hints_global_teardown(my_perl)
353
354 static SV *xsh_hints_fetch(pTHX) {
355 #define xsh_hints_fetch() xsh_hints_fetch(aTHX)
356 #if XSH_HINTS_ONLY_COMPILE_TIME
357  if (IN_PERL_RUNTIME)
358   return NULL;
359 #endif
360
361 #ifdef cop_hints_fetch_pvn
362  return cop_hints_fetch_pvn(PL_curcop, XSH_HINTS_KEY, XSH_HINTS_KEY_LEN,
363                                        xsh_hints_key_hash, 0);
364 #else
365  {
366   SV **val = hv_fetch(GvHV(PL_hintgv), XSH_HINTS_KEY, XSH_HINTS_KEY_LEN, 0);
367   return val ? *val : NULL;
368  }
369 #endif
370 }
371
372 #endif /* XSH_HINTS_H */