Tcl Source Code

Check-in [eaafb5917f]
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:merge 8.5
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-6-branch
Files: files | file ages | folders
SHA3-256:eaafb5917fa4a5afaa0716d884f19eb48f2bdbb00f6a2ab4a19797ae4a5605fd
User & Date: sebres 2019-04-17 20:00:37
Context
2019-04-23
06:43
timerate: code style, doc style check-in: 14a413ba72 user: dkf tags: core-8-6-branch
2019-04-17
20:00
merge 8.5 check-in: eaafb5917f user: sebres tags: core-8-6-branch
19:59
extend performance test-suite, allow several (repeatable) execution of _test_run (if encosed in _tes... check-in: 358ae35950 user: sebres tags: core-8-5-branch
14:34
Revise coroutines tests so they do not leave behind frame footprints that can interfere with other t... check-in: 30b5977b56 user: dgp tags: core-8-6-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to tests-perf/test-performance.tcl.

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
  puts $_(m)
  puts "Min:"
  puts [lindex $_(itm) $mini]
  puts "Max:"
  puts [lindex $_(itm) $maxi]
  puts [string repeat ** 40]
  puts ""




























}

proc _test_run {args} {
  upvar _ _
  # parse args:
  set _(out-result) 1
  if {[lindex $args 0] eq "-no-result"} {



    set _(out-result) 0
    set args [lrange $args 1 end]
  }

  if {[llength $args] < 2 || [llength $args] > 3} {
    return -code error "wrong # args: should be \"[lindex [info level [info level]] 0] ?-no-result? reptime lst ?outcmd?\""
  }
  set outcmd {puts $_(r)}
  set args [lassign $args reptime lst]
  if {[llength $args]} {
    set outcmd [lindex $args 0]
  }
  # avoid output if only once:
  if {[lindex $reptime 0] <= 1 || ([llength $reptime] > 1 && [lindex $reptime 1] == 1)} {
    set _(out-result) 0
  }

  array set _ [list itm {} reptime $reptime starttime [clock milliseconds]]




  # process measurement:
  foreach _(c) [_test_get_commands $lst] {
    puts "% [regsub -all {\n[ \t]*} $_(c) {; }]"
    if {[regexp {^\s*\#} $_(c)]} continue
    if {[regexp {^\s*(?:setup|cleanup)\s+} $_(c)]} {
      puts [if 1 [lindex $_(c) 1]]




      continue
    }




    # if output result (and not once):
    if {$_(out-result)} {
      set _(r) [if 1 $_(c)]
      if {$outcmd ne {}} $outcmd

      if {[llength $_(reptime)] > 1} { # decrement max-count
        lset _(reptime) 1 [expr {[lindex $_(reptime) 1] - 1}]
      }
    }
    puts [set _(m) [timerate $_(c) {*}$_(reptime)]]
    lappend _(itm) $_(m)
    puts ""

  }

  _test_out_total

}

}; # end of namespace ::tclTestPerf






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





|
|
>
>
>
|


>



|


|



|

>
|
>
>
>



|


|
>
>
>
>


>
>
>
>

|

<
>
|
|


|

<
>

>
|
>



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
  puts $_(m)
  puts "Min:"
  puts [lindex $_(itm) $mini]
  puts "Max:"
  puts [lindex $_(itm) $maxi]
  puts [string repeat ** 40]
  puts ""
  unset -nocomplain _(itm) _(starttime)
}

proc _test_start {reptime} {
  upvar _ _
  array set _ [list itm {} reptime $reptime starttime [clock milliseconds] -from-run 0]
}

proc _test_iter {args} {
  if {[llength $args] > 2} {
    return -code error "wrong # args: should be \"[lindex [info level [info level]] 0] ?level? measure-result\""
  }
  set lvl 1
  if {[llength $args] > 1} {
    set args [lassign $args lvl]
  }
  upvar $lvl _ _
  puts [set _(m) {*}$args]
  lappend _(itm) $_(m)
  puts ""
}

proc _adjust_maxcount {reptime maxcount} {
  if {[llength $reptime] > 1} {
    lreplace $reptime 1 1 [expr {min($maxcount,[lindex $reptime 1])}]
  } else {
    lappend reptime $maxcount
  }
}

proc _test_run {args} {
  upvar _ _
  # parse args:
  array set _ [set _opts {-no-result 0 -uplevel 0}]
  while {[llength $args] > 2} {
    if {[set o [lindex $args 0]] ni $_opts || $_($o)} {
      break
    }
    set _($o) 1
    set args [lrange $args 1 end]
  }
  unset -nocomplain _opts o
  if {[llength $args] < 2 || [llength $args] > 3} {
    return -code error "wrong # args: should be \"[lindex [info level [info level]] 0] ?-no-result? reptime lst ?outcmd?\""
  }
  set _(outcmd) {puts}
  set args [lassign $args reptime lst]
  if {[llength $args]} {
    set _(outcmd) [lindex $args 0]
  }
  # avoid output if only once:
  if {[lindex $reptime 0] <= 1 || ([llength $reptime] > 1 && [lindex $reptime 1] == 1)} {
    set _(-no-result) 1
  }
  if {![info exists _(itm)]} {
    array set _ [list itm {} reptime $reptime starttime [clock milliseconds] -from-run 1]
  } else {
    array set _ [list reptime $reptime]
  }

  # process measurement:
  foreach _(c) [_test_get_commands $lst] {
    {*}$_(outcmd) "% [regsub -all {\n[ \t]*} $_(c) {; }]"
    if {[regexp {^\s*\#} $_(c)]} continue
    if {[regexp {^\s*(?:setup|cleanup)\s+} $_(c)]} {
      set _(c) [lindex $_(c) 1]
      if {$_(-uplevel)} {
        set _(c) [list uplevel 1 $_(c)]
      }
      {*}$_(outcmd) [if 1 $_(c)]
      continue
    }
    if {$_(-uplevel)} {
      set _(c) [list uplevel 1 $_(c)]
    }
    set _(ittime) $_(reptime)
    # if output result (and not once):
    if {!$_(-no-result)} {
      set _(r) [if 1 $_(c)]

      if {$_(outcmd) ne {}} {{*}$_(outcmd) $_(r)}
      if {[llength $_(ittime)] > 1} { # decrement max-count
        lset _(ittime) 1 [expr {[lindex $_(ittime) 1] - 1}]
      }
    }
    {*}$_(outcmd) [set _(m) [timerate $_(c) {*}$_(ittime)]]
    lappend _(itm) $_(m)

    {*}$_(outcmd) ""
  }
  if {$_(-from-run)} {
    _test_out_total
  }
}

}; # end of namespace ::tclTestPerf