heptagon/compiler/obc/c/cmain.ml

(**************************************************************************)
(*                                                                        *)
(*  Heptagon                                                              *)
(*                                                                        *)
(*  Author : Marc Pouzet                                                  *)
(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
(*                                                                        *)
(**************************************************************************)

open Format
open List
open Misc
open Names
open Idents
open Obc
open Obc_utils
open Types
open Modules
open Signature
open C
open Cgen
open Location
open Format
open Compiler_utils

(** {1 Main C function generation} *)

let _ = Idents.enter_node (Modules.fresh_value "cmain" "main")

let fresh n = Idents.name (Idents.gen_var "cmain" n)

(* Unique names for C variables handling step counts. *)
let step_counter = fresh "step_c"
and max_step = fresh"step_max"

let assert_node_res cd =
  let stepm = find_step_method cd in
  if List.length stepm.m_inputs > 0 then
    (Format.eprintf "Cannot generate run-time check for node %s with inputs.@."
       (cname_of_qn cd.cd_name);
     exit 1);
  if (match stepm.m_outputs with
        | [{ v_type = Tid nbool; }] when nbool = Initial.pbool -> false
        | _ -> true) then
    (Format.eprintf
       "Cannot generate run-time check for node %s with non-boolean output.@."
       (cname_of_qn cd.cd_name);
     exit 1);
  let name = cname_of_qn cd.cd_name in
  let out =
    (fresh ("out_for_" ^ name),
      Cty_id (qn_append cd.cd_name "_out")) in
  let mem, reset_i =
    if cd.cd_stateful
    then ([], [])
    else
      let mem =
        (fresh ("mem_for_" ^ name), Cty_id (qn_append cd.cd_name "_mem")) in
      ([mem],
       [Csexpr (Cfun_call (name ^ "_reset", [Caddrof (Cvar (fst mem))]))]) in
  let step_i =
    (*
      step(&out, &mem);
      if (!out.proper_name) {
        printf("Node $node failed at step %d.\n", step_count);
        return 1;
      }
    *)
    let outn = Idents.name ((List.hd stepm.m_outputs).v_ident) in
    Csblock
      { var_decls = [];
        block_body =
          [
            Csexpr (Cfun_call (name ^ "_step",
                               Caddrof (Cvar (fst out))
                               :: (if cd.cd_stateful
                                   then [Caddrof (Cvar (fst (List.hd mem)))]
                                   else [])));
            Cif (Cuop ("!", Clhs (Cfield (Cvar (fst out), local_qn outn))),
                 [Csexpr (Cfun_call ("fprintf",
                                     [Clhs(Cvar "stderr");
				      Cconst (Cstrlit ("Node \\\"" ^ name
                                                       ^ "\\\" failed at step" ^
                                                       " %d.\\n"));
                                      Clhs (Cvar step_counter)]));
                  Creturn (Cconst (Ccint 1))],
                 []);
          ];
      } in
  (out :: mem, reset_i, step_i);;

(** [main_def_of_class_def cd] returns a [(var_list, rst_i, step_i)] where
    [var_list] (resp. [rst_i] and [step_i]) is a list of variables (resp. of
    statements) needed for a main() function calling [cd]. *)
let main_def_of_class_def cd =
  let format_for_type ty = match ty with
    | Tarray _ | Tprod _ | Tinvalid -> assert false
    | Types.Tid id when id = Initial.pfloat -> "%f"
    | Types.Tid id when id = Initial.pint -> "%d"
    | Types.Tid id when id = Initial.pbool -> "%d"
    | Tid _ -> "%s"
  in

  (** Does reading type [ty] need a buffer? When it is the case,
      [need_buf_for_ty] also returns the type's name. *)
  let need_buf_for_ty ty = match ty with
    | Tarray _ | Tprod _ | Tinvalid -> assert false
    | Types.Tid id when id = Initial.pfloat -> None
    | Types.Tid id when id = Initial.pint -> None
    | Types.Tid id when id = Initial.pbool -> None
    | Tid { name = n } -> Some n
  in
  let cprint_string s = Csexpr (Cfun_call ("printf", [Cconst (Cstrlit s)])) in

  (** Generates scanf statements. *)
  let rec read_lhs_of_ty lhs ty = match ty with
    | Tarray (ty, n) ->
        let iter_var = fresh "i" in
        let lhs = Carray (lhs, Clhs (Cvar iter_var)) in
        let (reads, bufs) = read_lhs_of_ty lhs ty in
        ([Cfor (iter_var, Cconst (Ccint 0), cexpr_of_static_exp n, reads)], bufs)
    | _ ->
        let rec mk_prompt lhs = match lhs with
          | Cvar vn -> (vn, [])
          | Carray (lhs, cvn) ->
              let (vn, args) = mk_prompt lhs in
              (vn ^ "[%d]", cvn :: args)
          | _ -> assert false in
        let (prompt, args_format_s) = mk_prompt lhs in
        let scan_exp =
          let printf_s = Format.sprintf "%s ? " prompt in
          let format_s = format_for_type ty in
	  let exp_scanf = Cfun_call ("scanf",
                                     [Cconst (Cstrlit format_s);
                                      Caddrof lhs]) in
	  let body =
	    if !Compiler_options.hepts_simulation
	    then (* hepts: systematically test and quit when EOF *)
	      [Cif(Cbop("==",exp_scanf,Clhs(Cvar("EOF"))),
		   [Creturn(Cconst(Ccint(0)))],[])]
	    else
	      [Csexpr (exp_scanf);] in
	  let body =
	    if !Compiler_options.hepts_simulation then
	      body
	    else
	      Csexpr (Cfun_call ("printf",
                                 Cconst (Cstrlit printf_s)
                                 :: args_format_s))
	      :: body in
          Csblock { var_decls = [];
                    block_body = body; } in
        match need_buf_for_ty ty with
          | None -> ([scan_exp], [])
          | Some tyn ->
              let varn = fresh "buf" in
              ([scan_exp;
                Csexpr (Cfun_call (tyn ^ "_of_string",
                                   [Clhs (Cvar varn)]))],
               [(varn, Cty_arr (20, Cty_char))]) in

  (** Generates printf statements and buffer declarations needed for printing
      resulting values of enum types. *)
  let rec write_lhs_of_ty lhs ty = match ty with
    | Tarray (ty, n) ->
        let iter_var = fresh "i" in
        let lhs = Carray (lhs, Clhs (Cvar iter_var)) in
        let (writes, bufs) = write_lhs_of_ty lhs ty in
	let writes_loop = 
	  Cfor (iter_var, Cconst (Ccint 0), cexpr_of_static_exp n, writes) in
	if !Compiler_options.hepts_simulation then
	  ([writes_loop], bufs)
	else
          ([cprint_string "[ ";
	    writes_loop;
            cprint_string "]"], bufs)
    | _ ->
        let varn = fresh "buf" in
        let format_s = format_for_type ty in
	let format_s =
	  if !Compiler_options.hepts_simulation
	  then format_s ^ "\\n"
	  else format_s ^ " " in
        let nbuf_opt = need_buf_for_ty ty in
        let ep = match nbuf_opt with
          | None -> [Clhs lhs]
          | Some sid -> [Cfun_call ("string_of_" ^ sid,
                                    [Clhs lhs;
                                     Clhs (Cvar varn)])] in
        ([Csexpr (Cfun_call ("printf",
                             Cconst (Cstrlit (format_s))
                             :: ep))],
         match nbuf_opt with
           | None -> []
           | Some _ -> [(varn, Cty_arr (20, Cty_char))]) in

  let stepm = find_step_method cd in
  let (scanf_calls, scanf_decls) =
    let read_lhs_of_ty_for_vd vd =
      read_lhs_of_ty (Cvar (Idents.name vd.v_ident)) vd.v_type in
    split (map read_lhs_of_ty_for_vd stepm.m_inputs) in

  let (printf_calls, printf_decls) =
    let write_lhs_of_ty_for_vd vd =
      let (stm, vars) =
        write_lhs_of_ty (Cfield (Cvar "res",
                                 local_qn (name vd.v_ident))) vd.v_type in
      if !Compiler_options.hepts_simulation then
	(stm, vars)
      else
	(cprint_string "=> " :: stm, vars)
    in
    split (map write_lhs_of_ty_for_vd stepm.m_outputs) in
  let printf_calls = List.concat printf_calls in

  let cinp = cvarlist_of_ovarlist stepm.m_inputs in
  let cout = ["res", (Cty_id (qn_append cd.cd_name "_out"))] in

  let varlist =
    (if cd.cd_stateful
     then [("mem", Cty_id (qn_append cd.cd_name "_mem"))]
     else [])
    @ cinp
    @ cout
    @ concat scanf_decls
    @ concat printf_decls in

  (** The main function loops (while (1) { ... }) reading arguments for our node
      and prints the results. *)
  let step_l =
    let funcall =
      let args =
        map (fun vd -> Clhs (Cvar (name vd.v_ident))) stepm.m_inputs
        @ (Caddrof (Cvar "res")
           :: if cd.cd_stateful then [Caddrof (Cvar "mem")] else []) in
      Cfun_call ((cname_of_qn cd.cd_name) ^ "_step", args) in
    concat scanf_calls
    @ [Csexpr funcall]
    @ printf_calls
    @ 
      (if !Compiler_options.hepts_simulation
       then []
       else [Csexpr (Cfun_call ("puts", [Cconst (Cstrlit "")]))])
    @ [Csexpr (Cfun_call ("fflush", [Clhs (Cvar "stdout")]))] in

  (** Do not forget to initialize memory via reset if needed. *)
  let rst_i =
    if cd.cd_stateful
    then [Csexpr (Cfun_call ((cname_of_qn cd.cd_name) ^ "_reset",
                             [Caddrof (Cvar "mem")]))]
    else [] in

  (varlist, rst_i, step_l)

(** [main_skel var_list prologue body] generates a C main() function using the
    variable list [var_list], prologue [prologue] and loop body [body]. *)
let main_skel var_list prologue body =
  Cfundef {
    f_name = "main";
    f_retty = Cty_int;
    f_args = [("argc", Cty_int); ("argv", Cty_ptr (Cty_ptr Cty_char))];
    f_body = {
      var_decls =
        (step_counter, Cty_int) :: (max_step, Cty_int) :: var_list;
      block_body =
        [
          (*
            step_count = 0;
            max_step = 0;
            if (argc == 2)
              max_step = atoi(argv[1]);
          *)
          Caffect (Cvar step_counter, Cconst (Ccint 0));
          Caffect (Cvar max_step, Cconst (Ccint 0));
          Cif (Cbop ("==", Clhs (Cvar "argc"), Cconst (Ccint 2)),
               [Caffect (Cvar max_step,
                         Cfun_call ("atoi",
                                    [Clhs (Carray (Cvar "argv",
                                                   Cconst (Ccint 1)))]))], []);
        ]
        @ prologue
          (* while (!max_step || step_c < max_step) *)
        @ [
          Cwhile (Cbop ("||",
                        Cuop ("!", Clhs (Cvar max_step)),
                        Cbop ("<",
                              Clhs (Cvar step_counter),
                              Clhs (Cvar max_step))),
                  (* step_counter = step_counter + 1; *)
                  Caffect (Cvar step_counter,
                           Cbop ("+",
                                 Clhs (Cvar step_counter),
                                 Cconst (Ccint 1)))
                  :: body);
          Creturn (Cconst (Ccint 0));
        ];
    }
  }

let mk_main name p =
  if !Compiler_options.simulation then (
      let classes = program_classes p in
      let n_names = !Compiler_options.assert_nodes in
      let find_class n =
        try List.find (fun cd -> cd.cd_name.name = n) classes
        with Not_found ->
          Format.eprintf "Unknown node %s.@." n;
          exit 1 in

      let a_classes = List.map find_class n_names in

      let (var_l, res_l, step_l) =
        let add cd (var_l, res_l, step_l) =
          let (var, res, step) = assert_node_res cd in
          (var @ var_l, res @ res_l, step :: step_l) in
        List.fold_right add a_classes ([], [], []) in

      let n = !Compiler_options.simulation_node in
      let (nvar_l, res, nstep_l) = main_def_of_class_def (find_class n) in
      let (var_l, res_l, step_l) =
        (nvar_l @ var_l, res @ res_l, nstep_l @ step_l) in

      [("_main.c", Csource [main_skel var_l res_l step_l]);
       ("_main.h", Cheader ([name], []))];
  ) else
    []



(******************************)

let translate name prog =
  let modname = (Filename.basename name) in
  global_name := String.capitalize modname;
  (global_file_header modname prog) @ (mk_main name prog)

let program p =
  let filename =
    filename_of_name (cname_of_name (modul_to_string p.p_modname)) in
  let dirname = build_path (filename ^ "_c") in
  let dir = clean_dir dirname in
  let c_ast = translate filename p in
    C.output dir c_ast