Plan for t/generate.t.
[p5sagit/Devel-BeginLift.git] / 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         if (SvTYPE(sv) == SVt_NULL) {
88                 op_free(o);
89                 return newOP(OP_NULL, 0);
90         }
91
92     return newSVOP(OP_CONST, 0, sv);
93   } else {
94     /* this bit not lifted, handles the 'sub doesn't return stuff' case
95        which fold_constants can ignore */
96     op_free(o);
97     return newOP(OP_NULL, 0);
98   }
99 }
100
101 MODULE = Devel::BeginLift  PACKAGE = Devel::BeginLift
102
103 PROTOTYPES: DISABLE
104
105 UV
106 setup_for_cv (class, CV *cv)
107   CODE:
108     RETVAL = (UV)hook_op_check_entersubforcv (cv, lift_cb, NULL);
109   OUTPUT:
110     RETVAL
111
112 void
113 teardown_for_cv (class, UV id)
114   CODE:
115     hook_op_check_entersubforcv_remove ((hook_op_check_id)id);