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