sid/component/testsuite/lib/monkey.exp

   1 # -*- Tcl -*-
   2 # monkey.exp
   3 #
   4 # Copyright (C) 2000 Red Hat
   5 #
   6 # Procedures for a monkey testing library. These procs are used to
   7 # fire random input to a victim component. If sid does not close its
   8 # stdin (ie crash), then the test is considered to have passed.
   9 #
  10 # State save/restore functionality is sometimes tested also.  It confirms that
  11 # standard attributes recover their save-time values at any subsequent restore.
  12 # Dejagnu WARNINGs are emitted when something was overlooked.
  13 #
  14 # monkey_start and monkey_stop must be called at the start and end of
  15 # the test case. monkey_test can run a complete monkey test on a
  16 # component.
  17
  18
  19
  20 # Return a random number between 0 and n-1.
  21 proc random {n} {
  22     return [expr [expr int(16777216 * [expr rand()])] % int($n)]
  23 }
  24
  25
  26 # generate string with sequential chars between [low .. high]
  27 proc string_spectrum {low high} {
  28     set chars {}
  29     for {set i $low} {$i <= $high} {incr i} {
  30         lappend chars $i
  31     }
  32     return [binary format c* $chars]
  33 }
  34
  35
  36 set charsets(0) "0123456789"; set lenexps(0) 4
  37 set charsets(1) [string_spectrum 0 255] ; set lenexps(1) 12
  38 set charsets(2) "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_"; set lenexps(2) 8
  39 set charsets(3) "bx-0123456789abcdef"; set lenexps(3) 4
  40
  41 proc random_string {} {
  42     global charsets lenexps
  43     set class [random 4]
  44     set charset $charsets($class)
  45     set lenexp $lenexps($class)
  46
  47     set numchars [string length $charset]
  48     set len [random [expr pow(2,$lenexp)]]
  49     set garbage {}
  50     for {set i 0} {$i < $len} {incr i} {
  51         append garbage [string index $charset [random $numchars]]
  52     }
  53     return $garbage
  54 }
  55
  56
  57 # Override these procs in client .exp files to make monkey avoid accessing
  58 # specific pins/buses/attributes, based on respective names.
  59
  60 proc pin_safe_p {pin_name} { return 1 }
  61 proc bus_safe_p {bus_name} { return 1 }
  62 proc attr_safe_p {attr_name} { return 1 }
  63 proc state_safe_p {} { return 1 }
  64 proc state_saved_p {attr_name} { return 1 }
  65 # XXX: add more?
  66 # eg., add parameters for operation type, non-name arguments
  67
  68
  69
  70 # Run a monkey test for a component.
  71 # type -- the component type.
  72 # symbol -- the name of the component library header.
  73 # lib -- the library name (e.g. libtimers.la).
  74 # iterations -- the number of random events to generate for the test.
  75 #   (may be overridden by a SID_MONKEYS environment variable)
  76
  77 proc monkey_test {type sym lib {iterations 30s}} {
  78     global env
  79     global pins buses attributes
  80
  81
  82     if [info exist env(SID_MONKEYS)] {
  83         set iterations $env(SID_MONKEYS)
  84     }
  85
  86     global test
  87     set test "monkey test $type"
  88     if {[monkey_start $type $sym $lib] < 0} then { return }
  89
  90     # If $iterations ends in a recognised time specifier
  91     # (e.g. m => minutes), then run the tests for the specified
  92     # duration, rather than as a fixed number of iterations.
  93
  94     if {[regexp {[smhd]$} $iterations]} {
  95         regexp {([0-9]+)[smhd]$} $iterations ignore units
  96         set now [clock seconds]
  97         switch [string range $iterations end end] {
  98             s { set finishtime [expr $units + $now] }
  99             m { set finishtime [expr 60 * $units + $now] }
 100             h { set finishtime [expr 3600 * $units + $now] }
 101             d { set finishtime [expr 3600 * 24 * $units + $now] }
 102             default { error "unknown unit of time in $iterations" }
 103         }
 104         note "Testing $type until [clock format $finishtime]"
 105         while {[clock seconds] < $finishtime} {
 106             do_one_test
 107         }
 108     } else {
 109         for {set i 0} {$i < $iterations} {incr i} {
 110             do_one_test
 111         }
 112     }
 113     sid_stop
 114     pass "$test ($iterations iterations)"
 115
 116     catch {unset pins buses attributes}
 117
 118     # restore hooks for next monkey_test
 119     proc pin_safe_p {pin_name} { return 1 }
 120     proc bus_safe_p {bus_name} { return 1 }
 121     proc attr_safe_p {attr_name} { return 1 }
 122     proc state_safe_p {} { return 1 }
 123     proc state_saved_p {attr_name} { return 1 }
 124 }
 125
 126
 127 # Do one monkey testing round
 128 proc do_one_test {} {
 129     global num_state_snapshots
 130
 131     set value [random 100]
 132     # skew distribution toward effective tests
 133     if {$value < 30} then {
 134         monkey_test_pin
 135     } elseif {$value < 50} then {
 136         monkey_test_bus
 137     } elseif {$value < 96} then {
 138         monkey_test_attribute
 139     } elseif {$value < 98} then {
 140         monkey_test_state_save
 141     } else {
 142         monkey_test_state_restore
 143     }
 144 }
 145
 146
 147
 148 # Start the monkey test--only called by monkey_test.  Return <0 on failure.
 149 proc monkey_start {type sym lib} {
 150     global test victim
 151     global pins buses attributes
 152     global num_state_snapshots
 153     global state_snapshots
 154     global state_snapshot_attrs state_snapshot_bad_attrs
 155
 156     sid_config_component_test_with_tracing \
 157             "monkey.conf" "load [sid_find_file $lib] $sym" $type
 158
 159     sid_start "monkey.conf"
 160     if {$victim == ""} then { fail "$test - sid startup"; return -1 }
 161
 162     catch {unset pins buses attributes}
 163     set pins [sid_cmd [list sid::component::pin_names $victim]]
 164     set buses [sid_cmd [list sid::component::bus_names $victim]]
 165     set attributes [sid_cmd [list sid::component::attribute_names $victim]]
 166
 167     catch {unset num_state_snapshots state_snapshots state_snapshot_attrs state_snapshot_bad_attrs}
 168     set num_state_snapshots 0
 169     set state_snapshot_bad_attrs [list]
 170
 171     return 0
 172 }
 173
 174 # Monkey test a pin (decided at runtime).
 175 proc monkey_test_pin {} {
 176     global pins victim
 177
 178     # Pick a random pin.
 179     if {[llength $pins] == 0} then { return }
 180     set pin [lindex $pins [random [llength $pins]]]
 181     if {! [pin_safe_p $pin]} then { return }
 182
 183     set handle [sid_cmd [list sid::component::find_pin $victim $pin]]
 184     if {$handle == ""} then {
 185         # probably just output-only pin
 186         return
 187     }
 188
 189     # Value-carrying pin.
 190     set value [random [expr int(pow(2,16))]]
 191     sid_cmd [list sid::pin::driven_h4 $handle $value]
 192 }
 193
 194 # Monkey test a bus (transaction type and width decided at runtime).
 195 # The entire 2^32 address space is not tested, but the important
 196 # addresses lie in the 0 to 1K range.
 197
 198 proc monkey_test_bus {} {
 199     global buses victim
 200
 201     # Pick a random bus.
 202     if {[llength $buses] == 0} then { return }
 203     set bus [lindex $buses [random [llength $buses]]]
 204     if {! [bus_safe_p $bus]} then { return }
 205
 206     set handle [sid_cmd [list sid::component::find_bus $victim $bus]]
 207
 208     # Pick an endianness.
 209     if {[random 2] > 0} { set endian b } else { set endian l }
 210
 211     # Pick data width.
 212     switch [random 4] {
 213         0 { set width 1 }
 214         1 { set width 2 }
 215         2 { set width 4 }
 216         3 { set width 8 }
 217         default { warning "This should never happen!" }
 218     }
 219
 220     # Pick address.
 221     set addr [random [expr int(pow(2,30))]]
 222
 223     # Pick read or write operation.
 224     if {[random 2] > 0} { set op write } else { set op read }
 225
 226     # Do the operation.
 227     if {$op == "write"} {
 228         switch $width {
 229             1 { set data [random 256] }
 230             2 { set data [random 65536] }
 231             4 { set data [random [expr int(pow(2,30))]] }
 232             8 { set data [random [expr int(pow(2,30))]] }
 233         }
 234         sid_cmd [list sid::bus::write_h4_$endian$width $handle $addr $data]
 235     } else {
 236         sid_cmd [list sid::bus::read_h4_$endian$width $handle $addr]
 237     }
 238 }
 239
 240 # Monkey test an attribute (decided at runtime).
 241 # A random string of garbage, composed of a random number of
 242 # characters from $charset is used.
 243
 244 proc monkey_test_attribute {} {
 245     global charset numchars
 246     global attributes victim
 247
 248     # Pick a random attribute.
 249     if {[llength $attributes] == 0} then { return }
 250     set attr [lindex $attributes [random [llength $attributes]]]
 251     if {! [attr_safe_p $attr]} then { return }
 252
 253     set garbage [random_string]
 254     sid_cmd [list sid::component::set_attribute_value $victim $attr $garbage]
 255 }
 256
 257
 258 # Accumulate a state snapshot of the target component.
 259 # Collect both the "state-snapshot" attribute, and also pin/register/setting attributes.
 260 proc monkey_test_state_save {} {
 261     global num_state_snapshots
 262     global state_snapshots
 263     global state_snapshot_attrs
 264     global victim
 265
 266     # do no work if this is deemed unsafe
 267     if {! [state_safe_p]} then { return }
 268
 269     set state [sid_cmd [list sid::component::attribute_value $victim state-snapshot]]
 270     if {$state == ""} then {
 271         # state save/restore apparently not supported
 272         return
 273     }
 274
 275     incr num_state_snapshots
 276     set state_snapshots($num_state_snapshots) $state
 277
 278     # fetch all user-visible attribute names
 279     set attrnames [list]
 280     foreach category {pin setting register} {
 281         set attrlist [sid_cmd [list sid::component::attribute_names_in_category $victim $category]]
 282         foreach an $attrlist {
 283             lappend attrnames $an
 284         }
 285     }
 286     # collect their current values
 287     foreach attrname $attrnames {
 288         set attrvalue [sid_cmd [list sid::component::attribute_value $victim $attrname]]
 289         set state_snapshot_attrs($num_state_snapshots,$attrname) $attrvalue
 290     }
 291 }
 292
 293
 294 # Pick a random state snapshot accumulated from the target component and attempt to
 295 # restore it.  Confirm that user-visible attributes are back to their old values.
 296 proc monkey_test_state_restore {} {
 297     global num_state_snapshots
 298     global state_snapshots
 299     global state_snapshot_attrs state_snapshot_bad_attrs
 300     global victim
 301     global test
 302
 303     if {$num_state_snapshots == 0} then {
 304         return
 305     }
 306
 307     set pick [expr [random $num_state_snapshots] + 1]
 308
 309     set state $state_snapshots($pick)
 310     set result [sid_cmd [list sid::component::set_attribute_value $victim state-snapshot $state]]
 311     if {$result != "ok"} then {
 312         # don't warn over and over again - dummy attribute
 313         set attrname "state-snapshot"
 314         if {[lsearch -exact $state_snapshot_bad_attrs $attrname] == -1} then {
 315             warning "$test - state restore failed"
 316             lappend state_snapshot_bad_attrs $attrname
 317         }
 318     }
 319
 320     # fetch all user-visible attribute names
 321     set attrnames [list]
 322     foreach category {pin setting register} {
 323         set attrlist [sid_cmd [list sid::component::attribute_names_in_category $victim $category]]
 324         foreach an $attrlist {
 325             lappend attrnames $an
 326         }
 327     }
 328     # compare their current values
 329     foreach attrname $attrnames {
 330         set attrvalue1 [sid_cmd [list sid::component::attribute_value $victim $attrname]]
 331         set attrvalue2 $state_snapshot_attrs($pick,$attrname)
 332         if {$attrvalue1 != $attrvalue2} then {
 333             # quietly accept failure for known-unsaved attributes
 334             if {! [state_saved_p $attrname]} then {
 335                 lappend state_snapshot_bad_attrs $attrname
 336             }
 337             # don't warn over and over again
 338             if {[lsearch -exact $state_snapshot_bad_attrs $attrname] == -1} then {
 339                 warning "$test - state restore did not preserve $attrname"
 340                 lappend state_snapshot_bad_attrs $attrname
 341             }
 342         }
 343     }
 344 }