#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "embed.h"
#include "XSUB.h"
#define NEED_load_module
#define NEED_newRV_noinc
#define NEED_vload_module
#include "ppport.h"
#define XPUSHREF(x) XPUSHs(sv_2mortal(newRV_inc(x)))
#define PUSHREF(x) PUSHs(sv_2mortal(newRV_inc(x)))
int (*Runops_Trace_old_runops ) ( pTHX );
int (*Runops_Trace_hook)(pTHX);
STATIC HV *Runops_Trace_op_counters;
STATIC int Runops_Trace_enabled;
STATIC UV Runops_Trace_threshold = 0;
STATIC SV *Runops_Trace_perl_hook;
STATIC int Runops_Trace_perl_ignore_ret = 1;
STATIC int Runops_Trace_loaded_B;
STATIC CV *Runops_Trace_B_UNOP_first;
STATIC XSUBADDR_t Runops_Trace_B_UNOP_first_xsub;
STATIC GV *Runops_Trace_B_UNOP_stash;
STATIC UNOP Runops_Trace_fakeop;
STATIC SV *Runops_Trace_fakeop_sv;
#define MAXO_PLUS ( MAXO + 100 )
#define MAXO_BIT_OCTETS ( ( MAXO_PLUS + 7 ) / 8 )
STATIC char *Runops_Trace_mask;
#define ARITY_NULL 0
#define ARITY_UNARY 1
#define ARITY_BINARY 1 << 1
#define ARITY_LIST 1 << 2
#define ARITY_LIST_BINARY (ARITY_LIST|ARITY_BINARY)
#define ARITY_LIST_UNARY (ARITY_LIST|ARITY_UNARY)
#define ARITY_UNKNOWN 1 << 3
/* this is the modified runloop */
int runops_trace(pTHX)
{
while (PL_op) {
if ( Runops_Trace_enabled &&
( !Runops_Trace_mask /* trace if no mask */
|| ( Runops_Trace_mask[PL_op->op_type >> 3] & ( 1 << (PL_op->op_type & 0x07) ) ) ) /* or this op is unmasked */
){
/* the hook may have assigned PL_op itself, in which case we just go to
* the next loop iteration */
if (Runops_Trace_hook && CALL_FPTR( Runops_Trace_hook) (aTHX))
continue;
}
/* this is pretty much the normal runops_standard */
PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX);
PERL_ASYNC_CHECK(); /* FIXME is it OK that PERL_ASYNC_CHECK happens even after PL_op might be false? */
}
TAINT_NOT;
return 0;
}
void
Runops_Trace_enable () {
Runops_Trace_enabled = 1;
}
void
Runops_Trace_disable () {
Runops_Trace_enabled = 0;
}
STATIC SV *
Runops_Trace_op_to_BOP (pTHX_ OP *op) {
dSP;
/* we fake B::UNOP object (fakeop_sv) that points to our static fakeop.
* then we set first_op to the op we want to make an object out of, and
* trampoline into B::UNOP->first so that it creates the B::OP of the
* correct class for us.
* B should really have a way to create an op from a pointer via some
* external API. This sucks monkey balls on olympic levels */
Runops_Trace_fakeop.op_first = op;
PUSHMARK(SP);
XPUSHs(Runops_Trace_fakeop_sv);
PUTBACK;
/* call_pv("B::UNOP::first", G_SCALAR); */
assert(Runops_Trace_loaded_B);
assert(Runops_Trace_B_UNOP_first);
assert(Runops_Trace_B_UNOP_first_xsub != NULL);
Runops_Trace_B_UNOP_first_xsub(aTHX_ Runops_Trace_B_UNOP_first);
SPAGAIN;
return POPs;
}
STATIC IV
Runops_Trace_op_arity (pTHX_ OP *o) {
switch (o->op_type) {
case OP_SASSIGN:
/* wtf? */
return ((o->op_private & OPpASSIGN_BACKWARDS) ? ARITY_UNARY : ARITY_BINARY);
case OP_ENTERSUB:
return ARITY_LIST_UNARY;
case OP_REFGEN:
return ARITY_LIST;
case OP_LEAVELOOP: /* FIXME BASEOP_OR_UNOP */
case OP_ENTERITER:
case OP_ENTERLOOP:
return ARITY_NULL;
}
switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
case OA_COP:
case OA_SVOP:
case OA_PADOP:
case OA_BASEOP:
case OA_FILESTATOP:
case OA_LOOPEXOP:
return ARITY_NULL;
case OA_BASEOP_OR_UNOP:
/* FIXME gotta check gimme from context block */
/* return (o->op_flags & OPf_KIDS ) ? ARITY_gimme : ARITY_NULL; */
return ARITY_NULL;
case OA_LOGOP:
case OA_UNOP:
return ARITY_UNARY;
case OA_LISTOP:
return ARITY_LIST;
case OA_BINOP:
if ( o->op_type == OP_AASSIGN ) {
return ARITY_LIST_BINARY;
} else {
return ARITY_BINARY;
}
default:
printf("%s is a %d\n", PL_op_name[o->op_type], PL_opargs[o->op_type] >> OASHIFT);
return ARITY_UNKNOWN;
}
}
STATIC AV *
av_make_with_refs(pTHX_ SV**from, SV**to) {
SV **i;
AV *av = newAV();
/* Bug #64830 */
if (to > from) {
av_extend(av, (to - from) / sizeof(SV **));
for (i = from; i <= to; i++) {
av_push(av, newRV_inc(*i));
}
}
return av;
}
/* this is a hook that calls to a perl code ref */
int
Runops_Trace_perl (pTHX) {
dSP;
SV **orig_sp = SP;
SV **list_mark;
SV *sv_ret;
SV *PL_op_object;
int ret;
IV arity;
/* if the threshold is enabled, only trace if the op has exceeded the threshold */
if (Runops_Trace_threshold != 0) {
SV **count;
UV c;
/* having a threshold means that only ops that are hit enough
* times get hooked, the idea is that this can be used for
* trace caching */
/* in the future this might change to a dynamically decayed bloom filter */
if ( !Runops_Trace_op_counters )
Runops_Trace_op_counters = newHV();
/* unfortunately we need to keep the counters in a hash */
count = hv_fetch(Runops_Trace_op_counters, (char *)PL_op, sizeof(PL_op), 1);
if ( SvTRUE(*count) ) {
SvUVX(*count)++;
} else {
*count = newSVuv(1);
}
/* if we haven't reached the threshold yet, then return */
if (c < Runops_Trace_threshold)
return 0;
}
/* don't want to hook the hook */
Runops_Trace_disable();
/* make the environment as normal as possible for callbacks */
PL_runops = Runops_Trace_old_runops;
ENTER;
SAVETMPS;
PL_op_object = Runops_Trace_op_to_BOP(aTHX_ PL_op);
arity = Runops_Trace_op_arity(aTHX_ PL_op);
/* arguments for the sub start at this mark */
PUSHMARK(SP);
EXTEND(SP, 4); /* op obj, arity flag, unary and binary ops. ARITY_LIST will call extend for nary args */
PUSHs(PL_op_object);
PUSHs(sv_2mortal(newSViv(arity)));
switch (arity) {
case ARITY_LIST_UNARY:
/* ENTERSUB's unary arg (the cv) is the last thing on the stack, but it has args too */
PUSHREF(*orig_sp--);
/* fall through */
case ARITY_LIST:
list_mark = PL_stack_base + *(PL_markstack_ptr-1) + 1;
/* repeat stack from the op's mark to SP just before we started pushing */
EXTEND(SP, orig_sp - list_mark);
while ( list_mark <= orig_sp ) {
XPUSHREF(*list_mark++);
}
break;
case ARITY_BINARY:
XPUSHREF(*(orig_sp-1));
case ARITY_UNARY:
XPUSHREF(*orig_sp);
break;
case ARITY_LIST_BINARY:
{
SV **mark = SP; dORIGMARK;
SV **lastlelem = orig_sp;
SV **lastrelem = PL_stack_base + *(PL_markstack_ptr-1);
SV **firstrelem = PL_stack_base + *(PL_markstack_ptr-2) + 1;
SV **firstlelem = lastrelem + 1;
SV *lav = (SV *)av_make_with_refs(aTHX_ firstlelem, lastlelem);
SV *rav = (SV *)av_make_with_refs(aTHX_ firstrelem, lastrelem);
SP = ORIGMARK;
XPUSHREF(lav);
XPUSHREF(rav);
}
break;
case ARITY_NULL:
break;
default:
/* warn("Unknown arity for %s (%p)", PL_op_name[PL_op->op_type], PL_op); */
break;
}
PUTBACK;
call_sv(Runops_Trace_perl_hook, (Runops_Trace_perl_ignore_ret ? G_DISCARD : G_SCALAR));
SPAGAIN;
/* we coerce it here so that SvTRUE is evaluated without hooking, and
* Runops_Trace_enable() is the last thing in this hook */
if (!Runops_Trace_perl_ignore_ret) {
sv_ret = POPs;
ret = SvTRUE(sv_ret);
} else {
ret = 0;
}
PUTBACK;
FREETMPS;
LEAVE;
/* set up debugging again */
PL_runops = runops_trace;
Runops_Trace_enable();
return ret;
}
void
Runops_Trace_clear_hook () {
Runops_Trace_hook = NULL;
}
void
Runops_Trace_set_hook (int (*hook)(pTHX)) {
Runops_Trace_hook = hook;
}
void
Runops_Trace_clear_perl_hook(pTHX) {
SvSetSV(Runops_Trace_perl_hook, &PL_sv_undef );
}
STATIC void
Runops_Trace_load_B (pTHX) {
if (!Runops_Trace_loaded_B) {
load_module( PERL_LOADMOD_NOIMPORT, newSVpv("B", 0), (SV *)NULL );
Runops_Trace_B_UNOP_first = get_cv("B::UNOP::first", TRUE);
Runops_Trace_B_UNOP_first_xsub = CvXSUB(Runops_Trace_B_UNOP_first);
Runops_Trace_fakeop_sv = sv_bless(newRV_noinc(newSVuv((UV)&Runops_Trace_fakeop)), gv_stashpv("B::UNOP", 0));
Runops_Trace_loaded_B = 1;
}
}
void
Runops_Trace_set_perl_hook (pTHX_ SV *tracer_rv) {
/* Validate tracer_rv */
if ( ! SvROK( tracer_rv ) || ! SVt_PVCV == SvTYPE( SvRV( tracer_rv ) ) ) {
croak("the hook must be a code reference");
}
Runops_Trace_load_B(aTHX);
Runops_Trace_clear_perl_hook(aTHX);
/* Initialize/set the tracing function */
SvSetSV( Runops_Trace_perl_hook, tracer_rv );
Runops_Trace_set_hook(Runops_Trace_perl);
}
STATIC UV
Runops_Trace_get_threshold () {
return Runops_Trace_threshold;
}
STATIC void
Runops_Trace_set_threshold (UV t) {
Runops_Trace_threshold = t;
}
STATIC void
Runops_Trace_mask_set (bool t) {
if ( Runops_Trace_mask ) {
char *byte = Runops_Trace_mask;
while ( byte < Runops_Trace_mask + MAXO_BIT_OCTETS ) {
*byte++ = t ? 0xff : 0;
}
}
}
STATIC void
Runops_Trace_mask_autocreate () {
if (!Runops_Trace_mask) {
I32 len = MAXO_BIT_OCTETS;
Newx(Runops_Trace_mask, MAXO_BIT_OCTETS, char);
Runops_Trace_mask_set(1);
}
}
STATIC void
Runops_Trace_mask_all () {
if (!Runops_Trace_mask) {
Newxz(Runops_Trace_mask, MAXO_BIT_OCTETS, char);
} else {
Runops_Trace_mask_set(0);
}
}
STATIC void
Runops_Trace_mask_none () {
if (!Runops_Trace_mask) {
Runops_Trace_mask_autocreate();
} else {
Runops_Trace_mask_set(1);
}
}
STATIC void
Runops_Trace_mask_set_op_type (I32 op_type, bool bit) {
if ( !Runops_Trace_mask )
Runops_Trace_mask_autocreate();
if ( op_type < MAXO_PLUS && op_type >= 0 ) {
const int offset = op_type >> 3;
const int bit = op_type & 0x07;
if (bit)
Runops_Trace_mask[offset] |= 1 << bit;
else
Runops_Trace_mask[offset] &= ~(1 << bit);
} else {
croak("Invalid op_type %d", op_type);
}
}
STATIC void
Runops_Trace_unmask_op_type (unsigned op_type) {
Runops_Trace_mask_set_op_type(op_type, 1);
}
STATIC void
Runops_Trace_mask_op_type (unsigned op_type) {
Runops_Trace_mask_set_op_type(op_type, 0);
}
STATIC void
Runops_Trace_clear_op_mask () {
Safefree(Runops_Trace_mask);
Runops_Trace_mask = NULL;
}
MODULE = Runops::Trace PACKAGE = Runops::Trace
PROTOTYPES: ENABLE
BOOT:
Runops_Trace_clear_hook();
Runops_Trace_old_runops = PL_runops;
PL_runops = runops_trace;
Runops_Trace_perl_hook = newSVsv( &PL_sv_undef );
HV *
get_op_counters()
PROTOTYPE:
CODE:
{
if ( !Runops_Trace_op_counters )
Runops_Trace_op_counters = newHV();
RETVAL = Runops_Trace_op_counters;
}
OUTPUT:
RETVAL
int
tracing_enabled()
PROTOTYPE:
CODE:
{
RETVAL = Runops_Trace_enabled;
}
OUTPUT:
RETVAL
void
enable_tracing()
PROTOTYPE:
CODE:
{
Runops_Trace_enable();
}
void
disable_tracing()
PROTOTYPE:
CODE:
{
Runops_Trace_disable();
}
UV
get_trace_threshold()
PROTOTYPE:
CODE:
{
RETVAL = Runops_Trace_get_threshold();
}
OUTPUT:
RETVAL
void
set_trace_threshold(SV *a)
PROTOTYPE: $
CODE:
{
Runops_Trace_set_threshold(SvUV(a));
}
void
set_tracer(SV *hook)
PROTOTYPE: $
CODE:
{
Runops_Trace_set_perl_hook(aTHX_ hook);
}
SV *
get_tracer()
PROTOTYPE:
CODE:
{
RETVAL = Runops_Trace_perl_hook;
}
OUTPUT:
RETVAL
void
clear_tracer()
PROTOTYPE:
CODE:
{
Runops_Trace_clear_perl_hook(aTHX);
Runops_Trace_clear_hook();
}
void
ignore_hook_ret()
PROTOTYPE:
CODE:
{
Runops_Trace_perl_ignore_ret = 1;
}
void
unignore_hook_ret()
PROTOTYPE:
CODE:
{
Runops_Trace_perl_ignore_ret = 0;
}
void
_trace_function( tracer_rv, to_trace_rv)
SV * tracer_rv
SV * to_trace_rv
PROTOTYPE: $$
CODE:
Runops_Trace_set_perl_hook( aTHX_ tracer_rv );
/* Call the function to trace */
Runops_Trace_enable();
call_sv( to_trace_rv, G_VOID | G_DISCARD | G_EVAL | G_KEEPERR );
Runops_Trace_disable();
void
enable_global_tracing(tracer_rv)
SV * tracer_rv
PROTOTYPE: $
CODE:
Runops_Trace_set_perl_hook( aTHX_ tracer_rv );
Runops_Trace_enable();
void
disable_global_tracing()
PROTOTYPE:
CODE:
Runops_Trace_disable();
void
mask_op_type (unsigned op_type)
PROTOTYPE: $
CODE:
{
Runops_Trace_mask_op_type(op_type);
}
void
unmask_op_type (unsigned op_type)
PROTOTYPE: $
CODE:
{
Runops_Trace_unmask_op_type(op_type);
}
void
mask_all ()
PROTOTYPE:
CODE:
{
Runops_Trace_mask_all();
}
void
unmask_all ()
PROTOTYPE:
CODE:
{
Runops_Trace_mask_none();
}
void
mask_none ()
PROTOTYPE:
CODE:
{
Runops_Trace_mask_none();
}
void
clear_mask()
PROTOTYPE:
CODE:
{
Runops_Trace_clear_op_mask();
}
int
ARITY_NULL ()
PROTOTYPE:
CODE:
{
RETVAL = ARITY_NULL;
}
OUTPUT:
RETVAL
int
ARITY_UNARY ()
PROTOTYPE:
CODE:
{
RETVAL = ARITY_UNARY;
}
OUTPUT:
RETVAL
int
ARITY_BINARY ()
PROTOTYPE:
CODE:
{
RETVAL = ARITY_BINARY;
}
OUTPUT:
RETVAL
int
ARITY_LIST ()
PROTOTYPE:
CODE:
{
RETVAL = ARITY_LIST;
}
OUTPUT:
RETVAL
int
ARITY_LIST_BINARY ()
PROTOTYPE:
CODE:
{
RETVAL = ARITY_LIST_BINARY;
}
OUTPUT:
RETVAL
int
ARITY_LIST_UNARY ()
PROTOTYPE:
CODE:
{
RETVAL = ARITY_LIST_UNARY;
}
OUTPUT:
RETVAL
int
ARITY_UNKNOWN ()
PROTOTYPE:
CODE:
{
RETVAL = ARITY_UNKNOWN;
}
OUTPUT:
RETVAL