CristalCaveGem » LustreC

let node_memory_variables nd =

 List.fold_left eq_memory_variables ISet.empty nd.node_eqs

(* computes the equivalence relation relating variables 

   in the same equation lhs, under the form of a table 

   of class representatives *)

 | Types.Ttuple tl -> duplicate v (List.length tl)

 | _         -> [v]

(* Add dependencies from lhs to rhs in [g, g'], *)

(* no-mem/no-mem and mem/no-mem in g            *)

(* mem/mem in g'                                *)

(* excluding all/[inputs]                       *)

      match (lhs_is_mem, ISet.mem x mems) with

      | (false, true ) -> (add_edges [x] lhs g, g'                  )

      | (false, false) -> (add_edges lhs [x] g, g'                  )

      | (true , false) -> (add_edges lhs [x] g, g'                  )

(* Add mashup dependencies for a user-defined node instance [lhs] = [f]([e]) *)

(* i.e every input is connected to every output, through a ghost var *)

    let mashup_appl_dependencies f e g =

      let f_var = mk_instance_var (sprintf "%s_%d" f eq.eq_loc.Location.loc_start.Lexing.pos_lnum) in

      List.fold_right (fun rhs -> add_dep lhs_is_mem (adjust_tuple f_var rhs) rhs)

    match rhs.expr_desc with

    | Expr_const _    -> g

    | Expr_fby (e1, e2)  -> add_dep true lhs e2 (add_dep false lhs e1 g)

    | Expr_pre e      -> add_dep true lhs e g

    | Expr_access (e1, _)

    | Expr_power (e1, _) -> add_dep lhs_is_mem lhs e1 g

    | Expr_array a -> List.fold_right (add_dep lhs_is_mem lhs) a g

    | Expr_tuple t -> List.fold_right2 (fun l r -> add_dep lhs_is_mem [l] r) lhs t g

    | Expr_ite   (c, t, e) -> add_dep lhs_is_mem lhs c (add_dep lhs_is_mem lhs t (add_dep lhs_is_mem lhs e g))

    | Expr_arrow (e1, e2)  -> add_dep lhs_is_mem lhs e2 (add_dep lhs_is_mem lhs e1 g)

    | Expr_appl (f, e, None) ->

      if Basic_library.is_internal_fun f

    (* tuple component-wise dependency for internal operators *)

      else

	mashup_appl_dependencies f e g

    | Expr_appl (f, e, Some (r, _)) ->

    | Expr_uclock  (e, _)

    | Expr_dclock  (e, _)

    | Expr_phclock (e, _) -> add_dep lhs_is_mem lhs e g 

(* Returns the dependence graph for node [n] *)

  eq_var_cpt := 0;

  instance_var_cpt := 0;

  let g = new_graph (), new_graph () in

  (* Basic dependencies *)

  g

end

let global_dependency node =

  let mems = ExprDep.node_memory_variables node in

  (*Format.eprintf "g_non_mems: %a" pp_dep_graph g_non_mems;

  Format.eprintf "g_mems: %a" pp_dep_graph g_mems;*)

  CycleDetection.check_cycles g_non_mems;

(* ck1 is a subtype of ck2 *)

let rec sub_unify sub ck1 ck2 =

  match (repr ck1).cdesc, (repr ck2).cdesc with

  | Ctuple cl1         , Ctuple cl2         ->

    if List.length cl1 <> List.length cl2

    then raise (Unify (ck1, ck2))

  (* let is_main = nd.node_id = !Options.main_node in *)

  let new_env = clock_var_decl_list env false nd.node_inputs in

  let new_env = clock_var_decl_list new_env true nd.node_outputs in

  List.iter (clock_eq new_env) nd.node_eqs;

  let ck_ins = clock_of_vlist nd.node_inputs in

  let ck_outs = clock_of_vlist nd.node_outputs in

     That's not the case for types. *)

  List.iter (fun vdecl -> try_generalize vdecl.var_clock vdecl.var_loc) nd.node_inputs;

  List.iter (fun vdecl -> try_generalize vdecl.var_clock vdecl.var_loc) nd.node_outputs;

  (* TODO : Xavier pourquoi ai je cette erreur ? *)

(*  if (is_main && is_polymorphic ck_node) then

    raise (Error (loc,(Cannot_be_polymorphic ck_node)));

      print_ck ck_node

      print_ck ck

let uneval const cr =

  (*Format.printf "Clocks.uneval %s %a@." const print_carrier cr;*)

  let cr = carrier_repr cr in

  match cr.carrier_desc with

  | Carry_var -> cr.carrier_desc <- Carry_const const

  | _         -> assert false

(* Local Variables: *)

      o

    end

(* translate_<foo> : node -> context -> <foo> -> machine code/expression *)

(* the context contains  m : state aka memory variables  *)

(*                      si : initialization instructions *)

let rec control_on_clock node ((m, si, j, d, s) as args) ck inst =

 match (Clocks.repr ck).cdesc with

 | Con    (ck1, cr, l) ->

   control_on_clock node args ck1 (MBranch (translate_ident node args id,

					    [l, [inst]] ))

 | _                   -> inst

let translate_guard node args expr =

  match expr.expr_desc with

  | Expr_ident x  -> translate_ident node args x

let rec translate_act node ((m, si, j, d, s) as args) (y, expr) =

  match expr.expr_desc with

      node_f,

      NodeDep.filter_static_inputs (node_inputs node_f) el in 

    let o = new_instance node node_f eq.eq_rhs.expr_tag in

    (m,

     (if Stateless.check_node node_f then si else MReset o :: si),

     (if Basic_library.is_internal_fun f then j else Utils.IMap.add o call_f j),

     d,

     reset_instance node args o r eq.eq_rhs.expr_clock @

   (* special treatment depending on the active backend. For horn backend, x = ite (g,t,e)

      are preserved. While they are replaced as if g then x = t else x = e in  C or Java

      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

let mk_expr_alias_opt opt node defvars expr =

(* Create a (normalized) expression from [ref_e], 

   replacing description with [norm_d],

  | _ -> normalize_expr ~alias:alias node offsets defvars expr

and normalize_guard node defvars expr =

(* outputs cannot be memories as well. If so, introduce new local variable.

*)

  match expr.expr_desc with

    | Expr_const c -> pp_const fmt c

    | Expr_ident id -> Format.fprintf fmt "%s" id

    | Expr_array a -> fprintf fmt "[%a]" pp_tuple a

    | Expr_access (a, d) -> fprintf fmt "%a[%a]" pp_expr a Dimension.pp_dimension d

    | Expr_power (a, d) -> fprintf fmt "(%a^%a)" pp_expr a Dimension.pp_dimension d

    !sorted

  end

let schedule_node n =

  try

    let eq_equiv = ExprDep.node_eq_equiv n in

    let n', g = global_dependency n in

    Log.report ~level:5 (fun fmt -> Format.eprintf "dependency graph for node %s: %a" n'.node_id pp_dep_graph g);

    let gg = IdentDepGraph.copy g in

    let death = Liveness.death_table n gg sort in

    Log.report ~level:5 (fun fmt -> Format.eprintf "death table for node %s: %a" n'.node_id Liveness.pp_death_table death);

(* ty1 is a subtype of ty2 *)

let rec sub_unify sub ty1 ty2 =

  match (repr ty1).tdesc, (repr ty2).tdesc with

  | Ttuple tl1         , Ttuple tl2         ->

    if List.length tl1 <> List.length tl2

    then raise (Unify (ty1, ty2))