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 SC = Struct_classify
 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) ->
 270             printf "    %s %s\n" (PP.string_of_f_type field_type) field_name
 271         ) all_fields
 272     ) structures;
 273
 274   (* Now perform the minimization step for each structure.
 275    * We do separate minimization for:
 276    *   - shape field structures
 277    *   - content field structures
 278    *   - parsers
 279    *)
 280   let structures =
 281     List.map (
 282       fun (struct_name, (kernels, all_fields)) ->
 283         let sflist, sfhash =
 284           SC.minimize_shape_field_structs struct_name good_struct_names
 285             kernels in
 286
 287         let cflist, cfhash =
 288           SC.minimize_content_field_structs struct_name good_struct_names
 289             kernels in
 290
 291         let palist, pahash =
 292           SC.minimize_parsers struct_name kernels sfhash cfhash in
 293
 294         (struct_name, (kernels, all_fields,
 295                        sflist, sfhash, cflist, cfhash, palist, pahash))
 296     ) structures in
 297
 298   if debug then
 299     List.iter (
 300       fun (struct_name,
 301            (kernels, all_fields,
 302             sflist, sfhash, cflist, cfhash, palist, pahash)) ->
 303         printf "struct %s:\n" struct_name;
 304
 305         printf "  shape field structures:\n";
 306         List.iter (
 307           fun { SC.sf_name = name; sf_fields = fields } ->
 308             printf "    type %s = {\n" name;
 309             List.iter (
 310               fun (name, typ) ->
 311                 printf "      %s %s;\n" (PP.string_of_f_type typ) name
 312             ) fields;
 313             printf "    }\n";
 314         ) sflist;
 315
 316         printf "  content field structures:\n";
 317         List.iter (
 318           fun { SC.cf_name = name; cf_fields = fields } ->
 319             printf "    type %s = {\n" name;
 320             List.iter (
 321               fun (name, typ) ->
 322                 printf "      %s %s;\n" (PP.string_of_f_type typ) name
 323             ) fields;
 324             printf "    }\n";
 325         ) cflist;
 326
 327         printf "  parsers:\n";
 328         List.iter (
 329           fun { SC.pa_name = name;
 330                 pa_shape_field_struct = sf;
 331                 pa_content_field_struct = cf } ->
 332             printf "    let %s = ...\n" name;
 333             printf "      -> (%s, %s)\n" sf.SC.sf_name cf.SC.cf_name
 334         ) palist
 335     ) structures;
 336
 337   (* Now let's generate some code. *)
 338   let implem_types, interf_types =
 339     CG.generate_types (
 340       List.map (
 341         fun (struct_name,
 342              (_, _, sflist, _, cflist, _, _, _)) ->
 343           (struct_name, sflist, cflist)
 344       ) structures
 345     ) in
 346
 347   let implem_offsets, interf_offsets =
 348     CG.generate_offsets (
 349       List.map (
 350         fun (struct_name,
 351              (kernels, all_fields, _, _, _, _, _, _)) ->
 352           (struct_name, (kernels, all_fields))
 353       ) structures
 354     ) in
 355
 356   let (implem_parsers, interf_parsers), subst_parsers =
 357     CG.generate_parsers (
 358       List.map (
 359         fun (struct_name, (_, _, _, _, _, _, palist, _)) ->
 360           (struct_name, palist)
 361       ) structures
 362     ) in
 363
 364   let implem_followers, interf_followers =
 365     CG.generate_followers (
 366       List.map (
 367         fun (struct_name, (kernels, _, sflist, sfhash, _, _, _, pahash)) ->
 368           (struct_name, (kernels, sflist, sfhash, pahash))
 369       ) structures
 370     ) in
 371
 372   (* Output the generated code. *)
 373   let output_file = outputdir // "kernel.mli" in
 374   printf "Writing kernel data interface to %s ...\n%!" output_file;
 375   CG.output_interf ~output_file
 376     interf_types interf_offsets interf_parsers interf_followers;
 377
 378   let output_file = outputdir // "kernel.ml" in
 379   printf "Writing kernel data parsers to %s ...\n%!" output_file;
 380   CG.output_implem ~output_file
 381     implem_types implem_offsets implem_parsers subst_parsers implem_followers;
 382
 383   printf "Finished.\n"