licDump.ml

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

open Printf
open Lxm
open Eff

let (long : Ident.long -> string) = Ident.string_of_long
(*   fun id ->  *)
(*     let str = Ident.string_of_long id in *)
(*       Str.global_replace (Str.regexp "::") "__" str *)

let type_alias_table = Hashtbl.create 0

(******************************************************************************)    
(* exported *)
type tab_elt = 
  | OpProfile of Eff.type_ list * Eff.type_ list
  | Subst of Eff.type_

let (polymorph_op_tab: (Lxm.t, tab_elt) Hashtbl.t) = Hashtbl.create 0

let (tabulate_poly_op : Lxm.t -> tab_elt -> unit) =
  fun key value -> Hashtbl.replace polymorph_op_tab key value

let (poly_op_mem : Lxm.t -> bool) =
 fun key -> Hashtbl.mem polymorph_op_tab key 
    
let (poly_op_find :  Lxm.t -> tab_elt option) =
  fun x -> 
    try Some (Hashtbl.find polymorph_op_tab x)
    with _ -> None

let last_poly_var = ref Int_type_eff

(** Un-nesting iterator calls. 

    The idea is the following: each time a nested iterator call
    (map<<map<<n,3>>,4>>) is encountered, we create a fresh alias
    name (create_alias_name) ad we add it in the node_alias_tbl.  At
    the end of the compilation, LicDump.dump_node_alias is called,
    which prints the definition of those node aliases.

    For example, the expression  "map<<map<<n,3>>,4>>" is printed like this:
    
    "map<<_node_alias1, 4>>"

    and later, the node alias is defined:

        node _node_alias1(x:int) returns(y:int); let y = map<<n,3>>(x); tel;
*)

(* This table associates to node its definition plus a flag indicating if that
   node has been generated. *)

type node_profile = Eff.type_ list * Eff.type_ list
let (node_alias_tbl : (string, Eff.node_exp * tab_elt option * bool) Hashtbl.t) = 
  Hashtbl.create 0
let alias_fresh_var_cpt = ref 0
let create_alias_name long =
  incr alias_fresh_var_cpt;
  ("_node_alias_" ^ (string_of_int !alias_fresh_var_cpt) 
   ^ "_" ^ (Ident.string_of_long long))


(******************************************************************************)    
(* prefix used to prefix user type name in order to avoid name clashed with
   the alias type name that are generated by the compiler. *)
let prefix = "_"

let rec string_of_const_eff = (
  function
    | Bool_const_eff true -> "true"
    | Bool_const_eff false -> "false"
    | Int_const_eff i -> sprintf "%d" i
    | Real_const_eff r -> sprintf "%f" r
    | Extern_const_eff (s,t,vopt) -> (long s) ^ (string_of_const_eff_opt vopt)
    | Enum_const_eff   (s,t) -> (long s)
    | Struct_const_eff (fl, t) -> (
	let string_of_field = 
	  function (id, veff) -> 
	    (Ident.to_string id)^" = "^(string_of_const_eff veff)
	in
	let flst = List.map string_of_field fl in
	  (string_of_type_eff t)^"{"^(String.concat "; " flst)^"}"
      )
    | Array_const_eff (ctab, t) -> (
	let vl = Array.to_list(Array.map string_of_const_eff ctab) in
	  "["^(String.concat ", " vl)^"]"
      )
)

and string_of_const_eff_opt = function
  | None -> ""
  | Some val_exp_eff -> string_of_const_eff val_exp_eff

and string_def_of_type_eff = function
  | Bool_type_eff -> "bool"
  | Int_type_eff  -> "int"
  | Real_type_eff -> "real"
  | External_type_eff i -> long i
  | Enum_type_eff (i, sl) -> 
      assert (sl <>[]);
      let f sep acc s  = acc ^ sep ^ (long s) in
        (List.fold_left (f ", ")  (f "" "enum {" (List.hd sl)) (List.tl sl)) ^ "}"
  | Array_type_eff (ty, sz) -> sprintf "%s^%d" (string_of_type_eff ty) sz
  | Struct_type_eff (name, fl) -> 
      assert (fl <>[]);
      let f sep acc (id, (type_eff, const_eff_opt))  = 
	acc ^ sep ^ (Ident.to_string id) ^ " : " ^
	  (string_of_type_eff type_eff) ^
	  match const_eff_opt with
	      None -> ""
	    | Some ce -> " = " ^ (string_of_const_eff ce)
      in
        "struct " ^
	  (List.fold_left (f "; ")  (f "" " {" (List.hd fl)) (List.tl fl)) ^ "}"
	  
  | Any -> "a"
  | Overload -> "o"

(* exported *)
and string_of_type_eff = function
  | Bool_type_eff -> "bool"
  | Int_type_eff  -> "int"
  | Real_type_eff -> "real"
  | External_type_eff name -> prefix ^ (long name)
  | Enum_type_eff (name, _) -> prefix ^ (long name)
  | Array_type_eff (ty, sz) -> array_alias ty sz
  | Struct_type_eff (name, _) -> prefix ^ (long name)
  | Any -> "a"
  | Overload -> "o"


(******************************************************************************)
(** Stuff to manage generated type alias 
    
    Indeed instead of printing:

    node toto(x: int ^ 4) ... 

    we want to print something like :

    type int4 = int ^ 4;
    node toto(x: int4) ... 
    
    That may occur only for array actually.

    To do that, we maintain a table of type alias that we fill each time
    we want to print (via string_of_type_eff) a type that is not a named type.
    Then, at the end, we will dump that table in the lic file.

    This table is filled by [array_alias].

    In order to avoid name clashes, we prefix all user name type by [prefix] (cf
    at the top of this file).
    
*)
and (array_alias : Eff.type_ -> int -> string) = 
  fun t size -> 
    let array_t = Array_type_eff(t,size) in
      try
        Hashtbl.find type_alias_table array_t 
      with Not_found -> 
        let alias_t = string_of_type_eff t in
        let res = "A_"^ alias_t ^ "_" ^(string_of_int size) in
          Hashtbl.add type_alias_table array_t res;
          res

(* exported *)
and dump_type_alias oc =
  let p = output_string oc in
    if Hashtbl.length type_alias_table > 0 then p "-- automatically defined aliases:";
    Hashtbl.iter
      (fun type_eff alias_name -> 
         p ("\ntype " ^ alias_name ^ " = "  ^ (string_def_of_type_eff type_eff)^";")
      )
      type_alias_table
      
(******************************************************************************) 

(* exported *)
and (dump_node_alias : out_channel -> unit) =
  fun oc -> 
    let p = output_string oc in
    let finished = ref true in
    let f alias (node, np, dumped) =
      let _ = 
        match np with
          | Some(Subst(t)) -> last_poly_var := t
          | Some(OpProfile(_)) | None -> ()
      in
      let get_name_and_type_string var =
        let t = subst_type !last_poly_var var.var_type_eff in
          (Ident.to_string var.var_name_eff) ^ ":" ^ (string_of_type_eff t)
      in
      let inlist  = List.map get_name_and_type_string node.inlist_eff
      and outlist = List.map get_name_and_type_string node.outlist_eff
      in
      let profile = ("("^(String.concat "; " inlist)^") returns ("^
                       (String.concat "; " outlist)^");\n")
      in
        if not dumped then (
          finished := false;
          p "node ";
          p alias;
          (*         p (profile_of_node_exp_eff node); *)
          p profile;
          p "let\n  ";
          p (Ident.to_string (List.hd node.outlist_eff).var_name_eff);
          p " = ";
          p (string_of_node_key_iter node.lxm node.node_key_eff);
          p "(";
          p (String.concat "," 
               (List.map (fun v -> Ident.to_string v.var_name_eff) node.inlist_eff));
          p ")";
          p ";\ntel\n";
          Hashtbl.replace node_alias_tbl alias (node, np, true)
        )
    in
      p "\n";
      Hashtbl.iter f node_alias_tbl;
      if not !finished then dump_node_alias oc

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

(* exported  *)
and (type_eff_list_to_string : Eff.type_ list -> string) =
  fun tel -> 
    let str_l = List.map string_of_type_eff tel in
      String.concat "*" str_l    

and string_of_type_eff_list = function
  | []  -> ""
  | [x] -> string_of_type_eff x
  | l   -> String.concat " * " (List.map string_of_type_eff l)


      
(* for printing recursive node *)
and string_of_node_key_rec (nkey: node_key) = 
  match nkey with
    | (ik, []) -> long ik
    | (ik, salst) ->
	let astrings = List.map static_arg2string_rec salst in
	  sprintf "%s_%s" (long ik) (String.concat "_" astrings)

(* for printing iterators *)
and string_of_node_key_iter lxm (nkey: node_key) = 
  match nkey with
    | (ik, []) -> long ik
    | (ik, salst) ->
	let astrings = List.map (static_arg2string (Some lxm)) salst in
	  sprintf "%s<<%s>>" (long ik) (String.concat ", " astrings)

(* for printing recursive node *)
and static_arg2string_rec (sa : Eff.static_arg) =
  match sa with
    | ConstStaticArgEff (id, ceff) -> sprintf "%s" (string_of_const_eff ceff)
    | TypeStaticArgEff  (id, teff) -> sprintf "%s" (string_of_type_eff teff)
    | NodeStaticArgEff  (id, opeff) ->
	sprintf "%s" (string_of_node_key_rec opeff.node_key_eff)

(* for printing iterators *)
and static_arg2string lxm_opt (sa : Eff.static_arg) =
  match sa with
    | ConstStaticArgEff (id, ceff) -> sprintf "%s" (string_of_const_eff ceff)
    | TypeStaticArgEff  (id, teff) -> sprintf "%s" (string_of_type_eff teff)
    | NodeStaticArgEff  (id, opeff) ->
        if 
          (snd opeff.node_key_eff) = []
        then 
	  sprintf "%s" (string_of_node_key_iter opeff.lxm opeff.node_key_eff)
        else
          let np = 
            match lxm_opt with
              | None -> None
              | Some lxm -> poly_op_find lxm
          in
          let alias = create_alias_name (fst opeff.node_key_eff) in
            Hashtbl.add node_alias_tbl alias (opeff, np, false);
            sprintf "%s" alias

and (string_of_var_info_eff: Eff.var_info -> string) =
  fun x -> 
    (Ident.to_string x.var_name_eff) ^ ":"^(string_of_type_eff x.var_type_eff)

and (type_string_of_var_info_eff: Eff.var_info -> string) =
  fun x -> (string_of_type_eff x.var_type_eff) ^ 
    (string_of_clock2 (snd x.var_clock_eff))

and string_of_decl var_info_eff = 
  (Ident.to_string var_info_eff.var_name_eff) ^ ":" ^ 
    (string_of_type_eff var_info_eff.var_type_eff) ^
    (string_of_clock_decl (snd var_info_eff.var_clock_eff))

and (string_of_type_decl_list : Eff.var_info list -> string -> string) =
  fun tel sep -> 
    let str = String.concat sep (List.map string_of_decl tel) in
      str



and string_of_slice_info_eff si_eff =
  "[" ^ (string_of_int si_eff.se_first) ^ " .. " ^ (string_of_int si_eff.se_last) ^
    (if si_eff.se_step = 1 then "" else " step " ^ (string_of_int si_eff.se_step)) ^
    "]"

and (string_of_leff : Eff.left -> string) =
  function
    | LeftVarEff  (vi_eff,_) -> Ident.to_string vi_eff.var_name_eff  
    | LeftFieldEff(leff,id,_) -> (string_of_leff leff) ^ "." ^ (Ident.to_string id)
    | LeftArrayEff(leff,i,_)  -> (string_of_leff leff) ^ "[" ^ (string_of_int i) ^ "]"
    | LeftSliceEff(leff,si,_) -> (string_of_leff leff) ^ (string_of_slice_info_eff si)

and (string_of_leff_list : Eff.left list -> string) =
  fun l -> 
    (if List.length l = 1 then "" else "(") ^ 
      (String.concat ", " (List.map string_of_leff l)) ^ 
      (if List.length l = 1 then "" else ")") 




and (string_of_by_pos_op_eff: Eff.by_pos_op srcflagged -> Eff.val_exp list -> string) =
  fun posop vel -> 
    let tuple vel = (String.concat ", " (List.map string_of_val_exp_eff vel)) in
    let tuple_par vel = "(" ^ (tuple vel) ^ ")" in
    let tuple_square vel = 
      "[" ^ (String.concat ", " (List.map string_of_val_exp_eff vel)) ^ "]"
    in
    let lxm = posop.src in
    let str = 
      match posop.it,vel with
	| Predef (Predef.IF_n,_), [ve1; ve2; ve3] ->
	    " if " ^ (string_of_val_exp_eff ve1) ^ 
	      " then " ^ (string_of_val_exp_eff ve2) ^ 
	      " else " ^ (string_of_val_exp_eff ve3)

	| Predef(op,sargs), vel -> 
	      if Predef.is_infix op then (
	        match vel with 
		  | [ve1; ve2] -> 
		      (string_of_val_exp_eff ve1) ^ " " ^ (Predef.op2string op) ^ 
		        " " ^ (string_of_val_exp_eff ve2)
		  | _ -> assert false
	      ) 
	      else 
	        ((Predef.op2string op) ^
		   (if sargs = [] then 
                      match op with
                        | Predef.ICONST_n _ | Predef.RCONST_n _   | Predef.NOT_n
                        | Predef.UMINUS_n | Predef.IUMINUS_n | Predef.RUMINUS_n
                        | Predef.FALSE_n | Predef.TRUE_n -> tuple vel 
                        | _ -> tuple_par vel 
                    else 
                   "<<" ^ 
                   (String.concat ", " (List.map (static_arg2string (Some lxm)) sargs))
		   ^ ">>" ^ (tuple_par vel)))

	| CALL nee, _  -> (
	    if nee.it.def_eff = ExternEff then
	      ((string_of_node_key_iter nee.src nee.it.node_key_eff) ^ (tuple_par vel))
	    else
	      (* recursive node cannot be extern *)
	      ((string_of_node_key_rec nee.it.node_key_eff) ^ (tuple_par vel))
	  )
	| IDENT idref, _ -> Ident.string_of_idref idref
	| CONST (idref,pn), _ ->
            Ident.string_of_idref (
              match Ident.pack_of_idref idref with
                | Some _ ->  idref
                | None -> Ident.make_idref pn (Ident.of_idref idref)
            )
	| PRE, _ -> "pre "  ^ (tuple vel)
	| ARROW, [ve1; ve2] -> 
	    (string_of_val_exp_eff ve1) ^ " -> " ^ (string_of_val_exp_eff ve2)
	| FBY, [ve1; ve2] -> 
	    (string_of_val_exp_eff ve1) ^ " fby " ^ (string_of_val_exp_eff ve2)
	| WHEN clk, vel -> (tuple vel) ^ " when " ^ (string_of_clock_exp clk)
	| CURRENT,_ -> "current " ^ (tuple vel)
	| TUPLE,_ -> (tuple vel)
	| WITH(ve),_ -> (string_of_val_exp_eff ve)
	| CONCAT, [ve1; ve2] ->  
	    (string_of_val_exp_eff ve1) ^ " | " ^ (string_of_val_exp_eff ve2)
	| HAT (i, ve), _ -> (string_of_val_exp_eff ve) ^ "^" ^ (string_of_int i)
	| ARRAY, _ -> tuple_square vel
	| STRUCT_ACCESS(id), [ve1] ->
	    (string_of_val_exp_eff ve1) ^ "." ^ (Ident.to_string id)

	| ARRAY_ACCES(i, type_eff), [ve1] ->
	    (string_of_val_exp_eff ve1) ^ "[" ^ (string_of_int i) ^ "]"

	| ARRAY_SLICE(si_eff, type_eff), [ve1] -> 
	    (string_of_val_exp_eff ve1) ^ (string_of_slice_info_eff si_eff)

	| ARRAY_SLICE(_,_), _ -> assert false (* todo *)
	| MERGE _, _ -> assert false (* todo *)
            (* 	| ITERATOR _, _ -> assert false (* todo *) *)

        (* Cannot happen *)
	| ARROW, _ -> assert false
	| FBY, _ -> assert false
	| CONCAT, _ -> assert false
	| STRUCT_ACCESS(_), _ -> assert false
	| ARRAY_ACCES(i, type_eff), _ -> assert false
    in
    let do_not_parenthesize = function 
      | CONST _,_ 
      | IDENT _,_ 
      | Predef((Predef.ICONST_n _), _),_
      | Predef((Predef.RCONST_n _), _),_
      | Predef((Predef.FALSE_n), _),_
      | Predef((Predef.TRUE_n), _),_
      | ARRAY_ACCES _,_
      | STRUCT_ACCESS _,_ -> true   
      | _,_ ->  false 
    in 
      if 
        (* already parenthesized *)
        ( Str.string_match (Str.regexp "^(") str 0 && 
            Str.string_match (Str.regexp ")$") str 0 ) 
        || 
          (* ident or predef constants *)
          (do_not_parenthesize (posop.it,vel)) 
        ||
          !Global.one_op_per_equation
      then 
        str 
      else 
        ("(" ^ str ^ ")")

and string_of_val_exp_eff = function
  | CallByPosEff (by_pos_op_eff, OperEff vel) ->
      (string_of_by_pos_op_eff by_pos_op_eff vel) 

  | CallByNameEff(by_name_op_eff, fl) -> 
      (match by_name_op_eff.it with
	 | STRUCT (pn,idref) -> prefix ^ (
             match Ident.pack_of_idref idref with
               | Some pn -> Ident.string_of_idref idref
               | None -> 
                   let idref = Ident.make_idref pn (Ident.of_idref idref) in
                     Ident.string_of_idref idref
           )
	 | STRUCT_anonymous -> "") ^
	"{" ^ (String.concat ";" 
		 (List.map 
		    (fun (id,veff) -> 
		       (Ident.to_string id.it) ^ "=" ^ (string_of_val_exp_eff veff)
		    )
		    fl)) ^
	"}"


and string_of_clock_exp = function
  | SyntaxTreeCore.Base -> "base"
  | SyntaxTreeCore.NamedClock clk -> Ident.string_of_clk clk.it


and wrap_long_line str = 
  if String.length str < 75 then str else
    let str_list = Str.split (Str.regexp " ") str in
    let new_str, reste =
      List.fold_left
	(fun (accl, acc_str) str ->
	   let new_acc_str = acc_str ^ " " ^ str in
	     if 
	       String.length new_acc_str > 75
	     then
	       (accl ^ acc_str ^ "\n\t" , str)
	     else
	       (accl, new_acc_str)
	)
	("","")
	str_list
    in
      new_str ^ " " ^ reste

and string_of_eq_info_eff (leff_list, vee) =
  wrap_long_line (
    (string_of_leff_list leff_list) ^ " = " ^ (string_of_val_exp_eff vee) ^ ";")

and (string_of_assert : Eff.val_exp srcflagged -> string ) =
  fun eq_eff -> 
    wrap_long_line (
      "assert(" ^ string_of_val_exp_eff eq_eff.it ^ ");")

and (string_of_eq : Eff.eq_info srcflagged -> string) =
  fun eq_eff ->
    string_of_eq_info_eff eq_eff.it



and wrap_long_profile str = 
  if String.length str < 75 then str else
    "\n"^(
      Str.global_replace (Str.regexp "returns") "\nreturns"
	(Str.global_replace (Str.regexp "(") "(\n\t"
	   (Str.global_replace (Str.regexp "; ") ";\n\t" str)))  

and (profile_of_node_exp_eff: Eff.node_exp -> string) =
  fun neff ->
    ("(" ^ (string_of_type_decl_list  neff.inlist_eff "; ") ^ ") returns (" ^
       (string_of_type_decl_list neff.outlist_eff "; ") ^ ");\n")

and (string_of_node_def : Eff.node_def -> string list) =
  function
    | ExternEff
    | AbstractEff -> []
    | BodyEff node_body_eff -> 
	List.append
	  (List.map string_of_assert node_body_eff.asserts_eff)
	  (List.map string_of_eq node_body_eff.eqs_eff)

          

(* exported *)
and (type_decl: Ident.long -> Eff.type_ -> string) =
  fun tname teff -> 
    "type " ^ prefix ^ (long tname) ^ 
      (match teff with 
	 | External_type_eff _ -> ";\n"
	 | _ -> " = " ^ (string_def_of_type_eff teff) ^ ";\n"
      )
      
(* exported *)
and (const_decl: Ident.long -> Eff.const -> string) =
  fun tname ceff -> 
    let begin_str = ("const " ^ (long tname)) in
    let end_str = (string_of_const_eff ceff) ^ ";\n" in
      (match ceff with 
         | Enum_const_eff _  -> "" 
             (* do not print those const, because there were
                introduced by the compiler *)
         | Extern_const_eff _ ->
             begin_str ^ ":" ^ (string_of_type_eff (Eff.type_of_const ceff)) ^ ";\n"
         | Struct_const_eff _
         | Array_const_eff _
         | Bool_const_eff _
         | Int_const_eff _
         | Real_const_eff _ -> begin_str ^ " = " ^ end_str
      ) 

        
(* exported *)
and (node_of_node_exp_eff: Eff.node_exp -> string) =
  fun neff -> 
    wrap_long_profile (
      (if neff.def_eff = ExternEff then "extern " else "") ^
        (if neff.has_mem_eff then "node " else "function ") ^
        (string_of_node_key_rec neff.node_key_eff) ^
        (profile_of_node_exp_eff neff)) ^ 
      (match neff.def_eff with
	 | ExternEff ->  ""
	 | AbstractEff -> ""
	 | BodyEff _ ->  
	     ((match neff.loclist_eff with None -> "" | Some [] -> ""
		 | Some l ->
		     "var\n   " ^ (string_of_type_decl_list l ";\n   ") ^ ";\n") ^
		"let\n   " ^
		 (String.concat "\n   " (string_of_node_def neff.def_eff)) ^
		 "\ntel\n-- end of node " ^
		 (string_of_node_key_rec neff.node_key_eff) ^ "\n"
	     )
      )


(* exported *)
and string_of_clock2 (ck : Eff.clock) =
  match ck with
    | BaseEff -> " on base"
    | On(clk_exp,ceff) ->
        let (cc,v) = clk_exp in
        let clk_exp_str =
          match Ident.string_of_idref cc with
            | "True" -> (Ident.to_string v)
            | "False" ->  " not " ^ (Ident.to_string v)
            | _ -> Ident.string_of_clk clk_exp
        in
          " on " ^ clk_exp_str ^ (string_of_clock2 ceff)
    | ClockVar i ->  "'a" ^ string_of_int i
        
 
and string_of_clock_decl (ck : Eff.clock) =
  match ck with
    | BaseEff -> ""
    | On(clk_exp,_) ->
        let (cc,v) = clk_exp in
        let clk_exp_str =
          match Ident.string_of_idref cc with
            | "True" -> (Ident.to_string v)
            | "False" ->  "not " ^ (Ident.to_string v)
            | _ -> Ident.string_of_clk clk_exp
        in
          " when " ^ clk_exp_str
    | ClockVar _ ->  assert false
        (*     | ClockVar i -> "_clock_var_" ^ (string_of_int i) *)



(*---------------------------------------------------------------------
Formatage standard des erreurs de compil
----------------------------------------------------------------------*)
let node_error_string lxm nkey = (
   Printf.sprintf "While checking %s" (string_of_node_key_iter lxm nkey)
)

(*---------------------------------------------------------------------
Message d'erreur (associé à un lexeme) sur stderr
----------------------------------------------------------------------*)
let print_compile_node_error nkey lxm msg = (
   Printf.eprintf "%s\n" (node_error_string lxm nkey);
  Errors.print_compile_error lxm msg ;
   flush stderr
)

let print_global_node_error lxm nkey msg = (
   Printf.eprintf "%s\n" (node_error_string lxm nkey);
  Errors.print_global_error msg ;
   flush stderr
)