diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclBasic.c | 142 | ||||
| -rw-r--r-- | generic/tclCompile.h | 91 | ||||
| -rw-r--r-- | generic/tclDTrace.d | 215 | ||||
| -rw-r--r-- | generic/tclExecute.c | 32 | ||||
| -rw-r--r-- | generic/tclInt.h | 33 | ||||
| -rw-r--r-- | generic/tclObj.c | 16 | ||||
| -rw-r--r-- | generic/tclProc.c | 54 |
7 files changed, 561 insertions, 22 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 3babbf9..f2490ef 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -9,11 +9,12 @@ * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.267 2007/09/05 21:31:01 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.268 2007/09/13 15:27:06 das Exp $ */ #include "tclInt.h" @@ -93,6 +94,11 @@ static int ExprWideFunc(ClientData clientData, Tcl_Interp *interp, static void MathFuncWrongNumArgs(Tcl_Interp* interp, int expected, int actual, Tcl_Obj *const *objv); +#ifdef USE_DTRACE +static int DTraceObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +#endif + extern TclStubs tclStubs; /* @@ -650,6 +656,14 @@ Tcl_CreateInterp(void) Tcl_CreateObjCommand(interp, "::tcl::Bgerror", TclDefaultBgErrorHandlerObjCmd, NULL, NULL); +#ifdef USE_DTRACE + /* + * Register the tcl::dtrace command. + */ + + Tcl_CreateObjCommand(interp, "::tcl::dtrace", DTraceObjCmd, NULL, NULL); +#endif /* USE_DTRACE */ + /* * Register the builtin math functions. */ @@ -2908,6 +2922,7 @@ CallCommandTraces( * command. This insures that traces get a correct nul-terminated command * string. * + *---------------------------------------------------------------------- */ static Tcl_Obj * @@ -3559,6 +3574,25 @@ TclEvalObjvInternal( } } + if (TCL_DTRACE_CMD_ARGS_ENABLED()) { + char *a[10]; + int i = 0; + + while (i < 10) { + a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++; + } + TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], + a[8], a[9]); + } + if (TCL_DTRACE_CMD_INFO_ENABLED() && iPtr->cmdFramePtr) { + Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); + char *a[4]; int i[2]; + + TclDTraceInfo(info, a, i); + TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1]); + TclDecrRefCount(info); + } + /* * Finally, invoke the command's Tcl_ObjCmdProc. */ @@ -3566,7 +3600,14 @@ TclEvalObjvInternal( cmdPtr->refCount++; iPtr->cmdCount++; if (code == TCL_OK && traceCode == TCL_OK && !TclLimitExceeded(iPtr->limit)) { + if (TCL_DTRACE_CMD_ENTRY_ENABLED()) { + TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, + (Tcl_Obj **)(objv + 1)); + } code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); + if (TCL_DTRACE_CMD_RETURN_ENABLED()) { + TCL_DTRACE_CMD_RETURN(TclGetString(objv[0]), code); + } } if (Tcl_AsyncReady()) { code = Tcl_AsyncInvoke(interp, code); @@ -3623,6 +3664,13 @@ TclEvalObjvInternal( (void) Tcl_GetObjResult(interp); } + if (TCL_DTRACE_CMD_RESULT_ENABLED()) { + Tcl_Obj *r; + + r = Tcl_GetObjResult(interp); + TCL_DTRACE_CMD_RESULT(TclGetString(objv[0]), code, TclGetString(r), r); + } + done: if (savedVarFramePtr) { iPtr->varFramePtr = savedVarFramePtr; @@ -6362,6 +6410,98 @@ MathFuncWrongNumArgs( "too %s arguments for math function \"%s\"", (found < expected ? "few" : "many"), name)); } +#ifdef USE_DTRACE + +/* + *---------------------------------------------------------------------- + * + * DTraceObjCmd -- + * + * This function is invoked to process the "::tcl::dtrace" Tcl command. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * The 'tcl-probe' DTrace probe is triggered (if it is enabled). + * + *---------------------------------------------------------------------- + */ + +static int +DTraceObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (TCL_DTRACE_TCL_PROBE_ENABLED()) { + char *a[10]; + int i = 0; + + while (i++ < 10) { + a[i-1] = i < objc ? TclGetString(objv[i]) : NULL; + } + TCL_DTRACE_TCL_PROBE(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], + a[8], a[9]); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclDTraceInfo -- + * + * Extract information from a TIP280 dict for use by DTrace probes. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclDTraceInfo( + Tcl_Obj *info, + char **args, + int *argsi) +{ + static Tcl_Obj *keys[7] = { NULL }; + Tcl_Obj **k = keys, *val; + int i; + + if (!*k) { + TclNewLiteralStringObj(keys[0], "cmd"); + TclNewLiteralStringObj(keys[1], "type"); + TclNewLiteralStringObj(keys[2], "proc"); + TclNewLiteralStringObj(keys[3], "file"); + TclNewLiteralStringObj(keys[4], "lambda"); + TclNewLiteralStringObj(keys[5], "line"); + TclNewLiteralStringObj(keys[6], "level"); + } + for (i = 0; i < 4; i++) { + Tcl_DictObjGet(NULL, info, *k++, &val); + args[i] = val ? TclGetString(val) : NULL; + } + if (!args[2]) { + Tcl_DictObjGet(NULL, info, *k, &val); + args[2] = val ? TclGetString(val) : NULL; + } + k++; + for (i = 0; i < 2; i++) { + Tcl_DictObjGet(NULL, info, *k++, &val); + if (val) { + Tcl_GetIntFromObj(NULL, val, &(argsi[i])); + } else { + argsi[i] = 0; + } + } +} +#endif /* USE_DTRACE */ /* * Local Variables: diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 50e2312..3db6da9 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -4,11 +4,12 @@ * Copyright (c) 1996-1998 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.h,v 1.78 2007/09/09 16:51:19 dgp Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.79 2007/09/13 15:27:07 das Exp $ */ #ifndef _TCLCOMPILATION @@ -1203,6 +1204,94 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr, #define TclMin(i, j) ((((int) i) < ((int) j))? (i) : (j)) #define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j)) +/* + * DTrace probe macros (NOPs if DTrace support is not enabled). + */ + +#ifdef USE_DTRACE + +#include "tclDTrace.h" + +#if defined(__GNUC__ ) && __GNUC__ > 2 +/* Use gcc branch prediction hint to minimize cost of DTrace ENABLED checks. */ +#define unlikely(x) (__builtin_expect((x), 0)) +#else +#define unlikely(x) (x) +#endif + +#define TCL_DTRACE_PROC_ENTRY_ENABLED() unlikely(TCL_PROC_ENTRY_ENABLED()) +#define TCL_DTRACE_PROC_RETURN_ENABLED() unlikely(TCL_PROC_RETURN_ENABLED()) +#define TCL_DTRACE_PROC_RESULT_ENABLED() unlikely(TCL_PROC_RESULT_ENABLED()) +#define TCL_DTRACE_PROC_ARGS_ENABLED() unlikely(TCL_PROC_ARGS_ENABLED()) +#define TCL_DTRACE_PROC_INFO_ENABLED() unlikely(TCL_PROC_INFO_ENABLED()) +#define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) TCL_PROC_ENTRY(a0, a1, a2) +#define TCL_DTRACE_PROC_RETURN(a0, a1) TCL_PROC_RETURN(a0, a1) +#define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) TCL_PROC_RESULT(a0, a1, a2, a3) +#define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ + TCL_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) +#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5) \ + TCL_PROC_INFO(a0, a1, a2, a3, a4, a5) + +#define TCL_DTRACE_CMD_ENTRY_ENABLED() unlikely(TCL_CMD_ENTRY_ENABLED()) +#define TCL_DTRACE_CMD_RETURN_ENABLED() unlikely(TCL_CMD_RETURN_ENABLED()) +#define TCL_DTRACE_CMD_RESULT_ENABLED() unlikely(TCL_CMD_RESULT_ENABLED()) +#define TCL_DTRACE_CMD_ARGS_ENABLED() unlikely(TCL_CMD_ARGS_ENABLED()) +#define TCL_DTRACE_CMD_INFO_ENABLED() unlikely(TCL_CMD_INFO_ENABLED()) +#define TCL_DTRACE_CMD_ENTRY(a0, a1, a2) TCL_CMD_ENTRY(a0, a1, a2) +#define TCL_DTRACE_CMD_RETURN(a0, a1) TCL_CMD_RETURN(a0, a1) +#define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) TCL_CMD_RESULT(a0, a1, a2, a3) +#define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ + TCL_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) +#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5) \ + TCL_CMD_INFO(a0, a1, a2, a3, a4, a5) + +#define TCL_DTRACE_INST_START_ENABLED() unlikely(TCL_INST_START_ENABLED()) +#define TCL_DTRACE_INST_DONE_ENABLED() unlikely(TCL_INST_DONE_ENABLED()) +#define TCL_DTRACE_INST_START(a0, a1, a2) TCL_INST_START(a0, a1, a2) +#define TCL_DTRACE_INST_DONE(a0, a1, a2) TCL_INST_DONE(a0, a1, a2) + +#define TCL_DTRACE_TCL_PROBE_ENABLED() unlikely(TCL_TCL_PROBE_ENABLED()) +#define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ + TCL_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) + +MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, char **args, int *argsi); + +#else /* USE_DTRACE */ + +#define TCL_DTRACE_PROC_ENTRY_ENABLED() 0 +#define TCL_DTRACE_PROC_RETURN_ENABLED() 0 +#define TCL_DTRACE_PROC_RESULT_ENABLED() 0 +#define TCL_DTRACE_PROC_ARGS_ENABLED() 0 +#define TCL_DTRACE_PROC_INFO_ENABLED() 0 +#define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) {} +#define TCL_DTRACE_PROC_RETURN(a0, a1) {} +#define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) {} +#define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) {} +#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5) {} + +#define TCL_DTRACE_CMD_ENTRY_ENABLED() 0 +#define TCL_DTRACE_CMD_RETURN_ENABLED() 0 +#define TCL_DTRACE_CMD_RESULT_ENABLED() 0 +#define TCL_DTRACE_CMD_ARGS_ENABLED() 0 +#define TCL_DTRACE_CMD_INFO_ENABLED() 0 +#define TCL_DTRACE_CMD_ENTRY(a0, a1, a2) {} +#define TCL_DTRACE_CMD_RETURN(a0, a1) {} +#define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) {} +#define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) {} +#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5) {} + +#define TCL_DTRACE_INST_START_ENABLED() 0 +#define TCL_DTRACE_INST_DONE_ENABLED() 0 +#define TCL_DTRACE_INST_START(a0, a1, a2) {} +#define TCL_DTRACE_INST_DONE(a0, a1, a2) {} + +#define TCL_DTRACE_TCL_PROBE_ENABLED() 0 +#define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) {} + +#define TclDTraceInfo(info, args, argsi) {*args = ""; *argsi = 0;} + +#endif /* USE_DTRACE */ + #endif /* _TCLCOMPILATION */ /* diff --git a/generic/tclDTrace.d b/generic/tclDTrace.d new file mode 100644 index 0000000..d41be9b --- /dev/null +++ b/generic/tclDTrace.d @@ -0,0 +1,215 @@ +/* + * tclDTrace.d -- + * + * Tcl DTrace provider. + * + * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclDTrace.d,v 1.1 2007/09/13 15:27:07 das Exp $ + */ + +typedef struct Tcl_Obj Tcl_Obj; + +/* + * Tcl DTrace probes + */ + +provider tcl { + /***************************** proc probes *****************************/ + /* + * tcl*:::proc-entry probe + * triggered immediately before proc bytecode execution + * arg0: proc name (string) + * arg1: number of arguments (int) + * arg2: array of proc argument objects (Tcl_Obj**) + */ + probe proc__entry(char* name, int objc, Tcl_Obj **objv); + /* + * tcl*:::proc-return probe + * triggered immediately after proc bytecode execution + * arg0: proc name (string) + * arg1: return code (int) + */ + probe proc__return(char* name, int code); + /* + * tcl*:::proc-result probe + * triggered after proc-return probe and result processing + * arg0: proc name (string) + * arg1: return code (int) + * arg2: proc result (string) + * arg3: proc result object (Tcl_Obj*) + */ + probe proc__result(char* name, int code, char* result, Tcl_Obj *resultobj); + /* + * tcl*:::proc-args probe + * triggered before proc-entry probe, gives access to string + * representation of proc arguments + * arg0: proc name (string) + * arg1-arg9: proc arguments or NULL (strings) + */ + probe proc__args(char* name, char* arg1, char* arg2, char* arg3, + char* arg4, char* arg5, char* arg6, char* arg7, char* arg8, + char* arg9); + /* + * tcl*:::proc-info probe + * triggered before proc-entry probe, gives access to TIP 280 + * information for the proc invocation (i.e. [info frame 0]) + * arg0: TIP 280 cmd (string) + * arg1: TIP 280 type (string) + * arg2: TIP 280 proc (string) + * arg3: TIP 280 file (string) + * arg4: TIP 280 line (int) + * arg5: TIP 280 level (int) + */ + probe proc__info(char* cmd, char* type, char* proc, char* file, int line, + int level); + + /***************************** cmd probes ******************************/ + /* + * tcl*:::cmd-entry probe + * triggered immediately before commmand execution + * arg0: command name (string) + * arg1: number of arguments (int) + * arg2: array of command argument objects (Tcl_Obj**) + */ + probe cmd__entry(char* name, int objc, Tcl_Obj **objv); + /* + * tcl*:::cmd-return probe + * triggered immediately after commmand execution + * arg0: command name (string) + * arg1: return code (int) + */ + probe cmd__return(char* name, int code); + /* + * tcl*:::cmd-result probe + * triggered after cmd-return probe and result processing + * arg0: command name (string) + * arg1: return code (int) + * arg2: command result (string) + * arg3: command result object (Tcl_Obj*) + */ + probe cmd__result(char* name, int code, char* result, Tcl_Obj *resultobj); + /* + * tcl*:::cmd-args probe + * triggered before cmd-entry probe, gives access to string + * representation of command arguments + * arg0: command name (string) + * arg1-arg9: command arguments or NULL (strings) + */ + probe cmd__args(char* name, char* arg1, char* arg2, char* arg3, + char* arg4, char* arg5, char* arg6, char* arg7, char* arg8, + char* arg9); + /* + * tcl*:::cmd-info probe + * triggered before cmd-entry probe, gives access to TIP 280 + * information for the command invocation (i.e. [info frame 0]) + * arg0: TIP 280 cmd (string) + * arg1: TIP 280 type (string) + * arg2: TIP 280 proc (string) + * arg3: TIP 280 file (string) + * arg4: TIP 280 line (int) + * arg5: TIP 280 level (int) + */ + probe cmd__info(char* cmd, char* type, char* proc, char* file, int line, + int level); + + /***************************** inst probes *****************************/ + /* + * tcl*:::inst-start probe + * triggered immediately before execution of a bytecode + * arg0: bytecode name (string) + * arg1: depth of stack (int) + * arg2: top of stack (Tcl_Obj**) + */ + probe inst__start(char* name, int depth, Tcl_Obj **stack); + /* + * tcl*:::inst-done probe + * triggered immediately after execution of a bytecode + * arg0: bytecode name (string) + * arg1: depth of stack (int) + * arg2: top of stack (Tcl_Obj**) + */ + probe inst__done(char* name, int depth, Tcl_Obj **stack); + + /***************************** obj probes ******************************/ + /* + * tcl*:::obj-create probe + * triggered immediately after a new Tcl_Obj has been created + * arg0: object created (Tcl_Obj*) + */ + probe obj__create(Tcl_Obj* obj); + /* + * tcl*:::obj-free probe + * triggered immediately before a Tcl_Obj is freed + * arg0: object to be freed (Tcl_Obj*) + */ + probe obj__free(Tcl_Obj* obj); + + /***************************** tcl probes ******************************/ + /* + * tcl*:::tcl-probe probe + * triggered when the ::tcl::dtrace command is called + * arg0-arg9: command arguments (strings) + */ + probe tcl__probe(char* arg0, char* arg1, char* arg2, char* arg3, + char* arg4, char* arg5, char* arg6, char* arg7, char* arg8, + char* arg9); +}; + +/* + * Tcl types and constants for use in DTrace scripts + */ + +typedef struct Tcl_ObjType { + char *name; + void *freeIntRepProc; + void *dupIntRepProc; + void *updateStringProc; + void *setFromAnyProc; +} Tcl_ObjType; + +struct Tcl_Obj { + int refCount; + char *bytes; + int length; + Tcl_ObjType *typePtr; + union { + long longValue; + double doubleValue; + void *otherValuePtr; + int64_t wideValue; + struct { + void *ptr1; + void *ptr2; + } twoPtrValue; + struct { + void *ptr; + unsigned long value; + } ptrAndLongRep; + } internalRep; +}; + +enum return_codes { + TCL_OK = 0, + TCL_ERROR, + TCL_RETURN, + TCL_BREAK, + TCL_CONTINUE +}; + +#pragma D attributes Evolving/Evolving/Common provider tcl provider +#pragma D attributes Private/Private/Common provider tcl module +#pragma D attributes Private/Private/Common provider tcl function +#pragma D attributes Evolving/Evolving/Common provider tcl name +#pragma D attributes Evolving/Evolving/Common provider tcl args + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d2bec9b..584c747 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -8,11 +8,12 @@ * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2002-2005 by Miguel Sofer. * Copyright (c) 2005-2007 by Donal K. Fellows. + * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.335 2007/09/11 14:47:43 msofer Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.336 2007/09/13 15:27:07 das Exp $ */ #include "tclInt.h" @@ -318,6 +319,28 @@ VarHashCreateVar(TclVarHashTable *tablePtr, Tcl_Obj *key, int *newPtr) #endif /* TCL_COMPILE_DEBUG */ /* + * DTrace instruction probe macros. + */ + +#define TCL_DTRACE_INST_NEXT() \ + if (TCL_DTRACE_INST_DONE_ENABLED()) {\ + if (curInstName) {\ + TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\ + }\ + curInstName = tclInstructionTable[*pc].name;\ + if (TCL_DTRACE_INST_START_ENABLED()) {\ + TCL_DTRACE_INST_START(curInstName, (int) CURR_DEPTH, tosPtr);\ + }\ + } else if (TCL_DTRACE_INST_START_ENABLED()) {\ + TCL_DTRACE_INST_START(tclInstructionTable[*pc].name, (int) CURR_DEPTH,\ + tosPtr);\ + } +#define TCL_DTRACE_INST_LAST() \ + if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) {\ + TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\ + } + +/* * Macro used in this file to save a function call for common uses of * TclGetNumberFromObj(). The ANSI C "prototype" is: * @@ -1555,6 +1578,7 @@ TclExecuteByteCode( int traceInstructions = (tclTraceExec == 3); char cmdNameBuf[21]; #endif + char *curInstName = NULL; /* * The execution uses a unified stack: first the catch stack, immediately @@ -1693,6 +1717,8 @@ TclExecuteByteCode( iPtr->stats.instructionCount[*pc]++; #endif + TCL_DTRACE_INST_NEXT(); + /* * Check for asynchronous handlers [Bug 746722]; we do the check every * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1). @@ -1818,6 +1844,7 @@ TclExecuteByteCode( */ if (*pc == INST_PUSH1) { + TCL_DTRACE_INST_NEXT(); goto instPush1Peephole; } #endif @@ -1844,6 +1871,7 @@ TclExecuteByteCode( pc++; #if !TCL_COMPILE_DEBUG if (*pc == INST_START_CMD) { + TCL_DTRACE_INST_NEXT(); goto instStartCmdPeephole; } #endif @@ -6095,6 +6123,7 @@ TclExecuteByteCode( */ pc += 5; + TCL_DTRACE_INST_NEXT(); #else NEXT_INST_F(5, 0, 0); #endif @@ -7008,6 +7037,7 @@ TclExecuteByteCode( abnormalReturn: { + TCL_DTRACE_INST_LAST(); while (tosPtr > initTosPtr) { Tcl_Obj *objPtr = POP_OBJECT(); Tcl_DecrRefCount(objPtr); diff --git a/generic/tclInt.h b/generic/tclInt.h index 6636f1e..9ba2331 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -8,11 +8,12 @@ * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.334 2007/09/09 19:28:31 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.335 2007/09/13 15:27:08 das Exp $ */ #ifndef _TCLINT @@ -2396,6 +2397,7 @@ MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr); MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); +MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr); MODULE_SCOPE int TclInfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int TclInfoLocalsCmd(ClientData dummy, Tcl_Interp *interp, @@ -3067,6 +3069,19 @@ MODULE_SCOPE int TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr, *---------------------------------------------------------------- */ +/* + * DTrace object allocation probe macros. + */ + +#ifdef USE_DTRACE +#include "tclDTrace.h" +#define TCL_DTRACE_OBJ_CREATE(objPtr) TCL_OBJ_CREATE(objPtr) +#define TCL_DTRACE_OBJ_FREE(objPtr) TCL_OBJ_FREE(objPtr) +#else /* USE_DTRACE */ +#define TCL_DTRACE_OBJ_CREATE(objPtr) {} +#define TCL_DTRACE_OBJ_FREE(objPtr) {} +#endif /* USE_DTRACE */ + #ifdef TCL_COMPILE_STATS # define TclIncrObjsAllocated() \ tclObjsAlloced++ @@ -3084,7 +3099,8 @@ MODULE_SCOPE int TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr, (objPtr)->refCount = 0; \ (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ - (objPtr)->typePtr = NULL + (objPtr)->typePtr = NULL; \ + TCL_DTRACE_OBJ_CREATE(objPtr) /* * Invalidate the string rep first so we can use the bytes value for our @@ -3096,6 +3112,7 @@ MODULE_SCOPE int TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr, # define TclDecrRefCount(objPtr) \ if (--(objPtr)->refCount > 0) ; else { \ if (!(objPtr)->typePtr || !(objPtr)->typePtr->freeIntRepProc) { \ + TCL_DTRACE_OBJ_FREE(objPtr); \ if ((objPtr)->bytes \ && ((objPtr)->bytes != tclEmptyStringRep)) { \ ckfree((char *) (objPtr)->bytes); \ @@ -3176,7 +3193,8 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr); # define TclDbNewObj(objPtr, file, line) \ TclIncrObjsAllocated(); \ (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \ - TclDbInitNewObj(objPtr); + TclDbInitNewObj(objPtr); \ + TCL_DTRACE_OBJ_CREATE(objPtr) # define TclNewObj(objPtr) \ TclDbNewObj(objPtr, __FILE__, __LINE__); @@ -3423,7 +3441,8 @@ MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int *bignum, (objPtr)->refCount = 0; \ (objPtr)->bytes = NULL; \ (objPtr)->internalRep.longValue = (long)(i); \ - (objPtr)->typePtr = &tclIntType + (objPtr)->typePtr = &tclIntType; \ + TCL_DTRACE_OBJ_CREATE(objPtr) #define TclNewLongObj(objPtr, l) \ TclNewIntObj((objPtr), (l)) @@ -3441,14 +3460,16 @@ MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int *bignum, (objPtr)->refCount = 0; \ (objPtr)->bytes = NULL; \ (objPtr)->internalRep.doubleValue = (double)(d); \ - (objPtr)->typePtr = &tclDoubleType + (objPtr)->typePtr = &tclDoubleType; \ + TCL_DTRACE_OBJ_CREATE(objPtr) #define TclNewStringObj(objPtr, s, len) \ TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ TclInitStringRep((objPtr), (s), (len));\ - (objPtr)->typePtr = NULL + (objPtr)->typePtr = NULL; \ + TCL_DTRACE_OBJ_CREATE(objPtr) #else /* TCL_MEM_DEBUG */ #define TclNewIntObj(objPtr, i) \ diff --git a/generic/tclObj.c b/generic/tclObj.c index 574947b..ee9807d 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -8,11 +8,12 @@ * Copyright (c) 1999 by Scriptics Corporation. * Copyright (c) 2001 by ActiveState Corporation. * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclObj.c,v 1.134 2007/09/09 19:28:31 dgp Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.135 2007/09/13 15:27:08 das Exp $ */ #include "tclInt.h" @@ -857,6 +858,7 @@ TclFreeObj( if (ObjDeletePending(context)) { PushObjToDelete(context, objPtr); } else { + TCL_DTRACE_OBJ_FREE(objPtr); if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { ObjDeletionLock(context); typePtr->freeIntRepProc(objPtr); @@ -866,22 +868,19 @@ TclFreeObj( Tcl_MutexLock(&tclObjMutex); ckfree((char *) objPtr); Tcl_MutexUnlock(&tclObjMutex); -#ifdef TCL_COMPILE_STATS - tclObjsFreed++; -#endif /* TCL_COMPILE_STATS */ + TclIncrObjsFreed(); ObjDeletionLock(context); while (ObjOnStack(context)) { Tcl_Obj *objToFree; PopObjToDelete(context,objToFree); + TCL_DTRACE_OBJ_FREE(objToFree); TclFreeIntRep(objToFree); Tcl_MutexLock(&tclObjMutex); ckfree((char *) objToFree); Tcl_MutexUnlock(&tclObjMutex); -#ifdef TCL_COMPILE_STATS - tclObjsFreed++; -#endif /* TCL_COMPILE_STATS */ + TclIncrObjsFreed(); } ObjDeletionUnlock(context); } @@ -905,6 +904,7 @@ TclFreeObj( * other objects: it will not cause recursive calls to this function. */ + TCL_DTRACE_OBJ_FREE(objPtr); TclFreeObjStorage(objPtr); TclIncrObjsFreed(); } else { @@ -927,6 +927,7 @@ TclFreeObj( * satisfy this. */ + TCL_DTRACE_OBJ_FREE(objPtr); ObjDeletionLock(context); objPtr->typePtr->freeIntRepProc(objPtr); ObjDeletionUnlock(context); @@ -937,6 +938,7 @@ TclFreeObj( while (ObjOnStack(context)) { Tcl_Obj *objToFree; PopObjToDelete(context,objToFree); + TCL_DTRACE_OBJ_FREE(objToFree); if ((objToFree->typePtr != NULL) && (objToFree->typePtr->freeIntRepProc != NULL)) { objToFree->typePtr->freeIntRepProc(objToFree); diff --git a/generic/tclProc.c b/generic/tclProc.c index cd85e73..7008187 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -7,11 +7,12 @@ * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 2004-2006 Miguel Sofer + * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.133 2007/09/09 19:28:31 dgp Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.134 2007/09/13 15:27:08 das Exp $ */ #include "tclInt.h" @@ -1645,7 +1646,8 @@ TclObjInterpProcCore( ProcErrorProc errorProc) /* How to convert results from the script into * results of the overall procedure. */ { - register Proc *procPtr = ((Interp *)interp)->varFramePtr->procPtr; + Interp *iPtr = (Interp *) interp; + register Proc *procPtr = iPtr->varFramePtr->procPtr; int result; CallFrame *freePtr; @@ -1656,7 +1658,7 @@ TclObjInterpProcCore( #if defined(TCL_COMPILE_DEBUG) if (tclTraceExec >= 1) { - register CallFrame *framePtr = ((Interp *)interp)->varFramePtr; + register CallFrame *framePtr = iPtr->varFramePtr; register int i; if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { @@ -1673,12 +1675,33 @@ TclObjInterpProcCore( } #endif /*TCL_COMPILE_DEBUG*/ + if (TCL_DTRACE_PROC_ARGS_ENABLED()) { + char *a[10]; + int i = 0; + int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + + while (i < 10) { + a[i] = (l < iPtr->varFramePtr->objc ? + TclGetString(iPtr->varFramePtr->objv[l]) : NULL); i++; l++; + } + TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], + a[8], a[9]); + } + if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) { + Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); + char *a[4]; int i[2]; + + TclDTraceInfo(info, a, i); + TCL_DTRACE_PROC_INFO(a[0], a[1], a[2], a[3], i[0], i[1]); + TclDecrRefCount(info); + } + /* * Invoke the commands in the procedure's body. */ procPtr->refCount++; - ((Interp *)interp)->numLevels++; + iPtr->numLevels++; if (TclInterpReady(interp) == TCL_ERROR) { result = TCL_ERROR; @@ -1687,14 +1710,25 @@ TclObjInterpProcCore( procPtr->bodyPtr->internalRep.otherValuePtr; codePtr->refCount++; + if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { + int l; + + l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 2 : 1; + TCL_DTRACE_PROC_ENTRY(TclGetString(procNameObj), + iPtr->varFramePtr->objc - l, + (Tcl_Obj **)(iPtr->varFramePtr->objv + l)); + } result = TclExecuteByteCode(interp, codePtr); + if (TCL_DTRACE_PROC_RETURN_ENABLED()) { + TCL_DTRACE_PROC_RETURN(TclGetString(procNameObj), result); + } codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } } - ((Interp *)interp)->numLevels--; + iPtr->numLevels--; procPtr->refCount--; if (procPtr->refCount <= 0) { TclProcCleanupProc(procPtr); @@ -1754,6 +1788,14 @@ TclObjInterpProcCore( (void) 0; /* do nothing */ } + if (TCL_DTRACE_PROC_RESULT_ENABLED()) { + Tcl_Obj *r; + + r = Tcl_GetObjResult(interp); + TCL_DTRACE_PROC_RESULT(TclGetString(procNameObj), result, + TclGetString(r), r); + } + procDone: /* * Free the stack-allocated compiled locals and CallFrame. It is important @@ -1763,7 +1805,7 @@ TclObjInterpProcCore( * allocated later on the stack. */ - freePtr = ((Interp *)interp)->framePtr; + freePtr = iPtr->framePtr; Tcl_PopCallFrame(interp); /* Pop but do not free. */ TclStackFree(interp, freePtr->compiledLocals); /* Free compiledLocals. */ |