extract/codegen/struct_classify.ml

   1 (* Memory info command 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 open ExtList
  21 open ExtString
  22
  23 open Printf
  24
  25 module PP = Pahole_parser
  26
  27 type f_class = ShapeField | ContentField
  28
  29 let classify_field names = function
  30   | (PP.FStructPointer struct_name | PP.FListHeadPointer struct_name)
  31       when List.mem struct_name names -> ShapeField
  32     (* .. anything else is a content field: *)
  33   | PP.FStructPointer _
  34   | PP.FListHeadPointer _
  35   | PP.FVoidPointer
  36   | PP.FAnonListHeadPointer
  37   | PP.FInteger
  38   | PP.FString _ -> ContentField
  39
  40 type shape_field_struct = {
  41   sf_i : int;
  42   sf_name : string;
  43   sf_fields : PP.field list;
  44 }
  45
  46 and content_field_struct = {
  47   cf_i : int;
  48   cf_name : string;
  49   cf_fields : PP.field list;
  50 }
  51
  52 and parser_ = {
  53   pa_i : int;
  54   pa_name : string;
  55   pa_endian : Bitstring.endian;
  56   pa_fields : Pahole_parser.field list;
  57   pa_shape_field_struct : shape_field_struct;
  58   pa_content_field_struct : content_field_struct;
  59 }
  60
  61 and sfhash = (string, shape_field_struct) Hashtbl.t
  62 and cfhash = (string, content_field_struct) Hashtbl.t
  63 and pahash = (string, parser_) Hashtbl.t
  64
  65 let endian_of_architecture arch =
  66   if String.starts_with arch "i386" ||
  67     String.starts_with arch "i486" ||
  68     String.starts_with arch "i586" ||
  69     String.starts_with arch "i686" ||
  70     String.starts_with arch "x86_64" ||
  71     String.starts_with arch "x86-64" then
  72       Bitstring.LittleEndian
  73   else if String.starts_with arch "ia64" then
  74     Bitstring.LittleEndian (* XXX usually? *)
  75   else if String.starts_with arch "ppc" then
  76     Bitstring.BigEndian
  77   else if String.starts_with arch "sparc" then
  78     Bitstring.BigEndian
  79   else
  80     failwith (sprintf "endian_of_architecture: cannot parse %S" arch)
  81
  82 let unique =
  83   let i = ref 0 in
  84   fun () ->
  85     incr i; !i
  86
  87 (* Minimization of shape fields & content fields. *)
  88
  89 let cmp { PP.field_name = n1 } { PP.field_name = n2 } = compare n1 n2
  90
  91 let hash_values h = Hashtbl.fold (fun _ v vs -> v :: vs) h []
  92
  93 let minimize_shape_field_structs struct_name names kernels =
  94   let h = Hashtbl.create 13 in
  95   let rh = Hashtbl.create 13 in
  96
  97   let only_shape_fields =
  98     List.filter (
  99       fun { PP.field_type = typ } ->
 100         classify_field names typ = ShapeField
 101     )
 102   in
 103
 104   let name_of i = sprintf "%s_shape_fields_%d" struct_name i in
 105
 106   List.iter (
 107     fun ({ PP.kernel_version = version },
 108          { PP.struct_fields = fields; struct_name = name_check }) ->
 109       assert (struct_name = name_check);
 110       let fields = List.sort ~cmp (only_shape_fields fields) in
 111       let key = List.map (fun { PP.field_name = name } -> name) fields in
 112       let sf =
 113         try Hashtbl.find h key
 114         with Not_found ->
 115           let i = unique () in
 116           let sf = { sf_i = i; sf_name = name_of i; sf_fields = fields } in
 117           Hashtbl.add h key sf;
 118           sf in
 119       Hashtbl.add rh version sf
 120   ) kernels;
 121
 122   let sfs = hash_values h in
 123   sfs, rh
 124
 125 let minimize_content_field_structs struct_name names kernels =
 126   let h = Hashtbl.create 13 in
 127   let rh = Hashtbl.create 13 in
 128
 129   let only_content_fields =
 130     List.filter (
 131       fun { PP.field_type = typ } ->
 132         classify_field names typ = ContentField
 133     )
 134   in
 135
 136   let name_of i = sprintf "%s_content_fields_%d" struct_name i in
 137
 138   List.iter (
 139     fun ({ PP.kernel_version = version },
 140          { PP.struct_fields = fields; struct_name = name_check }) ->
 141       assert (struct_name = name_check);
 142       let fields = List.sort ~cmp (only_content_fields fields) in
 143       let key = List.map (fun { PP.field_name = name } -> name) fields in
 144       let cf =
 145         try Hashtbl.find h key
 146         with Not_found ->
 147           let i = unique () in
 148           let cf = { cf_i = i; cf_name = name_of i; cf_fields = fields } in
 149           Hashtbl.add h key cf;
 150           cf in
 151       Hashtbl.add rh version cf
 152   ) kernels;
 153
 154   let cfs = hash_values h in
 155   cfs, rh
 156
 157 let minimize_parsers struct_name kernels sfhash cfhash =
 158   let h = Hashtbl.create 13 in
 159   let rh = Hashtbl.create 13 in
 160
 161   let name_of i = sprintf "%s_parser_%d" struct_name i in
 162
 163   List.iter (
 164     fun ({ PP.kernel_version = version; arch = arch },
 165          { PP.struct_fields = fields; struct_name = name_check }) ->
 166       assert (struct_name = name_check);
 167       let endian = endian_of_architecture arch in
 168       let key = endian, fields in
 169       let pa =
 170         try Hashtbl.find h key
 171         with Not_found ->
 172           let i = unique () in
 173           let sf =
 174             try Hashtbl.find sfhash version
 175             with Not_found -> assert false in
 176           let cf =
 177             try Hashtbl.find cfhash version
 178             with Not_found -> assert false in
 179           let pa = { pa_i = i; pa_name = name_of i; pa_fields = fields;
 180                      pa_endian = endian;
 181                      pa_shape_field_struct = sf;
 182                      pa_content_field_struct = cf } in
 183           Hashtbl.add h key pa;
 184           pa in
 185       Hashtbl.add rh version pa
 186   ) kernels;
 187
 188   let pas = hash_values h in
 189   pas, rh