test/malloctraceviewer.tcl

   1
   2 package require sqlite3
   3 package require Tk
   4
   5 #############################################################################
   6 # Code to set up scrollbars for widgets. This is generic, boring stuff.
   7 #
   8 namespace eval autoscroll {
   9   proc scrollable {widget path args} {
  10     ::ttk::frame $path
  11     set w  [$widget ${path}.widget {*}$args]
  12     set vs [::ttk::scrollbar ${path}.vs]
  13     set hs [::ttk::scrollbar ${path}.hs -orient horizontal]
  14     grid $w  -row 0 -column 0 -sticky nsew
  15
  16     grid rowconfigure    $path 0 -weight 1
  17     grid columnconfigure $path 0 -weight 1
  18
  19     set grid [list grid $vs -row 0 -column 1 -sticky nsew]
  20     $w configure -yscrollcommand [list ::autoscroll::scrollcommand $grid $vs]
  21     $vs configure -command       [list $w yview]
  22     set grid [list grid $hs -row 1 -column 0 -sticky nsew]
  23     $w configure -xscrollcommand [list ::autoscroll::scrollcommand $grid $hs]
  24     $hs configure -command       [list $w xview]
  25
  26     return $w
  27   }
  28   proc scrollcommand {grid sb args} {
  29     $sb set {*}$args
  30     set isRequired [expr {[lindex $args 0] != 0.0 || [lindex $args 1] != 1.0}]
  31     if {$isRequired && ![winfo ismapped $sb]} {
  32       {*}$grid
  33     }
  34     if {!$isRequired && [winfo ismapped $sb]} {
  35       grid forget $sb
  36     }
  37   }
  38   namespace export scrollable
  39 }
  40 namespace import ::autoscroll::*
  41 #############################################################################
  42
  43 proc populate_text_widget {db} {
  44   $::O(text) configure -state normal
  45   set id [lindex [$::O(tree) selection] 0]
  46   set frame [lindex $id end]
  47
  48   set line [$db one {SELECT line FROM frame WHERE frame = $frame}]
  49   if {$line ne ""} {
  50     regexp {^([^:]*):([0-9]*)} $line -> file line
  51     set content [$db one "SELECT content FROM file WHERE name = '$file'"]
  52     $::O(text) delete 0.0 end
  53
  54     set iLine 1
  55     foreach L [split $content "\n"] {
  56       if {$iLine == $line} {
  57         $::O(text) insert end "$L\n" highlight
  58       } else {
  59         $::O(text) insert end "$L\n"
  60       }
  61       incr iLine
  62     }
  63     $::O(text) yview -pickplace ${line}.0
  64   }
  65   $::O(text) configure -state disabled
  66 }
  67
  68 proc populate_index {db} {
  69   $::O(text) configure -state normal
  70
  71   $::O(text) delete 0.0 end
  72   $::O(text) insert end "\n\n"
  73
  74   set L [format "    % -40s%12s%12s\n" "Test Case" "Allocations" "Bytes"]
  75   $::O(text) insert end $L
  76   $::O(text) insert end "    [string repeat - 64]\n"
  77
  78   $db eval {
  79     SELECT 'TOTAL' AS ztest, sum(ncall) AS calls, sum(nbyte) AS bytes
  80     FROM malloc
  81       UNION ALL
  82     SELECT ztest AS ztest, sum(ncall) AS calls, sum(nbyte) AS bytes
  83     FROM malloc
  84     GROUP BY ztest
  85
  86     ORDER BY 3 DESC
  87   } {
  88     set tags [list $ztest]
  89     if {$ztest eq $::O(current)} {
  90       lappend tags highlight
  91     }
  92     set L [format "    % -40s%12s%12s\n" $ztest $calls $bytes]
  93     $::O(text) insert end $L $tags
  94
  95     $::O(text) tag bind $ztest <1> [list populate_tree_widget $db $ztest]
  96     $::O(text) tag bind $ztest <Enter> [list $::O(text) configure -cursor hand2]
  97     $::O(text) tag bind $ztest <Leave> [list $::O(text) configure -cursor ""]
  98   }
  99
 100   $::O(text) configure -state disabled
 101 }
 102
 103 proc sort_tree_compare {iLeft iRight} {
 104   global O
 105   switch -- [expr (int($O(tree_sort)/2))] {
 106     0 {
 107       set left  [$O(tree) item $iLeft -text]
 108       set right [$O(tree) item $iRight -text]
 109       set res [string compare $left $right]
 110     }
 111     1 {
 112       set left  [lindex [$O(tree) item $iLeft -values] 0]
 113       set right [lindex [$O(tree) item $iRight -values] 0]
 114       set res [expr $left - $right]
 115     }
 116     2 {
 117       set left  [lindex [$O(tree) item $iLeft -values] 1]
 118       set right [lindex [$O(tree) item $iRight -values] 1]
 119       set res [expr $left - $right]
 120     }
 121   }
 122   if {$O(tree_sort)&0x01} {
 123     set res [expr -1 * $res]
 124   }
 125   return $res
 126 }
 127
 128 proc sort_tree {iMode} {
 129   global O
 130   if {$O(tree_sort) == $iMode} {
 131     incr O(tree_sort)
 132   } else {
 133     set O(tree_sort) $iMode
 134   }
 135   set T $O(tree)
 136   set items [$T children {}]
 137   set items [lsort -command sort_tree_compare $items]
 138   for {set ii 0} {$ii < [llength $items]} {incr ii} {
 139     $T move [lindex $items $ii] {} $ii
 140   }
 141 }
 142
 143 proc trim_frames {stack} {
 144   while {[info exists ::O(ignore.[lindex $stack 0])]} {
 145     set stack [lrange $stack 1 end]
 146   }
 147   return $stack
 148 }
 149
 150 proc populate_tree_widget {db zTest} {
 151   $::O(tree) delete [$::O(tree) children {}]
 152
 153   for {set ii 0} {$ii < 15} {incr ii} {
 154     $db eval {
 155       SELECT
 156         sum(ncall) AS calls,
 157         sum(nbyte) AS bytes,
 158         trim_frames(lrange(lstack, 0, $ii)) AS stack
 159       FROM malloc
 160       WHERE (zTest = $zTest OR $zTest = 'TOTAL') AND llength(lstack)>$ii
 161       GROUP BY stack
 162       HAVING stack != ''
 163     } {
 164       set parent_id [lrange $stack 0 end-1]
 165       set frame [lindex $stack end]
 166       set line [$db one {SELECT line FROM frame WHERE frame = $frame}]
 167       set line [lindex [split $line /] end]
 168       set v [list $calls $bytes]
 169
 170       catch {
 171         $::O(tree) insert $parent_id end -id $stack -text $line -values $v
 172       }
 173     }
 174   }
 175
 176   set ::O(current) $zTest
 177   populate_index $db
 178 }
 179
 180
 181
 182 set O(tree_sort) 0
 183
 184 ::ttk::panedwindow .pan -orient horizontal
 185 set O(tree) [scrollable ::ttk::treeview .pan.tree]
 186
 187 frame .pan.right
 188 set O(text) [scrollable text .pan.right.text]
 189 button .pan.right.index -command {populate_index mddb} -text "Show Index"
 190 pack .pan.right.index -side top -fill x
 191 pack .pan.right.text -fill both -expand true
 192
 193 $O(text) tag configure highlight -background wheat
 194 $O(text) configure -wrap none -height 35
 195
 196 .pan add .pan.tree
 197 .pan add .pan.right
 198
 199 $O(tree) configure     -columns {calls bytes}
 200 $O(tree) heading #0    -text Line  -anchor w -command {sort_tree 0}
 201 $O(tree) heading calls -text Calls -anchor w -command {sort_tree 2}
 202 $O(tree) heading bytes -text Bytes -anchor w -command {sort_tree 4}
 203 $O(tree) column #0    -width 150
 204 $O(tree) column calls -width 100
 205 $O(tree) column bytes -width 100
 206
 207 pack .pan -fill both -expand 1
 208
 209 #--------------------------------------------------------------------
 210 # Open the database containing the malloc data. The user specifies the
 211 # database to use by passing the file-name on the command line.
 212 #
 213 proc open_database {} {
 214   if {[info exists ::BUILTIN]} {
 215     sqlite3 mddb :memory:
 216     mddb eval $::BUILTIN
 217     wm title . $::argv0
 218   } else {
 219     set zFilename [lindex $::argv 0]
 220     if {$zFilename eq ""} {
 221       set zFilename mallocs.sql
 222     }
 223     set fd [open $zFilename]
 224     set zHdr [read $fd 15]
 225     if {$zHdr eq "SQLite format 3"} {
 226       close $fd
 227       sqlite3 mddb $zFilename
 228     } else {
 229       seek $fd 0
 230       sqlite3 mddb :memory:
 231       mddb eval [read $fd]
 232       close $fd
 233     }
 234     wm title . $zFilename
 235   }
 236
 237   mddb function lrange -argcount 3 lrange
 238   mddb function llength -argcount 1 llength
 239   mddb function trim_frames -argcount 1 trim_frames
 240
 241   mddb eval {
 242     SELECT frame FROM frame
 243     WHERE line LIKE '%malloc.c:%' OR line LIKE '%mem2.c:%'
 244   } {
 245     set ::O(ignore.$frame) 1
 246   }
 247 }
 248
 249 open_database
 250 bind $O(tree) <<TreeviewSelect>> [list populate_text_widget mddb]
 251
 252 populate_tree_widget mddb [mddb one {SELECT zTest FROM malloc LIMIT 1}]
 253