Sample extension

testcb.c:

#include <tcl.h>
#include <string.h>

typedef struct 
{
    Tcl_Obj *callback;
    Tcl_ObjCmdProc *callbackObjProc;
    ClientData      callbackClientData;
} testcbCmdData;

static int
testcbInstanceCmd (
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[]
) {
    testcbCmdData *cmdData = clientData;
    int methodIndex, calls, call, rc, result;
    Tcl_Obj *vector[2], *cmdPtr;
    Tcl_CmdInfo cmdInfo;
    
    static const char *methods[] = {
        "configure", "run", NULL
    };
    enum method {
        m_configure, m_run
    };
    
    if (objc != 3) {
        Tcl_SetResult (interp, "wrong # args: should be \"testcbcmd configure <callback>\""
                       " or \"testcbcmd run <nrOfCallbackCalls>\"", NULL);
        return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], methods, "method", 0,
                            &methodIndex) != TCL_OK) {
        return TCL_ERROR;
    }
    switch ((enum method) methodIndex) {
    case m_configure:
        if (cmdData->callback) {
            Tcl_DecrRefCount (cmdData->callback);
        }
        cmdData->callback = objv[2];
        Tcl_IncrRefCount (cmdData->callback);
        rc = Tcl_GetCommandInfo(interp, Tcl_GetString(objv[2]), &cmdInfo);
        if (rc && cmdInfo.isNativeObjectProc) {
            cmdData->callbackObjProc = cmdInfo.objProc;
            cmdData->callbackClientData = cmdInfo.objClientData;
        } else {
            cmdData->callbackObjProc = NULL;
            cmdData->callbackClientData = NULL;
        }
        break;
    case m_run:
        if (Tcl_GetIntFromObj(interp, objv[2], &calls) != TCL_OK) {
            Tcl_SetResult(interp, "Second arg must be an integer", NULL);
            return TCL_ERROR;
        }
        for (call = 1; call <= calls; call++) {
            if (cmdData->callbackObjProc != NULL) {
                vector[0] = cmdData->callback;
                vector[1] = Tcl_NewIntObj(call);
                Tcl_IncrRefCount(vector[1]);
                result = cmdData->callbackObjProc(
                    cmdData->callbackClientData, interp, 2, vector
                    );
                Tcl_DecrRefCount(vector[1]);
            } else {
                if (cmdData->callback != NULL) {
                    cmdPtr = Tcl_DuplicateObj(cmdData->callback);
                    Tcl_IncrRefCount(cmdPtr);
                    Tcl_ListObjAppendElement(interp, cmdPtr,
                                             Tcl_NewIntObj(call));
                    result = Tcl_EvalObjEx(interp, cmdPtr,
                                           TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
                    Tcl_DecrRefCount(cmdPtr);
                }
            }
            if (result != TCL_OK) {
                Tcl_SetResult(interp, "Callback didn't returned TCL_OK", NULL);
                return TCL_ERROR;
            }
        }
        Tcl_ResetResult(interp);
        return TCL_OK;
        break;
    }
    return TCL_OK;
}

static void
testcbDeleteCmd (
    ClientData clientData
) {
    testcbCmdData *cmdData = clientData;

}

static int
testcbObjCmd (
    ClientData dummy,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[]
) {
    testcbCmdData *cmdData;

    if (objc != 2) {
        Tcl_SetResult(interp, "wrong # of args, call it: testcb <cmdName>", NULL);
        return TCL_ERROR;
    }
    cmdData = (testcbCmdData *) Tcl_Alloc (sizeof (testcbCmdData));
    memset (cmdData, 0, sizeof (testcbCmdData));
    Tcl_CreateObjCommand(interp, Tcl_GetString(objv[1]), testcbInstanceCmd,
                         (ClientData) cmdData, testcbDeleteCmd);
    return TCL_OK;
}
        
int
Testcb_Init (interp)
     Tcl_Interp *interp; /* Interpreter to initialize. */
{
    Tcl_InitStubs(interp, "8", 0);
    Tcl_CreateObjCommand(interp, "testcb", testcbObjCmd, NULL, NULL );
    Tcl_PkgProvide(interp, "testcb", "1.0");
    return TCL_OK;
}


build.sh

#!/bin/bash

rm -f testcb.o testcb.so
gcc -DUSE_TCL_STUBS=1  -fPIC -o testcb.o -c testcb.c
#gcc -shared -o testcb.so testcb.o -ltclstub8.6
gcc -shared -o testcb.so testcb.o -ltclstub8.5


test.tcl:

load ./testcb.so

testcb cmd1
cmd1 configure callback

proc callback {nr} {
    global count
    incr count $nr
}

puts [info patchlevel]
testcb cmd2
cmd2 configure callback

set count 0
puts "Canonical:"
puts [time {cmd1 run 1000000}]
puts $count

puts ""

puts "Tricky:"
set count 0
puts [time {cmd2 run 1000000}]
puts $count


Results:
8.6.8
Canonical:
1262410 microseconds per iteration
500000500000

Tricky:
385482 microseconds per iteration
500000500000

8.5.19
Canonical:
1084528 microseconds per iteration
500000500000

Tricky:
337282 microseconds per iteration
500000500000