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