extract/codegen/pahole_parser.ml

   1 (* Memory info command for virtual domains.
   2    (C) Copyright 2008 Richard W.M. Jones, Red Hat Inc.
   3    http://libvirt.org/
   4
   5    This program is free software; you can redistribute it and/or modify
   6    it under the terms of the GNU General Public License as published by
   7    the Free Software Foundation; either version 2 of the License, or
   8    (at your option) any later version.
   9
  10    This program is distributed in the hope that it will be useful,
  11    but WITHOUT ANY WARRANTY; without even the implied warranty of
  12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13    GNU General Public License for more details.
  14
  15    You should have received a copy of the GNU General Public License
  16    along with this program; if not, write to the Free Software
  17    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18  *)
  19
  20 open ExtList
  21 open ExtString
  22
  23 open Printf
  24
  25 let (//) = Filename.concat
  26
  27 type pathname = string
  28
  29 type info = {
  30   kv_i : int;
  31   kernel_version : string;
  32   arch : string;
  33   basename : string;
  34 }
  35
  36 type structure = {
  37   struct_name : string;
  38   struct_total_size : int;
  39   struct_fields : field list;
  40 }
  41
  42 and field = {
  43   field_name : string;
  44   field_type : f_type;
  45   field_offset : int;
  46   field_size : int;
  47 }
  48
  49 and f_type =
  50   | FStructPointer of string
  51   | FVoidPointer
  52   | FAnonListHeadPointer
  53   | FListHeadPointer of (string * string) option
  54   | FInteger
  55   | FString of int
  56
  57 let string_of_info i =
  58   sprintf "%s: %s (%d) %s" i.basename i.kernel_version i.kv_i i.arch
  59
  60 let rec string_of_structure s =
  61   let fields = List.map string_of_field s.struct_fields in
  62   let fields = String.concat "\n  " fields in
  63   sprintf "struct %s {\n  %s\n}; /* total size = %d bytes */"
  64     s.struct_name fields s.struct_total_size
  65
  66 and string_of_field f =
  67   sprintf "%s %s; /* offset = %d, size = %d */"
  68     (string_of_f_type f.field_type) f.field_name
  69     f.field_offset f.field_size
  70
  71 and string_of_f_type = function
  72   | FStructPointer struct_name -> sprintf "struct %s *" struct_name
  73   | FVoidPointer -> "void *"
  74   | FAnonListHeadPointer -> "struct list_head *"
  75   | FListHeadPointer None ->
  76       sprintf "struct /* self */ list_head *"
  77   | FListHeadPointer (Some (struct_name, field_name)) ->
  78       sprintf "struct /* to %s.%s */ list_head *" struct_name field_name
  79   | FInteger -> "int"
  80   | FString width -> sprintf "char[%d]" width
  81
  82 let file_exists name =
  83   try Unix.access name [Unix.F_OK]; true
  84   with Unix.Unix_error _ -> false
  85
  86 (* Regular expressions.  We really really should use ocaml-mikmatch ... *)
  87 let re_oldformat = Pcre.regexp "^RPM: \\d+: \\(build \\d+\\) ([-\\w]+) ([\\w.]+) ([\\w.]+) \\(.*?\\) (\\w+)"
  88 let re_keyvalue = Pcre.regexp "^(\\w+): (.*)"
  89
  90 let list_kernels path =
  91   (* Get the *.info files from the kernels database. *)
  92   let infos = Sys.readdir path in
  93   let infos = Array.to_list infos in
  94   let infos = List.filter (fun name -> String.ends_with name ".info") infos in
  95   let infos = List.map ( (//) path) infos in
  96
  97   (* Parse in the *.info files.  These have historically had a few different
  98    * formats that we need to support.
  99    *)
 100   let infos = List.mapi (
 101     fun i filename ->
 102       (* Get the basename (for getting the .data file later on). *)
 103       let basename = Filename.chop_suffix filename ".info" in
 104
 105       let chan = open_in filename in
 106       let line = input_line chan in
 107
 108       (* Kernel version string. *)
 109       let version, arch =
 110         if Pcre.pmatch ~rex:re_oldformat line then (
 111           (* If the file starts with "RPM: \d+: ..." then it's the
 112            * original Fedora format.  Everything in one line.
 113            *)
 114           let subs = Pcre.exec ~rex:re_oldformat line in
 115           (* let name = Pcre.get_substring subs 1 in *)
 116           let version = Pcre.get_substring subs 2 in
 117           let release = Pcre.get_substring subs 3 in
 118           let arch = Pcre.get_substring subs 4 in
 119           close_in chan;
 120           (* XXX Map name -> PAE, hugemem etc. *)
 121           (* name, *) sprintf "%s-%s.%s" version release arch, arch
 122         ) else (
 123           (* New-style "key: value" entries, up to end of file or the first
 124            * blank line.
 125            *)
 126           let (*name,*) version, release, arch =
 127             (*ref "",*) ref "", ref "", ref "" in
 128           let rec loop line =
 129             try
 130               let subs = Pcre.exec ~rex:re_keyvalue line in
 131               let key = Pcre.get_substring subs 1 in
 132               let value = Pcre.get_substring subs 2 in
 133               (*if key = "Name" then name := value
 134               else*) if key = "Version" then version := value
 135               else if key = "Release" then release := value
 136               else if key = "Architecture" then arch := value;
 137               let line = input_line chan in
 138               loop line
 139             with
 140               Not_found | End_of_file ->
 141                 close_in chan
 142           in
 143           loop line;
 144           let (*name,*) version, release, arch =
 145             (*!name,*) !version, !release, !arch in
 146           if (*name = "" ||*) version = "" || release = "" || arch = "" then
 147             failwith (sprintf "%s: missing Name, Version, Release or Architecture key" filename);
 148           (* XXX Map name -> PAE, hugemem etc. *)
 149           (* name, *) sprintf "%s-%s.%s" version release arch, arch
 150         ) in
 151
 152       (*printf "%s -> %s %s\n%!" basename version arch;*)
 153
 154       { kv_i = i;
 155         basename = basename; arch = arch;
 156         kernel_version = version }
 157   ) infos in
 158
 159   (* Check the .data, .data.gz or .data.bz2 file exists, and skip with
 160    * a warning if not.
 161    *)
 162   let infos = List.filter (
 163     fun { basename = basename } ->
 164       if not (file_exists (basename ^ ".data")) &&
 165         not (file_exists (basename ^ ".data.gz")) &&
 166         not (file_exists (basename ^ ".data.bz2")) then (
 167           eprintf "warning: %s: no data file found for this kernel - skipping\n%!"
 168             basename;
 169           false
 170         )
 171       else
 172         true
 173   ) infos in
 174
 175   infos
 176
 177 (* XXX This would be better as a proper lex/yacc parser.
 178  * XXX Even better would be to have a proper interface to libdwarves.
 179  *)
 180 let re_offsetsize = Pcre.regexp "/\\*\\s+(\\d+)\\s+(\\d+)\\s+\\*/"
 181 let re_intfield = Pcre.regexp "(?:int|char)\\s+(\\w+);"
 182 let re_ptrfield = Pcre.regexp "struct\\s+(\\w+)\\s*\\*\\s*(\\w+);"
 183 let re_voidptrfield = Pcre.regexp "void\\s*\\*\\s*(\\w+);"
 184 let re_strfield = Pcre.regexp "char\\s+(\\w+)\\[(\\d+)\\];"
 185 let re_structopener = Pcre.regexp "(struct|union)\\s+.*{$"
 186 let re_structcloser = Pcre.regexp "}\\s*(\\w+)?(\\[\\d+\\])?;"
 187
 188 let load_structures { basename = basename } struct_names =
 189   (* For quick access to the opener strings, build a hash. *)
 190   let openers = Hashtbl.create 13 in
 191   List.iter (
 192     fun struct_name ->
 193       let opener = sprintf "struct %s {" struct_name in
 194       let closer = "};" in
 195       Hashtbl.add openers opener (closer, struct_name)
 196   ) struct_names;
 197
 198   (* Now read the data file and parse out the structures of interest. *)
 199   let close_process_in cmd chan =
 200     match Unix.close_process_in chan with
 201     | Unix.WEXITED 0 -> ()
 202     | Unix.WEXITED i ->
 203         eprintf "%s: command exited with code %d\n" cmd i; exit i
 204     | Unix.WSIGNALED i ->
 205         eprintf "%s: command exited with signal %d\n" cmd i; exit 1
 206     | Unix.WSTOPPED i ->
 207         eprintf "%s: command stopped by signal %d\n" cmd i; exit 1
 208   in
 209
 210   (* Open the data file, uncompressing it on the fly if necessary. *)
 211   let chan, close =
 212     if file_exists (basename ^ ".data") then
 213       open_in (basename ^ ".data"), close_in
 214     else if file_exists (basename ^ ".data.gz") then (
 215       let cmd =
 216         sprintf "gzip -cd %s" (Filename.quote (basename ^ ".data.gz")) in
 217       Unix.open_process_in cmd, close_process_in cmd
 218     )
 219     else if file_exists (basename ^ ".data.bz2") then (
 220       let cmd =
 221         sprintf "bzip2 -cd %s" (Filename.quote (basename ^ ".data.bz2")) in
 222       Unix.open_process_in cmd, close_process_in cmd
 223     ) else
 224       failwith (sprintf "%s: cannot find corresponding data file" basename) in
 225
 226   (* Read the data file in, looking for structures of interest to us. *)
 227   let bodies = Hashtbl.create 13 in
 228   let rec loop () =
 229     let line = input_line chan in
 230
 231     (* If the line is an opener for one of the structures we
 232      * are looking for, then for now just save all the text until
 233      * we get to the closer line.
 234      *)
 235     (try
 236        let closer, struct_name = Hashtbl.find openers line in
 237        let rec loop2 lines =
 238          let line = input_line chan in
 239          let lines = line :: lines in
 240          if String.starts_with line closer then List.rev lines
 241          else loop2 lines
 242        in
 243
 244        let body =
 245          try loop2 [line]
 246          with End_of_file ->
 247            failwith (sprintf "%s: %s: %S not matched by closing %S" basename struct_name line closer) in
 248
 249        Hashtbl.replace bodies struct_name body
 250      with Not_found -> ());
 251
 252     loop ()
 253   in
 254   (try loop () with End_of_file -> ());
 255
 256   close chan;
 257
 258   (* Now parse each structure body. *)
 259
 260   (* 'basename' is the source file, and second parameter ('body') is
 261    * the list of text lines which covers this structure (minus the
 262    * opener line).  Result is the list of parsed fields from this
 263    * structure.
 264    *)
 265   let rec parse basename = function
 266     | [] -> assert false
 267     | [_] -> []                  (* Just the closer line, finished. *)
 268     | line :: lines when Pcre.pmatch ~rex:re_structopener line ->
 269       (* Recursively parse a sub-structure.  First search for the
 270        * corresponding closer line.
 271        *)
 272       let rec loop depth acc = function
 273         | [] ->
 274             eprintf "%s: %S has no matching close structure line\n%!"
 275               basename line;
 276             assert false
 277         | line :: lines when Pcre.pmatch ~rex:re_structopener line ->
 278           loop (depth+1) (line :: acc) lines
 279         | line :: lines
 280             when depth = 0 && Pcre.pmatch ~rex:re_structcloser line ->
 281           (line :: acc), lines
 282         | line :: lines
 283             when depth > 0 && Pcre.pmatch ~rex:re_structcloser line ->
 284           loop (depth-1) (line :: acc) lines
 285         | line :: lines -> loop depth (line :: acc) lines
 286       in
 287       let nested_body, rest = loop 0 [] lines in
 288
 289       (* Then parse the sub-structure. *)
 290       let struct_name, nested_body =
 291         match nested_body with
 292         | [] -> assert false
 293         | closer :: _ ->
 294             let subs = Pcre.exec ~rex:re_structcloser closer in
 295             let struct_name =
 296               try Some (Pcre.get_substring subs 1) with Not_found -> None in
 297             struct_name, List.rev nested_body in
 298       let nested_fields = parse basename nested_body in
 299
 300       (* Prefix the sub-fields with the name of the structure. *)
 301       let nested_fields =
 302         match struct_name with
 303         | None -> nested_fields
 304         | Some prefix ->
 305             List.map (
 306               fun ({ field_name = name } as field) ->
 307                 let name = prefix ^ "'" ^ name in
 308                 { field with field_name = name }
 309             ) nested_fields in
 310
 311       (* Parse the rest. *)
 312       nested_fields @ parse basename rest
 313
 314     | line :: lines when Pcre.pmatch ~rex:re_intfield line ->
 315       (* An int field. *)
 316       let subs = Pcre.exec ~rex:re_intfield line in
 317       let name = Pcre.get_substring subs 1 in
 318       (try
 319          let subs = Pcre.exec ~rex:re_offsetsize line in
 320          let offset = int_of_string (Pcre.get_substring subs 1) in
 321          let size = int_of_string (Pcre.get_substring subs 2) in
 322          let field =
 323            { field_name = name; field_type = FInteger;
 324              field_offset = offset; field_size = size } in
 325          field :: parse basename lines
 326        with
 327          Not_found -> parse basename lines
 328       );
 329
 330     | line :: lines when Pcre.pmatch ~rex:re_ptrfield line ->
 331       (* A pointer-to-struct field. *)
 332       let subs = Pcre.exec ~rex:re_ptrfield line in
 333       let struct_name = Pcre.get_substring subs 1 in
 334       let name = Pcre.get_substring subs 2 in
 335       (try
 336          let subs = Pcre.exec ~rex:re_offsetsize line in
 337          let offset = int_of_string (Pcre.get_substring subs 1) in
 338          let size = int_of_string (Pcre.get_substring subs 2) in
 339          let field_type =
 340            if struct_name <> "list_head" then
 341              FStructPointer struct_name
 342            else
 343              FAnonListHeadPointer in
 344          let field =
 345            { field_name = name; field_type = field_type;
 346              field_offset = offset; field_size = size } in
 347          field :: parse basename lines
 348        with
 349          Not_found -> parse basename lines
 350       );
 351
 352     | line :: lines when Pcre.pmatch ~rex:re_voidptrfield line ->
 353       (* A void* field. *)
 354       let subs = Pcre.exec ~rex:re_voidptrfield line in
 355       let name = Pcre.get_substring subs 1 in
 356       (try
 357          let subs = Pcre.exec ~rex:re_offsetsize line in
 358          let offset = int_of_string (Pcre.get_substring subs 1) in
 359          let size = int_of_string (Pcre.get_substring subs 2) in
 360          let field =
 361            { field_name = name; field_type = FVoidPointer;
 362              field_offset = offset; field_size = size } in
 363          field :: parse basename lines
 364        with
 365          Not_found -> parse basename lines
 366       );
 367
 368     | line :: lines when Pcre.pmatch ~rex:re_strfield line ->
 369       (* A string (char array) field. *)
 370       let subs = Pcre.exec ~rex:re_strfield line in
 371       let name = Pcre.get_substring subs 1 in
 372       let width = int_of_string (Pcre.get_substring subs 2) in
 373       (try
 374          let subs = Pcre.exec ~rex:re_offsetsize line in
 375          let offset = int_of_string (Pcre.get_substring subs 1) in
 376          let size = int_of_string (Pcre.get_substring subs 2) in
 377          let field =
 378            { field_name = name; field_type = FString width;
 379              field_offset = offset; field_size = size } in
 380          field :: parse basename lines
 381        with
 382          Not_found -> parse basename lines
 383       );
 384
 385     | _ :: lines ->
 386         (* Just ignore any other field we can't parse. *)
 387         parse basename lines
 388   in
 389
 390   let structures = List.filter_map (
 391     fun struct_name ->
 392       let body =
 393         try Some (Hashtbl.find bodies struct_name)
 394         with Not_found -> None in
 395       match body with
 396       | None -> None
 397       | Some body ->
 398           let body = List.tl body in (* Don't care about opener line. *)
 399           let fields = parse basename body in
 400
 401           (* Compute total size of the structure. *)
 402           let total_size =
 403             let fields = List.map (
 404               fun { field_offset = offset;
 405                     field_size = size } -> offset + size
 406             ) fields in
 407             List.fold_left max 0 fields in
 408
 409           (* Sort the structure fields by field offset.  They are
 410            * probably already in this order, but just make sure.
 411            *)
 412           let cmp { field_offset = o1 } { field_offset = o2 } = compare o1 o2 in
 413           let fields = List.sort ~cmp fields in
 414
 415           Some (
 416             struct_name,
 417             { struct_name = struct_name;
 418               struct_fields = fields;
 419               struct_total_size = total_size }
 420           )
 421   ) struct_names in
 422
 423   structures
 424
 425 (* XXX This loop is O(n^3), luckily n is small! *)
 426 let transpose good_struct_names kernels =
 427   List.map (
 428     fun struct_name ->
 429       let kernels =
 430         List.filter_map (
 431           fun (info, structures) ->
 432             try
 433               let s = List.assoc struct_name structures in
 434               Some (info, s)
 435             with
 436               Not_found -> None
 437         ) kernels in
 438
 439       (* Sort the kernels, which makes the generated output more stable
 440        * and makes patches more useful.
 441        *)
 442       let kernels = List.sort kernels in
 443
 444       struct_name, kernels
 445   ) good_struct_names
 446
 447 let get_fields structures =
 448   (* Use a hash table to accumulate the fields as we find them.
 449    * The key is the field name.  The value is the field type and the
 450    * kernel version where first seen (for error reporting).  If
 451    * we meet the field again, we check its type hasn't changed.
 452    * Finally, we can use the hash to pull out all field names and
 453    * types.
 454    *)
 455   let h = Hashtbl.create 13 in
 456
 457   (* A hash to check for fields which aren't always available by
 458    * counting the number of times we see each field.
 459    *)
 460   let count, get =
 461     let h = Hashtbl.create 13 in
 462     let count field_name =
 463       let r =
 464         try Hashtbl.find h field_name
 465         with Not_found -> let r = ref 0 in Hashtbl.add h field_name r; r in
 466       incr r
 467     in
 468     let get field_name = try !(Hashtbl.find h field_name) with Not_found -> 0 in
 469     count, get
 470   in
 471
 472   List.iter (
 473     fun ({kernel_version = version},
 474          {struct_name = struct_name; struct_fields = fields}) ->
 475       List.iter (
 476         fun {field_name = name; field_type = typ} ->
 477           count name;
 478           try
 479             let (field_type, version_first_seen) = Hashtbl.find h name in
 480             if typ <> field_type then (
 481               eprintf "Error: %s.%s: field changed type between kernel versions.\n"
 482                 struct_name name;
 483               eprintf "In version %s it had type %s.\n"
 484                 version_first_seen (string_of_f_type field_type);
 485               eprintf "In version %s it had type %s.\n"
 486                 version (string_of_f_type typ);
 487               eprintf "The code cannot handle fields which change type like this.\n";
 488               eprintf "See extract/codegen/pahole_parser.mli for more details.\n";
 489               exit 1
 490             )
 491           with Not_found ->
 492             Hashtbl.add h name (typ, version)
 493       ) fields
 494   ) structures;
 495
 496   let nr_kernels = List.length structures in
 497
 498   let fields =
 499     Hashtbl.fold (
 500       fun name (typ, _) fields ->
 501         let always_available = get name = nr_kernels in
 502         (name, (typ, always_available)) :: fields
 503     ) h [] in
 504
 505   List.sort fields