Callconvcheck

src/arrange.ml

@@ -157,7 +157,15 @@ and dec d = match d.it with
   | LetD (p, e) -> "LetD" $$ [pat p; exp e]
   | VarD (i, e) -> "VarD" $$ [id i; exp e]
   | FuncD (s, i, tp, p, t, e) ->
-    "FuncD" $$ [Atom (sharing s.it); id i] @ List.map typ_bind tp @ [pat p; typ t; exp e]
+    "FuncD" $$ [
+      Atom (Type.string_of_typ d.note.note_typ);
+      Atom (sharing s.it);
+      id i] @
+      List.map typ_bind tp @ [
+      pat p;
+      typ t;
+      exp e
+    ]
   | TypD (i, tp, t) ->
     "TypD" $$ [id i] @ List.map typ_bind tp @ [typ t]
   | ClassD (i, j, tp, s, p, i', efs) ->

src/async.ml

@@ -18,12 +18,11 @@ let localS =
    at=no_region;
    note=()}
 
-(*  
+
 let sharableS =
   {it=T.Call T.Sharable;
    at=no_region;
    note=()}
-*)
 
 let replyT typ = T.Func(T.Call T.Sharable, T.Returns, [], [typ], [])
 
@@ -62,7 +61,8 @@ let prelude_new_async t1 =
     at = no_region;    
   }
 
-let contTT t = funcT(localS,[],t,unitT)
+(* let contTT t = funcT(localS,[],t,unitT) *)
+let replyTT t = funcT(sharableS,[],t,unitT)             
 
 
 let shared_funcD f x e =
@@ -171,8 +171,8 @@ let rec t_typ (t:T.typ) =
               Func(s, c, List.map t_bind tbs, List.map t_typ t1, List.map t_typ t2)
            | [Async t2] ->
               Func (s, c, List.map t_bind tbs,
-                    extendTup (List.map t_typ t1) (contT (t_typ t2)), [])
-           | _ -> failwith "t_typT'"
+                    extendTup (List.map t_typ t1) (replyT (* contT*) (t_typ t2)), [])
+           | _ -> failwith "t_typ"
          end
        | _ ->
           Func (s, c, List.map t_bind tbs, List.map t_typ t1, List.map t_typ t2)
@@ -361,9 +361,9 @@ and t_dec' dec' =
            | T.Async res_typ ->
               let res_typ = t_typ res_typ in
               let pat = t_pat pat in
-              let cont_typ = contT res_typ in
+              let reply_typ = replyT res_typ in
               let typT' = tupT []  in
-              let k = fresh_id cont_typ in
+              let k = fresh_id reply_typ in
               let pat',d = extendTupP pat (varP k) in
               (* let pat' = tupP [pat;varP k] in *)
               let typbinds' = t_typbinds typbinds in                   
@@ -453,7 +453,7 @@ and t_typT' t =
               FuncT (s, t_typbinds tbs, t_typT t1, t_typT t2)
            | AsyncT t2 ->
               FuncT (localS, t_typbinds tbs,
-                     tupT [t_typT t1; contTT (t_typT t2)], unitT)
+                     tupT [t_typT t1; replyTT (t_typT t2)], unitT) 
            | _ -> failwith "t_typT'"
          end
        | _ ->

src/interpret.ml

@@ -41,7 +41,7 @@ let find id env =
   try V.Env.find id env
   with Not_found ->
     trap no_region "unbound identifier %s" id
-         
+
 (* Tracing *)
 
 let trace_depth = ref 0
@@ -136,21 +136,35 @@ let actor_msg id f v (k : V.value V.cont) =
     incr trace_depth;
     f v k
   )
-                  
+
 let make_unit_message id v =
-    let _, f = V.as_func v in
-    V.Func (None, fun v k -> actor_msg id f v (fun _ -> ()); k V.unit)
+  let _, call_conv, f = V.as_func v in
+  match call_conv with
+  | (T.Call T.Sharable, _ , arg_c, 0) ->
+    Value.message_func 0 (fun v k ->
+      actor_msg id f v (fun _ -> ());
+      k V.unit
+    )
+  | _ ->
+    failwith ("unexpected call_conv " ^ (V.string_of_call_conv call_conv))
+(* assert (false) *)
 
 let make_async_message id v =
-    assert (not !Flags.async_lowering);
-    let _, f = V.as_func v in
-    V.Func (None, fun v k ->
+  assert (not !Flags.async_lowering);
+  let _, call_conv, f = V.as_func v in
+  match call_conv with
+  | (T.Call T.Sharable, T.Promises, arg_c,1) ->
+    Value.async_func arg_c 1 (fun v k ->
       let async = make_async () in
       actor_msg id f v (fun v_async ->
         get_async (V.as_async v_async) (fun v_r -> set_async async v_r)
       );
       k (V.Async async)
     )
+  | _ ->
+    failwith ("unexpected call_conv " ^ (V.string_of_call_conv call_conv))
+    (*    assert (false) *)
+
 
 let make_message id t v : V.value =
   match t with
@@ -163,16 +177,16 @@ let make_message id t v : V.value =
      failwith (Printf.sprintf "actorfield: %s %s" id.it (T.string_of_typ t))
      (*     assert false *)
 
-  
+
 let extended_prim s at =
   match s with
   | "@async" ->
      assert(!Flags.await_lowering && not(!Flags.async_lowering)); 
      fun v k ->
-     let (call,f) = V.as_func v in
+     let (call,_,f) = V.as_func v in
      async at
        (fun k' ->
-         let k' = V.Func(None,fun v _ -> k' v) in
+         let k' = Value.local_func 1 0 (fun v _ -> k' v) in
          f k' V.as_unit)
        k
   | "@await" ->
@@ -181,13 +195,12 @@ let extended_prim s at =
      begin
        match V.as_tup v with
       | [async; w] ->
-        let (_,f) = V.as_func w in
+        let (_,_,f) = V.as_func w in
         await at (V.as_async async) (fun v -> f v k) 
       | _ -> assert false
      end
   | _ -> Prelude.prim s
 
-
 (* Literals *)
 
 let interpret_lit env lit : V.value =
@@ -208,6 +221,15 @@ let interpret_lit env lit : V.value =
 
 (* Expressions *)
 
+let check_call_conv exp ((func_sort,control,args,res) as call_conv) =
+  let ((exp_func_sort,exp_control,exp_args,exp_res) as exp_call_conv) = V.call_conv_of_typ exp.note.note_typ in
+  (* TODO: Check the full calling convention here *)
+  if not (exp_func_sort = func_sort) then
+    failwith (Printf.sprintf "call_conv mismatch: function %s expect %s, found %s"
+      (Wasm.Sexpr.to_string 80 (Arrange.exp exp))
+      (V.string_of_call_conv exp_call_conv)
+      (V.string_of_call_conv call_conv))
+
 let rec interpret_exp env exp (k : V.value V.cont) =
   interpret_exp_mut env exp (function V.Mut r -> k !r | v -> k v)
 
@@ -217,7 +239,7 @@ and interpret_exp_mut env exp (k : V.value V.cont) =
   match exp.it with
   | PrimE s ->
     let at = exp.at in
-    k (V.Func (None, extended_prim s at))
+    k (V.Func (None, V.call_conv_of_typ exp.note.note_typ, extended_prim s at))
   | VarE id ->
     (match Lib.Promise.value_opt (find id.it env.vals) with
     | Some v -> k v
@@ -281,7 +303,9 @@ and interpret_exp_mut env exp (k : V.value V.cont) =
   | CallE (exp1, typs, exp2) ->
     interpret_exp env exp1 (fun v1 ->
         interpret_exp env exp2 (fun v2 ->
-            let _, f = V.as_func v1 in f v2 k
+            let _, call_conv, f = V.as_func v1 in
+            check_call_conv exp1 call_conv;
+            f v2 k
 
 (*
         try     
@@ -338,7 +362,7 @@ and interpret_exp_mut env exp (k : V.value V.cont) =
   | ForE (pat, exp1, exp2) ->
     interpret_exp env exp1 (fun v1 ->
       let _, fs = V.as_obj v1 in
-      let _, next = V.as_func (find "next" fs) in
+      let _, _, next = V.as_func (find "next" fs) in
       let rec k_continue = fun v ->
         V.as_unit v;
         next V.unit (fun v' ->
@@ -384,7 +408,7 @@ and interpret_exp_mut env exp (k : V.value V.cont) =
         let b =
           match v1 with
           | V.Obj (Some c1, _) ->
-            let c2, _ = V.as_func v2 in
+            let c2, _, _ = V.as_func v2 in
             Some c1 = c2
           | _ -> false
         in k (V.Bool b)
@@ -618,20 +642,20 @@ and interpret_dec env dec (k : V.value V.cont) =
   | FuncD (_sort, id, _typbinds, pat, _typ, exp) ->
     let f = interpret_func env id pat
       (fun env' -> interpret_exp env' exp) in
-    let v = V.Func (None, f) in
+    let v = V.Func (None, V.call_conv_of_typ dec.note.note_typ, f) in
     let v =
       match _sort.it with
       | T.Sharable ->
          make_message id dec.note.note_typ v
       |  T.Local -> v
-    in                      
+    in
     define_id env id v;
     k v
-  | ClassD (id, _,  _typbinds, sort, pat, id', fields) ->
+  | ClassD (id, _, _typbinds, sort, pat, id', fields) ->
     let c = V.new_class () in
     let f = interpret_func env id pat
       (fun env' k' -> interpret_obj env' sort id' (Some c) fields k') in
-    let v = V.Func (Some c, f) in
+    let v = V.Func (Some c, V.call_conv_of_typ dec.note.note_typ, f) in
     define_id env id v;
     k v
 

src/prelude.ml

@@ -95,7 +95,7 @@ let prim = function
       (match Value.as_tup v with
        | [len; g] ->
          let len_nat = Int.to_int (as_int len) in
-         let (_, g') = Value.as_func g in
+         let (_, _, g') = Value.as_func g in
          let rec go prefix k i =
           if i == len_nat
           then k (Array (Array.of_list (prefix [])))

src/type.mli

@@ -141,6 +141,7 @@ module Env : Env.S with type key = string
 (* Pretty printing *)
 
 val string_of_prim : prim -> string
+val string_of_func_sort: func_sort -> string  
 val string_of_typ : typ -> string
 val string_of_kind : kind -> string
 val strings_of_kind : kind -> string * string * string