Correct translation for Eupdate and Eupdate_field
As the language is SSA, we should assign each element only once.
This commit is contained in:
parent
c23b9256f0
commit
f57d7f1589
|
@ -31,6 +31,8 @@ let fresh_it () =
|
||||||
id, mk_var_dec id Initial.tint
|
id, mk_var_dec id Initial.tint
|
||||||
|
|
||||||
let gen_obj_ident n = Idents.gen_var "mls2obc" ((shortname n) ^ "_inst")
|
let gen_obj_ident n = Idents.gen_var "mls2obc" ((shortname n) ^ "_inst")
|
||||||
|
let fresh_for = fresh_for "mls2obc"
|
||||||
|
let copy_array = copy_array "mls2obc"
|
||||||
|
|
||||||
let op_from_string op = { qual = Pervasives; name = op; }
|
let op_from_string op = { qual = Pervasives; name = op; }
|
||||||
|
|
||||||
|
@ -81,6 +83,48 @@ let rec bound_check_expr idx_list bounds =
|
||||||
[e; bound_check_expr idx_list bounds]))
|
[e; bound_check_expr idx_list bounds]))
|
||||||
| (_, _) -> internal_error "mls2obc" 3
|
| (_, _) -> internal_error "mls2obc" 3
|
||||||
|
|
||||||
|
(** Creates the action list that copies [src] to [dest],
|
||||||
|
updating the value at index [idx_list] with the value [v]. *)
|
||||||
|
let rec update_array dest src idx_list v = match dest.l_ty, idx_list with
|
||||||
|
| Tarray (t, n), idx::idx_list ->
|
||||||
|
(*Body of the copy loops*)
|
||||||
|
let copy i =
|
||||||
|
let src_i = mk_pattern_exp t (Larray (src, i)) in
|
||||||
|
let dest_i = mk_pattern t (Larray (dest, i)) in
|
||||||
|
[Aassgn(dest_i, src_i)]
|
||||||
|
in
|
||||||
|
|
||||||
|
(*Copy values < idx*)
|
||||||
|
let a_lower = fresh_for (mk_static_int 0) idx copy in
|
||||||
|
|
||||||
|
(* Update the correct element*)
|
||||||
|
let src_idx = mk_pattern_exp t (Larray (src, idx)) in
|
||||||
|
let dest_idx = mk_pattern t (Larray (dest, idx)) in
|
||||||
|
let a_update = update_array dest_idx src_idx v idx_list in
|
||||||
|
|
||||||
|
(*Copy values > idx*)
|
||||||
|
let idx_plus_one = mk_static_int_op (mk_pervasives "+") [idx; mk_static_int 1] in
|
||||||
|
let a_upper = fresh_for idx_plus_one n copy in
|
||||||
|
[a_lower] @ a_update @ [a_upper]
|
||||||
|
|
||||||
|
| _, _ ->
|
||||||
|
[Aassgn(dest, v)]
|
||||||
|
|
||||||
|
(** Creates the action list that copies [src] to [dest],
|
||||||
|
updating the value of field [f] with the value [v]. *)
|
||||||
|
let update_record dest src f v =
|
||||||
|
let assgn_act { f_name = l; f_type = ty } =
|
||||||
|
let dest_l = mk_pattern ty (Lfield(dest, l)) in
|
||||||
|
let src_l = mk_pattern_exp ty (Lfield(src, l)) in
|
||||||
|
if f = l then
|
||||||
|
Aassgn(dest_l, v)
|
||||||
|
else
|
||||||
|
Aassgn(dest_l, src_l)
|
||||||
|
in
|
||||||
|
let n = struct_name dest.l_ty in
|
||||||
|
let fields = find_struct n in
|
||||||
|
List.map assgn_act fields
|
||||||
|
|
||||||
let rec control map ck s =
|
let rec control map ck s =
|
||||||
match ck with
|
match ck with
|
||||||
| Cbase | Cvar { contents = Cindex _ } -> s
|
| Cbase | Cvar { contents = Cindex _ } -> s
|
||||||
|
@ -233,7 +277,7 @@ and translate_act map pat
|
||||||
let true_act = Aassgn (x, mk_exp p.pat_ty (Epattern p)) in
|
let true_act = Aassgn (x, mk_exp p.pat_ty (Epattern p)) in
|
||||||
let false_act = Aassgn (x, translate_extvalue map e2) in
|
let false_act = Aassgn (x, translate_extvalue map e2) in
|
||||||
let cond = bound_check_expr idx bounds in
|
let cond = bound_check_expr idx bounds in
|
||||||
[ Acase (cond, [ ptrue, mk_block [true_act]; pfalse, mk_block [false_act] ]) ]
|
[ mk_ifthenelse cond true_act false_act ]
|
||||||
|
|
||||||
| Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eselect_trunc }, e1::idx, _) ->
|
| Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eselect_trunc }, e1::idx, _) ->
|
||||||
let x = var_from_name map x in
|
let x = var_from_name map x in
|
||||||
|
@ -245,25 +289,18 @@ and translate_act map pat
|
||||||
|
|
||||||
| Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eupdate }, e1::e2::idx, _) ->
|
| Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eupdate }, e1::e2::idx, _) ->
|
||||||
let x = var_from_name map x in
|
let x = var_from_name map x in
|
||||||
(** TODO: remplacer par if 0 < e && e < n then for () ; o[e] = v; for () else o = a *)
|
|
||||||
let bounds = Mls_utils.bounds_list e1.Minils.e_ty in
|
let bounds = Mls_utils.bounds_list e1.Minils.e_ty in
|
||||||
let idx = List.map (translate_extvalue map) idx in
|
let idx = List.map (translate_extvalue map) idx in
|
||||||
let action = Aassgn (pattern_of_idx_list x idx,
|
|
||||||
translate_extvalue map e2) in
|
|
||||||
let cond = bound_check_expr idx bounds in
|
let cond = bound_check_expr idx bounds in
|
||||||
let action = Acase (cond, [ ptrue, mk_block [action] ]) in
|
let true_act = update_array x e1 e2 idx in
|
||||||
let copy = Aassgn (x, translate_extvalue map e1) in
|
let false_act = Aassgn (x, e1) in
|
||||||
[copy; action]
|
[ mk_ifthenelse cond true_act false_act ]
|
||||||
|
|
||||||
(** TODO: remplacer par o = { f = v; g = a.g; h = a.h; ... } *)
|
|
||||||
| Minils.Evarpat x,
|
| Minils.Evarpat x,
|
||||||
Minils.Eapp ({ Minils.a_op = Minils.Efield_update;
|
Minils.Eapp ({ Minils.a_op = Minils.Efield_update;
|
||||||
Minils.a_params = [{ se_desc = Sfield f }] }, [e1; e2], _) ->
|
Minils.a_params = [{ se_desc = Sfield f }] }, [e1; e2], _) ->
|
||||||
let x = var_from_name map x in
|
let x = var_from_name map x in
|
||||||
let copy = Aassgn (x, translate_extvalue map e1) in
|
update_record x e1 f e2
|
||||||
let action = Aassgn (mk_pattern x.pat_ty (Lfield (x, f)),
|
|
||||||
translate_extvalue map e2) in (* TODO wrong type *)
|
|
||||||
[copy; action]
|
|
||||||
|
|
||||||
| Minils.Evarpat n, _ ->
|
| Minils.Evarpat n, _ ->
|
||||||
[Aassgn (var_from_name map n, translate map act)]
|
[Aassgn (var_from_name map n, translate map act)]
|
||||||
|
|
|
@ -48,6 +48,9 @@ let mk_block ?(locals=[]) eq_list =
|
||||||
{ b_locals = locals;
|
{ b_locals = locals;
|
||||||
b_body = eq_list }
|
b_body = eq_list }
|
||||||
|
|
||||||
|
let mk_ifthenelse cond true_act false_act =
|
||||||
|
Acase (cond, [ ptrue, mk_block [true_act]; pfalse, mk_block [false_act] ])
|
||||||
|
|
||||||
let rec var_name x =
|
let rec var_name x =
|
||||||
match x.pat_desc with
|
match x.pat_desc with
|
||||||
| Lvar x -> x
|
| Lvar x -> x
|
||||||
|
@ -166,3 +169,23 @@ struct
|
||||||
let (_, deps) = Obc_mapfold.program funs ModulSet.empty p in
|
let (_, deps) = Obc_mapfold.program funs ModulSet.empty p in
|
||||||
ModulSet.remove p.p_modname deps
|
ModulSet.remove p.p_modname deps
|
||||||
end
|
end
|
||||||
|
|
||||||
|
(** 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))
|
||||||
|
|
||||||
|
(** 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)
|
||||||
|
|
|
@ -17,14 +17,7 @@ open Obc
|
||||||
open Obc_utils
|
open Obc_utils
|
||||||
open Obc_mapfold
|
open Obc_mapfold
|
||||||
|
|
||||||
|
let fresh_for = fresh_for "scalarize"
|
||||||
(** fresh Afor from 0 to [size] with [body] a function from [var_ident] (the iterator) to [act] list *)
|
|
||||||
let fresh_for size body =
|
|
||||||
let i = Idents.gen_var "scalarize" "i" in
|
|
||||||
let id = mk_var_dec i Initial.tint in
|
|
||||||
let ei = mk_evar_int i in
|
|
||||||
Afor (id, Initial.mk_static_int 0, size, mk_block (body ei))
|
|
||||||
|
|
||||||
|
|
||||||
let act funs () a = match a with
|
let act funs () a = match a with
|
||||||
| Aassgn (p,e) ->
|
| Aassgn (p,e) ->
|
||||||
|
|
Loading…
Reference in New Issue