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