Itcl - the [incr Tcl] extension

Check-in [b8ab55a29e]
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:add performance test-suite
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | sebres-on-dmnd-resolver-perf-branch
Files: files | file ages | folders
SHA3-256: b8ab55a29e2e939ef961ba9ff0988012b701fe024a5d4acd2fba6d7787164f1c
User & Date: sebres 2019-04-17 20:46:17
Context
2019-04-17
20:46
stop call of var-resolver twice (add TCL_GLOBAL_ONLY - trick to avoid call resolver for namespace of current frame, all vars are fully-qualified). check-in: c98c2c9ea2 user: sebres tags: sebres-on-dmnd-resolver-perf-branch
20:46
add performance test-suite check-in: b8ab55a29e user: sebres tags: sebres-on-dmnd-resolver-perf-branch
20:45
move bypass-logic of internal dicts into and simplify Itcl_ParseVarResolver check-in: d46639da5b user: sebres tags: sebres-on-dmnd-resolver-perf-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Added tests-perf/itcl-basic.perf.tcl.


















































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
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
#!/usr/bin/tclsh

# ------------------------------------------------------------------------
#
# itcl-basic.perf.tcl --
# 
#  This file provides performance tests for comparison of basic itcl-speed.
#
# ------------------------------------------------------------------------
# 
# Copyright (c) 2019 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 library]] tests-perf test-performance.tcl]
}

namespace eval ::itclTestPerf-Basic {

namespace path {::tclTestPerf}


## test cases covering run-time dependency to variable count of class with nested
## namespaces and class inheritances...
## original itcl-resolver (due to completely rebuild) has the complexity ca. O(nn**2,2**vn) here,
## so the deeper a class/inheritance and expecially the more variables it has,
## the worse the performance of class creation or modification.

proc test-create {{reptime {3000 10000}}} {
  upvar maxv maxv
  foreach ns {{} ::test-itcl-ns1 ::test-itcl-ns1::test-itcl-ns2} {
    incr n
    if {$ns ne {}} { namespace eval $ns {} }
    _test_start $reptime
    foreach clsi {0 1 2} {
      if {$clsi} {
        set inh ${ns}::timeClass[expr {$clsi-1}]
      } else {
        set inh {}
      }
      set cls ${ns}::timeClass$clsi
      puts "== ${n}.$clsi) class : $cls == [expr {$inh ne "" ? "inherite $inh" : ""}]"
      if {[info command $cls] ne ""} {
        itcl::delete class $cls
      }
      itcl::class $cls [string map [list \$reptime [list $reptime] \$in_inh [list $inh] \$clsi $clsi] {
        set j 0
        set inh $in_inh
        if {$inh ne ""} {
          puts "% inherit $inh"
          ::tclTestPerf::_test_iter 2 [timerate { 
            inherit $inh
          } 1 1]
        }
        puts "% declare vars ..."
        ::tclTestPerf::_test_iter 2 [timerate {
          public variable pub[incr j] 0
          protected variable pro$j 1
          private variable pri$j 2
          # 10K commons is too slow in Itcl original edition (time grows on each iter), so 1K enough:
          if {$j <= 1000} {
            public common com$j ""
          }
        } {*}$reptime]
        public method getv {vn} {set $vn}
        public method getpub1 {} {set pro1}
        public method getpro1 {} {set pro1}
        public method getpri1 {} {set pri1}
        public method getunknown {} {catch {set novarinthisclass}}
        # Itcl original edition may be too slow (time grows on each inheritance), so save real max-iters (<= 10K):
        uplevel [list set j $j]
      }]
      set maxv($clsi,$ns) $j
    }
  }
  _test_out_total
}

# access variable:
proc test-access {{reptime 1000}} {
  upvar maxv maxv
  _test_start $reptime
  foreach ns {{} ::test-itcl-ns1 ::test-itcl-ns1::test-itcl-ns2} {
    set reptm [_adjust_maxcount $reptime $maxv(0,$ns)]
    incr n
    set cls ${ns}::timeClass0
    puts "== ${n}) class : $cls =="
    set mp [list \
      \$cls $cls \$n $n \
      \$maxc0 [expr {min(1000,$maxv(0,$ns))}]
    ]
    _test_run $reptm [string map $mp {
      # $n) obj-var resolve/get
      setup {$cls o; set j 0}
      {o getv pub[incr j]}
      # $n) obj-var get (resolved)
      setup {set j 0}
      {o getv pub[incr j]}
      # $n) obj-var resolved
      setup {set j 0}
      {o getv pub1}
      # $n) obj-var in method compiled (public)
      {o getpub1}
      # $n) obj-var in method compiled (protected)
      {o getpro1}
      # $n) obj-var in method compiled (private)
      {o getpri1}
      # $n) obj-var in method unknown
      {o getunknown}
      cleanup {itcl::delete object o}

      # $n) obj-var resolve/cget
      setup {$cls o; set j 0}
      {o cget -pub[incr j]}
      # $n) obj-var cget (resolved):
      setup {set j 0}
      {o cget -pub[incr j]}

      # $n) obj-var cfg/cget
      {o configure -pub1} 
      {o cget -pub1}

      # $n) cls-com resolve
      setup {set j 0}
      {o getv com[incr j]; if {$j >= $maxc0} {set j 0}}

      # $n) cls-com resolved
      {o getv com1}
      cleanup {itcl::delete object o}
    }]
  }
  _test_out_total
}

# ------------------------------------------------------------------------

# create/delete object:
proc test-obj-instance {{reptime 1000}} {
  _test_start $reptime
  set n 0
  foreach ns {{} ::test-itcl-ns1 ::test-itcl-ns1::test-itcl-ns2} {
    incr n
    set cls ${ns}::timeClass0
    puts "== ${n}) class : $cls =="
    _test_run $reptime [string map [list \$cls $cls \$n $n] {
      setup {set i 0}
      # $n) create :
      {$cls o[incr i]}
      # $n) delete:
      {itcl::delete object o$i; if {[incr i -1] <= 0} break}
      cleanup {while {$i > 0} {itcl::delete object o$i; incr i -1}}
      # $n) create + delete:
      {$cls o; itcl::delete object o}
    }]
  }
  _test_out_total
}

# ------------------------------------------------------------------------

proc test {{reptime 1000}} {
  set reptm $reptime
  lset reptm 0 [expr {min(3000,[lindex $reptm 0] * 3)}]
  if {[llength $reptm] == 1} {
    lappend reptm 10000
  }
  puts "==== class creation ====\n"
  test-create $reptm
  puts "==== var access ====\n"
  test-access $reptime
  puts "==== object instance ====\n"
  test-obj-instance $reptime

  puts \n**OK**
}

}; # end of ::tclTestPerf-Timer-Event

# ------------------------------------------------------------------------

# if calling direct:
if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} {
  array set in {-time 500 -lib {} -load {}}
  array set in $argv
  if {$in(-load) eq ""} {
    eval $in(-load)
  }
  if {![namespace exists ::itcl]} {
    if {$in(-lib) eq ""} {
      set in(-lib) "itcl412"
    }
    puts "testing with $in(-lib)"
    load $in(-lib) itcl
  }

  ::itclTestPerf-Basic::test $in(-time)
}