+++ /dev/null
-(* Memory info command for virtual domains.
- (C) Copyright 2008 Richard W.M. Jones, Red Hat Inc.
- http://libvirt.org/
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
- *)
-
-open ExtList
-open ExtString
-
-open Printf
-
-module PP = Pahole_parser
-
-type f_class = ShapeField | ContentField
-
-let classify_field names = function
- | PP.FListHeadPointer None -> ShapeField
- | (PP.FStructPointer struct_name
- | PP.FListHeadPointer (Some (struct_name, _)))
- when List.mem struct_name names -> ShapeField
- (* .. anything else is a content field: *)
- | PP.FStructPointer _
- | PP.FListHeadPointer _
- | PP.FVoidPointer
- | PP.FAnonListHeadPointer
- | PP.FInteger
- | PP.FString _ -> ContentField
-
-type shape_field_struct = {
- sf_i : int;
- sf_name : string;
- sf_fields : (string * PP.f_type) list;
-}
-
-and content_field_struct = {
- cf_i : int;
- cf_name : string;
- cf_fields : (string * PP.f_type) list;
-}
-
-and parser_ = {
- pa_i : int;
- pa_name : string;
- pa_endian : Bitstring.endian;
- pa_structure : Pahole_parser.structure;
- pa_shape_field_struct : shape_field_struct;
- pa_content_field_struct : content_field_struct;
-}
-
-and sfhash = (string, shape_field_struct) Hashtbl.t
-and cfhash = (string, content_field_struct) Hashtbl.t
-and pahash = (string, parser_) Hashtbl.t
-
-let endian_of_architecture arch =
- if String.starts_with arch "i386" ||
- String.starts_with arch "i486" ||
- String.starts_with arch "i586" ||
- String.starts_with arch "i686" ||
- String.starts_with arch "x86_64" ||
- String.starts_with arch "x86-64" then
- Bitstring.LittleEndian
- else if String.starts_with arch "ia64" then
- Bitstring.LittleEndian (* XXX usually? *)
- else if String.starts_with arch "ppc" then
- Bitstring.BigEndian
- else if String.starts_with arch "sparc" then
- Bitstring.BigEndian
- else
- failwith (sprintf "endian_of_architecture: cannot parse %S" arch)
-
-let unique =
- let i = ref 0 in
- fun () ->
- incr i; !i
-
-(* Minimization of shape fields & content fields. *)
-
-let cmp (n1,_) (n2,_) = compare n1 n2
-
-let hash_values h = Hashtbl.fold (fun _ v vs -> v :: vs) h []
-
-let minimize_shape_field_structs struct_name names kernels =
- let h = Hashtbl.create 13 in
- let rh = Hashtbl.create 13 in
-
- let only_shape_fields =
- List.filter_map (
- fun { PP.field_name = name; field_type = typ } ->
- if classify_field names typ = ShapeField then Some (name, typ)
- else None
- )
- in
-
- let name_of i = sprintf "%s_shape_fields_%d" struct_name i in
-
- List.iter (
- fun ({ PP.kernel_version = version },
- { PP.struct_fields = fields; struct_name = name_check }) ->
- assert (struct_name = name_check);
- let fields = List.sort ~cmp (only_shape_fields fields) in
- let key = List.map fst fields in
- let sf =
- try Hashtbl.find h key
- with Not_found ->
- let i = unique () in
- let sf = { sf_i = i; sf_name = name_of i; sf_fields = fields } in
- Hashtbl.add h key sf;
- sf in
- Hashtbl.add rh version sf
- ) kernels;
-
- let sfs = hash_values h in
- sfs, rh
-
-let minimize_content_field_structs struct_name names kernels =
- let h = Hashtbl.create 13 in
- let rh = Hashtbl.create 13 in
-
- let only_content_fields =
- List.filter_map (
- fun { PP.field_name = name; field_type = typ } ->
- if classify_field names typ = ContentField then Some (name, typ)
- else None
- )
- in
-
- let name_of i = sprintf "%s_content_fields_%d" struct_name i in
-
- List.iter (
- fun ({ PP.kernel_version = version },
- { PP.struct_fields = fields; struct_name = name_check }) ->
- assert (struct_name = name_check);
- let fields = List.sort ~cmp (only_content_fields fields) in
- let key = List.map fst fields in
- let cf =
- try Hashtbl.find h key
- with Not_found ->
- let i = unique () in
- let cf = { cf_i = i; cf_name = name_of i; cf_fields = fields } in
- Hashtbl.add h key cf;
- cf in
- Hashtbl.add rh version cf
- ) kernels;
-
- let cfs = hash_values h in
- cfs, rh
-
-let minimize_parsers struct_name kernels sfhash cfhash =
- let h = Hashtbl.create 13 in
- let rh = Hashtbl.create 13 in
-
- (* Do not change - see Code_generation.re_subst. *)
- let name_of i = sprintf "%s_parser_%d" struct_name i in
-
- List.iter (
- fun ({ PP.kernel_version = version; arch = arch },
- ({ PP.struct_fields = fields; struct_name = name_check }
- as structure)) ->
- assert (struct_name = name_check);
- let endian = endian_of_architecture arch in
- let key = endian, fields in
- let pa =
- try Hashtbl.find h key
- with Not_found ->
- let i = unique () in
- let sf =
- try Hashtbl.find sfhash version
- with Not_found -> assert false in
- let cf =
- try Hashtbl.find cfhash version
- with Not_found -> assert false in
- let pa = { pa_i = i; pa_name = name_of i;
- pa_endian = endian;
- pa_structure = structure;
- pa_shape_field_struct = sf;
- pa_content_field_struct = cf } in
- Hashtbl.add h key pa;
- pa in
- Hashtbl.add rh version pa
- ) kernels;
-
- let pas = hash_values h in
- pas, rh
git.annexia.org / virt-mem.git / blobdiff