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