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