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