aboutsummaryrefslogtreecommitdiff
path: root/src/boot/fe
diff options
context:
space:
mode:
Diffstat (limited to 'src/boot/fe')
-rw-r--r--src/boot/fe/ast.ml45
-rw-r--r--src/boot/fe/item.ml5
-rw-r--r--src/boot/fe/pexp.ml79
3 files changed, 77 insertions, 52 deletions
diff --git a/src/boot/fe/ast.ml b/src/boot/fe/ast.ml
index 6cd1114a..357bf1e6 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)
@@ -259,7 +259,7 @@ and stmt_alt_type =
and stmt_alt_port =
{
- (* else lval is a timeout value. *)
+ (* else atom is a timeout value. *)
alt_port_arms: port_arm array;
alt_port_else: (atom * block) option;
}
@@ -328,7 +328,7 @@ and type_arm = type_arm' identified
and port_arm' = port_case * block
and port_arm = port_arm' identified
-and port_case =
+and port_case =
PORT_CASE_send of (lval * lval)
| PORT_CASE_recv of (lval * lval)
@@ -664,7 +664,7 @@ and fmt_constrained ff (ty, constrs) : unit =
fmt_constrs ff constrs;
fmt ff "@]";
fmt ff "@]";
-
+
and fmt_ty (ff:Format.formatter) (t:ty) : unit =
match t with
@@ -707,7 +707,7 @@ and fmt_ty (ff:Format.formatter) (t:ty) : unit =
| TY_tag ttag -> fmt_tag ff ttag
| TY_iso tiso -> fmt_iso ff tiso
| TY_idx idx -> fmt ff "<idx#%d>" idx
- | TY_constrained ctrd -> fmt_constrained ff ctrd
+ | TY_constrained ctrd -> fmt_constrained ff ctrd
| TY_obj (effect, fns) ->
fmt_obox ff;
@@ -942,10 +942,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 ";";
@@ -1233,7 +1234,7 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit =
Array.iter (fmt_tag_arm ff) at.alt_tag_arms;
fmt_cbb ff;
- | STMT_alt_type at ->
+ | STMT_alt_type at ->
fmt_obox ff;
fmt ff "alt type (";
fmt_lval ff at.alt_type_lval;
@@ -1241,7 +1242,7 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit =
fmt_obr ff;
Array.iter (fmt_type_arm ff) at.alt_type_arms;
begin
- match at.alt_type_else with
+ match at.alt_type_else with
None -> ()
| Some block ->
fmt ff "@\n";
@@ -1252,7 +1253,8 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit =
fmt_cbb ff;
end;
fmt_cbb ff;
- | STMT_alt_port at ->
+
+ | STMT_alt_port at ->
fmt_obox ff;
fmt ff "alt ";
fmt_obr ff;
@@ -1271,13 +1273,14 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit =
fmt_cbb ff;
end;
fmt_cbb ff;
- | STMT_note at ->
+
+ | STMT_note at ->
begin
fmt ff "note ";
fmt_atom ff at;
fmt ff ";"
end
- | STMT_slice (dst, src, slice) ->
+ | STMT_slice (dst, src, slice) ->
fmt_lval ff dst;
fmt ff " = ";
fmt_lval ff src;
@@ -1285,11 +1288,11 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit =
fmt_slice ff slice;
fmt ff ";";
end
-
-and fmt_arm
- (ff:Format.formatter)
+
+and fmt_arm
+ (ff:Format.formatter)
(fmt_arm_case_expr : Format.formatter -> unit)
- (block : block)
+ (block : block)
: unit =
fmt ff "@\n";
fmt_obox ff;
@@ -1299,15 +1302,16 @@ and fmt_arm
fmt_obr ff;
fmt_stmts ff block.node;
fmt_cbb ff;
-
+
and fmt_tag_arm (ff:Format.formatter) (tag_arm:tag_arm) : unit =
let (pat, block) = tag_arm.node in
fmt_arm ff (fun ff -> fmt_pat ff pat) block;
-
+
and fmt_type_arm (ff:Format.formatter) (type_arm:type_arm) : unit =
let (_, slot, block) = type_arm.node in
fmt_arm ff (fun ff -> fmt_slot ff slot) block;
-
+
+
and fmt_port_arm (ff:Format.formatter) (port_arm:port_arm) : unit =
let (port_case, block) = port_arm.node in
fmt_arm ff (fun ff -> fmt_port_case ff port_case) block;
@@ -1317,7 +1321,6 @@ and fmt_port_case (ff:Format.formatter) (port_case:port_case) : unit =
PORT_CASE_send params -> STMT_send params
| PORT_CASE_recv params -> STMT_recv params in
fmt_stmt ff {node = stmt'; id = Node 0};
-
and fmt_pat (ff:Format.formatter) (pat:pat) : unit =
match pat with
@@ -1348,9 +1351,9 @@ and fmt_slice (ff:Format.formatter) (slice:slice) : unit =
fmt ff "@]";
end;
fmt ff "@])";
-
-
+
+
and fmt_decl_param (ff:Format.formatter) (param:ty_param) : unit =
let (ident, (i, e)) = param in
diff --git a/src/boot/fe/item.ml b/src/boot/fe/item.ml
index 69fe5fc2..82ec2faf 100644
--- a/src/boot/fe/item.ml
+++ b/src/boot/fe/item.ml
@@ -253,7 +253,10 @@ and parse_stmts (ps:pstate) : Ast.stmt array =
let lv = name_to_lval apos bpos name in
Ast.PAT_tag (lv, paren_comma_list parse_pat ps)
- | LIT_INT _ | LIT_CHAR _ | LIT_BOOL _ ->
+ | LIT_INT _
+ | LIT_UINT _
+ | LIT_CHAR _
+ | LIT_BOOL _ ->
Ast.PAT_lit (Pexp.parse_lit ps)
| UNDERSCORE -> bump ps; Ast.PAT_wild
diff --git a/src/boot/fe/pexp.ml b/src/boot/fe/pexp.ml
index fb2d91a0..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
@@ -817,11 +835,33 @@ and parse_or_pexp (ps:pstate) : pexp =
step lhs
+and parse_as_pexp (ps:pstate) : pexp =
+ let apos = lexpos ps in
+ let pexp = ctxt "as pexp" parse_or_pexp ps in
+ let rec step accum =
+ match peek ps with
+ AS ->
+ bump ps;
+ let tapos = lexpos ps in
+ let t = parse_ty ps in
+ let bpos = lexpos ps in
+ let t = span ps tapos bpos t in
+ let node =
+ span ps apos bpos
+ (PEXP_unop ((Ast.UNOP_cast t), accum))
+ in
+ step node
+
+ | _ -> accum
+ in
+ step pexp
+
+
and parse_relational_pexp (ps:pstate) : pexp =
let name = "relational pexp" in
let apos = lexpos ps in
- let lhs = ctxt (name ^ " lhs") parse_or_pexp ps in
- let build = binop_build ps name apos parse_or_pexp in
+ let lhs = ctxt (name ^ " lhs") parse_as_pexp ps in
+ let build = binop_build ps name apos parse_as_pexp in
let rec step accum =
match peek ps with
LT -> build accum step Ast.BINOP_lt
@@ -883,30 +923,8 @@ and parse_oror_pexp (ps:pstate) : pexp =
step lhs
-and parse_as_pexp (ps:pstate) : pexp =
- let apos = lexpos ps in
- let pexp = ctxt "as pexp" parse_oror_pexp ps in
- let rec step accum =
- match peek ps with
- AS ->
- bump ps;
- let tapos = lexpos ps in
- let t = parse_ty ps in
- let bpos = lexpos ps in
- let t = span ps tapos bpos t in
- let node =
- span ps apos bpos
- (PEXP_unop ((Ast.UNOP_cast t), accum))
- in
- step node
-
- | _ -> accum
- in
- step pexp
-
-
and parse_pexp (ps:pstate) : pexp =
- parse_as_pexp ps
+ parse_oror_pexp ps
and parse_mutable_and_pexp (ps:pstate) : (Ast.mutability * pexp) =
let mutability = parse_mutability 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)
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-01 18:04:54 +0000