diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index 994211f..e4f7d6e 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -31,6 +31,8 @@ let fresh_it () = id, mk_var_dec id Initial.tint 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; } @@ -81,6 +83,48 @@ let rec bound_check_expr idx_list bounds = [e; bound_check_expr idx_list bounds])) | (_, _) -> 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 = match ck with | 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 false_act = Aassgn (x, translate_extvalue map e2) 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, _) -> 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, _) -> 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 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 action = Acase (cond, [ ptrue, mk_block [action] ]) in - let copy = Aassgn (x, translate_extvalue map e1) in - [copy; action] + let true_act = update_array x e1 e2 idx in + let false_act = Aassgn (x, e1) in + [ mk_ifthenelse cond true_act false_act ] - (** TODO: remplacer par o = { f = v; g = a.g; h = a.h; ... } *) | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Efield_update; Minils.a_params = [{ se_desc = Sfield f }] }, [e1; e2], _) -> let x = var_from_name map x in - let copy = Aassgn (x, translate_extvalue map e1) in - let action = Aassgn (mk_pattern x.pat_ty (Lfield (x, f)), - translate_extvalue map e2) in (* TODO wrong type *) - [copy; action] + update_record x e1 f e2 | Minils.Evarpat n, _ -> [Aassgn (var_from_name map n, translate map act)] diff --git a/compiler/obc/obc_utils.ml b/compiler/obc/obc_utils.ml index 47bba7c..ad76213 100644 --- a/compiler/obc/obc_utils.ml +++ b/compiler/obc/obc_utils.ml @@ -48,6 +48,9 @@ let mk_block ?(locals=[]) eq_list = { b_locals = locals; 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 = match x.pat_desc with | Lvar x -> x @@ -166,3 +169,23 @@ struct let (_, deps) = Obc_mapfold.program funs ModulSet.empty p in ModulSet.remove p.p_modname deps 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) diff --git a/compiler/obc/transformations/scalarize.ml b/compiler/obc/transformations/scalarize.ml index 38b1110..04022f7 100644 --- a/compiler/obc/transformations/scalarize.ml +++ b/compiler/obc/transformations/scalarize.ml @@ -17,14 +17,7 @@ open Obc open Obc_utils open Obc_mapfold - -(** 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 fresh_for = fresh_for "scalarize" let act funs () a = match a with | Aassgn (p,e) ->