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