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 type struct_t = {
  32   opener : string;      (* String in pa_hole file which starts this struct. *)
  33   closer : string;      (* String in pa_hole file which ends this struct. *)
  34   mandatory_struct : bool; (* Is this struct mandatory? *)
  35   fields : (string * field_t) list;   (* List of interesting fields. *)
  36 }
  37 and field_t = {
  38   mandatory_field : bool;  (* Is this field mandatory? *)
  39 }
  40
  41 let structs = [
  42   "task_struct", {
  43     opener = "struct task_struct {"; closer = "};"; mandatory_struct = true;
  44     fields = [
  45       "state",       { mandatory_field = true };
  46       "prio",        { mandatory_field = true };
  47       "normal_prio", { mandatory_field = true };
  48       "static_prio", { mandatory_field = true };
  49       "tasks'prev",  { mandatory_field = true };
  50       "tasks'next",  { mandatory_field = true };
  51       "mm",          { mandatory_field = true };
  52       "active_mm",   { mandatory_field = true };
  53       "comm",        { mandatory_field = true };
  54       "pid",         { mandatory_field = true };
  55     ]
  56   };
  57 (*
  58   "mm_struct", (
  59     "struct mm_struct {", "};", true,
  60     [ ]
  61   );
  62 *)
  63   "net_device", {
  64     opener = "struct net_device {"; closer = "};"; mandatory_struct = true;
  65     fields = [
  66       "dev_list'prev", { mandatory_field = false };
  67       "dev_list'next", { mandatory_field = false };
  68       "next",          { mandatory_field = false };
  69       "name",          { mandatory_field = true };
  70       "dev_addr",      { mandatory_field = true };
  71     ]
  72   };
  73   "net", {
  74     opener = "struct net {"; closer = "};"; mandatory_struct = false;
  75     fields = [
  76       "dev_base_head'next", { mandatory_field = true };
  77     ]
  78   };
  79 ]
  80
  81 let debug = false
  82
  83 open Camlp4.PreCast
  84 open Syntax
  85 (*open Ast*)
  86
  87 open ExtList
  88 open ExtString
  89 open Printf
  90
  91 let (//) = Filename.concat
  92
  93 (* Couple of handy camlp4 construction functions which do some
  94  * things that ought to be easy/obvious but aren't.
  95  *
  96  * 'concat_str_items' concatenates a list of str_item together into
  97  * one big str_item.
  98  *
  99  * 'concat_record_fields' concatenates a list of records fields into
 100  * a record.  The list must have at least one element.
 101  *
 102  * 'build_record' builds a record out of record fields.
 103  *
 104  * 'build_tuple_from_exprs' builds an arbitrary length tuple from
 105  * a list of expressions of length >= 2.
 106  *
 107  * Thanks to bluestorm on #ocaml for getting these working.
 108  *)
 109 let concat_str_items _loc items =
 110   match items with
 111   | [] -> <:str_item< >>
 112   | x :: xs ->
 113       List.fold_left (fun xs x -> <:str_item< $xs$ $x$ >>) x xs
 114
 115 let concat_sig_items _loc items =
 116   match items with
 117   | [] -> <:sig_item< >>
 118   | x :: xs ->
 119       List.fold_left (fun xs x -> <:sig_item< $xs$ $x$ >>) x xs
 120
 121 let concat_record_fields _loc fields =
 122   match fields with
 123     | [] -> assert false
 124     | f :: fs ->
 125         List.fold_left (fun fs f -> <:ctyp< $fs$ ; $f$ >>) f fs
 126
 127 let concat_record_bindings _loc rbs =
 128   match rbs with
 129     | [] -> assert false
 130     | rb :: rbs ->
 131         List.fold_left (fun rbs rb -> <:rec_binding< $rbs$ ; $rb$ >>) rb rbs
 132
 133 let build_record _loc rbs =
 134   Ast.ExRec (_loc, rbs, Ast.ExNil _loc)
 135
 136 let build_tuple_from_exprs _loc exprs =
 137   match exprs with
 138   | [] | [_] -> assert false
 139   | x :: xs ->
 140       Ast.ExTup (_loc,
 141                  List.fold_left (fun xs x -> Ast.ExCom (_loc, x, xs)) x xs)
 142
 143 let () =
 144   let args = Array.to_list Sys.argv in
 145
 146   let kernelsdir, outputdir =
 147     match args with
 148     | [_;kd;od] -> kd,od
 149     | _ ->
 150         let arg0 = Filename.basename Sys.executable_name in
 151         eprintf "%s - Turn kernels database into code modules.
 152
 153 Usage:
 154   %s <kernelsdir> <outputdir>
 155
 156 Example (from toplevel of virt-mem source tree):
 157   %s kernels/ lib/
 158 " arg0 arg0 arg0;
 159         exit 2 in
 160
 161   (* Get the *.info files from the kernels database. *)
 162   let infos = Sys.readdir kernelsdir in
 163   let infos = Array.to_list infos in
 164   let infos = List.filter (fun name -> String.ends_with name ".info") infos in
 165   let infos = List.map ( (//) kernelsdir) infos in
 166
 167   (* Regular expressions.  We really really should use ocaml-mikmatch ... *)
 168   let re_oldformat = Pcre.regexp "^RPM: \\d+: \\(build \\d+\\) ([-\\w]+) ([\\w.]+) ([\\w.]+) \\(.*?\\) (\\w+)" in
 169   let re_keyvalue = Pcre.regexp "^(\\w+): (.*)" in
 170
 171   (* Parse in the *.info files.  These have historically had a few different
 172    * formats that we need to support.
 173    *)
 174   let infos = List.map (
 175     fun filename ->
 176       (* Get the basename (for getting the .data file later on). *)
 177       let basename = Filename.chop_suffix filename ".info" in
 178
 179       let chan = open_in filename in
 180       let line = input_line chan in
 181
 182       (* Kernel version string. *)
 183       let version, arch =
 184         if Pcre.pmatch ~rex:re_oldformat line then (
 185           (* If the file starts with "RPM: \d+: ..." then it's the
 186            * original Fedora format.  Everything in one line.
 187            *)
 188           let subs = Pcre.exec ~rex:re_oldformat line in
 189           (* let name = Pcre.get_substring subs 1 in *)
 190           let version = Pcre.get_substring subs 2 in
 191           let release = Pcre.get_substring subs 3 in
 192           let arch = Pcre.get_substring subs 4 in
 193           close_in chan;
 194           (* XXX Map name -> PAE, hugemem etc. *)
 195           (* name, *) sprintf "%s-%s.%s" version release arch, arch
 196         ) else (
 197           (* New-style "key: value" entries, up to end of file or the first
 198            * blank line.
 199            *)
 200           let (*name,*) version, release, arch =
 201             (*ref "",*) ref "", ref "", ref "" in
 202           let rec loop line =
 203             try
 204               let subs = Pcre.exec ~rex:re_keyvalue line in
 205               let key = Pcre.get_substring subs 1 in
 206               let value = Pcre.get_substring subs 2 in
 207               (*if key = "Name" then name := value
 208               else*) if key = "Version" then version := value
 209               else if key = "Release" then release := value
 210               else if key = "Architecture" then arch := value;
 211               let line = input_line chan in
 212               loop line
 213             with
 214               Not_found | End_of_file ->
 215                 close_in chan
 216           in
 217           loop line;
 218           let (*name,*) version, release, arch =
 219             (*!name,*) !version, !release, !arch in
 220           if (*name = "" ||*) version = "" || release = "" || arch = "" then
 221             failwith (sprintf "%s: missing Name, Version, Release or Architecture key" filename);
 222           (* XXX Map name -> PAE, hugemem etc. *)
 223           (* name, *) sprintf "%s-%s.%s" version release arch, arch
 224         ) in
 225
 226       (*printf "%s -> %s %s\n%!" basename version arch;*)
 227
 228       (basename, version, arch)
 229   ) infos in
 230
 231   let nr_kernels = List.length infos in
 232
 233   (* For quick access to the opener strings, build a hash. *)
 234   let openers = Hashtbl.create 13 in
 235   List.iter (
 236     fun (name, { opener = opener; closer = closer }) ->
 237       Hashtbl.add openers opener (closer, name)
 238   ) structs;
 239
 240   (* Now read the data files and parse out the structures of interest. *)
 241   let kernels = List.mapi (
 242     fun i (basename, version, arch) ->
 243       printf "Loading kernel data file %d/%d\r%!" (i+1) nr_kernels;
 244
 245       let file_exists name =
 246         try Unix.access name [Unix.F_OK]; true
 247         with Unix.Unix_error _ -> false
 248       in
 249       let close_process_in cmd chan =
 250         match Unix.close_process_in chan with
 251         | Unix.WEXITED 0 -> ()
 252         | Unix.WEXITED i ->
 253             eprintf "%s: command exited with code %d\n" cmd i; exit i
 254         | Unix.WSIGNALED i ->
 255             eprintf "%s: command exited with signal %d\n" cmd i; exit 1
 256         | Unix.WSTOPPED i ->
 257             eprintf "%s: command stopped by signal %d\n" cmd i; exit 1
 258       in
 259
 260       (* Open the data file, uncompressing it on the fly if necessary. *)
 261       let chan, close =
 262         if file_exists (basename ^ ".data") then
 263           open_in (basename ^ ".data"), close_in
 264         else if file_exists (basename ^ ".data.gz") then (
 265           let cmd =
 266             sprintf "gzip -cd %s" (Filename.quote (basename ^ ".data.gz")) in
 267           Unix.open_process_in cmd, close_process_in cmd
 268         )
 269         else if file_exists (basename ^ ".data.bz2") then (
 270           let cmd =
 271             sprintf "bzip2 -cd %s" (Filename.quote (basename ^ ".data.bz2")) in
 272           Unix.open_process_in cmd, close_process_in cmd
 273         ) else
 274           failwith
 275             (sprintf "%s: cannot find corresponding data file" basename) in
 276
 277       (* Read the data file in, looking for structures of interest to us. *)
 278       let bodies = Hashtbl.create 13 in
 279       let rec loop () =
 280         let line = input_line chan in
 281
 282         (* If the line is an opener for one of the structures we
 283          * are looking for, then for now just save all the text until
 284          * we get to the closer line.
 285          *)
 286         (try
 287            let closer, name = Hashtbl.find openers line in
 288            let rec loop2 lines =
 289              let line = input_line chan in
 290              let lines = line :: lines in
 291              if String.starts_with line closer then List.rev lines
 292              else loop2 lines
 293            in
 294
 295            let body =
 296              try loop2 [line]
 297              with End_of_file ->
 298                failwith (sprintf "%s: %s: %S not matched by closing %S" basename name line closer) in
 299
 300            Hashtbl.replace bodies name body
 301          with Not_found -> ());
 302
 303         loop ()
 304       in
 305       (try loop () with End_of_file -> ());
 306
 307       close chan;
 308
 309       (* Make sure we got all the mandatory structures. *)
 310       List.iter (
 311          fun (name, { mandatory_struct = mandatory }) ->
 312            if mandatory && not (Hashtbl.mem bodies name) then
 313              failwith (sprintf "%s: structure %s not found in this kernel" basename name)
 314       ) structs;
 315
 316       (basename, version, arch, bodies)
 317   ) infos in
 318
 319   (* Now parse each structure body.
 320    * XXX This would be better as a proper lex/yacc parser.
 321    * XXX Even better would be to have a proper interface to libdwarves.
 322    *)
 323   let re_offsetsize = Pcre.regexp "/\\*\\s+(\\d+)\\s+(\\d+)\\s+\\*/" in
 324   let re_intfield = Pcre.regexp "int\\s+(\\w+);" in
 325   let re_ptrfield = Pcre.regexp "struct\\s+(\\w+)\\s*\\*\\s*(\\w+);" in
 326   let re_strfield = Pcre.regexp "char\\s+(\\w+)\\[(\\d+)\\];" in
 327   let re_structopener = Pcre.regexp "(struct|union)\\s+.*{$" in
 328   let re_structcloser = Pcre.regexp "}\\s*(\\w+)?(\\[\\d+\\])?;" in
 329
 330   (* 'basename' is the source file, and second parameter ('body') is
 331    * the list of text lines which covers this structure (minus the
 332    * opener line).  Result is the list of parsed fields from this
 333    * structure.
 334    *)
 335   let rec parse basename = function
 336     | [] -> assert false
 337     | [_] -> []                  (* Just the closer line, finished. *)
 338     | line :: lines when Pcre.pmatch ~rex:re_structopener line ->
 339       (* Recursively parse a sub-structure.  First search for the
 340        * corresponding closer line.
 341        *)
 342       let rec loop depth acc = function
 343         | [] ->
 344             eprintf "%s: %S has no matching close structure line\n%!"
 345               basename line;
 346             assert false
 347         | line :: lines when Pcre.pmatch ~rex:re_structopener line ->
 348           loop (depth+1) (line :: acc) lines
 349         | line :: lines
 350             when depth = 0 && Pcre.pmatch ~rex:re_structcloser line ->
 351           (line :: acc), lines
 352         | line :: lines
 353             when depth > 0 && Pcre.pmatch ~rex:re_structcloser line ->
 354           loop (depth-1) (line :: acc) lines
 355         | line :: lines -> loop depth (line :: acc) lines
 356       in
 357       let nested_body, rest = loop 0 [] lines in
 358
 359       (* Then parse the sub-structure. *)
 360       let struct_name, nested_body =
 361         match nested_body with
 362         | [] -> assert false
 363         | closer :: _ ->
 364             let subs = Pcre.exec ~rex:re_structcloser closer in
 365             let struct_name =
 366               try Some (Pcre.get_substring subs 1) with Not_found -> None in
 367             struct_name, List.rev nested_body in
 368       let nested_fields = parse basename nested_body in
 369
 370       (* Prefix the sub-fields with the name of the structure. *)
 371       let nested_fields =
 372         match struct_name with
 373         | None -> nested_fields
 374         | Some prefix ->
 375             List.map (
 376               fun (name, details) -> (prefix ^ "'" ^ name, details)
 377             ) nested_fields in
 378
 379       (* Parse the rest. *)
 380       nested_fields @ parse basename rest
 381
 382     | line :: lines when Pcre.pmatch ~rex:re_intfield line ->
 383       (* An int field. *)
 384       let subs = Pcre.exec ~rex:re_intfield line in
 385       let name = Pcre.get_substring subs 1 in
 386       (try
 387          let subs = Pcre.exec ~rex:re_offsetsize line in
 388          let offset = int_of_string (Pcre.get_substring subs 1) in
 389          let size = int_of_string (Pcre.get_substring subs 2) in
 390          (name, (`Int, offset, size)) :: parse basename lines
 391        with
 392          Not_found -> parse basename lines
 393       );
 394
 395     | line :: lines when Pcre.pmatch ~rex:re_ptrfield line ->
 396       (* A pointer-to-struct field. *)
 397       let subs = Pcre.exec ~rex:re_ptrfield line in
 398       let struct_name = Pcre.get_substring subs 1 in
 399       let name = Pcre.get_substring subs 2 in
 400       (try
 401          let subs = Pcre.exec ~rex:re_offsetsize line in
 402          let offset = int_of_string (Pcre.get_substring subs 1) in
 403          let size = int_of_string (Pcre.get_substring subs 2) in
 404          (name, (`Ptr struct_name, offset, size))
 405            :: parse basename lines
 406        with
 407          Not_found -> parse basename lines
 408       );
 409
 410     | line :: lines when Pcre.pmatch ~rex:re_strfield line ->
 411       (* A string (char array) field. *)
 412       let subs = Pcre.exec ~rex:re_strfield line in
 413       let name = Pcre.get_substring subs 1 in
 414       let width = int_of_string (Pcre.get_substring subs 2) in
 415       (try
 416          let subs = Pcre.exec ~rex:re_offsetsize line in
 417          let offset = int_of_string (Pcre.get_substring subs 1) in
 418          let size = int_of_string (Pcre.get_substring subs 2) in
 419          (name, (`Str width, offset, size))
 420            :: parse basename lines
 421        with
 422          Not_found -> parse basename lines
 423       );
 424
 425     | _ :: lines ->
 426         (* Just ignore any other field we can't parse. *)
 427         parse basename lines
 428
 429   in
 430
 431   let kernels = List.map (
 432     fun (basename, version, arch, bodies) ->
 433       let structures = List.filter_map (
 434         fun (struct_name, { fields = wanted_fields }) ->
 435           let body =
 436             try Some (Hashtbl.find bodies struct_name)
 437             with Not_found -> None in
 438           match body with
 439           | None -> None
 440           | Some body ->
 441               let body = List.tl body in (* Don't care about opener line. *)
 442               let fields = parse basename body in
 443
 444               (* Compute total size of the structure. *)
 445               let total_size =
 446                 let fields = List.map (
 447                   fun (_, (_, offset, size)) -> offset + size
 448                 ) fields in
 449                 List.fold_left max 0 fields in
 450
 451               (* That got us all the fields, but we only care about
 452                * the wanted_fields.
 453                *)
 454               let fields = List.filter (
 455                 fun (name, _) -> List.mem_assoc name wanted_fields
 456               ) fields in
 457
 458               (* Also check we have all the mandatory fields. *)
 459               List.iter (
 460                 fun (wanted_field, { mandatory_field = mandatory }) ->
 461                   if mandatory && not (List.mem_assoc wanted_field fields) then
 462                     failwith (sprintf "%s: structure %s is missing required field %s" basename struct_name wanted_field)
 463               ) wanted_fields;
 464
 465               (* Prefix all the field names with the structure name. *)
 466               let fields =
 467                 List.map (fun (name, details) ->
 468                             struct_name ^ "_" ^ name, details) fields in
 469
 470               Some (struct_name, (fields, total_size))
 471       ) structs in
 472
 473       (basename, version, arch, structures)
 474   ) kernels in
 475
 476   if debug then
 477     List.iter (
 478       fun (basename, version, arch, structures) ->
 479         printf "%s (version: %s, arch: %s):\n" basename version arch;
 480         List.iter (
 481           fun (struct_name, (fields, total_size)) ->
 482             printf "  struct %s {\n" struct_name;
 483             List.iter (
 484               fun (field_name, (typ, offset, size)) ->
 485                 (match typ with
 486                  | `Int ->
 487                      printf "    int %s; " field_name
 488                  | `Ptr struct_name ->
 489                      printf "    struct %s *%s; " struct_name field_name
 490                  | `Str width ->
 491                      printf "    char %s[%d]; " field_name width
 492                 );
 493                 printf " /* offset = %d, size = %d */\n" offset size
 494             ) fields;
 495             printf "  } /* %d bytes */\n\n" total_size;
 496         ) structures;
 497     ) kernels;
 498
 499   (* First output file is a simple list of kernels, to support the
 500    * 'virt-mem --list-kernels' option.
 501    *)
 502   let () =
 503     let _loc = Loc.ghost in
 504
 505     let versions = List.map (fun (_, version, _, _) -> version) kernels in
 506
 507     (* Sort them in reverse because we are going to generate the
 508      * final list in reverse.
 509      *)
 510     let cmp a b = compare b a in
 511     let versions = List.sort ~cmp versions in
 512
 513     let xs =
 514       List.fold_left (fun xs version -> <:expr< $str:version$ :: $xs$ >>)
 515       <:expr< [] >> versions in
 516
 517     let code = <:str_item<
 518       let kernels = $xs$
 519     >> in
 520
 521     let output_file = outputdir // "virt_mem_kernels.ml" in
 522     printf "Writing list of kernels to %s ...\n%!" output_file;
 523     Printers.OCaml.print_implem ~output_file code in
 524
 525   (* We'll generate a code file for each structure type (eg. task_struct
 526    * across all kernel versions), so rearrange 'kernels' for that purpose.
 527    *
 528    * XXX This loop is O(n^3), luckily n is small!
 529    *)
 530   let files =
 531     List.map (
 532       fun (name, _) ->
 533         let kernels =
 534           List.filter_map (
 535             fun (basename, version, arch, structures) ->
 536               try Some (basename, version, arch, List.assoc name structures)
 537               with Not_found -> None
 538           ) kernels in
 539
 540         (* Sort the kernels, which makes the generated output more stable
 541          * and makes patches more useful.
 542          *)
 543         let kernels = List.sort kernels in
 544
 545         name, kernels
 546     ) structs in
 547
 548   let kernels = () in ignore kernels; (* garbage collect *)
 549
 550   (* Get just the field types.
 551    *
 552    * It's plausible that a field with the same name has a different
 553    * type between kernel versions, so we must check that didn't
 554    * happen.
 555    *
 556    * This is complicated because of non-mandatory fields, which don't
 557    * appear in every kernel version.
 558    *)
 559   let files = List.map (
 560     fun (struct_name, kernels) ->
 561       let field_types =
 562         (* Get the list of fields expected in this structure. *)
 563         let { fields = struct_fields } = List.assoc struct_name structs in
 564
 565         (* Get the list of fields that we found in each kernel version. *)
 566         let found_fields =
 567           List.flatten
 568             (List.map (fun (_, _, _, (fields, _)) -> fields) kernels) in
 569
 570         (* Determine a hash from each field name to the type.  As we add
 571          * fields, we might get a conflicting type (meaning the type
 572          * changed between kernel versions).
 573          *)
 574         let hash = Hashtbl.create 13 in
 575
 576         List.iter (
 577           fun (field_name, (typ, _, _)) ->
 578             try
 579               let field_type = Hashtbl.find hash field_name in
 580               if typ <> field_type then
 581                 failwith (sprintf "%s.%s: structure field changed type between kernel versions" struct_name field_name);
 582             with Not_found ->
 583               Hashtbl.add hash field_name typ
 584         ) found_fields;
 585
 586         (* Now get a type for each structure field. *)
 587         List.filter_map (
 588           fun (field_name, { mandatory_field = mandatory }) ->
 589             try
 590               let field_name = struct_name ^ "_" ^ field_name in
 591               let typ = Hashtbl.find hash field_name in
 592               Some (field_name, (typ, mandatory))
 593             with Not_found ->
 594               let msg =
 595                 sprintf "%s.%s: this field was not found in any kernel version"
 596                   struct_name field_name in
 597               if mandatory then failwith msg else prerr_endline msg;
 598               None
 599         ) struct_fields in
 600       (struct_name, kernels, field_types)
 601   ) files in
 602
 603   (* To minimize generated code size, we want to fold together all
 604    * structures where the particulars (eg. offsets, sizes, endianness)
 605    * of the fields we care about are the same -- eg. between kernel
 606    * versions which are very similar.
 607    *)
 608   let endian_of_architecture arch =
 609     if String.starts_with arch "i386" ||
 610       String.starts_with arch "i486" ||
 611       String.starts_with arch "i586" ||
 612       String.starts_with arch "i686" ||
 613       String.starts_with arch "x86_64" ||
 614       String.starts_with arch "x86-64" then
 615         Bitstring.LittleEndian
 616     else if String.starts_with arch "ia64" then
 617       Bitstring.LittleEndian (* XXX usually? *)
 618     else if String.starts_with arch "ppc" then
 619       Bitstring.BigEndian
 620     else if String.starts_with arch "sparc" then
 621       Bitstring.BigEndian
 622     else
 623       failwith (sprintf "endian_of_architecture: cannot parse %S" arch)
 624   in
 625
 626   let files =
 627     List.map (
 628       fun (struct_name, kernels, field_types) ->
 629         let hash = Hashtbl.create 13 in
 630         let i = ref 0 in
 631         let xs = ref [] in
 632         let kernels =
 633           List.map (
 634             fun (basename, version, arch, (fields, total_size)) ->
 635               let key = endian_of_architecture arch, fields in
 636               let j =
 637                 try Hashtbl.find hash key
 638                 with Not_found ->
 639                   incr i;
 640                   xs := (!i, key) :: !xs; Hashtbl.add hash key !i;
 641                   !i in
 642               (basename, version, arch, total_size, j)
 643           ) kernels in
 644         let parsers = List.rev !xs in
 645         struct_name, kernels, field_types, parsers
 646     ) files in
 647
 648   (* How much did we save by sharing? *)
 649   if debug then
 650     List.iter (
 651       fun (struct_name, kernels, _, parsers) ->
 652         printf "struct %s:\n" struct_name;
 653         printf "  number of kernel versions: %d\n" (List.length kernels);
 654         printf "  number of parser functions needed after sharing: %d\n"
 655           (List.length parsers)
 656     ) files;
 657
 658   (* Extend the parsers fields by adding on any optional fields which
 659    * are not actually present in the specific kernel.
 660    *)
 661   let files =
 662     List.map (
 663       fun (struct_name, kernels, field_types, parsers) ->
 664         let parsers = List.map (
 665           fun (i, (endian, fields)) ->
 666             let fields_not_present =
 667               List.filter_map (
 668                 fun (field_name, _) ->
 669                   if List.mem_assoc field_name fields then None
 670                   else Some field_name
 671               ) field_types in
 672             (i, (endian, fields, fields_not_present))
 673         ) parsers in
 674         (struct_name, kernels, field_types, parsers)
 675     ) files in
 676
 677   (* Let's generate some code! *)
 678   let files =
 679     List.map (
 680       fun (struct_name, kernels, field_types, parsers) ->
 681         (* Dummy location required - there are no real locations for
 682          * output files.
 683          *)
 684         let _loc = Loc.ghost in
 685
 686         (* The structure type. *)
 687         let struct_type, struct_sig =
 688           let fields = List.map (
 689             function
 690             | (name, (`Int, true)) ->
 691                 <:ctyp< $lid:name$ : int64 >>
 692             | (name, (`Int, false)) ->
 693                 <:ctyp< $lid:name$ : int64 option >>
 694             | (name, (`Ptr _, true)) ->
 695                 <:ctyp< $lid:name$ : Virt_mem_mmap.addr >>
 696             | (name, (`Ptr _, false)) ->
 697                 <:ctyp< $lid:name$ : Virt_mem_mmap.addr option >>
 698             | (name, (`Str _, true)) ->
 699                 <:ctyp< $lid:name$ : string >>
 700             | (name, (`Str _, false)) ->
 701                 <:ctyp< $lid:name$ : string option >>
 702           ) field_types in
 703           let fields = concat_record_fields _loc fields in
 704           let struct_type = <:str_item< type t = { $fields$ } >> in
 705           let struct_sig = <:sig_item< type t = { $fields$ } >> in
 706           struct_type, struct_sig in
 707
 708         (* Create a "field signature" which describes certain aspects
 709          * of the fields which vary between kernel versions.
 710          *)
 711         let fieldsig_type, fieldsigs =
 712           let fieldsig_type =
 713             let fields = List.map (
 714               fun (name, _) ->
 715                 let fsname = "__fs_" ^ name in
 716                 <:ctyp< $lid:fsname$ : Virt_mem_types.fieldsig >>
 717             ) field_types in
 718             let fields = concat_record_fields _loc fields in
 719             <:str_item< type fs_t = { $fields$ } >> in
 720
 721           let fieldsigs = List.map (
 722             fun (i, (_, fields, fields_not_present)) ->
 723               let make_fieldsig field_name available offset =
 724                 let available =
 725                   if available then <:expr< true >> else <:expr< false >> in
 726                 let fsname = "__fs_" ^ field_name in
 727                 <:rec_binding<
 728                   $lid:fsname$ =
 729                       { Virt_mem_types.field_available = $available$;
 730                         field_offset = $`int:offset$ }
 731                 >>
 732               in
 733               let fields = List.map (
 734                 fun (field_name, (_, offset, _)) ->
 735                   make_fieldsig field_name true offset
 736               ) fields in
 737               let fields_not_present = List.map (
 738                 fun field_name ->
 739                   make_fieldsig field_name false (-1)
 740               ) fields_not_present in
 741
 742               let fieldsigs = fields @ fields_not_present in
 743               let fsname = sprintf "fieldsig_%d" i in
 744               let fieldsigs = concat_record_bindings _loc fieldsigs in
 745               let fieldsigs = build_record _loc fieldsigs in
 746               <:str_item<
 747                 let $lid:fsname$ = $fieldsigs$
 748               >>
 749           ) parsers in
 750
 751           let fieldsigs = concat_str_items _loc fieldsigs in
 752
 753           fieldsig_type, fieldsigs in
 754
 755         (* The shared parser functions.
 756          *
 757          * We could include bitmatch statements directly in here, but
 758          * what happens is that the macros get expanded here, resulting
 759          * in (even more) unreadable generated code.  So instead just
 760          * do a textual substitution later by post-processing the
 761          * generated files.  Not type-safe, but we can't have
 762          * everything.
 763          *)
 764         let parser_stmts, parser_subs =
 765           let parser_stmts = List.map (
 766             fun (i, _) ->
 767               let fnname = sprintf "parser_%d" i in
 768               <:str_item<
 769                 let $lid:fnname$ bits = $str:fnname$
 770               >>
 771           ) parsers in
 772
 773           let parser_stmts = concat_str_items _loc parser_stmts in
 774
 775           (* What gets substituted for "parser_NN" ... *)
 776           let parser_subs = List.map (
 777             fun (i, (endian, fields, fields_not_present)) ->
 778               let fnname = sprintf "parser_%d" i in
 779               let endian =
 780                 match endian with
 781                 | Bitstring.LittleEndian -> "littleendian"
 782                 | Bitstring.BigEndian -> "bigendian"
 783                 | _ -> assert false in
 784               let patterns =
 785                 (* Fields must be sorted by offset, otherwise bitmatch
 786                  * will complain.
 787                  *)
 788                 let cmp (_, (_, o1, _)) (_, (_, o2, _)) = compare o1 o2 in
 789                 let fields = List.sort ~cmp fields in
 790                 String.concat ";\n      " (
 791                   List.map (
 792                     function
 793                     | (field_name, (`Int, offset, size))
 794                     | (field_name, (`Ptr _, offset, size)) ->
 795                         (* 'zero+' is a hack to force the type to int64. *)
 796                         sprintf "%s : zero+%d : offset(%d), %s"
 797                           field_name (size*8) (offset*8) endian
 798                     | (field_name, (`Str width, offset, size)) ->
 799                         sprintf "%s : %d : offset(%d), string"
 800                           field_name (width*8) (offset*8)
 801                   ) fields
 802                 ) in
 803               let assignments =
 804                 List.map (
 805                   fun (field_name, typ) ->
 806                     let (_, mandatory) =
 807                       try List.assoc field_name field_types
 808                       with Not_found ->
 809                         failwith (sprintf "%s: not found in field_types"
 810                                     field_name) in
 811                     match typ, mandatory with
 812                     | (`Ptr "list_head", offset, size), true ->
 813                         sprintf "%s = Int64.sub %s %dL"
 814                           field_name field_name offset
 815                     | (`Ptr "list_head", offset, size), false ->
 816                         sprintf "%s = Some (Int64.sub %s %dL)"
 817                           field_name field_name offset
 818                     | _, true ->
 819                         sprintf "%s = %s" field_name field_name
 820                     | _, false ->
 821                         sprintf "%s = Some %s" field_name field_name
 822                 ) fields in
 823               let assignments_not_present =
 824                 List.map (
 825                   fun field_name -> sprintf "%s = None" field_name
 826                 ) fields_not_present in
 827
 828               let assignments =
 829                 String.concat ";\n        "
 830                   (assignments @ assignments_not_present) in
 831
 832               let sub =
 833                 sprintf "
 834   bitmatch bits with
 835   | { %s } ->
 836       { %s }
 837   | { _ } ->
 838       raise (Virt_mem_types.ParseError (struct_name, %S, match_err))"
 839                   patterns assignments fnname in
 840
 841               fnname, sub
 842           ) parsers in
 843
 844           parser_stmts, parser_subs in
 845
 846         (* Define a map from kernel versions to parsing functions. *)
 847         let version_map =
 848           let stmts = List.fold_left (
 849             fun stmts (_, version, arch, total_size, i) ->
 850               let parserfn = sprintf "parser_%d" i in
 851               let fsname = sprintf "fieldsig_%d" i in
 852               <:str_item<
 853                 $stmts$
 854                 let v = ($lid:parserfn$, $`int:total_size$, $lid:fsname$)
 855                 let map = StringMap.add $str:version$ v map
 856               >>
 857           ) <:str_item< let map = StringMap.empty >> kernels in
 858
 859           <:str_item<
 860             module StringMap = Map.Make (String) ;;
 861             $stmts$
 862           >> in
 863
 864         (* Accessors for the field signatures. *)
 865         let fsaccess, fsaccess_sig =
 866           let fields = List.map (
 867             fun (field_name, _) ->
 868               let fsname = "__fs_" ^ field_name in
 869               <:str_item<
 870                 let $lid:"field_signature_of_"^field_name$ version =
 871                   let _, _, fs = StringMap.find version map in
 872                   fs.$lid:fsname$
 873               >>
 874           ) field_types in
 875
 876           let fsaccess = concat_str_items _loc fields in
 877
 878           let fields = List.map (
 879             fun (field_name, _) ->
 880               <:sig_item<
 881                 val $lid:"field_signature_of_"^field_name$ : kernel_version ->
 882                   Virt_mem_types.fieldsig
 883               >>
 884           ) field_types in
 885
 886           let fsaccess_sig = concat_sig_items _loc fields in
 887
 888           fsaccess, fsaccess_sig in
 889
 890         (* Code (.ml file). *)
 891         let code = <:str_item<
 892           let zero = 0
 893           let struct_name = $str:struct_name$
 894           let match_err = "failed to match kernel structure" ;;
 895           $struct_type$
 896           $fieldsig_type$
 897           $fieldsigs$
 898           $parser_stmts$
 899           $version_map$
 900
 901           type kernel_version = string
 902           let $lid:struct_name^"_known"$ version = StringMap.mem version map
 903           let $lid:struct_name^"_size"$ version =
 904             let _, size, _ = StringMap.find version map in
 905             size
 906           let $lid:struct_name^"_of_bits"$ version bits =
 907             let parsefn, _, _ = StringMap.find version map in
 908             parsefn bits
 909           let $lid:"get_"^struct_name$ version mem addr =
 910             let parsefn, size, _ = StringMap.find version map in
 911             let bytes = Virt_mem_mmap.get_bytes mem addr size in
 912             let bits = Bitstring.bitstring_of_string bytes in
 913             parsefn bits ;;
 914           $fsaccess$
 915         >> in
 916
 917         (* Interface (.mli file). *)
 918         let interface = <:sig_item<
 919           $struct_sig$
 920
 921           val struct_name : string
 922           type kernel_version = string
 923           val $lid:struct_name^"_known"$ : kernel_version -> bool
 924           val $lid:struct_name^"_size"$ : kernel_version -> int
 925           val $lid:struct_name^"_of_bits"$ :
 926             kernel_version -> Bitstring.bitstring -> t
 927           val $lid:"get_"^struct_name$ : kernel_version ->
 928             ('a, 'b, [`HasMapping]) Virt_mem_mmap.t -> Virt_mem_mmap.addr -> t;;
 929           $fsaccess_sig$
 930         >> in
 931
 932         (struct_name, code, interface, parser_subs)
 933     ) files in
 934
 935   (* Finally generate the output files. *)
 936   let re_subst = Pcre.regexp "^(.*)\"(parser_\\d+)\"(.*)$" in
 937
 938   List.iter (
 939     fun (struct_name, code, interface, parser_subs) ->
 940       (* Interface (.mli file). *)
 941       let output_file = outputdir // "kernel_" ^ struct_name ^ ".mli" in
 942       printf "Writing %s interface to %s ...\n%!" struct_name output_file;
 943       Printers.OCaml.print_interf ~output_file interface;
 944
 945       (* Implementation (.ml file). *)
 946       let output_file = outputdir // "kernel_" ^ struct_name ^ ".ml" in
 947       printf "Writing %s implementation to %s ...\n%!" struct_name output_file;
 948
 949       let new_output_file = output_file ^ ".new" in
 950       Printers.OCaml.print_implem ~output_file:new_output_file code;
 951
 952       (* Substitute the parser bodies in the output file. *)
 953       let ichan = open_in new_output_file in
 954       let ochan = open_out output_file in
 955
 956       output_string ochan "\
 957 (* WARNING: This file and the corresponding mli (interface) are
 958  * automatically generated by the extract/codegen/kerneldb_to_parser.ml
 959  * program.
 960  *
 961  * Any edits you make to this file will be lost.
 962  *
 963  * To update this file from the latest kernel database, it is recommended
 964  * that you do 'make update-kernel-structs'.
 965  *)\n\n";
 966
 967       let rec loop () =
 968         let line = input_line ichan in
 969         let line =
 970           if Pcre.pmatch ~rex:re_subst line then (
 971             let subs = Pcre.exec ~rex:re_subst line in
 972             let start = Pcre.get_substring subs 1 in
 973             let template = Pcre.get_substring subs 2 in
 974             let rest = Pcre.get_substring subs 3 in
 975             let sub = List.assoc template parser_subs in
 976             start ^ sub ^ rest
 977           ) else line in
 978         output_string ochan line; output_char ochan '\n';
 979         loop ()
 980       in
 981       (try loop () with End_of_file -> ());
 982
 983       close_out ochan;
 984       close_in ichan;
 985
 986       Unix.unlink new_output_file
 987   ) files