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 "dev_addr", ordinary_field;
87 opener = "struct net {"; closer = "};"; mandatory_struct = false;
90 (* Don't do list_head adjustment on this field, because it points
91 * to a net_device struct.
93 { mandatory_field = true; list_head_adjustment = false };
108 let (//) = Filename.concat
110 (* Couple of handy camlp4 construction functions which do some
111 * things that ought to be easy/obvious but aren't.
113 * 'concat_str_items' concatenates a list of str_item together into
116 * 'concat_record_fields' concatenates a list of records fields into
117 * a record. The list must have at least one element.
119 * 'build_record' builds a record out of record fields.
121 * 'build_tuple_from_exprs' builds an arbitrary length tuple from
122 * a list of expressions of length >= 2.
124 * Thanks to bluestorm on #ocaml for getting these working.
126 let concat_str_items _loc items =
128 | [] -> <:str_item< >>
130 List.fold_left (fun xs x -> <:str_item< $xs$ $x$ >>) x xs
132 let concat_sig_items _loc items =
134 | [] -> <:sig_item< >>
136 List.fold_left (fun xs x -> <:sig_item< $xs$ $x$ >>) x xs
138 let concat_record_fields _loc fields =
142 List.fold_left (fun fs f -> <:ctyp< $fs$ ; $f$ >>) f fs
144 let concat_record_bindings _loc rbs =
148 List.fold_left (fun rbs rb -> <:rec_binding< $rbs$ ; $rb$ >>) rb rbs
150 let build_record _loc rbs =
151 Ast.ExRec (_loc, rbs, Ast.ExNil _loc)
153 let build_tuple_from_exprs _loc exprs =
155 | [] | [_] -> assert false
158 List.fold_left (fun xs x -> Ast.ExCom (_loc, x, xs)) x xs)
161 let args = Array.to_list Sys.argv in
163 let kernelsdir, outputdir =
167 let arg0 = Filename.basename Sys.executable_name in
168 eprintf "%s - Turn kernels database into code modules.
171 %s <kernelsdir> <outputdir>
173 Example (from toplevel of virt-mem source tree):
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
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
188 (* Parse in the *.info files. These have historically had a few different
189 * formats that we need to support.
191 let infos = List.map (
193 (* Get the basename (for getting the .data file later on). *)
194 let basename = Filename.chop_suffix filename ".info" in
196 let chan = open_in filename in
197 let line = input_line chan in
199 (* Kernel version string. *)
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.
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
211 (* XXX Map name -> PAE, hugemem etc. *)
212 (* name, *) sprintf "%s-%s.%s" version release arch, arch
214 (* New-style "key: value" entries, up to end of file or the first
217 let (*name,*) version, release, arch =
218 (*ref "",*) ref "", ref "", ref "" in
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
231 Not_found | End_of_file ->
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
243 (*printf "%s -> %s %s\n%!" basename version arch;*)
245 (basename, version, arch)
248 let nr_kernels = List.length infos in
250 (* For quick access to the opener strings, build a hash. *)
251 let openers = Hashtbl.create 13 in
253 fun (name, { opener = opener; closer = closer }) ->
254 Hashtbl.add openers opener (closer, name)
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;
262 let file_exists name =
263 try Unix.access name [Unix.F_OK]; true
264 with Unix.Unix_error _ -> false
266 let close_process_in cmd chan =
267 match Unix.close_process_in chan with
268 | Unix.WEXITED 0 -> ()
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
274 eprintf "%s: command stopped by signal %d\n" cmd i; exit 1
277 (* Open the data file, uncompressing it on the fly if necessary. *)
279 if file_exists (basename ^ ".data") then
280 open_in (basename ^ ".data"), close_in
281 else if file_exists (basename ^ ".data.gz") then (
283 sprintf "gzip -cd %s" (Filename.quote (basename ^ ".data.gz")) in
284 Unix.open_process_in cmd, close_process_in cmd
286 else if file_exists (basename ^ ".data.bz2") then (
288 sprintf "bzip2 -cd %s" (Filename.quote (basename ^ ".data.bz2")) in
289 Unix.open_process_in cmd, close_process_in cmd
292 (sprintf "%s: cannot find corresponding data file" basename) in
294 (* Read the data file in, looking for structures of interest to us. *)
295 let bodies = Hashtbl.create 13 in
297 let line = input_line chan in
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.
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
315 failwith (sprintf "%s: %s: %S not matched by closing %S" basename name line closer) in
317 Hashtbl.replace bodies name body
318 with Not_found -> ());
322 (try loop () with End_of_file -> ());
326 (* Make sure we got all the mandatory structures. *)
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)
333 (basename, version, arch, bodies)
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.
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
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
352 let rec parse basename = function
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.
359 let rec loop depth acc = function
361 eprintf "%s: %S has no matching close structure line\n%!"
364 | line :: lines when Pcre.pmatch ~rex:re_structopener line ->
365 loop (depth+1) (line :: acc) lines
367 when depth = 0 && Pcre.pmatch ~rex:re_structcloser line ->
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
374 let nested_body, rest = loop 0 [] lines in
376 (* Then parse the sub-structure. *)
377 let struct_name, nested_body =
378 match nested_body with
381 let subs = Pcre.exec ~rex:re_structcloser closer in
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
387 (* Prefix the sub-fields with the name of the structure. *)
389 match struct_name with
390 | None -> nested_fields
393 fun (name, details) -> (prefix ^ "'" ^ name, details)
396 (* Parse the rest. *)
397 nested_fields @ parse basename rest
399 | line :: lines when Pcre.pmatch ~rex:re_intfield line ->
401 let subs = Pcre.exec ~rex:re_intfield line in
402 let name = Pcre.get_substring subs 1 in
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
409 Not_found -> parse basename lines
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
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
424 Not_found -> parse basename lines
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
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
439 Not_found -> parse basename lines
443 (* Just ignore any other field we can't parse. *)
448 let kernels = List.map (
449 fun (basename, version, arch, bodies) ->
450 let structures = List.filter_map (
451 fun (struct_name, { fields = wanted_fields }) ->
453 try Some (Hashtbl.find bodies struct_name)
454 with Not_found -> None in
458 let body = List.tl body in (* Don't care about opener line. *)
459 let fields = parse basename body in
461 (* Compute total size of the structure. *)
463 let fields = List.map (
464 fun (_, (_, offset, size)) -> offset + size
466 List.fold_left max 0 fields in
468 (* That got us all the fields, but we only care about
471 let fields = List.filter (
472 fun (name, _) -> List.mem_assoc name wanted_fields
475 (* Also check we have all the mandatory fields. *)
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)
482 (* Prefix all the field names with the structure name. *)
484 List.map (fun (name, details) ->
485 struct_name ^ "_" ^ name, details) fields in
487 Some (struct_name, (fields, total_size))
490 (basename, version, arch, structures)
495 fun (basename, version, arch, structures) ->
496 printf "%s (version: %s, arch: %s):\n" basename version arch;
498 fun (struct_name, (fields, total_size)) ->
499 printf " struct %s {\n" struct_name;
501 fun (field_name, (typ, offset, size)) ->
504 printf " int %s; " field_name
505 | `Ptr struct_name ->
506 printf " struct %s *%s; " struct_name field_name
508 printf " char %s[%d]; " field_name width
510 printf " /* offset = %d, size = %d */\n" offset size
512 printf " } /* %d bytes */\n\n" total_size;
516 (* First output file is a simple list of kernels, to support the
517 * 'virt-mem --list-kernels' option.
520 let _loc = Loc.ghost in
522 let versions = List.map (fun (_, version, _, _) -> version) kernels in
524 (* Sort them in reverse because we are going to generate the
525 * final list in reverse.
527 let cmp a b = compare b a in
528 let versions = List.sort ~cmp versions in
531 List.fold_left (fun xs version -> <:expr< $str:version$ :: $xs$ >>)
532 <:expr< [] >> versions in
534 let code = <:str_item<
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
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.
545 * XXX This loop is O(n^3), luckily n is small!
552 fun (basename, version, arch, structures) ->
553 try Some (basename, version, arch, List.assoc name structures)
554 with Not_found -> None
557 (* Sort the kernels, which makes the generated output more stable
558 * and makes patches more useful.
560 let kernels = List.sort kernels in
565 let kernels = () in ignore kernels; (* garbage collect *)
567 (* Get just the field types.
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
573 * This is complicated because of non-mandatory fields, which don't
574 * appear in every kernel version.
576 let files = List.map (
577 fun (struct_name, kernels) ->
579 (* Get the list of fields expected in this structure. *)
580 let { fields = struct_fields } = List.assoc struct_name structs in
582 (* Get the list of fields that we found in each kernel version. *)
585 (List.map (fun (_, _, _, (fields, _)) -> fields) kernels) in
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).
591 let hash = Hashtbl.create 13 in
594 fun (field_name, (typ, _, _)) ->
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);
600 Hashtbl.add hash field_name typ
603 (* Now get a type for each structure field. *)
605 fun (field_name, ft) ->
607 let field_name = struct_name ^ "_" ^ field_name in
608 let typ = Hashtbl.find hash field_name in
609 Some (field_name, (typ, ft))
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;
617 (struct_name, kernels, field_types)
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.
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
637 else if String.starts_with arch "sparc" then
640 failwith (sprintf "endian_of_architecture: cannot parse %S" arch)
645 fun (struct_name, kernels, field_types) ->
646 let hash = Hashtbl.create 13 in
651 fun (basename, version, arch, (fields, total_size)) ->
652 let key = endian_of_architecture arch, fields in
654 try Hashtbl.find hash key
657 xs := (!i, key) :: !xs; Hashtbl.add hash key !i;
659 (basename, version, arch, total_size, j)
661 let parsers = List.rev !xs in
662 struct_name, kernels, field_types, parsers
665 (* How much did we save by sharing? *)
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)
675 (* Extend the parsers fields by adding on any optional fields which
676 * are not actually present in the specific kernel.
680 fun (struct_name, kernels, field_types, parsers) ->
681 let parsers = List.map (
682 fun (i, (endian, fields)) ->
683 let fields_not_present =
685 fun (field_name, _) ->
686 if List.mem_assoc field_name fields then None
689 (i, (endian, fields, fields_not_present))
691 (struct_name, kernels, field_types, parsers)
694 (* Let's generate some code! *)
697 fun (struct_name, kernels, field_types, parsers) ->
698 (* Dummy location required - there are no real locations for
701 let _loc = Loc.ghost in
703 (* The structure type. *)
704 let struct_type, struct_sig =
705 let fields = List.map (
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 >>
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
725 (* Create a "field signature" which describes certain aspects
726 * of the fields which vary between kernel versions.
728 let fieldsig_type, fieldsigs =
730 let fields = List.map (
732 let fsname = "__fs_" ^ name in
733 <:ctyp< $lid:fsname$ : Virt_mem_types.fieldsig >>
735 let fields = concat_record_fields _loc fields in
736 <:str_item< type fs_t = { $fields$ } >> in
738 let fieldsigs = List.map (
739 fun (i, (_, fields, fields_not_present)) ->
740 let make_fieldsig field_name available offset =
742 if available then <:expr< true >> else <:expr< false >> in
743 let fsname = "__fs_" ^ field_name in
746 { Virt_mem_types.field_available = $available$;
747 field_offset = $`int:offset$ }
750 let fields = List.map (
751 fun (field_name, (_, offset, _)) ->
752 make_fieldsig field_name true offset
754 let fields_not_present = List.map (
756 make_fieldsig field_name false (-1)
757 ) fields_not_present in
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
764 let $lid:fsname$ = $fieldsigs$
768 let fieldsigs = concat_str_items _loc fieldsigs in
770 fieldsig_type, fieldsigs in
772 (* The shared parser functions.
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
781 let parser_stmts, parser_subs =
782 let parser_stmts = List.map (
784 let fnname = sprintf "parser_%d" i in
786 let $lid:fnname$ bits = $str:fnname$
790 let parser_stmts = concat_str_items _loc parser_stmts in
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
798 | Bitstring.LittleEndian -> "littleendian"
799 | Bitstring.BigEndian -> "bigendian"
800 | _ -> assert false in
802 (* Fields must be sorted by offset, otherwise bitmatch
805 let cmp (_, (_, o1, _)) (_, (_, o2, _)) = compare o1 o2 in
806 let fields = List.sort ~cmp fields in
807 String.concat ";\n " (
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)
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
827 failwith (sprintf "%s: not found in field_types"
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
837 sprintf "%s = %s" field_name field_name
839 sprintf "%s = Some %s" field_name field_name
841 let assignments_not_present =
843 fun field_name -> sprintf "%s = None" field_name
844 ) fields_not_present in
848 (assignments @ assignments_not_present) in
856 raise (Virt_mem_types.ParseError (struct_name, %S, match_err))"
857 patterns assignments fnname in
862 parser_stmts, parser_subs in
864 (* Define a map from kernel versions to parsing functions. *)
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
872 let v = ($lid:parserfn$, $`int:total_size$, $lid:fsname$)
873 let map = StringMap.add $str:version$ v map
875 ) <:str_item< let map = StringMap.empty >> kernels in
878 module StringMap = Map.Make (String) ;;
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
888 let $lid:"field_signature_of_"^field_name$ version =
889 let _, _, fs = StringMap.find version map in
894 let fsaccess = concat_str_items _loc fields in
896 let fields = List.map (
897 fun (field_name, _) ->
899 val $lid:"field_signature_of_"^field_name$ : kernel_version ->
900 Virt_mem_types.fieldsig
904 let fsaccess_sig = concat_sig_items _loc fields in
906 fsaccess, fsaccess_sig in
908 (* Code (.ml file). *)
909 let code = <:str_item<
911 let struct_name = $str:struct_name$
912 let match_err = "failed to match kernel structure" ;;
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
924 let $lid:struct_name^"_of_bits"$ version bits =
925 let parsefn, _, _ = StringMap.find version map in
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
935 (* Interface (.mli file). *)
936 let interface = <:sig_item<
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;;
950 (struct_name, code, interface, parser_subs)
953 (* Finally generate the output files. *)
954 let re_subst = Pcre.regexp "^(.*)\"(parser_\\d+)\"(.*)$" in
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;
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;
967 let new_output_file = output_file ^ ".new" in
968 Printers.OCaml.print_implem ~output_file:new_output_file code;
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
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
979 * Any edits you make to this file will be lost.
981 * To update this file from the latest kernel database, it is recommended
982 * that you do 'make update-kernel-structs'.
986 let line = input_line ichan in
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
996 output_string ochan line; output_char ochan '\n';
999 (try loop () with End_of_file -> ());
1004 Unix.unlink new_output_file