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