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/virt_mem_kernels.ml
27 The stuff at the top of this file determine what structures
32 good_fields : string list;
33 field_metadata : (string * field_metadata_t) list;
35 and field_metadata_t =
36 | VoidPointerIsReally of string
37 | ListHeadIsReally of (string * string) option
39 (*----------------------------------------------------------------------
40 * This controls what structures & fields we will parse out.
41 *----------------------------------------------------------------------*)
44 good_fields = [ "tasks'next"; "tasks'prev";
45 "run_list'next"; "run_list'prev";
46 "state"; "prio"; "static_prio"; "normal_prio";
49 "tasks'next", ListHeadIsReally None;
50 (*"tasks'prev", ListHeadIsReally None; XXX point to 'next *)
51 "run_list'next", ListHeadIsReally None;
52 (*"run_list'prev", ListHeadIsReally None; XXX point to 'next *)
56 good_fields = [ "dev_list'prev"; "dev_list'next"; "next";
58 "name"; "flags"; "operstate"; "mtu"; "perm_addr";
61 "dev_list'next", ListHeadIsReally None;
62 (*"dev_list'prev", ListHeadIsReally None; XXX point to 'next *)
63 "ip_ptr", VoidPointerIsReally "in_device";
64 "ip6_ptr", VoidPointerIsReally "inet6_dev";
68 good_fields = [ "dev_base_head'next"; "dev_base_head'prev" ];
71 ListHeadIsReally (Some ("net_device", "dev_list'next"));
73 ListHeadIsReally (Some ("net_device", "dev_list'next"));
77 good_fields = [ "ifa_list" ];
81 good_fields = [ "addr_list" ];
85 good_fields = [ "ifa_next"; "ifa_local"; "ifa_address";
86 "ifa_mask"; "ifa_broadcast" ];
90 good_fields = [ "prefix_len"; "lst_next" ];
95 (*----------------------------------------------------------------------
96 * These are the code fragments which run over kernel structures.
97 *----------------------------------------------------------------------*)
101 let get_net_devices net_device =
102 let rec loop dev acc =
103 let ipv4 = net_device.ip_ptr.ifa_list in
105 let rec loop2 ipv4 acc =
106 let addr = ipv4.ifa_address :: acc in
107 let ipv4 = ipv4.ifa_next in
111 let acc = ipv4_addresses :: acc in
112 let next = get_net_devices net_device.dev_list'next in
113 if next <> net_device then loop next
118 let get_net_devices_from_init_net net =
119 get_net_devices net.dev_base_head'next
134 module PP = Pahole_parser
135 module SC = Struct_classify
136 module CG = Code_generation
138 let (//) = Filename.concat
140 (* Start of the main program. *)
142 let quick = ref false in
143 let anon_args = ref [] in
145 let argspec = Arg.align [
146 "--quick", Arg.Set quick, " Quick mode (just for testing)";
149 let anon_arg str = anon_args := str :: !anon_args in
151 compile-kerneldb: Turn kernels database into code modules.
154 compile-kerneldb [-options] <kerneldb> <outputdir>
156 For example, from the top level of the virt-mem source tree:
157 compile-kerneldb kernels/ lib/
161 Arg.parse argspec anon_arg usage;
163 let quick = !quick in
164 let anon_args = List.rev !anon_args in
166 let kernelsdir, outputdir =
170 eprintf "compile-kerneldb <kerneldb> <outputdir>\n";
173 (* Read in the list of kernels from the kerneldb. *)
174 let kernels = PP.list_kernels kernelsdir in
176 (* In quick mode, just process the first few kernels. *)
177 let kernels = if quick then List.take 10 kernels else kernels in
179 let good_struct_names = List.map fst good_structs in
181 (* Load in the structures. *)
182 let nr_kernels = List.length kernels in
183 let kernels = List.mapi (
185 printf "Loading kernel data file %d/%d\r%!" (i+1) nr_kernels;
187 let structures = PP.load_structures info good_struct_names in
192 (* Keep only the good fields. *)
193 let kernels = List.map (
194 fun (info, structures) ->
195 let structures = List.map (
196 fun (struct_name, structure) ->
197 let { good_fields = good_fields } =
198 List.assoc struct_name good_structs in
199 let fields = List.filter (
200 fun { PP.field_name = name } -> List.mem name good_fields
201 ) structure.PP.struct_fields in
202 struct_name, { structure with PP.struct_fields = fields }
207 (* Turn anonymous list_head and void * pointers into pointers to
208 * known structure types, where we have that meta-information.
210 let kernels = List.map (
211 fun (info, structures) ->
212 let structures = List.map (
213 fun (struct_name, structure) ->
214 let { field_metadata = metadata } =
215 List.assoc struct_name good_structs in
216 let fields = structure.PP.struct_fields in
217 let fields = List.map (
218 fun ({ PP.field_name = name; PP.field_type = typ } as field) ->
220 let meta = List.assoc name metadata in
223 | ListHeadIsReally s, PP.FAnonListHeadPointer ->
224 PP.FListHeadPointer s
225 | VoidPointerIsReally s, PP.FVoidPointer ->
228 { field with PP.field_type = typ }
232 struct_name, { structure with PP.struct_fields = fields }
239 fun (info, structures) ->
240 printf "\n%s ----------\n" (PP.string_of_info info);
242 fun (_, structure) ->
243 printf "%s\n\n" (PP.string_of_structure structure);
247 (* First output file is a simple list of kernels, to support the
248 * 'virt-mem --list-kernels' option.
251 let _loc = Loc.ghost in
253 let versions = List.map (
254 fun ({ PP.kernel_version = version }, _) -> version
257 (* Sort them in reverse because we are going to generate the
258 * final list in reverse.
260 let cmp a b = compare b a in
261 let versions = List.sort ~cmp versions in
264 List.fold_left (fun xs version -> <:expr< $str:version$ :: $xs$ >>)
265 <:expr< [] >> versions in
267 let code = <:str_item<
271 let output_file = outputdir // "virt_mem_kernels.ml" in
272 printf "Writing list of kernels to %s ...\n%!" output_file;
273 Printers.OCaml.print_implem ~output_file code in
275 (* We want to track single structures as they have changed over
276 * time, ie. over kernel versions. Transpose our dataset so we are
277 * looking at structures over time.
279 let structures = PP.transpose good_struct_names kernels in
281 let kernels = () in ignore (kernels); (* garbage collect *)
285 fun (struct_name, kernels) ->
286 let all_fields = PP.get_fields kernels in
287 (struct_name, (kernels, all_fields))
292 fun (struct_name, (kernels, all_fields)) ->
293 printf "struct %s:\n" struct_name;
294 printf " structure occurs in %d kernel versions\n"
295 (List.length kernels);
296 printf " union of fields found:\n";
298 fun (field_name, field_type) ->
299 printf " %s %s\n" (PP.string_of_f_type field_type) field_name
303 (* Now perform the minimization step for each structure.
304 * We do separate minimization for:
305 * - shape field structures
306 * - content field structures
311 fun (struct_name, (kernels, all_fields)) ->
313 SC.minimize_shape_field_structs struct_name good_struct_names
317 SC.minimize_content_field_structs struct_name good_struct_names
321 SC.minimize_parsers struct_name kernels sfhash cfhash in
323 (struct_name, (kernels, all_fields,
324 sflist, sfhash, cflist, cfhash, palist, pahash))
330 (kernels, all_fields,
331 sflist, sfhash, cflist, cfhash, palist, pahash)) ->
332 printf "struct %s:\n" struct_name;
334 printf " shape field structures:\n";
336 fun { SC.sf_name = name; sf_fields = fields } ->
337 printf " type %s = {\n" name;
340 printf " %s %s;\n" (PP.string_of_f_type typ) name
345 printf " content field structures:\n";
347 fun { SC.cf_name = name; cf_fields = fields } ->
348 printf " type %s = {\n" name;
351 printf " %s %s;\n" (PP.string_of_f_type typ) name
356 printf " parsers:\n";
358 fun { SC.pa_name = name;
359 pa_shape_field_struct = sf;
360 pa_content_field_struct = cf } ->
361 printf " let %s = ...\n" name;
362 printf " -> (%s, %s)\n" sf.SC.sf_name cf.SC.cf_name
366 (* Now let's generate some code. *)
367 let implem_types, interf_types =
371 (_, _, sflist, _, cflist, _, _, _)) ->
372 (struct_name, sflist, cflist)
376 let implem_offsets, interf_offsets =
377 CG.generate_offsets (
380 (kernels, all_fields, _, _, _, _, _, _)) ->
381 (struct_name, (kernels, all_fields))
385 let (implem_parsers, interf_parsers), subst_parsers =
386 CG.generate_parsers (
388 fun (struct_name, (_, _, _, _, _, _, palist, _)) ->
389 (struct_name, palist)
393 let implem_followers, interf_followers =
394 CG.generate_followers (
396 fun (struct_name, (kernels, _, sflist, sfhash, _, _, _, pahash)) ->
397 (struct_name, (kernels, sflist, sfhash, pahash))
401 (* Output the generated code. *)
402 let output_file = outputdir // "kernel.mli" in
403 printf "Writing kernel data interface to %s ...\n%!" output_file;
404 CG.output_interf ~output_file
405 interf_types interf_offsets interf_parsers interf_followers;
407 let output_file = outputdir // "kernel.ml" in
408 printf "Writing kernel data parsers to %s ...\n%!" output_file;
409 CG.output_implem ~output_file
410 implem_types implem_offsets implem_parsers subst_parsers implem_followers;