2010-07-27 12:28:51 +02:00
|
|
|
(**************************************************************************)
|
|
|
|
(* *)
|
|
|
|
(* Heptagon *)
|
|
|
|
(* *)
|
|
|
|
(* Author : Marc Pouzet *)
|
|
|
|
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
|
|
|
|
(* *)
|
|
|
|
(**************************************************************************)
|
|
|
|
|
|
|
|
open Names
|
2011-02-14 15:21:57 +01:00
|
|
|
open Idents
|
|
|
|
open Location
|
2010-07-27 12:28:51 +02:00
|
|
|
open Misc
|
|
|
|
open Types
|
2011-04-26 18:02:18 +02:00
|
|
|
open Linearity
|
2010-07-27 12:28:51 +02:00
|
|
|
open Obc
|
|
|
|
open Obc_mapfold
|
|
|
|
open Global_mapfold
|
|
|
|
|
2011-11-17 15:22:28 +01:00
|
|
|
let mk_var_dec ?(loc=no_location) ?(linearity = Ltop) ?(mut=false) ?(alias=false) ident ty =
|
|
|
|
{ v_ident = ident; v_type = ty; v_linearity = linearity;
|
|
|
|
v_alias = alias; v_mutable = mut; v_loc = loc }
|
2011-02-14 15:21:57 +01:00
|
|
|
|
2011-05-30 10:06:16 +02:00
|
|
|
let mk_ext_value ?(loc=no_location) ty desc =
|
|
|
|
{ w_desc = desc; w_ty = ty; w_loc = loc; }
|
|
|
|
|
|
|
|
let mk_ext_value_int ?(loc=no_location) desc =
|
|
|
|
mk_ext_value ~loc:loc Initial.tint desc
|
|
|
|
|
|
|
|
let mk_ext_value_bool ?(loc=no_location) desc =
|
|
|
|
mk_ext_value ~loc:loc Initial.tbool desc
|
|
|
|
|
2011-02-14 15:21:57 +01:00
|
|
|
let mk_exp ?(loc=no_location) ty desc =
|
|
|
|
{ e_desc = desc; e_ty = ty; e_loc = loc }
|
|
|
|
|
|
|
|
let mk_exp_int ?(loc=no_location) desc =
|
2011-05-30 10:06:16 +02:00
|
|
|
mk_exp ~loc:loc Initial.tint desc
|
2011-02-14 15:21:57 +01:00
|
|
|
|
2011-04-18 15:38:42 +02:00
|
|
|
let mk_exp_static_int ?(loc=no_location) se =
|
2011-05-30 10:06:16 +02:00
|
|
|
mk_exp_int ~loc:loc (Eextvalue (mk_ext_value_int (Wconst se)))
|
2011-04-18 15:38:42 +02:00
|
|
|
|
|
|
|
let mk_exp_const_int ?(loc=no_location) i =
|
2011-05-30 10:06:16 +02:00
|
|
|
mk_exp_static_int ~loc:loc (Initial.mk_static_int i)
|
2011-04-18 15:38:42 +02:00
|
|
|
|
2011-02-14 15:21:57 +01:00
|
|
|
let mk_exp_bool ?(loc=no_location) desc =
|
|
|
|
{ e_desc = desc; e_ty = Initial.tbool; e_loc = loc }
|
|
|
|
|
|
|
|
let mk_pattern ?(loc=no_location) ty desc =
|
|
|
|
{ pat_desc = desc; pat_ty = ty; pat_loc = loc }
|
|
|
|
|
|
|
|
let mk_pattern_int ?(loc=no_location) desc =
|
|
|
|
{ pat_desc = desc; pat_ty = Initial.tint; pat_loc = loc }
|
|
|
|
|
2011-05-30 10:06:16 +02:00
|
|
|
let mk_ext_value_exp ty desc =
|
|
|
|
let w = mk_ext_value ty desc in
|
|
|
|
mk_exp ty (Eextvalue w)
|
|
|
|
|
|
|
|
let mk_ext_value_exp_int desc = mk_ext_value_exp Initial.tint desc
|
|
|
|
|
|
|
|
let mk_ext_value_exp_bool desc = mk_ext_value_exp Initial.tbool desc
|
|
|
|
|
|
|
|
let mk_ext_value_static ty sed = mk_ext_value_exp ty (Wconst sed)
|
2011-02-14 15:21:57 +01:00
|
|
|
|
|
|
|
let mk_evar ty id =
|
2011-05-30 10:06:16 +02:00
|
|
|
mk_ext_value_exp ty (Wvar id)
|
2011-02-14 15:21:57 +01:00
|
|
|
|
|
|
|
let mk_evar_int id =
|
2011-05-30 10:06:16 +02:00
|
|
|
mk_evar Initial.tint id
|
2011-02-14 15:21:57 +01:00
|
|
|
|
|
|
|
let mk_block ?(locals=[]) eq_list =
|
|
|
|
{ b_locals = locals;
|
|
|
|
b_body = eq_list }
|
|
|
|
|
2011-04-14 15:14:41 +02:00
|
|
|
let mk_ifthenelse cond true_act false_act =
|
2011-04-18 15:38:42 +02:00
|
|
|
Acase (cond, [ Initial.ptrue, mk_block true_act; Initial.pfalse, mk_block false_act ])
|
2011-04-14 15:14:41 +02:00
|
|
|
|
2011-11-21 01:37:15 +01:00
|
|
|
let mk_if cond true_act =
|
|
|
|
Acase (cond, [Initial.ptrue, mk_block true_act])
|
|
|
|
|
2011-02-14 15:21:57 +01:00
|
|
|
let rec var_name x =
|
|
|
|
match x.pat_desc with
|
|
|
|
| Lvar x -> x
|
|
|
|
| Lmem x -> x
|
|
|
|
| Lfield(x,_) -> var_name x
|
|
|
|
| Larray(l, _) -> var_name 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_ident = n or (vd_mem n l)
|
|
|
|
|
|
|
|
(** Returns the var_dec object corresponding to the name n
|
|
|
|
in a list of var_dec. *)
|
|
|
|
let rec vd_find n = function
|
|
|
|
| [] -> Format.eprintf "Not found var %s@." (name n); raise Not_found
|
|
|
|
| vd::l ->
|
|
|
|
if vd.v_ident = n then vd else vd_find n l
|
|
|
|
|
|
|
|
(** Returns the type of a [var_dec list] *)
|
|
|
|
let vd_list_to_type vd_l = match vd_l with
|
|
|
|
| [vd] -> vd.v_type
|
|
|
|
| _ -> Tprod (List.map (fun vd -> vd.v_type) vd_l)
|
|
|
|
|
|
|
|
let pattern_list_to_type p_l = match p_l with
|
|
|
|
| [p] -> p.pat_ty
|
|
|
|
| _ -> Tprod (List.map (fun p -> p.pat_ty) p_l)
|
|
|
|
|
2011-05-30 10:06:16 +02:00
|
|
|
let ext_value_of_exp e = match e.e_desc with
|
|
|
|
| Eextvalue w -> w
|
2011-02-14 15:21:57 +01:00
|
|
|
| _ -> assert false
|
|
|
|
|
|
|
|
let find_step_method cd =
|
|
|
|
List.find (fun m -> m.m_name = Mstep) cd.cd_methods
|
|
|
|
let find_reset_method cd =
|
|
|
|
List.find (fun m -> m.m_name = Mreset) cd.cd_methods
|
|
|
|
|
2011-04-27 08:26:40 +02:00
|
|
|
let replace_step_method st cd =
|
|
|
|
let f md = if md.m_name = Mstep then st else md in
|
|
|
|
{ cd with cd_methods = List.map f cd.cd_methods }
|
|
|
|
|
2011-02-14 15:21:57 +01:00
|
|
|
let obj_ref_name o =
|
|
|
|
match o with
|
|
|
|
| Oobj obj
|
|
|
|
| Oarray (obj, _) -> obj
|
|
|
|
|
2011-04-26 18:36:00 +02:00
|
|
|
let rec find_obj o j = match j with
|
|
|
|
| [] -> assert false
|
|
|
|
| obj::j ->
|
|
|
|
if o = obj.o_ident then
|
|
|
|
Modules.find_value obj.o_class
|
|
|
|
else
|
|
|
|
find_obj o j
|
|
|
|
|
2011-02-14 15:21:57 +01:00
|
|
|
(** Input a block [b] and remove all calls to [Reset] method from it *)
|
|
|
|
let remove_resets b =
|
2011-05-30 10:06:16 +02:00
|
|
|
let block funs () b =
|
|
|
|
let b, () = Obc_mapfold.block funs () b in
|
2011-02-14 15:21:57 +01:00
|
|
|
let is_not_reset a = match a with
|
|
|
|
| Acall( _,_,Mreset,_) -> false
|
|
|
|
| _ -> true
|
|
|
|
in
|
|
|
|
let b = { b with b_body = List.filter is_not_reset b.b_body } in
|
|
|
|
b, ()
|
|
|
|
in
|
|
|
|
let funs = { Obc_mapfold.defaults with block = block } in
|
|
|
|
let b,_ = block_it funs () b in
|
|
|
|
b
|
|
|
|
|
|
|
|
|
2010-07-27 12:28:51 +02:00
|
|
|
module Deps =
|
|
|
|
struct
|
2010-09-09 00:35:06 +02:00
|
|
|
|
2011-03-08 09:22:02 +01:00
|
|
|
let deps_longname deps qn = match qn.qual with
|
|
|
|
| Module _ | QualModule _ -> ModulSet.add qn.qual deps
|
|
|
|
| _ -> deps
|
2010-07-27 12:28:51 +02:00
|
|
|
|
2011-09-06 11:54:03 +02:00
|
|
|
let deps_ty funs deps ty = match ty with
|
|
|
|
| Tid ln -> ty, deps_longname deps ln
|
|
|
|
| _ -> raise Errors.Fallback
|
|
|
|
|
2010-07-27 12:28:51 +02:00
|
|
|
let deps_static_exp_desc funs deps sedesc =
|
|
|
|
let (sedesc, deps) = Global_mapfold.static_exp_desc funs deps sedesc in
|
|
|
|
match sedesc with
|
|
|
|
| Svar ln -> (sedesc, deps_longname deps ln)
|
|
|
|
| Sconstructor ln -> (sedesc, deps_longname deps ln)
|
|
|
|
| Srecord fnel ->
|
|
|
|
let add deps (ln, _) = deps_longname deps ln in
|
|
|
|
(sedesc, List.fold_left add deps fnel)
|
|
|
|
| Sop (ln, _) -> (sedesc, deps_longname deps ln)
|
2010-09-15 09:38:52 +02:00
|
|
|
| _ -> raise Errors.Fallback
|
2010-07-27 12:28:51 +02:00
|
|
|
|
|
|
|
let deps_lhsdesc funs deps ldesc =
|
|
|
|
let (ldesc, deps) = Obc_mapfold.lhsdesc funs deps ldesc in
|
|
|
|
match ldesc with
|
|
|
|
| Lfield (_, ln) -> (ldesc, deps_longname deps ln)
|
2010-09-15 09:38:52 +02:00
|
|
|
| _ -> raise Errors.Fallback
|
2010-07-27 12:28:51 +02:00
|
|
|
|
|
|
|
let deps_edesc funs deps edesc =
|
|
|
|
let (edesc, deps) = Obc_mapfold.edesc funs deps edesc in
|
|
|
|
match edesc with
|
|
|
|
| Eop (ln, _) -> (edesc, deps_longname deps ln)
|
|
|
|
| Estruct (ln, fnel) ->
|
|
|
|
let add deps (ln, _) = deps_longname deps ln in
|
|
|
|
(edesc, List.fold_left add (deps_longname deps ln) fnel)
|
2010-09-15 09:38:52 +02:00
|
|
|
| _ -> raise Errors.Fallback
|
2010-07-27 12:28:51 +02:00
|
|
|
|
|
|
|
let deps_act funs deps act =
|
|
|
|
let (act, deps) = Obc_mapfold.act funs deps act in
|
|
|
|
match act with
|
|
|
|
| Acase (_, cbl) ->
|
|
|
|
let add deps (ln, _) = deps_longname deps ln in
|
|
|
|
(act, List.fold_left add deps cbl)
|
2010-09-15 09:38:52 +02:00
|
|
|
| _ -> raise Errors.Fallback
|
2010-07-27 12:28:51 +02:00
|
|
|
|
|
|
|
let deps_obj_dec funs deps od =
|
|
|
|
let (od, deps) = Obc_mapfold.obj_dec funs deps od in
|
|
|
|
(od, deps_longname deps od.o_class)
|
|
|
|
|
|
|
|
let deps_program p =
|
|
|
|
let funs = { Obc_mapfold.defaults with
|
|
|
|
global_funs = { Global_mapfold.defaults with
|
2011-09-06 11:54:03 +02:00
|
|
|
static_exp_desc = deps_static_exp_desc;
|
|
|
|
ty = deps_ty };
|
2010-07-27 12:28:51 +02:00
|
|
|
lhsdesc = deps_lhsdesc;
|
|
|
|
edesc = deps_edesc;
|
|
|
|
act = deps_act;
|
|
|
|
obj_dec = deps_obj_dec;
|
|
|
|
} in
|
2011-03-08 09:22:02 +01:00
|
|
|
let (_, deps) = Obc_mapfold.program funs ModulSet.empty p in
|
|
|
|
ModulSet.remove p.p_modname deps
|
2011-09-06 11:54:03 +02:00
|
|
|
|
|
|
|
let deps_interface i =
|
|
|
|
let funs = { Obc_mapfold.defaults with
|
|
|
|
global_funs = { Global_mapfold.defaults with
|
|
|
|
static_exp_desc = deps_static_exp_desc;
|
|
|
|
ty = deps_ty };
|
|
|
|
} in
|
|
|
|
let (_, deps) = Obc_mapfold.interface funs ModulSet.empty i in
|
|
|
|
ModulSet.remove i.i_modname deps
|
2010-09-15 09:38:52 +02:00
|
|
|
end
|
2011-04-14 15:14:41 +02:00
|
|
|
|
|
|
|
(** Creates a new for loop. Expects the size of the iteration
|
|
|
|
and the body as a function of the variable iterating. *)
|
|
|
|
let fresh_for pass down up body =
|
|
|
|
let i = Idents.gen_var pass "i" in
|
|
|
|
let id = mk_var_dec i Initial.tint in
|
|
|
|
let ei = mk_evar_int i in
|
|
|
|
Afor (id, down, up, mk_block (body ei))
|
|
|
|
|
2011-04-14 18:06:54 +02:00
|
|
|
(*
|
2011-04-14 15:14:41 +02:00
|
|
|
(** Creates the action copying [src] to [dest].*)
|
|
|
|
let rec copy_array pass dest src = match dest.l_ty with
|
|
|
|
| Tarray (t, n) ->
|
|
|
|
let copy i =
|
|
|
|
let src_i = mk_pattern_exp t (Larray (src, i)) in
|
|
|
|
let dest_i = mk_pattern t (Larray (dest, i)) in
|
|
|
|
[copy_array dest_i src_i]
|
|
|
|
in
|
|
|
|
fresh_for pass (mk_static_int 0) n copy
|
|
|
|
| _ ->
|
|
|
|
Aassgn(dest, Epattern src)
|
2011-04-18 15:38:42 +02:00
|
|
|
*)
|
2011-04-19 09:23:52 +02:00
|
|
|
|
|
|
|
let program_types p =
|
2011-04-19 13:08:35 +02:00
|
|
|
let add_type pd acc = match pd with
|
2011-04-19 09:23:52 +02:00
|
|
|
| Ptype ty -> ty :: acc
|
|
|
|
| _ -> acc
|
|
|
|
in
|
2011-04-19 13:08:35 +02:00
|
|
|
List.fold_right add_type p.p_desc []
|
2011-04-19 09:23:52 +02:00
|
|
|
|
|
|
|
let program_classes p =
|
2011-04-19 13:08:35 +02:00
|
|
|
let add_class pd acc = match pd with
|
2011-04-19 09:23:52 +02:00
|
|
|
| Pclass cd -> cd :: acc
|
|
|
|
| _ -> acc
|
|
|
|
in
|
2011-04-19 13:08:35 +02:00
|
|
|
List.fold_right add_class p.p_desc []
|
2011-05-30 10:06:16 +02:00
|
|
|
|
2011-09-06 11:54:03 +02:00
|
|
|
let interface_types i =
|
|
|
|
let add_type id acc = match id with
|
|
|
|
| Itypedef ty -> ty :: acc
|
|
|
|
| _ -> acc
|
|
|
|
in
|
|
|
|
List.fold_right add_type i.i_desc []
|
|
|
|
|
2011-05-30 10:06:16 +02:00
|
|
|
let rec ext_value_of_pattern patt =
|
|
|
|
let desc = match patt.pat_desc with
|
|
|
|
| Lvar id -> Wvar id
|
|
|
|
| Lmem id -> Wmem id
|
|
|
|
| Lfield (p, fn) -> Wfield (ext_value_of_pattern p, fn)
|
|
|
|
| Larray (p, e) -> Warray (ext_value_of_pattern p, e) in
|
|
|
|
mk_ext_value ~loc:patt.pat_loc patt.pat_ty desc
|
|
|
|
|
|
|
|
let rec exp_of_pattern patt =
|
|
|
|
let w = ext_value_of_pattern patt in
|
|
|
|
mk_exp w.w_ty (Eextvalue w)
|