diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclBasic.c | 79 | ||||
| -rw-r--r-- | generic/tclCompile.h | 77 | ||||
| -rw-r--r-- | generic/tclDTrace.d | 185 | ||||
| -rw-r--r-- | generic/tclExecute.c | 33 | ||||
| -rw-r--r-- | generic/tclInt.h | 24 | ||||
| -rw-r--r-- | generic/tclObj.c | 8 | ||||
| -rw-r--r-- | generic/tclProc.c | 29 |
7 files changed, 424 insertions, 11 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 diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 1769a76..06414fd 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.33.2.1 2006/11/28 22:20:00 andreas_kupries Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.33.2.2 2007/09/13 15:28:11 das Exp $ */ #ifndef _TCLCOMPILATION @@ -1082,6 +1083,80 @@ EXTERN int TclCompileVariableCmd _ANSI_ARGS_(( #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_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_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_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_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) + +#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_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_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_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_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) {} + +#endif /* USE_DTRACE */ + # undef TCL_STORAGE_CLASS # define TCL_STORAGE_CLASS DLLIMPORT diff --git a/generic/tclDTrace.d b/generic/tclDTrace.d new file mode 100644 index 0000000..550539d --- /dev/null +++ b/generic/tclDTrace.d @@ -0,0 +1,185 @@ +/* + * 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.2.2 2007/09/13 15:28:12 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); + + /***************************** 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); + + /***************************** 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; + } 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 4fd6dcc..c0deb73 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -11,7 +11,7 @@ * 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.94.2.21 2007/03/13 16:26:32 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.94.2.22 2007/09/13 15:28:12 das Exp $ */ #include "tclInt.h" @@ -259,6 +259,31 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; #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, stackTop - initStackTop,\ + stackPtr + stackTop);\ + }\ + curInstName = tclInstructionTable[*pc].name;\ + if (TCL_DTRACE_INST_START_ENABLED()) {\ + TCL_DTRACE_INST_START(curInstName, stackTop - initStackTop,\ + stackPtr + stackTop);\ + }\ + } else if (TCL_DTRACE_INST_START_ENABLED()) {\ + TCL_DTRACE_INST_START(tclInstructionTable[*pc].name,\ + stackTop - initStackTop, stackPtr + stackTop);\ + } +#define TCL_DTRACE_INST_LAST() \ + if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) {\ + TCL_DTRACE_INST_DONE(curInstName, stackTop - initStackTop,\ + stackPtr + stackTop);\ + } + +/* * Macro to read a string containing either a wide or an int and * decide which it is while decoding it at the same time. This * enforces the policy that integer constants between LONG_MIN and @@ -1115,6 +1140,7 @@ TclExecuteByteCode(interp, codePtr) int traceInstructions = (tclTraceExec == 3); char cmdNameBuf[21]; #endif + char *curInstName = NULL; /* * This procedure uses a stack to hold information about catch commands. @@ -1259,6 +1285,9 @@ TclExecuteByteCode(interp, codePtr) #ifdef TCL_COMPILE_STATS iPtr->stats.instructionCount[*pc]++; #endif + + TCL_DTRACE_INST_NEXT(); + switch (*pc) { case INST_DONE: if (stackTop <= initStackTop) { @@ -4035,6 +4064,7 @@ TclExecuteByteCode(interp, codePtr) */ pc += 5; + TCL_DTRACE_INST_NEXT(); #else NEXT_INST_F(5, 0, 0); #endif @@ -4390,6 +4420,7 @@ TclExecuteByteCode(interp, codePtr) */ abnormalReturn: + TCL_DTRACE_INST_LAST(); while (stackTop > initStackTop) { valuePtr = POP_OBJECT(); TclDecrRefCount(valuePtr); diff --git a/generic/tclInt.h b/generic/tclInt.h index 9d05bd4..76544c0 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.118.2.29 2007/08/23 00:27:21 das Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.118.2.30 2007/09/13 15:28:13 das Exp $ */ #ifndef _TCLINT @@ -2300,6 +2301,19 @@ EXTERN Tcl_Obj *TclPtrIncrVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr, *---------------------------------------------------------------- */ +/* + * 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++ @@ -2316,7 +2330,8 @@ EXTERN Tcl_Obj *TclPtrIncrVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr, (objPtr)->refCount = 0; \ (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ - (objPtr)->typePtr = NULL + (objPtr)->typePtr = NULL; \ + TCL_DTRACE_OBJ_CREATE(objPtr) #ifdef TCL_MEM_DEBUG @@ -2325,6 +2340,7 @@ EXTERN Tcl_Obj *TclPtrIncrVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr, #else # define TclDecrRefCount(objPtr) \ if (--(objPtr)->refCount <= 0) { \ + TCL_DTRACE_OBJ_FREE(objPtr); \ if (((objPtr)->typePtr != NULL) \ && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ (objPtr)->typePtr->freeIntRepProc(objPtr); \ @@ -2356,7 +2372,9 @@ EXTERN Tcl_Obj *TclPtrIncrVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr, (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ (objPtr)->typePtr = NULL; \ - TclIncrObjsAllocated() + TclIncrObjsAllocated(); \ + TCL_DTRACE_OBJ_CREATE(objPtr) + #elif defined(PURIFY) diff --git a/generic/tclObj.c b/generic/tclObj.c index 9d480d5..092dc1a 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -7,11 +7,12 @@ * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. * Copyright (c) 2001 by ActiveState Corporation. + * 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.42.2.14 2005/11/29 14:02:04 dkf Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.42.2.15 2007/09/13 15:28:13 das Exp $ */ #include "tclInt.h" @@ -674,6 +675,7 @@ TclFreeObj(objPtr) } #endif /* TCL_MEM_DEBUG */ + TCL_DTRACE_OBJ_FREE(objPtr); if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { typePtr->freeIntRepProc(objPtr); } @@ -698,9 +700,7 @@ TclFreeObj(objPtr) Tcl_MutexUnlock(&tclObjMutex); #endif /* TCL_MEM_DEBUG */ -#ifdef TCL_COMPILE_STATS - tclObjsFreed++; -#endif /* TCL_COMPILE_STATS */ + TclIncrObjsFreed(); } /* diff --git a/generic/tclProc.c b/generic/tclProc.c index 3ecf243..d903ae6 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -6,11 +6,12 @@ * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. + * 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.44.2.6 2006/11/28 22:20:02 andreas_kupries Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.44.2.7 2007/09/13 15:28:17 das Exp $ */ #include "tclInt.h" @@ -1158,8 +1159,23 @@ TclObjInterpProc(clientData, interp, objc, objv) } #endif /*TCL_COMPILE_DEBUG*/ + if (TCL_DTRACE_PROC_ARGS_ENABLED()) { + char *a[10]; + int i = 0; + + while (i < 10) { + a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++; + } + TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], + a[8], a[9]); + } + iPtr->returnCode = TCL_OK; procPtr->refCount++; + if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { + TCL_DTRACE_PROC_ENTRY(TclGetString(objv[0]), objc - 1, + (Tcl_Obj **)(objv + 1)); + } #ifndef TCL_TIP280 result = TclCompEvalObj(interp, procPtr->bodyPtr); #else @@ -1169,6 +1185,9 @@ TclObjInterpProc(clientData, interp, objc, objv) result = TclCompEvalObj(interp, procPtr->bodyPtr, NULL, 0); #endif + if (TCL_DTRACE_PROC_RETURN_ENABLED()) { + TCL_DTRACE_PROC_RETURN(TclGetString(objv[0]), result); + } procPtr->refCount--; if (procPtr->refCount <= 0) { TclProcCleanupProc(procPtr); @@ -1178,6 +1197,14 @@ TclObjInterpProc(clientData, interp, objc, objv) result = ProcessProcResultCode(interp, procName, nameLen, result); } + if (TCL_DTRACE_PROC_RESULT_ENABLED()) { + Tcl_Obj *r; + + r = Tcl_GetObjResult(interp); + TCL_DTRACE_PROC_RESULT(TclGetString(objv[0]), result, + TclGetString(r), r); + } + /* * Pop and free the call frame for this procedure invocation, then * free the compiledLocals array if malloc'ed storage was used. |