From afb6b82ad412a7fb6f45ea72347804b401e5ddd4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 19 Mar 2024 08:09:13 +0000 Subject: (cherry-pick) docs - note that Tcl_AsyncMark() and Tcl_AsyncDelete() are actually void funcs --- doc/Async.3 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/doc/Async.3 b/doc/Async.3 index 347ba3d..a8896af 100644 --- a/doc/Async.3 +++ b/doc/Async.3 @@ -17,11 +17,13 @@ Tcl_AsyncCreate, Tcl_AsyncMark, Tcl_AsyncInvoke, Tcl_AsyncDelete, Tcl_AsyncReady Tcl_AsyncHandler \fBTcl_AsyncCreate\fR(\fIproc, clientData\fR) .sp +void \fBTcl_AsyncMark\fR(\fIasync\fR) .sp int \fBTcl_AsyncInvoke\fR(\fIinterp, code\fR) .sp +void \fBTcl_AsyncDelete\fR(\fIasync\fR) .sp int -- cgit v0.12 From 51726860a52a5b883da201bbe583ed41e4f01e52 Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 20 Mar 2024 16:37:22 +0000 Subject: added performance regression tests for list facilities (initially only few lsearch cases, illustrating [6811a0081940b76c]) --- tests-perf/list.perf.tcl | 100 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 100 insertions(+) create mode 100644 tests-perf/list.perf.tcl diff --git a/tests-perf/list.perf.tcl b/tests-perf/list.perf.tcl new file mode 100644 index 0000000..9c66259 --- /dev/null +++ b/tests-perf/list.perf.tcl @@ -0,0 +1,100 @@ +#!/usr/bin/tclsh + +# ------------------------------------------------------------------------ +# +# list.perf.tcl -- +# +# This file provides performance tests for comparison of tcl-speed +# of list facilities. +# +# ------------------------------------------------------------------------ +# +# 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-List { + +namespace path {::tclTestPerf} + +# regression tests for [bug-da16d15574] (fix for [db4f2843cd]): +proc test-lsearch-regress {{reptime 1000}} { + _test_run -no-result $reptime { + # list with 5000 strings with ca. 50 chars elements: + setup { set str [join [lrepeat 13 "XXX"] /]; set l [lrepeat 5000 $str]; llength $l } + # lsearch with no option, found immediatelly : + { lsearch $l $str } + # lsearch with -glob, found immediatelly : + { lsearch -glob $l $str } + # lsearch with -exact, found immediatelly : + { lsearch -exact $l $str } + # lsearch with -dictionary, found immediatelly : + { lsearch -dictionary $l $str } + + # lsearch with -nocase only, found immediatelly : + { lsearch -nocase $l $str } + # lsearch with -nocase -glob, found immediatelly : + { lsearch -nocase -glob $l $str } + # lsearch with -nocase -exact, found immediatelly : + { lsearch -nocase -exact $l $str } + # lsearch with -nocase -dictionary, found immediatelly : + { lsearch -nocase -dictionary $l $str } + } +} + +proc test-lsearch-nf-regress {{reptime 1000}} { + _test_run -no-result $reptime { + # list with 5000 strings with ca. 50 chars elements: + setup { set str [join [lrepeat 13 "XXX"] /]; set sNF $str/NF; set l [lrepeat 5000 $str]; llength $l } + # lsearch with no option, not found: + { lsearch $l $sNF } + # lsearch with -glob, not found: + { lsearch -glob $l $sNF } + # lsearch with -exact, not found: + { lsearch -exact $l $sNF } + # lsearch with -dictionary, not found: + { lsearch -dictionary $l $sNF } + } +} + +proc test-lsearch-nc-nf-regress {{reptime 1000}} { + _test_run -no-result $reptime { + # list with 5000 strings with ca. 50 chars elements: + setup { set str [join [lrepeat 13 "XXX"] /]; set sNF $str/NF; set l [lrepeat 5000 $str]; llength $l } + # lsearch with -nocase only, not found: + { lsearch -nocase $l $sNF } + # lsearch with -nocase -glob, not found: + { lsearch -nocase -glob $l $sNF } + # lsearch with -nocase -exact, not found: + { lsearch -nocase -exact $l $sNF } + # lsearch with -nocase -dictionary, not found: + { lsearch -nocase -dictionary $l $sNF } + } +} + +proc test {{reptime 1000}} { + test-lsearch-regress $reptime + test-lsearch-nf-regress $reptime + test-lsearch-nc-nf-regress $reptime + + puts \n**OK** +} + +}; # end of ::tclTestPerf-List + +# ------------------------------------------------------------------------ + +# 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-List::test $in(-time) +} -- cgit v0.12 From 4d5b75e119924242a8d98267802d7b57d396de43 Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 20 Mar 2024 16:39:12 +0000 Subject: small amend (incorrect copy&paste removed) --- tests-perf/list.perf.tcl | 1 - 1 file changed, 1 deletion(-) diff --git a/tests-perf/list.perf.tcl b/tests-perf/list.perf.tcl index 9c66259..9fde335 100644 --- a/tests-perf/list.perf.tcl +++ b/tests-perf/list.perf.tcl @@ -25,7 +25,6 @@ namespace eval ::tclTestPerf-List { namespace path {::tclTestPerf} -# regression tests for [bug-da16d15574] (fix for [db4f2843cd]): proc test-lsearch-regress {{reptime 1000}} { _test_run -no-result $reptime { # list with 5000 strings with ca. 50 chars elements: -- cgit v0.12 From 30f26cff8be85483cb7c90b15ce9acc2f4607583 Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 20 Mar 2024 17:56:25 +0000 Subject: optimize TclUtfToUCS4 for single code units (non high surrogates), especially for ascii; fixes performance regression [6811a0081940b76c] --- generic/tclInt.h | 8 +++++++- generic/tclUtf.c | 6 +++--- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index de92a7d..7efaf80 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3180,7 +3180,7 @@ MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes, MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes, const char *trim, int numTrim); MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); -MODULE_SCOPE int TclUtfToUCS4(const char *, int *); +MODULE_SCOPE int TclpUtfToUCS4(const char *, int *); MODULE_SCOPE int TclUCS4ToUtf(int, char *); MODULE_SCOPE int TclUCS4ToLower(int ch); #if TCL_UTF_MAX == 4 @@ -3995,6 +3995,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, * the result of Tcl_UtfToUniChar. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE int TclUtfToUniChar(const char *string, Tcl_UniChar *ch); + * MODULE_SCOPE int TclpUtfToUCS4(const char *src, int *ucs4Ptr); *---------------------------------------------------------------- */ @@ -4003,6 +4004,11 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, ((*(chPtr) = UCHAR(*(str))), 1) \ : Tcl_UtfToUniChar(str, chPtr)) +#define TclUtfToUCS4(src, ucs4Ptr) \ + (((UCHAR(*(src))) < 0x80) ? \ + ((*(ucs4Ptr) = UCHAR(*(src))), 1) \ + : TclpUtfToUCS4(src, ucs4Ptr)) + /* *---------------------------------------------------------------- * Macro counterpart of the Tcl_NumUtfChars() function. To be used in speed- diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 6fbeb36..04f7208 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -2462,18 +2462,18 @@ TclUniCharMatch( */ int -TclUtfToUCS4( +TclpUtfToUCS4( const char *src, /* The UTF-8 string. */ int *ucs4Ptr) /* Filled with the UCS4 codepoint represented * by the UTF-8 string. */ { Tcl_UniChar ch = 0; - int len = Tcl_UtfToUniChar(src, &ch); + int len = TclUtfToUniChar(src, &ch); #if TCL_UTF_MAX <= 4 if ((ch & ~0x3FF) == 0xD800) { Tcl_UniChar low = ch; - int len2 = Tcl_UtfToUniChar(src+len, &low); + int len2 = TclUtfToUniChar(src+len, &low); if ((low & ~0x3FF) == 0xDC00) { *ucs4Ptr = (((ch & 0x3FF) << 10) | (low & 0x3FF)) + 0x10000; return len + len2; -- cgit v0.12