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