Fix bug and generate MstepAsync call in MiniLS

Easync applications were not flowing throw some Heptagon passes.

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

compiler/heptagon/hept_printer.ml

@@ -207,7 +207,8 @@ and print_app ff (app, args) =
         fprintf ff "@[%a@,%a@,%a@]"
           print_qualname f print_params app.a_params  print_exp_tuple args
     | Easync (f, ack) ->
-        fprintf ff "@[async@,%a@,%a@,%a@,on@,%s@,%a@]"
+        print_stateful ff true;
+        fprintf ff "@[async %a@,%a@,%a on %s@,%a@]"
           print_qualname f
           print_params app.a_params
           print_exp_tuple args

compiler/heptagon/parsing/hept_static_scoping.ml

@@ -68,9 +68,9 @@ let qualify_pervasive q =
     op<a1,a2> (a3) == op <a1> (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

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
 

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

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

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 }