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