Tcl Source Code

Check-in [b274b30ee6]
Login

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

Overview
Comment:Improve code generation for [array set] in a common case.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: b274b30ee6c40d94e8eef68d4f0ae9a9a3ec00ff
User & Date: dkf 2013-04-29 09:31:53
Context
2013-04-30
18:49
(::platform::LibcVersion): Followup to the 2013-01-30 change. The RE become too restrictive again. S... check-in: b15cddcf1f user: andreask tags: trunk
2013-04-29
12:34
Bringing vexpr up to date with the latest trunk.

Combining the vexpr patch with my fix to the m4 fi... Closed-Leaf check-in: 728208200b user: hypnotoad tags: hypnotoad-vexpr

12:31
Bringing patch up to date with the latest trunk Closed-Leaf check-in: 216aa27e26 user: hypnotoad tags: hypnotoad-prefer-native-8.6
09:31
Improve code generation for [array set] in a common case. check-in: b274b30ee6 user: dkf tags: trunk
2013-04-25
07:40
merge-mark check-in: f97e93ec09 user: jan.nijtmans tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.






1
2
3
4
5
6
7





2013-04-23  Jan Nijtmans  <[email protected]>

	* generic/tclDecls.h: Implement Tcl_NewBooleanObj, Tcl_DbNewBooleanObj
	and Tcl_SetBooleanObj as macros using Tcl_NewIntObj, Tcl_DbNewLongObj
	and Tcl_SetIntObj. Starting with Tcl 8.5, this is exactly the same,
	it only eliminates code duplication.
	* generic/tclInt.h: Eliminate use of NO_WIDE_TYPE everywhere: It's
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
2013-04-29  Donal K. Fellows  <[email protected]>

	* generic/tclCompCmds.c (TclCompileArraySetCmd): Generate better code
	when the list of things to set is a literal.

2013-04-23  Jan Nijtmans  <[email protected]>

	* generic/tclDecls.h: Implement Tcl_NewBooleanObj, Tcl_DbNewBooleanObj
	and Tcl_SetBooleanObj as macros using Tcl_NewIntObj, Tcl_DbNewLongObj
	and Tcl_SetIntObj. Starting with Tcl 8.5, this is exactly the same,
	it only eliminates code duplication.
	* generic/tclInt.h: Eliminate use of NO_WIDE_TYPE everywhere: It's

Changes to generic/tclCompCmds.c.

282
283
284
285
286
287
288

289
290

291
292
293
294
295
296
297
298
299
300
301
302
303






304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326


327















328
329
330
331
332
333
334
    Command *cmdPtr,		/* Points to defintion of command being
				 * compiled. */
    CompileEnv *envPtr)		/* Holds resulting instructions. */
{
    DefineLineInformation;	/* TIP #280 */
    Tcl_Token *varTokenPtr, *dataTokenPtr;
    int simpleVarName, isScalar, localIndex;

    int dataVar, iterVar, keyVar, valVar, infoIndex;
    int back, fwd, offsetBack, offsetFwd, savedStackDepth;

    ForeachInfo *infoPtr;

    if (parsePtr->numWords != 3) {
	return TCL_ERROR;
    }

    varTokenPtr = TokenAfter(parsePtr->tokenPtr);
    PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
	    &localIndex, &simpleVarName, &isScalar, 1);
    dataTokenPtr = TokenAfter(varTokenPtr);
    if (!isScalar) {
	return TCL_ERROR;
    }







    /*
     * Special case: literal empty value argument is just an "ensure array"
     * operation.
     */

    if (dataTokenPtr->type == TCL_TOKEN_SIMPLE_WORD
	    && dataTokenPtr[1].size == 0) {
	if (localIndex >= 0) {
	    TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex,	envPtr);
	    TclEmitInstInt1(INST_JUMP_TRUE1, 7,			envPtr);
	    TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex,	envPtr);
	} else {
	    TclEmitOpcode(  INST_DUP,				envPtr);
	    TclEmitOpcode(  INST_ARRAY_EXISTS_STK,		envPtr);
	    TclEmitInstInt1(INST_JUMP_TRUE1, 5,			envPtr);
	    savedStackDepth = envPtr->currStackDepth;
	    TclEmitOpcode(  INST_ARRAY_MAKE_STK,		envPtr);
	    TclEmitInstInt1(INST_JUMP1, 3,			envPtr);
	    envPtr->currStackDepth = savedStackDepth;
	    TclEmitOpcode(  INST_POP,				envPtr);
	}
	PushLiteral(envPtr, "", 0);


	return TCL_OK;















    }

    /*
     * Prepare for the internal foreach.
     */

    dataVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);







>


>









<



>
>
>
>
>
>






<
|















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







282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301

302
303
304
305
306
307
308
309
310
311
312
313
314
315
316

317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
    Command *cmdPtr,		/* Points to defintion of command being
				 * compiled. */
    CompileEnv *envPtr)		/* Holds resulting instructions. */
{
    DefineLineInformation;	/* TIP #280 */
    Tcl_Token *varTokenPtr, *dataTokenPtr;
    int simpleVarName, isScalar, localIndex;
    int isDataLiteral, isDataValid, isDataEven, len;
    int dataVar, iterVar, keyVar, valVar, infoIndex;
    int back, fwd, offsetBack, offsetFwd, savedStackDepth;
    Tcl_Obj *literalObj;
    ForeachInfo *infoPtr;

    if (parsePtr->numWords != 3) {
	return TCL_ERROR;
    }

    varTokenPtr = TokenAfter(parsePtr->tokenPtr);
    PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
	    &localIndex, &simpleVarName, &isScalar, 1);

    if (!isScalar) {
	return TCL_ERROR;
    }
    dataTokenPtr = TokenAfter(varTokenPtr);
    literalObj = Tcl_NewObj();
    isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj);
    isDataValid = (isDataLiteral
	    && Tcl_ListObjLength(NULL, literalObj, &len) == TCL_OK);
    isDataEven = (isDataValid && (len & 1) == 0);

    /*
     * Special case: literal empty value argument is just an "ensure array"
     * operation.
     */


    if (isDataEven && len == 0) {
	if (localIndex >= 0) {
	    TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex,	envPtr);
	    TclEmitInstInt1(INST_JUMP_TRUE1, 7,			envPtr);
	    TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex,	envPtr);
	} else {
	    TclEmitOpcode(  INST_DUP,				envPtr);
	    TclEmitOpcode(  INST_ARRAY_EXISTS_STK,		envPtr);
	    TclEmitInstInt1(INST_JUMP_TRUE1, 5,			envPtr);
	    savedStackDepth = envPtr->currStackDepth;
	    TclEmitOpcode(  INST_ARRAY_MAKE_STK,		envPtr);
	    TclEmitInstInt1(INST_JUMP1, 3,			envPtr);
	    envPtr->currStackDepth = savedStackDepth;
	    TclEmitOpcode(  INST_POP,				envPtr);
	}
	PushLiteral(envPtr, "", 0);
	goto done;
    }

    /*
     * Special case: literal odd-length argument is always an error.
     */

    if (isDataValid && !isDataEven) {
	savedStackDepth = envPtr->currStackDepth;
	PushLiteral(envPtr, "list must have an even number of elements",
		strlen("list must have an even number of elements"));
	PushLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}",
		strlen("-errorCode {TCL ARGUMENT FORMAT}"));
	TclEmitInstInt4(INST_RETURN_IMM, 1,			envPtr);
	TclEmitInt4(		0,				envPtr);
	envPtr->currStackDepth = savedStackDepth;
	PushLiteral(envPtr, "", 0);
	goto done;
    }

    /*
     * Prepare for the internal foreach.
     */

    dataVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379








380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395

396
397
398
399
400
401
402
	if (localIndex >= 0) {
	    CompileWord(envPtr, varTokenPtr, interp, 1);
	} else {
	    TclEmitInstInt4(INST_REVERSE, 2,			envPtr);
	}
	CompileWord(envPtr, dataTokenPtr, interp, 2);
	TclEmitInstInt1(INST_INVOKE_STK1, 3,			envPtr);
	return TCL_OK;
    }

    infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *));
    infoPtr->numLists = 1;
    infoPtr->firstValueTemp = dataVar;
    infoPtr->loopCtTemp = iterVar;
    infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) * 2*sizeof(int));
    infoPtr->varLists[0]->numVars = 2;
    infoPtr->varLists[0]->varIndexes[0] = keyVar;
    infoPtr->varLists[0]->varIndexes[1] = valVar;
    infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr);

    /*
     * Start issuing instructions to write to the array.
     */

    CompileWord(envPtr, dataTokenPtr, interp, 2);








    TclEmitOpcode(	INST_DUP,				envPtr);
    TclEmitOpcode(	INST_LIST_LENGTH,			envPtr);
    PushLiteral(envPtr, "1", 1);
    TclEmitOpcode(	INST_BITAND,				envPtr);
    offsetFwd = CurrentOffset(envPtr);
    TclEmitInstInt1(	INST_JUMP_FALSE1, 0,			envPtr);
    savedStackDepth = envPtr->currStackDepth;
    PushLiteral(envPtr, "list must have an even number of elements",
	    strlen("list must have an even number of elements"));
    PushLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}",
	    strlen("-errorCode {TCL ARGUMENT FORMAT}"));
    TclEmitInstInt4(	INST_RETURN_IMM, 1,			envPtr);
    TclEmitInt4(		0,				envPtr);
    envPtr->currStackDepth = savedStackDepth;
    fwd = CurrentOffset(envPtr) - offsetFwd;
    TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);

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

    if (localIndex >= 0) {
	TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex,	envPtr);
	TclEmitInstInt1(INST_JUMP_TRUE1, 7,			envPtr);
	TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex,	envPtr);







|

















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







378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
	if (localIndex >= 0) {
	    CompileWord(envPtr, varTokenPtr, interp, 1);
	} else {
	    TclEmitInstInt4(INST_REVERSE, 2,			envPtr);
	}
	CompileWord(envPtr, dataTokenPtr, interp, 2);
	TclEmitInstInt1(INST_INVOKE_STK1, 3,			envPtr);
	goto done;
    }

    infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *));
    infoPtr->numLists = 1;
    infoPtr->firstValueTemp = dataVar;
    infoPtr->loopCtTemp = iterVar;
    infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) * 2*sizeof(int));
    infoPtr->varLists[0]->numVars = 2;
    infoPtr->varLists[0]->varIndexes[0] = keyVar;
    infoPtr->varLists[0]->varIndexes[1] = valVar;
    infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr);

    /*
     * Start issuing instructions to write to the array.
     */

    CompileWord(envPtr, dataTokenPtr, interp, 2);
    if (!isDataLiteral || !isDataValid) {
	/*
	 * Only need this safety check if we're handling a non-literal or list
	 * containing an invalid literal; with valid list literals, we've
	 * already checked (worth it because literals are a very common
	 * use-case with [array set]).
	 */

	TclEmitOpcode(	INST_DUP,				envPtr);
	TclEmitOpcode(	INST_LIST_LENGTH,			envPtr);
	PushLiteral(envPtr, "1", 1);
	TclEmitOpcode(	INST_BITAND,				envPtr);
	offsetFwd = CurrentOffset(envPtr);
	TclEmitInstInt1(INST_JUMP_FALSE1, 0,			envPtr);
	savedStackDepth = envPtr->currStackDepth;
	PushLiteral(envPtr, "list must have an even number of elements",
		strlen("list must have an even number of elements"));
	PushLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}",
		strlen("-errorCode {TCL ARGUMENT FORMAT}"));
	TclEmitInstInt4(INST_RETURN_IMM, 1,			envPtr);
	TclEmitInt4(		0,				envPtr);
	envPtr->currStackDepth = savedStackDepth;
	fwd = CurrentOffset(envPtr) - offsetFwd;
	TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
    }
    Emit14Inst(		INST_STORE_SCALAR, dataVar,		envPtr);
    TclEmitOpcode(	INST_POP,				envPtr);

    if (localIndex >= 0) {
	TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex,	envPtr);
	TclEmitInstInt1(INST_JUMP_TRUE1, 7,			envPtr);
	TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex,	envPtr);
435
436
437
438
439
440
441

442
443

444


445
446
447
448
449
450
451
	back = offsetBack - CurrentOffset(envPtr);
	TclEmitInstInt1(INST_JUMP1, back,			envPtr);
	fwd = CurrentOffset(envPtr) - offsetFwd;
	TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
	envPtr->currStackDepth = savedStackDepth;
	TclEmitOpcode(	INST_POP,				envPtr);
    }

    TclEmitInstInt1(	INST_UNSET_SCALAR, 0,			envPtr);
    TclEmitInt4(		dataVar,			envPtr);

    PushLiteral(envPtr,	"", 0);


    return TCL_OK;
}

int
TclCompileArrayUnsetCmd(
    Tcl_Interp *interp,		/* Used for looking up stuff. */
    Tcl_Parse *parsePtr,	/* Points to a parse structure for the command







>
|
|
>

>
>







467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
	back = offsetBack - CurrentOffset(envPtr);
	TclEmitInstInt1(INST_JUMP1, back,			envPtr);
	fwd = CurrentOffset(envPtr) - offsetFwd;
	TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
	envPtr->currStackDepth = savedStackDepth;
	TclEmitOpcode(	INST_POP,				envPtr);
    }
    if (!isDataLiteral) {
	TclEmitInstInt1(INST_UNSET_SCALAR, 0,			envPtr);
	TclEmitInt4(		dataVar,			envPtr);
    }
    PushLiteral(envPtr,	"", 0);
  done:
    Tcl_DecrRefCount(literalObj);
    return TCL_OK;
}

int
TclCompileArrayUnsetCmd(
    Tcl_Interp *interp,		/* Used for looking up stuff. */
    Tcl_Parse *parsePtr,	/* Points to a parse structure for the command

Changes to tests/set-old.test.

674
675
676
677
678
679
680





681
682
683
684
685
686
687
} [list 1 "\"a\" isn't an array"]
test set-old-8.57 {array command, array get with trivial pattern} {
    catch {unset a}
    set a(x) 1
    set a(y) 2
    array get a x
} {x 1}






test set-old-9.1 {ids for array enumeration} {
    catch {unset a}
    set a(a) 1
    list [array star a] [array star a] [array done a s-1-a; array star a] \
	    [array done a s-2-a; array d a s-3-a; array start a]
} {s-1-a s-2-a s-3-a s-1-a}







>
>
>
>
>







674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
} [list 1 "\"a\" isn't an array"]
test set-old-8.57 {array command, array get with trivial pattern} {
    catch {unset a}
    set a(x) 1
    set a(y) 2
    array get a x
} {x 1}
test set-old-8.58 {array command, array set with LVT and odd length literal} {
    list [catch {apply {{} {
	array set a {b c d}
    }}} msg] $msg
} {1 {list must have an even number of elements}}

test set-old-9.1 {ids for array enumeration} {
    catch {unset a}
    set a(a) 1
    list [array star a] [array star a] [array done a s-1-a; array star a] \
	    [array done a s-2-a; array d a s-3-a; array start a]
} {s-1-a s-2-a s-3-a s-1-a}