getEff.ml

(** Time-stamp: <modified the 23/07/2008 (at 15:36) by Erwan Jahier> *)


open Lxm
open Predef
open SyntaxTree
open SyntaxTreeCore
open CompiledData
open Errors


(******************************************************************************)
exception GetEffType_error of string

(* exported *)
let rec (typ:CompiledData.id_solver -> SyntaxTreeCore.type_exp -> 
	  CompiledData.type_eff)=
  fun env texp ->
    try (
      match texp.it with
     	| Bool_type_exp -> Bool_type_eff
	| Int_type_exp  -> Int_type_eff
	| Real_type_exp -> Real_type_eff
	| Named_type_exp s -> env.id2type s texp.src
	| Array_type_exp (elt_texp, szexp) ->
	    let elt_teff = typ env elt_texp in
	      try
		let sz = EvalConst.eval_array_size env szexp in
		  Array_type_eff (elt_teff, sz)
	      with EvalConst.EvalArray_error msg -> raise(GetEffType_error msg)
    )
    with GetEffType_error msg ->
      raise (Compile_error(texp.src, "can't eval type: "^msg))

(* exported *)
let rec (clock : CompiledData.id_solver -> var_info -> CompiledData.clock_eff)=
  fun id_solver v ->
    match v.var_clock  with
      | Base -> On(v.var_name,BaseEff)
      | NamedClock id ->
	  let id_v = id_solver.id2var (Ident.to_idref id.it) id.src in
	    On(v.var_name, id_v.var_clock_eff)


(******************************************************************************)
(* Checks that the left part has the same type as the right one. *)
and (type_check_equation: id_solver -> eq_info srcflagged -> left_eff list -> 
      val_exp_eff -> unit) =
  fun id_solver eq_info lpl_eff ve_eff -> 
    let lpl_teff = List.map type_eff_of_left_eff lpl_eff in
    let right_part = EvalType.f id_solver ve_eff in
      if (List.length lpl_teff <> List.length right_part) then
	raise (Compile_error(eq_info.src, 
			     "tuple size error: \n*** the tuple size is\n***\t"^ 
			       (string_of_int (List.length lpl_teff)) ^
			       " for the left-hand-side, and \n***\t" ^ 
			       (string_of_int (List.length right_part)) ^
			       " for the right-hand-side"))
      else
	List.iter2
	  (fun le re -> 
	     if le <> re then
	       let msg = "type mismatch: \n***\t'" 
		 ^ (LicDump.string_of_type_eff le) ^ 
		 "' (left-hand-side) \n*** is not compatible with \n***\t'" 
		 ^ (LicDump.string_of_type_eff re) ^ "' (right-hand-side)"
	       in
		 raise (Compile_error(eq_info.src, msg))
	  )
	  lpl_teff
	  right_part

(* Checks that the left part has the same clock as the right one. *)
and (clock_check_equation:id_solver -> eq_info srcflagged -> left_eff list ->
      val_exp_eff -> unit) =
  fun id_solver eq_info lpl_eff ve_eff ->
    let right_part,s = EvalClock.f id_solver UnifyClock.empty_subst ve_eff in
      EvalClock.check_res eq_info.src s lpl_eff right_part 


(******************************************************************************)
let (get_static_params_from_idref : SymbolTab.t -> Lxm.t -> Ident.idref ->
      static_param srcflagged list) =
  fun symbols lxm idref ->
    match SymbolTab.find_node symbols (Ident.name_of_idref idref) lxm with
      | SymbolTab.Local ni -> ni.it.static_params
      | SymbolTab.Imported(imported_node, params) -> params


(* exported *)
let rec (node : CompiledData.id_solver -> SyntaxTreeCore.node_exp srcflagged -> 
	  CompiledData.node_exp_eff) =
  fun id_solver { src = lxm; it=(idref, static_args) } ->
    let static_params = get_static_params_from_idref id_solver.symbols lxm idref in
    let static_args_eff = 
      assert(List.length static_params = List.length static_args);
      List.map2 (check_static_arg id_solver) 
	static_params 
	static_args 
    in
      id_solver.id2node idref static_args_eff lxm

	
(** [check_static_arg this pn id sa (symbols, acc)] compile a static arg 
    into a static_arg_eff
*)
and (check_static_arg : CompiledData.id_solver ->
      SyntaxTreeCore.static_param srcflagged  -> 
      SyntaxTreeCore.static_arg srcflagged -> 
      CompiledData.static_arg_eff) =
  fun node_id_solver sp sa -> 
    let sa_eff =
      match sa.it, sp.it with
	| StaticArgIdent idref, StaticParamConst(id, _type_exp) ->
	    let ceff = node_id_solver.id2const idref sa.src in
	      ConstStaticArgEff (id, ceff)

	| StaticArgIdent idref, StaticParamType(id) ->
	    let teff = node_id_solver.id2type idref sa.src in
	      TypeStaticArgEff (id, teff)
		
	| StaticArgIdent idref, StaticParamNode(id,_,_,_) ->
	    let sargs = [] in
	      (* We suppose that static arg cannot themselves be 
		 template calls (eg, f<<g<<3>>>> is forbidden) 
	      *)
	    let neff = node_id_solver.id2node idref sargs sa.src in
	      NodeStaticArgEff (id, neff)

	| StaticArgConst ce, StaticParamConst(id, _type_exp) -> (
	    let ceff = EvalConst.f node_id_solver ce in
	      match ceff with
		| [ceff] -> ConstStaticArgEff (id,ceff)
		| _ -> assert false (* should not occur *)
	  )
	| StaticArgType te, StaticParamType id -> 
	    let teff = typ node_id_solver te in
	      TypeStaticArgEff (id, teff)

	| StaticArgNode(CALL_n ne), StaticParamNode(id,_,_,_) ->
	    let neff = node node_id_solver ne in
	      NodeStaticArgEff (id, neff)

	| StaticArgNode(Predef (op,sargs)), StaticParamNode(id,_,_,_) ->
	    let sargs_eff = 
	      translate_predef_static_args node_id_solver sargs sa.src
	    in
	    let opeff = PredefEvalType.make_node_exp_eff op sa.src sargs_eff in
	      NodeStaticArgEff (id, opeff)

	| StaticArgNode(      
	    (MERGE_n _|ARRAY_SLICE_n _|ARRAY_ACCES_n _|STRUCT_ACCESS_n _|IDENT_n _
	    |ARRAY_n|HAT_n|CONCAT_n|WITH_n(_)|TUPLE_n|WHEN_n|CURRENT_n|FBY_n
	    |ARROW_n|PRE_n)), _ -> assert false

	| StaticArgType _, StaticParamNode(id,_,_,_) 
	| StaticArgType _, StaticParamConst(id,_) 

	| StaticArgNode _, StaticParamType(id) 
	| StaticArgNode _, StaticParamConst(id,_) 
	    
	| StaticArgConst _, StaticParamNode(id,_,_,_) 
	| StaticArgConst _, StaticParamType(id) 
	    -> 
	    assert false (* can it occur actually? Let's wait it occurs...*)
    in
      sa_eff

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


(* exported *)
and (eq : id_solver -> eq_info srcflagged -> eq_info_eff srcflagged) =
  fun id_solver eq_info -> 
    let (lpl, ve) = eq_info.it in
    let lpl_eff = List.map (translate_left_part id_solver) lpl
    and ve_eff  = translate_val_exp id_solver ve
    in
      type_check_equation id_solver eq_info lpl_eff ve_eff;
      clock_check_equation id_solver eq_info lpl_eff ve_eff;
      flagit (lpl_eff, ve_eff) eq_info.src


and (translate_left_part : id_solver -> left_part -> left_eff) =
  fun id_solver lp_top -> 
    match lp_top with
      | LeftVar id -> 
	  let vi_eff =  id_solver.id2var (Ident.idref_of_string (Ident.to_string id.it)) id.src in
	    LeftVarEff (vi_eff, id.src)
	      
      | LeftField (lp, id) -> (
	  let lp_eff = translate_left_part id_solver lp in
	  let teff = CompiledData.type_eff_of_left_eff lp_eff in
	    (* check that [lp_eff] is a struct that have a field named [id] *)
	    match teff with
	      | Struct_type_eff(_, fl) -> (
		  try let (teff_field,_) = List.assoc id.it fl in
		    LeftFieldEff(lp_eff, id.it, teff_field)
		  with Not_found ->
		    raise (Compile_error(id.src, "bad field name in structure"))
		)
	      | _  -> raise (Compile_error(id.src, "a structure was expected"))
	)
      | LeftArray (lp, vef) -> (
	  let lp_eff = translate_left_part id_solver lp in
	  let teff = CompiledData.type_eff_of_left_eff lp_eff in
	  let lxm = vef.src in
	    match teff with
	      | Array_type_eff(teff_elt, size) ->
		  let index = EvalConst.eval_array_index id_solver vef.it size lxm in
		    LeftArrayEff(lp_eff, index, teff_elt)
		      
	      | _ -> raise (Compile_error(vef.src, "an array was expected"))
	)
      | LeftSlice (lp, sif) -> (
	  let lp_eff = translate_left_part id_solver lp in
	  let teff = CompiledData.type_eff_of_left_eff lp_eff in
	    match teff with  
	      | Array_type_eff(teff_elt, size) -> 
		  let sieff = translate_slice_info id_solver sif.it size sif.src in
		  let size_slice = sieff.se_width in
		  let teff_slice = Array_type_eff(teff_elt, size_slice) in
		    LeftSliceEff(lp_eff, sieff, teff_slice)
	      | _ -> raise (Compile_error(sif.src, "an array was expected"))
	)


and (translate_val_exp : id_solver -> val_exp -> val_exp_eff) =
  fun id_solver ve ->
    match ve with
      | CallByName(by_name_op, field_list) ->
	  (CallByNameEff(
	     flagit (translate_by_name_op by_name_op.it) by_name_op.src,
	     List.map (translate_field id_solver) field_list))

      | CallByPos(by_pos_op, Oper vel) ->
	  let vel_eff = List.map (translate_val_exp id_solver) vel in
	  let by_pos_op_eff = translate_by_pos_op id_solver by_pos_op vel in
	    CallByPosEff(flagit by_pos_op_eff by_pos_op.src, OperEff vel_eff)
	      
	      
and translate_by_name_op = function
  | STRUCT_n idref     -> STRUCT_eff idref
  | STRUCT_anonymous_n -> STRUCT_anonymous_eff


and translate_field id_solver (id, ve) = (id, translate_val_exp id_solver ve)


(* XXX autre nom, autre module ? 
   ca fait partie de la definition des iterateurs d'une certaine maniere...
   -> crer 2 modules, Iterator + IteratorSemantics 
*)
and get_const id_solver const_or_const_ident lxm = 
  match const_or_const_ident with
    | StaticArgConst(c) -> List.hd (EvalConst.f id_solver c) 
    | StaticArgIdent(id) -> id_solver.id2const id lxm 
    | StaticArgType _
    | StaticArgNode _ -> raise (Compile_error(lxm, "a constant was expected"))

and get_node id_solver node_or_node_ident lxm =
  match node_or_node_ident with
    | StaticArgIdent(id) -> 
	let sargs = [] in (* I should do something more clever here to support 
			     imbricated use of iterators (e.g., "map<<map<<..." *)
	  id_solver.id2node id sargs lxm 

    | StaticArgNode(CALL_n ne) -> node id_solver ne
    | StaticArgNode(Predef (op,sargs)) ->
	let sargs_eff = translate_predef_static_args id_solver sargs lxm in
	  PredefEvalType.make_node_exp_eff op lxm sargs_eff 
    | StaticArgNode(_) -> assert false

    | StaticArgType _ 
    | StaticArgConst _ -> raise (Compile_error(lxm, "a node was expected"))


(* exported *)
and (translate_predef_static_args: id_solver -> static_arg srcflagged list -> 
      Lxm.t -> static_arg_eff list) =
  fun id_solver sargs lxm -> 
    match sargs with
      | [] -> []
      | [{src=lxm_c1;it=c1}; {src=lxm_c2;it=c2}; {src=lxm_c3;it=c3}] -> 
	  [
	    ConstStaticArgEff(Ident.of_string "min", get_const id_solver c1 lxm_c1);
	    ConstStaticArgEff(Ident.of_string "max", get_const id_solver c2 lxm_c2);
	    ConstStaticArgEff(Ident.of_string "size",get_const id_solver c3 lxm_c3)
	  ]

      | [{src=lxm_n;it=node}; {src=lxm_c;it=const}] -> 
	  let node_eff = get_node id_solver node lxm_n in
	    [NodeStaticArgEff(Ident.of_string "node", node_eff);
 	     ConstStaticArgEff(Ident.of_string "size",get_const id_solver const lxm_c)]
      | _ ->  
 	  raise (Compile_error(lxm, "bad arguments number for array iterator"))


and (translate_iteror: id_solver -> by_pos_op -> Lxm.t -> by_pos_op_eff) =
  fun id_solver op lxm ->
    match op with 
      | Predef(iter_op, sargs) ->
	  Predef_eff(iter_op, translate_predef_static_args id_solver sargs lxm)
      | _ -> assert false


and (translate_by_pos_op : id_solver -> by_pos_op srcflagged -> val_exp list ->
      by_pos_op_eff) =
  fun id_solver {it=by_pos_op;src=lxm} args ->
    match by_pos_op with
	(* put that in another module ? yes, see above.*)
      | Predef(Map,  _)
      | Predef(Fill, _)
      | Predef(Red,  _)
      | Predef(FillRed, _)
      | Predef(BoolRed, _) -> translate_iteror id_solver by_pos_op lxm 

      (* other predef operators *)
      | Predef(op, args) -> assert (args=[]); Predef_eff (op,[])
	  
      | CALL_n node_exp_f -> 
	  CALL_eff (flagit (node id_solver node_exp_f) node_exp_f.src)

      | IDENT_n idref -> (
          try
            match Ident.pack_of_idref idref with
              | Some pn -> IDENT_eff idref
                  (* Constant with a pack name are treated as
                     IDENT_eff.  Indeed, I do not see any means to
                     know if idref denotes a constant or not, since
                     the SymbolTab tables are indexed by
                     Ident.t... Anyway, CONST_eff was introduced
                     precisely to handle idref constants with no pack
                     name, so handling idref with a pack name as
                     before should be ok (albeit being quite
                     inelegant). *)
              | None -> 
                  let id = Ident.of_idref idref in
                  let pn = fst (SymbolTab.find_const2 id_solver.symbols id lxm) in
                    CONST_eff (idref, pn)
          with _ -> IDENT_eff idref  
        )
      | IDENT_n idref -> IDENT_eff idref
      | CURRENT_n -> CURRENT_eff
      | PRE_n -> PRE_eff

      | ARROW_n -> ARROW_eff
      | FBY_n -> FBY_eff
      | CONCAT_n -> CONCAT_eff
      | TUPLE_n -> TUPLE_eff
      | ARRAY_n -> ARRAY_eff
      | WITH_n(c,e1,e2) ->
	  let c_eff = EvalConst.f id_solver c in
	    if c_eff = [ Bool_const_eff true ]  then
	      WITH_eff (translate_val_exp id_solver e1)
	    else 
	      WITH_eff (translate_val_exp id_solver e2) 
      | STRUCT_ACCESS_n id -> STRUCT_ACCESS_eff id

      | WHEN_n -> 
	  (match List.map (translate_val_exp id_solver) args with
	     | [_;CallByPosEff({it=IDENT_eff id; src=lxm}, _)] -> 
		 let clk = try (id_solver.id2var id lxm) with _ -> assert false in
		   WHEN_eff clk

	     | [_;CallByPosEff
		  ({it=Predef_eff(NOT_n,[])}, 
		   OperEff [CallByPosEff({src = lxm; it = IDENT_eff id}, _)])] ->
		 let clk = try (id_solver.id2var id lxm) with _ -> assert false in
		   WHENOT_eff clk
		     
	     | _  ->
		 let msg = "syntax error: clock expr expected" in 
		   raise (Compile_error(lxm, msg))
	  )
      | ARRAY_ACCES_n ve_index ->
	  let teff = 
	    assert (List.length args = 1);
	    EvalType.f id_solver (translate_val_exp id_solver (List.hd args))
	  in
	  let size, teff_elt =
	    match teff with
	      | [Array_type_eff(teff_elt, size)] -> size, teff_elt
	      | _ ->
		  raise (Compile_error(
			   lxm, "\n*** Type error: '" ^ 
			     (LicDump.string_of_type_eff_list teff) ^ 
			     "' was expected to be an array"))
	  in
	    ARRAY_ACCES_eff(
	      EvalConst.eval_array_index id_solver ve_index size lxm, 
	      teff_elt
	    )

      | ARRAY_SLICE_n si ->
	  let teff = 
	    assert (List.length args = 1);
	    EvalType.f id_solver (translate_val_exp id_solver (List.hd args))
	  in
	  let size, teff_elt =
	    match teff with
	      | [Array_type_eff(teff_elt, size)] -> size, teff_elt
	      | _ ->
		  raise (Compile_error(
			   lxm, "\n*** Type error: '" ^ 
			     (LicDump.string_of_type_eff_list teff) ^ 
			     "' was expected to be an array"))
	  in
	    ARRAY_SLICE_eff(EvalConst.eval_array_slice id_solver si size lxm, 
			    teff_elt)

      | HAT_n -> (
	  match args with
	    | [exp; ve_size] -> 
		let size_const_eff = EvalConst.f id_solver ve_size 
		and exp_eff = translate_val_exp id_solver exp in 
		  (match size_const_eff with
		     | [Int_const_eff size] -> HAT_eff(size, exp_eff)
		     | _ -> assert false)
	    | _ -> assert false
	)

      | MERGE_n(id, idl) -> MERGE_eff(id, idl)

	  
and (translate_slice_info  : id_solver -> slice_info -> int -> Lxm.t -> 
      slice_info_eff) =
  fun id_solver si size lxm ->
    EvalConst.eval_array_slice id_solver si size lxm


(**********************************************************************************)
(* exported *)
let (assertion : CompiledData.id_solver -> SyntaxTreeCore.val_exp  Lxm.srcflagged -> 
      CompiledData.val_exp_eff  Lxm.srcflagged) =
  fun id_solver vef ->
    let val_exp_eff = translate_val_exp id_solver vef.it in
    (* Check that the assert is a bool. *)
    let evaled_exp = EvalType.f id_solver val_exp_eff in
      List.iter
	(fun ve -> 
	   if ve <> Bool_type_eff then
	     let msg = "type mismatch: \n\tthe content of the assertion is of type " 
	       ^ (LicDump.string_of_type_eff ve) 
	       ^ " whereas it shoud be a Boolean\n"
	     in
	       raise (Compile_error(vef.src, msg))
	)
	evaled_exp;
      (* type is ok *)

      Lxm.flagit val_exp_eff vef.src

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