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