Add names to tasks and domains. These can either be an explicit literal string

after the "spawn" keyword, or implicitly the call expression used to start the
spawn.

9 files changed, 41 insertions, 18 deletions

diff --git a/src/boot/fe/ast.ml b/src/boot/fe/ast.ml
index efbd62ae..8fc952a5 100644
--- a/src/boot/fe/ast.ml
+++ b/src/boot/fe/ast.ml
@@ -199,7 +199,7 @@ and tup_input = (mutability * atom)
 and stmt' =
 
   (* lval-assigning stmts. *)
-    STMT_spawn of (lval * domain * lval * (atom array))
+    STMT_spawn of (lval * domain * string * lval * (atom array))
   | STMT_new_rec of (lval * (rec_input array) * lval option)
   | STMT_new_tup of (lval * (tup_input array))
   | STMT_new_vec of (lval * mutability * atom array)
@@ -936,10 +936,11 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit =
             fmt ff ";"
           end
 
-      | STMT_spawn (dst, domain, fn, args) ->
+      | STMT_spawn (dst, domain, name, fn, args) ->
           fmt_lval ff dst;
           fmt ff " = spawn ";
           fmt_domain ff domain;
+          fmt_str ff ("\"" ^ name ^ "\"");
           fmt_lval ff fn;
           fmt_atoms ff args;
           fmt ff ";";
diff --git a/src/boot/fe/pexp.ml b/src/boot/fe/pexp.ml
index 3e17e0e4..75983c7f 100644
--- a/src/boot/fe/pexp.ml
+++ b/src/boot/fe/pexp.ml
@@ -18,7 +18,7 @@ open Parser;;
 
 type pexp' =
     PEXP_call of (pexp * pexp array)
-  | PEXP_spawn of (Ast.domain * pexp)
+  | PEXP_spawn of (Ast.domain * string * pexp)
   | PEXP_bind of (pexp * pexp option array)
   | PEXP_rec of ((Ast.ident * Ast.mutability * pexp) array * pexp option)
   | PEXP_tup of ((Ast.mutability * pexp) array)
@@ -558,9 +558,27 @@ and parse_bottom_pexp (ps:pstate) : pexp =
               THREAD -> bump ps; Ast.DOMAIN_thread
             | _ -> Ast.DOMAIN_local
         in
-        let pexp = ctxt "spawn [domain] pexp: init call" parse_pexp ps in
+          (* Spawns either have an explicit literal string for the spawned
+             task's name, or the task is named as the entry call
+             expression. *)
+        let explicit_name =
+          match peek ps with
+              LIT_STR s -> bump ps; Some s
+            | _ -> None
+        in
+        let pexp =
+          ctxt "spawn [domain] [name] pexp: init call" parse_pexp ps
+        in
         let bpos = lexpos ps in
-          span ps apos bpos (PEXP_spawn (domain, pexp))
+        let name =
+          match explicit_name with
+              Some s -> s
+                (* FIXME: string_of_span returns a string like
+                   "./driver.rs:10:16 - 11:52", not the actual text at those
+                   characters *)
+            | None -> Session.string_of_span { lo = apos; hi = bpos }
+        in
+          span ps apos bpos (PEXP_spawn (domain, name, pexp))
 
     | BIND ->
         let apos = lexpos ps in
@@ -1183,7 +1201,7 @@ and desugar_expr_init
           let bind_stmt = ss (Ast.STMT_bind (dst_lval, fn_lval, arg_atoms)) in
             ac [ fn_stmts; arg_stmts; [| bind_stmt |] ]
 
-      | PEXP_spawn (domain, sub) ->
+      | PEXP_spawn (domain, name, sub) ->
           begin
             match sub.node with
                 PEXP_call (fn, args) ->
@@ -1191,7 +1209,8 @@ and desugar_expr_init
                   let (arg_stmts, arg_atoms) = desugar_expr_atoms ps args in
                   let fn_lval = atom_lval ps fn_atom in
                   let spawn_stmt =
-                    ss (Ast.STMT_spawn (dst_lval, domain, fn_lval, arg_atoms))
+                    ss (Ast.STMT_spawn
+                          (dst_lval, domain, name, fn_lval, arg_atoms))
                   in
                     ac [ fn_stmts; arg_stmts; [| spawn_stmt |] ]
               | _ -> raise (err "non-call spawn" ps)
diff --git a/src/boot/me/alias.ml b/src/boot/me/alias.ml
index 94d34fb2..27575324 100644
--- a/src/boot/me/alias.ml
+++ b/src/boot/me/alias.ml
@@ -59,7 +59,7 @@ let alias_analysis_visitor
              * survive 'into' a sub-block (those formed during iteration)
              * need to be handled in this module.  *)
             Ast.STMT_call (dst, callee, args)
-          | Ast.STMT_spawn (dst, _, callee, args)
+          | Ast.STMT_spawn (dst, _, _, callee, args)
             -> alias_call_args dst callee args
 
           | Ast.STMT_send (_, src) -> alias src
diff --git a/src/boot/me/effect.ml b/src/boot/me/effect.ml
index 79868def..73797409 100644
--- a/src/boot/me/effect.ml
+++ b/src/boot/me/effect.ml
@@ -62,7 +62,7 @@ let mutability_checking_visitor
       match s.node with
             Ast.STMT_copy (lv_dst, _)
           | Ast.STMT_call (lv_dst, _, _)
-          | Ast.STMT_spawn (lv_dst, _, _, _)
+          | Ast.STMT_spawn (lv_dst, _, _, _, _)
           | Ast.STMT_recv (lv_dst, _)
           | Ast.STMT_bind (lv_dst, _, _)
           | Ast.STMT_new_rec (lv_dst, _, _)
diff --git a/src/boot/me/layout.ml b/src/boot/me/layout.ml
index a9358795..1df37f0f 100644
--- a/src/boot/me/layout.ml
+++ b/src/boot/me/layout.ml
@@ -400,7 +400,7 @@ let layout_visitor
       let callees =
         match s.node with
             Ast.STMT_call (_, lv, _)
-          | Ast.STMT_spawn (_, _, lv, _) -> [| lv |]
+          | Ast.STMT_spawn (_, _, _, lv, _) -> [| lv |]
           | Ast.STMT_check (_, calls) -> Array.map (fun (lv, _) -> lv) calls
           | _ -> [| |]
       in
diff --git a/src/boot/me/trans.ml b/src/boot/me/trans.ml
index b708bb26..01a89c56 100644
--- a/src/boot/me/trans.ml
+++ b/src/boot/me/trans.ml
@@ -2128,10 +2128,12 @@ let trans_visitor
       ((*initializing*)_:bool)
       (dst:Ast.lval)
       (domain:Ast.domain)
+      (name:string)
       (fn_lval:Ast.lval)
       (args:Ast.atom array)
       : unit =
     let (task_cell, _) = trans_lval_init dst in
+    let runtime_name = trans_static_string name in
     let (fptr_operand, fn_ty) = trans_callee fn_lval in
     (*let fn_ty_params = [| |] in*)
     let _ =
@@ -2165,7 +2167,7 @@ let trans_visitor
         match domain with
             Ast.DOMAIN_thread ->
               begin
-                trans_upcall "upcall_new_thread" new_task [| |];
+                trans_upcall "upcall_new_thread" new_task [| runtime_name |];
                 copy_fn_args false true (CLONE_all new_task) call;
                 trans_upcall "upcall_start_thread" task_cell
                   [|
@@ -2177,7 +2179,7 @@ let trans_visitor
             end
          | _ ->
              begin
-                 trans_upcall "upcall_new_task" new_task [| |];
+                 trans_upcall "upcall_new_task" new_task [| runtime_name |];
                  copy_fn_args false true (CLONE_chan new_task) call;
                  trans_upcall "upcall_start_task" task_cell
                    [|
@@ -4496,8 +4498,9 @@ let trans_visitor
       | Ast.STMT_send (chan,src) ->
           trans_send chan src
 
-      | Ast.STMT_spawn (dst, domain, plv, args) ->
-          trans_spawn (maybe_init stmt.id "spawn" dst) dst domain plv args
+      | Ast.STMT_spawn (dst, domain, name, plv, args) ->
+          trans_spawn (maybe_init stmt.id "spawn" dst) dst
+            domain name plv args
 
       | Ast.STMT_recv (dst, chan) ->
           trans_recv (maybe_init stmt.id "recv" dst) dst chan
diff --git a/src/boot/me/type.ml b/src/boot/me/type.ml
index 23210ea1..b2d5a622 100644
--- a/src/boot/me/type.ml
+++ b/src/boot/me/type.ml
@@ -692,7 +692,7 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
     and check_stmt (stmt:Ast.stmt) : unit =
       check_ret stmt;
       match stmt.Common.node with
-          Ast.STMT_spawn (dst, _, callee, args) ->
+          Ast.STMT_spawn (dst, _, _, callee, args) ->
             infer_lval Ast.TY_task dst;
             demand Ast.TY_nil (check_fn callee args)
 
diff --git a/src/boot/me/typestate.ml b/src/boot/me/typestate.ml
index baf4a543..20702990 100644
--- a/src/boot/me/typestate.ml
+++ b/src/boot/me/typestate.ml
@@ -664,7 +664,7 @@ let condition_assigning_visitor
             let precond = Array.append dst_init src_init in
               raise_pre_post_cond s.id precond;
 
-        | Ast.STMT_spawn (dst, _, lv, args)
+        | Ast.STMT_spawn (dst, _, _, lv, args)
         | Ast.STMT_call (dst, lv, args) ->
             raise_dst_init_precond_if_writing_through s.id dst;
             visit_callable_pre s.id (lval_slots cx dst) lv args
@@ -1350,7 +1350,7 @@ let lifecycle_visitor
         match s.node with
             Ast.STMT_copy (lv_dst, _)
           | Ast.STMT_call (lv_dst, _, _)
-          | Ast.STMT_spawn (lv_dst, _, _, _)
+          | Ast.STMT_spawn (lv_dst, _, _, _, _)
           | Ast.STMT_recv (lv_dst, _)
           | Ast.STMT_bind (lv_dst, _, _)
           | Ast.STMT_new_rec (lv_dst, _, _)
diff --git a/src/boot/me/walk.ml b/src/boot/me/walk.ml
index 0e65406a..cadfd66b 100644
--- a/src/boot/me/walk.ml
+++ b/src/boot/me/walk.ml
@@ -451,7 +451,7 @@ and walk_stmt
           walk_lval v f;
           Array.iter (walk_opt_atom v) az
 
-      | Ast.STMT_spawn (dst,_,p,az) ->
+      | Ast.STMT_spawn (dst,_,_,p,az) ->
           walk_lval v dst;
           walk_lval v p;
           Array.iter (walk_atom v) az