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