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 = true
 135
 136 open Camlp4.PreCast
 137 open Syntax
 138 (*open Ast*)
 139
 140 open ExtList
 141 open ExtString
 142 open Printf
 143
 144 module PP = Pahole_parser
 145
 146 let (//) = Filename.concat
 147
 148 (* Couple of handy camlp4 construction functions which do some
 149  * things that ought to be easy/obvious but aren't.
 150  *
 151  * 'concat_str_items' concatenates a list of str_item together into
 152  * one big str_item.
 153  *
 154  * 'concat_record_fields' concatenates a list of records fields into
 155  * a record.  The list must have at least one element.
 156  *
 157  * 'build_record' builds a record out of record fields.
 158  *
 159  * 'build_tuple_from_exprs' builds an arbitrary length tuple from
 160  * a list of expressions of length >= 2.
 161  *
 162  * Thanks to bluestorm on #ocaml for getting these working.
 163  *)
 164 let concat_str_items _loc items =
 165   match items with
 166   | [] -> <:str_item< >>
 167   | x :: xs ->
 168       List.fold_left (fun xs x -> <:str_item< $xs$ $x$ >>) x xs
 169
 170 let concat_sig_items _loc items =
 171   match items with
 172   | [] -> <:sig_item< >>
 173   | x :: xs ->
 174       List.fold_left (fun xs x -> <:sig_item< $xs$ $x$ >>) x xs
 175
 176 let concat_record_fields _loc fields =
 177   match fields with
 178     | [] -> assert false
 179     | f :: fs ->
 180         List.fold_left (fun fs f -> <:ctyp< $fs$ ; $f$ >>) f fs
 181
 182 let concat_record_bindings _loc rbs =
 183   match rbs with
 184     | [] -> assert false
 185     | rb :: rbs ->
 186         List.fold_left (fun rbs rb -> <:rec_binding< $rbs$ ; $rb$ >>) rb rbs
 187
 188 let build_record _loc rbs =
 189   Ast.ExRec (_loc, rbs, Ast.ExNil _loc)
 190
 191 let build_tuple_from_exprs _loc exprs =
 192   match exprs with
 193   | [] | [_] -> assert false
 194   | x :: xs ->
 195       Ast.ExTup (_loc,
 196                  List.fold_left (fun xs x -> Ast.ExCom (_loc, x, xs)) x xs)
 197
 198 let () =
 199   let args = Array.to_list Sys.argv in
 200
 201   let kernelsdir, outputdir =
 202     match args with
 203     | [_;kd;od] -> kd,od
 204     | _ ->
 205         let arg0 = Filename.basename Sys.executable_name in
 206         eprintf "%s - Turn kernels database into code modules.
 207
 208 Usage:
 209   %s <kernelsdir> <outputdir>
 210
 211 Example (from toplevel of virt-mem source tree):
 212   %s kernels/ lib/
 213 " arg0 arg0 arg0;
 214         exit 2 in
 215
 216   let kernels = PP.list_kernels kernelsdir in
 217   let nr_kernels = List.length kernels in
 218
 219   let kernels = List.mapi (
 220     fun i info ->
 221       printf "Loading kernel data file %d/%d\r%!" (i+1) nr_kernels;
 222
 223       let struct_names = List.map fst structs in
 224       let structures = PP.load_structures info struct_names in
 225
 226       (* Make sure we got all the mandatory structures & fields. *)
 227       List.iter (
 228         fun (struct_name,
 229              { mandatory_struct = mandatory; fields = wanted_fields }) ->
 230           try
 231             let s =
 232               List.find (fun s -> struct_name = s.PP.struct_name)
 233                 structures in
 234
 235             (* Check we have all the mandatory fields. *)
 236             let all_fields = s.PP.struct_fields in
 237             List.iter (
 238               fun (wanted_field, { mandatory_field = mandatory }) ->
 239                 let got_it =
 240                   List.exists (
 241                     fun { PP.field_name = name } -> name = wanted_field
 242                   ) all_fields in
 243                 if mandatory && not got_it then (
 244                   eprintf "%s: structure %s is missing required field %s\n"
 245                     info.PP.basename struct_name wanted_field;
 246                   eprintf "fields found in this structure:\n";
 247                   List.iter (
 248                     fun { PP.field_name = name } -> eprintf "\t%s\n" name
 249                   ) all_fields;
 250                   exit 1
 251                 );
 252             ) wanted_fields
 253
 254           with Not_found ->
 255             if mandatory then
 256               failwith (sprintf "%s: structure %s not found in this kernel"
 257                           info.PP.basename struct_name)
 258       ) structs;
 259
 260       let structures =
 261         List.map (
 262           fun ({ PP.struct_name = struct_name; PP.struct_fields = fields }
 263                  as structure) ->
 264             let { fields = wanted_fields } = List.assoc struct_name structs in
 265
 266             (* That got us all the fields, but we only care about
 267              * the wanted_fields.
 268              *)
 269             let fields = List.filter (
 270               fun { PP.field_name = name } -> List.mem_assoc name wanted_fields
 271             ) fields in
 272
 273             (* Prefix all the field names with the structure name. *)
 274             let fields =
 275               List.map (
 276                 fun ({ PP.field_name = name } as field) ->
 277                   let name = struct_name ^ "_" ^ name in
 278                   { field with PP.field_name = name }
 279               ) fields in
 280             { structure with PP.struct_fields = fields }
 281         ) structures in
 282
 283       (info, structures)
 284   ) kernels in
 285
 286   if debug then
 287     List.iter (
 288       fun (info, structures) ->
 289         printf "%s ----------\n" (PP.string_of_info info);
 290         List.iter (
 291           fun structure ->
 292             printf "%s\n\n" (PP.string_of_structure structure);
 293         ) structures;
 294     ) kernels;
 295
 296   (* First output file is a simple list of kernels, to support the
 297    * 'virt-mem --list-kernels' option.
 298    *)
 299   let () =
 300     let _loc = Loc.ghost in
 301
 302     let versions = List.map (
 303       fun ({ PP.kernel_version = version }, _) -> version
 304     ) kernels in
 305
 306     (* Sort them in reverse because we are going to generate the
 307      * final list in reverse.
 308      *)
 309     let cmp a b = compare b a in
 310     let versions = List.sort ~cmp versions in
 311
 312     let xs =
 313       List.fold_left (fun xs version -> <:expr< $str:version$ :: $xs$ >>)
 314       <:expr< [] >> versions in
 315
 316     let code = <:str_item<
 317       let kernels = $xs$
 318     >> in
 319
 320     let output_file = outputdir // "virt_mem_kernels.ml" in
 321     printf "Writing list of kernels to %s ...\n%!" output_file;
 322     Printers.OCaml.print_implem ~output_file code in
 323
 324   (* We'll generate a code file for each structure type (eg. task_struct
 325    * across all kernel versions), so rearrange 'kernels' for that purpose.
 326    *
 327    * XXX This loop is O(n^3), luckily n is small!
 328    *)
 329   let files =
 330     List.map (
 331       fun (struct_name, _) ->
 332         let kernels =
 333           List.filter_map (
 334             fun (info, structures) ->
 335               try
 336                 let structure =
 337                   List.find (
 338                     fun { PP.struct_name = name } -> name = struct_name
 339                   ) structures in
 340                 Some (info, structure)
 341               with Not_found ->
 342                 None
 343           ) kernels in
 344
 345         (* Sort the kernels, which makes the generated output more stable
 346          * and makes patches more useful.
 347          *)
 348         let kernels = List.sort kernels in
 349
 350         struct_name, kernels
 351     ) structs in
 352
 353   let kernels = () in ignore kernels; (* garbage collect *)
 354
 355 (*
 356   (* Get just the field types.
 357    *
 358    * It's plausible that a field with the same name has a different
 359    * type between kernel versions, so we must check that didn't
 360    * happen.
 361    *
 362    * This is complicated because of non-mandatory fields, which don't
 363    * appear in every kernel version.
 364    *)
 365   let files = List.map (
 366     fun (struct_name, kernels) ->
 367       let field_types =
 368         (* Get the list of fields expected in this structure. *)
 369         let { fields = struct_fields } = List.assoc struct_name structs in
 370
 371         (* Get the list of fields that we found in each kernel version. *)
 372         let found_fields =
 373           List.flatten
 374             (List.map (fun (_, _, _, (fields, _)) -> fields) kernels) in
 375
 376         (* Determine a hash from each field name to the type.  As we add
 377          * fields, we might get a conflicting type (meaning the type
 378          * changed between kernel versions).
 379          *)
 380         let hash = Hashtbl.create 13 in
 381
 382         List.iter (
 383           fun (field_name, (typ, _, _)) ->
 384             try
 385               let field_type = Hashtbl.find hash field_name in
 386               if typ <> field_type then
 387                 failwith (sprintf "%s.%s: structure field changed type between kernel versions" struct_name field_name);
 388             with Not_found ->
 389               Hashtbl.add hash field_name typ
 390         ) found_fields;
 391
 392         (* Now get a type for each structure field. *)
 393         List.filter_map (
 394           fun (field_name, ft) ->
 395             try
 396               let field_name = struct_name ^ "_" ^ field_name in
 397               let typ = Hashtbl.find hash field_name in
 398               Some (field_name, (typ, ft))
 399             with Not_found ->
 400               let msg =
 401                 sprintf "%s.%s: this field was not found in any kernel version"
 402                   struct_name field_name in
 403               if ft.mandatory_field then failwith msg else prerr_endline msg;
 404               None
 405         ) struct_fields in
 406       (struct_name, kernels, field_types)
 407   ) files in
 408
 409   (* To minimize generated code size, we want to fold together all
 410    * structures where the particulars (eg. offsets, sizes, endianness)
 411    * of the fields we care about are the same -- eg. between kernel
 412    * versions which are very similar.
 413    *)
 414   let endian_of_architecture arch =
 415     if String.starts_with arch "i386" ||
 416       String.starts_with arch "i486" ||
 417       String.starts_with arch "i586" ||
 418       String.starts_with arch "i686" ||
 419       String.starts_with arch "x86_64" ||
 420       String.starts_with arch "x86-64" then
 421         Bitstring.LittleEndian
 422     else if String.starts_with arch "ia64" then
 423       Bitstring.LittleEndian (* XXX usually? *)
 424     else if String.starts_with arch "ppc" then
 425       Bitstring.BigEndian
 426     else if String.starts_with arch "sparc" then
 427       Bitstring.BigEndian
 428     else
 429       failwith (sprintf "endian_of_architecture: cannot parse %S" arch)
 430   in
 431
 432   let files =
 433     List.map (
 434       fun (struct_name, kernels, field_types) ->
 435         let hash = Hashtbl.create 13 in
 436         let i = ref 0 in
 437         let xs = ref [] in
 438         let kernels =
 439           List.map (
 440             fun (basename, version, arch, (fields, total_size)) ->
 441               let key = endian_of_architecture arch, fields in
 442               let j =
 443                 try Hashtbl.find hash key
 444                 with Not_found ->
 445                   incr i;
 446                   xs := (!i, key) :: !xs; Hashtbl.add hash key !i;
 447                   !i in
 448               (basename, version, arch, total_size, j)
 449           ) kernels in
 450         let parsers = List.rev !xs in
 451         struct_name, kernels, field_types, parsers
 452     ) files in
 453
 454   (* How much did we save by sharing? *)
 455   if debug then
 456     List.iter (
 457       fun (struct_name, kernels, _, parsers) ->
 458         printf "struct %s:\n" struct_name;
 459         printf "  number of kernel versions: %d\n" (List.length kernels);
 460         printf "  number of parser functions needed after sharing: %d\n"
 461           (List.length parsers)
 462     ) files;
 463
 464   (* Extend the parsers fields by adding on any optional fields which
 465    * are not actually present in the specific kernel.
 466    *)
 467   let files =
 468     List.map (
 469       fun (struct_name, kernels, field_types, parsers) ->
 470         let parsers = List.map (
 471           fun (i, (endian, fields)) ->
 472             let fields_not_present =
 473               List.filter_map (
 474                 fun (field_name, _) ->
 475                   if List.mem_assoc field_name fields then None
 476                   else Some field_name
 477               ) field_types in
 478             (i, (endian, fields, fields_not_present))
 479         ) parsers in
 480         (struct_name, kernels, field_types, parsers)
 481     ) files in
 482
 483   (* Let's generate some code! *)
 484   let files =
 485     List.map (
 486       fun (struct_name, kernels, field_types, parsers) ->
 487         (* Dummy location required - there are no real locations for
 488          * output files.
 489          *)
 490         let _loc = Loc.ghost in
 491
 492         (* The structure type. *)
 493         let struct_type, struct_sig =
 494           let fields = List.map (
 495             function
 496             | (name, (`Int, { mandatory_field = true })) ->
 497                 <:ctyp< $lid:name$ : int64 >>
 498             | (name, (`Int, { mandatory_field = false })) ->
 499                 <:ctyp< $lid:name$ : int64 option >>
 500             | (name, ((`VoidPtr|`Ptr _), { mandatory_field = true })) ->
 501                 <:ctyp< $lid:name$ : Virt_mem_mmap.addr >>
 502             | (name, ((`VoidPtr|`Ptr _), { mandatory_field = false })) ->
 503                 <:ctyp< $lid:name$ : Virt_mem_mmap.addr option >>
 504             | (name, (`Str _, { mandatory_field = true })) ->
 505                 <:ctyp< $lid:name$ : string >>
 506             | (name, (`Str _, { mandatory_field = false })) ->
 507                 <:ctyp< $lid:name$ : string option >>
 508           ) field_types in
 509           let fields = concat_record_fields _loc fields in
 510           let struct_type = <:str_item< type t = { $fields$ } >> in
 511           let struct_sig = <:sig_item< type t = { $fields$ } >> in
 512           struct_type, struct_sig in
 513
 514         (* Create a "field signature" which describes certain aspects
 515          * of the fields which vary between kernel versions.
 516          *)
 517         let fieldsig_type, fieldsigs =
 518           let fieldsig_type =
 519             let fields = List.map (
 520               fun (name, _) ->
 521                 let fsname = "__fs_" ^ name in
 522                 <:ctyp< $lid:fsname$ : Virt_mem_types.fieldsig >>
 523             ) field_types in
 524             let fields = concat_record_fields _loc fields in
 525             <:str_item< type fs_t = { $fields$ } >> in
 526
 527           let fieldsigs = List.map (
 528             fun (i, (_, fields, fields_not_present)) ->
 529               let make_fieldsig field_name available offset =
 530                 let available =
 531                   if available then <:expr< true >> else <:expr< false >> in
 532                 let fsname = "__fs_" ^ field_name in
 533                 <:rec_binding<
 534                   $lid:fsname$ =
 535                       { Virt_mem_types.field_available = $available$;
 536                         field_offset = $`int:offset$ }
 537                 >>
 538               in
 539               let fields = List.map (
 540                 fun (field_name, (_, offset, _)) ->
 541                   make_fieldsig field_name true offset
 542               ) fields in
 543               let fields_not_present = List.map (
 544                 fun field_name ->
 545                   make_fieldsig field_name false (-1)
 546               ) fields_not_present in
 547
 548               let fieldsigs = fields @ fields_not_present in
 549               let fsname = sprintf "fieldsig_%d" i in
 550               let fieldsigs = concat_record_bindings _loc fieldsigs in
 551               let fieldsigs = build_record _loc fieldsigs in
 552               <:str_item<
 553                 let $lid:fsname$ = $fieldsigs$
 554               >>
 555           ) parsers in
 556
 557           let fieldsigs = concat_str_items _loc fieldsigs in
 558
 559           fieldsig_type, fieldsigs in
 560
 561         (* The shared parser functions.
 562          *
 563          * We could include bitmatch statements directly in here, but
 564          * what happens is that the macros get expanded here, resulting
 565          * in (even more) unreadable generated code.  So instead just
 566          * do a textual substitution later by post-processing the
 567          * generated files.  Not type-safe, but we can't have
 568          * everything.
 569          *)
 570         let parser_stmts, parser_subs =
 571           let parser_stmts = List.map (
 572             fun (i, _) ->
 573               let fnname = sprintf "parser_%d" i in
 574               <:str_item<
 575                 let $lid:fnname$ bits = $str:fnname$
 576               >>
 577           ) parsers in
 578
 579           let parser_stmts = concat_str_items _loc parser_stmts in
 580
 581           (* What gets substituted for "parser_NN" ... *)
 582           let parser_subs = List.map (
 583             fun (i, (endian, fields, fields_not_present)) ->
 584               let fnname = sprintf "parser_%d" i in
 585               let endian =
 586                 match endian with
 587                 | Bitstring.LittleEndian -> "littleendian"
 588                 | Bitstring.BigEndian -> "bigendian"
 589                 | _ -> assert false in
 590               let patterns =
 591                 (* Fields must be sorted by offset, otherwise bitmatch
 592                  * will complain.
 593                  *)
 594                 let cmp (_, (_, o1, _)) (_, (_, o2, _)) = compare o1 o2 in
 595                 let fields = List.sort ~cmp fields in
 596                 String.concat ";\n      " (
 597                   List.map (
 598                     function
 599                     | (field_name, ((`Int|`Ptr _|`VoidPtr), offset, size)) ->
 600                         (* 'zero+' is a hack to force the type to int64. *)
 601                         sprintf "%s : zero+%d : offset(%d), %s"
 602                           field_name (size*8) (offset*8) endian
 603                     | (field_name, (`Str width, offset, size)) ->
 604                         sprintf "%s : %d : offset(%d), string"
 605                           field_name (width*8) (offset*8)
 606                   ) fields
 607                 ) in
 608               let assignments =
 609                 List.map (
 610                   fun (field_name, typ) ->
 611                     let (_, { mandatory_field = mandatory;
 612                               list_head_adjustment = list_head_adjustment }) =
 613                       try List.assoc field_name field_types
 614                       with Not_found ->
 615                         failwith (sprintf "%s: not found in field_types"
 616                                     field_name) in
 617                     match typ, mandatory, list_head_adjustment with
 618                     | (`Ptr "list_head", offset, size), true, true ->
 619                         sprintf "%s = Int64.sub %s %dL"
 620                           field_name field_name offset
 621                     | (`Ptr "list_head", offset, size), false, true ->
 622                         sprintf "%s = Some (Int64.sub %s %dL)"
 623                           field_name field_name offset
 624                     | _, true, _ ->
 625                         sprintf "%s = %s" field_name field_name
 626                     | _, false, _ ->
 627                         sprintf "%s = Some %s" field_name field_name
 628                 ) fields in
 629               let assignments_not_present =
 630                 List.map (
 631                   fun field_name -> sprintf "%s = None" field_name
 632                 ) fields_not_present in
 633
 634               let assignments =
 635                 String.concat ";\n        "
 636                   (assignments @ assignments_not_present) in
 637
 638               let sub =
 639                 sprintf "
 640   bitmatch bits with
 641   | { %s } ->
 642       { %s }
 643   | { _ } ->
 644       raise (Virt_mem_types.ParseError (struct_name, %S, match_err))"
 645                   patterns assignments fnname in
 646
 647               fnname, sub
 648           ) parsers in
 649
 650           parser_stmts, parser_subs in
 651
 652         (* Define a map from kernel versions to parsing functions. *)
 653         let version_map =
 654           let stmts = List.fold_left (
 655             fun stmts (_, version, arch, total_size, i) ->
 656               let parserfn = sprintf "parser_%d" i in
 657               let fsname = sprintf "fieldsig_%d" i in
 658               <:str_item<
 659                 $stmts$
 660                 let v = ($lid:parserfn$, $`int:total_size$, $lid:fsname$)
 661                 let map = StringMap.add $str:version$ v map
 662               >>
 663           ) <:str_item< let map = StringMap.empty >> kernels in
 664
 665           <:str_item<
 666             module StringMap = Map.Make (String) ;;
 667             $stmts$
 668           >> in
 669
 670         (* Accessors for the field signatures. *)
 671         let fsaccess, fsaccess_sig =
 672           let fields = List.map (
 673             fun (field_name, _) ->
 674               let fsname = "__fs_" ^ field_name in
 675               <:str_item<
 676                 let $lid:"field_signature_of_"^field_name$ version =
 677                   let _, _, fs = StringMap.find version map in
 678                   fs.$lid:fsname$
 679               >>
 680           ) field_types in
 681
 682           let fsaccess = concat_str_items _loc fields in
 683
 684           let fields = List.map (
 685             fun (field_name, _) ->
 686               <:sig_item<
 687                 val $lid:"field_signature_of_"^field_name$ : kernel_version ->
 688                   Virt_mem_types.fieldsig
 689               >>
 690           ) field_types in
 691
 692           let fsaccess_sig = concat_sig_items _loc fields in
 693
 694           fsaccess, fsaccess_sig in
 695
 696         (* Code (.ml file). *)
 697         let code = <:str_item<
 698           let zero = 0
 699           let struct_name = $str:struct_name$
 700           let match_err = "failed to match kernel structure" ;;
 701           $struct_type$
 702           $fieldsig_type$
 703           $fieldsigs$
 704           $parser_stmts$
 705           $version_map$
 706
 707           type kernel_version = string
 708           let $lid:struct_name^"_known"$ version = StringMap.mem version map
 709           let $lid:struct_name^"_size"$ version =
 710             let _, size, _ = StringMap.find version map in
 711             size
 712           let $lid:struct_name^"_of_bits"$ version bits =
 713             let parsefn, _, _ = StringMap.find version map in
 714             parsefn bits
 715           let $lid:"get_"^struct_name$ version mem addr =
 716             let parsefn, size, _ = StringMap.find version map in
 717             let bytes = Virt_mem_mmap.get_bytes mem addr size in
 718             let bits = Bitstring.bitstring_of_string bytes in
 719             parsefn bits ;;
 720           $fsaccess$
 721         >> in
 722
 723         (* Interface (.mli file). *)
 724         let interface = <:sig_item<
 725           $struct_sig$
 726
 727           val struct_name : string
 728           type kernel_version = string
 729           val $lid:struct_name^"_known"$ : kernel_version -> bool
 730           val $lid:struct_name^"_size"$ : kernel_version -> int
 731           val $lid:struct_name^"_of_bits"$ :
 732             kernel_version -> Bitstring.bitstring -> t
 733           val $lid:"get_"^struct_name$ : kernel_version ->
 734             ('a, 'b, [`HasMapping]) Virt_mem_mmap.t -> Virt_mem_mmap.addr -> t;;
 735           $fsaccess_sig$
 736         >> in
 737
 738         (struct_name, code, interface, parser_subs)
 739     ) files in
 740
 741   (* Finally generate the output files. *)
 742   let re_subst = Pcre.regexp "^(.*)\"(parser_\\d+)\"(.*)$" in
 743
 744   List.iter (
 745     fun (struct_name, code, interface, parser_subs) ->
 746       (* Interface (.mli file). *)
 747       let output_file = outputdir // "kernel_" ^ struct_name ^ ".mli" in
 748       printf "Writing %s interface to %s ...\n%!" struct_name output_file;
 749       Printers.OCaml.print_interf ~output_file interface;
 750
 751       (* Implementation (.ml file). *)
 752       let output_file = outputdir // "kernel_" ^ struct_name ^ ".ml" in
 753       printf "Writing %s implementation to %s ...\n%!" struct_name output_file;
 754
 755       let new_output_file = output_file ^ ".new" in
 756       Printers.OCaml.print_implem ~output_file:new_output_file code;
 757
 758       (* Substitute the parser bodies in the output file. *)
 759       let ichan = open_in new_output_file in
 760       let ochan = open_out output_file in
 761
 762       output_string ochan "\
 763 (* WARNING: This file and the corresponding mli (interface) are
 764  * automatically generated by the extract/codegen/kerneldb_to_parser.ml
 765  * program.
 766  *
 767  * Any edits you make to this file will be lost.
 768  *
 769  * To update this file from the latest kernel database, it is recommended
 770  * that you do 'make update-kernel-structs'.
 771  *)\n\n";
 772
 773       let rec loop () =
 774         let line = input_line ichan in
 775         let line =
 776           if Pcre.pmatch ~rex:re_subst line then (
 777             let subs = Pcre.exec ~rex:re_subst line in
 778             let start = Pcre.get_substring subs 1 in
 779             let template = Pcre.get_substring subs 2 in
 780             let rest = Pcre.get_substring subs 3 in
 781             let sub = List.assoc template parser_subs in
 782             start ^ sub ^ rest
 783           ) else line in
 784         output_string ochan line; output_char ochan '\n';
 785         loop ()
 786       in
 787       (try loop () with End_of_file -> ());
 788
 789       close_out ochan;
 790       close_in ichan;
 791
 792       Unix.unlink new_output_file
 793   ) files
 794 *)