extract/codegen/kerneldb_to_parser.ml

   1 (* Memory info 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 (* This program takes the kernel database (in kernels/ in toplevel
  21    directory) and generates parsing code for the various structures
  22    in the kernel that we are interested in.
  23
  24    The output programs -- *.ml, *.mli files of generated code -- go
  25    into lib/ at the toplevel, eg. lib/kernel_task_struct.ml
  26
  27    The stuff at the top of this file determine what structures
  28    and fields we try to parse.
  29 *)
  30
  31 let what = [
  32   "task_struct", (
  33     "struct task_struct {", "};", true,
  34     [ "state"; "prio"; "normal_prio"; "static_prio";
  35       "tasks'prev"; "tasks'next"; "comm"]
  36   );
  37 (*
  38   "mm_struct", (
  39     "struct mm_struct {", "};", true,
  40     [ ]
  41   );
  42 *)
  43   "net_device", (
  44     "struct net_device {", "};", true,
  45     [ "name"; "dev_addr" ]
  46   );
  47 ]
  48
  49 let debug = true
  50
  51 open Camlp4.PreCast
  52 open Syntax
  53 (*open Ast*)
  54
  55 open ExtList
  56 open ExtString
  57 open Printf
  58
  59 let (//) = Filename.concat
  60
  61 let () =
  62   let args = Array.to_list Sys.argv in
  63
  64   let kernelsdir, outputdir =
  65     match args with
  66     | [_;kd;od] -> kd,od
  67     | _ ->
  68         let arg0 = Filename.basename Sys.executable_name in
  69         eprintf "%s - Turn kernels database into code modules.
  70
  71 Usage:
  72   %s <kernelsdir> <outputdir>
  73
  74 Example (from toplevel of virt-mem source tree):
  75   %s kernels/ lib/
  76 " arg0 arg0 arg0;
  77         exit 2 in
  78
  79   (* Get the *.info files from the kernels database. *)
  80   let infos = Sys.readdir kernelsdir in
  81   let infos = Array.to_list infos in
  82   let infos = List.filter (fun name -> String.ends_with name ".info") infos in
  83   let infos = List.map ((//) kernelsdir) infos in
  84
  85   (* Regular expressions.  We really really should use ocaml-mikmatch ... *)
  86   let re_oldformat = Pcre.regexp "^RPM: \\d+: \\(build \\d+\\) ([-\\w]+) ([\\w.]+) ([\\w.]+) \\(.*?\\) (\\w+)" in
  87   let re_keyvalue = Pcre.regexp "^(\\w+): (.*)" in
  88
  89   (* Parse in the *.info files.  These have historically had a few different
  90    * formats that we need to support.
  91    *)
  92   let infos = List.map (
  93     fun filename ->
  94       (* Get the basename (for getting the .data file later on). *)
  95       let basename = Filename.chop_suffix filename ".info" in
  96
  97       let chan = open_in filename in
  98       let line = input_line chan in
  99
 100       (* Kernel version string. *)
 101       let version, arch =
 102         if Pcre.pmatch ~rex:re_oldformat line then (
 103           (* If the file starts with "RPM: \d+: ..." then it's the
 104            * original Fedora format.  Everything in one line.
 105            *)
 106           let subs = Pcre.exec ~rex:re_oldformat line in
 107           (* let name = Pcre.get_substring subs 1 in *)
 108           let version = Pcre.get_substring subs 2 in
 109           let release = Pcre.get_substring subs 3 in
 110           let arch = Pcre.get_substring subs 4 in
 111           close_in chan;
 112           (* XXX Map name -> PAE, hugemem etc. *)
 113           (* name, *) sprintf "%s-%s.%s" version release arch, arch
 114         ) else (
 115           (* New-style "key: value" entries, up to end of file or the first
 116            * blank line.
 117            *)
 118           let (*name,*) version, release, arch =
 119             (*ref "",*) ref "", ref "", ref "" in
 120           let rec loop line =
 121             try
 122               let subs = Pcre.exec ~rex:re_keyvalue line in
 123               let key = Pcre.get_substring subs 1 in
 124               let value = Pcre.get_substring subs 2 in
 125               (*if key = "Name" then name := value
 126               else*) if key = "Version" then version := value
 127               else if key = "Release" then release := value
 128               else if key = "Architecture" then arch := value;
 129               let line = input_line chan in
 130               loop line
 131             with
 132               Not_found | End_of_file ->
 133                 close_in chan
 134           in
 135           loop line;
 136           let (*name,*) version, release, arch =
 137             (*!name,*) !version, !release, !arch in
 138           if (*name = "" ||*) version = "" || release = "" || arch = "" then
 139             failwith (sprintf "%s: missing Name, Version, Release or Architecture key" filename);
 140           (* XXX Map name -> PAE, hugemem etc. *)
 141           (* name, *) sprintf "%s-%s.%s" version release arch, arch
 142         ) in
 143
 144       (*printf "%s -> %s %s\n%!" basename version arch;*)
 145
 146       (basename, version, arch)
 147   ) infos in
 148
 149   (* For quick access to the opener strings, build a hash. *)
 150   let openers = Hashtbl.create 13 in
 151   List.iter (
 152     fun (name, (opener, closer, _, _)) ->
 153       Hashtbl.add openers opener (closer, name)
 154   ) what;
 155
 156   (* Now read the data files and parse out the structures of interest. *)
 157   let datas = List.map (
 158     fun (basename, version, arch) ->
 159       let file_exists name =
 160         try Unix.access name [Unix.F_OK]; true
 161         with Unix.Unix_error _ -> false
 162       in
 163       let close_process_in cmd chan =
 164         match Unix.close_process_in chan with
 165         | Unix.WEXITED 0 -> ()
 166         | Unix.WEXITED i ->
 167             eprintf "%s: command exited with code %d\n" cmd i; exit i
 168         | Unix.WSIGNALED i ->
 169             eprintf "%s: command exited with signal %d\n" cmd i; exit 1
 170         | Unix.WSTOPPED i ->
 171             eprintf "%s: command stopped by signal %d\n" cmd i; exit 1
 172       in
 173
 174       (* Open the data file, uncompressing it on the fly if necessary. *)
 175       let chan, close =
 176         if file_exists (basename ^ ".data") then
 177           open_in (basename ^ ".data"), close_in
 178         else if file_exists (basename ^ ".data.gz") then (
 179           let cmd =
 180             sprintf "gzip -cd %s" (Filename.quote (basename ^ ".data.gz")) in
 181           Unix.open_process_in cmd, close_process_in cmd
 182         )
 183         else if file_exists (basename ^ ".data.bz2") then (
 184           let cmd =
 185             sprintf "bzip2 -cd %s" (Filename.quote (basename ^ ".data.bz2")) in
 186           Unix.open_process_in cmd, close_process_in cmd
 187         ) else
 188           failwith
 189             (sprintf "%s: cannot find corresponding data file" basename) in
 190
 191       (* Read the data file in, looking for structures of interest to us. *)
 192       let bodies = Hashtbl.create 13 in
 193       let rec loop () =
 194         let line = input_line chan in
 195
 196         (* If the line is an opener for one of the structures we
 197          * are looking for, then for now just save all the text until
 198          * we get to the closer line.
 199          *)
 200         (try
 201            let closer, name = Hashtbl.find openers line in
 202            let rec loop2 lines =
 203              let line = input_line chan in
 204              let lines = line :: lines in
 205              if String.starts_with line closer then List.rev lines
 206              else loop2 lines
 207            in
 208
 209            let body =
 210              try loop2 [line]
 211              with End_of_file ->
 212                failwith (sprintf "%s: %s: %S not matched by closing %S" basename name line closer) in
 213
 214            Hashtbl.replace bodies name body
 215          with Not_found -> ());
 216
 217         loop ()
 218       in
 219       (try loop () with End_of_file -> ());
 220
 221       close chan;
 222
 223       (* Make sure we got all the mandatory structures. *)
 224       List.iter (
 225          fun (name, (_, _, mandatory, _)) ->
 226            if mandatory && not (Hashtbl.mem bodies name) then
 227              failwith (sprintf "%s: structure %s not found in this kernel" basename name)
 228       ) what;
 229
 230       (basename, version, arch, bodies)
 231   ) infos in
 232
 233   (* Now parse each structure body.
 234    * XXX This would be better as a proper lex/yacc parser.
 235    * XXX Even better would be to have a proper interface to libdwarves.
 236    *)
 237   let re_offsetsize = Pcre.regexp "/\\*\\s+(\\d+)\\s+(\\d+)\\s+\\*/" in
 238   let re_intfield = Pcre.regexp "int\\s+(\\w+);" in
 239   let re_ptrfield = Pcre.regexp "struct\\s+(\\w+)\\s*\\*\\s*(\\w+);" in
 240   let re_strfield = Pcre.regexp "char\\s+(\\w+)\\[(\\d+)\\];" in
 241   let re_structopener = Pcre.regexp "(struct|union)\\s+.*{$" in
 242   let re_structcloser = Pcre.regexp "}\\s*(\\w+)?(\\[\\d+\\])?;" in
 243
 244   (* 'basename' is the source file, and second parameter ('body') is
 245    * the list of text lines which covers this structure (minus the
 246    * opener line).  Result is the list of parsed fields from this
 247    * structure.
 248    *)
 249   let rec parse basename = function
 250     | [] -> assert false
 251     | [_] -> []                  (* Just the closer line, finished. *)
 252     | line :: lines when Pcre.pmatch ~rex:re_structopener line ->
 253       (* Recursively parse a sub-structure.  First search for the
 254        * corresponding closer line.
 255        *)
 256       let rec loop depth acc = function
 257         | [] ->
 258             eprintf "%s: %S has no matching close structure line\n%!"
 259               basename line;
 260             assert false
 261         | line :: lines when Pcre.pmatch ~rex:re_structopener line ->
 262           loop (depth+1) (line :: acc) lines
 263         | line :: lines
 264             when depth = 0 && Pcre.pmatch ~rex:re_structcloser line ->
 265           (line :: acc), lines
 266         | line :: lines
 267             when depth > 0 && Pcre.pmatch ~rex:re_structcloser line ->
 268           loop (depth-1) (line :: acc) lines
 269         | line :: lines -> loop depth (line :: acc) lines
 270       in
 271       let nested_body, rest = loop 0 [] lines in
 272
 273       (* Then parse the sub-structure. *)
 274       let struct_name, nested_body =
 275         match nested_body with
 276         | [] -> assert false
 277         | closer :: _ ->
 278             let subs = Pcre.exec ~rex:re_structcloser closer in
 279             let struct_name =
 280               try Some (Pcre.get_substring subs 1) with Not_found -> None in
 281             struct_name, List.rev nested_body in
 282       let nested_fields = parse basename nested_body in
 283
 284       (* Prefix the sub-fields with the name of the structure. *)
 285       let nested_fields =
 286         match struct_name with
 287         | None -> nested_fields
 288         | Some prefix ->
 289             List.map (
 290               fun (name, details) -> (prefix ^ "'" ^ name, details)
 291             ) nested_fields in
 292
 293       (* Parse the rest. *)
 294       nested_fields @ parse basename rest
 295
 296     | line :: lines when Pcre.pmatch ~rex:re_intfield line ->
 297       (* An int field. *)
 298       let subs = Pcre.exec ~rex:re_intfield line in
 299       let name = Pcre.get_substring subs 1 in
 300       (try
 301          let subs = Pcre.exec ~rex:re_offsetsize line in
 302          let offset = int_of_string (Pcre.get_substring subs 1) in
 303          let size = int_of_string (Pcre.get_substring subs 2) in
 304          (name, (`Int, offset, size)) :: 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          (name, (`Ptr struct_name, offset, size)) :: parse basename lines
 319        with
 320          Not_found -> parse basename lines
 321       );
 322
 323     | line :: lines when Pcre.pmatch ~rex:re_strfield line ->
 324       (* A string (char array) field. *)
 325       let subs = Pcre.exec ~rex:re_strfield line in
 326       let name = Pcre.get_substring subs 1 in
 327       let width = int_of_string (Pcre.get_substring subs 2) in
 328       (try
 329          let subs = Pcre.exec ~rex:re_offsetsize line in
 330          let offset = int_of_string (Pcre.get_substring subs 1) in
 331          let size = int_of_string (Pcre.get_substring subs 2) in
 332          (name, (`Str width, offset, size)) :: parse basename lines
 333        with
 334          Not_found -> parse basename lines
 335       );
 336
 337     | _ :: lines ->
 338         (* Just ignore any other field we can't parse. *)
 339         parse basename lines
 340
 341   in
 342
 343   let datas = List.map (
 344     fun (basename, version, arch, bodies) ->
 345       let structures = List.filter_map (
 346         fun (name, (_, _, _, wanted_fields)) ->
 347           let body =
 348             try Some (Hashtbl.find bodies name) with Not_found -> None in
 349           match body with
 350           | None -> None
 351           | Some body ->
 352               let body = List.tl body in (* Don't care about opener line. *)
 353               let fields = parse basename body in
 354
 355               (* Compute total size of the structure. *)
 356               let total_size =
 357                 let fields = List.map (
 358                   fun (_, (_, offset, size)) -> offset + size
 359                 ) fields in
 360                 List.fold_left max 0 fields in
 361
 362               (* That got us all the fields, but we only care about
 363                * the wanted_fields.
 364                *)
 365               let fields = List.filter (
 366                 fun (name, _) -> List.mem name wanted_fields
 367               ) fields in
 368
 369               (* Also check we have all the wanted fields. *)
 370               List.iter (
 371                 fun wanted_field ->
 372                   if not (List.mem_assoc wanted_field fields) then
 373                     failwith (sprintf "%s: structure %s is missing required field %s" basename name wanted_field)
 374               ) wanted_fields;
 375
 376               Some (name, (fields, total_size))
 377       ) what in
 378
 379       (basename, version, arch, structures)
 380   ) datas in
 381
 382   if debug then
 383     List.iter (
 384       fun (basename, version, arch, structures) ->
 385         printf "%s (version: %s, arch: %s):\n" basename version arch;
 386         List.iter (
 387           fun (struct_name, (fields, total_size)) ->
 388             printf "  struct %s {\n" struct_name;
 389             List.iter (
 390               fun (field_name, (typ, offset, size)) ->
 391                 (match typ with
 392                  | `Int ->
 393                      printf "    int %s; " field_name
 394                  | `Ptr struct_name ->
 395                      printf "    struct %s *%s; " struct_name field_name
 396                  | `Str width ->
 397                      printf "    char %s[%d]; " field_name width
 398                 );
 399                 printf " /* offset = %d, size = %d */\n" offset size
 400             ) fields;
 401             printf "  } /* %d bytes */\n\n" total_size;
 402         ) structures;
 403     ) datas;
 404
 405   (* We'll generate a code file for each structure type (eg. task_struct
 406    * across all kernel versions), so rearrange 'datas' for that purpose.
 407    *
 408    * XXX This loop is O(n^3), luckily n is small!
 409    *)
 410   let files =
 411     List.map (
 412       fun (name, _) ->
 413         name,
 414         List.filter_map (
 415           fun (basename, version, arch, structures) ->
 416             try Some (basename, version, arch, List.assoc name structures)
 417             with Not_found -> None
 418         ) datas
 419     ) what in
 420
 421   let datas = () in ignore datas; (* garbage collect *)
 422
 423   (* Get just the field types.  It's plausible that a field with the
 424    * same name has a different type between kernel versions, so we must
 425    * check that didn't happen.
 426    *)
 427   let files = List.map (
 428     fun (struct_name, kernels) ->
 429       let field_types =
 430         match kernels with
 431         | [] -> []
 432         | (_, _, _, (fields, _)) :: kernels ->
 433             let field_types_of_fields fields =
 434               List.sort (
 435                 List.map (
 436                   fun (field_name, (typ, _, _)) -> field_name, typ
 437                 ) fields
 438               )
 439             in
 440             let field_types = field_types_of_fields fields in
 441             List.iter (
 442               fun (_, _, _, (fields, _)) ->
 443                 if field_types <> field_types_of_fields fields then
 444                   failwith (sprintf "%s: one of the structure fields changed type between kernel versions" struct_name)
 445             ) kernels;
 446             field_types in
 447       (struct_name, kernels, field_types)
 448   ) files in
 449
 450   (* To minimize generated code size, we want to fold together all
 451    * structures where the particulars (eg. offsets, sizes, endianness)
 452    * of the fields we care about are the same -- eg. between kernel
 453    * versions which are very similar.
 454    *)
 455   let endian_of_architecture arch =
 456     if String.starts_with arch "i386" ||
 457       String.starts_with arch "i486" ||
 458       String.starts_with arch "i586" ||
 459       String.starts_with arch "i686" ||
 460       String.starts_with arch "x86_64" ||
 461       String.starts_with arch "x86-64" then
 462         Bitstring.LittleEndian
 463     else if String.starts_with arch "ia64" then
 464       Bitstring.LittleEndian (* XXX usually? *)
 465     else if String.starts_with arch "ppc" then
 466       Bitstring.BigEndian
 467     else if String.starts_with arch "sparc" then
 468       Bitstring.BigEndian
 469     else
 470       failwith (sprintf "endian_of_architecture: cannot parse %S" arch)
 471   in
 472
 473   let files =
 474     List.map (
 475       fun (struct_name, kernels, field_types) ->
 476         let hash = Hashtbl.create 13 in
 477         let i = ref 0 in
 478         let xs = ref [] in
 479         let kernels =
 480           List.map (
 481             fun (basename, version, arch, (fields, total_size)) ->
 482               let key = endian_of_architecture arch, fields in
 483               let j =
 484                 try Hashtbl.find hash key
 485                 with Not_found ->
 486                   incr i;
 487                   xs := (!i, key) :: !xs; Hashtbl.add hash key !i;
 488                   !i in
 489               (basename, version, arch, total_size, j)
 490           ) kernels in
 491         struct_name, kernels, field_types, List.rev !xs
 492     ) files in
 493
 494   (* How much did we save by sharing? *)
 495   if debug then
 496     List.iter (
 497       fun (struct_name, kernels, _, parsers) ->
 498         printf "struct %s:\n" struct_name;
 499         printf "  number of kernel versions: %d\n" (List.length kernels);
 500         printf "  number of parser functions needed after sharing: %d\n"
 501           (List.length parsers)
 502     ) files;
 503
 504   (* Let's generate some code! *)
 505   let files =
 506     List.map (
 507       fun (struct_name, kernels, field_types, parsers) ->
 508         (* Dummy location required - there are no real locations for
 509          * output files.
 510          *)
 511         let _loc = Loc.ghost in
 512
 513         (* The structure type. *)
 514         let struct_type, struct_sig =
 515           let fields = List.map (
 516             function
 517             | (name, `Int) ->
 518                 <:ctyp< $lid:name$ : int >>
 519             | (name, `Ptr struct_name) ->
 520                 <:ctyp< $lid:name$ : [`$lid:struct_name$] int64 >>
 521             | (name, `Str _) ->
 522                 <:ctyp< $lid:name$ : string >>
 523           ) field_types in
 524           let f, fs = match fields with
 525             | [] -> failwith (sprintf "%s: structure has no fields" struct_name)
 526             | f :: fs -> f, fs in
 527           let fields = List.fold_left (
 528             fun fs f -> <:ctyp< $fs$ ; $f$ >>
 529           ) f fs in
 530
 531           let struct_type = <:str_item< type t = { $fields$ } >> in
 532           let struct_sig = <:sig_item< type t = { $fields$ } >> in
 533           struct_type, struct_sig in
 534
 535         (* The shared parser functions.
 536          * We could include bitmatch statements directly in here, but
 537          * what happens is that the macros get expanded here, resulting
 538          * in unreadable generated code.  So instead just do a textual
 539          * substitution later by post-processing the generated files.
 540          * Not type-safe, but we can't have everything.
 541          *)
 542         let parser_stmts, parser_subs =
 543           let parser_stmts = List.map (
 544             fun (i, _) ->
 545               let fnname = sprintf "parser_%d" i in
 546               <:str_item<
 547                 let $lid:fnname$ bits = $str:fnname$
 548               >>
 549           ) parsers in
 550
 551           let parser_stmts =
 552             match parser_stmts with
 553             | [] -> <:str_item< >>
 554             | p :: ps ->
 555                 List.fold_left (fun ps p -> <:str_item< $ps$ $p$ >>) p ps in
 556
 557           (* What gets substituted for "parser_NN" ... *)
 558           let parser_subs = List.map (
 559             fun (i, (endian, fields)) ->
 560               let fnname = sprintf "parser_%d" i in
 561               let patterns = "" and assignments = "" in (* XXX *)
 562               let sub =
 563                 sprintf "bitmatch bits with
 564                          | { %s } -> { %s }
 565                          | { _ } -> raise (ParseError (%S, %S, \"failed to match kernel structure\"))"
 566                   patterns assignments struct_name fnname in
 567               fnname, sub
 568           ) parsers in
 569
 570           parser_stmts, parser_subs in
 571
 572         (* Define a map from kernel versions to parsing functions. *)
 573         let version_map =
 574           let stmts = List.fold_left (
 575             fun stmts (_, version, arch, total_size, i) ->
 576               let parserfn = sprintf "parser_%d" i in
 577               <:str_item<
 578                 $stmts$
 579                 let v = ($lid:parserfn$, $`int:total_size$)
 580                 let map = StringMap.add $str:version$ v map
 581               >>
 582           ) <:str_item< let map = StringMap.empty >> kernels in
 583
 584           <:str_item<
 585             module StringMap = Map.Make (String)
 586             $stmts$
 587           >> in
 588
 589         (* Code (.ml file). *)
 590         let code = <:str_item<
 591           let warning = "This code is automatically generated from the kernel database by kerneldb-to-parser program.  Any edits you make will be lost."
 592           exception ParseError of string ;;
 593           $struct_type$
 594           $parser_stmts$
 595           $version_map$
 596
 597           type kernel_version = string
 598           let known version = StringMap.mem version map
 599           let size version =
 600             let _, size = StringMap.find version map in
 601             size
 602           let get version bits =
 603             let parsefn, _ = StringMap.find version map in
 604             parsefn bits
 605         >> in
 606
 607         (* Interface (.mli file). *)
 608         let interface = <:sig_item<
 609           exception ParseError of string ;;
 610           $struct_sig$
 611
 612           type kernel_version = string
 613           val known : kernel_version -> bool
 614           val size : kernel_version -> int
 615           val get : kernel_version -> Bitstring.bitstring -> t
 616         >> in
 617
 618         (struct_name, code, interface)
 619     ) files in
 620
 621   (* Finally generate the output files. *)
 622   List.iter (
 623     fun (struct_name, code, interface) ->
 624       let output_file = outputdir // "kernel_" ^ struct_name ^ ".ml" in
 625       printf "Writing %s implementation to %s ...\n%!" struct_name output_file;
 626       Printers.OCaml.print_implem ~output_file code;
 627
 628       let output_file = outputdir // "kernel_" ^ struct_name ^ ".mli" in
 629       printf "Writing %s interface to %s ...\n%!" struct_name output_file;
 630       Printers.OCaml.print_interf ~output_file interface
 631   ) files