contrib/visualize-alignment/tracetops.ml

   1 #!/usr/bin/ocamlrun /usr/bin/ocaml
   2
   3 (* Convert *.qtr (qemu block device trace) to Postscript.
   4  * Copyright (C) 2009-2010 Red Hat Inc.
   5  * By Richard W.M. Jones <rjones@redhat.com>.
   6  *
   7  * This program is free software; you can redistribute it and/or modify
   8  * it under the terms of the GNU General Public License as published by
   9  * the Free Software Foundation; either version 2 of the License, or
  10  * (at your option) any later version.
  11  *
  12  * This program is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with this program; if not, write to the Free Software
  19  * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20  *)
  21
  22 (* Note that we use ordinary OCaml ints, which means this program is
  23  * limited to: ~1TB disks for 32 bit machines, or effectively unlimited
  24  * for 64 bit machines.  Also we make several 512 byte sector
  25  * assumptions.
  26  *)
  27
  28 #use "topfind";;
  29 #require "extlib";;
  30
  31 open ExtList
  32 open Scanf
  33 open Printf
  34
  35 type op = Read | Write
  36
  37 (* If 'true' then print debug messages. *)
  38 let debug = true
  39
  40 (* Width of each row (in sectors) in the output. *)
  41 let row_size = 64
  42
  43 (* Desirable alignment (sectors). *)
  44 let alignment = 8
  45
  46 (* Height (in 1/72 inch) of the final image. *)
  47 let height = 6.*.72.
  48
  49 (* Width (in 1/72 inch) of the final image. *)
  50 let width = 6.*.72.
  51
  52 (* Reserve at left for the sector number (comes out of width). *)
  53 let sn_width = 36.
  54
  55 let input =
  56   if Array.length Sys.argv = 2 then
  57     Sys.argv.(1)
  58   else
  59     failwith "usage: tracetops filename.qtr"
  60
  61 (* Read the input file. *)
  62 let nb_sectors, accesses =
  63   let chan = open_in input in
  64   let nb_sectors =
  65     let summary = input_line chan in
  66     if String.length summary < 1 || summary.[0] <> 'S' then
  67       failwith (sprintf "%s: input is not a qemu block device trace file"
  68                   input);
  69     sscanf summary "S %d" (fun x -> x) in
  70
  71   if nb_sectors mod row_size <> 0 then
  72     failwith (sprintf "input nb_sectors (%d) not divisible by row size (%d)"
  73                 nb_sectors row_size);
  74
  75   (* Read the reads and writes from the remainder of the file. *)
  76   let accesses = ref [] in
  77   let rec loop () =
  78     let line = input_line chan in
  79     let rw, s, n = sscanf line "%c %d %d" (fun rw s n -> (rw, s, n)) in
  80     let rw =
  81       match rw with
  82       | 'R' -> Read | 'W' -> Write
  83       | c -> failwith
  84           (sprintf "%s: error reading input: got '%c', expecting 'R' or 'W'"
  85              input c) in
  86     if n < 0 || s < 0 || s+n > nb_sectors then
  87       failwith (sprintf "%s: s (%d), n (%d) out of range" input s n);
  88     let aligned = s mod alignment = 0 && n mod alignment = 0 in
  89     accesses := (rw, aligned, s, n) :: !accesses;
  90     loop ()
  91   in
  92   (try loop () with
  93    | End_of_file -> ()
  94    | Scan_failure msg ->
  95        failwith (sprintf "%s: error reading input: %s" input msg)
  96   );
  97   close_in chan;
  98
  99   let accesses = List.rev !accesses in
 100
 101   if debug then (
 102     eprintf "%s: nb_sectors = %d, accesses = %d\n"
 103       input nb_sectors (List.length accesses)
 104   );
 105
 106   nb_sectors, accesses
 107
 108 (* If the accesses list contains any qtrace on/off patterns (in
 109  * guestfish: debug "qtrace /dev/vda (on|off)") then filter out the
 110  * things we want to display.  Otherwise leave the whole trace.
 111  *)
 112 let accesses =
 113   let contains_qtrace_patterns =
 114     let rec loop = function
 115       | [] -> false
 116       | (Read, _, 2, 1) :: (Read, _, 21, 1) :: (Read, _, 15, 1) ::
 117           (Read, _, 2, 1) :: _ -> true
 118       | (Read, _, 2, 1) :: (Read, _, 15, 1) :: (Read, _, 21, 1) ::
 119           (Read, _, 2, 1) :: _ -> true
 120       | _ :: rest -> loop rest
 121     in
 122     loop accesses in
 123
 124   if contains_qtrace_patterns then (
 125     if debug then eprintf "%s: contains qtrace on/off patterns\n%!" input;
 126
 127     let rec find_qtrace_on = function
 128       | [] -> []
 129       | (Read, _, 2, 1) :: (Read, _, 21, 1) :: (Read, _, 15, 1) ::
 130           (Read, _, 2, 1) :: rest -> rest
 131       | (Read, _, 2, 1) :: (Read, _, 15, 1) :: (Read, _, 21, 1) ::
 132           (Read, _, 2, 1) :: rest ->
 133           eprintf "ignored 'qtrace off' pattern when expecting 'qtrace on'\n";
 134           find_qtrace_on rest
 135       | _ :: rest -> find_qtrace_on rest
 136     and split_until_qtrace_off = function
 137       | [] -> [], []
 138       | (Read, _, 2, 1) :: (Read, _, 15, 1) :: (Read, _, 21, 1) ::
 139           (Read, _, 2, 1) :: rest -> [], rest
 140       | (Read, _, 2, 1) :: (Read, _, 21, 1) :: (Read, _, 15, 1) ::
 141           (Read, _, 2, 1) :: rest ->
 142           eprintf "found 'qtrace on' pattern when expecting 'qtrace off'\n";
 143           split_until_qtrace_off rest
 144       | x :: ys ->
 145           let xs, ys = split_until_qtrace_off ys in
 146           x :: xs, ys
 147     and filter_accesses xs =
 148       let xs = find_qtrace_on xs in
 149       if xs <> [] then (
 150         let xs, ys = split_until_qtrace_off xs in
 151         let ys = filter_accesses ys in
 152         xs @ ys
 153       ) else
 154         []
 155     in
 156     filter_accesses accesses
 157   ) else
 158     accesses
 159
 160 let ranges =
 161   (* Given the number of sectors, make the row array. *)
 162   let nr_rows = nb_sectors / row_size in
 163   let rows = Array.make nr_rows false in
 164
 165   List.iter (
 166     fun (_, _, s, n) ->
 167       let i0 = s / row_size in
 168       let i1 = (s+n-1) / row_size in
 169       for i = i0 to i1 do rows.(i) <- true done;
 170   ) accesses;
 171
 172   (* Coalesce rows into a list of ranges of rows we will draw. *)
 173   let rows = Array.to_list rows in
 174   let rows = List.mapi (fun i v -> (v, i)) rows in
 175   let ranges =
 176     (* When called, we are in the middle of a range which started at i0. *)
 177     let rec loop i0 = function
 178       | (false, _) :: (false, _) :: (true, i1) :: []
 179       | _ :: (_, i1) :: []
 180       | (_, i1) :: [] ->
 181           [i0, i1]
 182       | (false, _) :: (false, _) :: (true, _) :: rest
 183       | (false, _) :: (true, _) :: rest
 184       | (true, _) :: rest ->
 185           loop i0 rest
 186       | (false, i1) :: rest ->
 187           let i1 = i1 - 1 in
 188           let rest = List.dropwhile (function (v, _) -> not v) rest in
 189           (match rest with
 190            | [] -> [i0, i1]
 191            | (_, i2) :: rest -> (i0, i1) :: loop i2 rest)
 192       | [] -> assert false
 193     in
 194     loop 0 (List.tl rows) in
 195
 196   if debug then (
 197     eprintf "%s: rows = %d (ranges = %d)\n" input nr_rows (List.length ranges);
 198     List.iter (
 199       fun (i0, i1) ->
 200         eprintf "  %d - %d (rows %d - %d)\n"
 201           (i0 * row_size) ((i1 + 1) * row_size - 1) i0 i1
 202     ) ranges
 203   );
 204
 205   ranges
 206
 207 (* Locate where we will draw the rows and cells in the final image. *)
 208 let iter_rows, mapxy, row_height, cell_width =
 209   let nr_ranges = List.length ranges in
 210   let nr_breaks = nr_ranges - 1 in
 211   let nr_rows =
 212     List.fold_left (+) 0 (List.map (fun (i0,i1) -> i1-i0+1) ranges) in
 213   let nr_rnb = nr_rows + nr_breaks in
 214   let row_height = height /. float nr_rnb in
 215   let cell_width = (width -. sn_width) /. float row_size in
 216
 217   if debug then (
 218     eprintf "number of rows and breaks = %d\n" nr_rnb;
 219     eprintf "row_height x cell_width = %g x %g\n" row_height cell_width
 220   );
 221
 222   (* Create a higher-order function to iterate over the rows. *)
 223   let rec iter_rows f =
 224     let rec loop row = function
 225       | [] -> ()
 226       | (i0,i1) :: rows ->
 227           for i = i0 to i1 do
 228             let y = float (row+i-i0) *. row_height in
 229             f y (Some i)
 230           done;
 231           (* Call an extra time for the break. *)
 232           let y = float (row+i1-i0+1) *. row_height in
 233           if rows <> [] then f y None;
 234           (* extra +1 here is to skip the break *)
 235           loop (row+i1-i0+1+1) rows
 236     in
 237     loop 0 ranges
 238   in
 239
 240   (* Create a hash which maps from the row number to the position
 241    * where we draw the row.  If the row is not drawn, the hash value
 242    * is missing.
 243    *)
 244   let row_y = Hashtbl.create nr_rows in
 245   iter_rows (
 246     fun y ->
 247       function
 248       | Some i -> Hashtbl.replace row_y i y
 249       | None -> ()
 250   );
 251
 252   (* Create a function which maps from the sector number to the final
 253    * position that we will draw it.
 254    *)
 255   let mapxy s =
 256     let r = s / row_size in
 257     let y = try Hashtbl.find row_y r with Not_found -> assert false in
 258     let x = sn_width +. cell_width *. float (s mod row_size) in
 259     x, y
 260   in
 261
 262   iter_rows, mapxy, row_height, cell_width
 263
 264 (* Start the PostScript file. *)
 265 let () =
 266   printf "%%!PS-Adobe-3.0 EPSF-3.0\n";
 267   printf "%%%%BoundingBox: -10 -10 %g %g\n"
 268     (width +. 10.) (height +. row_height +. 20.);
 269   printf "%%%%Creator: tracetops.ml (part of libguestfs)\n";
 270   printf "%%%%Title: %s\n" input;
 271   printf "%%%%LanguageLevel: 2\n";
 272   printf "%%%%Pages: 1\n";
 273   printf "%%%%Page: 1 1\n";
 274   printf "\n";
 275
 276   printf "/min { 2 copy gt { exch } if pop } def\n";
 277   printf "/max { 2 copy lt { exch } if pop } def\n";
 278
 279   (* Function for drawing cells. *)
 280   printf "/cell {\n";
 281   printf "  newpath\n";
 282   printf "    moveto\n";
 283   printf "    %g 0 rlineto\n" cell_width;
 284   printf "    0 %g rlineto\n" row_height;
 285   printf "    -%g 0 rlineto\n" cell_width;
 286   printf "  closepath\n";
 287   printf "  gsave fill grestore 0.75 setgray stroke\n";
 288   printf "} def\n";
 289
 290   (* Define colours for different cell types. *)
 291   printf "/unalignedread  { 0.95 0.95 0 setrgbcolor } def\n";
 292   printf "/unalignedwrite { 0.95 0 0    setrgbcolor } def\n";
 293   printf "/alignedread    { 0 0.95 0    setrgbcolor } def\n";
 294   printf "/alignedwrite   { 0 0 0.95    setrgbcolor } def\n";
 295
 296   (* Get width of text. *)
 297   printf "/textwidth { stringwidth pop } def\n";
 298
 299   (* Draw the outline. *)
 300   printf "/outline {\n";
 301   printf "  newpath\n";
 302   printf "    %g 0 moveto\n" sn_width;
 303   printf "    %g 0 lineto\n" width;
 304   printf "    %g %g lineto\n" width height;
 305   printf "    %g %g lineto\n" sn_width height;
 306   printf "  closepath\n";
 307   printf "  0.5 setlinewidth 0.3 setgray stroke\n";
 308   printf "} def\n";
 309
 310   (* Draw the outline breaks. *)
 311   printf "/breaks {\n";
 312   iter_rows (
 313     fun y ->
 314       function
 315       | Some _ -> ()
 316       | None ->
 317           let f xmin xmax =
 318             let yll = y +. row_height /. 3. -. 2. in
 319             let ylr = y +. row_height /. 2. -. 2. in
 320             let yur = y +. 2. *. row_height /. 3. in
 321             let yul = y +. row_height /. 2. in
 322             printf "  newpath\n";
 323             printf "    %g %g moveto\n" xmin yll;
 324             printf "    %g %g lineto\n" xmax ylr;
 325             printf "    %g %g lineto\n" xmax yur;
 326             printf "    %g %g lineto\n" xmin yul;
 327             printf "  closepath\n";
 328             printf "  1 setgray fill\n";
 329             printf "  newpath\n";
 330             printf "    %g %g moveto\n" xmin yll;
 331             printf "    %g %g lineto\n" xmax ylr;
 332             printf "    %g %g moveto\n" xmax yur;
 333             printf "    %g %g lineto\n" xmin yul;
 334             printf "  closepath\n";
 335             printf "  0.5 setlinewidth 0.3 setgray stroke\n"
 336           in
 337           f (sn_width -. 6.) (sn_width +. 6.);
 338           f (width -. 6.) (width +. 6.)
 339   );
 340   printf "} def\n";
 341
 342   (* Draw the labels. *)
 343   printf "/labels {\n";
 344   printf "  /Courier findfont\n";
 345   printf "  0.75 %g mul 10 min scalefont\n" row_height;
 346   printf "  setfont\n";
 347   iter_rows (
 348     fun y ->
 349       function
 350       | Some i ->
 351           let sector = i * row_size in
 352           printf "  newpath\n";
 353           printf "    /s { (%d) } def\n" sector;
 354           printf "    %g s textwidth sub 4 sub %g moveto\n" sn_width (y +. 2.);
 355           printf "  s show\n"
 356       | None -> ()
 357   );
 358   printf "} def\n";
 359
 360   (* Print the key. *)
 361   printf "/key {\n";
 362   printf "  /Times-Roman findfont\n";
 363   printf "  10. scalefont\n";
 364   printf "  setfont\n";
 365   let x = sn_width and y = height +. 10. in
 366   printf "  unalignedwrite %g %g cell\n" x y;
 367   let x = x +. cell_width +. 4. in
 368   printf "  newpath %g %g moveto (unaligned write) 0.3 setgray show\n" x y;
 369   let x = x +. 72. in
 370   printf "  unalignedread %g %g cell\n" x y;
 371   let x = x +. cell_width +. 4. in
 372   printf "  newpath %g %g moveto (unaligned read) 0.3 setgray show\n" x y;
 373   let x = x +. 72. in
 374   printf "  alignedwrite %g %g cell\n" x y;
 375   let x = x +. cell_width +. 4. in
 376   printf "  newpath %g %g moveto (aligned write) 0.3 setgray show\n" x y;
 377   let x = x +. 72. in
 378   printf "  alignedread %g %g cell\n" x y;
 379   let x = x +. cell_width +. 4. in
 380   printf "  newpath %g %g moveto (aligned read) 0.3 setgray show\n" x y;
 381   printf "} def\n";
 382
 383   printf "\n"
 384
 385 (* Draw the accesses. *)
 386 let () =
 387   (* Sort the accesses so unaligned ones are displayed at the end (on
 388    * top of aligned ones) and writes on top of reads.  This isn't
 389    * really perfect, but it'll do.
 390    *)
 391   let cmp (rw, aligned, s, n) (rw', aligned', s', n') =
 392     let r = compare rw rw' (* Write later *) in
 393     if r <> 0 then r else (
 394       let r = compare aligned' aligned (* unaligned later *) in
 395       if r <> 0 then r else
 396         compare (n, s) (n', s')
 397     )
 398   in
 399   let accesses = List.sort ~cmp accesses in
 400
 401   List.iter (
 402     fun op ->
 403       let col, s, n =
 404         match op with
 405         | Read, false, s, n ->
 406             "unalignedread", s, n
 407         | Write, false, s, n ->
 408             "unalignedwrite", s, n
 409         | Read, true, s, n ->
 410             "alignedread", s, n
 411         | Write, true, s, n ->
 412             "alignedwrite", s, n in
 413       for i = s to s+n-1 do
 414         let x, y = mapxy i in
 415         printf "%s %g %g cell\n" col x y
 416       done;
 417       printf "\n"
 418   ) accesses
 419
 420 (* Finish off the PostScript output. *)
 421 let () =
 422   printf "outline breaks labels key\n";
 423   printf "%%%%EOF\n"