heptagon/minils/minils.ml

754 lines
21 KiB
OCaml
Raw Normal View History

2010-06-15 10:49:03 +02:00
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* The internal MiniLustre representation *)
(* $Id$ *)
open Location
open Dep
open Misc
open Names
open Ident
open Linearity
open Interference_graph
open Global
open Static
(** Inlining policies, to be held in app records. *)
type inlining_policy =
| Ino (** Do not inline. *)
| Ione (** Just inline on one step. *)
| Irec (** Recursively inline all sub-calls. *)
type type_dec =
{ t_name: name;
t_desc: tdesc;
t_loc: location }
and tdesc =
| Type_abs
| Type_enum of name list
| Type_struct of (name * base_ty) list
and exp =
{ e_desc: desc; (* its descriptor *)
mutable e_ck: ck;
mutable e_ty: ty;
mutable e_linearity : linearity;
e_loc: location }
and desc =
| Econst of const
| Evar of ident
| Econstvar of name
| Efby of const option * exp
| Ereset_mem of ident * const * ident
| Etuple of exp list
| Eop of longname * size_exp list * exp list
| Eapp of app * size_exp list * exp list
| Eevery of app * size_exp list * exp list * ident
| Ewhen of exp * longname * ident
| Emerge of ident * (longname * exp) list
| Eifthenelse of exp * exp * exp
| Efield of exp * longname
| Estruct of (longname * exp) list
(*Array operators*)
| Earray of exp list
| Erepeat of size_exp * exp
| Eselect of size_exp list * exp (*indices, array*)
| Eselect_dyn of exp list * size_exp list * exp * exp (*indices, bounds, array, default*)
| Eupdate of size_exp list * exp * exp (*indices, array, value*)
| Eselect_slice of size_exp * size_exp * exp (*lower bound, upper bound, array*)
| Econcat of exp * exp
| Eiterator of iterator_name * longname * size_exp list * size_exp * exp list * ident option
| Efield_update of longname * exp * exp (*field, record, value*)
and app =
{ a_op: longname;
a_inlined: inlining_policy
}
and ct =
| Ck of ck
| Cprod of ct list
and ck =
| Cbase
| Cvar of link ref
| Con of ck * longname * ident
and link =
| Cindex of int
| Clink of ck
and ty =
| Tbase of base_ty
| Tprod of ty list
and base_ty =
| Tint | Tfloat
| Tid of longname
| Tarray of base_ty * size_exp
and const =
| Cint of int
| Cfloat of float
| Cconstr of longname
| Cconst_array of size_exp * const
and pat =
| Etuplepat of pat list
| Evarpat of ident
type eq =
{ p_lhs : pat;
p_rhs : exp; }
type var_dec =
{ v_name : ident;
v_copy_of : ident option;
v_type : base_ty;
v_linearity : linearity;
v_clock : ck }
type contract =
{ c_assume : exp;
c_enforce : exp;
c_controllables : var_dec list;
c_local : var_dec list;
c_eq : eq list;
}
type node_dec =
{ n_name : name;
n_input : var_dec list;
n_output : var_dec list;
n_contract : contract option;
n_local : var_dec list;
n_equs : eq list;
n_loc : location;
n_targeting : (int*int) list;
n_mem_alloc : (base_ty * ivar list) list;
n_states_graph : (name,name) interf_graph;
n_params : name list;
n_params_constraints : size_constr list;
n_params_instances : (int list) list; }
type const_dec =
{ c_name : name;
c_value : size_exp;
c_loc : location; }
type program =
{ p_pragmas: (name * string) list;
p_opened : name list;
p_types : type_dec list;
p_nodes : node_dec list;
p_consts : const_dec list; }
(*Helper functions to build the AST*)
let make_exp desc ty l ck loc =
{ e_desc = desc; e_ty = ty; e_linearity = l; e_ck = ck; e_loc = loc }
let make_dummy_exp desc ty =
{ e_desc = desc; e_ty = ty; e_linearity = NotLinear;
e_ck = Cbase; e_loc = no_location }
(* Helper functions to work with types *)
let base_type = function
| Tbase(bty) -> bty
| Tprod _ -> assert false
(* get the type of an expression ; assuming that this type is a base type *)
let exp_base_type e =
base_type e.e_ty
let rec size_exp_of_exp e =
match e.e_desc with
| Econstvar n -> SVar n
| Econst (Cint i) -> SConst i
| Eop(op, _, [e1;e2]) ->
let sop = op_from_app_name op in
SOp(sop, size_exp_of_exp e1, size_exp_of_exp e2)
| _ -> raise Not_static
(*Returns the list of bounds of an array type*)
let rec bounds_list ty =
match ty with
| Tarray(ty, n) -> n::(bounds_list ty)
| _ -> []
(** Returns the var_dec object corresponding to the name n
in a list of var_dec. *)
let rec vd_find n = function
| [] -> Format.printf "Not found var %s\n" (name n); raise Not_found
| vd::l ->
if vd.v_name = n then vd else vd_find n l
(** Returns whether an object of name n belongs to
a list of var_dec. *)
let rec vd_mem n = function
| [] -> false
| vd::l -> vd.v_name = n or (vd_mem n l)
(** Same as vd_mem but for an ivar value. *)
let ivar_vd_mem var vds =
match var with
| IVar id -> vd_mem id vds
| _ -> false
(** [is_record_type ty] returns whether ty corresponds to a record type. *)
let is_record_type ty =
match ty with
| Tid n ->
(try
ignore (Modules.find_struct n);
true
with
Not_found -> false
)
| _ -> false
module Vars =
struct
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
| Con(ck, c, n) -> if List.mem (IVar n) acc then acc else (IVar n) :: acc
| Cbase | Cvar { contents = Cindex _ } -> acc
| Cvar { contents = Clink ck } -> vars_ck acc ck
let rec read is_left acc e =
let add x acc = if List.mem (IVar x) acc then acc else (IVar x) :: acc in
let acc =
match e.e_desc with
| Emerge(x, c_e_list) ->
let acc = add x acc in
List.fold_left (fun acc (_, e) -> read is_left acc e) acc c_e_list
| Eifthenelse(e1, e2, e3) ->
read is_left (read is_left (read is_left acc e1) e2) e3
| Ewhen(e, c, x) ->
let acc = add x acc in
read is_left acc e
| Eop(_, _, e_list)
| Etuple(e_list) -> List.fold_left (read is_left) acc e_list
| Eapp(_, _, e_list) -> List.fold_left (read is_left) acc e_list
| Eevery(_, _, e_list, x) ->
let acc = add x acc in
List.fold_left (read is_left) acc e_list
| Efby(_, e) ->
if is_left then vars_ck acc e.e_ck else read is_left acc e
| Ereset_mem (_, _,res) -> add res acc
| Evar(n) -> add n acc
| Efield({ e_desc = Evar x }, f) ->
let acc = add x acc in
let x = IField(x,f) in
if List.mem x acc then acc else x::acc
| Efield(e, _) -> read is_left acc e
| Estruct(f_e_list) ->
List.fold_left (fun acc (_, e) -> read is_left acc e) acc f_e_list
| Econst _ | Econstvar _ -> acc
(*Array operators*)
| Earray e_list -> List.fold_left (read is_left) acc e_list
| Erepeat (_,e) -> read is_left acc e
| Eselect (_,e) -> read is_left acc e
| Eselect_dyn (e_list, _, e1, e2) ->
let acc = List.fold_left (read is_left) acc e_list in
read is_left (read is_left acc e1) e2
| Eupdate (_, e1, e2) | Efield_update (_, e1, e2) ->
read is_left (read is_left acc e1) e2
| Eselect_slice (_ , _, e) -> read is_left acc e
| Econcat (e1, e2) ->
read is_left (read is_left acc e1) e2
| Eiterator (_, _, _, _, e_list, _) ->
List.fold_left (read is_left) acc e_list
in
vars_ck acc e.e_ck
let rec remove x = function
| [] -> []
| y :: l -> if x = y then l else y :: remove x l
let def acc { p_lhs = pat } = vars_pat acc pat
let read is_left { p_lhs = pat; p_rhs = e } =
match pat, e.e_desc with
| Evarpat(n), Efby(_, e1) ->
if is_left
then remove (IVar n) (read is_left [] e1)
else read is_left [] e1
| _ -> read is_left [] e
let rec remove_records = function
| [] -> []
| (IVar x)::l -> (IVar x)::(remove_records l)
| (IField(x,f))::l ->
let l = remove (IVar x) l in
(IField(x,f))::(remove_records l)
let read_ivars is_left eq =
remove_records (read is_left eq)
let read is_left eq =
filter_vars (read is_left eq)
let antidep { p_rhs = e } =
match e.e_desc with Efby _ -> true | _ -> false
let clock { p_rhs = e } =
match e.e_desc with
| Emerge(_, (_, e) :: _) -> e.e_ck
| _ -> e.e_ck
let head ck =
let rec headrec ck l =
match ck with
| Cbase | Cvar { contents = Cindex _ } -> l
| Con(ck, c, n) -> headrec ck (n :: l)
| Cvar { contents = Clink ck } -> headrec ck l in
headrec ck []
let rec linear_use acc e =
match e.e_desc with
| Emerge(_, c_e_list) ->
List.fold_left (fun acc (_, e) -> linear_use acc e) acc c_e_list
| Eifthenelse(e1, e2, e3) ->
linear_use (linear_use (linear_use acc e1) e2) e3
| Ewhen(e, _, _) | Efield(e, _) | Efby(_, e) -> linear_use acc e
| Eop(_,_, e_list)
| Etuple(e_list) | Earray e_list
| Eapp(_,_, e_list) | Eiterator (_, _, _, _, e_list, _)
| Eevery(_,_, e_list, _) -> List.fold_left linear_use acc e_list
| Evar(n) ->
(match e.e_linearity with
| At _ -> if List.mem n acc then acc else n :: acc
| _ -> acc
)
| Estruct(f_e_list) ->
List.fold_left (fun acc (_, e) -> linear_use acc e) acc f_e_list
| Econst _ | Econstvar _ | Ereset_mem (_, _,_) -> acc
(*Array operators*)
| Erepeat (_,e)
| Eselect (_,e) | Eselect_slice (_ , _, e) -> linear_use acc e
| Eselect_dyn (e_list, _, e1, e2) ->
let acc = List.fold_left linear_use acc e_list in
linear_use (linear_use acc e1) e2
| Eupdate (_, e1, e2) | Efield_update (_, e1, e2)
| Econcat (e1, e2) ->
linear_use (linear_use acc e1) e2
let mem_reset { p_rhs = e } =
match e.e_desc with
| Ereset_mem (y, _, _) -> [y]
| _ -> []
end
(* data-flow dependences. pre-dependences are discarded *)
module DataFlowDep = Make
(struct
type equation = eq
let read eq = Vars.read true eq
let def = Vars.def
let linear_read eq = Vars.linear_use [] eq.p_rhs
let mem_reset = Vars.mem_reset
let antidep = Vars.antidep
end)
(* all dependences between variables *)
module AllDep = Make
(struct
type equation = eq
let read eq = Vars.read false eq
let linear_read eq = Vars.linear_use [] eq.p_rhs
let mem_reset = Vars.mem_reset
let def = Vars.def
let antidep eq = false
end)
module Printer =
struct
open Format
let is_infix =
let module StrSet = Set.Make(String) in
let set_infix = StrSet.singleton "or" in
fun s ->
if (StrSet.mem s set_infix) then true
else begin
match (String.get s 0) with
| 'a' .. 'z' | 'A' .. 'Z' | '_' | '`' -> false
| _ -> true
end
let rec print_list ff print sep l =
match l with
| [] -> ()
| [x] -> print ff x
| x :: l ->
print ff x;
fprintf ff "%s@ " sep;
print_list ff print sep l
let print_name ff n =
let n = if is_infix n then
match n with
| "*" -> "( * )"
| _ -> "(" ^ n ^ ")"
else n
in fprintf ff "%s" n
let print_longname ff n =
match n with
| Name(m) -> print_name ff m
| Modname({ qual = "Pervasives"; id = m }) ->
print_name ff m
| Modname({ qual = m1; id = m2 }) ->
fprintf ff "%s." m1; print_name ff m2
let print_ident ff id =
fprintf ff "%s" (name id)
let rec print_pat ff = function
| Evarpat(n) -> print_ident ff n
| Etuplepat(pat_list) ->
fprintf ff "@[(";
print_list ff print_pat "," pat_list;
fprintf ff ")@]"
let rec print_base_type ff = function
| Tint -> fprintf ff "int"
| Tfloat -> fprintf ff "float"
| Tid(id) -> print_longname ff id
| Tarray(ty, n) ->
print_base_type ff ty;
fprintf ff "^";
print_size_exp ff n
let rec print_type ff = function
| Tbase(base_ty) -> print_base_type ff base_ty
| Tprod(ty_list) ->
fprintf ff "@[(";
print_list ff print_type " *" ty_list;
fprintf ff ")@]"
let rec print_ck ff = function
| Cbase -> fprintf ff "base"
| Con(ck, c, n) ->
print_ck ff ck; fprintf ff " on ";
print_longname ff c; fprintf ff "(";
print_ident ff n; fprintf ff ")"
| Cvar { contents = Cindex n } -> fprintf ff "base"
| Cvar { contents = Clink ck } -> print_ck ff ck
let rec print_clock ff = function
| Ck(ck) -> print_ck ff ck
| Cprod(ct_list) ->
fprintf ff "@[(";
print_list ff print_clock " *" ct_list;
fprintf ff ")@]"
let print_vd ff { v_name = n; v_type = ty; v_clock = ck } =
fprintf ff "@[<v>";
print_ident ff n;
fprintf ff ":";
print_base_type ff ty;
fprintf ff " at ";
print_ck ff ck;
fprintf ff "@]"
let rec print_c ff = function
| Cint i -> fprintf ff "%d" i
| Cfloat f -> fprintf ff "%f" f
| Cconstr(tag) -> print_longname ff tag
| Cconst_array (n, c) ->
print_c ff c;
fprintf ff "^";
print_size_exp ff n
let print_call_params ff = function
| [] -> ()
| l ->
fprintf ff "<<";
print_list ff print_size_exp "," l;
fprintf ff ">>"
let rec print_exps ff e_list =
fprintf ff "@[(";print_list ff print_exp "," e_list; fprintf ff ")@]"
and print_exp ff e =
if !Misc.full_type_info then fprintf ff "(";
begin match e.e_desc with
| Evar x -> print_ident ff x
| Econstvar x -> print_name ff x
| Econst c -> print_c ff c
| Efby(Some(c), e) ->
print_c ff c; fprintf ff " fby "; print_exp ff e
| Ereset_mem(y,v,res) ->
fprintf ff "@[reset_mem ";
print_ident ff y;
fprintf ff " = ";
print_c ff v;
fprintf ff " every ";
print_ident ff res;
fprintf ff "@]"
| Efby(None, e) ->
fprintf ff "pre "; print_exp ff e
| Eop((Name(m) | Modname { qual = "Pervasives"; id = m }), params, [e1;e2])
when is_infix m ->
fprintf ff "(%a %s %a %a)"
print_exp e1
m
print_call_params params
print_exp e2
| Eop(op, params, e_list) ->
print_longname ff op;
print_call_params ff params;
print_exps ff e_list
| Eapp({ a_op = f }, params, e_list) ->
print_longname ff f;
print_call_params ff params;
print_exps ff e_list
| Eevery({ a_op = f }, params, e_list, x) ->
print_longname ff f;
print_call_params ff params;
print_exps ff e_list;
fprintf ff " every "; print_ident ff x
| Ewhen(e, c, n) ->
fprintf ff "(";
print_exp ff e;
fprintf ff " when ";
print_longname ff c; fprintf ff "(";
print_ident ff n; fprintf ff ")";
fprintf ff ")"
| Eifthenelse(e1, e2, e3) ->
fprintf ff "@[if ";print_exp ff e1;
fprintf ff "@ then ";
print_exp ff e2;
fprintf ff "@ else ";
print_exp ff e3;
fprintf ff "@]"
| Emerge(x, tag_e_list) ->
fprintf ff "@[<hov 2>merge ";print_ident ff x;fprintf ff "@ ";
fprintf ff "@[";
print_tag_e_list ff tag_e_list;
fprintf ff "@]@]"
| Etuple(e_list) ->
fprintf ff "@[(";
print_list ff print_exp "," e_list;
fprintf ff ")@]"
| Efield(e, field) ->
print_exp ff e;
fprintf ff ".";
print_longname ff field
| Estruct(f_e_list) ->
fprintf ff "@[<v 1>{";
print_list ff
(fun ff (field, e) -> print_longname ff field;fprintf ff " = ";
print_exp ff e)
";" f_e_list;
fprintf ff "}@]"
(*Array operators*)
| Earray e_list ->
fprintf ff "@[[";
print_list ff print_exp ";" e_list;
fprintf ff "]@]"
| Erepeat (n,e) ->
print_exp ff e;
fprintf ff "^";
print_size_exp ff n
| Eselect (idx,e) ->
print_exp ff e;
fprintf ff "[";
print_list ff print_size_exp "][" idx;
fprintf ff "]"
| Eselect_dyn (idx, _, e1, e2) ->
fprintf ff "@[";
print_exp ff e1;
fprintf ff "[";
print_list ff print_exp "][" idx;
fprintf ff "] default ";
print_exp ff e2;
fprintf ff "@]"
| Eupdate (idx, e1, e2) ->
fprintf ff "@[";
print_exp ff e1;
fprintf ff " with [";
print_list ff print_size_exp "][" idx;
fprintf ff "] = ";
print_exp ff e2;
fprintf ff "@]"
| Eselect_slice (idx1, idx2, e) ->
print_exp ff e;
fprintf ff "[";
print_size_exp ff idx1;
fprintf ff "..";
print_size_exp ff idx2;
fprintf ff "]"
| Econcat (e1, e2) ->
print_exp ff e1;
fprintf ff " @@ ";
print_exp ff e2
| Eiterator (it, f, params, n, e_list, reset) ->
fprintf ff "(";
fprintf ff "%s" (iterator_to_string it);
fprintf ff " ";
(match params with
| [] -> print_longname ff f
| l ->
fprintf ff "(";
print_longname ff f;
print_call_params ff params;
fprintf ff ")"
);
fprintf ff " <<";
print_size_exp ff n;
fprintf ff ">>) (@[";
print_list ff print_exp "," e_list;
fprintf ff ")@]";
(match reset with
| None -> ()
| Some r -> fprintf ff " every %s" (name r)
)
| Efield_update (f, e1, e2) ->
fprintf ff "@[";
print_exp ff e1;
fprintf ff " with .";
print_longname ff f;
fprintf ff " = ";
print_exp ff e2;
fprintf ff "@]"
end;
if !Misc.full_type_info
then begin
fprintf ff " : %a)" print_type e.e_ty;
if e.e_loc = no_location then fprintf ff " (no loc)"
end
and print_tag_e_list ff tag_e_list =
print_list ff
(fun ff (tag, e) ->
fprintf ff "@[(";
print_longname ff tag;
fprintf ff " -> ";
print_exp ff e;
fprintf ff ")@]@,") ""
tag_e_list
let print_eq ff { p_lhs = p; p_rhs = e } =
fprintf ff "@[<hov 2>";
print_pat ff p;
(* (\* DEBUG *\) *)
(* fprintf ff " : "; *)
(* print_ck ff e.e_ck; *)
(* (\* END DEBUG *\) *)
fprintf ff " =@ ";
print_exp ff e;
if !Misc.full_type_info
then begin fprintf ff "@ at "; print_ck ff e.e_ck end;
fprintf ff ";@]"
let print_eqs ff l =
fprintf ff "@[<v>"; print_list ff print_eq "" l; fprintf ff "@]"
let print_open_module ff name =
fprintf ff "@[open ";
print_name ff name;
fprintf ff "@.@]"
let print_type_def ff { t_name = name; t_desc = tdesc } =
match tdesc with
| Type_abs -> fprintf ff "@[type %s@\n@]" name
| Type_enum(tag_name_list) ->
fprintf ff "@[type %s = " name;
print_list ff print_name "|" tag_name_list;
fprintf ff "@\n@]"
| Type_struct(f_ty_list) ->
fprintf ff "@[type %s = " name;
fprintf ff "@[<v 1>{";
print_list ff
(fun ff (field, ty) -> print_name ff field;
fprintf ff ": ";
print_base_type ff ty) ";" f_ty_list;
fprintf ff "}@]@\n@]"
let print_contract ff {c_local = l;
c_eq = eqs;
c_assume = e_a;
c_enforce = e_g;
c_controllables = cl } =
if l <> [] then begin
fprintf ff "contract\n";
fprintf ff "@[<hov 4>var ";
print_list ff print_vd ";" l;
fprintf ff ";@]\n"
end;
if eqs <> [] then begin
fprintf ff "@[<v 2>let @,";
print_eqs ff eqs;
fprintf ff "@]"; fprintf ff "tel\n"
end;
fprintf ff "assume@ %a@;enforce@ %a with ("
print_exp e_a
print_exp e_g;
print_list ff print_vd ";" cl;
fprintf ff ")"
let print_node_params ff = function
| [] -> ()
| l ->
fprintf ff "<<";
print_list ff print_name "," l;
fprintf ff ">>"
let print_node ff
{ n_name = n;n_input = ni;n_output = no;
n_contract = contract;
n_local = nl; n_equs = ne;
n_params = params; } =
fprintf ff "@[<v 2>node %s" n;
print_node_params ff params;
fprintf ff "(@[";
print_list ff print_vd ";" ni;
fprintf ff "@]) returns (@[";
print_list ff print_vd ";" no;
fprintf ff "@])@,";
optunit (print_contract ff) contract;
if nl <> [] then begin
fprintf ff "@[<hov 2>var ";
print_list ff print_vd ";" nl;
fprintf ff ";@]@,"
end;
fprintf ff "@[<v 2>let @,";
print_eqs ff ne;
fprintf ff "@]@;"; fprintf ff "tel";fprintf ff "@.@]"
let print_exp oc e =
let ff = formatter_of_out_channel oc in
print_exp ff e;
fprintf ff "@."
let print_type oc ty =
let ff = formatter_of_out_channel oc in
print_type ff ty;
fprintf ff "@?"
let print_clock oc ct =
let ff = formatter_of_out_channel oc in
print_clock ff ct;
fprintf ff "@?"
let print oc { p_opened = pm; p_types = pt; p_nodes = pn } =
let ff = formatter_of_out_channel oc in
List.iter (print_open_module ff) pm;
List.iter (print_type_def ff) pt;
List.iter (print_node ff) pn;
fprintf ff "@?"
end