1/* -*- Mode: c++ -*- 2 * $Id: xotclTrace.c,v 1.8 2006/09/27 08:12:40 neumann Exp $ 3 * 4 * Extended Object Tcl (XOTcl) 5 * 6 * Copyright (C) 1999-2008 Gustaf Neumann, Uwe Zdun 7 * 8 * 9 * xotclTrace.c -- 10 * 11 * Tracing facilities for XOTcl 12 * 13 */ 14 15#include "xotclInt.h" 16#include "xotclAccessInt.h" 17 18void 19XOTclStackDump(Tcl_Interp *interp) { 20 Interp *iPtr = (Interp *)interp; 21 CallFrame *f = iPtr->framePtr, *v = iPtr->varFramePtr; 22 Tcl_Obj *varCmdObj; 23 24 XOTclNewObj(varCmdObj); 25 fprintf (stderr, " TCL STACK:\n"); 26 if (f == 0) fprintf(stderr, "- "); 27 while (f) { 28 Tcl_Obj *cmdObj; 29 XOTclNewObj(cmdObj); 30 fprintf(stderr, "\tFrame=%p ", f); 31 if (f && f->isProcCallFrame && f->procPtr && f->procPtr->cmdPtr) { 32 fprintf(stderr,"caller %p ",Tcl_CallFrame_callerPtr(f)); 33 fprintf(stderr,"callerV %p ",Tcl_CallFrame_callerVarPtr(f)); 34 Tcl_GetCommandFullName(interp, (Tcl_Command) f->procPtr->cmdPtr, cmdObj); 35 fprintf(stderr, "%s (%p) lvl=%d\n", ObjStr(cmdObj), f->procPtr->cmdPtr, f->level); 36 DECR_REF_COUNT(cmdObj); 37 } else fprintf(stderr, "- \n"); 38 39 f = f->callerPtr; 40 } 41 42 fprintf (stderr, " VARFRAME:\n"); 43 fprintf(stderr, "\tFrame=%p", v); 44 if (v) {fprintf(stderr, "caller %p", v->callerPtr);} 45 if (v && v->isProcCallFrame && v->procPtr && v->procPtr->cmdPtr) { 46 Tcl_GetCommandFullName(interp, (Tcl_Command) v->procPtr->cmdPtr, varCmdObj); 47 if (varCmdObj) { 48 fprintf(stderr, " %s (%d)\n", ObjStr(varCmdObj), v->level); 49 } 50 } else fprintf(stderr, "- \n"); 51 DECR_REF_COUNT(varCmdObj); 52} 53 54void 55XOTclCallStackDump(Tcl_Interp *interp) { 56 XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; 57 XOTclCallStackContent *csc; 58 int i=1, entries = cs->top - cs->content; 59 60 fprintf (stderr, " XOTCL CALLSTACK: (%d entries, top: %p) \n", entries, cs->top); 61 for (csc = &cs->content[1]; csc <= cs->top; csc++) { 62 fprintf(stderr, " %d: %p ",i++,csc); 63 if (csc->self) 64 fprintf(stderr, "OBJ %s (%p), ", ObjStr(csc->self->cmdName), csc->self); 65 if (csc->cl) 66 fprintf(stderr, "INSTPROC %s->", className(csc->cl)); 67 else 68 fprintf(stderr, "PROC "); 69 70 /*fprintf(stderr, " cmd %p, obj %p, ",csc->cmdPtr, csc->self);*/ 71 72 if (csc->cmdPtr && !csc->destroyedCmd) 73 fprintf(stderr, "%s (%p), ", Tcl_GetCommandName(interp, (Tcl_Command)csc->cmdPtr), 74 csc->cmdPtr); 75 else 76 fprintf(stderr, "NULL, "); 77 78 fprintf(stderr, "frameType: %d, ", csc->frameType); 79 fprintf(stderr, "callType: %d ", csc->callType); 80 fprintf(stderr, "cframe %p ", csc->currentFramePtr); 81 82 if (csc->currentFramePtr) 83 fprintf(stderr,"l=%d ",Tcl_CallFrame_level(csc->currentFramePtr)); 84 85 if (csc->destroyedCmd) 86 fprintf(stderr, "--destroyed cmd set (%p) ", csc->destroyedCmd); 87 88 fprintf(stderr, "\n"); 89 } 90 /* 91 if (entries > 0) { 92 XOTclCallStackContent *c; 93 c = XOTclCallStackFindLastInvocation(interp); 94 fprintf(stderr," --- findLastInvocation %p ",c); 95 if (c) { 96 if (c <= cs->top && c->currentFramePtr) 97 fprintf(stderr," l=%d", Tcl_CallFrame_level(c->currentFramePtr)); 98 } 99 c = XOTclCallStackFindActiveFrame(interp, 1); 100 fprintf(stderr," findActiveFrame %p ",c); 101 if (c) { 102 if (c <= cs->top && c->currentFramePtr) 103 fprintf(stderr," l=%d", Tcl_CallFrame_level(c->currentFramePtr)); 104 } 105 fprintf(stderr," --- \n"); 106 } 107 */ 108} 109 110/* helper function to print the vars dynamically created on a 111 callframe 112static void printLocalTable (CallFrame *c) { 113 Tcl_HashEntry *entryPtr; 114 Tcl_HashTable *localVarTablePtr = c->varTablePtr; 115 Tcl_HashSearch search; 116 117 fprintf(stderr, "LocalVars:"); 118 119 if (localVarTablePtr != NULL) { 120 for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search); 121 entryPtr != NULL; 122 entryPtr = Tcl_NextHashEntry(&search)) { 123 char *varName = Tcl_GetHashKey(localVarTablePtr, entryPtr); 124 fprintf(stderr, " %s,", varName); 125 } 126 } 127 fprintf(stderr,"\n"); 128} 129*/ 130 131int 132XOTcl_TraceObjCmd(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { 133 char *option; 134 if (objc != 2) 135 return XOTclObjErrArgCnt(interp, NULL, "::xotcl::trace"); 136 137 option = ObjStr(objv[1]); 138 if (strcmp(option,"stack") == 0) { 139 XOTclStackDump(interp); 140 return TCL_OK; 141 } 142 if (strcmp(option,"callstack") == 0) { 143 XOTclCallStackDump(interp); 144 return TCL_OK; 145 } 146 return XOTclVarErrMsg(interp, "xotcltrace: unknown option", (char*) NULL); 147} 148 149#ifdef XOTCL_MEM_COUNT 150void 151XOTclMemCountAlloc(char *id, void *p) { 152 int new; 153 XOTclMemCounter *entry; 154 Tcl_HashTable *table = &xotclMemCount; 155 Tcl_HashEntry *hPtr; 156 hPtr = Tcl_CreateHashEntry(table, id, &new); 157#ifdef XOTCL_MEM_TRACE 158 fprintf(stderr, "+++ alloc %s %p\n",id,p); 159#endif 160 /*fprintf(stderr,"+++alloc '%s'\n",id);*/ 161 if (new) { 162 entry = (XOTclMemCounter*)ckalloc(sizeof(XOTclMemCounter)); 163 entry->count = 1; 164 entry->peak = 1; 165 Tcl_SetHashValue(hPtr, entry); 166 } else { 167 entry = (XOTclMemCounter*) Tcl_GetHashValue(hPtr); 168 entry->count++; 169 if (entry->count > entry->peak) 170 entry->peak = entry->count; 171 } 172} 173 174void 175XOTclMemCountFree(char *id, void *p) { 176 XOTclMemCounter *entry; 177 Tcl_HashTable *table = &xotclMemCount; 178 Tcl_HashEntry *hPtr; 179#ifdef XOTCL_MEM_TRACE 180 fprintf(stderr, "+++ free %s %p\n",id,p); 181#endif 182 183 hPtr = Tcl_FindHashEntry(table, id); 184 if (!hPtr) { 185 fprintf(stderr, "******** MEM COUNT ALERT: Trying to free <%s>, but was not allocated\n", id); 186 return; 187 } 188 entry = (XOTclMemCounter*) Tcl_GetHashValue(hPtr); 189 entry->count--; 190} 191 192void 193XOTclMemCountDump() { 194 Tcl_HashTable *table = &xotclMemCount; 195 Tcl_HashSearch search; 196 Tcl_HashEntry *hPtr; 197 int count = 0; 198 199 xotclMemCountInterpCounter--; 200 if (xotclMemCountInterpCounter != 0) { 201 return; 202 } 203 204 fprintf(stderr, "******** XOTcl MEM Count *********\n* count peak\n"); 205 206 for (hPtr = Tcl_FirstHashEntry(table, &search); hPtr != NULL; 207 hPtr = Tcl_NextHashEntry(&search)) { 208 char *id = Tcl_GetHashKey(table, hPtr); 209 XOTclMemCounter *entry = (XOTclMemCounter*) Tcl_GetHashValue(hPtr); 210 count += entry->count; 211 fprintf(stderr, "* %4d %6d %s\n", entry->count, entry->peak, id); 212 ckfree ((char*) entry); 213 } 214 215 Tcl_DeleteHashTable(table); 216 217 fprintf(stderr, "******** Count Overall = %d\n", count); 218} 219 220#endif 221