From 0908f2ec1d8a680a41f811cc6181c4a719bd6fa7 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 26 Jan 2024 22:18:14 +0000 Subject: added channel regression tests (for read command) to illustrate bugs [db4f2843cd], [da16d15574] --- tests-perf/chan.perf.tcl | 93 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 93 insertions(+) create mode 100644 tests-perf/chan.perf.tcl diff --git a/tests-perf/chan.perf.tcl b/tests-perf/chan.perf.tcl new file mode 100644 index 0000000..b3bd1c4 --- /dev/null +++ b/tests-perf/chan.perf.tcl @@ -0,0 +1,93 @@ +#!/usr/bin/tclsh + +# ------------------------------------------------------------------------ +# +# chan.perf.tcl -- +# +# This file provides performance tests for comparison of tcl-speed +# of channel subsystem. +# +# ------------------------------------------------------------------------ +# +# Copyright (c) 2024 Serg G. Brester (aka sebres) +# +# See the file "license.terms" for information on usage and redistribution +# of this file. +# + + +if {![namespace exists ::tclTestPerf]} { + source [file join [file dirname [info script]] test-performance.tcl] +} + + +namespace eval ::tclTestPerf-Chan { + +namespace path {::tclTestPerf} + +proc _get_test_chan {{bufSize 4096}} { + lassign [chan pipe] ch wch; + fconfigure $ch -translation binary -encoding utf-8 -buffersize $bufSize -buffering full + fconfigure $wch -translation binary -encoding utf-8 -buffersize $bufSize -buffering full + + exec [info nameofexecutable] -- $bufSize >@$wch << { + set bufSize [lindex $::argv end] + fconfigure stdout -translation binary -encoding utf-8 -buffersize $bufSize -buffering full + set buf [string repeat test 1000]; # 4K + # write ~ 10*1M + 10*2M + 10*10M + 1*20M: + set i 0; while {$i < int((10*1e6 + 10*2e6 + 10*10e6 + 1*20e6)/4e3)} { + #puts -nonewline stdout $i\t + puts stdout $buf + flush stdout + incr i + } + } & + close $wch + return $ch +} + +# regression tests for [bug-da16d15574] (fix for [db4f2843cd]): +proc test-read-regress {{reptime {50000 10}}} { + _test_run -no-result $reptime { + # with 4KB buffersize: + setup { set ch [::tclTestPerf-Chan::_get_test_chan 4096]; fconfigure $ch -buffersize } + # 10 * 1M: + {read $ch [expr {int(1e6)}]} + # 10 * 2M: + {read $ch [expr {int(2e6)}]} + # 10 * 10M: + {read $ch [expr {int(10e6)}]} + # 1 * 20M: + {read $ch; break} + cleanup { close $ch } + + # with 1MB buffersize: + setup { set ch [::tclTestPerf-Chan::_get_test_chan 1048576]; fconfigure $ch -buffersize } + # 10 * 1M: + {read $ch [expr {int(1e6)}]} + # 10 * 2M: + {read $ch [expr {int(2e6)}]} + # 10 * 10M: + {read $ch [expr {int(10e6)}]} + # 1 * 20M: + {read $ch; break} + cleanup { close $ch } + } +} + +proc test {{reptime 1000}} { + test-read-regress + + puts \n**OK** +} + +}; # end of ::tclTestPerf-Chan + +# ------------------------------------------------------------------------ + +# if calling direct: +if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} { + array set in {-time 500} + array set in $argv + ::tclTestPerf-Chan::test $in(-time) +} -- cgit v0.12 From a44233ae3e64c20186cbd154e1873bc7f8448497 Mon Sep 17 00:00:00 2001 From: sebres Date: Mon, 29 Jan 2024 11:06:36 +0000 Subject: don't flush to use full buffer (otherwise the chunks were 4K anyway) --- tests-perf/chan.perf.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests-perf/chan.perf.tcl b/tests-perf/chan.perf.tcl index b3bd1c4..2ef87cb 100644 --- a/tests-perf/chan.perf.tcl +++ b/tests-perf/chan.perf.tcl @@ -38,7 +38,7 @@ proc _get_test_chan {{bufSize 4096}} { set i 0; while {$i < int((10*1e6 + 10*2e6 + 10*10e6 + 1*20e6)/4e3)} { #puts -nonewline stdout $i\t puts stdout $buf - flush stdout + #flush stdout; # don't flush to use full buffer incr i } } & -- cgit v0.12 From 6f48d352c1bda25b47dd2f3583bfcc31a7287356 Mon Sep 17 00:00:00 2001 From: sebres Date: Mon, 29 Jan 2024 13:55:50 +0000 Subject: closes [db4f2843cd]: fixes SF by BO in ReadChars (and Tcl_ReadChars with append) caused by wrong buffer enlarge if objPtr shimmering to unicode for whatever reason, since Tcl_AppendToObj prefers unicode to bytes, whereas TclAppendUtfToUtf always extend bytes (that handled by ReadChars) --- generic/tclIO.c | 3 ++- generic/tclInt.h | 2 ++ generic/tclStringObj.c | 37 +++++++++++++++++++++++++++++++++++-- 3 files changed, 39 insertions(+), 3 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 0f79f1e..b8a79c2 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -6111,8 +6111,9 @@ ReadChars( int factor = *factorPtr; int dstLimit = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR; + if (dstLimit <= 0) dstLimit = INT_MAX; /* avoid overflow */ (void) TclGetStringFromObj(objPtr, &numBytes); - Tcl_AppendToObj(objPtr, NULL, dstLimit); + TclAppendUtfToUtf(objPtr, NULL, dstLimit); if (toRead == srcLen) { unsigned int size; diff --git a/generic/tclInt.h b/generic/tclInt.h index a09d6cb..68c07f2 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2861,6 +2861,8 @@ struct Tcl_LoadHandle_ { MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr, const unsigned char *bytes, int len); +MODULE_SCOPE void TclAppendUtfToUtf(Tcl_Obj *objPtr, + const char *bytes, int numBytes); MODULE_SCOPE void TclAdvanceContinuations(int *line, int **next, int loc); MODULE_SCOPE void TclAdvanceLines(int *line, const char *start, diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 975b991..7f9f874 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1671,7 +1671,7 @@ AppendUnicodeToUtfRep( * None. * * Side effects: - * objPtr's internal rep is reallocated. + * objPtr's internal rep is reallocated and string rep is cleaned. * *---------------------------------------------------------------------- */ @@ -1707,7 +1707,7 @@ AppendUtfToUnicodeRep( * None. * * Side effects: - * objPtr's internal rep is reallocated. + * objPtr's string rep is reallocated (by TCL STRING GROWTH ALGORITHM). * *---------------------------------------------------------------------- */ @@ -1787,6 +1787,39 @@ AppendUtfToUtfRep( /* *---------------------------------------------------------------------- * + * TclAppendUtfToUtf -- + * + * This function appends "numBytes" bytes of "bytes" to the UTF string + * rep of "objPtr" (objPtr's internal rep converted to string on demand). + * numBytes must be non-negative. + * + * Results: + * None. + * + * Side effects: + * objPtr's string rep is reallocated (by TCL STRING GROWTH ALGORITHM). + * + *---------------------------------------------------------------------- + */ + +void +TclAppendUtfToUtf( + Tcl_Obj *objPtr, /* Points to the object to append to. */ + const char *bytes, /* String to append (or NULL to enlarge buffer). */ + int numBytes) /* Number of bytes of "bytes" to append. */ +{ + if (Tcl_IsShared(objPtr)) { + Tcl_Panic("%s called with shared object", "TclAppendUtfToUtf"); + } + + SetStringFromAny(NULL, objPtr); + + AppendUtfToUtfRep(objPtr, bytes, numBytes); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_AppendStringsToObjVA -- * * This function appends one or more null-terminated strings to an -- cgit v0.12