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