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 */