split.ml

(** Time-stamp: <modified the 01/06/2011 (at 13:45) by Erwan Jahier> *)


open Lxm
open Eff
open Predef

(********************************************************************************)
(* stuff to create fresh var names. *)
let new_var node_env type_eff clock_eff = 
  let id = Ident.of_string (Name.new_local_var ("v")) in
  let var =
    { 
      var_name_eff   = id;
      var_nature_eff = SyntaxTreeCore.VarLocal;
      var_number_eff = -1; (* this field is used only for i/o. 
                              Should i rather put something sensible there ? *)
      var_type_eff   = type_eff;
      var_clock_eff  = id,clock_eff;
    }
  in
    Hashtbl.add node_env.lenv_vars id var;
    var


(********************************************************************************)
(* functions that deal with tuple breaking *)

let rec (get_vel_from_tuple : val_exp -> val_exp list) =
  function
    | { ve_core = CallByPosEff({it=Eff.TUPLE }, OperEff vel) } -> 
        List.flatten (List.map get_vel_from_tuple vel)
    | ve -> [ve]

let to_be_broken = function
    (* We are only interested in operators that can deal with tuples! *)
  | CallByPosEff({ it = Eff.ARROW }, _) -> true
  | CallByPosEff({ it = Eff.FBY }, _) -> true
  | CallByPosEff({ it = Eff.PRE }, _) -> true
  | CallByPosEff({ it = Eff.CURRENT }, _) -> true
  | CallByPosEff({ it = Eff.TUPLE }, _) -> true
  | CallByPosEff({ it = Eff.WHEN _ }, _) -> true
  | CallByPosEff({ it = Eff.PREDEF_CALL(Predef.IF_n, []) }, _) -> true
  | _ -> false


let (break_it : val_exp -> val_exp list) =
  fun ve -> 
    let nvel = 
      match ve.ve_core with
	| CallByPosEff({it=Eff.PREDEF_CALL(Predef.IF_n,[]);src=lxm}, OperEff [c;ve1;ve2]) ->
            let vel1 = get_vel_from_tuple ve1
            and vel2 = get_vel_from_tuple ve2 
            in
              List.map2
		(fun ve1 ve2 -> 
		   { ve_core = 
                       CallByPosEff({it=Eff.PREDEF_CALL(Predef.IF_n,[]);src=lxm}, 
                                    OperEff [c;ve1;ve2]);
                     ve_typ = ve1.ve_typ;
                     ve_clk = ve1.ve_clk;
                   }
		)
		vel1
		vel2

	| CallByPosEff({it=WHEN clk; src=lxm}, OperEff vel) ->
            let vel = List.flatten (List.map get_vel_from_tuple vel) in
              List.map 
		(fun ve -> 
                   { ve with 
                       ve_core=CallByPosEff({it=WHEN clk ; src=lxm }, OperEff [ve])}) 
		vel

	| CallByPosEff({it=Eff.TUPLE ; src=lxm }, OperEff vel) ->
            let vel = List.flatten (List.map get_vel_from_tuple vel) in
              List.map 
		(fun ve -> 
                   { ve with 
                       ve_core=CallByPosEff({it=Eff.TUPLE ; src=lxm }, OperEff [ve])}) 
		vel

	| CallByPosEff({it=op ; src=lxm }, OperEff [ve]) ->
            let vel = get_vel_from_tuple ve in
              List.map 
                (fun ve -> { ve with ve_core=CallByPosEff({it=op;src=lxm}, OperEff [ve])})
                vel

	| CallByPosEff({it=op ; src=lxm }, OperEff [ve1;ve2]) ->
            let vel1 = get_vel_from_tuple ve1
            and vel2 = get_vel_from_tuple ve2 
            in
              List.map2
		(fun ve1 ve2 -> 
		   { ve_core = CallByPosEff({it=op ; src=lxm }, OperEff [ve1;ve2]);
                     ve_typ = ve1.ve_typ;
                     ve_clk = ve1.ve_clk }
		)
		vel1
		vel2
		
	| _ -> assert false (* dead code since it is guarded by to_be_broken... *)
    in
    let tl = ve.ve_typ
    and cl = ve.ve_clk in
    let nvel = List.map2 (fun nve t -> { nve with ve_typ = [t]; ve_clk=cl } ) nvel ve.ve_typ in
      assert(ve.ve_typ = tl);
      nvel

let (split_tuples:Eff.eq_info Lxm.srcflagged list -> Eff.eq_info Lxm.srcflagged list) =
  fun eql -> 
    let split_one_eq eq = 
      let { src = lxm_eq ; it = (lhs, n_rhs) } = eq in
        if List.length lhs > 1 && (to_be_broken n_rhs.ve_core) then
          let vel = break_it n_rhs in
          let eqs = 
            try List.map2 (fun lhs ve -> [lhs], ve) lhs vel 
            with _ -> 
              assert false
          in
          let eqs = List.map (fun eq -> Lxm.flagit eq lxm_eq) eqs in
            eqs
        else
          [eq]

    in
      List.flatten (List.map split_one_eq eql)


(********************************************************************************)
        
(********************************************************************************)
        
(* The functions below accumulate 
   (1) the new equations 
   (2) the fresh variables. 
*)
type split_acc = (Eff.eq_info srcflagged) list * Eff.var_info list

(* exported *)
let rec (eq : node_env -> Eff.eq_info Lxm.srcflagged -> split_acc) =
  fun node_env { src = lxm_eq ; it = (lhs, rhs) } ->
    let n_rhs, (neqs, nlocs) = split_val_exp false true node_env rhs in
      { src = lxm_eq ; it = (lhs, n_rhs) }::neqs, nlocs

and (split_eq_acc : 
       node_env -> split_acc -> Eff.eq_info srcflagged -> split_acc) =
  fun node_env (eqs, locs) equation -> 
    let (neqs, nlocs) = eq node_env equation in 
      (split_tuples (eqs@neqs), locs@nlocs)
        
and (split_val_exp : bool -> bool -> node_env -> Eff.val_exp -> 
      Eff.val_exp * split_acc) =
  fun when_flag top_level node_env ve -> 
    (* [when_flag] is true is the call is made from a "when" statement.
       We need this flag in order to know if it is necessary to add
       a when on constants. Indeed, in Lustre V6, it is not necessary
       to write " 1 when clk + x " if x in on clk (it's more sweet). 
       So we need to add it  (because if we split "1+1+x", then it
       is hard to know the "1" are on the clock of x ; moreover, lustre
       v4 (and the other backends) cannot infer such clock).

       But is is not forbidden either! so we need to make sure that there
       is no "when"...
    *)
    match ve.ve_core with
      | CallByPosEff({it=Eff.VAR_REF _}, _) -> ve, ([],[])
      | CallByPosEff({it=Eff.CONST_REF _}, _) -> ve, ([],[])

      | CallByPosEff({src=lxm;it=Eff.PREDEF_CALL(Predef.TRUE_n,_)}, _) 
      | CallByPosEff({src=lxm;it=Eff.PREDEF_CALL(Predef.FALSE_n,_)}, _) 
      | CallByPosEff({src=lxm;it=Eff.PREDEF_CALL(Predef.ICONST_n _,_)}, _) 
      | CallByPosEff({src=lxm;it=Eff.PREDEF_CALL(Predef.RCONST_n _,_)}, _) 
          (* We do not create an intermediary variable for those, 
             but 
          *)
        -> if not when_flag then
          let clk = ve.ve_clk in
            match (List.hd clk) with
              | On(clock,_) -> 
                  let clk_exp = SyntaxTreeCore.NamedClock (Lxm.flagit clock lxm) in
                    { ve with ve_core = 
                        CallByPosEff({src=lxm;it=Eff.WHEN clk_exp},OperEff [ve])},
                  ([],[])
                    
              | (ClockVar _) (* should not occur *)
              | BaseEff  -> ve, ([],[])
        else
          ve, ([],[])

      | CallByNameEff (by_name_op_eff, fl) ->
          let lxm = by_name_op_eff.src in 
          let fl, eql, vl = 
            List.fold_left
              (fun (fl_acc, eql_acc, vl_acc) (fn, fv) ->
                 let fv, (eql, vl) = split_val_exp false false node_env fv in
                   ((fn,fv)::fl_acc, eql@eql_acc, vl@vl_acc)
              )
              ([],[],[])
              fl
          in
          let rhs = { ve with ve_core = CallByNameEff (by_name_op_eff, List.rev fl) } in
	    if top_level then
              rhs, (eql, vl)
            else
              (* create the var for the current call *)
              let clk_l = ve.ve_clk in 
              let typ_l = ve.ve_typ in  
              let nv_l = List.map2 (new_var node_env.local) typ_l clk_l  in
              let nve = match nv_l with
                | [nv] -> { ve with ve_core = 
                      CallByPosEff(
                        Lxm.flagit (Eff.VAR_REF (nv.var_name_eff)) lxm,
                        OperEff [] 
                      )}
                | _ -> assert false
              in
              let lpl = List.map (fun nv -> LeftVarEff(nv, lxm)) nv_l in
              let eq = Lxm.flagit (lpl, rhs) lxm in
		nve, (eql@[eq], vl@nv_l)

                  
      | CallByPosEff(by_pos_op_eff, OperEff vel) -> (
          (* recursively split the arguments *) 
          let lxm = by_pos_op_eff.src in
          let (rhs, (eql,vl)) =
            match by_pos_op_eff.it with 
                (* for WITH and HAT, a particular treatment is done because
                   the val_exp is attached to them *)
              | Eff.WITH(ve) ->
                  let ve, (eql, vl) = split_val_exp false false node_env ve in
                  let by_pos_op_eff = Lxm.flagit (Eff.WITH(ve)) lxm in
                  let rhs = CallByPosEff(by_pos_op_eff, OperEff []) in
                    rhs, (eql, vl)

              | Eff.HAT(i,ve) ->
                  let ve, (eql, vl) = split_val_exp false false node_env ve in
                  let by_pos_op_eff = Lxm.flagit (Eff.HAT(i, ve)) lxm in
                  let rhs = CallByPosEff(by_pos_op_eff, OperEff []) in
                    rhs, (eql, vl)

              | Eff.WHEN ve -> (* should we create a var for the clock? *)
                  let vel,(eql, vl) = split_val_exp_list true false node_env vel in
                  let by_pos_op_eff = Lxm.flagit (Eff.WHEN(ve)) lxm in
                  let rhs = CallByPosEff(by_pos_op_eff, OperEff vel) in
                    rhs, (eql, vl)
                      
              | Eff.ARRAY vel ->
                  let vel, (eql, vl) = split_val_exp_list false false node_env vel in
                  let by_pos_op_eff = Lxm.flagit (Eff.ARRAY(vel)) lxm in
                  let rhs = CallByPosEff(by_pos_op_eff, OperEff []) in
                    rhs, (eql, vl)
                      
              | _ -> 
                  let vel, (eql, vl) = split_val_exp_list false false node_env vel in
                  let rhs = CallByPosEff(by_pos_op_eff, OperEff vel) in
                    rhs, (eql, vl)
          in
          let rhs = { ve with ve_core = rhs } in
	    if top_level || by_pos_op_eff.it = TUPLE then 
              rhs, (eql, vl) 
            else
              (* create the var for the current call *)
              let clk_l = ve.ve_clk in 
              let typ_l = ve.ve_typ in
              let nv_l = List.map2 (new_var node_env.local) typ_l clk_l  in

              let nve = 
                match nv_l with
                  | [nv] -> {
                      ve_typ = [nv.var_type_eff];
                      ve_clk = clk_l; 
                      ve_core = CallByPosEff(
                        Lxm.flagit (Eff.VAR_REF (nv.var_name_eff)) lxm,
                        OperEff [])		
	            }
                  | _ -> {
                      ve_typ = List.map (fun v -> v.var_type_eff) nv_l;
                      ve_clk = clk_l;
		      ve_core = CallByPosEff(
                        Lxm.flagit Eff.TUPLE lxm, 
                        OperEff
			  (List.map (
                             fun nv -> 
                               let nnv = {
                                 ve_core = CallByPosEff 
                                   (Lxm.flagit 
                                      (Eff.VAR_REF (nv.var_name_eff)) lxm,
				    OperEff []);
                                 ve_typ = [nv.var_type_eff];
                                 ve_clk = [snd nv.var_clock_eff]
                               }
			       in
			         nnv
			   )
                             nv_l
			  )
                      )
                    }
	      in
	      let lpl = List.map (fun nv -> LeftVarEff(nv, lxm)) nv_l in
              let eq = Lxm.flagit (lpl, rhs) lxm in
		nve, (eql@[eq], vl@nv_l)
        )

and (split_val_exp_list : bool -> 
      bool -> node_env -> Eff.val_exp list -> Eff.val_exp list * split_acc) =
  fun when_flag top_level node_env vel ->
    let vel, accl = 
      List.split (List.map (split_val_exp when_flag top_level node_env) vel) 
    in
    let eqll,vll = List.split accl in
    let eql, vl = List.flatten eqll, List.flatten vll in
      (vel,(eql,vl))

(* exported *)
and (node : node_env -> Eff.node_exp -> Eff.node_exp) =
  fun n_env n ->
    let _ =
      Verbose.printf ~level:3 "*** Splitting node  %s\n"
        (LicDump.string_of_node_key_iter n.node_key_eff);
      flush stdout
    in
      match n.def_eff with
        | ExternEff 
        | AbstractEff None -> n
        | AbstractEff (Some pn) -> 
            { n with def_eff = AbstractEff (Some (node n_env pn)) }
        | BodyEff b -> 
            let loc = match n.loclist_eff with None -> [] | Some l -> l in
            let (neqs, nv) = List.fold_left (split_eq_acc n_env) ([], loc) b.eqs_eff in
            let asserts = List.map (fun x -> x.it) b.asserts_eff in
            let lxm_asserts = List.map (fun x -> x.src) b.asserts_eff in
            let nasserts,(neqs_asserts,nv_asserts) =
              split_val_exp_list false true n_env asserts
            in
            let nasserts = List.map2 Lxm.flagit nasserts lxm_asserts in
            let (neqs, nv) =  (neqs@neqs_asserts, nv@nv_asserts) in
            let nb = { eqs_eff = neqs ; asserts_eff = nasserts } in
            let res =
              { n with
                  loclist_eff = Some nv;
                  def_eff = BodyEff nb
              }
            in
              res