From 73db32c6befcd5bda51914ed4804461fe80e258e Mon Sep 17 00:00:00 2001 From: Tom Barthe Date: Wed, 23 Dec 2020 13:08:10 +0100 Subject: [PATCH] Fix bug and generate MstepAsync call in MiniLS Easync applications were not flowing throw some Heptagon passes. --- compiler/heptagon/analysis/typing.ml | 17 +++++++++---- .../heptagon/parsing/hept_static_scoping.ml | 4 ++-- compiler/main/mls2obc.ml | 24 ++++++++++++++++--- compiler/minils/mls_printer.ml | 2 +- compiler/minils/transformations/callgraph.ml | 14 ++++++++--- compiler/obc/obc.ml | 3 +++ 6 files changed, 51 insertions(+), 13 deletions(-) diff --git a/compiler/heptagon/analysis/typing.ml b/compiler/heptagon/analysis/typing.ml index 591b840..3863e24 100644 --- a/compiler/heptagon/analysis/typing.ml +++ b/compiler/heptagon/analysis/typing.ml @@ -266,13 +266,17 @@ let flatten_ty_list l = List.fold_right (fun arg args -> match arg with Tprod l -> l@args | a -> a::args ) l [] -let kind f ty_desc = +let kind f ty_desc ack = let ty_of_arg v = if Linearity.is_linear v.a_linearity && not !Compiler_options.do_linear_typing then error Eenable_memalloc; v.a_type in - let op = if ty_desc.node_stateful then Enode f else Efun f in + let op = match ack with + | Some ack -> Easync (f, ack) + | _ when ty_desc.node_stateful -> Enode f + | _ -> Efun f + in op, List.map ty_of_arg ty_desc.node_inputs, List.map ty_of_arg ty_desc.node_outputs @@ -633,7 +637,8 @@ let rec typing cenv h e = a_params = params } as app), n_list, pe_list, e_list, reset) -> let ty_desc = find_value f in - let op, expected_ty_list, result_ty_list = kind f ty_desc in + (* TODO(Arduino): iterator + async *) + let op, expected_ty_list, result_ty_list = kind f ty_desc None in let node_params = List.map (fun { p_name = n } -> local_qn n) ty_desc.node_params in let m = build_subst node_params params in @@ -772,7 +777,11 @@ and typing_app cenv h app e_list = (* FIXME(Arduino): voir si c'est correct *) | (Efun f | Enode f | Easync (f, _)) -> let ty_desc = find_value f in - let op, expected_ty_list, result_ty_list = kind f ty_desc in + let ack = match app.a_op with + | Easync (_, ack) -> Some ack + | _ -> None + in + let op, expected_ty_list, result_ty_list = kind f ty_desc ack in let node_params = List.map (fun { p_name = n } -> local_qn n) ty_desc.node_params in let m = build_subst node_params app.a_params in let expected_ty_list = List.map (simplify_type m) expected_ty_list in diff --git a/compiler/heptagon/parsing/hept_static_scoping.ml b/compiler/heptagon/parsing/hept_static_scoping.ml index 7ddf700..42f6887 100644 --- a/compiler/heptagon/parsing/hept_static_scoping.ml +++ b/compiler/heptagon/parsing/hept_static_scoping.ml @@ -68,9 +68,9 @@ let qualify_pervasive q = op (a3) == op (a2,a3) == op (a1,a2,a3) *) let static_app_from_app app args = match app.a_op with + (* TODO(Arduino): static? *) | Efun q - | Enode q - | Easync (q, _) -> + | Enode q -> let q = qualify_pervasive q in q, (app.a_params @ args) | _ -> raise Not_static diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index 1144485..8b6494e 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -489,12 +489,16 @@ let rec translate_eq map call_context let action = Aop (q, List.map (translate_extvalue_to_exp map) args) in v, si, j, (control map ck action) :: s - | pat, Minils.Eapp ({ Minils.a_op = Minils.Efun _ | Minils.Enode _ } as app, e_list, r) -> + | pat, Minils.Eapp + ({ Minils.a_op = + Minils.Efun _ | Minils.Enode _ | Minils.Easync _ } as app, + e_list, r) -> let name_list = translate_pat map e.Minils.e_ty pat in let c_list = List.map (translate_extvalue_to_exp map) e_list in let v', si', j', action = mk_node_call map call_context app loc name_list c_list e.Minils.e_ty in let action = List.map (control map ck) action in + (* TODO(Arduino): add Easync? *) let s = (match r, app.Minils.a_op with | Some r, Minils.Enode _ -> let ck = Clocks.Con (ck, Initial.ptrue, r) in @@ -533,6 +537,9 @@ and translate_eq_list map call_context act_list = let rev_act = List.rev act_list in List.fold_left (translate_eq map call_context) ([], [], [], []) rev_act +and translate_ack { Minils.ack_name = name; Minils.ack_params = params } = + { ack_name = name; ack_params = params } + and mk_node_call map call_context app loc (name_list : Obc.pattern list) args ty = match app.Minils.a_op with | Minils.Efun f when Mls_utils.is_op f -> @@ -572,22 +579,33 @@ and mk_node_call map call_context app loc (name_list : Obc.pattern list) args ty let env = List.fold_left2 build Env.empty nd.Minils.n_input args in v @ nd.Minils.n_local, si, j, subst_act_list env s - | Minils.Enode f | Minils.Efun f -> + | Minils.Enode f | Minils.Efun f | Minils.Easync (f, _) -> let id = match app.Minils.a_id with | None -> gen_obj_ident f | Some id -> id in let o = mk_obj_call_from_context call_context id in + let ack = match app.Minils.a_op with + | Minils.Easync (_, ack) -> Some (translate_ack ack) + | _ -> None + in let obj = { o_ident = obj_ref_name o; o_class = f; o_params = app.Minils.a_params; + o_ack = ack; o_size = size_from_call_context call_context; o_loc = loc } in let si = match app.Minils.a_op with | Minils.Efun _ -> [] | Minils.Enode _ -> [reinit o] + (* TODO(Arduino): is it correct? *) + | Minils.Easync _ -> [] | _ -> assert false in - let s = [Acall (name_list, o, Mstep, args)] in + let m = match app.Minils.a_op with + | Minils.Easync _ -> MstepAsync + | _ -> Mstep + in + let s = [Acall (name_list, o, m, args)] in [], si, [obj], s | _ -> assert false diff --git a/compiler/minils/mls_printer.ml b/compiler/minils/mls_printer.ml index 59d368f..d206b1d 100644 --- a/compiler/minils/mls_printer.ml +++ b/compiler/minils/mls_printer.ml @@ -164,7 +164,7 @@ and print_app ff (app, args) = fprintf ff "@[%a@,%a@,%a@]" print_qualname f print_params app.a_params print_w_tuple args | Easync (f, ack) -> - fprintf ff "@[async@,%a@,%a@,%a@,on@,%s@,%a@]" + fprintf ff "@[async %a@,%a@,%a on %s@,%a@]" print_qualname f print_params app.a_params print_w_tuple args diff --git a/compiler/minils/transformations/callgraph.ml b/compiler/minils/transformations/callgraph.ml index 64a23c0..2377ec5 100644 --- a/compiler/minils/transformations/callgraph.ml +++ b/compiler/minils/transformations/callgraph.ml @@ -188,6 +188,12 @@ struct | Eapp ({ a_op = Enode ln; a_params = params } as app, e_list, r) -> let op = Enode (node_for_params_call ln (instantiate m params)) in Eapp ({ app with a_op = op; a_params = [] }, e_list, r) + | Eapp ({ a_op = Easync (ln, ack); + a_params = params } as app, e_list, r) -> + let op = + Easync (node_for_params_call ln (instantiate m params), ack) + in + Eapp ({ app with a_op = op; a_params = [] }, e_list, r) | Eiterator(it, ({ a_op = Efun ln; a_params = params } as app), n, pe_list, e_list, r) -> let op = Efun (node_for_params_call ln (instantiate m params)) in @@ -198,6 +204,7 @@ struct let op = Enode (node_for_params_call ln (instantiate m params)) in Eiterator(it,{app with a_op = op; a_params = [] }, n, pe_list, e_list, r) + (* TODO(Arduino): iterator *) | _ -> ed in ed, m @@ -313,10 +320,11 @@ let collect_node_calls ln = else (ln, params)::acc in let edesc _ acc ed = match ed with - | Eapp ({ a_op = (Enode ln | Efun ln); a_params = params }, _, _) -> + | Eapp ({ a_op = (Enode ln | Efun ln | Easync (ln, _)); + a_params = params }, _, _) -> ed, add_called_node ln params acc - | Eiterator(_, { a_op = (Enode ln | Efun ln); a_params = params }, - _, _, _, _) -> + | Eiterator(_, { a_op = (Enode ln | Efun ln | Easync (ln, _)); + a_params = params }, _, _, _, _) -> ed, add_called_node ln params acc | _ -> raise Errors.Fallback in diff --git a/compiler/obc/obc.ml b/compiler/obc/obc.ml index fff7594..bbf4fe5 100644 --- a/compiler/obc/obc.ml +++ b/compiler/obc/obc.ml @@ -114,10 +114,13 @@ and var_dec = v_mutable : bool; v_loc : location } +and ack = { ack_name : ack_name; ack_params : static_exp list } + type obj_dec = { o_ident : obj_ident; o_class : class_name; o_params : static_exp list; + o_ack : ack option; (** size of the array if the declaration is an array of obj *) o_size : static_exp list option; o_loc : location }