CristalCaveGem » LustreC

module HeaderMod = C_backend_header.EmptyMod

module Header = C_backend_header.Main (HeaderMod)

let print_lusic_to_h basename extension =

  let lusic = read_lusic basename extension in

  let header_name = basename ^ ".h" in

  let h_out = open_out header_name in

  let h_fmt = formatter_of_out_channel h_out in

  begin

    assert (not lusic.obsolete);

    (*Format.eprintf "lusic to h: %i items.@." (List.length lusic.contents);*)

    Typing.uneval_prog_generics lusic.contents;

    Clock_calculus.uneval_prog_generics lusic.contents;

    Header.print_header_from_header h_fmt (Filename.basename basename) lusic.contents;

    close_out h_out

  end

    Lusic.print_lusic_to_h destname lusic_ext;

  begin

      begin

	Log.report ~level:1 (fun fmt -> fprintf fmt ".. generating compiled header file %s@," header_name);

	Lusic.write_lusic false (Lusic.extract_header dirname basename prog) destname lusic_ext;

	Lusic.print_lusic_to_h destname lusic_ext

      end

      if not lusic.Lusic.from_lusi then

	begin

	  Log.report ~level:1 (fun fmt -> fprintf fmt ".. generating compiled header file %s@," header_name);

       	  Lusic.write_lusic false (Lusic.extract_header dirname basename prog) destname lusic_ext;

	  (*List.iter (fun top_decl -> Format.eprintf "lusic: %a@." Printers.pp_decl top_decl) lusic.Lusic.contents;*)

	  Lusic.print_lusic_to_h destname lusic_ext

	end

      else

	begin

	  Log.report ~level:1 (fun fmt -> fprintf fmt ".. loading compiled header file %s@," header_name);

	  Modules.check_dependency lusic destname;

	  let header = lusic.Lusic.contents in

	  let (declared_types_env, declared_clocks_env) = get_envs_from_top_decls header in

	  check_compatibility

	    (prog, computed_types_env, computed_clocks_env)

	    (header, declared_types_env, declared_clocks_env)

	end

  end

    Normalization.unfold_arrow_active := false;

    Normalization.unfold_arrow_active := false;

open Normalization

let expr_true loc ck =

{ expr_tag = Utils.new_tag ();

  expr_desc = Expr_const (Const_tag tag_true);

  expr_type = Type_predef.type_bool;

  expr_clock = ck;

  expr_delay = Delay.new_var ();

  expr_annot = None;

  expr_loc = loc }

let expr_false loc ck =

{ expr_tag = Utils.new_tag ();

  expr_desc = Expr_const (Const_tag tag_false);

  expr_type = Type_predef.type_bool;

  expr_clock = ck;

  expr_delay = Delay.new_var ();

  expr_annot = None;

  expr_loc = loc }

let expr_once loc ck =

 { expr_tag = Utils.new_tag ();

  expr_desc = Expr_arrow (expr_true loc ck, expr_false loc ck);

  expr_type = Type_predef.type_bool;

  expr_clock = ck;

  expr_delay = Delay.new_var ();

  expr_annot = None;

  expr_loc = loc }

let is_expr_once =

  let dummy_expr_once = expr_once Location.dummy_loc (Clocks.new_var true) in

  fun expr -> Corelang.is_eq_expr expr dummy_expr_once

let unfold_arrow expr =

 match expr.expr_desc with

 | Expr_arrow (e1, e2) ->

    let loc = expr.expr_loc in

    let ck = List.hd (Clocks.clock_list_of_clock expr.expr_clock) in

    { expr with expr_desc = Expr_ite (expr_once loc ck, e1, e2) }

 | _                   -> assert false

let unfold_arrow_active = ref true

let cpt_fresh = ref 0

(* Generate a new local [node] variable *)

let mk_fresh_var node loc ty ck =

  let vars = get_node_vars node in

  let rec aux () =

  incr cpt_fresh;

  let s = Printf.sprintf "__%s_%d" node.node_id !cpt_fresh in

  if List.exists (fun v -> v.var_id = s) vars then aux () else

  {

    var_id = s;

    var_orig = false;

    var_dec_type = dummy_type_dec;

    var_dec_clock = dummy_clock_dec;

    var_dec_const = false;

    var_dec_value = None;

    var_type = ty;

    var_clock = ck;

    var_loc = loc

  }

  in aux ()

(* Get the equation in [defs] with [expr] as rhs, if any *)

let get_expr_alias defs expr =

 try Some (List.find (fun eq -> is_eq_expr eq.eq_rhs expr) defs)

 with

 | Not_found -> None

(* Replace [expr] with (tuple of) [locals] *)

let replace_expr locals expr =

 match locals with

 | []  -> assert false

 | [v] -> { expr with

   expr_tag = Utils.new_tag ();

   expr_desc = Expr_ident v.var_id }

 | _   -> { expr with

   expr_tag = Utils.new_tag ();

   expr_desc = Expr_tuple (List.map expr_of_vdecl locals) }

let unfold_offsets e offsets =

  let add_offset e d =

(*Format.eprintf "add_offset %a(%a) %a @." Printers.pp_expr e Types.print_ty e.expr_type Dimension.pp_dimension d;

    let res = *)

    { e with

      expr_tag = Utils.new_tag ();

      expr_loc = d.Dimension.dim_loc;

      expr_type = Types.array_element_type e.expr_type;

      expr_desc = Expr_access (e, d) }

(*in (Format.eprintf "= %a @." Printers.pp_expr res; res) *)

  in

 List.fold_left add_offset e offsets

(* Create an alias for [expr], if none exists yet *)

let mk_expr_alias node (defs, vars) expr =

(*Format.eprintf "mk_expr_alias %a %a %a@." Printers.pp_expr expr Types.print_ty expr.expr_type Clocks.print_ck expr.expr_clock;*)

  match get_expr_alias defs expr with

  | Some eq ->

    let aliases = List.map (fun id -> List.find (fun v -> v.var_id = id) vars) eq.eq_lhs in

    (defs, vars), replace_expr aliases expr

  | None    ->

    let new_aliases =

      List.map2

	(mk_fresh_var node expr.expr_loc)

	(Types.type_list_of_type expr.expr_type)

	(Clocks.clock_list_of_clock expr.expr_clock) in

    let new_def =

      mkeq expr.expr_loc (List.map (fun v -> v.var_id) new_aliases, expr)

    in

    (* Format.eprintf "Checking def of alias: %a -> %a@." (fprintf_list ~sep:", " (fun fmt v -> Format.pp_print_string fmt v.var_id)) new_aliases Printers.pp_expr expr; *)

    (new_def::defs, new_aliases@vars), replace_expr new_aliases expr

(* Create an alias for [expr], if [expr] is not already an alias (i.e. an ident)

   and [opt] is true *)

let mk_expr_alias_opt opt node (defs, vars) expr =

(*Format.eprintf "mk_expr_alias_opt %B %a %a %a@." opt Printers.pp_expr expr Types.print_ty expr.expr_type Clocks.print_ck expr.expr_clock;*)

  match expr.expr_desc with

  | Expr_ident alias ->

    (defs, vars), expr

  | _                ->

    match get_expr_alias defs expr with

    | Some eq ->

      let aliases = List.map (fun id -> List.find (fun v -> v.var_id = id) vars) eq.eq_lhs in

      (defs, vars), replace_expr aliases expr

    | None    ->

      if opt

      then

	let new_aliases =

	  List.map2

	    (mk_fresh_var node expr.expr_loc)

	    (Types.type_list_of_type expr.expr_type)

	    (Clocks.clock_list_of_clock expr.expr_clock) in

	let new_def =

	  mkeq expr.expr_loc (List.map (fun v -> v.var_id) new_aliases, expr)

	in (new_def::defs, new_aliases@vars), replace_expr new_aliases expr

      else

	(defs, vars), expr