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 Utils

open LustreSpec

open Corelang

open Format

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