1 (* Memory info for virtual domains.
2 (C) Copyright 2008 Richard W.M. Jones, Red Hat Inc.
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.
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.
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.
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.
24 The output programs -- *.ml, *.mli files of generated code -- go
25 into lib/ at the toplevel, eg. lib/kernel_task_struct.ml
27 The stuff at the top of this file determine what structures
28 and fields we try to parse.
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. *)
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.
49 let ordinary_field = { mandatory_field = true; list_head_adjustment = true; }
51 (*----------------------------------------------------------------------
52 * This controls what structures & fields we will parse out.
53 *----------------------------------------------------------------------*)
56 opener = "struct task_struct {"; closer = "};"; mandatory_struct = true;
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;
65 "active_mm", ordinary_field;
66 "comm", ordinary_field;
67 "pid", ordinary_field;
72 "struct mm_struct {", "};", true,
77 opener = "struct net_device {"; closer = "};"; mandatory_struct = true;
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;
93 opener = "struct net {"; closer = "};"; mandatory_struct = false;
96 (* Don't do list_head adjustment on this field, because it points
97 * to a net_device struct.
99 { mandatory_field = true; list_head_adjustment = false };
103 opener = "struct in_device {"; closer = "};"; mandatory_struct = true;
105 "ifa_list", ordinary_field;
109 opener = "struct inet6_dev {"; closer = "};"; mandatory_struct = true;
111 "addr_list", ordinary_field;
115 opener = "struct in_ifaddr {"; closer = "};"; mandatory_struct = true;
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;
125 opener = "struct inet6_ifaddr {"; closer = "};"; mandatory_struct = true;
127 (*"addr'in6_u'u6_addr8", ordinary_field;*)
128 "prefix_len", ordinary_field;
129 "lst_next", ordinary_field;
144 let (//) = Filename.concat
146 (* Couple of handy camlp4 construction functions which do some
147 * things that ought to be easy/obvious but aren't.
149 * 'concat_str_items' concatenates a list of str_item together into
152 * 'concat_record_fields' concatenates a list of records fields into
153 * a record. The list must have at least one element.
155 * 'build_record' builds a record out of record fields.
157 * 'build_tuple_from_exprs' builds an arbitrary length tuple from
158 * a list of expressions of length >= 2.
160 * Thanks to bluestorm on #ocaml for getting these working.
162 let concat_str_items _loc items =
164 | [] -> <:str_item< >>
166 List.fold_left (fun xs x -> <:str_item< $xs$ $x$ >>) x xs
168 let concat_sig_items _loc items =
170 | [] -> <:sig_item< >>
172 List.fold_left (fun xs x -> <:sig_item< $xs$ $x$ >>) x xs
174 let concat_record_fields _loc fields =
178 List.fold_left (fun fs f -> <:ctyp< $fs$ ; $f$ >>) f fs
180 let concat_record_bindings _loc rbs =
184 List.fold_left (fun rbs rb -> <:rec_binding< $rbs$ ; $rb$ >>) rb rbs
186 let build_record _loc rbs =
187 Ast.ExRec (_loc, rbs, Ast.ExNil _loc)
189 let build_tuple_from_exprs _loc exprs =
191 | [] | [_] -> assert false
194 List.fold_left (fun xs x -> Ast.ExCom (_loc, x, xs)) x xs)
197 let args = Array.to_list Sys.argv in
199 let kernelsdir, outputdir =
203 let arg0 = Filename.basename Sys.executable_name in
204 eprintf "%s - Turn kernels database into code modules.
207 %s <kernelsdir> <outputdir>
209 Example (from toplevel of virt-mem source tree):
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
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
224 (* Parse in the *.info files. These have historically had a few different
225 * formats that we need to support.
227 let infos = List.map (
229 (* Get the basename (for getting the .data file later on). *)
230 let basename = Filename.chop_suffix filename ".info" in
232 let chan = open_in filename in
233 let line = input_line chan in
235 (* Kernel version string. *)
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.
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
247 (* XXX Map name -> PAE, hugemem etc. *)
248 (* name, *) sprintf "%s-%s.%s" version release arch, arch
250 (* New-style "key: value" entries, up to end of file or the first
253 let (*name,*) version, release, arch =
254 (*ref "",*) ref "", ref "", ref "" in
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
267 Not_found | End_of_file ->
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
279 (*printf "%s -> %s %s\n%!" basename version arch;*)
281 (basename, version, arch)
284 let nr_kernels = List.length infos in
286 (* For quick access to the opener strings, build a hash. *)
287 let openers = Hashtbl.create 13 in
289 fun (name, { opener = opener; closer = closer }) ->
290 Hashtbl.add openers opener (closer, name)
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;
298 let file_exists name =
299 try Unix.access name [Unix.F_OK]; true
300 with Unix.Unix_error _ -> false
302 let close_process_in cmd chan =
303 match Unix.close_process_in chan with
304 | Unix.WEXITED 0 -> ()
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
310 eprintf "%s: command stopped by signal %d\n" cmd i; exit 1
313 (* Open the data file, uncompressing it on the fly if necessary. *)
315 if file_exists (basename ^ ".data") then
316 open_in (basename ^ ".data"), close_in
317 else if file_exists (basename ^ ".data.gz") then (
319 sprintf "gzip -cd %s" (Filename.quote (basename ^ ".data.gz")) in
320 Unix.open_process_in cmd, close_process_in cmd
322 else if file_exists (basename ^ ".data.bz2") then (
324 sprintf "bzip2 -cd %s" (Filename.quote (basename ^ ".data.bz2")) in
325 Unix.open_process_in cmd, close_process_in cmd
328 (sprintf "%s: cannot find corresponding data file" basename) in
330 (* Read the data file in, looking for structures of interest to us. *)
331 let bodies = Hashtbl.create 13 in
333 let line = input_line chan in
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.
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
351 failwith (sprintf "%s: %s: %S not matched by closing %S" basename name line closer) in
353 Hashtbl.replace bodies name body
354 with Not_found -> ());
358 (try loop () with End_of_file -> ());
362 (* Make sure we got all the mandatory structures. *)
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)
369 (basename, version, arch, bodies)
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.
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
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
389 let rec parse basename = function
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.
396 let rec loop depth acc = function
398 eprintf "%s: %S has no matching close structure line\n%!"
401 | line :: lines when Pcre.pmatch ~rex:re_structopener line ->
402 loop (depth+1) (line :: acc) lines
404 when depth = 0 && Pcre.pmatch ~rex:re_structcloser line ->
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
411 let nested_body, rest = loop 0 [] lines in
413 (* Then parse the sub-structure. *)
414 let struct_name, nested_body =
415 match nested_body with
418 let subs = Pcre.exec ~rex:re_structcloser closer in
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
424 (* Prefix the sub-fields with the name of the structure. *)
426 match struct_name with
427 | None -> nested_fields
430 fun (name, details) -> (prefix ^ "'" ^ name, details)
433 (* Parse the rest. *)
434 nested_fields @ parse basename rest
436 | line :: lines when Pcre.pmatch ~rex:re_intfield line ->
438 let subs = Pcre.exec ~rex:re_intfield line in
439 let name = Pcre.get_substring subs 1 in
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
446 Not_found -> parse basename lines
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
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
461 Not_found -> parse basename lines
464 | line :: lines when Pcre.pmatch ~rex:re_voidptrfield line ->
466 let subs = Pcre.exec ~rex:re_voidptrfield line in
467 let name = Pcre.get_substring subs 1 in
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
475 Not_found -> parse basename lines
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
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
490 Not_found -> parse basename lines
494 (* Just ignore any other field we can't parse. *)
499 let kernels = List.map (
500 fun (basename, version, arch, bodies) ->
501 let structures = List.filter_map (
502 fun (struct_name, { fields = wanted_fields }) ->
504 try Some (Hashtbl.find bodies struct_name)
505 with Not_found -> None in
509 let body = List.tl body in (* Don't care about opener line. *)
510 let fields = parse basename body in
512 (* Compute total size of the structure. *)
514 let fields = List.map (
515 fun (_, (_, offset, size)) -> offset + size
517 List.fold_left max 0 fields in
519 (* That got us all the fields, but we only care about
522 let all_fields = fields in
523 let fields = List.filter (
524 fun (name, _) -> List.mem_assoc name wanted_fields
527 (* Also check we have all the mandatory fields. *)
529 fun (wanted_field, { mandatory_field = mandatory }) ->
530 if mandatory && not (List.mem_assoc wanted_field fields)
532 eprintf "%s: structure %s is missing required field %s\n" basename struct_name wanted_field;
533 eprintf "fields found in this structure:\n";
535 fun (name, _) -> eprintf "\t%s\n" name
541 (* Prefix all the field names with the structure name. *)
543 List.map (fun (name, details) ->
544 struct_name ^ "_" ^ name, details) fields in
546 Some (struct_name, (fields, total_size))
549 (basename, version, arch, structures)
554 fun (basename, version, arch, structures) ->
555 printf "%s (version: %s, arch: %s):\n" basename version arch;
557 fun (struct_name, (fields, total_size)) ->
558 printf " struct %s {\n" struct_name;
560 fun (field_name, (typ, offset, size)) ->
563 printf " int %s; " field_name
564 | `Ptr struct_name ->
565 printf " struct %s *%s; " struct_name field_name
567 printf " void *%s; " field_name
569 printf " char %s[%d]; " field_name width
571 printf " /* offset = %d, size = %d */\n" offset size
573 printf " } /* %d bytes */\n\n" total_size;
577 (* First output file is a simple list of kernels, to support the
578 * 'virt-mem --list-kernels' option.
581 let _loc = Loc.ghost in
583 let versions = List.map (fun (_, version, _, _) -> version) kernels in
585 (* Sort them in reverse because we are going to generate the
586 * final list in reverse.
588 let cmp a b = compare b a in
589 let versions = List.sort ~cmp versions in
592 List.fold_left (fun xs version -> <:expr< $str:version$ :: $xs$ >>)
593 <:expr< [] >> versions in
595 let code = <:str_item<
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
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.
606 * XXX This loop is O(n^3), luckily n is small!
613 fun (basename, version, arch, structures) ->
614 try Some (basename, version, arch, List.assoc name structures)
615 with Not_found -> None
618 (* Sort the kernels, which makes the generated output more stable
619 * and makes patches more useful.
621 let kernels = List.sort kernels in
626 let kernels = () in ignore kernels; (* garbage collect *)
628 (* Get just the field types.
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
634 * This is complicated because of non-mandatory fields, which don't
635 * appear in every kernel version.
637 let files = List.map (
638 fun (struct_name, kernels) ->
640 (* Get the list of fields expected in this structure. *)
641 let { fields = struct_fields } = List.assoc struct_name structs in
643 (* Get the list of fields that we found in each kernel version. *)
646 (List.map (fun (_, _, _, (fields, _)) -> fields) kernels) in
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).
652 let hash = Hashtbl.create 13 in
655 fun (field_name, (typ, _, _)) ->
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);
661 Hashtbl.add hash field_name typ
664 (* Now get a type for each structure field. *)
666 fun (field_name, ft) ->
668 let field_name = struct_name ^ "_" ^ field_name in
669 let typ = Hashtbl.find hash field_name in
670 Some (field_name, (typ, ft))
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;
678 (struct_name, kernels, field_types)
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.
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
698 else if String.starts_with arch "sparc" then
701 failwith (sprintf "endian_of_architecture: cannot parse %S" arch)
706 fun (struct_name, kernels, field_types) ->
707 let hash = Hashtbl.create 13 in
712 fun (basename, version, arch, (fields, total_size)) ->
713 let key = endian_of_architecture arch, fields in
715 try Hashtbl.find hash key
718 xs := (!i, key) :: !xs; Hashtbl.add hash key !i;
720 (basename, version, arch, total_size, j)
722 let parsers = List.rev !xs in
723 struct_name, kernels, field_types, parsers
726 (* How much did we save by sharing? *)
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)
736 (* Extend the parsers fields by adding on any optional fields which
737 * are not actually present in the specific kernel.
741 fun (struct_name, kernels, field_types, parsers) ->
742 let parsers = List.map (
743 fun (i, (endian, fields)) ->
744 let fields_not_present =
746 fun (field_name, _) ->
747 if List.mem_assoc field_name fields then None
750 (i, (endian, fields, fields_not_present))
752 (struct_name, kernels, field_types, parsers)
755 (* Let's generate some code! *)
758 fun (struct_name, kernels, field_types, parsers) ->
759 (* Dummy location required - there are no real locations for
762 let _loc = Loc.ghost in
764 (* The structure type. *)
765 let struct_type, struct_sig =
766 let fields = List.map (
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 >>
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
786 (* Create a "field signature" which describes certain aspects
787 * of the fields which vary between kernel versions.
789 let fieldsig_type, fieldsigs =
791 let fields = List.map (
793 let fsname = "__fs_" ^ name in
794 <:ctyp< $lid:fsname$ : Virt_mem_types.fieldsig >>
796 let fields = concat_record_fields _loc fields in
797 <:str_item< type fs_t = { $fields$ } >> in
799 let fieldsigs = List.map (
800 fun (i, (_, fields, fields_not_present)) ->
801 let make_fieldsig field_name available offset =
803 if available then <:expr< true >> else <:expr< false >> in
804 let fsname = "__fs_" ^ field_name in
807 { Virt_mem_types.field_available = $available$;
808 field_offset = $`int:offset$ }
811 let fields = List.map (
812 fun (field_name, (_, offset, _)) ->
813 make_fieldsig field_name true offset
815 let fields_not_present = List.map (
817 make_fieldsig field_name false (-1)
818 ) fields_not_present in
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
825 let $lid:fsname$ = $fieldsigs$
829 let fieldsigs = concat_str_items _loc fieldsigs in
831 fieldsig_type, fieldsigs in
833 (* The shared parser functions.
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
842 let parser_stmts, parser_subs =
843 let parser_stmts = List.map (
845 let fnname = sprintf "parser_%d" i in
847 let $lid:fnname$ bits = $str:fnname$
851 let parser_stmts = concat_str_items _loc parser_stmts in
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
859 | Bitstring.LittleEndian -> "littleendian"
860 | Bitstring.BigEndian -> "bigendian"
861 | _ -> assert false in
863 (* Fields must be sorted by offset, otherwise bitmatch
866 let cmp (_, (_, o1, _)) (_, (_, o2, _)) = compare o1 o2 in
867 let fields = List.sort ~cmp fields in
868 String.concat ";\n " (
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)
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
887 failwith (sprintf "%s: not found in field_types"
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
897 sprintf "%s = %s" field_name field_name
899 sprintf "%s = Some %s" field_name field_name
901 let assignments_not_present =
903 fun field_name -> sprintf "%s = None" field_name
904 ) fields_not_present in
908 (assignments @ assignments_not_present) in
916 raise (Virt_mem_types.ParseError (struct_name, %S, match_err))"
917 patterns assignments fnname in
922 parser_stmts, parser_subs in
924 (* Define a map from kernel versions to parsing functions. *)
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
932 let v = ($lid:parserfn$, $`int:total_size$, $lid:fsname$)
933 let map = StringMap.add $str:version$ v map
935 ) <:str_item< let map = StringMap.empty >> kernels in
938 module StringMap = Map.Make (String) ;;
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
948 let $lid:"field_signature_of_"^field_name$ version =
949 let _, _, fs = StringMap.find version map in
954 let fsaccess = concat_str_items _loc fields in
956 let fields = List.map (
957 fun (field_name, _) ->
959 val $lid:"field_signature_of_"^field_name$ : kernel_version ->
960 Virt_mem_types.fieldsig
964 let fsaccess_sig = concat_sig_items _loc fields in
966 fsaccess, fsaccess_sig in
968 (* Code (.ml file). *)
969 let code = <:str_item<
971 let struct_name = $str:struct_name$
972 let match_err = "failed to match kernel structure" ;;
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
984 let $lid:struct_name^"_of_bits"$ version bits =
985 let parsefn, _, _ = StringMap.find version map in
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
995 (* Interface (.mli file). *)
996 let interface = <:sig_item<
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;;
1010 (struct_name, code, interface, parser_subs)
1013 (* Finally generate the output files. *)
1014 let re_subst = Pcre.regexp "^(.*)\"(parser_\\d+)\"(.*)$" in
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;
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;
1027 let new_output_file = output_file ^ ".new" in
1028 Printers.OCaml.print_implem ~output_file:new_output_file code;
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
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
1039 * Any edits you make to this file will be lost.
1041 * To update this file from the latest kernel database, it is recommended
1042 * that you do 'make update-kernel-structs'.
1046 let line = input_line ichan in
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
1056 output_string ochan line; output_char ochan '\n';
1059 (try loop () with End_of_file -> ());
1064 Unix.unlink new_output_file