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
 106 let (//) = Filename.concat
 107
 108 (* Couple of handy camlp4 construction functions which do some
 109  * things that ought to be easy/obvious but aren't.
 110  *
 111  * 'concat_str_items' concatenates a list of str_item together into
 112  * one big str_item.
 113  *
 114  * 'concat_record_fields' concatenates a list of records fields into
 115  * a record.  The list must have at least one element.
 116  *
 117  * 'build_record' builds a record out of record fields.
 118  *
 119  * 'build_tuple_from_exprs' builds an arbitrary length tuple from
 120  * a list of expressions of length >= 2.
 121  *
 122  * Thanks to bluestorm on #ocaml for getting these working.
 123  *)
 124 let concat_str_items _loc items =
 125   match items with
 126   | [] -> <:str_item< >>
 127   | x :: xs ->
 128       List.fold_left (fun xs x -> <:str_item< $xs$ $x$ >>) x xs
 129
 130 let concat_sig_items _loc items =
 131   match items with
 132   | [] -> <:sig_item< >>
 133   | x :: xs ->
 134       List.fold_left (fun xs x -> <:sig_item< $xs$ $x$ >>) x xs
 135
 136 let concat_record_fields _loc fields =
 137   match fields with
 138     | [] -> assert false
 139     | f :: fs ->
 140         List.fold_left (fun fs f -> <:ctyp< $fs$ ; $f$ >>) f fs
 141
 142 let concat_record_bindings _loc rbs =
 143   match rbs with
 144     | [] -> assert false
 145     | rb :: rbs ->
 146         List.fold_left (fun rbs rb -> <:rec_binding< $rbs$ ; $rb$ >>) rb rbs
 147
 148 let build_record _loc rbs =
 149   Ast.ExRec (_loc, rbs, Ast.ExNil _loc)
 150
 151 let build_tuple_from_exprs _loc exprs =
 152   match exprs with
 153   | [] | [_] -> assert false
 154   | x :: xs ->
 155       Ast.ExTup (_loc,
 156                  List.fold_left (fun xs x -> Ast.ExCom (_loc, x, xs)) x xs)
 157
 158 (* Start of the main program. *)
 159 let () =
 160   let quick = ref false in
 161   let anon_args = ref [] in
 162
 163   let argspec = Arg.align [
 164     "--quick", Arg.Set quick, " Quick mode (just for testing)";
 165   ] in
 166
 167   let anon_arg str = anon_args := str :: !anon_args in
 168   let usage = "\
 169 compile-kerneldb: Turn kernels database into code modules.
 170
 171 Usage:
 172   compile-kerneldb [-options] <kerneldb> <outputdir>
 173
 174 For example, from the top level of the virt-mem source tree:
 175   compile-kerneldb kernels/ lib/
 176
 177 Options:
 178 " in
 179   Arg.parse argspec anon_arg usage;
 180
 181   let quick = !quick in
 182   let anon_args = List.rev !anon_args in
 183
 184   let kernelsdir, outputdir =
 185     match anon_args with
 186     | [kd;od] -> kd,od
 187     | _ ->
 188         eprintf "compile-kerneldb <kerneldb> <outputdir>\n";
 189         exit 2 in
 190
 191   (* Read in the list of kernels from the kerneldb. *)
 192   let kernels = PP.list_kernels kernelsdir in
 193
 194   (* In quick mode, just process the first few kernels. *)
 195   let kernels = if quick then List.take 10 kernels else kernels in
 196
 197   let good_struct_names = List.map fst good_structs in
 198
 199   (* Load in the structures. *)
 200   let nr_kernels = List.length kernels in
 201   let kernels = List.mapi (
 202     fun i info ->
 203       printf "Loading kernel data file %d/%d\r%!" (i+1) nr_kernels;
 204
 205       let structures = PP.load_structures info good_struct_names in
 206
 207       (info, structures)
 208   ) kernels in
 209
 210   (* Keep only the good fields. *)
 211   let kernels = List.map (
 212     fun (info, structures) ->
 213       let structures = List.map (
 214         fun (struct_name, structure) ->
 215           let { good_fields = good_fields } =
 216             List.assoc struct_name good_structs in
 217           let fields = List.filter (
 218             fun { PP.field_name = name } -> List.mem name good_fields
 219           ) structure.PP.struct_fields in
 220           struct_name, { structure with PP.struct_fields = fields }
 221       ) structures in
 222       (info, structures)
 223   ) kernels in
 224
 225   (* Turn anonymous list_head and void * pointers into pointers to
 226    * known structure types, where we have that meta-information.
 227    *)
 228   let kernels = List.map (
 229     fun (info, structures) ->
 230       let structures = List.map (
 231         fun (struct_name, structure) ->
 232           let { field_metadata  = metadata } =
 233             List.assoc struct_name good_structs in
 234           let fields = structure.PP.struct_fields in
 235           let fields = List.map (
 236             fun ({ PP.field_name = name; PP.field_type = typ } as field) ->
 237               try
 238                 let meta = List.assoc name metadata in
 239                 let typ =
 240                   match meta, typ with
 241                   | ListHeadIsReally s, PP.FAnonListHeadPointer ->
 242                       PP.FListHeadPointer s
 243                   | VoidPointerIsReally s, PP.FVoidPointer ->
 244                       PP.FStructPointer s
 245                   | _, typ -> typ in
 246                 { field with PP.field_type = typ }
 247               with
 248                 Not_found -> field
 249           ) fields in
 250           struct_name, { structure with PP.struct_fields = fields }
 251       ) structures in
 252       (info, structures)
 253   ) kernels in
 254
 255   if debug then
 256     List.iter (
 257       fun (info, structures) ->
 258         printf "\n%s ----------\n" (PP.string_of_info info);
 259         List.iter (
 260           fun (_, structure) ->
 261             printf "%s\n\n" (PP.string_of_structure structure);
 262         ) structures;
 263     ) kernels;
 264
 265   (* First output file is a simple list of kernels, to support the
 266    * 'virt-mem --list-kernels' option.
 267    *)
 268   let () =
 269     let _loc = Loc.ghost in
 270
 271     let versions = List.map (
 272       fun ({ PP.kernel_version = version }, _) -> version
 273     ) kernels in
 274
 275     (* Sort them in reverse because we are going to generate the
 276      * final list in reverse.
 277      *)
 278     let cmp a b = compare b a in
 279     let versions = List.sort ~cmp versions in
 280
 281     let xs =
 282       List.fold_left (fun xs version -> <:expr< $str:version$ :: $xs$ >>)
 283       <:expr< [] >> versions in
 284
 285     let code = <:str_item<
 286       let kernels = $xs$
 287     >> in
 288
 289     let output_file = outputdir // "virt_mem_kernels.ml" in
 290     printf "Writing list of kernels to %s ...\n%!" output_file;
 291     Printers.OCaml.print_implem ~output_file code in
 292
 293   (* We want to track single structures as they have changed over
 294    * time, ie. over kernel versions.  Transpose our dataset so we are
 295    * looking at structures over time.
 296    *)
 297   let structures = PP.transpose good_struct_names kernels in
 298
 299   let kernels = () in ignore (kernels); (* garbage collect *)
 300
 301   let structures =
 302     List.map (
 303       fun (struct_name, kernels) ->
 304         let all_fields = PP.get_fields kernels in
 305         (struct_name, (kernels, all_fields))
 306     ) structures in
 307
 308   if debug then
 309     List.iter (
 310       fun (struct_name, (kernels, all_fields)) ->
 311         printf "struct %s:\n" struct_name;
 312         printf "  structure occurs in %d kernel versions\n"
 313           (List.length kernels);
 314         printf "  union of fields found:\n";
 315         List.iter (
 316           fun (field_name, field_type) ->
 317             printf "    %s %s\n" (PP.string_of_f_type field_type) field_name
 318         ) all_fields
 319     ) structures;
 320
 321   (* Now perform the minimization step for each structure.
 322    * We do separate minimization for:
 323    *   - shape field structures
 324    *   - content field structures
 325    *   - parsers
 326    *)
 327   let structures =
 328     List.map (
 329       fun (struct_name, (kernels, all_fields)) ->
 330         let sflist, sfhash =
 331           SC.minimize_shape_field_structs struct_name good_struct_names
 332             kernels in
 333
 334         let cflist, cfhash =
 335           SC.minimize_content_field_structs struct_name good_struct_names
 336             kernels in
 337
 338         let palist, pahash =
 339           SC.minimize_parsers struct_name kernels sfhash cfhash in
 340
 341         (struct_name, (kernels, all_fields,
 342                        sflist, sfhash, cflist, cfhash, palist, pahash))
 343     ) structures in
 344
 345   if debug then
 346     List.iter (
 347       fun (struct_name,
 348            (kernels, all_fields,
 349             sflist, sfhash, cflist, cfhash, palist, pahash)) ->
 350         printf "struct %s:\n" struct_name;
 351
 352         printf "  shape field structures:\n";
 353         List.iter (
 354           fun { SC.sf_name = name; sf_fields = fields } ->
 355             printf "    type %s = {\n" name;
 356             List.iter (
 357               fun { PP.field_name = name; field_type = typ } ->
 358                 printf "      %s %s;\n" (PP.string_of_f_type typ) name
 359             ) fields;
 360             printf "    }\n";
 361         ) sflist;
 362
 363         printf "  content field structures:\n";
 364         List.iter (
 365           fun { SC.cf_name = name; cf_fields = fields } ->
 366             printf "    type %s = {\n" name;
 367             List.iter (
 368               fun { PP.field_name = name; field_type = typ } ->
 369                 printf "      %s %s;\n" (PP.string_of_f_type typ) name
 370             ) fields;
 371             printf "    }\n";
 372         ) cflist;
 373
 374         printf "  parsers:\n";
 375         List.iter (
 376           fun { SC.pa_name = name;
 377                 pa_shape_field_struct = sf;
 378                 pa_content_field_struct = cf } ->
 379             printf "    let %s = ...\n" name;
 380             printf "      -> (%s, %s)\n" sf.SC.sf_name cf.SC.cf_name
 381         ) palist
 382     ) structures;