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 #include "hook_op_check_entersubforcv.h"
  10
  11 /* lifted from op.c */
  12
  13 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
  14
  15 #ifndef linklist
  16 # define linklist(o) THX_linklist(aTHX_ o)
  17 STATIC OP *THX_linklist(pTHX_ OP *o) {
  18   OP *first;
  19   if(o->op_next)
  20     return o->op_next;
  21   first = cUNOPo->op_first;
  22   if (first) {
  23     OP *kid;
  24     o->op_next = LINKLIST(first);
  25     kid = first;
  26     for (;;) {
  27       if (kid->op_sibling) {
  28    kid->op_next = LINKLIST(kid->op_sibling);
  29    kid = kid->op_sibling;
  30       } else {
  31    kid->op_next = o;
  32    break;
  33       }
  34     }
  35   } else {
  36     o->op_next = o;
  37   }
  38   return o->op_next;
  39 }
  40 #endif /* !linklist */
  41
  42 STATIC OP *lift_cb(pTHX_ OP *o, CV *cv, void *user_data) {
  43   dSP;
  44   SV *sv;
  45   SV **stack_save;
  46   OP *curop, *kid, *saved_next;
  47   I32 type = o->op_type;
  48
  49   /* shamelessly lifted from fold_constants in op.c */
  50
  51   stack_save = SP;
  52
  53   curop = LINKLIST(o);
  54
  55   if (0) { /* call as macro */
  56     OP *arg;
  57     OP *gv;
  58     /* this means the argument pushing ops are not executed, only the GV to
  59      * resolve the call is, and B::OP objects will be made of all the opcodes
  60      * */
  61     PUSHMARK(SP); /* push a mark for the arguments */
  62
  63     /* push an arg for every sibling op */
  64     for ( arg = curop->op_sibling; arg->op_sibling; arg = arg->op_sibling ) {
  65       XPUSHs(sv_bless(newRV_inc(newSViv(PTR2IV(arg))), gv_stashpv("B::LISTOP", 0)));
  66     }
  67
  68     /* find the last non null before the lifted entersub */
  69     for ( kid = curop; kid->op_next != o; kid = kid->op_next ) {
  70       if ( kid->op_type == OP_GV )
  71           gv = kid;
  72     }
  73
  74     PL_op = gv; /* make the call to our sub without evaluating the arg ops */
  75   } else {
  76     PL_op = curop;
  77   }
  78
  79   /* stop right after the call */
  80   saved_next = o->op_next;
  81   o->op_next = NULL;
  82
  83   PUTBACK;
  84   SAVETMPS;
  85   CALLRUNOPS(aTHX);
  86   SPAGAIN;
  87
  88   if (SP > stack_save) { /* sub returned something */
  89     sv = POPs;
  90     if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
  91       pad_swipe(o->op_targ,  FALSE);
  92     else if (SvTEMP(sv)) {      /* grab mortal temp? */
  93       (void)SvREFCNT_inc(sv);
  94       SvTEMP_off(sv);
  95     }
  96
  97     if (SvROK(sv) && sv_derived_from(sv, "B::OP")) {
  98       OP *new = INT2PTR(OP *,SvIV((SV *)SvRV(sv)));
  99       new->op_sibling = NULL;
 100
 101       /* FIXME this is bullshit */
 102       if ( (PL_opargs[new->op_type] & OA_CLASS_MASK) != OA_SVOP ) {
 103         new->op_next = saved_next;
 104       } else {
 105         new->op_next = new;
 106       }
 107
 108       return new;
 109     }
 110
 111     if (type == OP_RV2GV)
 112       return newGVOP(OP_GV, 0, (GV*)sv);
 113
 114         if (SvTYPE(sv) == SVt_NULL) {
 115                 op_free(o);
 116                 return newOP(OP_NULL, 0);
 117         }
 118
 119     return newSVOP(OP_CONST, 0, sv);
 120   } else {
 121     /* this bit not lifted, handles the 'sub doesn't return stuff' case
 122        which fold_constants can ignore */
 123     op_free(o);
 124     return newOP(OP_NULL, 0);
 125   }
 126 }
 127
 128 MODULE = Devel::BeginLift  PACKAGE = Devel::BeginLift
 129
 130 PROTOTYPES: DISABLE
 131
 132 UV
 133 setup_for_cv (class, CV *cv)
 134   CODE:
 135     RETVAL = (UV)hook_op_check_entersubforcv (cv, lift_cb, NULL);
 136   OUTPUT:
 137     RETVAL
 138
 139 void
 140 teardown_for_cv (class, UV id)
 141   CODE:
 142     hook_op_check_entersubforcv_remove ((hook_op_check_id)id);