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 let endian_of_architecture arch =
  62   if String.starts_with arch "i386" ||
  63     String.starts_with arch "i486" ||
  64     String.starts_with arch "i586" ||
  65     String.starts_with arch "i686" ||
  66     String.starts_with arch "x86_64" ||
  67     String.starts_with arch "x86-64" then
  68       Bitstring.LittleEndian
  69   else if String.starts_with arch "ia64" then
  70     Bitstring.LittleEndian (* XXX usually? *)
  71   else if String.starts_with arch "ppc" then
  72     Bitstring.BigEndian
  73   else if String.starts_with arch "sparc" then
  74     Bitstring.BigEndian
  75   else
  76     failwith (sprintf "endian_of_architecture: cannot parse %S" arch)
  77
  78 let unique =
  79   let i = ref 0 in
  80   fun () ->
  81     incr i; !i
  82
  83 (* Minimization of shape fields & content fields. *)
  84
  85 let cmp { PP.field_name = n1 } { PP.field_name = n2 } = compare n1 n2
  86
  87 let hash_values h = Hashtbl.fold (fun _ v vs -> v :: vs) h []
  88
  89 let minimize_shape_field_structs struct_name names kernels =
  90   let h = Hashtbl.create 13 in
  91   let rh = Hashtbl.create 13 in
  92
  93   let only_shape_fields =
  94     List.filter (
  95       fun { PP.field_type = typ } ->
  96         classify_field names typ = ShapeField
  97     )
  98   in
  99
 100   let name_of i = sprintf "%s_shape_fields_%d" struct_name i in
 101
 102   List.iter (
 103     fun ({ PP.kernel_version = version },
 104          { PP.struct_fields = fields; struct_name = name_check }) ->
 105       assert (struct_name = name_check);
 106       let fields = List.sort ~cmp (only_shape_fields fields) in
 107       let key = List.map (fun { PP.field_name = name } -> name) fields in
 108       let sf =
 109         try Hashtbl.find h key
 110         with Not_found ->
 111           let i = unique () in
 112           let sf = { sf_i = i; sf_name = name_of i; sf_fields = fields } in
 113           Hashtbl.add h key sf;
 114           sf in
 115       Hashtbl.add rh version sf
 116   ) kernels;
 117
 118   let sfs = hash_values h in
 119   sfs, rh
 120
 121 let minimize_content_field_structs struct_name names kernels =
 122   let h = Hashtbl.create 13 in
 123   let rh = Hashtbl.create 13 in
 124
 125   let only_content_fields =
 126     List.filter (
 127       fun { PP.field_type = typ } ->
 128         classify_field names typ = ContentField
 129     )
 130   in
 131
 132   let name_of i = sprintf "%s_content_fields_%d" struct_name i in
 133
 134   List.iter (
 135     fun ({ PP.kernel_version = version },
 136          { PP.struct_fields = fields; struct_name = name_check }) ->
 137       assert (struct_name = name_check);
 138       let fields = List.sort ~cmp (only_content_fields fields) in
 139       let key = List.map (fun { PP.field_name = name } -> name) fields in
 140       let cf =
 141         try Hashtbl.find h key
 142         with Not_found ->
 143           let i = unique () in
 144           let cf = { cf_i = i; cf_name = name_of i; cf_fields = fields } in
 145           Hashtbl.add h key cf;
 146           cf in
 147       Hashtbl.add rh version cf
 148   ) kernels;
 149
 150   let cfs = hash_values h in
 151   cfs, rh
 152
 153 let minimize_parsers struct_name kernels sfhash cfhash =
 154   let h = Hashtbl.create 13 in
 155   let rh = Hashtbl.create 13 in
 156
 157   let name_of i = sprintf "%s_parser_%d" struct_name i in
 158
 159   List.iter (
 160     fun ({ PP.kernel_version = version; arch = arch },
 161          { PP.struct_fields = fields; struct_name = name_check }) ->
 162       assert (struct_name = name_check);
 163       let endian = endian_of_architecture arch in
 164       let key = endian, fields in
 165       let pa =
 166         try Hashtbl.find h key
 167         with Not_found ->
 168           let i = unique () in
 169           let sf =
 170             try Hashtbl.find sfhash version
 171             with Not_found -> assert false in
 172           let cf =
 173             try Hashtbl.find cfhash version
 174             with Not_found -> assert false in
 175           let pa = { pa_i = i; pa_name = name_of i; pa_fields = fields;
 176                      pa_endian = endian;
 177                      pa_shape_field_struct = sf;
 178                      pa_content_field_struct = cf } in
 179           Hashtbl.add h key pa;
 180           pa in
 181       Hashtbl.add rh version pa
 182   ) kernels;
 183
 184   let pas = hash_values h in
 185   pas, rh