diff options
author | das <das@noemail.net> | 2007-09-13 15:28:09 (GMT) |
---|---|---|
committer | das <das@noemail.net> | 2007-09-13 15:28:09 (GMT) |
commit | aca06afb4efb254fbc9c145875851cf09e0691b9 (patch) | |
tree | 593d357422c91ee5b5623ed463f7d5629d99a4a5 /generic/tclBasic.c | |
parent | d4a95d0141489d80a35a91f45a033447479b8539 (diff) | |
download | tcl-aca06afb4efb254fbc9c145875851cf09e0691b9.zip tcl-aca06afb4efb254fbc9c145875851cf09e0691b9.tar.gz tcl-aca06afb4efb254fbc9c145875851cf09e0691b9.tar.bz2 |
* 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/Makefile: enable DTrace support.
* unix/configure: autoconf-2.13
FossilOrigin-Name: 9eb5b5b76c36ef5452df1d5d43ec78519fadb17b
Diffstat (limited to 'generic/tclBasic.c')
-rw-r--r-- | generic/tclBasic.c | 79 |
1 files changed, 78 insertions, 1 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 76f439c..270f3e2 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.75.2.26 2006/11/28 22:19:59 andreas_kupries Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.75.2.27 2007/09/13 15:28:10 das Exp $ */ #include "tclInt.h" @@ -52,6 +53,11 @@ static int EvalTokensStandard _ANSI_ARGS_((Tcl_Interp *interp, #endif +#ifdef USE_DTRACE +static int DTraceObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +#endif + extern TclStubs tclStubs; /* @@ -508,6 +514,14 @@ Tcl_CreateInterp() } } +#ifdef USE_DTRACE + /* + * Register the tcl::dtrace command. + */ + + Tcl_CreateObjCommand(interp, "::tcl::dtrace", DTraceObjCmd, NULL, NULL); +#endif /* USE_DTRACE */ + /* * Register the builtin math functions. */ @@ -3181,13 +3195,31 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) break; } + 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]); + } + /* * Finally, invoke the command's Tcl_ObjCmdProc. */ cmdPtr->refCount++; iPtr->cmdCount++; if ( code == TCL_OK && traceCode == TCL_OK) { + 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); @@ -3235,6 +3267,13 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) (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: iPtr->varFramePtr = savedVarFramePtr; return code; @@ -6082,8 +6121,46 @@ Tcl_GetVersion(majorV, minorV, patchLevelV, type) *type = TCL_RELEASE_LEVEL; } } +#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; +} +#endif /* USE_DTRACE */ + +/* * Local Variables: * mode: c * c-basic-offset: 4 |