(* Memory info 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.
*)

(* This program takes the kernel database (in kernels/ in toplevel
   directory) and generates parsing code for the various structures
   in the kernel that we are interested in.

   The output programs -- *.ml, *.mli files of generated code -- go
   into lib/ at the toplevel, eg. lib/virt_mem_kernels.ml

   The stuff at the top of this file determine what structures
   we try to parse.
*)

type struct_t = {
  good_fields : string list;
  field_metadata : (string * field_metadata_t) list;
}
and field_metadata_t =
  | VoidPointerIsReally of string
  | ListHeadIsReally of string

(*----------------------------------------------------------------------
 * This controls what structures & fields we will parse out.
 *----------------------------------------------------------------------*)
let good_structs = [
  "task_struct", {
    good_fields = [ "tasks'next"; "tasks'prev";
		    "run_list'next"; "run_list'prev";
		    "state"; "prio"; "static_prio"; "normal_prio";
		    "comm"; "pid" ];
    field_metadata = [
      "tasks'next", ListHeadIsReally "task_struct";
      "tasks'prev", ListHeadIsReally "task_struct";
      "run_list'next", ListHeadIsReally "task_struct";
      "run_list'prev", ListHeadIsReally "task_struct";
    ];
  };
  "net_device", {
    good_fields = [ "dev_list'prev"; "dev_list'next"; "next";
		    "ip_ptr"; "ip6_ptr";
		    "name"; "flags"; "operstate"; "mtu"; "perm_addr";
		    "addr_len" ];
    field_metadata = [
      "dev_list'next", ListHeadIsReally "net_device";
      "dev_list'prev", ListHeadIsReally "net_device";
      "ip_ptr", VoidPointerIsReally "in_device";
      "ip6_ptr", VoidPointerIsReally "inet6_dev";
    ];
  };
  "net", {
    good_fields = [ "dev_base_head'next"; "dev_base_head'prev" ];
    field_metadata = [
      "dev_base_head'next", ListHeadIsReally "net_device";
      "dev_base_head'prev", ListHeadIsReally "net_device";
    ];
  };
  "in_device", {
    good_fields = [ "ifa_list" ];
    field_metadata = [];
  };
  "inet6_dev", {
    good_fields = [ "addr_list" ];
    field_metadata = [];
  };
  "in_ifaddr", {
    good_fields = [ "ifa_next"; "ifa_local"; "ifa_address";
		    "ifa_mask"; "ifa_broadcast" ];
    field_metadata = [];
  };
  "inet6_ifaddr", {
    good_fields = [ "prefix_len"; "lst_next" ];
    field_metadata = [];
  };
]

let debug = true

open Camlp4.PreCast
open Syntax
(*open Ast*)

open ExtList
open ExtString
open Printf

module PP = Pahole_parser
module SC = Struct_classify
module CG = Code_generation

let (//) = Filename.concat

(* Start of the main program. *)
let () =
  let quick = ref false in
  let anon_args = ref [] in

  let argspec = Arg.align [
    "--quick", Arg.Set quick, " Quick mode (just for testing)";
  ] in

  let anon_arg str = anon_args := str :: !anon_args in
  let usage = "\
compile-kerneldb: Turn kernels database into code modules.

Usage:
  compile-kerneldb [-options] <kerneldb> <outputdir>

For example, from the top level of the virt-mem source tree:
  compile-kerneldb kernels/ lib/

Options:
" in
  Arg.parse argspec anon_arg usage;

  let quick = !quick in
  let anon_args = List.rev !anon_args in

  let kernelsdir, outputdir =
    match anon_args with
    | [kd;od] -> kd,od
    | _ ->
	eprintf "compile-kerneldb <kerneldb> <outputdir>\n";
	exit 2 in

  (* Read in the list of kernels from the kerneldb. *)
  let kernels = PP.list_kernels kernelsdir in

  (* In quick mode, just process the first few kernels. *)
  let kernels = if quick then List.take 10 kernels else kernels in

  let good_struct_names = List.map fst good_structs in

  (* Load in the structures. *)
  let nr_kernels = List.length kernels in
  let kernels = List.mapi (
    fun i info ->
      printf "Loading kernel data file %d/%d\r%!" (i+1) nr_kernels;

      let structures = PP.load_structures info good_struct_names in

      (info, structures)
  ) kernels in

  (* Keep only the good fields. *)
  let kernels = List.map (
    fun (info, structures) ->
      let structures = List.map (
	fun (struct_name, structure) ->
	  let { good_fields = good_fields } =
	    List.assoc struct_name good_structs in
	  let fields = List.filter (
	    fun { PP.field_name = name } -> List.mem name good_fields
	  ) structure.PP.struct_fields in
	  struct_name, { structure with PP.struct_fields = fields }
      ) structures in
      (info, structures)
  ) kernels in

  (* Turn anonymous list_head and void * pointers into pointers to
   * known structure types, where we have that meta-information.
   *)
  let kernels = List.map (
    fun (info, structures) ->
      let structures = List.map (
	fun (struct_name, structure) ->
	  let { field_metadata  = metadata } =
	    List.assoc struct_name good_structs in
	  let fields = structure.PP.struct_fields in
	  let fields = List.map (
	    fun ({ PP.field_name = name; PP.field_type = typ } as field) ->
	      try
		let meta = List.assoc name metadata in
		let typ =
		  match meta, typ with
		  | ListHeadIsReally s, PP.FAnonListHeadPointer ->
		      PP.FListHeadPointer s
		  | VoidPointerIsReally s, PP.FVoidPointer ->
		      PP.FStructPointer s
		  | _, typ -> typ in
		{ field with PP.field_type = typ }
	      with
		Not_found -> field
	  ) fields in
	  struct_name, { structure with PP.struct_fields = fields }
      ) structures in
      (info, structures)
  ) kernels in

  if debug then
    List.iter (
      fun (info, structures) ->
	printf "\n%s ----------\n" (PP.string_of_info info);
	List.iter (
	  fun (_, structure) ->
	    printf "%s\n\n" (PP.string_of_structure structure);
	) structures;
    ) kernels;

  (* First output file is a simple list of kernels, to support the
   * 'virt-mem --list-kernels' option.
   *)
  let () =
    let _loc = Loc.ghost in

    let versions = List.map (
      fun ({ PP.kernel_version = version }, _) -> version
    ) kernels in

    (* Sort them in reverse because we are going to generate the
     * final list in reverse.
     *)
    let cmp a b = compare b a in
    let versions = List.sort ~cmp versions in

    let xs =
      List.fold_left (fun xs version -> <:expr< $str:version$ :: $xs$ >>)
      <:expr< [] >> versions in

    let code = <:str_item<
      let kernels = $xs$
    >> in

    let output_file = outputdir // "virt_mem_kernels.ml" in
    printf "Writing list of kernels to %s ...\n%!" output_file;
    Printers.OCaml.print_implem ~output_file code in

  (* We want to track single structures as they have changed over
   * time, ie. over kernel versions.  Transpose our dataset so we are
   * looking at structures over time.
   *)
  let structures = PP.transpose good_struct_names kernels in

  let kernels = () in ignore (kernels); (* garbage collect *)

  let structures =
    List.map (
      fun (struct_name, kernels) ->
	let all_fields = PP.get_fields kernels in
	(struct_name, (kernels, all_fields))
    ) structures in

  if debug then
    List.iter (
      fun (struct_name, (kernels, all_fields)) ->
	printf "struct %s:\n" struct_name;
	printf "  structure occurs in %d kernel versions\n"
	  (List.length kernels);
	printf "  union of fields found:\n";
	List.iter (
	  fun (field_name, field_type) ->
	    printf "    %s %s\n" (PP.string_of_f_type field_type) field_name
	) all_fields
    ) structures;

  (* Now perform the minimization step for each structure.
   * We do separate minimization for:
   *   - shape field structures
   *   - content field structures
   *   - parsers
   *)
  let structures =
    List.map (
      fun (struct_name, (kernels, all_fields)) ->
	let sflist, sfhash =
	  SC.minimize_shape_field_structs struct_name good_struct_names
	    kernels in

	let cflist, cfhash =
	  SC.minimize_content_field_structs struct_name good_struct_names
	    kernels in

	let palist, pahash =
	  SC.minimize_parsers struct_name kernels sfhash cfhash in

	(struct_name, (kernels, all_fields,
		       sflist, sfhash, cflist, cfhash, palist, pahash))
    ) structures in

  if debug then
    List.iter (
      fun (struct_name,
	   (kernels, all_fields,
	    sflist, sfhash, cflist, cfhash, palist, pahash)) ->
	printf "struct %s:\n" struct_name;

	printf "  shape field structures:\n";
	List.iter (
	  fun { SC.sf_name = name; sf_fields = fields } ->
	    printf "    type %s = {\n" name;
	    List.iter (
	      fun { PP.field_name = name; field_type = typ } ->
		printf "      %s %s;\n" (PP.string_of_f_type typ) name
	    ) fields;
	    printf "    }\n";
	) sflist;

	printf "  content field structures:\n";
	List.iter (
	  fun { SC.cf_name = name; cf_fields = fields } ->
	    printf "    type %s = {\n" name;
	    List.iter (
	      fun { PP.field_name = name; field_type = typ } ->
		printf "      %s %s;\n" (PP.string_of_f_type typ) name
	    ) fields;
	    printf "    }\n";
	) cflist;

	printf "  parsers:\n";
	List.iter (
	  fun { SC.pa_name = name;
		pa_shape_field_struct = sf;
		pa_content_field_struct = cf } ->
	    printf "    let %s = ...\n" name;
	    printf "      -> (%s, %s)\n" sf.SC.sf_name cf.SC.cf_name
	) palist
    ) structures;

  (* Now let's generate some code. *)
  let implem_types, interf_types =
    CG.generate_types (
      List.map (
	fun (struct_name,
	     (_, _, sflist, _, cflist, _, _, _)) ->
	  (struct_name, sflist, cflist)
      ) structures
    ) in

  (* Output the generated code. *)
  let output_file = outputdir // "kernel.mli" in
  printf "Writing kernel data interface to %s ...\n%!" output_file;
  CG.output_interf ~output_file interf_types;

  let output_file = outputdir // "kernel.ml" in
  printf "Writing kernel data parsers to %s ...\n%!" output_file;
  CG.output_implem ~output_file implem_types;

  (* XXX Here we need to substitute the parser code. *)