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 : PP.field list;
  46 }
  47
  48 and content_field_struct = {
  49   cf_i : int;
  50   cf_name : string;
  51   cf_fields : PP.field 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 { PP.field_name = n1 } { PP.field_name = 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 (
 101       fun { PP.field_type = typ } ->
 102         classify_field names typ = ShapeField
 103     )
 104   in
 105
 106   let name_of i = sprintf "%s_shape_fields_%d" struct_name i in
 107
 108   List.iter (
 109     fun ({ PP.kernel_version = version },
 110          { PP.struct_fields = fields; struct_name = name_check }) ->
 111       assert (struct_name = name_check);
 112       let fields = List.sort ~cmp (only_shape_fields fields) in
 113       let key = List.map (fun { PP.field_name = name } -> name) fields in
 114       let sf =
 115         try Hashtbl.find h key
 116         with Not_found ->
 117           let i = unique () in
 118           let sf = { sf_i = i; sf_name = name_of i; sf_fields = fields } in
 119           Hashtbl.add h key sf;
 120           sf in
 121       Hashtbl.add rh version sf
 122   ) kernels;
 123
 124   let sfs = hash_values h in
 125   sfs, rh
 126
 127 let minimize_content_field_structs struct_name names kernels =
 128   let h = Hashtbl.create 13 in
 129   let rh = Hashtbl.create 13 in
 130
 131   let only_content_fields =
 132     List.filter (
 133       fun { PP.field_type = typ } ->
 134         classify_field names typ = ContentField
 135     )
 136   in
 137
 138   let name_of i = sprintf "%s_content_fields_%d" struct_name i in
 139
 140   List.iter (
 141     fun ({ PP.kernel_version = version },
 142          { PP.struct_fields = fields; struct_name = name_check }) ->
 143       assert (struct_name = name_check);
 144       let fields = List.sort ~cmp (only_content_fields fields) in
 145       let key = List.map (fun { PP.field_name = name } -> name) fields in
 146       let cf =
 147         try Hashtbl.find h key
 148         with Not_found ->
 149           let i = unique () in
 150           let cf = { cf_i = i; cf_name = name_of i; cf_fields = fields } in
 151           Hashtbl.add h key cf;
 152           cf in
 153       Hashtbl.add rh version cf
 154   ) kernels;
 155
 156   let cfs = hash_values h in
 157   cfs, rh
 158
 159 let minimize_parsers struct_name kernels sfhash cfhash =
 160   let h = Hashtbl.create 13 in
 161   let rh = Hashtbl.create 13 in
 162
 163   (* Do not change - see Code_generation.re_subst. *)
 164   let name_of i = sprintf "%s_parser_%d" struct_name i in
 165
 166   List.iter (
 167     fun ({ PP.kernel_version = version; arch = arch },
 168          ({ PP.struct_fields = fields; struct_name = name_check }
 169             as structure)) ->
 170       assert (struct_name = name_check);
 171       let endian = endian_of_architecture arch in
 172       let key = endian, fields in
 173       let pa =
 174         try Hashtbl.find h key
 175         with Not_found ->
 176           let i = unique () in
 177           let sf =
 178             try Hashtbl.find sfhash version
 179             with Not_found -> assert false in
 180           let cf =
 181             try Hashtbl.find cfhash version
 182             with Not_found -> assert false in
 183           let pa = { pa_i = i; pa_name = name_of i;
 184                      pa_endian = endian;
 185                      pa_structure = structure;
 186                      pa_shape_field_struct = sf;
 187                      pa_content_field_struct = cf } in
 188           Hashtbl.add h key pa;
 189           pa in
 190       Hashtbl.add rh version pa
 191   ) kernels;
 192
 193   let pas = hash_values h in
 194   pas, rh