--- /dev/null
+(* Memory info for virtual domains.
+ (C) Copyright 2008 Richard W.M. Jones, Red Hat Inc.
+ http://libvirt.org/
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+*)
+
+(* This program takes the kernel database (in kernels/ in toplevel
+ directory) and generates parsing code for the various structures
+ in the kernel that we are interested in.
+
+ The output programs -- *.ml, *.mli files of generated code -- go
+ into lib/ at the toplevel, eg. lib/virt_mem_kernels.ml
+
+ The stuff at the top of this file determine what structures
+ we try to parse.
+*)
+
+type struct_t = {
+ good_fields : string list;
+ field_metadata : (string * field_metadata_t) list;
+}
+and field_metadata_t =
+ | VoidPointerIsReally of string
+ | ListHeadIsReally of string
+
+(*----------------------------------------------------------------------
+ * This controls what structures & fields we will parse out.
+ *----------------------------------------------------------------------*)
+let good_structs = [
+ "task_struct", {
+ good_fields = [ "tasks'next"; "tasks'prev";
+ "run_list'next"; "run_list'prev";
+ "state"; "prio"; "static_prio"; "normal_prio";
+ "comm"; "pid" ];
+ field_metadata = [
+ "tasks'next", ListHeadIsReally "task_struct";
+ "tasks'prev", ListHeadIsReally "task_struct";
+ "run_list'next", ListHeadIsReally "task_struct";
+ "run_list'prev", ListHeadIsReally "task_struct";
+ ];
+ };
+ "net_device", {
+ good_fields = [ "dev_list'prev"; "dev_list'next"; "next";
+ "ip_ptr"; "ip6_ptr";
+ "name"; "flags"; "operstate"; "mtu"; "perm_addr";
+ "addr_len" ];
+ field_metadata = [
+ "dev_list'next", ListHeadIsReally "net_device";
+ "dev_list'prev", ListHeadIsReally "net_device";
+ "ip_ptr", VoidPointerIsReally "in_device";
+ "ip6_ptr", VoidPointerIsReally "inet6_dev";
+ ];
+ };
+ "net", {
+ good_fields = [ "dev_base_head'next"; "dev_base_head'prev" ];
+ field_metadata = [
+ "dev_base_head'next", ListHeadIsReally "net_device";
+ "dev_base_head'prev", ListHeadIsReally "net_device";
+ ];
+ };
+ "in_device", {
+ good_fields = [ "ifa_list" ];
+ field_metadata = [];
+ };
+ "inet6_dev", {
+ good_fields = [ "addr_list" ];
+ field_metadata = [];
+ };
+ "in_ifaddr", {
+ good_fields = [ "ifa_next"; "ifa_local"; "ifa_address";
+ "ifa_mask"; "ifa_broadcast" ];
+ field_metadata = [];
+ };
+ "inet6_ifaddr", {
+ good_fields = [ "prefix_len"; "lst_next" ];
+ field_metadata = [];
+ };
+]
+
+let debug = true
+
+open Camlp4.PreCast
+open Syntax
+(*open Ast*)
+
+open ExtList
+open ExtString
+open Printf
+
+module PP = Pahole_parser
+module SC = Struct_classify
+
+let (//) = Filename.concat
+
+(* Couple of handy camlp4 construction functions which do some
+ * things that ought to be easy/obvious but aren't.
+ *
+ * 'concat_str_items' concatenates a list of str_item together into
+ * one big str_item.
+ *
+ * 'concat_record_fields' concatenates a list of records fields into
+ * a record. The list must have at least one element.
+ *
+ * 'build_record' builds a record out of record fields.
+ *
+ * 'build_tuple_from_exprs' builds an arbitrary length tuple from
+ * a list of expressions of length >= 2.
+ *
+ * Thanks to bluestorm on #ocaml for getting these working.
+ *)
+let concat_str_items _loc items =
+ match items with
+ | [] -> <:str_item< >>
+ | x :: xs ->
+ List.fold_left (fun xs x -> <:str_item< $xs$ $x$ >>) x xs
+
+let concat_sig_items _loc items =
+ match items with
+ | [] -> <:sig_item< >>
+ | x :: xs ->
+ List.fold_left (fun xs x -> <:sig_item< $xs$ $x$ >>) x xs
+
+let concat_record_fields _loc fields =
+ match fields with
+ | [] -> assert false
+ | f :: fs ->
+ List.fold_left (fun fs f -> <:ctyp< $fs$ ; $f$ >>) f fs
+
+let concat_record_bindings _loc rbs =
+ match rbs with
+ | [] -> assert false
+ | rb :: rbs ->
+ List.fold_left (fun rbs rb -> <:rec_binding< $rbs$ ; $rb$ >>) rb rbs
+
+let build_record _loc rbs =
+ Ast.ExRec (_loc, rbs, Ast.ExNil _loc)
+
+let build_tuple_from_exprs _loc exprs =
+ match exprs with
+ | [] | [_] -> assert false
+ | x :: xs ->
+ Ast.ExTup (_loc,
+ List.fold_left (fun xs x -> Ast.ExCom (_loc, x, xs)) x xs)
+
+(* Start of the main program. *)
+let () =
+ let quick = ref false in
+ let anon_args = ref [] in
+
+ let argspec = Arg.align [
+ "--quick", Arg.Set quick, " Quick mode (just for testing)";
+ ] in
+
+ let anon_arg str = anon_args := str :: !anon_args in
+ let usage = "\
+compile-kerneldb: Turn kernels database into code modules.
+
+Usage:
+ compile-kerneldb [-options] <kerneldb> <outputdir>
+
+For example, from the top level of the virt-mem source tree:
+ compile-kerneldb kernels/ lib/
+
+Options:
+" in
+ Arg.parse argspec anon_arg usage;
+
+ let quick = !quick in
+ let anon_args = List.rev !anon_args in
+
+ let kernelsdir, outputdir =
+ match anon_args with
+ | [kd;od] -> kd,od
+ | _ ->
+ eprintf "compile-kerneldb <kerneldb> <outputdir>\n";
+ exit 2 in
+
+ (* Read in the list of kernels from the kerneldb. *)
+ let kernels = PP.list_kernels kernelsdir in
+
+ (* In quick mode, just process the first few kernels. *)
+ let kernels = if quick then List.take 10 kernels else kernels in
+
+ let good_struct_names = List.map fst good_structs in
+
+ (* Load in the structures. *)
+ let nr_kernels = List.length kernels in
+ let kernels = List.mapi (
+ fun i info ->
+ printf "Loading kernel data file %d/%d\r%!" (i+1) nr_kernels;
+
+ let structures = PP.load_structures info good_struct_names in
+
+ (info, structures)
+ ) kernels in
+
+ (* Keep only the good fields. *)
+ let kernels = List.map (
+ fun (info, structures) ->
+ let structures = List.map (
+ fun (struct_name, structure) ->
+ let { good_fields = good_fields } =
+ List.assoc struct_name good_structs in
+ let fields = List.filter (
+ fun { PP.field_name = name } -> List.mem name good_fields
+ ) structure.PP.struct_fields in
+ struct_name, { structure with PP.struct_fields = fields }
+ ) structures in
+ (info, structures)
+ ) kernels in
+
+ (* Turn anonymous list_head and void * pointers into pointers to
+ * known structure types, where we have that meta-information.
+ *)
+ let kernels = List.map (
+ fun (info, structures) ->
+ let structures = List.map (
+ fun (struct_name, structure) ->
+ let { field_metadata = metadata } =
+ List.assoc struct_name good_structs in
+ let fields = structure.PP.struct_fields in
+ let fields = List.map (
+ fun ({ PP.field_name = name; PP.field_type = typ } as field) ->
+ try
+ let meta = List.assoc name metadata in
+ let typ =
+ match meta, typ with
+ | ListHeadIsReally s, PP.FAnonListHeadPointer ->
+ PP.FListHeadPointer s
+ | VoidPointerIsReally s, PP.FVoidPointer ->
+ PP.FStructPointer s
+ | _, typ -> typ in
+ { field with PP.field_type = typ }
+ with
+ Not_found -> field
+ ) fields in
+ struct_name, { structure with PP.struct_fields = fields }
+ ) structures in
+ (info, structures)
+ ) kernels in
+
+ if debug then
+ List.iter (
+ fun (info, structures) ->
+ printf "\n%s ----------\n" (PP.string_of_info info);
+ List.iter (
+ fun (_, structure) ->
+ printf "%s\n\n" (PP.string_of_structure structure);
+ ) structures;
+ ) kernels;
+
+ (* First output file is a simple list of kernels, to support the
+ * 'virt-mem --list-kernels' option.
+ *)
+ let () =
+ let _loc = Loc.ghost in
+
+ let versions = List.map (
+ fun ({ PP.kernel_version = version }, _) -> version
+ ) kernels in
+
+ (* Sort them in reverse because we are going to generate the
+ * final list in reverse.
+ *)
+ let cmp a b = compare b a in
+ let versions = List.sort ~cmp versions in
+
+ let xs =
+ List.fold_left (fun xs version -> <:expr< $str:version$ :: $xs$ >>)
+ <:expr< [] >> versions in
+
+ let code = <:str_item<
+ let kernels = $xs$
+ >> in
+
+ let output_file = outputdir // "virt_mem_kernels.ml" in
+ printf "Writing list of kernels to %s ...\n%!" output_file;
+ Printers.OCaml.print_implem ~output_file code in
+
+ (* We want to track single structures as they have changed over
+ * time, ie. over kernel versions. Transpose our dataset so we are
+ * looking at structures over time.
+ *)
+ let structures = PP.transpose good_struct_names kernels in
+
+ let kernels = () in ignore (kernels); (* garbage collect *)
+
+ let structures =
+ List.map (
+ fun (struct_name, kernels) ->
+ let all_fields = PP.get_fields kernels in
+ (struct_name, (kernels, all_fields))
+ ) structures in
+
+ if debug then
+ List.iter (
+ fun (struct_name, (kernels, all_fields)) ->
+ printf "struct %s:\n" struct_name;
+ printf " structure occurs in %d kernel versions\n"
+ (List.length kernels);
+ printf " union of fields found:\n";
+ List.iter (
+ fun (field_name, field_type) ->
+ printf " %s %s\n" (PP.string_of_f_type field_type) field_name
+ ) all_fields
+ ) structures;
+
+ (* Now perform the minimization step for each structure.
+ * We do separate minimization for:
+ * - shape field structures
+ * - content field structures
+ * - parsers
+ *)
+ let structures =
+ List.map (
+ fun (struct_name, (kernels, all_fields)) ->
+ let sflist, sfhash =
+ SC.minimize_shape_field_structs struct_name good_struct_names
+ kernels in
+
+ let cflist, cfhash =
+ SC.minimize_content_field_structs struct_name good_struct_names
+ kernels in
+
+ let palist, pahash =
+ SC.minimize_parsers struct_name kernels sfhash cfhash in
+
+ (struct_name, (kernels, all_fields,
+ sflist, sfhash, cflist, cfhash, palist, pahash))
+ ) structures in
+
+ if debug then
+ List.iter (
+ fun (struct_name,
+ (kernels, all_fields,
+ sflist, sfhash, cflist, cfhash, palist, pahash)) ->
+ printf "struct %s:\n" struct_name;
+
+ printf " shape field structures:\n";
+ List.iter (
+ fun { SC.sf_name = name; sf_fields = fields } ->
+ printf " type %s = {\n" name;
+ List.iter (
+ fun { PP.field_name = name; field_type = typ } ->
+ printf " %s %s;\n" (PP.string_of_f_type typ) name
+ ) fields;
+ printf " }\n";
+ ) sflist;
+
+ printf " content field structures:\n";
+ List.iter (
+ fun { SC.cf_name = name; cf_fields = fields } ->
+ printf " type %s = {\n" name;
+ List.iter (
+ fun { PP.field_name = name; field_type = typ } ->
+ printf " %s %s;\n" (PP.string_of_f_type typ) name
+ ) fields;
+ printf " }\n";
+ ) cflist;
+
+ printf " parsers:\n";
+ List.iter (
+ fun { SC.pa_name = name;
+ pa_shape_field_struct = sf;
+ pa_content_field_struct = cf } ->
+ printf " let %s = ...\n" name;
+ printf " -> (%s, %s)\n" sf.SC.sf_name cf.SC.cf_name
+ ) palist
+ ) structures;
git.annexia.org / virt-mem.git / blobdiff