(* 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

let (//) = Filename.concat

type pathname = string

type info = {
  kv_i : int;
  kernel_version : string;
  arch : string;
  basename : string;
}

type structure = {
  struct_name : string;
  struct_total_size : int;
  struct_fields : field list;
}

and field = {
  field_name : string;
  field_type : f_type;
  field_offset : int;
  field_size : int;
}

and f_type =
  | FStructPointer of string
  | FVoidPointer
  | FAnonListHeadPointer
  | FListHeadPointer of (string * string) option
  | FInteger
  | FString of int

let string_of_info i =
  sprintf "%s: %s (%d) %s" i.basename i.kernel_version i.kv_i i.arch

let rec string_of_structure s =
  let fields = List.map string_of_field s.struct_fields in
  let fields = String.concat "\n  " fields in
  sprintf "struct %s {\n  %s\n}; /* total size = %d bytes */"
    s.struct_name fields s.struct_total_size

and string_of_field f =
  sprintf "%s %s; /* offset = %d, size = %d */"
    (string_of_f_type f.field_type) f.field_name
    f.field_offset f.field_size

and string_of_f_type = function
  | FStructPointer struct_name -> sprintf "struct %s *" struct_name
  | FVoidPointer -> "void *"
  | FAnonListHeadPointer -> "struct list_head *"
  | FListHeadPointer None ->
      sprintf "struct /* self */ list_head *"
  | FListHeadPointer (Some (struct_name, field_name)) ->
      sprintf "struct /* to %s.%s */ list_head *" struct_name field_name
  | FInteger -> "int"
  | FString width -> sprintf "char[%d]" width

let file_exists name =
  try Unix.access name [Unix.F_OK]; true
  with Unix.Unix_error _ -> false

(* Regular expressions.  We really really should use ocaml-mikmatch ... *)
let re_oldformat = Pcre.regexp "^RPM: \\d+: \\(build \\d+\\) ([-\\w]+) ([\\w.]+) ([\\w.]+) \\(.*?\\) (\\w+)"
let re_keyvalue = Pcre.regexp "^(\\w+): (.*)"

let list_kernels path =
  (* Get the *.info files from the kernels database. *)
  let infos = Sys.readdir path in
  let infos = Array.to_list infos in
  let infos = List.filter (fun name -> String.ends_with name ".info") infos in
  let infos = List.map ( (//) path) infos in

  (* Parse in the *.info files.  These have historically had a few different
   * formats that we need to support.
   *)
  let infos = List.mapi (
    fun i filename ->
      (* Get the basename (for getting the .data file later on). *)
      let basename = Filename.chop_suffix filename ".info" in

      let chan = open_in filename in
      let line = input_line chan in

      (* Kernel version string. *)
      let version, arch =
	if Pcre.pmatch ~rex:re_oldformat line then (
	  (* If the file starts with "RPM: \d+: ..." then it's the
	   * original Fedora format.  Everything in one line.
	   *)
	  let subs = Pcre.exec ~rex:re_oldformat line in
	  (* let name = Pcre.get_substring subs 1 in *)
	  let version = Pcre.get_substring subs 2 in
	  let release = Pcre.get_substring subs 3 in
	  let arch = Pcre.get_substring subs 4 in
	  close_in chan;
	  (* XXX Map name -> PAE, hugemem etc. *)
	  (* name, *) sprintf "%s-%s.%s" version release arch, arch
	) else (
	  (* New-style "key: value" entries, up to end of file or the first
	   * blank line.
	   *)
	  let (*name,*) version, release, arch =
	    (*ref "",*) ref "", ref "", ref "" in
	  let rec loop line =
	    try
	      let subs = Pcre.exec ~rex:re_keyvalue line in
	      let key = Pcre.get_substring subs 1 in
	      let value = Pcre.get_substring subs 2 in
	      (*if key = "Name" then name := value
	      else*) if key = "Version" then version := value
	      else if key = "Release" then release := value
	      else if key = "Architecture" then arch := value;
	      let line = input_line chan in
	      loop line
	    with
	      Not_found | End_of_file ->
		close_in chan
	  in
	  loop line;
	  let (*name,*) version, release, arch =
	    (*!name,*) !version, !release, !arch in
	  if (*name = "" ||*) version = "" || release = "" || arch = "" then
	    failwith (sprintf "%s: missing Name, Version, Release or Architecture key" filename);
	  (* XXX Map name -> PAE, hugemem etc. *)
	  (* name, *) sprintf "%s-%s.%s" version release arch, arch
	) in

      (*printf "%s -> %s %s\n%!" basename version arch;*)

      { kv_i = i;
	basename = basename; arch = arch;
	kernel_version = version }
  ) infos in

  (* Check the .data, .data.gz or .data.bz2 file exists, and skip with
   * a warning if not.
   *)
  let infos = List.filter (
    fun { basename = basename } ->
      if not (file_exists (basename ^ ".data")) &&
	not (file_exists (basename ^ ".data.gz")) &&
	not (file_exists (basename ^ ".data.bz2")) then (
	  eprintf "warning: %s: no data file found for this kernel - skipping\n%!"
	    basename;
	  false
	)
      else
	true
  ) infos in

  infos

(* XXX This would be better as a proper lex/yacc parser.
 * XXX Even better would be to have a proper interface to libdwarves.
 *)
let re_offsetsize = Pcre.regexp "/\\*\\s+(\\d+)\\s+(\\d+)\\s+\\*/"
let re_intfield = Pcre.regexp "(?:int|char)\\s+(\\w+);"
let re_ptrfield = Pcre.regexp "struct\\s+(\\w+)\\s*\\*\\s*(\\w+);"
let re_voidptrfield = Pcre.regexp "void\\s*\\*\\s*(\\w+);"
let re_strfield = Pcre.regexp "char\\s+(\\w+)\\[(\\d+)\\];"
let re_structopener = Pcre.regexp "(struct|union)\\s+.*{$"
let re_structcloser = Pcre.regexp "}\\s*(\\w+)?(\\[\\d+\\])?;"

let load_structures { basename = basename } struct_names =
  (* For quick access to the opener strings, build a hash. *)
  let openers = Hashtbl.create 13 in
  List.iter (
    fun struct_name ->
      let opener = sprintf "struct %s {" struct_name in
      let closer = "};" in
      Hashtbl.add openers opener (closer, struct_name)
  ) struct_names;

  (* Now read the data file and parse out the structures of interest. *)
  let close_process_in cmd chan =
    match Unix.close_process_in chan with
    | Unix.WEXITED 0 -> ()
    | Unix.WEXITED i ->
	eprintf "%s: command exited with code %d\n" cmd i; exit i
    | Unix.WSIGNALED i ->
	eprintf "%s: command exited with signal %d\n" cmd i; exit 1
    | Unix.WSTOPPED i ->
	eprintf "%s: command stopped by signal %d\n" cmd i; exit 1
  in

  (* Open the data file, uncompressing it on the fly if necessary. *)
  let chan, close =
    if file_exists (basename ^ ".data") then
      open_in (basename ^ ".data"), close_in
    else if file_exists (basename ^ ".data.gz") then (
      let cmd =
	sprintf "gzip -cd %s" (Filename.quote (basename ^ ".data.gz")) in
      Unix.open_process_in cmd, close_process_in cmd
    )
    else if file_exists (basename ^ ".data.bz2") then (
      let cmd =
	sprintf "bzip2 -cd %s" (Filename.quote (basename ^ ".data.bz2")) in
      Unix.open_process_in cmd, close_process_in cmd
    ) else
      failwith (sprintf "%s: cannot find corresponding data file" basename) in

  (* Read the data file in, looking for structures of interest to us. *)
  let bodies = Hashtbl.create 13 in
  let rec loop () =
    let line = input_line chan in

    (* If the line is an opener for one of the structures we
     * are looking for, then for now just save all the text until
     * we get to the closer line.
     *)
    (try
       let closer, struct_name = Hashtbl.find openers line in
       let rec loop2 lines =
	 let line = input_line chan in
	 let lines = line :: lines in
	 if String.starts_with line closer then List.rev lines
	 else loop2 lines
       in

       let body =
	 try loop2 [line]
	 with End_of_file ->
	   failwith (sprintf "%s: %s: %S not matched by closing %S" basename struct_name line closer) in

       Hashtbl.replace bodies struct_name body
     with Not_found -> ());

    loop ()
  in
  (try loop () with End_of_file -> ());

  close chan;

  (* Now parse each structure body. *)

  (* 'basename' is the source file, and second parameter ('body') is
   * the list of text lines which covers this structure (minus the
   * opener line).  Result is the list of parsed fields from this
   * structure.
   *)
  let rec parse basename = function
    | [] -> assert false
    | [_] -> []			 (* Just the closer line, finished. *)
    | line :: lines when Pcre.pmatch ~rex:re_structopener line ->
      (* Recursively parse a sub-structure.  First search for the
       * corresponding closer line.
       *)
      let rec loop depth acc = function
	| [] ->
	    eprintf "%s: %S has no matching close structure line\n%!"
	      basename line;
	    assert false
	| line :: lines when Pcre.pmatch ~rex:re_structopener line ->
	  loop (depth+1) (line :: acc) lines
	| line :: lines
	    when depth = 0 && Pcre.pmatch ~rex:re_structcloser line ->
	  (line :: acc), lines
	| line :: lines
	    when depth > 0 && Pcre.pmatch ~rex:re_structcloser line ->
	  loop (depth-1) (line :: acc) lines
	| line :: lines -> loop depth (line :: acc) lines
      in
      let nested_body, rest = loop 0 [] lines in

      (* Then parse the sub-structure. *)
      let struct_name, nested_body =
	match nested_body with
	| [] -> assert false
	| closer :: _ ->
	    let subs = Pcre.exec ~rex:re_structcloser closer in
	    let struct_name =
	      try Some (Pcre.get_substring subs 1) with Not_found -> None in
	    struct_name, List.rev nested_body in
      let nested_fields = parse basename nested_body in

      (* Prefix the sub-fields with the name of the structure. *)
      let nested_fields =
	match struct_name with
	| None -> nested_fields
	| Some prefix ->
            List.map (
              fun ({ field_name = name } as field) ->
		let name = prefix ^ "'" ^ name in
		{ field with field_name = name }
            ) nested_fields in

      (* Parse the rest. *)
      nested_fields @ parse basename rest

    | line :: lines when Pcre.pmatch ~rex:re_intfield line ->
      (* An int field. *)
      let subs = Pcre.exec ~rex:re_intfield line in
      let name = Pcre.get_substring subs 1 in
      (try
	 let subs = Pcre.exec ~rex:re_offsetsize line in
	 let offset = int_of_string (Pcre.get_substring subs 1) in
	 let size = int_of_string (Pcre.get_substring subs 2) in
	 let field =
	   { field_name = name; field_type = FInteger;
	     field_offset = offset; field_size = size } in
	 field :: parse basename lines
       with
	 Not_found -> parse basename lines
      );

    | line :: lines when Pcre.pmatch ~rex:re_ptrfield line ->
      (* A pointer-to-struct field. *)
      let subs = Pcre.exec ~rex:re_ptrfield line in
      let struct_name = Pcre.get_substring subs 1 in
      let name = Pcre.get_substring subs 2 in
      (try
	 let subs = Pcre.exec ~rex:re_offsetsize line in
	 let offset = int_of_string (Pcre.get_substring subs 1) in
	 let size = int_of_string (Pcre.get_substring subs 2) in
	 let field_type =
	   if struct_name <> "list_head" then
	     FStructPointer struct_name
	   else
	     FAnonListHeadPointer in
	 let field =
	   { field_name = name; field_type = field_type;
	     field_offset = offset; field_size = size } in
	 field :: parse basename lines
       with
	 Not_found -> parse basename lines
      );

    | line :: lines when Pcre.pmatch ~rex:re_voidptrfield line ->
      (* A void* field. *)
      let subs = Pcre.exec ~rex:re_voidptrfield line in
      let name = Pcre.get_substring subs 1 in
      (try
	 let subs = Pcre.exec ~rex:re_offsetsize line in
	 let offset = int_of_string (Pcre.get_substring subs 1) in
	 let size = int_of_string (Pcre.get_substring subs 2) in
	 let field =
	   { field_name = name; field_type = FVoidPointer;
	     field_offset = offset; field_size = size } in
	 field :: parse basename lines
       with
	 Not_found -> parse basename lines
      );

    | line :: lines when Pcre.pmatch ~rex:re_strfield line ->
      (* A string (char array) field. *)
      let subs = Pcre.exec ~rex:re_strfield line in
      let name = Pcre.get_substring subs 1 in
      let width = int_of_string (Pcre.get_substring subs 2) in
      (try
	 let subs = Pcre.exec ~rex:re_offsetsize line in
	 let offset = int_of_string (Pcre.get_substring subs 1) in
	 let size = int_of_string (Pcre.get_substring subs 2) in
	 let field =
	   { field_name = name; field_type = FString width;
	     field_offset = offset; field_size = size } in
	 field :: parse basename lines
       with
	 Not_found -> parse basename lines
      );

    | _ :: lines ->
	(* Just ignore any other field we can't parse. *)
	parse basename lines
  in

  let structures = List.filter_map (
    fun struct_name ->
      let body =
	try Some (Hashtbl.find bodies struct_name)
	with Not_found -> None in
      match body with
      | None -> None
      | Some body ->
	  let body = List.tl body in (* Don't care about opener line. *)
	  let fields = parse basename body in

	  (* Compute total size of the structure. *)
	  let total_size =
	    let fields = List.map (
	      fun { field_offset = offset;
		    field_size = size } -> offset + size
	    ) fields in
	    List.fold_left max 0 fields in

	  (* Sort the structure fields by field offset.  They are
	   * probably already in this order, but just make sure.
	   *)
	  let cmp { field_offset = o1 } { field_offset = o2 } = compare o1 o2 in
	  let fields = List.sort ~cmp fields in

	  Some (
	    struct_name,
	    { struct_name = struct_name;
	      struct_fields = fields;
	      struct_total_size = total_size }
	  )
  ) struct_names in

  structures

(* XXX This loop is O(n^3), luckily n is small! *)
let transpose good_struct_names kernels =
  List.map (
    fun struct_name ->
      let kernels =
	List.filter_map (
	  fun (info, structures) ->
	    try
	      let s = List.assoc struct_name structures in
	      Some (info, s)
	    with
	      Not_found -> None
	) kernels in

      (* Sort the kernels, which makes the generated output more stable
       * and makes patches more useful.
       *)
      let kernels = List.sort kernels in

      struct_name, kernels
  ) good_struct_names

let get_fields structures =
  (* Use a hash table to accumulate the fields as we find them.
   * The key is the field name.  The value is the field type and the
   * kernel version where first seen (for error reporting).  If
   * we meet the field again, we check its type hasn't changed.
   * Finally, we can use the hash to pull out all field names and
   * types.
   *)
  let h = Hashtbl.create 13 in

  (* A hash to check for fields which aren't always available by
   * counting the number of times we see each field.
   *)
  let count, get =
    let h = Hashtbl.create 13 in
    let count field_name =
      let r =
	try Hashtbl.find h field_name
	with Not_found -> let r = ref 0 in Hashtbl.add h field_name r; r in
      incr r
    in
    let get field_name = try !(Hashtbl.find h field_name) with Not_found -> 0 in
    count, get
  in

  List.iter (
    fun ({kernel_version = version},
	 {struct_name = struct_name; struct_fields = fields}) ->
      List.iter (
	fun {field_name = name; field_type = typ} ->
	  count name;
	  try
	    let (field_type, version_first_seen) = Hashtbl.find h name in
	    if typ <> field_type then (
	      eprintf "Error: %s.%s: field changed type between kernel versions.\n"
		struct_name name;
	      eprintf "In version %s it had type %s.\n"
		version_first_seen (string_of_f_type field_type);
	      eprintf "In version %s it had type %s.\n"
		version (string_of_f_type typ);
	      eprintf "The code cannot handle fields which change type like this.\n";
	      eprintf "See extract/codegen/pahole_parser.mli for more details.\n";
	      exit 1
	    )
	  with Not_found ->
	    Hashtbl.add h name (typ, version)
      ) fields
  ) structures;

  let nr_kernels = List.length structures in

  let fields =
    Hashtbl.fold (
      fun name (typ, _) fields ->
	let always_available = get name = nr_kernels in
	(name, (typ, always_available)) :: fields
    ) h [] in

  List.sort fields