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 let debug = false
  96
  97 open Camlp4.PreCast
  98 open Syntax
  99 (*open Ast*)
 100
 101 open ExtList
 102 open ExtString
 103 open Printf
 104
 105 module PP = Pahole_parser
 106 module MM = Minimizer
 107 module CG = Code_generation
 108
 109 let (//) = Filename.concat
 110
 111 (* Start of the main program. *)
 112 let () =
 113   let quick = ref false in
 114   let anon_args = ref [] in
 115
 116   let argspec = Arg.align [
 117     "--quick", Arg.Set quick, " Quick mode (just for testing)";
 118   ] in
 119
 120   let anon_arg str = anon_args := str :: !anon_args in
 121   let usage = "\
 122 compile-kerneldb: Turn kernels database into code modules.
 123
 124 Usage:
 125   compile-kerneldb [-options] <kerneldb> <outputdir>
 126
 127 For example, from the top level of the virt-mem source tree:
 128   compile-kerneldb kernels/ lib/
 129
 130 Options:
 131 " in
 132   Arg.parse argspec anon_arg usage;
 133
 134   let quick = !quick in
 135   let anon_args = List.rev !anon_args in
 136
 137   let kernelsdir, outputdir =
 138     match anon_args with
 139     | [kd;od] -> kd,od
 140     | _ ->
 141         eprintf "compile-kerneldb <kerneldb> <outputdir>\n";
 142         exit 2 in
 143
 144   (* Read in the list of kernels from the kerneldb. *)
 145   let kernels = PP.list_kernels kernelsdir in
 146
 147   (* In quick mode, just process the first few kernels. *)
 148   let kernels = if quick then List.take 10 kernels else kernels in
 149
 150   let good_struct_names = List.map fst good_structs in
 151
 152   (* Load in the structures. *)
 153   let nr_kernels = List.length kernels in
 154   let kernels = List.mapi (
 155     fun i info ->
 156       printf "Loading kernel data file %d/%d\r%!" (i+1) nr_kernels;
 157
 158       let structures = PP.load_structures info good_struct_names in
 159
 160       (info, structures)
 161   ) kernels in
 162
 163   (* Keep only the good fields. *)
 164   let kernels = List.map (
 165     fun (info, structures) ->
 166       let structures = List.map (
 167         fun (struct_name, structure) ->
 168           let { good_fields = good_fields } =
 169             List.assoc struct_name good_structs in
 170           let fields = List.filter (
 171             fun { PP.field_name = name } -> List.mem name good_fields
 172           ) structure.PP.struct_fields in
 173           struct_name, { structure with PP.struct_fields = fields }
 174       ) structures in
 175       (info, structures)
 176   ) kernels in
 177
 178   (* Turn anonymous list_head and void * pointers into pointers to
 179    * known structure types, where we have that meta-information.
 180    *)
 181   let kernels = List.map (
 182     fun (info, structures) ->
 183       let structures = List.map (
 184         fun (struct_name, structure) ->
 185           let { field_metadata  = metadata } =
 186             List.assoc struct_name good_structs in
 187           let fields = structure.PP.struct_fields in
 188           let fields = List.map (
 189             fun ({ PP.field_name = name; PP.field_type = typ } as field) ->
 190               try
 191                 let meta = List.assoc name metadata in
 192                 let typ =
 193                   match meta, typ with
 194                   | ListHeadIsReally s, PP.FAnonListHeadPointer ->
 195                       PP.FListHeadPointer s
 196                   | VoidPointerIsReally s, PP.FVoidPointer ->
 197                       PP.FStructPointer s
 198                   | _, typ -> typ in
 199                 { field with PP.field_type = typ }
 200               with
 201                 Not_found -> field
 202           ) fields in
 203           struct_name, { structure with PP.struct_fields = fields }
 204       ) structures in
 205       (info, structures)
 206   ) kernels in
 207
 208   if debug then
 209     List.iter (
 210       fun (info, structures) ->
 211         printf "\n%s ----------\n" (PP.string_of_info info);
 212         List.iter (
 213           fun (_, structure) ->
 214             printf "%s\n\n" (PP.string_of_structure structure);
 215         ) structures;
 216     ) kernels;
 217
 218   (* First output file is a simple list of kernels, to support the
 219    * 'virt-mem --list-kernels' option.
 220    *)
 221   let () =
 222     let _loc = Loc.ghost in
 223
 224     let versions = List.map (
 225       fun ({ PP.kernel_version = version }, _) -> version
 226     ) kernels in
 227
 228     (* Sort them in reverse because we are going to generate the
 229      * final list in reverse.
 230      *)
 231     let cmp a b = compare b a in
 232     let versions = List.sort ~cmp versions in
 233
 234     let xs =
 235       List.fold_left (fun xs version -> <:expr< $str:version$ :: $xs$ >>)
 236       <:expr< [] >> versions in
 237
 238     let code = <:str_item<
 239       let kernels = $xs$
 240     >> in
 241
 242     let output_file = outputdir // "virt_mem_kernels.ml" in
 243     printf "Writing list of kernels to %s ...\n%!" output_file;
 244     Printers.OCaml.print_implem ~output_file code in
 245
 246   (* We want to track single structures as they have changed over
 247    * time, ie. over kernel versions.  Transpose our dataset so we are
 248    * looking at structures over time.
 249    *)
 250   let structures = PP.transpose good_struct_names kernels in
 251
 252   let kernels = () in ignore (kernels); (* garbage collect *)
 253
 254   let structures =
 255     List.map (
 256       fun (struct_name, kernels) ->
 257         let all_fields = PP.get_fields kernels in
 258         (struct_name, (kernels, all_fields))
 259     ) structures in
 260
 261   if debug then
 262     List.iter (
 263       fun (struct_name, (kernels, all_fields)) ->
 264         printf "struct %s:\n" struct_name;
 265         printf "  structure occurs in %d kernel versions\n"
 266           (List.length kernels);
 267         printf "  union of fields found:\n";
 268         List.iter (
 269           fun (field_name, (field_type, always_available)) ->
 270             printf "    %s %s /* %s */\n"
 271               (PP.string_of_f_type field_type) field_name
 272               (if always_available then "always" else "optional")
 273         ) all_fields
 274     ) structures;
 275
 276   (* Now perform the minimization step for parsers. *)
 277   let structures =
 278     List.map (
 279       fun (struct_name, (kernels, all_fields)) ->
 280         let palist, pahash = MM.minimize_parsers struct_name kernels in
 281
 282         (struct_name, (kernels, all_fields, palist, pahash))
 283     ) structures in
 284
 285   if debug then
 286     List.iter (
 287       fun (struct_name,
 288            (kernels, all_fields, palist, pahash)) ->
 289         printf "struct %s:\n" struct_name;
 290
 291         printf "  parsers:\n";
 292         List.iter (
 293           fun { MM.pa_name = name; pa_structure = structure } ->
 294             printf "    let %s bits =\n" name;
 295             List.iter (
 296               fun ({ PP.field_name = name; field_type = typ }) ->
 297                 printf "      %s %s;\n" (PP.string_of_f_type typ) name
 298             ) structure.PP.struct_fields;
 299         ) palist
 300     ) structures;
 301
 302   (* Now let's generate some code. *)
 303   let implem_types, interf_types =
 304     CG.generate_types (
 305       List.map (
 306         fun (struct_name, (_, all_fields, _, _)) ->
 307           (struct_name, all_fields)
 308       ) structures
 309     ) in
 310
 311   let implem_offsets, interf_offsets =
 312     CG.generate_offsets (
 313       List.map (
 314         fun (struct_name, (kernels, all_fields, _, _)) ->
 315           (struct_name, (kernels, all_fields))
 316       ) structures
 317     ) in
 318
 319   let (implem_parsers, interf_parsers), subst_parsers =
 320     CG.generate_parsers (
 321       List.map (
 322         fun (struct_name, (_, all_fields, palist, _)) ->
 323           (struct_name, (all_fields, palist))
 324       ) structures
 325     ) in
 326
 327   let implem_version_maps, interf_version_maps =
 328     CG.generate_version_maps (
 329       List.map (
 330         fun (struct_name, (kernels, _, _, pahash)) ->
 331           (struct_name, (kernels, pahash))
 332       ) structures
 333     ) in
 334
 335   let implem_followers, interf_followers =
 336     CG.generate_followers good_struct_names (
 337       List.map (
 338         fun (struct_name, (_, all_fields, _, _)) -> (struct_name, all_fields)
 339       ) structures
 340     ) in
 341
 342   (* Output the generated code. *)
 343   let output_file = outputdir // "kernel.mli" in
 344   printf "Writing kernel data interface to %s ...\n%!" output_file;
 345   CG.output_interf ~output_file
 346     interf_types interf_offsets interf_parsers
 347     interf_version_maps interf_followers;
 348
 349   let output_file = outputdir // "kernel.ml" in
 350   printf "Writing kernel data parsers to %s ...\n%!" output_file;
 351   CG.output_implem ~output_file
 352     implem_types implem_offsets implem_parsers subst_parsers
 353     implem_version_maps implem_followers;
 354
 355   printf "Finished.\n"