Tcl Source Code

Check-in [35565158e5]
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:merge new catch compiler
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | mig-optimize
Files: files | file ages | folders
SHA1: 35565158e5aa6a503614bc2ce14462c43cad9ba4
User & Date: mig 2013-12-11 17:29:22
Context
2013-12-11
18:02
fix stupid error check-in: d203d7e71a user: mig tags: mig-optimize
17:31
merge - no diff to mig-optimize has yet been committed check-in: 95715761bd user: mig
17:29
merge new catch compiler check-in: 35565158e5 user: mig tags: mig-optimize
17:13
allow simple optimization of the OK case, at the cost of some code duplication Closed-Leaf check-in: e777d7ae20 user: mig tags: mig-catch-compiler
12:57
shrink 4 jumps even if not recursing; change jumps to next into NOP or POP check-in: 98e98e59ec user: mig tags: mig-optimize
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclCompCmds.c.

582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605

606
607
608
609
610
611
612
613
614
615
616



617
618
619
620
621

622
623
624

625
626
627

628
629
630
631
632
633
634
635
636
637

638



639
640
641
642
643
644


645
646

647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670



671
672


673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
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
	    }
	}
    }

    /*
     * We will compile the catch command. Declare the exception range that it
     * uses.
     */

    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);

    /*
     * If the body is a simple word, compile a BEGIN_CATCH instruction,
     * followed by the instructions to eval the body.
     * Otherwise, compile instructions to substitute the body text before
     * starting the catch, then BEGIN_CATCH, and then EVAL_STK to evaluate the
     * substituted body.
     * Care has to be taken to make sure that substitution happens outside the
     * catch range so that errors in the substitution are not caught.
     * [Bug 219184]
     * The reason for duplicating the script is that EVAL_STK would otherwise
     * begin by undeflowing the stack below the mark set by BEGIN_CATCH4.
     */


    if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	TclEmitInstInt4(	INST_BEGIN_CATCH4, range,	envPtr);
	ExceptionRangeStarts(envPtr, range);
	BODY(cmdTokenPtr, 1);
    } else {
	SetLineInformation(1);
	CompileTokens(envPtr, cmdTokenPtr, interp);
	TclEmitInstInt4(	INST_BEGIN_CATCH4, range,	envPtr);
	ExceptionRangeStarts(envPtr, range);
	TclEmitOpcode(		INST_DUP,			envPtr);
	TclEmitInvoke(envPtr,	INST_EVAL_STK);



    }
    /* Stack at this point:
     *    nonsimple:  script <mark> result
     *    simple:            <mark> result
     */


    if (resultIndex == -1) {
	/*

	 * Special case when neither result nor options are being saved. In
	 * that case, we can skip quite a bit of the command epilogue; all we
	 * have to do is drop the result and push the return code (and, of

	 * course, finish the catch context).
	 */

	TclEmitOpcode(		INST_POP,			envPtr);
	PushStringLiteral(envPtr, "0");
	TclEmitInstInt1(	INST_JUMP1, 3,			envPtr);
	TclAdjustStackDepth(-1, envPtr);
	ExceptionRangeTarget(envPtr, range, catchOffset);
	TclEmitOpcode(		INST_PUSH_RETURN_CODE,		envPtr);
	ExceptionRangeEnds(envPtr, range);

	TclEmitOpcode(		INST_END_CATCH,			envPtr);




	/*
	 * Stack at this point:
	 *    nonsimple:  script <mark> returnCode
	 *    simple:            <mark> returnCode
	 */



	goto dropScriptAtEnd;

    }

    /*
     * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result,
     * and jump around the "error case" code.
     */

    PushStringLiteral(envPtr, "0");
    TclEmitForwardJump(envPtr, JUMP, &jumpFixup);
    /* Stack at this point: ?script? <mark> result TCL_OK */

    /* 
     * Emit the "error case" epilogue. Push the interpreter result and the
     * return code.
     */

    TclAdjustStackDepth(-2, envPtr);
    ExceptionRangeTarget(envPtr, range, catchOffset);
    /* Stack at this point:  ?script? */
    TclEmitOpcode(		INST_PUSH_RESULT,		envPtr);
    TclEmitOpcode(		INST_PUSH_RETURN_CODE,		envPtr);

    /*
     * Update the target of the jump after the "no errors" code. 



     */



    /* Stack at this point: ?script? result returnCode */
    TclFixupForwardJumpToHere(envPtr, jumpFixup);

    /*
     * Push the return options if the caller wants them.
     */

    if (optsIndex != -1) {
	TclEmitOpcode(		INST_PUSH_RETURN_OPTIONS,	envPtr);
    }

    /*
     * End the catch
     */

    ExceptionRangeEnds(envPtr, range);
    TclEmitOpcode(		INST_END_CATCH,			envPtr);

    /*
     * At this point, the top of the stack is inconveniently ordered:
     *		?script? result returnCode ?returnOptions?
     * Reverse the stack to bring the result to the top.
     */

    if (optsIndex != -1) {
	TclEmitInstInt4(	INST_REVERSE, 3,		envPtr);
    } else {
	TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
    }

    /*
     * Store the result and remove it from the stack.
     */

    Emit14Inst(			INST_STORE_SCALAR, resultIndex,	envPtr);
    TclEmitOpcode(		INST_POP,			envPtr);

    /*
     * Stack is now ?script? ?returnOptions? returnCode.
     * If the options dict has been requested, it is buried on the stack under
     * the return code. Reverse the stack to bring it to the top, store it and
     * remove it from the stack.
     */

    if (optsIndex != -1) {
	TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
	Emit14Inst(		INST_STORE_SCALAR, optsIndex,	envPtr);
	TclEmitOpcode(		INST_POP,			envPtr);
    }

  dropScriptAtEnd:

    /*
     * Stack is now ?script? result. Get rid of the subst'ed script if it's
     * hanging arond.
     */

    if (cmdTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
	TclEmitOpcode(		INST_POP,			envPtr);
    }


    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileContinueCmd --






<
|
<
<
<












>











>
>
>

<
<
<
<
>

<
|
>
|
|
<
>
|
|

|
<
<
<
<
|
<
>
|
>
>
>
|
<
<
<
<
<
>
>
|
<
>
|
<
<
<
<
<
<


<






|

<
<
<

<
<
>
>
>


>
>
|
<
|
<
<
<
<



<
<
<
<
<
<



|
|
<



<
<
<
<
<
<
<
<
<
|
|
|
<
<
<
<
<
<
<
|
<
|
|


<
<
<
<
<
<
<
<
<
<
<
<
>







582
583
584
585
586
587
588

589



590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617




618
619

620
621
622
623

624
625
626
627
628




629

630
631
632
633
634
635





636
637
638

639
640






641
642

643
644
645
646
647
648
649
650



651


652
653
654
655
656
657
658
659

660




661
662
663






664
665
666
667
668

669
670
671









672
673
674







675

676
677
678
679












680
681
682
683
684
685
686
687
	    }
	}
    }

    /*
     * We will compile the catch command. Declare the exception range that it
     * uses.

     *



     * If the body is a simple word, compile a BEGIN_CATCH instruction,
     * followed by the instructions to eval the body.
     * Otherwise, compile instructions to substitute the body text before
     * starting the catch, then BEGIN_CATCH, and then EVAL_STK to evaluate the
     * substituted body.
     * Care has to be taken to make sure that substitution happens outside the
     * catch range so that errors in the substitution are not caught.
     * [Bug 219184]
     * The reason for duplicating the script is that EVAL_STK would otherwise
     * begin by undeflowing the stack below the mark set by BEGIN_CATCH4.
     */

    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
    if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	TclEmitInstInt4(	INST_BEGIN_CATCH4, range,	envPtr);
	ExceptionRangeStarts(envPtr, range);
	BODY(cmdTokenPtr, 1);
    } else {
	SetLineInformation(1);
	CompileTokens(envPtr, cmdTokenPtr, interp);
	TclEmitInstInt4(	INST_BEGIN_CATCH4, range,	envPtr);
	ExceptionRangeStarts(envPtr, range);
	TclEmitOpcode(		INST_DUP,			envPtr);
	TclEmitInvoke(envPtr,	INST_EVAL_STK);
	/* drop the script */
	TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
	TclEmitOpcode(		INST_POP,			envPtr);
    }




    ExceptionRangeEnds(envPtr, range);


    /*
     * Emit the "no errors" epilogue: last instruction is push "0" (TCL_OK)
     * as the catch result, and jump to the end. There is some code
     * duplication in order to allow the optimization of the OK case.

     *
     * NOTE: see comments on instruction ordering below!
     */

    if (optsIndex != -1) {




	TclEmitOpcode(		INST_PUSH_RETURN_OPTIONS,	envPtr);

    }
    TclEmitOpcode(		INST_END_CATCH,			envPtr);
    if (optsIndex != -1) {
	Emit14Inst(		INST_STORE_SCALAR, optsIndex,	envPtr);
	TclEmitOpcode(		INST_POP,			envPtr);
    }





    if (resultIndex != -1) {
	Emit14Inst(	INST_STORE_SCALAR, resultIndex,	envPtr);
    }

    TclEmitOpcode(	INST_POP,			envPtr);
    






    PushStringLiteral(envPtr, "0");
    TclEmitForwardJump(envPtr, JUMP, &jumpFixup);


    /* 
     * Emit the "error case" epilogue. Push the interpreter result and the
     * return code.
     */

    TclAdjustStackDepth(-1, envPtr);
    ExceptionRangeTarget(envPtr, range, catchOffset);






    /* Stack at this point is empty. Push the return code, then push the
     * result and return options if the caller wants them. This needs to
     * happen before INST_END_CATCH.
     */

    TclEmitOpcode(		INST_PUSH_RETURN_CODE,		envPtr);
    if (resultIndex != -1) {
	TclEmitOpcode(		INST_PUSH_RESULT,		envPtr);

    }




    if (optsIndex != -1) {
	TclEmitOpcode(		INST_PUSH_RETURN_OPTIONS,	envPtr);
    }






    TclEmitOpcode(		INST_END_CATCH,			envPtr);

    /*
     * Save the result and return options if the caller wants them. This needs
     * to happen after INST_END_CATCH (compile-3.6/7).

     */

    if (optsIndex != -1) {









	Emit14Inst(		INST_STORE_SCALAR, optsIndex,	envPtr);
	TclEmitOpcode(		INST_POP,			envPtr);
    }







    if (resultIndex != -1) {

	Emit14Inst(	INST_STORE_SCALAR, resultIndex,	envPtr);
	TclEmitOpcode(	INST_POP,			envPtr);
    }













    TclFixupForwardJumpToHere(envPtr, jumpFixup);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileContinueCmd --

Changes to tests/compile.test.

162
163
164
165
166
167
168






























169
170
171
172
173
174
175
	    list $count $result2
	}
	catchtest::x
    }
    -result {10 {can't set "result1": trace on result1 fails by request}}
    -cleanup {namespace delete catchtest}
}































test compile-4.1 {TclCompileForCmd: command substituted test expression} {
    set i 0
    set j 0
    # Should be "forever"
    for {} [expr $i < 3] {} {
	set j [incr i]






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







162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
	    list $count $result2
	}
	catchtest::x
    }
    -result {10 {can't set "result1": trace on result1 fails by request}}
    -cleanup {namespace delete catchtest}
}

test compile-3.7 {TclCompileCatchCmd: error in storing options [Bug 3098302]} {*}{
     -setup {
	 namespace eval catchtest {
	     variable options1 {}
	 }
	 trace add variable catchtest::options1 write catchtest::failtrace
	 proc catchtest::failtrace {n1 n2 op} {
	     return -code error "trace on $n1 fails by request"
	 }
     }
    -body {
	proc catchtest::x {} {
	    variable options1
	    set count 0
	    for {set i 0} {$i < 10} {incr i} {
		set status2 [catch {
		    set status1 [catch {
			return -code error -level 0 "original failure"
		    } result1 options1]
		} result2 options2]
		incr count
	    }
	    list $count $result2
	}
	catchtest::x
    }
    -result {10 {can't set "options1": trace on options1 fails by request}}
    -cleanup {namespace delete catchtest}
}

test compile-4.1 {TclCompileForCmd: command substituted test expression} {
    set i 0
    set j 0
    # Should be "forever"
    for {} [expr $i < 3] {} {
	set j [incr i]