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 module PP = Pahole_parser
146 let (//) = Filename.concat
148 (* Couple of handy camlp4 construction functions which do some
149 * things that ought to be easy/obvious but aren't.
151 * 'concat_str_items' concatenates a list of str_item together into
154 * 'concat_record_fields' concatenates a list of records fields into
155 * a record. The list must have at least one element.
157 * 'build_record' builds a record out of record fields.
159 * 'build_tuple_from_exprs' builds an arbitrary length tuple from
160 * a list of expressions of length >= 2.
162 * Thanks to bluestorm on #ocaml for getting these working.
164 let concat_str_items _loc items =
166 | [] -> <:str_item< >>
168 List.fold_left (fun xs x -> <:str_item< $xs$ $x$ >>) x xs
170 let concat_sig_items _loc items =
172 | [] -> <:sig_item< >>
174 List.fold_left (fun xs x -> <:sig_item< $xs$ $x$ >>) x xs
176 let concat_record_fields _loc fields =
180 List.fold_left (fun fs f -> <:ctyp< $fs$ ; $f$ >>) f fs
182 let concat_record_bindings _loc rbs =
186 List.fold_left (fun rbs rb -> <:rec_binding< $rbs$ ; $rb$ >>) rb rbs
188 let build_record _loc rbs =
189 Ast.ExRec (_loc, rbs, Ast.ExNil _loc)
191 let build_tuple_from_exprs _loc exprs =
193 | [] | [_] -> assert false
196 List.fold_left (fun xs x -> Ast.ExCom (_loc, x, xs)) x xs)
199 let args = Array.to_list Sys.argv in
201 let kernelsdir, outputdir =
205 let arg0 = Filename.basename Sys.executable_name in
206 eprintf "%s - Turn kernels database into code modules.
209 %s <kernelsdir> <outputdir>
211 Example (from toplevel of virt-mem source tree):
216 let kernels = PP.list_kernels kernelsdir in
217 let nr_kernels = List.length kernels in
219 let kernels = List.mapi (
221 printf "Loading kernel data file %d/%d\r%!" (i+1) nr_kernels;
223 let struct_names = List.map fst structs in
224 let structures = PP.load_structures info struct_names in
226 (* Make sure we got all the mandatory structures & fields. *)
229 { mandatory_struct = mandatory; fields = wanted_fields }) ->
232 List.find (fun s -> struct_name = s.PP.struct_name)
235 (* Check we have all the mandatory fields. *)
236 let all_fields = s.PP.struct_fields in
238 fun (wanted_field, { mandatory_field = mandatory }) ->
241 fun { PP.field_name = name } -> name = wanted_field
243 if mandatory && not got_it then (
244 eprintf "%s: structure %s is missing required field %s\n"
245 info.PP.basename struct_name wanted_field;
246 eprintf "fields found in this structure:\n";
248 fun { PP.field_name = name } -> eprintf "\t%s\n" name
256 failwith (sprintf "%s: structure %s not found in this kernel"
257 info.PP.basename struct_name)
262 fun ({ PP.struct_name = struct_name; PP.struct_fields = fields }
264 let { fields = wanted_fields } = List.assoc struct_name structs in
266 (* That got us all the fields, but we only care about
269 let fields = List.filter (
270 fun { PP.field_name = name } -> List.mem_assoc name wanted_fields
273 (* Prefix all the field names with the structure name. *)
276 fun ({ PP.field_name = name } as field) ->
277 let name = struct_name ^ "_" ^ name in
278 { field with PP.field_name = name }
280 { structure with PP.struct_fields = fields }
288 fun (info, structures) ->
289 printf "%s ----------\n" (PP.string_of_info info);
292 printf "%s\n\n" (PP.string_of_structure structure);
296 (* First output file is a simple list of kernels, to support the
297 * 'virt-mem --list-kernels' option.
300 let _loc = Loc.ghost in
302 let versions = List.map (
303 fun ({ PP.kernel_version = version }, _) -> version
306 (* Sort them in reverse because we are going to generate the
307 * final list in reverse.
309 let cmp a b = compare b a in
310 let versions = List.sort ~cmp versions in
313 List.fold_left (fun xs version -> <:expr< $str:version$ :: $xs$ >>)
314 <:expr< [] >> versions in
316 let code = <:str_item<
320 let output_file = outputdir // "virt_mem_kernels.ml" in
321 printf "Writing list of kernels to %s ...\n%!" output_file;
322 Printers.OCaml.print_implem ~output_file code in
324 (* We'll generate a code file for each structure type (eg. task_struct
325 * across all kernel versions), so rearrange 'kernels' for that purpose.
327 * XXX This loop is O(n^3), luckily n is small!
331 fun (struct_name, _) ->
334 fun (info, structures) ->
338 fun { PP.struct_name = name } -> name = struct_name
340 Some (info, structure)
345 (* Sort the kernels, which makes the generated output more stable
346 * and makes patches more useful.
348 let kernels = List.sort kernels in
353 let kernels = () in ignore kernels; (* garbage collect *)
356 (* Get just the field types.
358 * It's plausible that a field with the same name has a different
359 * type between kernel versions, so we must check that didn't
362 * This is complicated because of non-mandatory fields, which don't
363 * appear in every kernel version.
365 let files = List.map (
366 fun (struct_name, kernels) ->
368 (* Get the list of fields expected in this structure. *)
369 let { fields = struct_fields } = List.assoc struct_name structs in
371 (* Get the list of fields that we found in each kernel version. *)
374 (List.map (fun (_, _, _, (fields, _)) -> fields) kernels) in
376 (* Determine a hash from each field name to the type. As we add
377 * fields, we might get a conflicting type (meaning the type
378 * changed between kernel versions).
380 let hash = Hashtbl.create 13 in
383 fun (field_name, (typ, _, _)) ->
385 let field_type = Hashtbl.find hash field_name in
386 if typ <> field_type then
387 failwith (sprintf "%s.%s: structure field changed type between kernel versions" struct_name field_name);
389 Hashtbl.add hash field_name typ
392 (* Now get a type for each structure field. *)
394 fun (field_name, ft) ->
396 let field_name = struct_name ^ "_" ^ field_name in
397 let typ = Hashtbl.find hash field_name in
398 Some (field_name, (typ, ft))
401 sprintf "%s.%s: this field was not found in any kernel version"
402 struct_name field_name in
403 if ft.mandatory_field then failwith msg else prerr_endline msg;
406 (struct_name, kernels, field_types)
409 (* To minimize generated code size, we want to fold together all
410 * structures where the particulars (eg. offsets, sizes, endianness)
411 * of the fields we care about are the same -- eg. between kernel
412 * versions which are very similar.
414 let endian_of_architecture arch =
415 if String.starts_with arch "i386" ||
416 String.starts_with arch "i486" ||
417 String.starts_with arch "i586" ||
418 String.starts_with arch "i686" ||
419 String.starts_with arch "x86_64" ||
420 String.starts_with arch "x86-64" then
421 Bitstring.LittleEndian
422 else if String.starts_with arch "ia64" then
423 Bitstring.LittleEndian (* XXX usually? *)
424 else if String.starts_with arch "ppc" then
426 else if String.starts_with arch "sparc" then
429 failwith (sprintf "endian_of_architecture: cannot parse %S" arch)
434 fun (struct_name, kernels, field_types) ->
435 let hash = Hashtbl.create 13 in
440 fun (basename, version, arch, (fields, total_size)) ->
441 let key = endian_of_architecture arch, fields in
443 try Hashtbl.find hash key
446 xs := (!i, key) :: !xs; Hashtbl.add hash key !i;
448 (basename, version, arch, total_size, j)
450 let parsers = List.rev !xs in
451 struct_name, kernels, field_types, parsers
454 (* How much did we save by sharing? *)
457 fun (struct_name, kernels, _, parsers) ->
458 printf "struct %s:\n" struct_name;
459 printf " number of kernel versions: %d\n" (List.length kernels);
460 printf " number of parser functions needed after sharing: %d\n"
461 (List.length parsers)
464 (* Extend the parsers fields by adding on any optional fields which
465 * are not actually present in the specific kernel.
469 fun (struct_name, kernels, field_types, parsers) ->
470 let parsers = List.map (
471 fun (i, (endian, fields)) ->
472 let fields_not_present =
474 fun (field_name, _) ->
475 if List.mem_assoc field_name fields then None
478 (i, (endian, fields, fields_not_present))
480 (struct_name, kernels, field_types, parsers)
483 (* Let's generate some code! *)
486 fun (struct_name, kernels, field_types, parsers) ->
487 (* Dummy location required - there are no real locations for
490 let _loc = Loc.ghost in
492 (* The structure type. *)
493 let struct_type, struct_sig =
494 let fields = List.map (
496 | (name, (`Int, { mandatory_field = true })) ->
497 <:ctyp< $lid:name$ : int64 >>
498 | (name, (`Int, { mandatory_field = false })) ->
499 <:ctyp< $lid:name$ : int64 option >>
500 | (name, ((`VoidPtr|`Ptr _), { mandatory_field = true })) ->
501 <:ctyp< $lid:name$ : Virt_mem_mmap.addr >>
502 | (name, ((`VoidPtr|`Ptr _), { mandatory_field = false })) ->
503 <:ctyp< $lid:name$ : Virt_mem_mmap.addr option >>
504 | (name, (`Str _, { mandatory_field = true })) ->
505 <:ctyp< $lid:name$ : string >>
506 | (name, (`Str _, { mandatory_field = false })) ->
507 <:ctyp< $lid:name$ : string option >>
509 let fields = concat_record_fields _loc fields in
510 let struct_type = <:str_item< type t = { $fields$ } >> in
511 let struct_sig = <:sig_item< type t = { $fields$ } >> in
512 struct_type, struct_sig in
514 (* Create a "field signature" which describes certain aspects
515 * of the fields which vary between kernel versions.
517 let fieldsig_type, fieldsigs =
519 let fields = List.map (
521 let fsname = "__fs_" ^ name in
522 <:ctyp< $lid:fsname$ : Virt_mem_types.fieldsig >>
524 let fields = concat_record_fields _loc fields in
525 <:str_item< type fs_t = { $fields$ } >> in
527 let fieldsigs = List.map (
528 fun (i, (_, fields, fields_not_present)) ->
529 let make_fieldsig field_name available offset =
531 if available then <:expr< true >> else <:expr< false >> in
532 let fsname = "__fs_" ^ field_name in
535 { Virt_mem_types.field_available = $available$;
536 field_offset = $`int:offset$ }
539 let fields = List.map (
540 fun (field_name, (_, offset, _)) ->
541 make_fieldsig field_name true offset
543 let fields_not_present = List.map (
545 make_fieldsig field_name false (-1)
546 ) fields_not_present in
548 let fieldsigs = fields @ fields_not_present in
549 let fsname = sprintf "fieldsig_%d" i in
550 let fieldsigs = concat_record_bindings _loc fieldsigs in
551 let fieldsigs = build_record _loc fieldsigs in
553 let $lid:fsname$ = $fieldsigs$
557 let fieldsigs = concat_str_items _loc fieldsigs in
559 fieldsig_type, fieldsigs in
561 (* The shared parser functions.
563 * We could include bitmatch statements directly in here, but
564 * what happens is that the macros get expanded here, resulting
565 * in (even more) unreadable generated code. So instead just
566 * do a textual substitution later by post-processing the
567 * generated files. Not type-safe, but we can't have
570 let parser_stmts, parser_subs =
571 let parser_stmts = List.map (
573 let fnname = sprintf "parser_%d" i in
575 let $lid:fnname$ bits = $str:fnname$
579 let parser_stmts = concat_str_items _loc parser_stmts in
581 (* What gets substituted for "parser_NN" ... *)
582 let parser_subs = List.map (
583 fun (i, (endian, fields, fields_not_present)) ->
584 let fnname = sprintf "parser_%d" i in
587 | Bitstring.LittleEndian -> "littleendian"
588 | Bitstring.BigEndian -> "bigendian"
589 | _ -> assert false in
591 (* Fields must be sorted by offset, otherwise bitmatch
594 let cmp (_, (_, o1, _)) (_, (_, o2, _)) = compare o1 o2 in
595 let fields = List.sort ~cmp fields in
596 String.concat ";\n " (
599 | (field_name, ((`Int|`Ptr _|`VoidPtr), offset, size)) ->
600 (* 'zero+' is a hack to force the type to int64. *)
601 sprintf "%s : zero+%d : offset(%d), %s"
602 field_name (size*8) (offset*8) endian
603 | (field_name, (`Str width, offset, size)) ->
604 sprintf "%s : %d : offset(%d), string"
605 field_name (width*8) (offset*8)
610 fun (field_name, typ) ->
611 let (_, { mandatory_field = mandatory;
612 list_head_adjustment = list_head_adjustment }) =
613 try List.assoc field_name field_types
615 failwith (sprintf "%s: not found in field_types"
617 match typ, mandatory, list_head_adjustment with
618 | (`Ptr "list_head", offset, size), true, true ->
619 sprintf "%s = Int64.sub %s %dL"
620 field_name field_name offset
621 | (`Ptr "list_head", offset, size), false, true ->
622 sprintf "%s = Some (Int64.sub %s %dL)"
623 field_name field_name offset
625 sprintf "%s = %s" field_name field_name
627 sprintf "%s = Some %s" field_name field_name
629 let assignments_not_present =
631 fun field_name -> sprintf "%s = None" field_name
632 ) fields_not_present in
636 (assignments @ assignments_not_present) in
644 raise (Virt_mem_types.ParseError (struct_name, %S, match_err))"
645 patterns assignments fnname in
650 parser_stmts, parser_subs in
652 (* Define a map from kernel versions to parsing functions. *)
654 let stmts = List.fold_left (
655 fun stmts (_, version, arch, total_size, i) ->
656 let parserfn = sprintf "parser_%d" i in
657 let fsname = sprintf "fieldsig_%d" i in
660 let v = ($lid:parserfn$, $`int:total_size$, $lid:fsname$)
661 let map = StringMap.add $str:version$ v map
663 ) <:str_item< let map = StringMap.empty >> kernels in
666 module StringMap = Map.Make (String) ;;
670 (* Accessors for the field signatures. *)
671 let fsaccess, fsaccess_sig =
672 let fields = List.map (
673 fun (field_name, _) ->
674 let fsname = "__fs_" ^ field_name in
676 let $lid:"field_signature_of_"^field_name$ version =
677 let _, _, fs = StringMap.find version map in
682 let fsaccess = concat_str_items _loc fields in
684 let fields = List.map (
685 fun (field_name, _) ->
687 val $lid:"field_signature_of_"^field_name$ : kernel_version ->
688 Virt_mem_types.fieldsig
692 let fsaccess_sig = concat_sig_items _loc fields in
694 fsaccess, fsaccess_sig in
696 (* Code (.ml file). *)
697 let code = <:str_item<
699 let struct_name = $str:struct_name$
700 let match_err = "failed to match kernel structure" ;;
707 type kernel_version = string
708 let $lid:struct_name^"_known"$ version = StringMap.mem version map
709 let $lid:struct_name^"_size"$ version =
710 let _, size, _ = StringMap.find version map in
712 let $lid:struct_name^"_of_bits"$ version bits =
713 let parsefn, _, _ = StringMap.find version map in
715 let $lid:"get_"^struct_name$ version mem addr =
716 let parsefn, size, _ = StringMap.find version map in
717 let bytes = Virt_mem_mmap.get_bytes mem addr size in
718 let bits = Bitstring.bitstring_of_string bytes in
723 (* Interface (.mli file). *)
724 let interface = <:sig_item<
727 val struct_name : string
728 type kernel_version = string
729 val $lid:struct_name^"_known"$ : kernel_version -> bool
730 val $lid:struct_name^"_size"$ : kernel_version -> int
731 val $lid:struct_name^"_of_bits"$ :
732 kernel_version -> Bitstring.bitstring -> t
733 val $lid:"get_"^struct_name$ : kernel_version ->
734 ('a, 'b, [`HasMapping]) Virt_mem_mmap.t -> Virt_mem_mmap.addr -> t;;
738 (struct_name, code, interface, parser_subs)
741 (* Finally generate the output files. *)
742 let re_subst = Pcre.regexp "^(.*)\"(parser_\\d+)\"(.*)$" in
745 fun (struct_name, code, interface, parser_subs) ->
746 (* Interface (.mli file). *)
747 let output_file = outputdir // "kernel_" ^ struct_name ^ ".mli" in
748 printf "Writing %s interface to %s ...\n%!" struct_name output_file;
749 Printers.OCaml.print_interf ~output_file interface;
751 (* Implementation (.ml file). *)
752 let output_file = outputdir // "kernel_" ^ struct_name ^ ".ml" in
753 printf "Writing %s implementation to %s ...\n%!" struct_name output_file;
755 let new_output_file = output_file ^ ".new" in
756 Printers.OCaml.print_implem ~output_file:new_output_file code;
758 (* Substitute the parser bodies in the output file. *)
759 let ichan = open_in new_output_file in
760 let ochan = open_out output_file in
762 output_string ochan "\
763 (* WARNING: This file and the corresponding mli (interface) are
764 * automatically generated by the extract/codegen/kerneldb_to_parser.ml
767 * Any edits you make to this file will be lost.
769 * To update this file from the latest kernel database, it is recommended
770 * that you do 'make update-kernel-structs'.
774 let line = input_line ichan in
776 if Pcre.pmatch ~rex:re_subst line then (
777 let subs = Pcre.exec ~rex:re_subst line in
778 let start = Pcre.get_substring subs 1 in
779 let template = Pcre.get_substring subs 2 in
780 let rest = Pcre.get_substring subs 3 in
781 let sub = List.assoc template parser_subs in
784 output_string ochan line; output_char ochan '\n';
787 (try loop () with End_of_file -> ());
792 Unix.unlink new_output_file