extract/codegen/compile_kerneldb.ml

   1 (* Memory info for virtual domains.
   2    (C) Copyright 2008 Richard W.M. Jones, Red Hat Inc.
   3    http://libvirt.org/
   4
   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.
   9
  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.
  14
  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.
  18 *)
  19
  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.
  23
  24    The output programs -- *.ml, *.mli files of generated code -- go
  25    into lib/ at the toplevel, eg. lib/virt_mem_kernels.ml
  26
  27    The stuff at the top of this file determine what structures
  28    we try to parse.
  29 *)
  30
  31 type struct_t = {
  32   good_fields : string list;
  33   field_metadata : (string * field_metadata_t) list;
  34 }
  35 and field_metadata_t =
  36   | VoidPointerIsReally of string
  37   | ListHeadIsReally of (string * string) option
  38
  39 (*----------------------------------------------------------------------
  40  * This controls what structures & fields we will parse out.
  41  *----------------------------------------------------------------------*)
  42 let good_structs = [
  43   "task_struct", {
  44     good_fields = [ "tasks'next"; "tasks'prev";
  45                     "run_list'next"; "run_list'prev";
  46                     "state"; "prio"; "static_prio"; "normal_prio";
  47                     "comm"; "pid" ];
  48     field_metadata = [
  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 *)
  53     ];
  54   };
  55   "net_device", {
  56     good_fields = [ "dev_list'prev"; "dev_list'next"; "next";
  57                     "ip_ptr"; "ip6_ptr";
  58                     "name"; "flags"; "operstate"; "mtu"; "perm_addr";
  59                     "addr_len" ];
  60     field_metadata = [
  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";
  65     ];
  66   };
  67   "net", {
  68     good_fields = [ "dev_base_head'next"; "dev_base_head'prev" ];
  69     field_metadata = [
  70       "dev_base_head'next",
  71         ListHeadIsReally (Some ("net_device", "dev_list'next"));
  72       "dev_base_head'prev",
  73         ListHeadIsReally (Some ("net_device", "dev_list'next"));
  74     ];
  75   };
  76   "in_device", {
  77     good_fields = [ "ifa_list" ];
  78     field_metadata = [];
  79   };
  80   "inet6_dev", {
  81     good_fields = [ "addr_list" ];
  82     field_metadata = [];
  83   };
  84   "in_ifaddr", {
  85     good_fields = [ "ifa_next"; "ifa_local"; "ifa_address";
  86                     "ifa_mask"; "ifa_broadcast" ];
  87     field_metadata = [];
  88   };
  89   "inet6_ifaddr", {
  90     good_fields = [ "prefix_len"; "lst_next" ];
  91     field_metadata = [];
  92   };
  93 ]
  94
  95 (*----------------------------------------------------------------------
  96  * These are the code fragments which run over kernel structures.
  97  *----------------------------------------------------------------------*)
  98
  99 let fragments = [
 100   <:str_item<
 101     let get_net_devices net_device =
 102       let rec loop dev acc =
 103         let ipv4 = net_device.ip_ptr.ifa_list in
 104         let ipv4_addresses =
 105           let rec loop2 ipv4 acc =
 106             let addr = ipv4.ifa_address :: acc in
 107             let ipv4 = ipv4.ifa_next in
 108             loop2 ipv4
 109           in
 110           loop ipv4 [] 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
 114         else acc
 115   >>;
 116
 117   <:str_item<
 118     let get_net_devices_from_init_net net =
 119       get_net_devices net.dev_base_head'next
 120   >>;
 121
 122 ]
 123
 124 let debug = false
 125
 126 open Camlp4.PreCast
 127 open Syntax
 128 (*open Ast*)
 129
 130 open ExtList
 131 open ExtString
 132 open Printf
 133
 134 module PP = Pahole_parser
 135 module SC = Struct_classify
 136 module CG = Code_generation
 137
 138 let (//) = Filename.concat
 139
 140 (* Start of the main program. *)
 141 let () =
 142   let quick = ref false in
 143   let anon_args = ref [] in
 144
 145   let argspec = Arg.align [
 146     "--quick", Arg.Set quick, " Quick mode (just for testing)";
 147   ] in
 148
 149   let anon_arg str = anon_args := str :: !anon_args in
 150   let usage = "\
 151 compile-kerneldb: Turn kernels database into code modules.
 152
 153 Usage:
 154   compile-kerneldb [-options] <kerneldb> <outputdir>
 155
 156 For example, from the top level of the virt-mem source tree:
 157   compile-kerneldb kernels/ lib/
 158
 159 Options:
 160 " in
 161   Arg.parse argspec anon_arg usage;
 162
 163   let quick = !quick in
 164   let anon_args = List.rev !anon_args in
 165
 166   let kernelsdir, outputdir =
 167     match anon_args with
 168     | [kd;od] -> kd,od
 169     | _ ->
 170         eprintf "compile-kerneldb <kerneldb> <outputdir>\n";
 171         exit 2 in
 172
 173   (* Read in the list of kernels from the kerneldb. *)
 174   let kernels = PP.list_kernels kernelsdir in
 175
 176   (* In quick mode, just process the first few kernels. *)
 177   let kernels = if quick then List.take 10 kernels else kernels in
 178
 179   let good_struct_names = List.map fst good_structs in
 180
 181   (* Load in the structures. *)
 182   let nr_kernels = List.length kernels in
 183   let kernels = List.mapi (
 184     fun i info ->
 185       printf "Loading kernel data file %d/%d\r%!" (i+1) nr_kernels;
 186
 187       let structures = PP.load_structures info good_struct_names in
 188
 189       (info, structures)
 190   ) kernels in
 191
 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 }
 203       ) structures in
 204       (info, structures)
 205   ) kernels in
 206
 207   (* Turn anonymous list_head and void * pointers into pointers to
 208    * known structure types, where we have that meta-information.
 209    *)
 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) ->
 219               try
 220                 let meta = List.assoc name metadata in
 221                 let typ =
 222                   match meta, typ with
 223                   | ListHeadIsReally s, PP.FAnonListHeadPointer ->
 224                       PP.FListHeadPointer s
 225                   | VoidPointerIsReally s, PP.FVoidPointer ->
 226                       PP.FStructPointer s
 227                   | _, typ -> typ in
 228                 { field with PP.field_type = typ }
 229               with
 230                 Not_found -> field
 231           ) fields in
 232           struct_name, { structure with PP.struct_fields = fields }
 233       ) structures in
 234       (info, structures)
 235   ) kernels in
 236
 237   if debug then
 238     List.iter (
 239       fun (info, structures) ->
 240         printf "\n%s ----------\n" (PP.string_of_info info);
 241         List.iter (
 242           fun (_, structure) ->
 243             printf "%s\n\n" (PP.string_of_structure structure);
 244         ) structures;
 245     ) kernels;
 246
 247   (* First output file is a simple list of kernels, to support the
 248    * 'virt-mem --list-kernels' option.
 249    *)
 250   let () =
 251     let _loc = Loc.ghost in
 252
 253     let versions = List.map (
 254       fun ({ PP.kernel_version = version }, _) -> version
 255     ) kernels in
 256
 257     (* Sort them in reverse because we are going to generate the
 258      * final list in reverse.
 259      *)
 260     let cmp a b = compare b a in
 261     let versions = List.sort ~cmp versions in
 262
 263     let xs =
 264       List.fold_left (fun xs version -> <:expr< $str:version$ :: $xs$ >>)
 265       <:expr< [] >> versions in
 266
 267     let code = <:str_item<
 268       let kernels = $xs$
 269     >> in
 270
 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
 274
 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.
 278    *)
 279   let structures = PP.transpose good_struct_names kernels in
 280
 281   let kernels = () in ignore (kernels); (* garbage collect *)
 282
 283   let structures =
 284     List.map (
 285       fun (struct_name, kernels) ->
 286         let all_fields = PP.get_fields kernels in
 287         (struct_name, (kernels, all_fields))
 288     ) structures in
 289
 290   if debug then
 291     List.iter (
 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";
 297         List.iter (
 298           fun (field_name, field_type) ->
 299             printf "    %s %s\n" (PP.string_of_f_type field_type) field_name
 300         ) all_fields
 301     ) structures;
 302
 303   (* Now perform the minimization step for each structure.
 304    * We do separate minimization for:
 305    *   - shape field structures
 306    *   - content field structures
 307    *   - parsers
 308    *)
 309   let structures =
 310     List.map (
 311       fun (struct_name, (kernels, all_fields)) ->
 312         let sflist, sfhash =
 313           SC.minimize_shape_field_structs struct_name good_struct_names
 314             kernels in
 315
 316         let cflist, cfhash =
 317           SC.minimize_content_field_structs struct_name good_struct_names
 318             kernels in
 319
 320         let palist, pahash =
 321           SC.minimize_parsers struct_name kernels sfhash cfhash in
 322
 323         (struct_name, (kernels, all_fields,
 324                        sflist, sfhash, cflist, cfhash, palist, pahash))
 325     ) structures in
 326
 327   if debug then
 328     List.iter (
 329       fun (struct_name,
 330            (kernels, all_fields,
 331             sflist, sfhash, cflist, cfhash, palist, pahash)) ->
 332         printf "struct %s:\n" struct_name;
 333
 334         printf "  shape field structures:\n";
 335         List.iter (
 336           fun { SC.sf_name = name; sf_fields = fields } ->
 337             printf "    type %s = {\n" name;
 338             List.iter (
 339               fun (name, typ) ->
 340                 printf "      %s %s;\n" (PP.string_of_f_type typ) name
 341             ) fields;
 342             printf "    }\n";
 343         ) sflist;
 344
 345         printf "  content field structures:\n";
 346         List.iter (
 347           fun { SC.cf_name = name; cf_fields = fields } ->
 348             printf "    type %s = {\n" name;
 349             List.iter (
 350               fun (name, typ) ->
 351                 printf "      %s %s;\n" (PP.string_of_f_type typ) name
 352             ) fields;
 353             printf "    }\n";
 354         ) cflist;
 355
 356         printf "  parsers:\n";
 357         List.iter (
 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
 363         ) palist
 364     ) structures;
 365
 366   (* Now let's generate some code. *)
 367   let implem_types, interf_types =
 368     CG.generate_types (
 369       List.map (
 370         fun (struct_name,
 371              (_, _, sflist, _, cflist, _, _, _)) ->
 372           (struct_name, sflist, cflist)
 373       ) structures
 374     ) in
 375
 376   let implem_offsets, interf_offsets =
 377     CG.generate_offsets (
 378       List.map (
 379         fun (struct_name,
 380              (kernels, all_fields, _, _, _, _, _, _)) ->
 381           (struct_name, (kernels, all_fields))
 382       ) structures
 383     ) in
 384
 385   let (implem_parsers, interf_parsers), subst_parsers =
 386     CG.generate_parsers (
 387       List.map (
 388         fun (struct_name, (_, _, _, _, _, _, palist, _)) ->
 389           (struct_name, palist)
 390       ) structures
 391     ) in
 392
 393   let implem_followers, interf_followers =
 394     CG.generate_followers (
 395       List.map (
 396         fun (struct_name, (kernels, _, sflist, sfhash, _, _, _, pahash)) ->
 397           (struct_name, (kernels, sflist, sfhash, pahash))
 398       ) structures
 399     ) in
 400
 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;
 406
 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;
 411
 412   printf "Finished.\n"