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"; "mm"; "active_mm"; "comm"; "pid" ]
  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 = false
  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   let nr_kernels = List.length infos in
 150
 151   (* For quick access to the opener strings, build a hash. *)
 152   let openers = Hashtbl.create 13 in
 153   List.iter (
 154     fun (name, (opener, closer, _, _)) ->
 155       Hashtbl.add openers opener (closer, name)
 156   ) what;
 157
 158   (* Now read the data files and parse out the structures of interest. *)
 159   let kernels = List.mapi (
 160     fun i (basename, version, arch) ->
 161       printf "Loading kernel data file %d/%d\r%!" (i+1) nr_kernels;
 162
 163       let file_exists name =
 164         try Unix.access name [Unix.F_OK]; true
 165         with Unix.Unix_error _ -> false
 166       in
 167       let close_process_in cmd chan =
 168         match Unix.close_process_in chan with
 169         | Unix.WEXITED 0 -> ()
 170         | Unix.WEXITED i ->
 171             eprintf "%s: command exited with code %d\n" cmd i; exit i
 172         | Unix.WSIGNALED i ->
 173             eprintf "%s: command exited with signal %d\n" cmd i; exit 1
 174         | Unix.WSTOPPED i ->
 175             eprintf "%s: command stopped by signal %d\n" cmd i; exit 1
 176       in
 177
 178       (* Open the data file, uncompressing it on the fly if necessary. *)
 179       let chan, close =
 180         if file_exists (basename ^ ".data") then
 181           open_in (basename ^ ".data"), close_in
 182         else if file_exists (basename ^ ".data.gz") then (
 183           let cmd =
 184             sprintf "gzip -cd %s" (Filename.quote (basename ^ ".data.gz")) in
 185           Unix.open_process_in cmd, close_process_in cmd
 186         )
 187         else if file_exists (basename ^ ".data.bz2") then (
 188           let cmd =
 189             sprintf "bzip2 -cd %s" (Filename.quote (basename ^ ".data.bz2")) in
 190           Unix.open_process_in cmd, close_process_in cmd
 191         ) else
 192           failwith
 193             (sprintf "%s: cannot find corresponding data file" basename) in
 194
 195       (* Read the data file in, looking for structures of interest to us. *)
 196       let bodies = Hashtbl.create 13 in
 197       let rec loop () =
 198         let line = input_line chan in
 199
 200         (* If the line is an opener for one of the structures we
 201          * are looking for, then for now just save all the text until
 202          * we get to the closer line.
 203          *)
 204         (try
 205            let closer, name = Hashtbl.find openers line in
 206            let rec loop2 lines =
 207              let line = input_line chan in
 208              let lines = line :: lines in
 209              if String.starts_with line closer then List.rev lines
 210              else loop2 lines
 211            in
 212
 213            let body =
 214              try loop2 [line]
 215              with End_of_file ->
 216                failwith (sprintf "%s: %s: %S not matched by closing %S" basename name line closer) in
 217
 218            Hashtbl.replace bodies name body
 219          with Not_found -> ());
 220
 221         loop ()
 222       in
 223       (try loop () with End_of_file -> ());
 224
 225       close chan;
 226
 227       (* Make sure we got all the mandatory structures. *)
 228       List.iter (
 229          fun (name, (_, _, mandatory, _)) ->
 230            if mandatory && not (Hashtbl.mem bodies name) then
 231              failwith (sprintf "%s: structure %s not found in this kernel" basename name)
 232       ) what;
 233
 234       (basename, version, arch, bodies)
 235   ) infos in
 236
 237   (* Now parse each structure body.
 238    * XXX This would be better as a proper lex/yacc parser.
 239    * XXX Even better would be to have a proper interface to libdwarves.
 240    *)
 241   let re_offsetsize = Pcre.regexp "/\\*\\s+(\\d+)\\s+(\\d+)\\s+\\*/" in
 242   let re_intfield = Pcre.regexp "int\\s+(\\w+);" in
 243   let re_ptrfield = Pcre.regexp "struct\\s+(\\w+)\\s*\\*\\s*(\\w+);" in
 244   let re_strfield = Pcre.regexp "char\\s+(\\w+)\\[(\\d+)\\];" in
 245   let re_structopener = Pcre.regexp "(struct|union)\\s+.*{$" in
 246   let re_structcloser = Pcre.regexp "}\\s*(\\w+)?(\\[\\d+\\])?;" in
 247
 248   (* 'basename' is the source file, and second parameter ('body') is
 249    * the list of text lines which covers this structure (minus the
 250    * opener line).  Result is the list of parsed fields from this
 251    * structure.
 252    *)
 253   let rec parse basename = function
 254     | [] -> assert false
 255     | [_] -> []                  (* Just the closer line, finished. *)
 256     | line :: lines when Pcre.pmatch ~rex:re_structopener line ->
 257       (* Recursively parse a sub-structure.  First search for the
 258        * corresponding closer line.
 259        *)
 260       let rec loop depth acc = function
 261         | [] ->
 262             eprintf "%s: %S has no matching close structure line\n%!"
 263               basename line;
 264             assert false
 265         | line :: lines when Pcre.pmatch ~rex:re_structopener line ->
 266           loop (depth+1) (line :: acc) lines
 267         | line :: lines
 268             when depth = 0 && Pcre.pmatch ~rex:re_structcloser line ->
 269           (line :: acc), lines
 270         | line :: lines
 271             when depth > 0 && Pcre.pmatch ~rex:re_structcloser line ->
 272           loop (depth-1) (line :: acc) lines
 273         | line :: lines -> loop depth (line :: acc) lines
 274       in
 275       let nested_body, rest = loop 0 [] lines in
 276
 277       (* Then parse the sub-structure. *)
 278       let struct_name, nested_body =
 279         match nested_body with
 280         | [] -> assert false
 281         | closer :: _ ->
 282             let subs = Pcre.exec ~rex:re_structcloser closer in
 283             let struct_name =
 284               try Some (Pcre.get_substring subs 1) with Not_found -> None in
 285             struct_name, List.rev nested_body in
 286       let nested_fields = parse basename nested_body in
 287
 288       (* Prefix the sub-fields with the name of the structure. *)
 289       let nested_fields =
 290         match struct_name with
 291         | None -> nested_fields
 292         | Some prefix ->
 293             List.map (
 294               fun (name, details) -> (prefix ^ "'" ^ name, details)
 295             ) nested_fields in
 296
 297       (* Parse the rest. *)
 298       nested_fields @ parse basename rest
 299
 300     | line :: lines when Pcre.pmatch ~rex:re_intfield line ->
 301       (* An int field. *)
 302       let subs = Pcre.exec ~rex:re_intfield line in
 303       let name = Pcre.get_substring subs 1 in
 304       (try
 305          let subs = Pcre.exec ~rex:re_offsetsize line in
 306          let offset = int_of_string (Pcre.get_substring subs 1) in
 307          let size = int_of_string (Pcre.get_substring subs 2) in
 308          (name, (`Int, offset, size)) :: 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          (name, (`Ptr struct_name, offset, size))
 323            :: parse basename lines
 324        with
 325          Not_found -> parse basename lines
 326       );
 327
 328     | line :: lines when Pcre.pmatch ~rex:re_strfield line ->
 329       (* A string (char array) field. *)
 330       let subs = Pcre.exec ~rex:re_strfield line in
 331       let name = Pcre.get_substring subs 1 in
 332       let width = int_of_string (Pcre.get_substring subs 2) in
 333       (try
 334          let subs = Pcre.exec ~rex:re_offsetsize line in
 335          let offset = int_of_string (Pcre.get_substring subs 1) in
 336          let size = int_of_string (Pcre.get_substring subs 2) in
 337          (name, (`Str width, offset, size))
 338            :: parse basename lines
 339        with
 340          Not_found -> parse basename lines
 341       );
 342
 343     | _ :: lines ->
 344         (* Just ignore any other field we can't parse. *)
 345         parse basename lines
 346
 347   in
 348
 349   let kernels = List.map (
 350     fun (basename, version, arch, bodies) ->
 351       let structures = List.filter_map (
 352         fun (struct_name, (_, _, _, wanted_fields)) ->
 353           let body =
 354             try Some (Hashtbl.find bodies struct_name)
 355             with Not_found -> None in
 356           match body with
 357           | None -> None
 358           | Some body ->
 359               let body = List.tl body in (* Don't care about opener line. *)
 360               let fields = parse basename body in
 361
 362               (* Compute total size of the structure. *)
 363               let total_size =
 364                 let fields = List.map (
 365                   fun (_, (_, offset, size)) -> offset + size
 366                 ) fields in
 367                 List.fold_left max 0 fields in
 368
 369               (* That got us all the fields, but we only care about
 370                * the wanted_fields.
 371                *)
 372               let fields = List.filter (
 373                 fun (name, _) -> List.mem name wanted_fields
 374               ) fields in
 375
 376               (* Also check we have all the wanted fields. *)
 377               List.iter (
 378                 fun wanted_field ->
 379                   if not (List.mem_assoc wanted_field fields) then
 380                     failwith (sprintf "%s: structure %s is missing required field %s" basename struct_name wanted_field)
 381               ) wanted_fields;
 382
 383               (* Prefix all the field names with the structure name. *)
 384               let fields =
 385                 List.map (fun (name, details) ->
 386                             struct_name ^ "_" ^ name, details) fields in
 387
 388               Some (struct_name, (fields, total_size))
 389       ) what in
 390
 391       (basename, version, arch, structures)
 392   ) kernels in
 393
 394   if debug then
 395     List.iter (
 396       fun (basename, version, arch, structures) ->
 397         printf "%s (version: %s, arch: %s):\n" basename version arch;
 398         List.iter (
 399           fun (struct_name, (fields, total_size)) ->
 400             printf "  struct %s {\n" struct_name;
 401             List.iter (
 402               fun (field_name, (typ, offset, size)) ->
 403                 (match typ with
 404                  | `Int ->
 405                      printf "    int %s; " field_name
 406                  | `Ptr struct_name ->
 407                      printf "    struct %s *%s; " struct_name field_name
 408                  | `Str width ->
 409                      printf "    char %s[%d]; " field_name width
 410                 );
 411                 printf " /* offset = %d, size = %d */\n" offset size
 412             ) fields;
 413             printf "  } /* %d bytes */\n\n" total_size;
 414         ) structures;
 415     ) kernels;
 416
 417   (* First output file is a simple list of kernels, to support the
 418    * 'virt-mem --list-kernels' option.
 419    *)
 420   let () =
 421     let _loc = Loc.ghost in
 422
 423     let versions = List.map (fun (_, version, _, _) -> version) kernels in
 424
 425     (* Sort them in reverse because we are going to generate the
 426      * final list in reverse.
 427      *)
 428     let cmp a b = compare b a in
 429     let versions = List.sort ~cmp versions in
 430
 431     let xs =
 432       List.fold_left (fun xs version -> <:expr< $str:version$ :: $xs$ >>)
 433       <:expr< [] >> versions in
 434
 435     let code = <:str_item<
 436       let kernels = $xs$
 437     >> in
 438
 439     let output_file = outputdir // "virt_mem_kernels.ml" in
 440     printf "Writing list of kernels to %s ...\n%!" output_file;
 441     Printers.OCaml.print_implem ~output_file code in
 442
 443   (* We'll generate a code file for each structure type (eg. task_struct
 444    * across all kernel versions), so rearrange 'kernels' for that purpose.
 445    *
 446    * XXX This loop is O(n^3), luckily n is small!
 447    *)
 448   let files =
 449     List.map (
 450       fun (name, _) ->
 451         let kernels =
 452           List.filter_map (
 453             fun (basename, version, arch, structures) ->
 454               try Some (basename, version, arch, List.assoc name structures)
 455               with Not_found -> None
 456           ) kernels in
 457
 458         (* Sort the kernels, which makes the generated output more stable
 459          * and makes patches more useful.
 460          *)
 461         let kernels = List.sort kernels in
 462
 463         name, kernels
 464     ) what in
 465
 466   let kernels = () in ignore kernels; (* garbage collect *)
 467
 468   (* Get just the field types.  It's plausible that a field with the
 469    * same name has a different type between kernel versions, so we must
 470    * check that didn't happen.
 471    *)
 472   let files = List.map (
 473     fun (struct_name, kernels) ->
 474       let field_types =
 475         match kernels with
 476         | [] -> []
 477         | (_, _, _, (fields, _)) :: kernels ->
 478             let field_types_of_fields fields =
 479               List.sort (
 480                 List.map (
 481                   fun (field_name, (typ, _, _)) -> field_name, typ
 482                 ) fields
 483               )
 484             in
 485             let field_types = field_types_of_fields fields in
 486             List.iter (
 487               fun (_, _, _, (fields, _)) ->
 488                 if field_types <> field_types_of_fields fields then
 489                   failwith (sprintf "%s: one of the structure fields changed type between kernel versions" struct_name)
 490             ) kernels;
 491             field_types in
 492       (struct_name, kernels, field_types)
 493   ) files in
 494
 495   (* To minimize generated code size, we want to fold together all
 496    * structures where the particulars (eg. offsets, sizes, endianness)
 497    * of the fields we care about are the same -- eg. between kernel
 498    * versions which are very similar.
 499    *)
 500   let endian_of_architecture arch =
 501     if String.starts_with arch "i386" ||
 502       String.starts_with arch "i486" ||
 503       String.starts_with arch "i586" ||
 504       String.starts_with arch "i686" ||
 505       String.starts_with arch "x86_64" ||
 506       String.starts_with arch "x86-64" then
 507         Bitstring.LittleEndian
 508     else if String.starts_with arch "ia64" then
 509       Bitstring.LittleEndian (* XXX usually? *)
 510     else if String.starts_with arch "ppc" then
 511       Bitstring.BigEndian
 512     else if String.starts_with arch "sparc" then
 513       Bitstring.BigEndian
 514     else
 515       failwith (sprintf "endian_of_architecture: cannot parse %S" arch)
 516   in
 517
 518   let files =
 519     List.map (
 520       fun (struct_name, kernels, field_types) ->
 521         let hash = Hashtbl.create 13 in
 522         let i = ref 0 in
 523         let xs = ref [] in
 524         let kernels =
 525           List.map (
 526             fun (basename, version, arch, (fields, total_size)) ->
 527               let key = endian_of_architecture arch, fields in
 528               let j =
 529                 try Hashtbl.find hash key
 530                 with Not_found ->
 531                   incr i;
 532                   xs := (!i, key) :: !xs; Hashtbl.add hash key !i;
 533                   !i in
 534               (basename, version, arch, total_size, j)
 535           ) kernels in
 536         let parsers = List.rev !xs in
 537         struct_name, kernels, field_types, parsers
 538     ) files in
 539
 540   (* How much did we save by sharing? *)
 541   if debug then
 542     List.iter (
 543       fun (struct_name, kernels, _, parsers) ->
 544         printf "struct %s:\n" struct_name;
 545         printf "  number of kernel versions: %d\n" (List.length kernels);
 546         printf "  number of parser functions needed after sharing: %d\n"
 547           (List.length parsers)
 548     ) files;
 549
 550   (* Let's generate some code! *)
 551   let files =
 552     List.map (
 553       fun (struct_name, kernels, field_types, parsers) ->
 554         (* Dummy location required - there are no real locations for
 555          * output files.
 556          *)
 557         let _loc = Loc.ghost in
 558
 559         (* The structure type. *)
 560         let struct_type, struct_sig =
 561           let fields = List.map (
 562             function
 563             | (name, `Int) ->
 564                 <:ctyp< $lid:name$ : int64 >>
 565             | (name, `Ptr _) ->
 566                 <:ctyp< $lid:name$ : Virt_mem_mmap.addr >>
 567             | (name, `Str _) ->
 568                 <:ctyp< $lid:name$ : string >>
 569           ) field_types in
 570           let f, fs = match fields with
 571             | [] -> failwith (sprintf "%s: structure has no fields" struct_name)
 572             | f :: fs -> f, fs in
 573           let fields = List.fold_left (
 574             fun fs f -> <:ctyp< $fs$ ; $f$ >>
 575           ) f fs in
 576
 577           let struct_type = <:str_item< type t = { $fields$ } >> in
 578           let struct_sig = <:sig_item< type t = { $fields$ } >> in
 579           struct_type, struct_sig in
 580
 581         (* The shared parser functions.
 582          *
 583          * We could include bitmatch statements directly in here, but
 584          * what happens is that the macros get expanded here, resulting
 585          * in (even more) unreadable generated code.  So instead just
 586          * do a textual substitution later by post-processing the
 587          * generated files.  Not type-safe, but we can't have
 588          * everything.
 589          *)
 590         let parser_stmts, parser_subs =
 591           let parser_stmts = List.map (
 592             fun (i, _) ->
 593               let fnname = sprintf "parser_%d" i in
 594               <:str_item<
 595                 let $lid:fnname$ bits = $str:fnname$
 596                   >>
 597           ) parsers in
 598
 599           let parser_stmts =
 600             match parser_stmts with
 601             | [] -> <:str_item< >>
 602             | p :: ps ->
 603                 List.fold_left (fun ps p -> <:str_item< $ps$ $p$ >>) p ps in
 604
 605           (* What gets substituted for "parser_NN" ... *)
 606           let parser_subs = List.map (
 607             fun (i, (endian, fields)) ->
 608               let fnname = sprintf "parser_%d" i in
 609               let endian =
 610                 match endian with
 611                 | Bitstring.LittleEndian -> "littleendian"
 612                 | Bitstring.BigEndian -> "bigendian"
 613                 | _ -> assert false in
 614               let patterns =
 615                 (* Fields must be sorted by offset, otherwise bitmatch
 616                  * will complain.
 617                  *)
 618                 let cmp (_, (_, o1, _)) (_, (_, o2, _)) = compare o1 o2 in
 619                 let fields = List.sort ~cmp fields in
 620                 String.concat ";\n      " (
 621                   List.map (
 622                     function
 623                     | (field_name, (`Int, offset, size))
 624                     | (field_name, (`Ptr _, offset, size)) ->
 625                         (* 'zero+' is a hack to force the type to int64. *)
 626                         sprintf "%s : zero+%d : offset(%d), %s"
 627                           field_name (size*8) (offset*8) endian
 628                     | (field_name, (`Str width, offset, size)) ->
 629                         sprintf "%s : %d : offset(%d), string"
 630                           field_name (width*8) (offset*8)
 631                   ) fields
 632                 ) in
 633               let assignments =
 634                 String.concat ";\n        " (
 635                   List.map (
 636                     function
 637                     | (field_name, (`Ptr "list_head", offset, size)) ->
 638                         sprintf "%s = Int64.sub %s %dL" field_name field_name offset
 639                     | (field_name, _) ->
 640                         sprintf "%s = %s" field_name field_name
 641                   ) fields
 642                 ) in
 643
 644               let sub =
 645                 sprintf "
 646   bitmatch bits with
 647   | { %s } ->
 648       { %s }
 649   | { _ } ->
 650       raise (ParseError (struct_name, %S, match_err))"
 651                   patterns assignments fnname in
 652
 653               fnname, sub
 654           ) parsers in
 655
 656           parser_stmts, parser_subs in
 657
 658         (* Define a map from kernel versions to parsing functions. *)
 659         let version_map =
 660           let stmts = List.fold_left (
 661             fun stmts (_, version, arch, total_size, i) ->
 662               let parserfn = sprintf "parser_%d" i in
 663               <:str_item<
 664                 $stmts$
 665                 let v = ($lid:parserfn$, $`int:total_size$)
 666                 let map = StringMap.add $str:version$ v map
 667               >>
 668           ) <:str_item< let map = StringMap.empty >> kernels in
 669
 670           <:str_item<
 671             module StringMap = Map.Make (String) ;;
 672             $stmts$
 673           >> in
 674
 675         (* Code (.ml file). *)
 676         let code = <:str_item<
 677           let zero = 0
 678           let struct_name = $str:struct_name$
 679           let match_err = "failed to match kernel structure"
 680           exception ParseError of string * string * string;;
 681           $struct_type$
 682           $parser_stmts$
 683           $version_map$
 684
 685           type kernel_version = string
 686           let $lid:struct_name^"_known"$ version = StringMap.mem version map
 687           let $lid:struct_name^"_size"$ version =
 688             let _, size = StringMap.find version map in
 689             size
 690           let $lid:struct_name^"_of_bits"$ version bits =
 691             let parsefn, _ = StringMap.find version map in
 692             parsefn bits
 693           let $lid:"get_"^struct_name$ version mem addr =
 694             let parsefn, size = StringMap.find version map in
 695             let bytes = Virt_mem_mmap.get_bytes mem addr size in
 696             let bits = Bitstring.bitstring_of_string bytes in
 697             parsefn bits
 698         >> in
 699
 700         (* Interface (.mli file). *)
 701         let interface = <:sig_item<
 702           exception ParseError of string * string * string;;
 703           $struct_sig$
 704
 705           val struct_name : string
 706           type kernel_version = string
 707           val $lid:struct_name^"_known"$ : kernel_version -> bool
 708           val $lid:struct_name^"_size"$ : kernel_version -> int
 709           val $lid:struct_name^"_of_bits"$ :
 710             kernel_version -> Bitstring.bitstring -> t
 711           val $lid:"get_"^struct_name$ : kernel_version ->
 712             ('a, 'b, [`HasMapping]) Virt_mem_mmap.t -> Virt_mem_mmap.addr -> t
 713         >> in
 714
 715         (struct_name, code, interface, parser_subs)
 716     ) files in
 717
 718   (* Finally generate the output files. *)
 719   let re_subst = Pcre.regexp "^(.*)\"(parser_\\d+)\"(.*)$" in
 720
 721   List.iter (
 722     fun (struct_name, code, interface, parser_subs) ->
 723       (* Interface (.mli file). *)
 724       let output_file = outputdir // "kernel_" ^ struct_name ^ ".mli" in
 725       printf "Writing %s interface to %s ...\n%!" struct_name output_file;
 726       Printers.OCaml.print_interf ~output_file interface;
 727
 728       (* Implementation (.ml file). *)
 729       let output_file = outputdir // "kernel_" ^ struct_name ^ ".ml" in
 730       printf "Writing %s implementation to %s ...\n%!" struct_name output_file;
 731
 732       let new_output_file = output_file ^ ".new" in
 733       Printers.OCaml.print_implem ~output_file:new_output_file code;
 734
 735       (* Substitute the parser bodies in the output file. *)
 736       let ichan = open_in new_output_file in
 737       let ochan = open_out output_file in
 738
 739       output_string ochan "\
 740 (* WARNING: This file and the corresponding mli (interface) are
 741  * automatically generated by the extract/codegen/kerneldb_to_parser.ml
 742  * program.
 743  *
 744  * Any edits you make to this file will be lost.
 745  *
 746  * To update this file from the latest kernel database, it is recommended
 747  * that you do 'make update-kernel-structs'.
 748  *)
 749 ";
 750
 751       let rec loop () =
 752         let line = input_line ichan in
 753         let line =
 754           if Pcre.pmatch ~rex:re_subst line then (
 755             let subs = Pcre.exec ~rex:re_subst line in
 756             let start = Pcre.get_substring subs 1 in
 757             let template = Pcre.get_substring subs 2 in
 758             let rest = Pcre.get_substring subs 3 in
 759             let sub = List.assoc template parser_subs in
 760             start ^ sub ^ rest
 761           ) else line in
 762         output_string ochan line; output_char ochan '\n';
 763         loop ()
 764       in
 765       (try loop () with End_of_file -> ());
 766
 767       close_out ochan;
 768       close_in ichan;
 769
 770       Unix.unlink new_output_file
 771   ) files