BeginLift.xs

   1 #define PERL_CORE
   2 #define PERL_NO_GET_CONTEXT
   3 #include "EXTERN.h"
   4 #include "perl.h"
   5 #include "XSUB.h"
   6 #include <stdio.h>
   7 #include <string.h>
   8
   9 /* lifted from op.c */
  10
  11 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
  12
  13 /* pointer to old PL_check entersub entry to be populated in init */
  14
  15 STATIC OP *(*dbl_old_ck_entersub)(pTHX_ OP *op);
  16
  17 /* replacement PL_check entersub entry */
  18
  19 STATIC OP *dbl_ck_entersub(pTHX_ OP *o) {
  20   dSP;
  21   OP *kid;
  22   OP *last;
  23   OP *curop;
  24   OP *saved_next;
  25   HV *stash;
  26   I32 type = o->op_type;
  27   SV *sv;
  28   SV** stack_save;
  29   HV* to_lift;
  30   SV** to_lift_pack_ref;
  31   HV* to_lift_pack_hash;
  32   SV** to_lift_flag_ref;
  33
  34   o = dbl_old_ck_entersub(aTHX_ o); /* let the original do its job */
  35
  36   kid = cUNOPo->op_first;
  37
  38   if (kid->op_type != OP_NULL) /* pushmark for method call ... */
  39     return o;
  40
  41   last = kLISTOP->op_last;
  42
  43   if (last->op_type != OP_NULL) /* not what we expected */
  44     return o;
  45
  46   kid = cUNOPx(last)->op_first;
  47
  48   if (kid->op_type != OP_GV) /* not a GV so ignore */
  49     return o;
  50
  51   stash = GvSTASH(kGVOP_gv);
  52
  53   /* printf("Calling GV %s -> %s\n",
  54     HvNAME(stash), GvNAME(kGVOP_gv)); */
  55
  56   to_lift = get_hv("Devel::BeginLift::lift", FALSE);
  57
  58   if (!to_lift)
  59     return o;
  60
  61   to_lift_pack_ref = hv_fetch(to_lift, HvNAME(stash), strlen(HvNAME(stash)),
  62                                FALSE);
  63
  64   if (!to_lift_pack_ref || !SvROK(*to_lift_pack_ref))
  65     return o; /* not a hashref */
  66
  67   to_lift_pack_hash = (HV*) SvRV(*to_lift_pack_ref);
  68
  69   to_lift_flag_ref = hv_fetch(to_lift_pack_hash, GvNAME(kGVOP_gv),
  70                                 strlen(GvNAME(kGVOP_gv)), FALSE);
  71
  72   if (!to_lift_flag_ref || !SvTRUE(*to_lift_flag_ref))
  73     return o;
  74
  75   /* shamelessly lifted from fold_constants in op.c */
  76
  77   stack_save = SP;
  78
  79   curop = LINKLIST(o);
  80
  81   if (0) { /* call as macro */
  82     OP *arg;
  83     OP *gv;
  84     /* this means the argument pushing ops are not executed, only the GV to
  85      * resolve the call is, and B::OP objects will be made of all the opcodes
  86      * */
  87     PUSHMARK(SP); /* push a mark for the arguments */
  88
  89     /* push an arg for every sibling op */
  90     for ( arg = curop->op_sibling; arg->op_sibling; arg = arg->op_sibling ) {
  91       XPUSHs(sv_bless(newRV_inc(newSViv(PTR2IV(arg))), gv_stashpv("B::LISTOP", 0)));
  92     }
  93
  94     /* find the last non null before the lifted entersub */
  95     for ( kid = curop; kid->op_next != o; kid = kid->op_next ) {
  96       if ( kid->op_type == OP_GV )
  97           gv = kid;
  98     }
  99
 100     PL_op = gv; /* make the call to our sub without evaluating the arg ops */
 101   } else {
 102     PL_op = curop;
 103   }
 104
 105   /* stop right after the call */
 106   saved_next = o->op_next;
 107   o->op_next = NULL;
 108
 109   PUTBACK;
 110   SAVETMPS;
 111   CALLRUNOPS(aTHX);
 112   SPAGAIN;
 113
 114   if (SP > stack_save) { /* sub returned something */
 115     sv = POPs;
 116     if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
 117       pad_swipe(o->op_targ,  FALSE);
 118     else if (SvTEMP(sv)) {      /* grab mortal temp? */
 119       (void)SvREFCNT_inc(sv);
 120       SvTEMP_off(sv);
 121     }
 122
 123     if (SvROK(sv) && sv_derived_from(sv, "B::OP")) {
 124       OP *new = INT2PTR(OP *,SvIV((SV *)SvRV(sv)));
 125       new->op_sibling = NULL;
 126
 127       /* FIXME this is bullshit */
 128       if ( (PL_opargs[new->op_type] & OA_CLASS_MASK) != OA_SVOP ) {
 129         new->op_next = saved_next;
 130       } else {
 131         new->op_next = new;
 132       }
 133
 134       return new;
 135     }
 136
 137     if (type == OP_RV2GV)
 138       return newGVOP(OP_GV, 0, (GV*)sv);
 139
 140     return newSVOP(OP_CONST, 0, sv);
 141   } else {
 142     /* this bit not lifted, handles the 'sub doesn't return stuff' case
 143        which fold_constants can ignore */
 144     op_free(o);
 145     return newOP(OP_NULL, 0);
 146   }
 147 }
 148
 149 static int initialized = 0;
 150
 151 MODULE = Devel::BeginLift  PACKAGE = Devel::BeginLift
 152
 153 PROTOTYPES: DISABLE
 154
 155 void
 156 setup()
 157   CODE:
 158   if (!initialized++) {
 159     dbl_old_ck_entersub = PL_check[OP_ENTERSUB];
 160     PL_check[OP_ENTERSUB] = dbl_ck_entersub;
 161   }
 162
 163 void
 164 teardown()
 165   CODE:
 166   /* ensure we only uninit when number of teardown calls matches
 167      number of setup calls */
 168   if (initialized && !--initialized) {
 169     PL_check[OP_ENTERSUB] = dbl_old_ck_entersub;
 170   }