CristalCaveGem » LustreC

module type MODIFIERS_MAINSRC = sig end

module EmptyMod = struct end

module Main =

functor

  (Mod : MODIFIERS_MAINSRC)

  ->

  struct

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

    (* Main related functions *)

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

    let pp_c_main_var_input fmt id = fprintf fmt "%s" id.var_id

    let pp_c_main_var_output fmt id =

      if Types.is_address_type id.var_type then fprintf fmt "%s" id.var_id

      else fprintf fmt "&%s" id.var_id

    let print_put_output fmt id o' o =

      let suff = string_of_int (id + 1) in

      print_put_var fmt suff o'.var_id o.var_type o.var_id

    let print_main_inout_declaration fmt m =

        "/* Declaration of inputs/outputs variables */@,\

         %a%a@[<v 2>if (traces) {@,\

         %a%a@]@,\

         }"

        (pp_print_list_i ~pp_open_box:pp_open_vbox0 ~pp_epilogue:pp_print_cut

           (fun fmt idx v ->

             fprintf fmt "%a; %a" (pp_c_type v.var_id) v.var_type

               (fun fmt () -> pp_file_decl fmt "in" idx)

               ()))

        m.mstep.step_inputs

        (pp_print_list_i ~pp_open_box:pp_open_vbox0 ~pp_epilogue:pp_print_cut

           (fun fmt idx v ->

             fprintf fmt "%a; %a" (pp_c_type v.var_id) v.var_type

               (fun fmt () -> pp_file_decl fmt "out" idx)

               ()))

        m.mstep.step_outputs

        (pp_print_list_i ~pp_epilogue:pp_print_cut (fun fmt idx _ ->

             ignore (pp_file_open fmt "in" idx)))

        m.mstep.step_inputs

        (pp_print_list_i (fun fmt idx _ -> ignore (pp_file_open fmt "out" idx)))

        m.mstep.step_outputs

    let print_main_memory_allocation mname main_mem fmt m =

      if not (fst (get_stateless_status m)) then

        fprintf fmt

          "@[<v>/* Main memory allocation */@,\

           %a@,\

           @,\

           /* Initialize the main memory */@,\

           %a(%s);@]"

          (fun fmt () ->

            if !Options.static_mem && !Options.main_node <> "" then

              fprintf fmt "%a(static,main_mem);" pp_machine_static_alloc_name

                mname

            else

              fprintf fmt "%a *main_mem = %a();"

                (pp_machine_memtype_name ~ghost:false)

                mname pp_machine_alloc_name mname)

          () pp_machine_set_reset_name mname main_mem

    let print_global_initialize fmt basename =

      let mNAME = file_to_module_name basename in

      fprintf fmt "/* Initialize global constants */@,%a();" pp_global_init_name

        mNAME

    let print_global_clear fmt basename =

      let mNAME = file_to_module_name basename in

      fprintf fmt "/* Clear global constants */@,%a();" pp_global_clear_name

        mNAME

    let print_main_initialize mname main_mem fmt m =

      let inputs = mpfr_vars m.mstep.step_inputs in

      let outputs = mpfr_vars m.mstep.step_outputs in

      if not (fst (get_stateless_status m)) then

        fprintf fmt "/* Initialize inputs, outputs and memories */@,%a%a%a(%s);"

          (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_eol:pp_print_cut

             (pp_initialize m main_mem (pp_c_var_read m)))

          inputs

          (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_eol:pp_print_cut

             (pp_initialize m main_mem (pp_c_var_read m)))

          outputs pp_machine_init_name mname main_mem

      else

        fprintf fmt "/* Initialize inputs and outputs */@,%a%a@ "

          (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_eol:pp_print_cut

             (pp_initialize m main_mem (pp_c_var_read m)))

          inputs

          (pp_print_list ~pp_open_box:pp_open_vbox0

             (pp_initialize m main_mem (pp_c_var_read m)))

          outputs

    let print_main_clear mname main_mem fmt m =

      let inputs = mpfr_vars m.mstep.step_inputs in

      let outputs = mpfr_vars m.mstep.step_outputs in

      if not (fst (get_stateless_status m)) then

        fprintf fmt

          "@[<v>/* Clear inputs, outputs and memories */@,%a%a%a(%s);@]"

          (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_eol:pp_print_cut

             (pp_clear m main_mem (pp_c_var_read m)))

          inputs

          (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_eol:pp_print_cut

             (pp_clear m main_mem (pp_c_var_read m)))

          outputs pp_machine_clear_name mname main_mem

      else

        fprintf fmt "@[<v>/* Clear inputs and outputs */@,%a%a@]"

          (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_eol:pp_print_cut

             (pp_clear m main_mem (pp_c_var_read m)))

          inputs

          (pp_print_list ~pp_open_box:pp_open_vbox0

             (pp_clear m main_mem (pp_c_var_read m)))

          outputs

    let print_get_input fmt id v' v =

      let pp_file = pp_print_file ("in" ^ string_of_int (id + 1)) in

      let unclocked_t = Types.unclock_type v.var_type in

      fprintf fmt "@[<v>%a@]"

        (fun fmt () ->

          if Types.is_int_type unclocked_t then

            fprintf fmt "%s = _get_int(\"%s\");@,%a" v.var_id v'.var_id pp_file

              ("d", v.var_id)

          else if Types.is_bool_type unclocked_t then

            fprintf fmt "%s = _get_bool(\"%s\");@,%a" v.var_id v'.var_id pp_file

              ("i", v.var_id)

          else if Types.is_real_type unclocked_t then

            if !Options.mpfr then

              fprintf fmt

                "double %s_tmp = _get_double(\"%s\");@,\

                 %a@,\

                 mpfr_set_d(%s, %s_tmp, %i);" v.var_id v'.var_id pp_file

                ("f", v.var_id ^ "_tmp")

                v.var_id v.var_id (Mpfr.mpfr_prec ())

            else

              fprintf fmt "%s = _get_double(\"%s\");@,%a" v.var_id v'.var_id

                pp_file ("f", v.var_id)

          else (

            Global.main_node := !Options.main_node;

            eprintf "Code generation error: %a%a@." Error.pp_error_msg

              Error.Main_wrong_kind Location.pp_loc v'.var_loc;

            raise (Error.Error (v'.var_loc, Error.Main_wrong_kind))))

        ()

    let pp_main_call mname self fmt m (inputs : value_t list)

        (outputs : var_decl list) =

      if fst (Machine_code_common.get_stateless_status m) then

        fprintf fmt "%a (%a%a);" pp_machine_step_name mname

          (pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma

             (pp_c_val m self pp_c_main_var_input))

          inputs

          (pp_print_list ~pp_sep:pp_print_comma pp_c_main_var_output)

          outputs

      else

        fprintf fmt "%a (%a%a%s);" pp_machine_step_name mname

          (pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma

             (pp_c_val m self pp_c_main_var_input))

          inputs

          (pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma

             pp_c_main_var_output)

          outputs self

    let print_main_loop mname main_mem fmt m =

      let input_values =

        List.map (fun v -> mk_val (Var v) v.var_type) m.mstep.step_inputs

      in

      fprintf fmt

        "ISATTY = isatty(0);@,\

         /* Infinite loop */@,\

         @[<v 2>while(1){@,\

         fflush(stdout);@,\

         @[<v 2>if (traces) {@,\

         %a%a@]@,\

         }@,\

         %a%a%a"

        (pp_print_list_i ~pp_open_box:pp_open_vbox0 ~pp_epilogue:pp_print_cut

           (fun fmt idx _ -> fprintf fmt "fflush(f_in%i);" (idx + 1)))

        m.mstep.step_inputs

        (pp_print_list_i ~pp_open_box:pp_open_vbox0 (fun fmt idx _ ->

             fprintf fmt "fflush(f_out%i);" (idx + 1)))

        m.mstep.step_outputs

        (pp_print_list_i2 ~pp_open_box:pp_open_vbox0 ~pp_epilogue:pp_print_cut

           print_get_input)

        (m.mname.node_inputs, m.mstep.step_inputs)

          pp_main_call mname main_mem fmt m input_values m.mstep.step_outputs)

        ()

        (pp_print_list_i2 ~pp_open_box:pp_open_vbox0 ~pp_prologue:pp_print_cut

           print_put_output)

        (m.mname.node_outputs, m.mstep.step_outputs)

    let print_usage fmt () =

        "@[<v 2>void usage(char *argv[]) {@,\

         printf(\"Usage: %%s\\n\", argv[0]);@,\

         printf(\" -t: produce trace files for input/output flows\\n\");@,\

         printf(\" -d<dir>: directory containing traces (default: \

         _traces)\\n\");@,\

         printf(\" -p<prefix>: prefix_simu.scope<id> (default: \

         file_node)\\n\");@,\

         exit (8);@]@,\

         }"

    let print_options fmt name =

        "@[<v>int traces = 0;@,\

         char* prefix = \"%s\";@,\

         char* dir = \".\";@,\

         @[<v 2>while ((argc > 1) && (argv[1][0] == '-')) {@,\

         @[<v 2>switch (argv[1][1]) {@,\

         @[<v 2>case 't':@,\

         traces = 1;@,\

         break;@,\

         @]@,\

         @[<v 2>case 'd':@,\

         dir = &argv[1][2];@,\

         break;@,\

         @]@,\

         @[<v 2>case 'p':@,\

         prefix = &argv[1][2];@,\

         break;@,\

         @]@,\

         @[<v 2>default:@,\

         printf(\"Wrong Argument: %%s\\n\", argv[1]);@,\

         usage(argv);@]@]@,\

         }@,\

         ++argv;@,\

         --argc;@]@,\

         }@]"

        name

    let print_main_code fmt (basename, m) =

      let mname = m.mname.node_id in

      (* TODO: find a proper way to shorthen long names. This causes segfault in

         the binary when trying to fprintf in them *)

      let mname =

        if String.length mname > 50 then string_of_int (Hashtbl.hash mname)

        else mname

      in

      let main_mem =

        if !Options.static_mem && !Options.main_node <> "" then "&main_mem"

        else "main_mem"

      in

        "@[<v>%a@,\

         @,\

         @[<v 2>int main (int argc, char *argv[]) {@,\

         %a@,\

         @,\

         %a@,\

         %a@,\

         %a@,\

         %a@,\

         %a@,\

         %a@]@,\

         }@,\

         %areturn 1;@]@,\

         }@]@."

        print_usage () print_options

        (basename ^ "_" ^ mname)

        print_main_inout_declaration m

        (Plugins.c_backend_main_loop_body_prefix basename mname)

        ()

        (print_main_memory_allocation mname main_mem)

        m

        (fun fmt () ->

          if !Options.mpfr then

            fprintf fmt "@[<v>%a@,%a@]@," print_global_initialize basename

              (print_main_initialize mname main_mem)

              m)

        ()

        (print_main_loop mname main_mem)

        m Plugins.c_backend_main_loop_body_suffix ()

        (fun fmt () ->

          if !Options.mpfr then

            fprintf fmt "@[<v>%a@,%a@]@,"

              (print_main_clear mname main_mem)

              m print_global_clear basename)

        ()

    let print_main_header fmt () =

      fprintf fmt "@[<v>#include <stdio.h>@,#include <unistd.h>@,%a@]"

        (fun fmt () ->

          fprintf fmt

            (if !Options.cpp then "#include \"%s/io_frontend.hpp\""

            else "#include <string.h>@,#include \"%s/io_frontend.h\"")

            (Options_management.core_dependency "io_frontend"))

        ()

    let print_main_c main_fmt main_machine basename _prog _machines

        _dependencies =

      fprintf main_fmt

        "@[<v>%a@,\

         #include <stdlib.h>@,\

         #include <assert.h>@,\

         %a@,\

         @,\

         %a@,\

         %a\n\

        \       @]@." print_main_header () print_import_alloc_prototype

        {

          local = true;

          name = basename;

          content = [];

          is_stateful = true (* assuming it is stateful*);

        }

        (* Print the svn version number and the supported C standard (C90 or

           C99) *)

        pp_print_version () print_main_code (basename, main_machine)

  end