Basic listing of the network devices.
[virt-mem.git] / 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