(* 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.FStructPointer struct_name | PP.FListHeadPointer 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 : PP.field list;
}

and content_field_struct = {
  cf_i : int;
  cf_name : string;
  cf_fields : PP.field list;
}

and parser_ = {
  pa_i : int;
  pa_name : string;
  pa_endian : Bitstring.endian;
  pa_fields : Pahole_parser.field list;
  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 { PP.field_name = n1 } { PP.field_name = 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 (
      fun { PP.field_type = typ } ->
	classify_field names typ = ShapeField
    )
  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 (fun { PP.field_name = name } -> name) 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 (
      fun { PP.field_type = typ } ->
	classify_field names typ = ContentField
    )
  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 (fun { PP.field_name = name } -> name) 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

  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 }) ->
      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_fields = fields;
		     pa_endian = endian;
		     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