void
XOTclStackDump(Tcl_Interp *interp) {
Interp *iPtr = (Interp *)interp;
CallFrame *f = iPtr->framePtr, *v = iPtr->varFramePtr;
Tcl_Obj *varCmdObj;
XOTclNewObj(varCmdObj);
fprintf (stderr, " TCL STACK:\n");
if (f == 0) fprintf(stderr, "- ");
while (f) {
Tcl_Obj *cmdObj;
XOTclNewObj(cmdObj);
fprintf(stderr, "\tFrame=%p ", f);
if (f && f->isProcCallFrame && f->procPtr && f->procPtr->cmdPtr) {
fprintf(stderr,"caller %p ",Tcl_CallFrame_callerPtr(f));
fprintf(stderr,"callerV %p ",Tcl_CallFrame_callerVarPtr(f));
Tcl_GetCommandFullName(interp, (Tcl_Command) f->procPtr->cmdPtr, cmdObj);
fprintf(stderr, "%s (%p) lvl=%d\n", ObjStr(cmdObj), f->procPtr->cmdPtr, f->level);
DECR_REF_COUNT(cmdObj);
} else fprintf(stderr, "- \n");
f = f->callerPtr;
}
fprintf (stderr, " VARFRAME:\n");
fprintf(stderr, "\tFrame=%p", v);
if (v) {fprintf(stderr, "caller %p", v->callerPtr);}
if (v && v->isProcCallFrame && v->procPtr && v->procPtr->cmdPtr) {
Tcl_GetCommandFullName(interp, (Tcl_Command) v->procPtr->cmdPtr, varCmdObj);
if (varCmdObj) {
fprintf(stderr, " %s (%d)\n", ObjStr(varCmdObj), v->level);
}
} else fprintf(stderr, "- \n");
DECR_REF_COUNT(varCmdObj);
}
/*
*----------------------------------------------------------------------
*
* NsfMethodObjSet --
*
* Convert the provided Tcl_Obj into the type of NsfMethodContext.
*
*----------------------------------------------------------------------
*/
int
NsfMethodObjSet(
Tcl_Interp *UNUSED(interp), /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr, /* The object to convert. */
const Tcl_ObjType *objectType,
void *context, /* context (to avoid over-eager sharing) */
unsigned int methodEpoch, /* methodEpoch */
Tcl_Command cmd, /* the Tcl command behind the method */
NsfClass *cl, /* the object/class where the method was defined */
unsigned int flags /* flags */
) {
NsfMethodContext *mcPtr;
#if defined(METHOD_OBJECT_TRACE)
fprintf(stderr, "... NsfMethodObjSet %p %s context %p methodEpoch %d "
"cmd %p cl %p %s old obj type <%s> flags %.6x\n",
objPtr, ObjStr(objPtr), context, methodEpoch, cmd, cl,
(cl != NULL) ? ClassName(cl) : "obj",
(objPtr->typePtr != NULL) ? objPtr->typePtr->name : "none", flags);
#endif
/*
* Free or reuse the old internal representation and store own
* structure as internal representation.
*/
if (objPtr->typePtr != objectType) {
#if defined(METHOD_OBJECT_TRACE)
fprintf(stderr, "... NsfMethodObjSet frees old int rep %s\n", (objPtr->typePtr != NULL) ? objPtr->typePtr->name : "none");
#endif
TclFreeIntRep(objPtr);
mcPtr = NEW(NsfMethodContext);
/*fprintf(stderr, "NsfMethodObjSet allocated NsfMethodContext %p for %s\n", mcPtr, ObjStr(objPtr));*/
objPtr->internalRep.twoPtrValue.ptr1 = (void *)mcPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = objectType;
#if defined(METHOD_OBJECT_TRACE)
fprintf(stderr, "alloc %p methodContext %p methodEpoch %d type <%s> %s refCount %d\n",
objPtr, mcPtr, methodEpoch, objectType->name, ObjStr(objPtr), objPtr->refCount);
#endif
} else {
mcPtr = (NsfMethodContext *)objPtr->internalRep.twoPtrValue.ptr1;
#if defined(METHOD_OBJECT_TRACE)
fprintf(stderr, "... NsfMethodObjSet %p reuses internal rep, serial (%d/%d) refCount %d\n",
objPtr, mcPtr->methodEpoch, methodEpoch, objPtr->refCount);
#endif
}
assert(mcPtr != NULL);
/*
* add values to the structure
*/
mcPtr->context = context;
mcPtr->methodEpoch = methodEpoch;
mcPtr->cmd = cmd;
mcPtr->cl = cl;
mcPtr->flags = flags;
return TCL_OK;
}
void
NsfStackDump(Tcl_Interp *interp) {
Interp *iPtr = (Interp *)interp;
CallFrame *f, *v;
Tcl_Obj *varCmdObj;
nonnull_assert(interp != NULL);
f = iPtr->framePtr;
v = iPtr->varFramePtr;
varCmdObj = Tcl_NewObj();
fprintf (stderr, " TCL STACK:\n");
if (f == 0) {
fprintf(stderr, "- ");
}
while (f) {
Tcl_Obj *cmdObj = Tcl_NewObj();
fprintf(stderr, "\tFrame=%p ", (void *)f);
if (f && f->isProcCallFrame && f->procPtr && f->procPtr->cmdPtr) {
fprintf(stderr,"caller %p ", (void *)Tcl_CallFrame_callerPtr(f));
fprintf(stderr,"callerV %p ", (void *)Tcl_CallFrame_callerVarPtr(f));
Tcl_GetCommandFullName(interp, (Tcl_Command)f->procPtr->cmdPtr, cmdObj);
fprintf(stderr, "%s (%p) lvl=%d\n", ObjStr(cmdObj), (void *)f->procPtr->cmdPtr, f->level);
} else {
if (f && f->varTablePtr) {
fprintf(stderr, "var_table = %p ", (void *)f->varTablePtr);
}
fprintf(stderr, "- \n");
}
DECR_REF_COUNT(cmdObj);
f = f->callerPtr;
}
fprintf (stderr, " VARFRAME:\n");
fprintf(stderr, "\tFrame=%p ", (void *)v);
if (v != NULL) {
fprintf(stderr, "caller %p var_table %p ", (void *)v->callerPtr, (void *)v->varTablePtr);
/* if (v->varTablePtr != NULL)
panic(0, "testing");*/
}
if (v != NULL && v->isProcCallFrame && v->procPtr && v->procPtr->cmdPtr) {
Tcl_GetCommandFullName(interp, (Tcl_Command) v->procPtr->cmdPtr, varCmdObj);
fprintf(stderr, " %s (%d)\n", ObjStr(varCmdObj), v->level);
} else {
fprintf(stderr, "- \n");
}
DECR_REF_COUNT(varCmdObj);
}
/*
*----------------------------------------------------------------------
* AsmInstructionArgvSet --
*
* Set argument to be passed to an instruction of the assemble
* code.
*
*----------------------------------------------------------------------
*/
static void
AsmInstructionArgvSet(Tcl_Interp *interp, int from, int to, int currentArg,
AsmInstruction *inst, AsmCompiledProc *asmProc,
Tcl_Obj **wordOv, int verbose) {
int j;
for (j = from; j < to; j += 2, currentArg++) {
int argIndex, intValue;
Tcl_GetIndexFromObj(interp, wordOv[j], asmStatementArgType, "asm cmd arg type", 0, &argIndex);
Tcl_GetIntFromObj(interp, wordOv[j+1], &intValue);
if (verbose != 0) {
fprintf(stderr, "AsmInstructionArgvSet (type %d) arg[%d] := %s[%s]\n",
argIndex, currentArg, ObjStr(wordOv[j]), ObjStr(wordOv[j+1]));
}
switch (argIndex) {
case asmStatementArgTypeObjIdx:
inst->argv[currentArg] = asmProc->slots[intValue];
break;
case asmStatementArgTypeArgIdx:
AsmArgSet(asmProc, intValue, &inst->argv[currentArg]);
break;
case asmStatementArgTypeResultIdx:
inst->argv[currentArg] = NULL;
break;
case asmStatementArgTypeSlotIdx:
case asmStatementArgTypeInstructionIdx:
case asmStatementArgTypeIntIdx:
inst->argv[currentArg] = INT2PTR(intValue);
break;
case asmStatementArgTypeVarIdx:
fprintf(stderr, ".... var set [%d] = %s\n", currentArg, ObjStr(wordOv[j+1]));
inst->argv[currentArg] = wordOv[j+1];
Tcl_IncrRefCount(inst->argv[currentArg]); // TODO: DECR missing
break;
}
/*fprintf(stderr, "[%d] inst %p name %s arg[%d] %s\n", currentAsmInstruction,
inst, ObjStr(inst->argv[0]), currentArg,
inst->argv[currentArg] ? ObjStr(inst->argv[currentArg]) : "NULL");*/
}
}
/*
* setFromAnyProc
*/
static int
FilterregSetFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr /* The object to convert. */
) {
Tcl_Obj *guardObj = NULL, *filterObj;
Filterreg *filterregPtr;
int oc; Tcl_Obj **ov;
if (Tcl_ListObjGetElements(interp, objPtr, &oc, &ov) == TCL_OK) {
if (oc == 1) {
filterObj = ov[0];
/* } else if (oc == 2) {
filterObj = ov[0];
guardObj = ov[1];*/
} else if (oc == 3 && !strcmp(ObjStr(ov[1]), NsfGlobalStrings[NSF_GUARD_OPTION])) {
filterObj = ov[0];
guardObj = ov[2];
} else {
return TCL_ERROR;
}
} else {
return TCL_ERROR;
}
/*
* Conversion was ok.
* Allocate structure ...
*/
filterregPtr = NEW(Filterreg);
filterregPtr->filterObj = filterObj;
filterregPtr->guardObj = guardObj;
/*
* ... and increment refCounts
*/
INCR_REF_COUNT2("filterregPtr->filterObj", filterObj);
if (guardObj != NULL) {INCR_REF_COUNT2("filterregPtr->guardObj", guardObj);}
/*fprintf(stderr, "FilterregSetFromAny alloc filterreg %p class %p guard %p\n",
filterregPtr, filterregPtr->filterObj, filterregPtr->guardObj);*/
/*
* Free the old internal representation and store own structure as internal
* representation.
*/
TclFreeIntRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = (void *)filterregPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &NsfFilterregObjType;
return TCL_OK;
}
void
XOTclCallStackDump(Tcl_Interp *interp) {
XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs;
XOTclCallStackContent *csc;
int i=1, entries = cs->top - cs->content;
fprintf (stderr, " XOTCL CALLSTACK: (%d entries, top: %p) \n", entries, cs->top);
for (csc = &cs->content[1]; csc <= cs->top; csc++) {
fprintf(stderr, " %d: %p ",i++,csc);
if (csc->self)
fprintf(stderr, "OBJ %s (%p), ", ObjStr(csc->self->cmdName), csc->self);
if (csc->cl)
fprintf(stderr, "INSTPROC %s->", className(csc->cl));
else
fprintf(stderr, "PROC ");
/*fprintf(stderr, " cmd %p, obj %p, ",csc->cmdPtr, csc->self);*/
if (csc->cmdPtr && !csc->destroyedCmd)
fprintf(stderr, "%s (%p), ", Tcl_GetCommandName(interp, (Tcl_Command)csc->cmdPtr),
csc->cmdPtr);
else
fprintf(stderr, "NULL, ");
fprintf(stderr, "frameType: %d, ", csc->frameType);
fprintf(stderr, "callType: %d ", csc->callType);
fprintf(stderr, "cframe %p ", csc->currentFramePtr);
if (csc->currentFramePtr)
fprintf(stderr,"l=%d ",Tcl_CallFrame_level(csc->currentFramePtr));
if (csc->destroyedCmd)
fprintf(stderr, "--destroyed cmd set (%p) ", csc->destroyedCmd);
fprintf(stderr, "\n");
}
/*
if (entries > 0) {
XOTclCallStackContent *c;
c = XOTclCallStackFindLastInvocation(interp);
fprintf(stderr," --- findLastInvocation %p ",c);
if (c) {
if (c <= cs->top && c->currentFramePtr)
fprintf(stderr," l=%d", Tcl_CallFrame_level(c->currentFramePtr));
}
c = XOTclCallStackFindActiveFrame(interp, 1);
fprintf(stderr," findActiveFrame %p ",c);
if (c) {
if (c <= cs->top && c->currentFramePtr)
fprintf(stderr," l=%d", Tcl_CallFrame_level(c->currentFramePtr));
}
fprintf(stderr," --- \n");
}
*/
}
void
XOTclProfileEvaluateData(Tcl_Interp* interp, long int startSec, long int startUsec,
XOTclObject* obj, XOTclClass *cl, char *methodName) {
double totalMicroSec;
struct timeval trt;
Tcl_DString objectKey, methodKey;
XOTclProfile* profile = &RUNTIME_STATE(interp)->profile;
gettimeofday(&trt, NULL);
totalMicroSec = (trt.tv_sec - startSec) * 1000000 +
(trt.tv_usec - startUsec);
profile->overallTime += totalMicroSec;
if (obj->teardown == 0 || !obj->id || obj->destroyCalled)
return;
ALLOC_DSTRING(&objectKey, ObjStr(obj->cmdName));
if (cl)
ALLOC_DSTRING(&methodKey, ObjStr(cl->object.cmdName));
else
ALLOC_DSTRING(&methodKey, ObjStr(obj->cmdName));
Tcl_DStringAppend(&methodKey, "->", 2);
Tcl_DStringAppend(&methodKey, methodName, -1);
if (cl)
Tcl_DStringAppend(&methodKey, " (instproc)", 11);
else
Tcl_DStringAppend(&methodKey, " (proc)", 7);
XOTclProfileFillTable(&profile->objectData, &objectKey, totalMicroSec);
XOTclProfileFillTable(&profile->methodData, &methodKey, totalMicroSec);
DSTRING_FREE(&objectKey);
DSTRING_FREE(&methodKey);
}
int
Nsf_ConvertToPointer(Tcl_Interp *interp, Tcl_Obj *objPtr, Nsf_Param const *pPtr,
ClientData *clientData, Tcl_Obj **outObjPtr) {
void *valuePtr;
nonnull_assert(interp != NULL);
nonnull_assert(objPtr != NULL);
nonnull_assert(pPtr != NULL);
nonnull_assert(clientData != NULL);
nonnull_assert(outObjPtr != NULL);
*outObjPtr = objPtr;
valuePtr = Nsf_PointerGet(ObjStr(objPtr), pPtr->type);
if (valuePtr != NULL) {
*clientData = valuePtr;
return TCL_OK;
}
return NsfObjErrType(interp, NULL, objPtr, pPtr->type, (Nsf_Param *)pPtr);
}
/*
*----------------------------------------------------------------------
* AsmInstructionArgvCheck --
*
* Check the argument types of a assemble statement.
*
*----------------------------------------------------------------------
*/
static int
AsmInstructionArgvCheck(Tcl_Interp *interp, int from, int to, CONST char **argType,
int nrSlots, int nrStatements, Tcl_Obj **wordOv, Tcl_Obj *lineObj) {
int j;
for (j = from; j < to; j += 2) {
int argIndex, typesIndex, intValue, result;
//fprintf(stderr, "check arg type %s\n", ObjStr(wordOv[j]));
result = Tcl_GetIndexFromObj(interp, wordOv[j], asmStatementArgType,
"asm statement arg type", 0, &typesIndex);
if (result != TCL_OK) {
return NsfPrintError(interp,
"Asm: unknown arg type %s, line '%s'",
ObjStr(wordOv[j]), ObjStr(lineObj));
}
result = Tcl_GetIndexFromObj(interp, wordOv[j], argType, "asm internal arg type", 0, &argIndex);
if (result != TCL_OK) {
return NsfPrintError(interp,
"Asm: instruction argument has invalid type: '%s', line %s\n",
ObjStr(wordOv[j]), ObjStr(lineObj));
}
//fprintf(stderr, "check arg value %s\n", ObjStr(wordOv[j+1]));
if (Tcl_GetIntFromObj(interp, wordOv[j+1], &intValue) != TCL_OK
|| intValue < 0) {
return NsfPrintError(interp,
"Asm: instruction argument of type %s must have numeric index >= 0,"
" got '%s', line '%s'",
ObjStr(wordOv[j]), ObjStr(wordOv[j+1]), ObjStr(lineObj));
}
if ((
typesIndex == asmStatementArgTypeObjIdx ||
typesIndex == asmStatementArgTypeSlotIdx
)
&& intValue > nrSlots) {
return NsfPrintError(interp,
"Asm: instruction argument value must be less than %d,"
" got '%s', line '%s'",
nrSlots, ObjStr(wordOv[j+1]), ObjStr(lineObj));
}
/* we assume, that every declaration results in exactly one slot */
if ((typesIndex == asmStatementArgTypeInstructionIdx)
&& intValue > (nrStatements - nrSlots)) {
return NsfPrintError(interp,
"Asm: instruction argument value must be less than %d,"
" got '%s', line '%s'",
nrStatements - nrSlots, ObjStr(wordOv[j+1]), ObjStr(lineObj));
}
}
return TCL_OK;
}
void AsmInstructionPrint(AsmInstruction *ip) {
int i;
fprintf(stderr, "(%d) ", ip->argc);
for (i=0; i<ip->argc; i++) {fprintf(stderr, "%s ", ObjStr(ip->argv[i]));}
fprintf(stderr, "\n");
}
/*
* setFromAnyProc
*/
static int
MixinregSetFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr /* The object to convert. */
) {
NsfClass *mixin = NULL;
int oc, result;
Tcl_Obj **ov;
result = Tcl_ListObjGetElements(interp, objPtr, &oc, &ov);
if (likely(result == TCL_OK)) {
Tcl_Obj *guardObj, *nameObj;
/*
* objPtr holds a valid Tcl list
*/
if (oc == 1) {
nameObj = ov[0];
guardObj = NULL;
} else if (oc == 3 && !strcmp(ObjStr(ov[1]), NsfGlobalStrings[NSF_GUARD_OPTION])) {
nameObj = ov[0];
guardObj = ov[2];
} else {
nameObj = objPtr;
guardObj = NULL;
}
/*
* Syntax was ok. Try to lookup mixin classes:
*/
if (NsfGetClassFromObj(interp, nameObj, &mixin, 1) != TCL_OK) {
result = NsfObjErrType(interp, "mixin", nameObj, "a class as mixin", NULL);
} else {
Mixinreg *mixinRegPtr;
assert(mixin != NULL);
/*
* Conversion was ok.
* Allocate structure ...
*/
mixinRegPtr = NEW(Mixinreg);
mixinRegPtr->mixin = mixin;
mixinRegPtr->guardObj = guardObj;
/*
* ... and increment refCounts
*/
NsfObjectRefCountIncr((&mixin->object));
if (guardObj != NULL) {INCR_REF_COUNT2("mixinRegPtr->guardObj", guardObj);}
/*
* Build list of Tcl_Objs per mixin class for invalidation.
*/
{ NsfClassOpt *clOpt = NsfRequireClassOpt(mixin);
if (clOpt->mixinRegObjs == NULL) {
clOpt->mixinRegObjs = Tcl_NewListObj(1, &objPtr);
INCR_REF_COUNT2("mixinRegObjs", clOpt->mixinRegObjs);
} else {
Tcl_ListObjAppendElement(interp, clOpt->mixinRegObjs, objPtr);
}
}
/*fprintf(stderr, "MixinregSetFromAny alloc mixinReg %p class %p guard %p object->refCount %d\n",
mixinRegPtr, mixinRegPtr->mixin, mixinRegPtr->guardObj, ((&mixin->object)->refCount));*/
/*
* Free the old internal representation and store own structure as internal
* representation.
*/
TclFreeIntRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = (void *)mixinRegPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &NsfMixinregObjType;
}
}
return result;
}
