From 5c4bb0f4e9e073df2b65f086dd9660cd344dcb26 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 5 Jun 2017 17:57:33 +0000 Subject: Revert performance optimization as first step to providing a refactored one. --- generic/tclExecute.c | 25 +------------------------ 1 file changed, 1 insertion(+), 24 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 30ef536..cfcdd26 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2685,34 +2685,11 @@ TEBCresume( opnd = TclGetUInt1AtPtr(pc+1); - objv = &OBJ_AT_DEPTH(opnd-1); - /* minor optimization in simplest cases */ - switch (opnd) { - case 1: /* only one object */ - objResultPtr = *objv; - goto endINST_STR_CONCAT1; - case 2: /* two objects - check empty */ - if (objv[0]->bytes == &tclEmptyString) { - objResultPtr = objv[1]; - goto endINST_STR_CONCAT1; - } - else - if (objv[1]->bytes == &tclEmptyString) { - objResultPtr = objv[0]; - goto endINST_STR_CONCAT1; - } - break; - case 0: /* no objects - use new empty */ - TclNewObj(objResultPtr); - goto endINST_STR_CONCAT1; - } - /* do concat */ if (TCL_OK != TclStringCatObjv(interp, /* inPlace */ 1, - opnd, objv, &objResultPtr)) { + opnd, &OBJ_AT_DEPTH(opnd-1), &objResultPtr)) { TRACE_ERROR(interp); goto gotError; } - endINST_STR_CONCAT1: TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(2, opnd, 1); -- cgit v0.12 From cb68061d12f2680e86ea13986fd98eabbe706537 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 5 Jun 2017 20:03:19 +0000 Subject: Optimize TclStringCatObjv() for case when only one argument is non-empty. --- generic/tclStringObj.c | 30 ++++++++++++++++++++++-------- 1 file changed, 22 insertions(+), 8 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 3478cbb..a4c242a 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2848,7 +2848,7 @@ TclStringCatObjv( Tcl_Obj **objPtrPtr) { Tcl_Obj *objPtr, *objResultPtr, * const *ov; - int oc, length = 0, binary = 1, first = 0; + int oc, length = 0, binary = 1, first = 0, last = 0; int allowUniChar = 1, requestUniChar = 0; /* assert (objc >= 2) */ @@ -2904,8 +2904,11 @@ TclStringCatObjv( int numBytes; Tcl_GetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */ - if (length == 0) { - first = objc - oc - 1; + if (numBytes) { + last = objc - oc - 1; + if (length == 0) { + first = last; + } } length += numBytes; } @@ -2920,8 +2923,11 @@ TclStringCatObjv( int numChars; Tcl_GetUnicodeFromObj(objPtr, &numChars); /* PANIC? */ - if (length == 0) { - first = objc - oc - 1; + if (numChars) { + last = objc - oc - 1; + if (length == 0) { + first = last; + } } length += numChars; } @@ -2935,8 +2941,11 @@ TclStringCatObjv( objPtr = *ov++; Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */ - if ((length == 0) && numBytes) { - first = objc - oc - 1; + if (numBytes) { + last = objc - oc - 1; + if (length == 0) { + first = last; + } } length += numBytes; } @@ -2956,8 +2965,13 @@ TclStringCatObjv( *objPtrPtr = objv[0]; return TCL_OK; } + if (last == first) { + /* Only one non-empty value; return it */ + *objPtrPtr = objv[first]; + return TCL_OK; + } - objv += first; objc -= first; + objv += first; objc = (last - first + 1); if (binary) { /* Efficiently produce a pure byte array result */ -- cgit v0.12 From 3d8a0152affb0feac24a3e9b6272e7c2badb050f Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 6 Jun 2017 08:34:00 +0000 Subject: small code review: don't need to check length if unchanged + the same case if 0 length --- generic/tclStringObj.c | 35 ++++++++++++++++++----------------- 1 file changed, 18 insertions(+), 17 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index a4c242a..c1c15f2 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2897,7 +2897,7 @@ TclStringCatObjv( if (binary) { /* Result will be pure byte array. Pre-size it */ ov = objv; oc = objc; - while (oc-- && (length >= 0)) { + while (oc--) { objPtr = *ov++; if (objPtr->bytes == NULL) { @@ -2909,14 +2909,16 @@ TclStringCatObjv( if (length == 0) { first = last; } + if ((length += numBytes) < 0) { + break; /* overflow */ + } } - length += numBytes; } } } else if (allowUniChar && requestUniChar) { /* Result will be pure Tcl_UniChar array. Pre-size it. */ ov = objv; oc = objc; - while (oc-- && (length >= 0)) { + while (oc--) { objPtr = *ov++; if ((objPtr->bytes == NULL) || (objPtr->length)) { @@ -2929,13 +2931,15 @@ TclStringCatObjv( first = last; } } - length += numChars; + if ((length += numChars) < 0) { + break; /* overflow */ + } } } } else { /* Result will be concat of string reps. Pre-size it. */ ov = objv; oc = objc; - while (oc-- && (length >= 0)) { + while (oc--) { int numBytes; objPtr = *ov++; @@ -2946,11 +2950,19 @@ TclStringCatObjv( if (length == 0) { first = last; } + if ((length += numBytes) < 0) { + break; /* overflow */ + } } - length += numBytes; } } + if (last == first || length == 0) { + /* Only one non-empty value or zero length; return first */ + *objPtrPtr = objv[first]; + return TCL_OK; + } + if (length < 0) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2960,17 +2972,6 @@ TclStringCatObjv( return TCL_ERROR; } - if (length == 0) { - /* Total length of zero means every value has length zero */ - *objPtrPtr = objv[0]; - return TCL_OK; - } - if (last == first) { - /* Only one non-empty value; return it */ - *objPtrPtr = objv[first]; - return TCL_OK; - } - objv += first; objc = (last - first + 1); if (binary) { -- cgit v0.12 From 7edce7686e817824758808dfba651a68c00558dd Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 6 Jun 2017 09:01:18 +0000 Subject: amend to [eac4656f1e8cf793] (moved to scope where numChars != 0 in Unicode case) --- generic/tclStringObj.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index c1c15f2..6332e9f 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2930,9 +2930,9 @@ TclStringCatObjv( if (length == 0) { first = last; } - } - if ((length += numChars) < 0) { - break; /* overflow */ + if ((length += numChars) < 0) { + break; /* overflow */ + } } } } -- cgit v0.12 From 615771f0b6f577cc8f23a668314bdf5cd8309a59 Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 6 Jun 2017 09:25:00 +0000 Subject: makes TclStringCatObjv safe accepting objc = 0 (or 1), then fast exits with new object / first; check-cycles rewritten to be still more faster. --- generic/tclStringObj.c | 28 ++++++++++++++++------------ 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 6332e9f..b78394e 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2851,7 +2851,11 @@ TclStringCatObjv( int oc, length = 0, binary = 1, first = 0, last = 0; int allowUniChar = 1, requestUniChar = 0; - /* assert (objc >= 2) */ + if (objc <= 1) { + /* Only one or no objects; return first or empty */ + *objPtrPtr = objc ? objv[0] : Tcl_NewObj(); + return TCL_OK; + } /* * Analyze to determine what representation result should be. @@ -2861,7 +2865,7 @@ TclStringCatObjv( */ ov = objv, oc = objc; - while (oc-- && (binary || allowUniChar)) { + do { objPtr = *ov++; if (objPtr->bytes) { @@ -2892,12 +2896,12 @@ TclStringCatObjv( } } } - } + } while (--oc && (binary || allowUniChar)); if (binary) { /* Result will be pure byte array. Pre-size it */ ov = objv; oc = objc; - while (oc--) { + do { objPtr = *ov++; if (objPtr->bytes == NULL) { @@ -2905,7 +2909,7 @@ TclStringCatObjv( Tcl_GetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */ if (numBytes) { - last = objc - oc - 1; + last = objc - oc; if (length == 0) { first = last; } @@ -2914,11 +2918,11 @@ TclStringCatObjv( } } } - } + } while (--oc); } else if (allowUniChar && requestUniChar) { /* Result will be pure Tcl_UniChar array. Pre-size it. */ ov = objv; oc = objc; - while (oc--) { + do { objPtr = *ov++; if ((objPtr->bytes == NULL) || (objPtr->length)) { @@ -2926,7 +2930,7 @@ TclStringCatObjv( Tcl_GetUnicodeFromObj(objPtr, &numChars); /* PANIC? */ if (numChars) { - last = objc - oc - 1; + last = objc - oc; if (length == 0) { first = last; } @@ -2935,18 +2939,18 @@ TclStringCatObjv( } } } - } + } while (--oc); } else { /* Result will be concat of string reps. Pre-size it. */ ov = objv; oc = objc; - while (oc--) { + do { int numBytes; objPtr = *ov++; Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */ if (numBytes) { - last = objc - oc - 1; + last = objc - oc; if (length == 0) { first = last; } @@ -2954,7 +2958,7 @@ TclStringCatObjv( break; /* overflow */ } } - } + } while (--oc); } if (last == first || length == 0) { -- cgit v0.12 From b0146fbd504c02b6561813c75835ac8333f22805 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 6 Jun 2017 12:56:37 +0000 Subject: A few more tweaks to streamline and clarify. --- generic/tclStringObj.c | 30 +++++++++++++++++------------- 1 file changed, 17 insertions(+), 13 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index b78394e..aae52ba 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2851,12 +2851,16 @@ TclStringCatObjv( int oc, length = 0, binary = 1, first = 0, last = 0; int allowUniChar = 1, requestUniChar = 0; + /* assert ( objc >= 0 ) */ + if (objc <= 1) { /* Only one or no objects; return first or empty */ *objPtrPtr = objc ? objv[0] : Tcl_NewObj(); return TCL_OK; } + /* assert ( objc >= 2 ) */ + /* * Analyze to determine what representation result should be. * GOALS: Avoid shimmering & string rep generation. @@ -2914,7 +2918,7 @@ TclStringCatObjv( first = last; } if ((length += numBytes) < 0) { - break; /* overflow */ + goto overflow; } } } @@ -2935,7 +2939,7 @@ TclStringCatObjv( first = last; } if ((length += numChars) < 0) { - break; /* overflow */ + goto overflow; } } } @@ -2955,27 +2959,19 @@ TclStringCatObjv( first = last; } if ((length += numBytes) < 0) { - break; /* overflow */ + goto overflow; } } } while (--oc); } - if (last == first || length == 0) { + if (last == first /*|| length == 0 */) { /* Only one non-empty value or zero length; return first */ + /* NOTE: (length == 0) implies (last == first) */ *objPtrPtr = objv[first]; return TCL_OK; } - if (length < 0) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - return TCL_ERROR; - } - objv += first; objc = (last - first + 1); if (binary) { @@ -3106,6 +3102,14 @@ TclStringCatObjv( } *objPtrPtr = objResultPtr; return TCL_OK; + + overflow: + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; } /* -- cgit v0.12 From 0aa0da515cfab250658ae8010baea869bb889595 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 6 Jun 2017 14:33:16 +0000 Subject: Add more test-cases for UTF-8 parser, including test-cases for TCL_UTF_MAX=4 or TCL_UTF_MAX=6 --- tests/encoding.test | 20 +++++++++++++------- tests/string.test | 18 +++++++++++------- tests/utf.test | 38 ++++++++++++++++++++++++++++++++------ 3 files changed, 56 insertions(+), 20 deletions(-) diff --git a/tests/encoding.test b/tests/encoding.test index a359f76..5b3c3e1 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -34,6 +34,7 @@ proc runtests {} { # Some tests require the testencoding command testConstraint testencoding [llength [info commands testencoding]] +testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}] testConstraint exec [llength [info commands exec]] testConstraint testgetdefenc [llength [info commands testgetdefenc]] @@ -73,7 +74,7 @@ test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup { } -constraints {testencoding} -body { encoding system shiftjis ;# incr ref count encoding dirs [list [pwd]] - set x [encoding convertto shiftjis \u4e4e] ;# old one found + set x [encoding convertto shiftjis \u4e4e] ;# old one found encoding system identity llength shiftjis ;# Shimmer away any cache of Tcl_Encoding lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg @@ -182,7 +183,7 @@ test encoding-8.1 {Tcl_ExternalToUtf} { puts -nonewline $f "ab\x8c\xc1g" close $f set f [open [file join [temporaryDirectory] dummy] r] - fconfigure $f -translation binary -encoding shiftjis + fconfigure $f -translation binary -encoding shiftjis set x [read $f] close $f file delete [file join [temporaryDirectory] dummy] @@ -265,7 +266,7 @@ test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} makeDirectory tmp makeDirectory [file join tmp encoding] set f [open [file join tmp encoding splat.enc] w] - fconfigure $f -translation binary + fconfigure $f -translation binary puts $f "abcdefghijklmnop" close $f encoding convertto splat \u4e4e @@ -286,11 +287,11 @@ test encoding-12.1 {LoadTableEncoding: normal encoding} { append x [encoding convertfrom iso8859-3 \xd5] } "\xd5?\u120" test encoding-12.2 {LoadTableEncoding: single-byte encoding} { - set x [encoding convertto iso8859-3 ab\u0120g] + set x [encoding convertto iso8859-3 ab\u0120g] append x [encoding convertfrom iso8859-3 ab\xd5g] } "ab\xd5gab\u120g" test encoding-12.3 {LoadTableEncoding: multi-byte encoding} { - set x [encoding convertto shiftjis ab\u4e4eg] + set x [encoding convertto shiftjis ab\u4e4eg] append x [encoding convertfrom shiftjis ab\x8c\xc1g] } "ab\x8c\xc1gab\u4e4eg" test encoding-12.4 {LoadTableEncoding: double-byte encoding} { @@ -332,9 +333,14 @@ test encoding-16.1 {UnicodeToUtfProc} { set val [encoding convertfrom unicode NN] list $val [format %x [scan $val %c]] } "\u4e4e 4e4e" +test encoding-16.2 {UnicodeToUtfProc} -constraints fullutf -body { + set val [encoding convertfrom unicode "\xd8\xd8\xdc\xdc"] + list $val [format %x [scan $val %c]] +} -result "\U460dc 460dc" -test encoding-17.1 {UtfToUnicodeProc} { -} {} +test encoding-17.1 {UtfToUnicodeProc} -constraints fullutf -body { + encoding convertto unicode "\U460dc" +} -result "\xd8\xd8\xdc\xdc" test encoding-18.1 {TableToUtfProc} { } {} diff --git a/tests/string.test b/tests/string.test index 3611753..cc65e67 100644 --- a/tests/string.test +++ b/tests/string.test @@ -219,7 +219,7 @@ test string-4.14 {string first, negative start index} { } 1 test string-4.15 {string first, ability to two-byte encoded utf-8 chars} { # Test for a bug in Tcl 8.3 where test for all-single-byte-encoded - # strings was incorrect, leading to an index returned by [string first] + # strings was incorrect, leading to an index returned by [string first] # which pointed past the end of the string. set uchar \u057e ;# character with two-byte encoding in utf-8 string first % %#$uchar$uchar#$uchar$uchar#% 3 @@ -419,7 +419,7 @@ test string-6.37 {string is double, false on int overflow} -setup { } -result {1 priorValue} # string-6.38 removed, underflow on input is no longer an error. test string-6.39 {string is double, false} { - # This test is non-portable because IRIX thinks + # This test is non-portable because IRIX thinks # that .e1 is a valid double - this is really a bug # on IRIX as .e1 should NOT be a valid double # @@ -576,12 +576,12 @@ test string-6.85 {string is control} { } 0 test string-6.86 {string is graph} { ## graph is any print char, except space - list [string is gra -fail var "0123abc!@#\$\u0100 "] $var -} {0 12} + list [string is gra -fail var "0123abc!@#\$\u0100\UE0100\UE01EF "] $var +} {0 14} test string-6.87 {string is print} { ## basically any printable char - list [string is print -fail var "0123abc!@#\$\u0100 \u0010"] $var -} {0 13} + list [string is print -fail var "0123abc!@#\$\u0100 \UE0100\UE01EF\u0010"] $var +} {0 15} test string-6.88 {string is punct} { ## any graph char that isn't alnum list [string is punct -fail var "_!@#\u00beq0"] $var @@ -901,6 +901,10 @@ test string-10.20 {string map, dictionaries don't alter map ordering} { set map {aa X a Y} list [string map [dict create aa X a Y] aaa] [string map $map aaa] [dict size $map] [string map $map aaa] } {XY XY 2 XY} +test string-10.20.1 {string map, dictionaries don't alter map ordering} { + set map {a X b Y a Z} + list [string map [dict create a X b Y a Z] aaa] [string map $map aaa] [dict size $map] [string map $map aaa] +} {ZZZ XXX 2 XXX} test string-10.21 {string map, ABR checks} { string map {longstring foob} long } long @@ -1833,7 +1837,7 @@ proc MemStress {args} { set res {} foreach body $args { set end 0 - for {set i 0} {$i < 5} {incr i} { + for {set i 0} {$i < 5} {incr i} { proc MemStress_Body {} $body uplevel 1 MemStress_Body rename MemStress_Body {} diff --git a/tests/utf.test b/tests/utf.test index a03dd6c..28981d6 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -20,6 +20,9 @@ testConstraint testbytestring [llength [info commands testbytestring]] catch {unset x} +# Some tests require support for 4-byte UTF-8 sequences +testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}] + test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} testbytestring { expr {"\x01" eq [testbytestring "\x01"]} } 1 @@ -38,6 +41,9 @@ test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring { test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring { expr {[format %c -1] eq [testbytestring "\xef\xbf\xbd"]} } 1 +test utf-1.7 {Tcl_UniCharToUtf: 4 byte sequences} -constraints {fullutf testbytestring} -body { + expr {"\U014e4e" eq [testbytestring "\xf0\x94\xb9\x8e"]} +} -result 1 test utf-2.1 {Tcl_UtfToUniChar: low ascii} { string length "abc" @@ -60,9 +66,21 @@ test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} testbytestrin test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring { string length [testbytestring "\xE4\xb9\x8e"] } {1} -test utf-2.8 {Tcl_UtfToUniChar: longer UTF sequences not supported} testbytestring { - string length [testbytestring "\xF4\xA2\xA2\xA2"] +test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body { + string length [testbytestring "\xF0\x90\x80\x80"] +} -result {1} +test utf-2.9 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body { + string length [testbytestring "\xF4\x8F\xBF\xBF"] +} -result {1} +test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring { + string length [testbytestring "\xF0\x8F\xBF\xBF"] +} {4} +test utf-2.11 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, overflow} testbytestring { + string length [testbytestring "\xF4\x90\x80\x80"] } {4} +test utf-2.12 {Tcl_UtfToUniChar: longer UTF sequences not supported} testbytestring { + string length [testbytestring "\xF8\xA2\xA2\xA2\xA2"] +} {5} test utf-3.1 {Tcl_UtfCharComplete} { } {} @@ -195,8 +213,16 @@ bsCheck \Ua1 161 bsCheck \U4e21 20001 bsCheck \U004e21 20001 bsCheck \U00004e21 20001 -bsCheck \U00110000 65533 -bsCheck \Uffffffff 65533 +bsCheck \U0000004e21 78 +if {[testConstraint fullutf]} { + bsCheck \U00110000 69632 + bsCheck \U01100000 69632 + bsCheck \U11000000 69632 + bsCheck \U0010FFFF 1114111 + bsCheck \U010FFFF0 1114111 + bsCheck \U10FFFF00 1114111 + bsCheck \UFFFFFFFF 1048575 +} test utf-11.1 {Tcl_UtfToUpper} { string toupper {} @@ -264,8 +290,8 @@ test utf-16.1 {Tcl_UniCharToLower, negative delta} { string tolower aA } aa test utf-16.2 {Tcl_UniCharToLower, positive delta} { - string tolower \u0178\u00ff\uA78D\u01c5 -} \u00ff\u00ff\u0265\u01c6 + string tolower \u0178\u00ff\uA78D\u01c5\U10400 +} \u00ff\u00ff\u0265\u01c6\U10428 test utf-17.1 {Tcl_UniCharToLower, no delta} { string tolower ! -- cgit v0.12