Tcl Source Code

Check-in [7bbaefb54f]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:tailcall now running in a simpler model, with no eval-flags and no nre-stack rewriting; yieldto also requires one fewer bounce. Mostly from mig-nre-mods
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 7bbaefb54fb9e4d47337c595c03dd2fdb7be3fd1
User & Date: mig 2013-01-10 21:18:52
Context
2013-01-11
14:04
First attempt at fixing problems caused by [array set] inside [namespace eval], which caused partial... check-in: aa3b9c941a user: dkf tags: bug-3600328
12:42
Name functions according to 'what' instead of 'how' in the [tailcall] machinery, in view of making p... check-in: 436a4cdd32 user: mig tags: trunk
2013-01-10
21:39
bring in improvs from trunk check-in: b6343c1d9f user: mig tags: mig-nre-mods
21:18
tailcall now running in a simpler model, with no eval-flags and no nre-stack rewriting; yieldto also... check-in: 7bbaefb54f user: mig tags: trunk
18:17
fix off-by-one error introduced in bd7d7a2061 check-in: 6547cc9e7b user: mig tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclBasic.c.

156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
....
4157
4158
4159
4160
4161
4162
4163

4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181

4182
4183
4184
4185


4186
4187
4188
4189
4190
4191
4192
....
4363
4364
4365
4366
4367
4368
4369








4370
4371
4372
4373
4374
4375
4376
....
4621
4622
4623
4624
4625
4626
4627

4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
....
6008
6009
6010
6011
6012
6013
6014

6015
6016
6017
6018
6019
6020
6021
6022
....
8265
8266
8267
8268
8269
8270
8271
















8272
8273
8274

8275
8276
8277
8278
8279
8280
8281
8282
8283
8284
8285
8286
8287
8288
8289
8290
8291
8292
8293
8294
8295
8296
8297
8298
8299
8300
8301
....
8317
8318
8319
8320
8321
8322
8323
8324
8325
8326
8327
8328
8329
8330
8331
....
8332
8333
8334
8335
8336
8337
8338
8339
8340



8341
8342
8343
8344
8345
8346
8347
8348
8349
8350
8351
8352
8353
8354
8355
8356
8357
8358
8359
8360
8361
8362
8363
8364
8365
8366
8367
8368
8369
8370
8371
8372



8373
8374
8375
8376
8377
8378
8379
....
8384
8385
8386
8387
8388
8389
8390

8391
8392
8393
8394
8395
8396
8397
8398
8399
8400
8401
8402
8403
8404
8405
8406
8407
8408
8409
8410
8411
8412
8413
8414
8415
8416
8417
8418
8419
8420
8421
8422
8423
....
8511
8512
8513
8514
8515
8516
8517






8518
8519
8520
8521
8522
8523
8524
8525
8526

8527
8528
8529
8530
8531
8532
8533
8534
8535
8536
8537
8538
8539
8540
8541
8542
8543
8544
8545
8546
8547
8548
8549
8550
8551
8552
8553
8554
8555
8556
8557
8558
8559
8560
8561
8562
8563
8564
8565
8566
8567
8568
static Tcl_NRPostProc	TEOEx_ByteCodeCallback;
static Tcl_NRPostProc	TEOEx_ListCallback;
static Tcl_NRPostProc	TEOV_Error;
static Tcl_NRPostProc	TEOV_Exception;
static Tcl_NRPostProc	TEOV_NotFoundCallback;
static Tcl_NRPostProc	TEOV_RestoreVarFrame;
static Tcl_NRPostProc	TEOV_RunLeaveTraces;
static Tcl_NRPostProc	YieldToCallback;

static void	        ClearTailcall(Tcl_Interp *interp,
			    struct NRE_callback *tailcallPtr);
static Tcl_ObjCmdProc NRCoroInjectObjCmd;

MODULE_SCOPE const TclStubs tclStubs;

/*
 * Magical counts for the number of arguments accepted by a coroutine command
 * after particular kinds of [yield].
................................................................................
				 * here, otherwise the pointer to the
				 * requested Command struct to be invoked. */
{
    Interp *iPtr = (Interp *) interp;
    int result;
    Namespace *lookupNsPtr = iPtr->lookupNsPtr;
    Command **cmdPtrPtr;


    iPtr->lookupNsPtr = NULL;

    /*
     * Push a callback with cleanup tasks for commands; the cmdPtr at data[0]
     * will be filled later when the command is found: save its address at
     * objProcPtr.
     *
     * data[1] stores a marker for use by tailcalls; it will be set to 1 by
     * command redirectors (imports, alias, ensembles) so that tailcalls
     * finishes the source command and not just the target.
     */

    if (iPtr->evalFlags & TCL_EVAL_REDIRECT) {
	TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1), INT2PTR(objc), objv);
	iPtr->evalFlags &= ~TCL_EVAL_REDIRECT;
    } else {
	TclNRAddCallback(interp, NRCommand, NULL, NULL, INT2PTR(objc), objv);

    }
    cmdPtrPtr = (Command **) &(TOP_CB(interp)->data[0]);

    TclNRSpliceDeferred(interp);



    iPtr->numLevels++;
    result = TclInterpReady(interp);

    if ((result != TCL_OK) || (objc == 0)) {
	return result;
    }
................................................................................
    Command *cmdPtr = data[0];
    /* int cmdStart = PTR2INT(data[1]); NOT USED HERE */

    if (cmdPtr) {
	TclCleanupCommandMacro(cmdPtr);
    }
    ((Interp *)interp)->numLevels--;









    /* OPT ??
     * Do not interrupt a series of cleanups with async or limit checks:
     * just check at the end?
     */

    if (TclAsyncReady(iPtr)) {
................................................................................
	return TCL_ERROR;
    }

    if (lookupNsPtr) {
	savedNsPtr = varFramePtr->nsPtr;
	varFramePtr->nsPtr = lookupNsPtr;
    }

    TclNRDeferCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc),
	    newObjv, savedNsPtr, NULL);
    iPtr->evalFlags |= TCL_EVAL_REDIRECT;
    return TclNREvalObjv(interp, newObjc, newObjv, TCL_EVAL_NOERR, NULL);
}

static int
TEOV_NotFoundCallback(
    ClientData data[],
    Tcl_Interp *interp,
................................................................................

	    eoFramePtr->cmd.listPtr = listPtr;
	    eoFramePtr->data.eval.path = NULL;

	    iPtr->cmdFramePtr = eoFramePtr;
	}


	TclNRDeferCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
		NULL, NULL);

	ListObjGetElements(listPtr, objc, objv);
	return TclNREvalObjv(interp, objc, objv, flags, NULL);
    }

    if (!(flags & TCL_EVAL_DIRECT)) {
................................................................................
 *	 implementation does not (or does it? Changed, test!) - it causes an
 *	 error.
 *
 * FIXME NRE!
 */

void
















TclSpliceTailcall(
    Tcl_Interp *interp,
    NRE_callback *tailcallPtr)

{
    /*
     * Find the splicing spot: right before the NRCommand of the thing
     * being tailcalled. Note that we skip NRCommands marked in data[1]
     * (used by command redirectors).
     */

    NRE_callback *runPtr;

    for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
	if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) {
            break;
        }
    }
    if (!runPtr) {
        Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!");
    }

    tailcallPtr->nextPtr = runPtr->nextPtr;
    runPtr->nextPtr = tailcallPtr;
}

int
TclNRTailcallObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
................................................................................

    /*
     * Invocation without args just clears a scheduled tailcall; invocation
     * with an argument replaces any previously scheduled tailcall.
     */

    if (iPtr->varFramePtr->tailcallPtr) {
        ClearTailcall(interp, iPtr->varFramePtr->tailcallPtr);
        iPtr->varFramePtr->tailcallPtr = NULL;
    }

    /*
     * Create the callback to actually evaluate the tailcalled
     * command, then set it in the varFrame so that PopCallFrame can use it
     * at the proper time. Being lazy: exploit the TclNRAddCallBack macro to
................................................................................
     * build the callback.
     */

    if (objc > 1) {
        Tcl_Obj *listPtr, *nsObjPtr;
        Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
        Tcl_Namespace *ns1Ptr;
        NRE_callback *tailcallPtr;




        listPtr = Tcl_NewListObj(objc-1, objv+1);
        Tcl_IncrRefCount(listPtr);

        nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
        if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
                || (nsPtr != ns1Ptr)) {
            Tcl_Panic("Tailcall failed to find the proper namespace");
        }
        Tcl_IncrRefCount(nsObjPtr);

        TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr,
                NULL, NULL);
        tailcallPtr = TOP_CB(interp);
        TOP_CB(interp) = tailcallPtr->nextPtr;
        iPtr->varFramePtr->tailcallPtr = tailcallPtr;
    }
    return TCL_RETURN;
}

int
TclNRTailcallEval(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *listPtr = data[0];
    Tcl_Obj *nsObjPtr = data[1];
    Tcl_Namespace *nsPtr;
    int objc;
    Tcl_Obj **objv;




    if (result == TCL_OK) {
	result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
    }

    if (result != TCL_OK) {
        /*
         * Tailcall execution was preempted, eg by an intervening catch or by
................................................................................
        return result;
    }

    /*
     * Perform the tailcall
     */


    TclNRDeferCallback(interp, TailcallCleanup, listPtr, nsObjPtr, NULL,NULL);
    iPtr->lookupNsPtr = (Namespace *) nsPtr;
    ListObjGetElements(listPtr, objc, objv);
    return TclNREvalObjv(interp, objc, objv, 0, NULL);
}

static int
TailcallCleanup(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_DecrRefCount((Tcl_Obj *) data[0]);
    Tcl_DecrRefCount((Tcl_Obj *) data[1]);
    return result;
}

static void
ClearTailcall(
    Tcl_Interp *interp,
    NRE_callback *tailcallPtr)
{
    TailcallCleanup(tailcallPtr->data, interp, TCL_OK);
    TCLNR_FREE(interp, tailcallPtr);
}

 
void
Tcl_NRAddCallback(
    Tcl_Interp *interp,
    Tcl_NRPostProc *postProcPtr,
    ClientData data0,
    ClientData data1,
................................................................................

    /*
     * Add the tailcall in the caller env, then just yield.
     *
     * This is essentially code from TclNRTailcallObjCmd
     */







    listPtr = Tcl_NewListObj(objc-1, objv+1);
    Tcl_IncrRefCount(listPtr);

    nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
    if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
	    || (nsPtr != ns1Ptr)) {
	Tcl_Panic("yieldto failed to find the proper namespace");
    }
    Tcl_IncrRefCount(nsObjPtr);


    /*
     * Add the callback in the caller's env, then instruct TEBC to yield.
     */

    iPtr->execEnvPtr = corPtr->callerEEPtr;
    TclNRAddCallback(interp, YieldToCallback, corPtr, listPtr, nsObjPtr,
	    NULL);
    iPtr->execEnvPtr = corPtr->eePtr;

    return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv);
}

static int
YieldToCallback(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    /* CoroutineData *corPtr = data[0];*/
    Tcl_Obj *listPtr = data[1];
    ClientData nsPtr = data[2];
    NRE_callback *cbPtr;

    /*
     * yieldTo: invoke the command using tailcall tech.
     */

    TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsPtr, NULL, NULL);
    cbPtr = TOP_CB(interp);
    TOP_CB(interp) = cbPtr->nextPtr;

    TclSpliceTailcall(interp, cbPtr);
    return TCL_OK;
}
 
static int
RewindCoroutineCallback(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{






<

<
<







 







>
|












|
|
|

|
>

|

<
>
>







 







>
>
>
>
>
>
>
>







 







>
|

<







 







>
|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|

<
>



|






|






|
<
<







 







|







 







<

>
>
>
|
<






|
|
<
<
<
<
|











|
<




>
>
>







 







>
|

<
|









<



<
<
<
<
<
<
<
<
<







 







>
>
>
>
>
>
|
<






|
>






|
<




<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







156
157
158
159
160
161
162

163


164
165
166
167
168
169
170
....
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183

4184
4185
4186
4187
4188
4189
4190
4191
4192
....
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
....
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638

4639
4640
4641
4642
4643
4644
4645
....
6016
6017
6018
6019
6020
6021
6022
6023
6024
6025
6026
6027
6028
6029
6030
6031
....
8274
8275
8276
8277
8278
8279
8280
8281
8282
8283
8284
8285
8286
8287
8288
8289
8290
8291
8292
8293
8294
8295
8296
8297
8298

8299
8300
8301
8302
8303
8304
8305
8306
8307
8308
8309
8310
8311
8312
8313
8314
8315
8316
8317


8318
8319
8320
8321
8322
8323
8324
....
8340
8341
8342
8343
8344
8345
8346
8347
8348
8349
8350
8351
8352
8353
8354
....
8355
8356
8357
8358
8359
8360
8361

8362
8363
8364
8365
8366

8367
8368
8369
8370
8371
8372
8373
8374




8375
8376
8377
8378
8379
8380
8381
8382
8383
8384
8385
8386
8387

8388
8389
8390
8391
8392
8393
8394
8395
8396
8397
8398
8399
8400
8401
....
8406
8407
8408
8409
8410
8411
8412
8413
8414
8415

8416
8417
8418
8419
8420
8421
8422
8423
8424
8425

8426
8427
8428









8429
8430
8431
8432
8433
8434
8435
....
8523
8524
8525
8526
8527
8528
8529
8530
8531
8532
8533
8534
8535
8536

8537
8538
8539
8540
8541
8542
8543
8544
8545
8546
8547
8548
8549
8550
8551

8552
8553
8554
8555























8556
8557
8558
8559
8560
8561
8562
static Tcl_NRPostProc	TEOEx_ByteCodeCallback;
static Tcl_NRPostProc	TEOEx_ListCallback;
static Tcl_NRPostProc	TEOV_Error;
static Tcl_NRPostProc	TEOV_Exception;
static Tcl_NRPostProc	TEOV_NotFoundCallback;
static Tcl_NRPostProc	TEOV_RestoreVarFrame;
static Tcl_NRPostProc	TEOV_RunLeaveTraces;




static Tcl_ObjCmdProc NRCoroInjectObjCmd;

MODULE_SCOPE const TclStubs tclStubs;

/*
 * Magical counts for the number of arguments accepted by a coroutine command
 * after particular kinds of [yield].
................................................................................
				 * here, otherwise the pointer to the
				 * requested Command struct to be invoked. */
{
    Interp *iPtr = (Interp *) interp;
    int result;
    Namespace *lookupNsPtr = iPtr->lookupNsPtr;
    Command **cmdPtrPtr;
    NRE_callback *callbackPtr;
    
    iPtr->lookupNsPtr = NULL;

    /*
     * Push a callback with cleanup tasks for commands; the cmdPtr at data[0]
     * will be filled later when the command is found: save its address at
     * objProcPtr.
     *
     * data[1] stores a marker for use by tailcalls; it will be set to 1 by
     * command redirectors (imports, alias, ensembles) so that tailcalls
     * finishes the source command and not just the target.
     */

    if (iPtr->deferredCallbacks) {
        callbackPtr = iPtr->deferredCallbacks;
        iPtr->deferredCallbacks = NULL;
    } else {
	TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
        callbackPtr = TOP_CB(interp);
    }
    cmdPtrPtr = (Command **) &(callbackPtr->data[0]);


    callbackPtr->data[2] = INT2PTR(objc);
    callbackPtr->data[3] = (ClientData) objv;

    iPtr->numLevels++;
    result = TclInterpReady(interp);

    if ((result != TCL_OK) || (objc == 0)) {
	return result;
    }
................................................................................
    Command *cmdPtr = data[0];
    /* int cmdStart = PTR2INT(data[1]); NOT USED HERE */

    if (cmdPtr) {
	TclCleanupCommandMacro(cmdPtr);
    }
    ((Interp *)interp)->numLevels--;

     /*
      * If there is a tailcall, schedule it
      */
 
    if (data[1] && (data[1] != INT2PTR(1))) {
        TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL);
    }

    /* OPT ??
     * Do not interrupt a series of cleanups with async or limit checks:
     * just check at the end?
     */

    if (TclAsyncReady(iPtr)) {
................................................................................
	return TCL_ERROR;
    }

    if (lookupNsPtr) {
	savedNsPtr = varFramePtr->nsPtr;
	varFramePtr->nsPtr = lookupNsPtr;
    }
    TclDeferCallbacks(interp, 1);
    TclNRAddCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc),
	    newObjv, savedNsPtr, NULL);

    return TclNREvalObjv(interp, newObjc, newObjv, TCL_EVAL_NOERR, NULL);
}

static int
TEOV_NotFoundCallback(
    ClientData data[],
    Tcl_Interp *interp,
................................................................................

	    eoFramePtr->cmd.listPtr = listPtr;
	    eoFramePtr->data.eval.path = NULL;

	    iPtr->cmdFramePtr = eoFramePtr;
	}

	TclDeferCallbacks(interp, 0);
        TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
		NULL, NULL);

	ListObjGetElements(listPtr, objc, objv);
	return TclNREvalObjv(interp, objc, objv, flags, NULL);
    }

    if (!(flags & TCL_EVAL_DIRECT)) {
................................................................................
 *	 implementation does not (or does it? Changed, test!) - it causes an
 *	 error.
 *
 * FIXME NRE!
 */

void
TclDeferCallbacks(
    Tcl_Interp *interp,
    int skipTailcalls)
{
    Interp *iPtr = (Interp *) interp;

    if (iPtr->deferredCallbacks == NULL) {
	TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(skipTailcalls != 0),
                NULL, NULL);
        iPtr->deferredCallbacks = TOP_CB(interp);
    } else if (skipTailcalls) {
        iPtr->deferredCallbacks->data[1] = INT2PTR(skipTailcalls != 0);
    }
}

void
TclSetTailcall(
    Tcl_Interp *interp,

    Tcl_Obj *listPtr)
{
    /*
     * Find the splicing spot: right before the NRCommand of the thing
     * being tailcalled. Note that we skip NRCommands marked by a 1 in data[1]
     * (used by command redirectors).
     */

    NRE_callback *runPtr;

    for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
        if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) {
            break;
        }
    }
    if (!runPtr) {
        Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!");
    }
    runPtr->data[1] = listPtr;


}

int
TclNRTailcallObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
................................................................................

    /*
     * Invocation without args just clears a scheduled tailcall; invocation
     * with an argument replaces any previously scheduled tailcall.
     */

    if (iPtr->varFramePtr->tailcallPtr) {
        Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr);
        iPtr->varFramePtr->tailcallPtr = NULL;
    }

    /*
     * Create the callback to actually evaluate the tailcalled
     * command, then set it in the varFrame so that PopCallFrame can use it
     * at the proper time. Being lazy: exploit the TclNRAddCallBack macro to
................................................................................
     * build the callback.
     */

    if (objc > 1) {
        Tcl_Obj *listPtr, *nsObjPtr;
        Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
        Tcl_Namespace *ns1Ptr;


        /* The tailcall data is in a Tcl list: the first element is the
         * namespace, the rest the command to be tailcalled. */
        
        listPtr = Tcl_NewListObj(objc, objv);


        nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
        if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
                || (nsPtr != ns1Ptr)) {
            Tcl_Panic("Tailcall failed to find the proper namespace");
        }
 	TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
        




        iPtr->varFramePtr->tailcallPtr = listPtr;
    }
    return TCL_RETURN;
}

int
TclNRTailcallEval(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *listPtr = data[0], *nsObjPtr;

    Tcl_Namespace *nsPtr;
    int objc;
    Tcl_Obj **objv;

    Tcl_ListObjGetElements(interp, listPtr, &objc, &objv); 
    nsObjPtr = objv[0];
    
    if (result == TCL_OK) {
	result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
    }

    if (result != TCL_OK) {
        /*
         * Tailcall execution was preempted, eg by an intervening catch or by
................................................................................
        return result;
    }

    /*
     * Perform the tailcall
     */

    TclDeferCallbacks(interp, 0);
    TclNRAddCallback(interp, TailcallCleanup, listPtr, NULL, NULL,NULL);
    iPtr->lookupNsPtr = (Namespace *) nsPtr;

    return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL);
}

static int
TailcallCleanup(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_DecrRefCount((Tcl_Obj *) data[0]);

    return result;
}










 
void
Tcl_NRAddCallback(
    Tcl_Interp *interp,
    Tcl_NRPostProc *postProcPtr,
    ClientData data0,
    ClientData data1,
................................................................................

    /*
     * Add the tailcall in the caller env, then just yield.
     *
     * This is essentially code from TclNRTailcallObjCmd
     */

    /*
     * Add the tailcall in the caller env, then just yield.
     *
     * This is essentially code from TclNRTailcallObjCmd
     */

    listPtr = Tcl_NewListObj(objc, objv);


    nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
    if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
	    || (nsPtr != ns1Ptr)) {
	Tcl_Panic("yieldto failed to find the proper namespace");
    }
    TclListObjSetElement(interp, listPtr, 0, nsObjPtr);


    /*
     * Add the callback in the caller's env, then instruct TEBC to yield.
     */

    iPtr->execEnvPtr = corPtr->callerEEPtr;
    TclSetTailcall(interp, listPtr);

    iPtr->execEnvPtr = corPtr->eePtr;

    return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv);
}























 
static int
RewindCoroutineCallback(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{

Changes to generic/tclCompCmdsSZ.c.

1949
1950
1951
1952
1953
1954
1955


1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
    int i;

    if (parsePtr->numWords < 2 || parsePtr->numWords > 256
	    || envPtr->procPtr == NULL) {
	return TCL_ERROR;
    }



    for (i=1 ; i<parsePtr->numWords ; i++) {
	tokenPtr = TokenAfter(tokenPtr);
	CompileWord(envPtr, tokenPtr, interp, i);
    }
    TclEmitInstInt1(	INST_TAILCALL, parsePtr->numWords-1,	envPtr);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileThrowCmd --






>
>




|







1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
    int i;

    if (parsePtr->numWords < 2 || parsePtr->numWords > 256
	    || envPtr->procPtr == NULL) {
	return TCL_ERROR;
    }

    /* make room for the nsObjPtr */
    CompileWord(envPtr, tokenPtr, interp, 0);
    for (i=1 ; i<parsePtr->numWords ; i++) {
	tokenPtr = TokenAfter(tokenPtr);
	CompileWord(envPtr, tokenPtr, interp, i);
    }
    TclEmitInstInt1(	INST_TAILCALL, parsePtr->numWords,	envPtr);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileThrowCmd --

Changes to generic/tclEnsemble.c.

1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
....
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
	    }
	}

	/*
	 * Hand off to the target command.
	 */

	iPtr->evalFlags |= TCL_EVAL_REDIRECT;
	return TclNREvalObjEx(interp, copyPtr, TCL_EVAL_INVOKE, NULL,INT_MIN);
    }

  unknownOrAmbiguousSubcommand:
    /*
     * Have not been able to match the subcommand asked for with a real
     * subcommand that we export. See whether a handler has been registered
................................................................................
     * Now call the unknown handler. (We don't bother NRE-enabling this; deep
     * recursing through unknown handlers is horribly perverse.) Note that it
     * is always an error for an unknown handler to delete its ensemble; don't
     * do that!
     */

    Tcl_Preserve(ensemblePtr);
    ((Interp *) interp)->evalFlags |= TCL_EVAL_REDIRECT;
    result = Tcl_EvalObjv(interp, paramc, paramv, 0);
    if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) {
	if (!Tcl_InterpDeleted(interp)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "unknown subcommand handler deleted its ensemble", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED",
		    NULL);






|







 







|







1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
....
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
	    }
	}

	/*
	 * Hand off to the target command.
	 */

	TclDeferCallbacks(interp, /* skip tailcalls */ 1);
	return TclNREvalObjEx(interp, copyPtr, TCL_EVAL_INVOKE, NULL,INT_MIN);
    }

  unknownOrAmbiguousSubcommand:
    /*
     * Have not been able to match the subcommand asked for with a real
     * subcommand that we export. See whether a handler has been registered
................................................................................
     * Now call the unknown handler. (We don't bother NRE-enabling this; deep
     * recursing through unknown handlers is horribly perverse.) Note that it
     * is always an error for an unknown handler to delete its ensemble; don't
     * do that!
     */

    Tcl_Preserve(ensemblePtr);
    TclDeferCallbacks (interp, /*skip tailcalls */ 1);
    result = Tcl_EvalObjv(interp, paramc, paramv, 0);
    if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) {
	if (!Tcl_InterpDeleted(interp)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "unknown subcommand handler deleted its ensemble", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED",
		    NULL);

Changes to generic/tclExecute.c.

2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
....
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443

2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
....
3050
3051
3052
3053
3054
3055
3056

3057
3058

3059
3060
3061
3062
3063
3064
3065
		INT2PTR(0), NULL, NULL);

	return TCL_OK;
    }

    case INST_TAILCALL: {
	Tcl_Obj *listPtr, *nsObjPtr;
        NRE_callback *tailcallPtr;

	opnd = TclGetUInt1AtPtr(pc+1);

	if (!(iPtr->varFramePtr->isProcCallFrame & 1)) {
	    TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd));
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "tailcall can only be called from a proc or lambda", -1));
................................................................................
	/*
	 * Push the evaluation of the called command into the NR callback
	 * stack.
	 */

	listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));
	nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, -1);
	Tcl_IncrRefCount(listPtr);
	Tcl_IncrRefCount(nsObjPtr);
	TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr,
		NULL, NULL);

	/*
	 * Unstitch ourselves and do a [return].
	 */


	tailcallPtr = TOP_CB(interp);
	TOP_CB(interp) = tailcallPtr->nextPtr;
	iPtr->varFramePtr->tailcallPtr = tailcallPtr;
	result = TCL_RETURN;
	cleanup = opnd;
	goto processExceptionReturn;
    }

    case INST_DONE:
	if (tosPtr > initTosPtr) {
................................................................................
	}
	iPtr->ensembleRewrite.sourceObjs = objv;
	iPtr->ensembleRewrite.numRemovedObjs = opnd;
	iPtr->ensembleRewrite.numInsertedObjs = 1;
	DECACHE_STACK_INFO();
	pc += 6;
	TEBC_YIELD();

	TclNRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL);
	iPtr->evalFlags |= TCL_EVAL_REDIRECT;

	return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE, NULL, INT_MIN);

    /*
     * -----------------------------------------------------------------
     *	   Start of INST_LOAD instructions.
     *
     * WARNING: more 'goto' here than your doctor recommended! The different






<







 







|
|
|
<
|
<
<
<
>

<
<
<







 







>

<
>







2395
2396
2397
2398
2399
2400
2401

2402
2403
2404
2405
2406
2407
2408
....
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437

2438



2439
2440



2441
2442
2443
2444
2445
2446
2447
....
3043
3044
3045
3046
3047
3048
3049
3050
3051

3052
3053
3054
3055
3056
3057
3058
3059
		INT2PTR(0), NULL, NULL);

	return TCL_OK;
    }

    case INST_TAILCALL: {
	Tcl_Obj *listPtr, *nsObjPtr;


	opnd = TclGetUInt1AtPtr(pc+1);

	if (!(iPtr->varFramePtr->isProcCallFrame & 1)) {
	    TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd));
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "tailcall can only be called from a proc or lambda", -1));
................................................................................
	/*
	 * Push the evaluation of the called command into the NR callback
	 * stack.
	 */

	listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));
	nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, -1);
	TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
	if (iPtr->varFramePtr->tailcallPtr) {
	    Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr);

	}



	iPtr->varFramePtr->tailcallPtr = listPtr;




	result = TCL_RETURN;
	cleanup = opnd;
	goto processExceptionReturn;
    }

    case INST_DONE:
	if (tosPtr > initTosPtr) {
................................................................................
	}
	iPtr->ensembleRewrite.sourceObjs = objv;
	iPtr->ensembleRewrite.numRemovedObjs = opnd;
	iPtr->ensembleRewrite.numInsertedObjs = 1;
	DECACHE_STACK_INFO();
	pc += 6;
	TEBC_YIELD();

	TclNRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL);

	TclDeferCallbacks(interp, /*skip tailcalls */ 1);
	return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE, NULL, INT_MIN);

    /*
     * -----------------------------------------------------------------
     *	   Start of INST_LOAD instructions.
     *
     * WARNING: more 'goto' here than your doctor recommended! The different

Changes to generic/tclInt.h.

1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
....
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
....
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
....
4804
4805
4806
4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
				 * sets it, and it should only ever be set by
				 * the code that is pushing the frame. In that
				 * case, the code that sets it should also
				 * have some means of discovering what the
				 * meaning of the value is, which we do not
				 * specify. */
    LocalCache *localCachePtr;
    struct NRE_callback *tailcallPtr;
				/* NULL if no tailcall is scheduled */
} CallFrame;

#define FRAME_IS_PROC	0x1
#define FRAME_IS_LAMBDA 0x2
#define FRAME_IS_METHOD	0x4	/* The frame is a method body, and the frame's
				 * clientData field contains a CallContext
................................................................................
 *			code other than TCL_OK or TCL_ERROR; 0 means codes
 *			other than these should be turned into errors.
 */

#define TCL_ALLOW_EXCEPTIONS	4
#define TCL_EVAL_FILE		2
#define TCL_EVAL_CTX		8
#define TCL_EVAL_REDIRECT	16

/*
 * Flag bits for Interp structures:
 *
 * DELETED:		Non-zero means the interpreter has been deleted:
 *			don't process any more commands for it, and destroy
 *			the structure as soon as all nested invocations of
................................................................................
MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd;
MODULE_SCOPE Tcl_NRPostProc TclNRTailcallEval;
MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;

MODULE_SCOPE void  TclSpliceTailcall(Tcl_Interp *interp,
	               struct NRE_callback *tailcallPtr);

/*
 * This structure holds the data for the various iteration callbacks used to
 * NRE the 'for' and 'while' commands. We need a separate structure because we
 * have more than the 4 client data entries we can provide directly thorugh
 * the callback API. It is the 'word' information which puts us over the
 * limit. It is needed because the loop body is argument 4 of 'for' and
................................................................................
	callbackPtr->data[1] = (ClientData)(data1);			\
	callbackPtr->data[2] = (ClientData)(data2);			\
	callbackPtr->data[3] = (ClientData)(data3);			\
	callbackPtr->nextPtr = TOP_CB(interp);				\
	TOP_CB(interp) = callbackPtr;					\
    } while (0)

#define TclNRDeferCallback(interp,postProcPtr,data0,data1,data2,data3) \
    do {								\
	NRE_callback *callbackPtr;					\
	TCLNR_ALLOC((interp), (callbackPtr));				\
	callbackPtr->procPtr = (postProcPtr);				\
	callbackPtr->data[0] = (ClientData)(data0);			\
	callbackPtr->data[1] = (ClientData)(data1);			\
	callbackPtr->data[2] = (ClientData)(data2);			\
	callbackPtr->data[3] = (ClientData)(data3);			\
	callbackPtr->nextPtr = ((Interp *)interp)->deferredCallbacks;	\
	((Interp *)interp)->deferredCallbacks = callbackPtr;		\
    } while (0)

#define TclNRSpliceCallbacks(interp, topPtr) \
    do {					\
	NRE_callback *bottomPtr = topPtr;	\
	while (bottomPtr->nextPtr) {		\
	    bottomPtr = bottomPtr->nextPtr;	\
	}					\
	bottomPtr->nextPtr = TOP_CB(interp);	\
	TOP_CB(interp) = topPtr;		\
    } while (0)

#define TclNRSpliceDeferred(interp)					\
    if (((Interp *)interp)->deferredCallbacks) {			\
	TclNRSpliceCallbacks(interp, ((Interp *)interp)->deferredCallbacks); \
	((Interp *)interp)->deferredCallbacks = NULL;			\
    }

#if NRE_USE_SMALL_ALLOC
#define TCLNR_ALLOC(interp, ptr) \
    TclSmallAllocEx(interp, sizeof(NRE_callback), (ptr))
#define TCLNR_FREE(interp, ptr)  TclSmallFreeEx((interp), (ptr))
#else
#define TCLNR_ALLOC(interp, ptr) \
    (ptr = ((ClientData) ckalloc(sizeof(NRE_callback))))






|







 







<







 







|
|







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
....
2246
2247
2248
2249
2250
2251
2252

2253
2254
2255
2256
2257
2258
2259
....
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
....
4803
4804
4805
4806
4807
4808
4809





























4810
4811
4812
4813
4814
4815
4816
				 * sets it, and it should only ever be set by
				 * the code that is pushing the frame. In that
				 * case, the code that sets it should also
				 * have some means of discovering what the
				 * meaning of the value is, which we do not
				 * specify. */
    LocalCache *localCachePtr;
    Tcl_Obj    *tailcallPtr;
				/* NULL if no tailcall is scheduled */
} CallFrame;

#define FRAME_IS_PROC	0x1
#define FRAME_IS_LAMBDA 0x2
#define FRAME_IS_METHOD	0x4	/* The frame is a method body, and the frame's
				 * clientData field contains a CallContext
................................................................................
 *			code other than TCL_OK or TCL_ERROR; 0 means codes
 *			other than these should be turned into errors.
 */

#define TCL_ALLOW_EXCEPTIONS	4
#define TCL_EVAL_FILE		2
#define TCL_EVAL_CTX		8


/*
 * Flag bits for Interp structures:
 *
 * DELETED:		Non-zero means the interpreter has been deleted:
 *			don't process any more commands for it, and destroy
 *			the structure as soon as all nested invocations of
................................................................................
MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd;
MODULE_SCOPE Tcl_NRPostProc TclNRTailcallEval;
MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;

MODULE_SCOPE void  TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr);
MODULE_SCOPE void  TclDeferCallbacks(Tcl_Interp *interp, int skipTailcall);

/*
 * This structure holds the data for the various iteration callbacks used to
 * NRE the 'for' and 'while' commands. We need a separate structure because we
 * have more than the 4 client data entries we can provide directly thorugh
 * the callback API. It is the 'word' information which puts us over the
 * limit. It is needed because the loop body is argument 4 of 'for' and
................................................................................
	callbackPtr->data[1] = (ClientData)(data1);			\
	callbackPtr->data[2] = (ClientData)(data2);			\
	callbackPtr->data[3] = (ClientData)(data3);			\
	callbackPtr->nextPtr = TOP_CB(interp);				\
	TOP_CB(interp) = callbackPtr;					\
    } while (0)






























#if NRE_USE_SMALL_ALLOC
#define TCLNR_ALLOC(interp, ptr) \
    TclSmallAllocEx(interp, sizeof(NRE_callback), (ptr))
#define TCLNR_FREE(interp, ptr)  TclSmallFreeEx((interp), (ptr))
#else
#define TCLNR_ALLOC(interp, ptr) \
    (ptr = ((ClientData) ckalloc(sizeof(NRE_callback))))

Changes to generic/tclInterp.c.

1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
    /*
     * We are sending a 0-refCount obj, do not need a callback: it will be
     * cleaned up automatically. But we may need to clear the rootEnsemble
     * stuff ...
     */

    if (isRootEnsemble) {
	TclNRDeferCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
    }
    iPtr->evalFlags |= TCL_EVAL_REDIRECT;
    return Tcl_NREvalObj(interp, listPtr, flags);
}

static int
AliasObjCmd(
    ClientData clientData,	/* Alias record. */
    Tcl_Interp *interp,		/* Current interpreter. */






|

|







1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
    /*
     * We are sending a 0-refCount obj, do not need a callback: it will be
     * cleaned up automatically. But we may need to clear the rootEnsemble
     * stuff ...
     */

    if (isRootEnsemble) {
	TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
    }
    TclDeferCallbacks(interp, /* skip tailcalls */ 1);
    return Tcl_NREvalObj(interp, listPtr, flags);
}

static int
AliasObjCmd(
    ClientData clientData,	/* Alias record. */
    Tcl_Interp *interp,		/* Current interpreter. */

Changes to generic/tclNamesp.c.

419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
....
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
    if ((nsPtr->flags & NS_DYING)
	    && (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) {
	Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
    }
    framePtr->nsPtr = NULL;

    if (framePtr->tailcallPtr) {
	TclSpliceTailcall(interp, framePtr->tailcallPtr);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclPushStackFrame --
................................................................................
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    ImportedCmdData *dataPtr = clientData;
    Command *realCmdPtr = dataPtr->realCmdPtr;

    ((Interp *) interp)->evalFlags |= TCL_EVAL_REDIRECT;
    return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0);
}

static int
InvokeImportedCmd(
    ClientData clientData,	/* Points to the imported command's
				 * ImportedCmdData structure. */






|







 







|







419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
....
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
    if ((nsPtr->flags & NS_DYING)
	    && (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) {
	Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
    }
    framePtr->nsPtr = NULL;

    if (framePtr->tailcallPtr) {
	TclSetTailcall(interp, framePtr->tailcallPtr);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclPushStackFrame --
................................................................................
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    ImportedCmdData *dataPtr = clientData;
    Command *realCmdPtr = dataPtr->realCmdPtr;

    TclDeferCallbacks(interp, /* skip tailcalls */ 1);
    return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0);
}

static int
InvokeImportedCmd(
    ClientData clientData,	/* Points to the imported command's
				 * ImportedCmdData structure. */