Tcl Source Code

Check-in [bd1fb54305]
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:And the last bits that need fixing; the code is still less efficient than desired but should now not crash.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | dkf-loop-exception-range-work
Files: files | file ages | folders
SHA1: bd1fb54305b2f19c408ca2bd7224a0dd5c0dfe1f
User & Date: dkf 2013-10-20 18:11:35
Context
2013-10-20
18:15
[2835313] Ensure correct stack balance when break and continue exceptions are about: the hard cases ... check-in: 582877d8ab user: dkf tags: trunk
18:11
And the last bits that need fixing; the code is still less efficient than desired but should now not... Closed-Leaf check-in: bd1fb54305 user: dkf tags: dkf-loop-exception-range-work
2013-10-19
14:11
Fix handling of 'invokeExpanded' and start to do 'returnStk'. check-in: 7e41c534a9 user: dkf tags: dkf-loop-exception-range-work
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclAssembly.c.

242
243
244
245
246
247
248


249
250
251
252
253
254
255
...
675
676
677
678
679
680
681
682
683
684
685



686
687
688
689
690
691
692
...
707
708
709
710
711
712
713























714
715
716
717
718
719
720
....
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
			    int count);
static void		BBEmitInstInt1(AssemblyEnv* assemEnvPtr, int tblIdx,
			    int opnd, int count);
static void		BBEmitInstInt4(AssemblyEnv* assemEnvPtr, int tblIdx,
			    int opnd, int count);
static void		BBEmitInst1or4(AssemblyEnv* assemEnvPtr, int tblIdx,
			    int param, int count);


static void		BBEmitOpcode(AssemblyEnv* assemEnvPtr, int tblIdx,
			    int count);
static int		BuildExceptionRanges(AssemblyEnv* assemEnvPtr);
static int		CalculateJumpRelocations(AssemblyEnv*, int*);
static int		CheckForUnclosedCatches(AssemblyEnv*);
static int		CheckForThrowInWrongContext(AssemblyEnv*);
static int		CheckNonThrowingBlock(AssemblyEnv*, BasicBlock*);
................................................................................
    BBEmitOpcode(assemEnvPtr, tblIdx, count);
    TclEmitInt4(opnd, assemEnvPtr->envPtr);
}
 
/*
 *-----------------------------------------------------------------------------
 *
 * BBEmitInst1or4 --
 *
 *	Emits a 1- or 4-byte operation according to the magnitude of the
 *	operand



 *
 *-----------------------------------------------------------------------------
 */

static void
BBEmitInst1or4(
    AssemblyEnv* assemEnvPtr,	/* Assembly environment */
................................................................................
    }
    TclEmitInt1(op, envPtr);
    if (param <= 0xff) {
	TclEmitInt1(param, envPtr);
    } else {
	TclEmitInt4(param, envPtr);
    }























    TclUpdateAtCmdStart(op, envPtr);
    BBUpdateStackReqs(bbPtr, tblIdx, count);
}
 
/*
 *-----------------------------------------------------------------------------
 *
................................................................................
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
		|| CheckStrictlyPositive(interp, opnd) != TCL_OK) {
	    goto cleanup;
	}

	// FIXME - use TclEmitInvoke
	BBEmitInst1or4(assemEnvPtr, tblIdx, opnd, opnd);
	break;

    case ASSEM_JUMP:
    case ASSEM_JUMP4:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "label");
	    goto cleanup;






>
>







 







|


|
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







<
|







242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
...
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
...
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
....
1474
1475
1476
1477
1478
1479
1480

1481
1482
1483
1484
1485
1486
1487
1488
			    int count);
static void		BBEmitInstInt1(AssemblyEnv* assemEnvPtr, int tblIdx,
			    int opnd, int count);
static void		BBEmitInstInt4(AssemblyEnv* assemEnvPtr, int tblIdx,
			    int opnd, int count);
static void		BBEmitInst1or4(AssemblyEnv* assemEnvPtr, int tblIdx,
			    int param, int count);
static void		BBEmitInvoke1or4(AssemblyEnv* assemEnvPtr, int tblIdx,
			    int param, int count);
static void		BBEmitOpcode(AssemblyEnv* assemEnvPtr, int tblIdx,
			    int count);
static int		BuildExceptionRanges(AssemblyEnv* assemEnvPtr);
static int		CalculateJumpRelocations(AssemblyEnv*, int*);
static int		CheckForUnclosedCatches(AssemblyEnv*);
static int		CheckForThrowInWrongContext(AssemblyEnv*);
static int		CheckNonThrowingBlock(AssemblyEnv*, BasicBlock*);
................................................................................
    BBEmitOpcode(assemEnvPtr, tblIdx, count);
    TclEmitInt4(opnd, assemEnvPtr->envPtr);
}
 
/*
 *-----------------------------------------------------------------------------
 *
 * BBEmitInst1or4, BBEmitInvoke1or4 --
 *
 *	Emits a 1- or 4-byte operation according to the magnitude of the
 *	operand. The Invoke variant generates wrapping stack-balance
 *	management if necessary (which is not normally required in assembled
 *	code, as loop exception ranges, expansions, breaks and continues can't
 *	be issued currently).
 *
 *-----------------------------------------------------------------------------
 */

static void
BBEmitInst1or4(
    AssemblyEnv* assemEnvPtr,	/* Assembly environment */
................................................................................
    }
    TclEmitInt1(op, envPtr);
    if (param <= 0xff) {
	TclEmitInt1(param, envPtr);
    } else {
	TclEmitInt4(param, envPtr);
    }
    TclUpdateAtCmdStart(op, envPtr);
    BBUpdateStackReqs(bbPtr, tblIdx, count);
}

static void
BBEmitInvoke1or4(
    AssemblyEnv* assemEnvPtr,	/* Assembly environment */
    int tblIdx,			/* Index in TalInstructionTable of op */
    int param,			/* Variable-length parameter */
    int count)			/* Arity if variadic */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    BasicBlock* bbPtr = assemEnvPtr->curr_bb;
				/* Current basic block */
    int op = TalInstructionTable[tblIdx].tclInstCode;

    if (param <= 0xff) {
	op >>= 8;
    } else {
	op &= 0xff;
    }
    TclEmitInvoke(envPtr, op, param);
    TclUpdateAtCmdStart(op, envPtr);
    BBUpdateStackReqs(bbPtr, tblIdx, count);
}
 
/*
 *-----------------------------------------------------------------------------
 *
................................................................................
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
		|| CheckStrictlyPositive(interp, opnd) != TCL_OK) {
	    goto cleanup;
	}


	BBEmitInvoke1or4(assemEnvPtr, tblIdx, opnd, opnd);
	break;

    case ASSEM_JUMP:
    case ASSEM_JUMP4:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "label");
	    goto cleanup;

Changes to generic/tclCompCmds.c.

1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
....
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
    TclEmitOpcode(	INST_PUSH_RESULT,			envPtr);
    TclEmitOpcode(	INST_PUSH_RETURN_OPTIONS,		envPtr);
    TclEmitOpcode(	INST_END_CATCH,				envPtr);
    TclEmitInstInt4(	INST_REVERSE, 3,			envPtr);

    TclEmitInstInt4(	INST_DICT_UPDATE_END, dictIndex,	envPtr);
    TclEmitInt4(		infoIndex,			envPtr);
    TclEmitOpcode(	INST_RETURN_STK,			envPtr);

    if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
	Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
		(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
    }
    TclStackFree(interp, keyTokenPtrs);
    return TCL_OK;
................................................................................
    }
    Emit14Inst(			INST_LOAD_SCALAR, keysTmp,	envPtr);
    if (dictVar == -1) {
	TclEmitOpcode(		INST_DICT_RECOMBINE_STK,	envPtr);
    } else {
	TclEmitInstInt4(	INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
    }
    TclEmitOpcode(		INST_RETURN_STK,		envPtr);

    /*
     * Prepare for the start of the next command.
     */

    if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
	Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",






|







 







|







1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
....
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
    TclEmitOpcode(	INST_PUSH_RESULT,			envPtr);
    TclEmitOpcode(	INST_PUSH_RETURN_OPTIONS,		envPtr);
    TclEmitOpcode(	INST_END_CATCH,				envPtr);
    TclEmitInstInt4(	INST_REVERSE, 3,			envPtr);

    TclEmitInstInt4(	INST_DICT_UPDATE_END, dictIndex,	envPtr);
    TclEmitInt4(		infoIndex,			envPtr);
    TclEmitInvoke(envPtr,INST_RETURN_STK);

    if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
	Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
		(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
    }
    TclStackFree(interp, keyTokenPtrs);
    return TCL_OK;
................................................................................
    }
    Emit14Inst(			INST_LOAD_SCALAR, keysTmp,	envPtr);
    if (dictVar == -1) {
	TclEmitOpcode(		INST_DICT_RECOMBINE_STK,	envPtr);
    } else {
	TclEmitInstInt4(	INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
    }
    TclEmitInvoke(envPtr,	INST_RETURN_STK);

    /*
     * Prepare for the start of the next command.
     */

    if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
	Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",

Changes to generic/tclCompCmdsGR.c.

2377
2378
2379
2380
2381
2382
2383




2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
    objv = TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *));

    /*
     * Scan through the return options. If any are unknown at compile time,
     * there is no value in bytecompiling. Save the option values known in an
     * objv array for merging into a return options dictionary.




     */

    for (objc = 0; objc < numOptionWords; objc++) {
	objv[objc] = Tcl_NewObj();
	Tcl_IncrRefCount(objv[objc]);
	if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
	    /*
	     * Non-literal, so punt to run-time.
	     */

	    for (; objc>=0 ; objc--) {
		TclDecrRefCount(objv[objc]);
	    }
	    TclStackFree(interp, objv);
	    goto issueRuntimeReturn;






>
>
>
>







|







2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
    objv = TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *));

    /*
     * Scan through the return options. If any are unknown at compile time,
     * there is no value in bytecompiling. Save the option values known in an
     * objv array for merging into a return options dictionary.
     *
     * TODO: There is potential for improvement if all option keys are known
     * at compile time and all option values relating to '-code' and '-level'
     * are known at compile time.
     */

    for (objc = 0; objc < numOptionWords; objc++) {
	objv[objc] = Tcl_NewObj();
	Tcl_IncrRefCount(objv[objc]);
	if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
	    /*
	     * Non-literal, so punt to run-time assembly of the dictionary.
	     */

	    for (; objc>=0 ; objc--) {
		TclDecrRefCount(objv[objc]);
	    }
	    TclStackFree(interp, objv);
	    goto issueRuntimeReturn;

Changes to generic/tclCompCmdsSZ.c.

95
96
97
98
99
100
101


102
103
104
105
106
107
108
...
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
....
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
....
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
....
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
....
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
    (var) = CurrentOffset(envPtr);TclEmitInstInt1(INST_##name##1,0,envPtr)
#define FIXJUMP1(var) \
    TclStoreInt1AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1)
#define LOAD(idx) \
    if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));}
#define STORE(idx) \
    if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));}


 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileSetCmd --
 *
 *	Procedure called to compile the "set" command.
................................................................................
	ExceptionRangeTarget(envPtr, catchRange, catchOffset);
	OP(	PUSH_RETURN_OPTIONS);
	OP(	PUSH_RESULT);
	OP(	PUSH_RETURN_CODE);
	OP(	END_CATCH);
	OP(	RETURN_CODE_BRANCH);

	/* ERROR -> reraise it */
	OP(	RETURN_STK);
	OP(	NOP);

	/* RETURN */
	TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &returnFixup);

	/* BREAK */
................................................................................
	    OP(				POP);
	    PUSH(			"-during");
	    OP4(			REVERSE, 2);
	    OP44(			DICT_SET, 1, optionsVar);
	    TclAdjustStackDepth(-1, envPtr);
	    FIXJUMP1(		dontChangeOptions);
	    OP4(			REVERSE, 2);
	    OP(				RETURN_STK);
	}

	JUMP4(				JUMP, addrsToFix[i]);
	if (matchClauses[i]) {
	    FIXJUMP4(	notECJumpSource);
	}
	FIXJUMP4(	notCodeJumpSource);
................................................................................
     * exception. Note also that INST_RETURN_STK can proceed to the next
     * instruction.
     */

    OP(					POP);
    LOAD(				optionsVar);
    LOAD(				resultVar);
    OP(					RETURN_STK);

    /*
     * Fix all the jumps from taken clauses to here (which is the end of the
     * [try]).
     */

    if (!trapZero) {
................................................................................
    OP(					POP);
    FIXJUMP1(			finalError);
    STORE(				resultVar);
    OP(					POP);
    FIXJUMP1(			finalOK);
    LOAD(				optionsVar);
    LOAD(				resultVar);
    OP(					RETURN_STK);

    return TCL_OK;
}

static int
IssueTryFinallyInstructions(
    Tcl_Interp *interp,
................................................................................
    FIXJUMP1(		jumpSplice);
    OP4(				REVERSE, 4);
    OP(					POP);
    OP(					POP);
    OP1(				JUMP1, 7);
    FIXJUMP1(		jumpOK);
    OP4(				REVERSE, 2);
    OP(					RETURN_STK);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileUnsetCmd --






>
>







 







|







 







|







 







|







 







|







 







|







95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
...
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
....
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
....
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
....
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
....
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
    (var) = CurrentOffset(envPtr);TclEmitInstInt1(INST_##name##1,0,envPtr)
#define FIXJUMP1(var) \
    TclStoreInt1AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1)
#define LOAD(idx) \
    if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));}
#define STORE(idx) \
    if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));}
#define INVOKE(name) \
    TclEmitInvoke(envPtr,INST_##name)
 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileSetCmd --
 *
 *	Procedure called to compile the "set" command.
................................................................................
	ExceptionRangeTarget(envPtr, catchRange, catchOffset);
	OP(	PUSH_RETURN_OPTIONS);
	OP(	PUSH_RESULT);
	OP(	PUSH_RETURN_CODE);
	OP(	END_CATCH);
	OP(	RETURN_CODE_BRANCH);

	/* ERROR -> reraise it; NB: can't require BREAK/CONTINUE handling */
	OP(	RETURN_STK);
	OP(	NOP);

	/* RETURN */
	TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &returnFixup);

	/* BREAK */
................................................................................
	    OP(				POP);
	    PUSH(			"-during");
	    OP4(			REVERSE, 2);
	    OP44(			DICT_SET, 1, optionsVar);
	    TclAdjustStackDepth(-1, envPtr);
	    FIXJUMP1(		dontChangeOptions);
	    OP4(			REVERSE, 2);
	    INVOKE(			RETURN_STK);
	}

	JUMP4(				JUMP, addrsToFix[i]);
	if (matchClauses[i]) {
	    FIXJUMP4(	notECJumpSource);
	}
	FIXJUMP4(	notCodeJumpSource);
................................................................................
     * exception. Note also that INST_RETURN_STK can proceed to the next
     * instruction.
     */

    OP(					POP);
    LOAD(				optionsVar);
    LOAD(				resultVar);
    INVOKE(				RETURN_STK);

    /*
     * Fix all the jumps from taken clauses to here (which is the end of the
     * [try]).
     */

    if (!trapZero) {
................................................................................
    OP(					POP);
    FIXJUMP1(			finalError);
    STORE(				resultVar);
    OP(					POP);
    FIXJUMP1(			finalOK);
    LOAD(				optionsVar);
    LOAD(				resultVar);
    INVOKE(				RETURN_STK);

    return TCL_OK;
}

static int
IssueTryFinallyInstructions(
    Tcl_Interp *interp,
................................................................................
    FIXJUMP1(		jumpSplice);
    OP4(				REVERSE, 4);
    OP(					POP);
    OP(					POP);
    OP1(				JUMP1, 7);
    FIXJUMP1(		jumpOK);
    OP4(				REVERSE, 2);
    INVOKE(				RETURN_STK);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileUnsetCmd --