2010-06-27 17:24:31 +02:00
|
|
|
open Minils
|
2010-07-16 09:58:56 +02:00
|
|
|
open Mls_mapfold
|
2010-06-27 17:24:31 +02:00
|
|
|
open Mls_printer
|
|
|
|
open Location
|
|
|
|
open Names
|
2010-07-23 19:45:19 +02:00
|
|
|
open Idents
|
2010-06-27 17:24:31 +02:00
|
|
|
open Signature
|
|
|
|
open Static
|
|
|
|
open Types
|
2010-07-23 22:06:06 +02:00
|
|
|
open Clocks
|
2010-06-27 17:24:31 +02:00
|
|
|
open Misc
|
|
|
|
|
|
|
|
(** Error Kind *)
|
2010-06-30 17:20:56 +02:00
|
|
|
type err_kind = | Enot_static_exp
|
2010-06-27 17:24:31 +02:00
|
|
|
|
|
|
|
let err_message ?(exp=void) ?(loc=exp.e_loc) = function
|
2010-06-30 17:20:56 +02:00
|
|
|
| Enot_static_exp ->
|
2010-09-14 09:39:02 +02:00
|
|
|
Format.eprintf "%aThe expression %a should be a static_exp.@."
|
|
|
|
print_location loc
|
2010-07-01 20:00:46 +02:00
|
|
|
print_exp exp;
|
2010-09-15 09:38:52 +02:00
|
|
|
raise Errors.Error
|
2010-06-27 17:24:31 +02:00
|
|
|
|
2010-06-30 17:20:56 +02:00
|
|
|
let rec static_exp_of_exp e =
|
2010-06-29 11:18:50 +02:00
|
|
|
match e.e_desc with
|
2010-07-02 13:50:18 +02:00
|
|
|
| Econst se -> se
|
2010-06-30 17:20:56 +02:00
|
|
|
| _ -> err_message ~exp:e Enot_static_exp
|
2010-06-27 17:24:31 +02:00
|
|
|
|
|
|
|
(** @return the list of bounds of an array type*)
|
2010-06-29 11:18:50 +02:00
|
|
|
let rec bounds_list ty =
|
2010-07-28 09:53:16 +02:00
|
|
|
match Modules.unalias_type ty with
|
2010-06-27 17:24:31 +02:00
|
|
|
| Tarray(ty, n) -> n::(bounds_list ty)
|
|
|
|
| _ -> []
|
|
|
|
|
|
|
|
(** @return the [var_dec] object corresponding to the name [n]
|
|
|
|
in a list of [var_dec]. *)
|
|
|
|
let rec vd_find n = function
|
2010-09-01 13:31:28 +02:00
|
|
|
| [] -> Format.eprintf "Not found var %s@." (name n); raise Not_found
|
2010-06-29 11:18:50 +02:00
|
|
|
| vd::l ->
|
2010-06-27 17:24:31 +02:00
|
|
|
if vd.v_ident = n then vd else vd_find n l
|
|
|
|
|
2010-06-29 11:18:50 +02:00
|
|
|
(** @return whether an object of name [n] belongs to
|
2010-06-27 17:24:31 +02:00
|
|
|
a list of [var_dec]. *)
|
|
|
|
let rec vd_mem n = function
|
|
|
|
| [] -> false
|
|
|
|
| vd::l -> vd.v_ident = n or (vd_mem n l)
|
|
|
|
|
|
|
|
(** @return whether [ty] corresponds to a record type. *)
|
|
|
|
let is_record_type ty = match ty with
|
|
|
|
| Tid n ->
|
2010-09-09 00:35:06 +02:00
|
|
|
(match Modules.find_type n with
|
2010-09-10 11:47:11 +02:00
|
|
|
| Tstruct _ -> true
|
2010-09-09 00:35:06 +02:00
|
|
|
| _ -> false)
|
2010-06-27 17:24:31 +02:00
|
|
|
| _ -> false
|
|
|
|
|
2010-06-30 10:22:31 +02:00
|
|
|
let is_op = function
|
2010-09-09 00:35:06 +02:00
|
|
|
| { qual = "Pervasives"; name = _ } -> true | _ -> false
|
2010-06-30 10:22:31 +02:00
|
|
|
|
2010-07-15 17:58:32 +02:00
|
|
|
|
|
|
|
let exp_list_of_static_exp_list se_list =
|
|
|
|
let mk_one_const se =
|
2010-09-14 17:14:27 +02:00
|
|
|
Minils.mk_exp ~ty:se.se_ty (Minils.Econst se)
|
2010-07-15 17:58:32 +02:00
|
|
|
in
|
|
|
|
List.map mk_one_const se_list
|
|
|
|
|
2010-06-27 17:24:31 +02:00
|
|
|
module Vars =
|
|
|
|
struct
|
2010-07-14 02:31:31 +02:00
|
|
|
let add x acc = if List.mem x acc then acc else x :: acc
|
2010-06-27 17:24:31 +02:00
|
|
|
|
|
|
|
let rec vars_pat acc = function
|
|
|
|
| Evarpat x -> x :: acc
|
|
|
|
| Etuplepat pat_list -> List.fold_left vars_pat acc pat_list
|
|
|
|
|
|
|
|
let rec vars_ck acc = function
|
2010-09-14 09:39:02 +02:00
|
|
|
| Con(_, _, n) -> add n acc
|
2010-06-27 17:24:31 +02:00
|
|
|
| Cbase | Cvar { contents = Cindex _ } -> acc
|
|
|
|
| Cvar { contents = Clink ck } -> vars_ck acc ck
|
|
|
|
|
2010-07-15 11:57:47 +02:00
|
|
|
let read_exp read_funs (is_left, acc_init) e =
|
2010-07-14 02:31:31 +02:00
|
|
|
(* recursive call *)
|
2010-07-15 11:57:47 +02:00
|
|
|
let _,(_, acc) = Mls_mapfold.exp read_funs (is_left, acc_init) e in
|
2010-07-14 02:31:31 +02:00
|
|
|
(* special cases *)
|
|
|
|
let acc = match e.e_desc with
|
|
|
|
| Evar x | Emerge(x,_) | Ewhen(_, _, x)
|
|
|
|
| Eapp(_, _, Some x) | Eiterator (_, _, _, _, Some x) ->
|
|
|
|
add x acc
|
|
|
|
| Efby(_, e) ->
|
2010-07-15 11:57:47 +02:00
|
|
|
if is_left then
|
|
|
|
(* do not consider variables to the right
|
|
|
|
of the fby, only clocks*)
|
|
|
|
vars_ck acc_init e.e_ck
|
|
|
|
else acc
|
2010-07-14 02:31:31 +02:00
|
|
|
| _ -> acc
|
2010-06-27 17:24:31 +02:00
|
|
|
in
|
2010-07-14 02:31:31 +02:00
|
|
|
e, (is_left, vars_ck acc e.e_ck)
|
|
|
|
|
|
|
|
let read_exp is_left acc e =
|
|
|
|
let _, (_, acc) =
|
|
|
|
Mls_mapfold.exp_it
|
|
|
|
{ Mls_mapfold.defaults with Mls_mapfold.exp = read_exp }
|
|
|
|
(is_left, acc) e in
|
|
|
|
acc
|
2010-06-27 17:24:31 +02:00
|
|
|
|
|
|
|
let rec remove x = function
|
|
|
|
| [] -> []
|
|
|
|
| y :: l -> if x = y then l else y :: remove x l
|
|
|
|
|
|
|
|
let def acc { eq_lhs = pat } = vars_pat acc pat
|
|
|
|
|
2010-07-14 02:31:31 +02:00
|
|
|
let read is_left { eq_lhs = pat; eq_rhs = e } = match pat, e.e_desc with
|
|
|
|
| Evarpat(n), Efby(_, e1) ->
|
|
|
|
if is_left
|
|
|
|
then remove n (read_exp is_left [] e1)
|
|
|
|
else read_exp is_left [] e1
|
|
|
|
| _ -> read_exp is_left [] e
|
2010-06-27 17:24:31 +02:00
|
|
|
|
|
|
|
let antidep { eq_rhs = e } =
|
|
|
|
match e.e_desc with Efby _ -> true | _ -> false
|
|
|
|
|
2010-07-14 02:31:31 +02:00
|
|
|
let clock { eq_rhs = e } = match e.e_desc with
|
|
|
|
| Emerge(_, (_, e) :: _) -> e.e_ck
|
|
|
|
| _ -> e.e_ck
|
2010-06-27 17:24:31 +02:00
|
|
|
|
|
|
|
let head ck =
|
|
|
|
let rec headrec ck l =
|
|
|
|
match ck with
|
|
|
|
| Cbase | Cvar { contents = Cindex _ } -> l
|
2010-09-14 09:39:02 +02:00
|
|
|
| Con(ck, _, n) -> headrec ck (n :: l)
|
2010-06-29 11:18:50 +02:00
|
|
|
| Cvar { contents = Clink ck } -> headrec ck l
|
2010-06-27 17:24:31 +02:00
|
|
|
in
|
2010-06-29 11:18:50 +02:00
|
|
|
headrec ck []
|
2010-06-27 17:24:31 +02:00
|
|
|
|
2010-06-29 11:18:50 +02:00
|
|
|
(** Returns a list of memory vars (x in x = v fby e)
|
2010-06-27 17:24:31 +02:00
|
|
|
appearing in an equation. *)
|
2010-07-14 02:31:31 +02:00
|
|
|
let memory_vars ({ eq_lhs = _; eq_rhs = e } as eq) = match e.e_desc with
|
|
|
|
| Efby(_, _) -> def [] eq
|
|
|
|
| _ -> []
|
2010-06-27 17:24:31 +02:00
|
|
|
end
|
|
|
|
|
2010-07-16 09:58:56 +02:00
|
|
|
let node_memory_vars n =
|
2010-09-14 09:39:02 +02:00
|
|
|
let eq _ acc ({ eq_lhs = pat; eq_rhs = e } as eq) =
|
2010-07-16 09:58:56 +02:00
|
|
|
match e.e_desc with
|
|
|
|
| Efby(_, _) -> eq, Vars.vars_pat acc pat
|
|
|
|
| _ -> eq, acc
|
|
|
|
in
|
|
|
|
let funs = { Mls_mapfold.defaults with eq = eq } in
|
|
|
|
let _, acc = node_dec_it funs [] n in
|
|
|
|
acc
|
2010-06-27 17:24:31 +02:00
|
|
|
|
|
|
|
(* data-flow dependences. pre-dependences are discarded *)
|
|
|
|
module DataFlowDep = Dep.Make
|
|
|
|
(struct
|
|
|
|
type equation = eq
|
|
|
|
let read eq = Vars.read true eq
|
|
|
|
let def = Vars.def
|
|
|
|
let antidep = Vars.antidep
|
|
|
|
end)
|
|
|
|
|
|
|
|
(* all dependences between variables *)
|
|
|
|
module AllDep = Dep.Make
|
|
|
|
(struct
|
|
|
|
type equation = eq
|
|
|
|
let read eq = Vars.read false eq
|
|
|
|
let def = Vars.def
|
2010-09-14 09:39:02 +02:00
|
|
|
let antidep _ = false
|
2010-06-27 17:24:31 +02:00
|
|
|
end)
|