(* 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 Camlp4.PreCast
open Syntax
(*open Ast*)

open ExtList
open ExtString
open Printf

module PP = Pahole_parser
module SC = Struct_classify

(* We don't care about locations when generating code, so it's
 * useful to just have a single global _loc.
 *)
let _loc = Loc.ghost

(* Some handy camlp4 construction functions which do some
 * things that ought to be easy/obvious but aren't.
 *
 * 'concat_str_items' concatenates a list of str_item together into
 * one big str_item.
 *
 * 'concat_record_fields' concatenates a list of records fields into
 * a record.  The list must have at least one element.
 *
 * 'build_record' builds a record out of record fields.
 * 
 * 'build_tuple_from_exprs' builds an arbitrary length tuple from
 * a list of expressions of length >= 2.
 *
 * Thanks to bluestorm on #ocaml for getting these working.
 *)
let concat_str_items items =
  match items with
  | [] -> <:str_item< >>
  | x :: xs ->
      List.fold_left (fun xs x -> <:str_item< $xs$ $x$ >>) x xs

let concat_sig_items items =
  match items with
  | [] -> <:sig_item< >>
  | x :: xs ->
      List.fold_left (fun xs x -> <:sig_item< $xs$ $x$ >>) x xs

let concat_record_fields fields =
  match fields with
    | [] -> assert false
    | f :: fs ->
	List.fold_left (fun fs f -> <:ctyp< $fs$ ; $f$ >>) f fs

let concat_record_bindings rbs =
  match rbs with
    | [] -> assert false
    | rb :: rbs ->
	List.fold_left (fun rbs rb -> <:rec_binding< $rbs$ ; $rb$ >>) rb rbs

let build_record rbs =
  Ast.ExRec (_loc, rbs, Ast.ExNil _loc)

let build_tuple_from_exprs exprs =
  match exprs with
  | [] | [_] -> assert false
  | x :: xs ->
      Ast.ExTup (_loc,
		 List.fold_left (fun xs x -> Ast.ExCom (_loc, x, xs)) x xs)

let ocaml_type_of_field_type = function
  | PP.FInteger -> <:ctyp< int64 >>
  | PP.FString _ -> <:ctyp< string >>
  | PP.FStructPointer _ | PP.FVoidPointer
  | PP.FAnonListHeadPointer | PP.FListHeadPointer _ ->
      <:ctyp< Virt_mem_mmap.addr >>

let generate_types xs =
  let strs = List.map (
    fun (struct_name, sflist, cflist) ->
      let sflist = List.map (
	fun { SC.sf_name = sf_name; sf_fields = fields } ->
	  if fields <> [] then (
	    let fields = List.map (
	      fun { PP.field_name = name; PP.field_type = t } ->
		let t = ocaml_type_of_field_type t in
		<:ctyp< $lid:sf_name^"_"^name$ : $t$ >>
	    ) fields in
	    let fields = concat_record_fields fields in

	    <:str_item<
	      type $lid:sf_name$ = { $fields$ }
            >>
	  ) else
	    <:str_item< type $lid:sf_name$ = unit >>
      ) sflist in
      let sflist = concat_str_items sflist in

      let cflist = List.map (
	fun { SC.cf_name = cf_name; cf_fields = fields } ->
	  if fields <> [] then (
	    let fields = List.map (
	      fun { PP.field_name = name; PP.field_type = t } ->
		let t = ocaml_type_of_field_type t in
		<:ctyp< $lid:cf_name^"_"^name$ : $t$ >>
	    ) fields in
	    let fields = concat_record_fields fields in

	    <:str_item<
	      type $lid:cf_name$ = { $fields$ }
            >>
	  ) else
	    <:str_item< type $lid:cf_name$ = unit >>
      ) cflist in
      let cflist = concat_str_items cflist in

      <:str_item<
        type ('a, 'b) $lid:struct_name$ = {
	  $lid:struct_name^"_shape"$ : 'a;
	  $lid:struct_name^"_content"$ : 'b;
	}
	$sflist$
	$cflist$
      >>
  ) xs in

  let sigs =
    List.map (
      fun (struct_name, _, _) ->
	<:sig_item<
          type ('a, 'b) $lid:struct_name$
	>>
    ) xs in

  concat_str_items strs, concat_sig_items sigs

let generate_parsers xs =
  let strs =
    List.map (
      fun (struct_name, palist) ->
	let palist =
	  List.map (
	    fun { SC.pa_name = pa_name } ->
	      <:str_item< let $lid:pa_name$ bits = $str:pa_name$ >>
	  ) palist in
	concat_str_items palist
    ) xs in

  let strs = concat_str_items strs in
  let strs =
    <:str_item<
      let match_err = "failed to match kernel structure" ;;
      let zero = 0 ;;
      $strs$
    >> in

  (* The shared parser functions.
   * 
   * We could include bitmatch statements directly in here, but
   * what happens is that the macros get expanded here, resulting
   * in (even more) unreadable generated code.  So instead just
   * do a textual substitution later by post-processing the
   * generated files.  Not type-safe, but we can't have
   * everything.
   *)
  let subs = Hashtbl.create 13 in
  List.iter (
    fun (struct_name, palist) ->
      List.iter (
	fun ({ SC.pa_name = pa_name;
	       pa_endian = endian; pa_structure = structure;
	       pa_shape_field_struct = sf;
	       pa_content_field_struct = cf }) ->
	  (* Generate the code to match this structure. *)
	  let endian =
	    match endian with
	    | Bitstring.LittleEndian -> "littleendian"
	    | Bitstring.BigEndian -> "bigendian"
	    | _ -> assert false in
	  let patterns =
	    String.concat ";\n      " (
	      List.map (
		function
		| { PP.field_name = field_name;
		    field_type = PP.FInteger;
		    field_offset = offset;
		    field_size = size } ->
		    (* 'zero+' is a hack to force the type to int64. *)
		    sprintf "%s : zero+%d : offset(%d), %s"
		      field_name (size*8) (offset*8) endian

		| { PP.field_name = field_name;
		    field_type = (PP.FStructPointer _
		                  | PP.FVoidPointer
				  | PP.FAnonListHeadPointer
				  | PP.FListHeadPointer _);
		    field_offset = offset;
		    field_size = size } ->
		    sprintf "%s : zero+%d : offset(%d), %s"
		      field_name (size*8) (offset*8) endian

		| { PP.field_name = field_name;
		    field_type = PP.FString width;
		    field_offset = offset;
		    field_size = size } ->
		    sprintf "%s : %d : offset(%d), string"
		      field_name (width*8) (offset*8)
	      ) structure.PP.struct_fields
	    ) in

	  let shape_assignments =
	    List.map (
	      fun { PP.field_name = field_name;
		    field_type = field_type;
		    field_offset = offset } ->

		match field_type with
		| PP.FListHeadPointer None ->
		    sprintf "%s_%s = Int64.sub %s %dL"
		      sf.SC.sf_name field_name field_name offset

		| PP.FListHeadPointer (Some (other_struct_name, other_field_name)) ->
		    let other_offset = 666 in
		    sprintf "%s_%s = Int64.sub %s %dL"
		      sf.SC.sf_name field_name field_name other_offset

		| _ ->
		    sprintf "%s_%s = %s" sf.SC.sf_name field_name field_name
	    ) sf.SC.sf_fields in

	  let shape_assignments =
	    String.concat ";\n        " shape_assignments in

	  let content_assignments =
	    List.map (
	      fun { PP.field_name = field_name } ->
		sprintf "%s_%s = %s" sf.SC.sf_name field_name field_name
	    ) sf.SC.sf_fields in

	  let content_assignments =
	    String.concat ";\n        " content_assignments in

	  let code =
	    sprintf "
  bitmatch bits with
  | { %s } ->
      let shape =
      { %s } in
      let content =
      { %s } in
      { %s_shape = shape; %s_content = content }
  | { _ } ->
      raise (Virt_mem_types.ParseError (%S, %S, match_err))"
	      patterns shape_assignments content_assignments
	      struct_name struct_name
	      struct_name pa_name in

	  Hashtbl.add subs pa_name code
      ) palist;
  ) xs;

  strs, <:sig_item< >>, subs

let output_interf ~output_file types parsers =
  let sigs = concat_sig_items [ types; parsers ] in
  Printers.OCaml.print_interf ~output_file sigs

(* Finally generate the output files. *)
let re_subst = Pcre.regexp "^(.*)\"(\\w+_parser_\\d+)\"(.*)$"

let output_implem ~output_file types parsers parser_subs =
  let new_output_file = output_file ^ ".new" in

  let strs = concat_str_items [ types; parsers ] in
  Printers.OCaml.print_implem ~output_file:new_output_file strs;

  (* Substitute the parser bodies in the output file. *)
  let ichan = open_in new_output_file in
  let ochan = open_out output_file in

  output_string ochan "\
(* WARNING: This file and the corresponding mli (interface) are
 * automatically generated by the extract/codegen/ program.
 *
 * Any edits you make to this file will be lost.
 *
 * To update this file from the latest kernel database, it is recommended
 * that you do 'make update-kernel-structs'.
 *)\n\n";

  let rec loop () =
    let line = input_line ichan in
    let line =
      if Pcre.pmatch ~rex:re_subst line then (
	let subs = Pcre.exec ~rex:re_subst line in
	let start = Pcre.get_substring subs 1 in
	let template = Pcre.get_substring subs 2 in
	let rest = Pcre.get_substring subs 3 in
	let sub =
	  try Hashtbl.find parser_subs template
	  with Not_found -> assert false in
	start ^ sub ^ rest
      ) else line in
    output_string ochan line; output_char ochan '\n';
    loop ()
  in
  (try loop () with End_of_file -> ());

  close_out ochan;
  close_in ichan;

  Unix.unlink new_output_file