summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c142
-rw-r--r--generic/tclCompile.h91
-rw-r--r--generic/tclDTrace.d215
-rw-r--r--generic/tclExecute.c32
-rw-r--r--generic/tclInt.h33
-rw-r--r--generic/tclObj.c16
-rw-r--r--generic/tclProc.c54
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. */