* generic/tclDTrace.d (new file): add DTrace provider for Tcl; allows

	* generic/tclCompile.h:		  tracing of proc and command entry &
	* generic/tclBasic.c:		  return, bytecode execution, object
	* generic/tclExecute.c:		  allocation and more; with essentially
	* generic/tclInt.h:		  zero cost when tracing is inactive;
	* generic/tclObj.c:		  enable with --enable-dtrace configure
	* generic/tclProc.c:		  arg (disabled by default, will only
	* unix/Makefile.in:		  enable if DTrace is present).
	* unix/configure.in:		  [Patch 1793984]

	* macosx/GNUmakefile:		  enable DTrace support.
	* macosx/Tcl-Common.xcconfig:
	* macosx/Tcl.xcodeproj/project.pbxproj:

	* unix/configure: autoconf-2.59
	* unix/tclConfig.h.in: autoheader-2.59

1 files changed, 141 insertions, 1 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: