Callconvcheck

src/arrange.ml

@@ -157,7 +157,7 @@ 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

@@ -138,20 +138,35 @@ let actor_msg id f v (k : V.value V.cont) =
   )
 
 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) ->
+     V.Func (None,
+             (T.Call T.Sharable, T.Returns, arg_c, 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 ->
-      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)
-    )
-
+  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) ->
+     V.Func (None,
+             (T.Call T.Sharable, T.Promises, 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
   | T.Func (_, _, _, _, []) ->
@@ -169,10 +184,12 @@ let extended_prim s at =
   | "@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' = V.Func(None,
+                         (T.Call T.Local, T.Returns, 1, 0),
+                         fun v _ -> k' v) in
          f k' V.as_unit)
        k
   | "@await" ->
@@ -181,7 +198,7 @@ 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
@@ -208,6 +225,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
+  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 +243,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 +307,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 +366,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 +412,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,7 +646,7 @@ 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 ->
@@ -631,7 +659,7 @@ and interpret_dec env dec (k : V.value V.cont) =
     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

src/value.ml

@@ -1,5 +1,5 @@
 open Printf
-
+module T = Type
 
 (* Environments *)
 
@@ -190,7 +190,15 @@ end
 type unicode = int
 type class_ = int
 
-type func = value -> value cont -> unit
+type call_conv = Type.func_sort * Type.control * int * int
+
+let call_conv_of_typ typ =
+    match typ with
+    | Type.Func(s,c,tbds,dom,res) -> (s,c,List.length dom, List.length res)
+    | _ -> assert(false)
+
+type func =
+  (value -> value cont -> unit)
 and value =
   | Null
   | Bool of bool
@@ -206,7 +214,7 @@ and value =
   | Opt of value
   | Array of value array
   | Obj of class_ option * value Env.t
-  | Func of class_ option * func
+  | Func of class_ option * call_conv * func 
   | Async of async
   | Mut of value ref
 
@@ -244,51 +252,64 @@ let as_pair = function Tup [v1; v2] -> v1, v2 | _ -> invalid "as_pair"
 
 let obj_of_array a =
   let get =
-    Func (None, fun v k ->
-      let n = as_int v in
-      if Nat.lt n (Nat.of_int (Array.length a)) then
-        k (a.(Nat.to_int n))
-      else
-        raise (Invalid_argument "array index out of bounds")
-    )
+    Func (None,
+          (T.Call T.Local, T.Returns, 1, 1),
+          fun v k ->
+            let n = as_int v in
+            if Nat.lt n (Nat.of_int (Array.length a)) then
+              k (a.(Nat.to_int n))
+            else
+              raise (Invalid_argument "array index out of bounds")
+      )
   in
   let set =
-    Func (None, fun v k ->
-      let v1, v2 = as_pair v in
-      let n = as_int v1 in
-      if Nat.lt n (Nat.of_int (Array.length a)) then
-        k (a.(Nat.to_int n) <- v2; Tup [])
-      else
-        raise (Invalid_argument "array index out of bounds")
-    )
+    Func (None,
+          (T.Call T.Local,T.Returns, 1, 1),
+          fun v k ->
+            let v1, v2 = as_pair v in
+            let n = as_int v1 in
+            if Nat.lt n (Nat.of_int (Array.length a)) then
+              k (a.(Nat.to_int n) <- v2; Tup [])
+            else
+              raise (Invalid_argument "array index out of bounds")
+      )
   in
   let len =
-    Func (None, fun v k -> as_unit v; k (Int (Nat.of_int (Array.length a))))
+    Func (None,
+          (T.Call T.Local, T.Returns, 0, 1),
+          fun v k -> as_unit v; k (Int (Nat.of_int (Array.length a))))
   in
   let keys =
-    Func (None, fun v k ->
-      as_unit v;
-      let i = ref 0 in
-      let next = fun v k' ->
-        if !i = Array.length a then k' Null else
-        let v = Opt (Int (Nat.of_int !i)) in incr i; k' v
-      in k (Obj (None, Env.singleton "next" (Func (None, next))))
-    )
+    Func (None,
+          (T.Call T.Local, T.Returns, 0, 1),
+          fun v k ->
+            as_unit v;
+            let i = ref 0 in
+            let next_conv = (T.Call T.Local, T.Returns, 0, 1) in            
+            let next =fun v k' ->
+                if !i = Array.length a then k' Null else
+                  let v = Opt (Int (Nat.of_int !i)) in incr i; k' v
+            in k (Obj (None, Env.singleton "next"
+                               (Func (None, next_conv, next))))
+      )
   in
   let vals =
-    Func (None, fun v k ->
-      as_unit v;
-      let i = ref 0 in
-      let next = fun v k' ->
-        if !i = Array.length a then k' Null else
-        let v = Opt (a.(!i)) in incr i; k' v
-      in k (Obj (None, Env.singleton "next" (Func (None, next))))
-    )
+    Func (None,
+          (T.Call T.Local, T.Returns, 0, 1),
+          fun v k ->
+            as_unit v;
+            let i = ref 0 in
+            let next_conv = (T.Call T.Local, T.Returns, 0, 1) in
+            let next = fun v k' ->
+                if !i = Array.length a then k' Null else
+                  let v = Opt (a.(!i)) in incr i; k' v
+            in k (Obj (None, Env.singleton "next" (Func (None, next_conv, next))))
+      )
   in
   Env.from_list ["get", get; "set", set; "len", len; "keys", keys; "vals", vals]
 
 let as_obj = function Obj (co, ve) -> co, ve | Array a -> None, obj_of_array a | _ -> invalid "as_obj"
-let as_func = function Func (co, f) -> co, f | _ -> invalid "as_func"
+let as_func = function Func (co, cc, f) -> co, cc, f | _ -> invalid "as_func"
 let as_async = function Async a -> a | _ -> invalid "as_async"
 let as_mut = function Mut r -> r | _ -> invalid "as_mut"
 
@@ -363,8 +384,8 @@ let rec string_of_val_nullary d = function
   | Array a ->
     sprintf "[%s]" (String.concat ", "
       (List.map (string_of_val' d) (Array.to_list a)))
-  | Func (None, _) -> "func"
-  | Func (Some _, _) -> "class"
+  | Func (None, _, _) -> "func"
+  | Func (Some _, _, _) -> "class"
   | v -> "(" ^ string_of_val' d v ^ ")"
 
 and string_of_val' d = function
@@ -388,3 +409,13 @@ and string_of_def' d def =
 
 let string_of_val v = string_of_val' !Flags.print_depth v
 let string_of_def d = string_of_def' !Flags.print_depth d
+
+let string_of_call_conv (sort,control,args,results) =
+  sprintf "(%s %i %s %i)"
+    (T.string_of_func_sort sort)
+    args
+    (match control with
+     | T.Returns -> "->"
+     | T.Promises -> "@>")
+    results               
+