jeltz/heptagon
1
0
Fork 0
Code Issues Pull requests Releases Activity

Fixed refactoring errors.

Browse source
This commit is contained in:
Adrien Guatto 2010-07-02 15:38:11 +02:00
parent eaafc5db05
commit 5a6a3c74ac
8 changed files with 46 additions and 45 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
compiler/global/signature.ml
View file

@ -26,7 +26,7 @@ type node =
node_outputs : arg list;
node_statefull : bool;
node_params : param list; (** Static parameters *)
node_params_constraints : size_constr list }
node_params_constraints : size_constraint list }
type field = { f_name : name; f_type : ty }
type structure = field list

34
compiler/global/static.ml
View file

@ -17,15 +17,15 @@
open Names
open Format
type op = | SPlus | SMinus | STimes | SDiv
type op = | Splus | Sminus | Stimes | Sdiv
type size_exp =
| SConst of int | SVar of name | SOp of op * size_exp * size_exp
| SConst of int | Svar of name | Sop of op * size_exp * size_exp
(** Constraints on size expressions. *)
type size_constraint =
| Cequal of static_exp * static_exp (* e1 = e2*)
| Clequal of static_exp * static_exp (* e1 <= e2 *)
| Cequal of size_exp * size_exp (* e1 = e2*)
| Clequal of size_exp * size_exp (* e1 <= e2 *)
| Cfalse
(* unsatisfiable constraint *)
@ -36,10 +36,10 @@ exception Not_static
(** Returns the op from an operator full name. *)
let op_from_app_name n =
match n with
| Modname { qual = "Pervasives"; id = "+" } | Name "+" -> SPlus
| Modname { qual = "Pervasives"; id = "-" } | Name "-" -> SMinus
| Modname { qual = "Pervasives"; id = "*" } | Name "*" -> STimes
| Modname { qual = "Pervasives"; id = "/" } | Name "/" -> SDiv
| Modname { qual = "Pervasives"; id = "+" } | Name "+" -> Splus
| Modname { qual = "Pervasives"; id = "-" } | Name "-" -> Sminus
| Modname { qual = "Pervasives"; id = "*" } | Name "*" -> Stimes
| Modname { qual = "Pervasives"; id = "/" } | Name "/" -> Sdiv
| _ -> raise Not_static
(** [simplify env e] returns e simplified with the
@ -58,10 +58,10 @@ let rec simplify env =
| (SConst n1, SConst n2) ->
let n =
(match op with
| SPlus -> n1 + n2
| SMinus -> n1 - n2
| STimes -> n1 * n2
| SDiv ->
| Splus -> n1 + n2
| Sminus -> n1 - n2
| Stimes -> n1 * n2
| Sdiv ->
if n2 = 0 then raise Instanciation_failed else n1 / n2)
in SConst n
| (_, _) -> Sop (op, e1, e2))
@ -96,7 +96,7 @@ let is_true env =
| (_, _) -> (None, (Clequal (e1, e2))))
| Cfalse -> (None, Cfalse)
exception Solve_failed of size_constr
exception Solve_failed of size_constraint
(** [solve env constr_list solves a list of constraints. It
removes equations that can be decided and simplify others.
@ -130,7 +130,7 @@ let instanciate_constr m constr =
in List.map (replace_one m) constr
let op_to_string =
function | SPlus -> "+" | SMinus -> "-" | STimes -> "*" | SDiv -> "/"
function | Splus -> "+" | Sminus -> "-" | Stimes -> "*" | Sdiv -> "/"
let rec print_size_exp ff =
function
@ -140,14 +140,14 @@ let rec print_size_exp ff =
fprintf ff "@[(%a %s %a)@]"
print_size_exp e1 (op_to_string op) print_size_exp e2
let print_size_constr ff = function
let print_size_constraint ff = function
| Cequal (e1, e2) ->
fprintf ff "@[%a = %a@]" print_size_exp e1 print_size_exp e2
| Clequal (e1, e2) ->
fprintf ff "@[%a <= %a@]" print_size_exp e1 print_size_exp e2
| Cfalse -> fprintf ff "False"
let psize_constr oc c =
let psize_constraint oc c =
let ff = formatter_of_out_channel oc
in (print_size_constr ff c; fprintf ff "@?")
in (print_size_constraint ff c; fprintf ff "@?")

2
compiler/heptagon/analysis/interface.ml
View file

@ -92,7 +92,7 @@ struct
| [] -> ()
| constr ->
fprintf ff "\n with: @[";
print_list_r Static.print_size_constr "" "," "" ff constr;
print_list_r Static.print_size_constraint "" "," "" ff constr;
fprintf ff "@]"
);
fprintf ff "@.@]"

44
compiler/heptagon/analysis/typing.ml
View file

@ -41,7 +41,7 @@ type error =
| Esubscripted_value_not_an_array of ty
| Earray_subscript_should_be_const
| Eundefined_const of name
| Econstraint_solve_failed of size_constr
| Econstraint_solve_failed of size_constraint
| Etype_should_be_static of ty
| Erecord_type_expected of ty
| Eno_such_field of ty * longname
@ -132,7 +132,7 @@ let message loc kind =
Printf.eprintf
"%aThe following constraint cannot be satisified:\n %a.\n"
output_location loc
psize_constr c
psize_constraint c
| Etype_should_be_static ty ->
Printf.eprintf
"%aThis type should be static : %a.\n"
@ -178,12 +178,12 @@ let find_field c =
let find_struct c =
try find_struct c with Not_found -> error (Eundefined(fullname c))
let (curr_size_constr : size_constr list ref) = ref []
let add_size_constr c =
curr_size_constr := c::(!curr_size_constr)
let get_size_constr () =
let l = !curr_size_constr in
curr_size_constr := [];
let (curr_size_constraint : size_constr list ref) = ref []
let add_size_constraint c =
curr_size_constraint := c::(!curr_size_constr)
let get_size_constraint () =
let l = !curr_size_constraint in
curr_size_constraint := [];
l
let get_number_of_fields ty =
@ -215,7 +215,7 @@ let rec unify t1 t2 =
_ -> raise Unify
)
| Tarray (ty1, e1), Tarray (ty2, e2) ->
add_size_constr (Cequal(e1,e2));
add_size_constraint (Cequal(e1,e2));
unify ty1 ty2
| _ -> raise Unify
@ -573,10 +573,10 @@ and typing_app statefull h op e_list =
params in
let expected_ty_list = List.map (subst_type_vars m) expected_ty_list in
let typed_e_list = typing_args statefull h expected_ty_list e_list in
let size_constrs =
let size_constraints =
instanciate_constr m ty_desc.node_params_constraints in
let result_ty_list = List.map (subst_type_vars m) result_ty_list in
List.iter add_size_constr size_constrs;
List.iter add_size_constraint size_constrs;
(prod result_ty_list,
Ecall ( { op_desc with op_name = Modname q; op_kind = k }, reset),
typed_e_list)
@ -607,7 +607,7 @@ and typing_array_op statefull h op e_list =
let typed_e2 = expect statefull h (Tid Initial.pint) e2 in
let e2 = size_exp_of_exp e2 in
let typed_e1, t1 = typing statefull h e1 in
add_size_constr (Clequal (SConst 1, e2));
add_size_constraint (Clequal (SConst 1, e2));
Tarray (t1, e2), op, [typed_e1; typed_e2]
| Eselect idx_list, [e1] ->
let typed_e1, t1 = typing statefull h e1 in
@ -628,9 +628,9 @@ and typing_array_op statefull h op e_list =
let typed_idx2 = expect statefull h (Tid Initial.pint) idx2 in
let typed_e, t1 = typing statefull h e in
(*Create the expression to compute the size of the array *)
let e1 = Sop (SMinus, size_exp_of_exp idx2, size_exp_of_exp idx1) in
let e2 = Sop (SPlus, e1, SConst 1) in
add_size_constr (Clequal (SConst 1, e2));
let e1 = Sop (Sminus, size_exp_of_exp idx2, size_exp_of_exp idx1) in
let e2 = Sop (Splus, e1, SConst 1) in
add_size_constraint (Clequal (SConst 1, e2));
Tarray (element_type t1, e2), op, [typed_e; typed_idx1; typed_idx2]
| Econcat, [e1; e2] ->
let typed_e1, t1 = typing statefull h e1 in
@ -640,7 +640,7 @@ and typing_array_op statefull h op e_list =
with
TypingError(kind) -> message e1.e_loc kind
end;
let n = Sop (SPlus, size_exp t1, size_exp t2) in
let n = Sop (Splus, size_exp t1, size_exp t2) in
Tarray (element_type t1, n), op, [typed_e1; typed_e2]
| Eiterator (it, ({ op_name = f; op_params = params;
op_kind = k } as op_desc), reset),
@ -651,15 +651,15 @@ and typing_array_op statefull h op e_list =
let m = List.combine (List.map (fun p -> p.p_name) ty_desc.node_params)
params in
let expected_ty_list = List.map (subst_type_vars m) expected_ty_list in
let size_constrs =
let size_constraints =
instanciate_constr m ty_desc.node_params_constraints in
let result_ty_list = List.map (subst_type_vars m) result_ty_list in
let typed_e = expect statefull h (Tid Initial.pint) e in
let e = size_exp_of_exp e in
let ty, typed_e_list = typing_iterator statefull h it e
expected_ty_list result_ty_list e_list in
add_size_constr (Clequal (SConst 1, e));
List.iter add_size_constr size_constrs;
add_size_constraint (Clequal (SConst 1, e));
List.iter add_size_constraint size_constrs;
ty, Eiterator(it, { op_desc with op_name = f; op_kind = k }, reset),
typed_e::typed_e_list
@ -718,8 +718,8 @@ and typing_array_subscript statefull h idx_list ty =
match ty, idx_list with
| ty, [] -> ty
| Tarray(ty, exp), idx::idx_list ->
add_size_constr (Clequal (SConst 0, idx));
add_size_constr (Clequal (idx, Sop(SMinus, exp, SConst 1)));
add_size_constraint (Clequal (SConst 0, idx));
add_size_constraint (Clequal (idx, Sop(Sminus, exp, SConst 1)));
typing_array_subscript statefull h idx_list ty
| _, _ -> error (Esubscripted_value_not_an_array ty)
@ -980,7 +980,7 @@ let node const_env ({ n_name = f; n_statefull = statefull;
included_env expected_names defined_names;
included_env defined_names expected_names;
let cl = get_size_constr () in
let cl = get_size_constraint () in
let cl = solve loc const_env cl in
add_value f (signature const_env statefull i_list o_list node_params cl);

2
compiler/heptagon/heptagon.ml
View file

@ -124,7 +124,7 @@ type node_dec = {
n_output : var_dec list; n_local : var_dec list;
n_contract : contract option; n_equs : eq list; n_loc : location;
n_params : param list;
n_params_constraints : size_constr list
n_params_constraints : size_constraint list
}
type const_dec = {

2
compiler/minils/minils.ml
View file

@ -124,7 +124,7 @@ type node_dec =
n_equs : eq list;
n_loc : location;
n_params : param list;
n_params_constraints : size_constr list;
n_params_constraints : size_constraint list;
n_params_instances : (int list) list; }(*TODO commenter ou passer en env*)
type const_dec =

3
compiler/minils/sequential/cmain.ml
View file

@ -234,7 +234,8 @@ let main_skel var_list prologue body =
Cbop ("+",
Clhs (Cvar (name step_counter)),
Cconst (Ccint 1)))
:: body)
:: body);
Creturn (Cconst (Cint 0));
];
}
}

2
compiler/minils/sequential/mls2obc.ml
View file

@ -81,7 +81,7 @@ let rec translate const_env map (m, si, j, s)
match desc with
| Minils.Econst v -> Const (translate_const const_env v)
| Minils.Evar n -> Lhs (var_from_name map n)
| Minils.Econstvar n -> Const (Cint (int_of_size_exp const_env (SVar n)))
| Minils.Econstvar n -> Const (Cint (int_of_size_exp const_env (Svar n)))
| Minils.Ecall ({ Minils.op_name = n; Minils.op_kind = Minils.Efun },
e_list, _) when Mls_utils.is_op n ->
Op (n, List.map (translate const_env map (m, si, j, s)) e_list)