CristalCaveGem » LustreC

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

(*                                                                  *)

(*  The LustreC compiler toolset   /  The LustreC Development Team  *)

(*  Copyright 2012 -    --   ONERA - CNRS - INPT                    *)

(*                                                                  *)

(*  LustreC is free software, distributed WITHOUT ANY WARRANTY      *)

(*  under the terms of the GNU Lesser General Public License        *)

(*  version 2.1.                                                    *)

(*                                                                  *)

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

open Format

open Utils

open LustreSpec

open Corelang

open Machine_code

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

(* Basic Printing functions *)

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

let pp_final_char_if_non_empty c l fmt =

  match l with [] -> () | _ -> fprintf fmt "%s" c

let pp_newline_if_non_empty l fmt =

  match l with [] -> () | _ -> fprintf fmt "@,"

let pp_dimension fmt d = Printers.pp_expr fmt (expr_of_dimension d)

let pp_type fmt t =

  match (Types.repr t).Types.tdesc with

  | Types.Tbool ->

    pp_print_string fmt "boolean"

  | Types.Treal ->

    pp_print_string fmt "double"

  | _ ->

    Types.print_ty fmt t

let pp_var fmt id = fprintf fmt "%a %s" pp_type id.var_type id.var_id

let pp_tag fmt t = pp_print_string fmt t

let rec pp_const fmt c =

  match c with

  | Const_int i ->

    pp_print_int fmt i

  | Const_real r ->

    pp_print_string fmt r

  | Const_float r ->

    pp_print_float fmt r

  | Const_tag t ->

    pp_tag fmt t

  | Const_array ca ->

    Format.fprintf fmt "{%a}" (Utils.fprintf_list ~sep:"," pp_const) ca

let rec pp_val m fmt v =

  match v with

  | Cst c ->

    pp_const fmt c

  | Var v ->

    if is_state_vars m.memories v then fprintf fmt "%s" v

    else if List.exists (fun o -> o.var_id = v) m.mstep.step_outputs then

      fprintf fmt "*%s" v

    else pp_print_string fmt v

  | Fun (n, vl) ->

    if Basic_library.is_internal_fun n then

      Basic_library.pp_java n (pp_val m) fmt vl

    else fprintf fmt "%s (%a)" n (Utils.fprintf_list ~sep:", " (pp_val m)) vl

let pp_add_val m fmt i =

  if List.exists (fun o -> o.var_id = i) m.mstep.step_outputs then

    fprintf fmt "%s" i

  else fprintf fmt "&%s" i

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

(* Instruction Printing functions *)

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

let get_output_of_machine machines i =

  try

    let m = List.find (fun m -> m.mname.node_id = i) machines in

    m.mstep.step_outputs

  with Not_found -> assert false

let rec pp_machine_instr m machines instance_out_list fmt instr =

  match instr with

  | MReset i -> (

    match List.assoc i m.minstances with

    | "_arrow" ->

      fprintf fmt "%s = true;" i

    | _ ->

      fprintf fmt "%s.reset();" i)

  | MLocalAssign (i, v) ->

    fprintf fmt "%s = %a;" i (pp_val m) v

  | MStateAssign (i, v) ->

    fprintf fmt "%s = %a;" i (pp_val m) v

  | MStep ([ i0 ], i, vl) when Basic_library.is_internal_fun i ->

    fprintf fmt "%s = %a;" i0 (Basic_library.pp_java i (pp_val m)) vl

  | MStep ([ i0 ], i, [ init; step ]) when List.assoc i m.minstances = "_arrow"

    ->

    fprintf fmt

      "@[<v 2>if (%s) {@,\

       %s = false;@,\

       %s = %a;@]@,\

       @[<v 2>} else {@,\

       %s = %a;@]@,\

       };@,"

      i i i0 (pp_val m) init i0 (pp_val m) step

  | MStep (il, i, vl) ->

    let out =

      try List.assoc i instance_out_list

      with Not_found ->

        eprintf "impossible to find instance %s in the list@.@?" i;

        assert false

    in

    fprintf fmt "%s = %s.step (%a);@," out i

      (Utils.fprintf_list ~sep:", " (pp_val m))

      vl;

    Utils.fprintf_list ~sep:"@,"

      (fun fmt (o, oname) -> fprintf fmt "%s = %s.%s;" o out oname)

      fmt

      (List.map2

         (fun x y -> x, y.var_id)

         il

         (get_output_of_machine machines (List.assoc i m.minstances)))

  | MBranch (g, hl) ->

    Format.fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]" (pp_val m) g

      (Utils.fprintf_list ~sep:"@,"

         (pp_machine_branch m machines instance_out_list))

      hl

and pp_machine_branch m machines instance_out_list fmt (t, h) =

  Format.fprintf fmt "@[<v 2>case %a:@,%a@,break;@]" pp_tag t

    (Utils.fprintf_list ~sep:"@,"

       (pp_machine_instr m machines instance_out_list))

    h

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

(* Java file Printing functions *)

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

let get_class_name n =

  match n with "_arrow" -> "boolean" | _ -> String.capitalize n

let pp_local_fields visibility =

  fprintf_list ~sep:"@," (fun fmt v -> fprintf fmt "%s %a;" visibility pp_var v)

let pp_local_field_instances =

  fprintf_list ~sep:"@," (fun fmt (node_inst, node_type) ->

      fprintf fmt "protected %s %s;" (get_class_name node_type) node_inst)

let pp_output_constructor fmt outputs =

  fprintf fmt "@[<v 2>public Output(%a) {@,%a@]@,}"

    (fprintf_list ~sep:"; " pp_var)

    outputs

    (fprintf_list ~sep:"@," (fun fmt v ->

         fprintf fmt "this.%s = %s;" v.var_id v.var_id))

    outputs

let pp_output_class fmt step =

  fprintf fmt "@[<v 2>public class Output {@,%a@,@,%a@]@,}@,"

    (pp_local_fields "public") step.step_outputs pp_output_constructor

    step.step_outputs

let pp_constructor fmt (name, instances) =

  fprintf fmt "@[<v 2>public %s () {@,%a@]@,}@," (String.capitalize name)

    (fprintf_list ~sep:"@," (fun fmt (node_inst, node_type) ->

         match node_type with

         | "_arrow" ->

           fprintf fmt "%s = true;" node_inst

         | _ ->

           fprintf fmt "%s = new %s();" node_inst (get_class_name node_type)))

    instances

let pp_reset machines fmt m =

  fprintf fmt "@[<v 2>public void reset () {@,%a@]@,}@,"

    (fprintf_list ~sep:"@," (pp_machine_instr m machines []))

    m.minit

let pp_step machines fmt m : unit =

  let out_assoc_list =

    List.map (fun (node_inst, _) -> node_inst, "out_" ^ node_inst) m.minstances

  in

  fprintf fmt "@[<v 2>public Output step (%a) {@,%a%t@,%a%a%t@,%a@,%t@]@,}@,"

    (Utils.fprintf_list ~sep:",@ " pp_var)

    m.mstep.step_inputs

    (* locals *)

    (Utils.fprintf_list ~sep:";@," pp_var)

    m.mstep.step_locals

    (pp_final_char_if_non_empty ";" m.mstep.step_locals)

    (* declare out variables of subnode instances + out of this node *)

    (fprintf_list ~sep:"" (fun fmt (ninst, ntype) ->

         fprintf fmt "%s.Output out_%s;@," (get_class_name ntype) ninst))

    (List.filter (fun (_, ntyp) -> not (ntyp = "_arrow")) m.minstances)

    (fprintf_list ~sep:";@," pp_var)

    m.mstep.step_outputs

    (pp_final_char_if_non_empty ";" m.mstep.step_outputs)

    (* instructions *)

    (fprintf_list ~sep:"@," (pp_machine_instr m machines out_assoc_list))

    m.mstep.step_instrs

    (* create out object and return it *)

      (fun fmt ->

      fprintf fmt "return new Output(%a);"

        (fprintf_list ~sep:"," (fun fmt v -> pp_print_string fmt v.var_id))

        m.mstep.step_outputs)

let print_machine machines fmt m =

  if m.mname.node_id = "_arrow" then ()

  else

    (* We don't print arrow function *)

    fprintf fmt "@[<v 2>class %s {@,%a%t%a%t%t%a@,%a@,%a@,%a@]@,}@.@.@."

      (String.capitalize m.mname.node_id)

      (* class name *)

      (pp_local_fields "protected")

      m.mmemory

      (* fields *)

      (pp_newline_if_non_empty m.mmemory)

      pp_local_field_instances m.minstances

      (* object fields *)

      (pp_newline_if_non_empty m.minstances)

      (pp_newline_if_non_empty m.minstances)

      pp_output_class m.mstep

      (* class for output of step method *)

      pp_constructor

      (m.mname.node_id, m.minstances)

      (* constructor to instanciate object fields *)

      (pp_reset machines)

      m

      (* reset method *)

      (pp_step machines)

      m

(* step method *)

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

(* Main related functions *)

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

(* let print_get_input fmt v = *)

(*   match v.var_type.Types.tdesc with *)

(*     | Types.Tint -> fprintf fmt "_get_int(\"%s\")" v.var_id *)

(*     | Types.Tbool -> fprintf fmt "_get_bool(\"%s\")" v.var_id *)

(*     | Types.Treal -> fprintf fmt "_get_double(\"%s\")" v.var_id *)

(*     | _ -> assert false *)

(* let print_put_outputs fmt ol =  *)

(*   let po fmt o = *)

(*     match o.var_type.Types.tdesc with *)

(*     | Types.Tint -> fprintf fmt "_put_int(\"%s\", %s)" o.var_id o.var_id *)

(*     | Types.Tbool -> fprintf fmt "_put_bool(\"%s\", %s)" o.var_id o.var_id *)

(* | Types.Treal -> fprintf fmt "_put_double(\"%s\", %s)" o.var_id o.var_id *)

(*     | _ -> assert false *)

(*   in *)

(*   List.iter (fprintf fmt "@ %a;" po) ol *)

let read_input fmt typ =

  match typ.Types.tdesc with

  | Types.Treal ->

    fprintf fmt "StdIn.readDouble()"

  | Types.Tint ->

    fprintf fmt "StdIn.readInt()"

  | Types.Tbool ->

    fprintf fmt "StdIn.readBoolean()"

  | _ ->

    assert false

let print_main_fun basename machines m fmt =

  let m_class = String.capitalize m.mname.node_id in

  fprintf fmt "@[<v 2>class %s {@,@,@[<v 2>%s {@,%t@,%t@]@,}@,@]@,}@."

    (String.capitalize basename)

    "public static void main (String[] args)"

    (fun fmt -> fprintf fmt "%s main_node = new %s();" m_class m_class)

    (fun fmt ->

      fprintf fmt "@[<v 2>while (true) {@,%a@,%t@,%a@]@,}@,"

        (fprintf_list ~sep:"@," (fun fmt v ->

             fprintf fmt "System.out.println(\"%s?\");@,%a = %a;" v.var_id

               pp_var v read_input v.var_type))

        m.mstep.step_inputs

        (fun fmt ->

          fprintf fmt "%s.Output out = main_node.step(%a);" m_class

            (fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id))

            m.mstep.step_inputs)

        (fprintf_list ~sep:"@," (fun fmt v ->

             fprintf fmt "System.out.println(\"%s = \" + out.%s);" v.var_id

               v.var_id))

        m.mstep.step_outputs)

(* let print_main_fun machines m fmt = *)

(*   let mname = m.mname.node_id in *)

(*   let main_mem = *)

(*     if (!Options.static_mem && !Options.main_node <> "") *)

(*     then "&main_mem" *)

(*     else "main_mem" in *)

(*   fprintf fmt "@[<v 2>int main (int argc, char *argv[]) {@ "; *)

(*   fprintf fmt "/* Declaration of inputs/outputs variables */@ "; *)

(*   List.iter  *)

(* (fun v -> fprintf fmt "%a %s = %a;@ " pp_c_type v.var_type v.var_id

   pp_c_initialize v.var_type *)

(*     ) m.mstep.step_inputs; *)

(*   List.iter  *)

(* (fun v -> fprintf fmt "%a %s = %a;@ " pp_c_type v.var_type v.var_id

   pp_c_initialize v.var_type *)

(*     ) m.mstep.step_outputs; *)

(*   fprintf fmt "@ /* Main memory allocation */@ "; *)

(*   if (!Options.static_mem && !Options.main_node <> "") *)

(*   then (fprintf fmt "%a(main_mem);@ " pp_machine_static_alloc_name mname) *)

(* else (fprintf fmt "%a *main_mem = %a();@ " pp_machine_memtype_name mname

   pp_machine_alloc_name mname); *)

(*   fprintf fmt "@ /* Initialize the main memory */@ "; *)

(*   fprintf fmt "%a(%s);@ " pp_machine_reset_name mname main_mem; *)

(*   fprintf fmt "@ ISATTY = isatty(0);@ "; *)

(*   fprintf fmt "@ /* Infinite loop */@ "; *)

(*   fprintf fmt "@[<v 2>while(1){@ "; *)

(*   fprintf fmt  "fflush(stdout);@ "; *)

(*   List.iter  *)

(*     (fun v -> fprintf fmt "%s = %a;@ " *)

(*       v.var_id *)

(*       print_get_input v *)

(*     ) m.mstep.step_inputs; *)

(*   (match m.mstep.step_outputs with *)

(*     | [] -> ( *)

(*       fprintf fmt "%a(%a%t%s);@ "  *)

(* 	pp_machine_step_name mname *)

(* (Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id))

   m.mstep.step_inputs *)

(* 	(pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)

(* 	main_mem *)

(*     ) *)

(*     | [o] -> ( *)

(*       fprintf fmt "%s = %a(%a%t%a, %s);%a" *)

(* 	o.var_id *)

(* 	pp_machine_step_name mname *)

(* (Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id))

   m.mstep.step_inputs *)

(* (pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)

(* (Utils.fprintf_list ~sep:", " (fun fmt v -> fprintf fmt "&%s" v.var_id))

   m.mstep.step_outputs *)

(* 	main_mem *)

(* 	print_put_outputs [o]) *)

(*     | _ -> ( *)

(*       fprintf fmt "%a(%a%t%a, %s);%a" *)

(* 	pp_machine_step_name mname *)

(* (Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id))

   m.mstep.step_inputs *)

(* (pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)

(* (Utils.fprintf_list ~sep:", " (fun fmt v -> fprintf fmt "&%s" v.var_id))

   m.mstep.step_outputs *)

(* 	main_mem *)

(* 	print_put_outputs m.mstep.step_outputs) *)

(*   ); *)

(*   fprintf fmt "@]@ }@ "; *)

(*   fprintf fmt "return 1;"; *)

(*   fprintf fmt "@]@ }@."        *)

(* let print_main_header fmt = *)

(* fprintf fmt "#include <stdio.h>@.#include <unistd.h>@.#include

   \"io_frontend.h\"@." *)

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

(* Translation function *)

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

let translate_to_java source_fmt basename prog machines =

  (* If a main node is identified, generate a main function for it *)

  let main_print =

    match !Options.main_node with

    | "" ->

      fun _ -> ()

    | main_node -> (

      let main_node_opt =

        List.fold_left

          (fun res m ->

            match res with

            | Some _ ->

              res

            | None ->

              if m.mname.node_id = main_node then Some m else None)

          None machines

      in

      match main_node_opt with

      | None ->

        eprintf "Unable to find a main node named %s@.@?" main_node;

        fun _ -> ()

      | Some m ->

        print_main_fun basename machines m)

  in

  (* Print nodes one by one (in the previous order) *)

  List.iter ((print_machine machines) source_fmt) machines;

  main_print source_fmt

(* Local Variables: *)

(* compile-command:"make -C .." *)

(* End: *)