Shells in OCaml
Initial async jobs
We implement background jobs, however, because of Eio's structured
concurrency we cannot actually stop running the shell and end up waiting
on all the processes in the background!
+123
-47
+3
src/bin/main.ml
+3
src/bin/main.ml
···
5
5
let sh ~command ~dump ~file env =
6
6
let executor = Merry_posix.Exec.{ mgr = env#process_mgr } in
7
7
let interactive = Option.is_none file && Option.is_none command in
8
+
Eio.Switch.run @@ fun async_switch ->
8
9
let ctx =
9
10
C.
10
11
{
···
18
19
fs = env#fs;
19
20
options = Merry.Built_ins.Options.default;
20
21
stdout = None;
22
+
async_switch;
23
+
background_jobs = [];
21
24
}
22
25
in
23
26
match (file, command) with
+16
-6
src/lib/ast.ml
+16
-6
src/lib/ast.ml
···
38
38
| CST.SeparatorOp_Semicolon -> Semicolon
39
39
40
40
and clist : ?sep:separator -> CST.clist -> clist =
41
-
fun ?(sep = Nosep) x ->
41
+
fun ?(sep = Semicolon) x ->
42
42
match x with
43
43
| CList_CList_SeparatorOp_AndOr (a, b, c) ->
44
44
let next_sep = separator_op b.value in
···
135
135
match x with
136
136
| CompoundList_LineBreak_Term (_, b) ->
137
137
let b = term b.value in
138
-
(b, Nosep)
138
+
(b, Semicolon)
139
139
| CompoundList_LineBreak_Term_Separator (_, b, c) ->
140
140
let b = term b.value in
141
141
let c = separator c.value in
···
151
151
Nslist.cons b c rest
152
152
| Term_AndOr a ->
153
153
let a = and_or a.value in
154
-
Nslist.singleton Nosep a
154
+
Nslist.singleton Semicolon a
155
155
156
156
and for_clause : CST.for_clause -> for_clause =
157
157
fun x ->
···
508
508
fun x ->
509
509
match x with
510
510
| Separator_SeparatorOp_LineBreak (a, _) -> separator_op a.value
511
-
| Separator_NewLineList _ -> Nosep
511
+
| Separator_NewLineList _ -> Semicolon
512
512
513
513
and word : CST.word -> word = fun x -> match x with Word (_, b) -> word_cst b
514
514
and word_cst : CST.word_cst -> word_cst = fun v -> List.map word_component v
···
719
719
Yojson.Safe.pretty_print ppf yjs
720
720
end
721
721
722
-
let of_string s = Morbig.parse_string "-" s |> of_program
722
+
let of_string s =
723
+
let f = Morbig.parse_string "-" s in
724
+
(* Fmt.pr "MORBIG====\n%!"; *)
725
+
(* Morbig.JsonHelpers.save_as_json true Out_channel.stdout f; *)
726
+
(* Fmt.pr "MORBIG====\n%!"; *)
727
+
of_program f
723
728
724
729
let of_file path =
725
730
let fname = Eio.Path.native_exn path in
726
-
Eio.Path.load path |> Morbig.parse_string fname |> of_program
731
+
732
+
let f = Eio.Path.load path |> Morbig.parse_string fname in
733
+
(* Fmt.pr "MORBIG====\n%!"; *)
734
+
(* Morbig.JsonHelpers.save_as_json true Out_channel.stdout f; *)
735
+
(* Fmt.pr "MORBIG====\n%!"; *)
736
+
of_program f
727
737
728
738
let rec word_component_to_string : word_component -> string = function
729
739
| WordName s -> s
+3
src/lib/dune
+3
src/lib/dune
+9
src/lib/eunix.ml
+9
src/lib/eunix.ml
···
16
16
let name = Unix.getlogin () in
17
17
let host = Unix.gethostname () in
18
18
Fmt.str "%s@%s" name host
19
+
20
+
external tcsetpgrp : int -> int -> int = "caml_merry_tcsetpgrp"
21
+
external setpgrp : int -> int -> int = "caml_merry_setpgid"
22
+
23
+
let make_process_group () = match setpgrp 0 0 with 0 -> () | n -> exit n
24
+
25
+
let background () =
26
+
let _pgrid = Unix.getpid () in
27
+
()
+63
-34
src/lib/eval.ml
+63
-34
src/lib/eval.ml
···
2
2
Copyright (c) 2025 The merry programmers. All rights reserved.
3
3
SPDX-License-Identifier: ISC
4
4
-----------------------------------------------------------------*)
5
+
open Eio.Std
5
6
open Import
6
7
open Exit.Syntax
7
8
···
35
36
fs : Eio.Fs.dir_ty Eio.Path.t;
36
37
options : Built_ins.Options.t;
37
38
stdout : Eio_unix.sink_ty Eio.Flow.sink option;
39
+
background_jobs : J.t list;
40
+
async_switch : Eio.Switch.t;
38
41
}
39
42
40
43
let clear_local_state ctx = { ctx with local_state = [] }
···
202
205
List.fold_left (fun acc (k, _) -> List.remove_assoc k acc) env extra
203
206
|> List.append extra
204
207
205
-
let rec execute_commands initial_ctx pipeline_switch p : ctx Exit.t =
208
+
let rec handle_pipeline ~async initial_ctx pipeline_switch p : ctx Exit.t =
209
+
let pipeline_switch =
210
+
if async then initial_ctx.async_switch else pipeline_switch
211
+
in
206
212
let handle_job ~pgid j p =
207
213
match (j, p) with
208
214
| None, _ ->
209
-
Option.some
210
-
@@ J.make ~state:`Running ~bang:false pgid (Nlist.Singleton p)
215
+
Option.some @@ J.make ~state:`Running pgid (Nlist.Singleton p)
211
216
| Some j, `Process p -> Option.some @@ J.add_process p j
212
217
| Some j, `Built_in p -> Option.some @@ J.add_built_in p j
213
218
in
···
362
367
in
363
368
match job with
364
369
| None -> Exit.zero ctx
365
-
| Some job -> J.await_exit ~pipefail:false job >|= fun () -> ctx
370
+
| Some job ->
371
+
if not async then J.await_exit ~pipefail:false job >|= fun () -> ctx
372
+
else begin
373
+
Exit.zero { ctx with background_jobs = job :: ctx.background_jobs }
374
+
end
366
375
367
376
and expand_cst (ctx : ctx) cst =
368
377
let cst = tilde_expansion ctx cst in
···
382
391
expand_redirects (ctx, v :: acc) rest
383
392
| s :: rest -> expand_redirects (ctx, s :: acc) rest
384
393
385
-
and handle_single_pipeline ~sw ctx c =
394
+
and handle_and_or ~sw ~async ctx c =
386
395
let pipeline = function
387
396
| Ast.Pipeline p -> (Fun.id, p)
388
397
| Ast.Pipeline_Bang p -> (Exit.not, p)
···
396
405
match exit_so_far with
397
406
| Exit.Zero ctx ->
398
407
let f, p = pipeline p in
399
-
f @@ execute_commands ctx sw p
408
+
f @@ handle_pipeline ~async ctx sw p
400
409
| v -> v)
401
410
| Or, Nlist.Singleton (p, _) -> (
402
411
match exit_so_far with
403
412
| Exit.Zero _ as ctx -> ctx
404
413
| _ ->
405
414
let f, p = pipeline p in
406
-
f @@ execute_commands ctx sw p)
415
+
f @@ handle_pipeline ~async ctx sw p)
407
416
| Noand_or, Nlist.Singleton (p, _) ->
408
417
let f, p = pipeline p in
409
-
f @@ execute_commands ctx sw p
418
+
f @@ handle_pipeline ~async ctx sw p
410
419
| Noand_or, Nlist.Cons ((p, next_sep), rest) ->
411
420
let f, p = pipeline p in
412
-
fold (next_sep, f (execute_commands ctx sw p)) rest
421
+
fold (next_sep, f (handle_pipeline ~async ctx sw p)) rest
413
422
| And, Nlist.Cons ((p, next_sep), rest) -> (
414
423
match exit_so_far with
415
424
| Exit.Zero ctx ->
416
425
let f, p = pipeline p in
417
-
fold (next_sep, f (execute_commands ctx sw p)) rest
426
+
fold (next_sep, f (handle_pipeline ~async ctx sw p)) rest
418
427
| Exit.Nonzero _ as v -> v)
419
428
| Or, Nlist.Cons ((p, next_sep), rest) -> (
420
429
match exit_so_far with
421
430
| Exit.Zero _ as exit_so_far -> fold (next_sep, exit_so_far) rest
422
431
| Exit.Nonzero _ ->
423
432
let f, p = pipeline p in
424
-
fold (next_sep, f (execute_commands ctx sw p)) rest)
433
+
fold (next_sep, f (handle_pipeline ~async ctx sw p)) rest)
425
434
in
426
435
fold (Noand_or, Exit.zero ctx) c
427
436
···
550
559
word_glob_expand ctx cst)
551
560
swc
552
561
553
-
and exec initial_ctx (ast : Ast.complete_command) =
554
-
let command, _ = ast in
562
+
and exec initial_ctx ((command, sep) : Ast.complete_command) =
555
563
let rec loop : Eio.Switch.t -> ctx -> Ast.clist -> ctx Exit.t =
556
564
fun sw ctx -> function
557
-
| Nlist.Singleton (c, _) -> handle_single_pipeline ~sw ctx c
558
-
| Nlist.Cons ((c, (Semicolon | Nosep)), cs) -> (
559
-
match handle_single_pipeline ~sw ctx c with
565
+
| Nlist.Singleton (c, sep) ->
566
+
let async =
567
+
match sep with Semicolon -> false | Ampersand -> true
568
+
in
569
+
handle_and_or ~sw ~async ctx c
570
+
| Nlist.Cons ((c, sep), cs) -> (
571
+
let async =
572
+
match sep with Semicolon -> false | Ampersand -> true
573
+
in
574
+
match handle_and_or ~sw ~async ctx c with
560
575
| Exit.Zero ctx -> loop sw ctx cs
561
576
| v -> v)
562
-
| _ -> Fmt.failwith "Background tasks not implemented yet!"
563
577
in
564
-
Eio.Switch.run @@ fun sw -> loop sw initial_ctx command
578
+
match sep with
579
+
| Some Semicolon | None ->
580
+
Eio.Switch.run @@ fun sw -> loop sw initial_ctx command
581
+
| Some Ampersand ->
582
+
Fiber.fork ~sw:initial_ctx.async_switch (fun () ->
583
+
Fiber.yield ();
584
+
let _ : ctx Exit.t =
585
+
loop initial_ctx.async_switch initial_ctx command
586
+
in
587
+
());
588
+
Exit.zero initial_ctx
565
589
566
590
and execute ctx ast = exec ctx ast
567
591
568
592
and run ctx ast =
593
+
(* Make the shell its own process group *)
594
+
Eunix.make_process_group ();
569
595
let ctx, cs =
570
-
List.fold_left
571
-
(fun (ctx, cs) command ->
572
-
let ctx = Exit.value ctx in
573
-
let exit = execute ctx command in
574
-
match exit with
575
-
| Exit.Nonzero { exit_code; message; should_exit; _ } -> (
576
-
Option.iter (Fmt.epr "%s\n%!") message;
577
-
match
578
-
( should_exit.interactive,
579
-
should_exit.non_interactive,
580
-
ctx.interactive )
581
-
with
582
-
| `Yes, _, true | _, `Yes, false -> Stdlib.exit exit_code
583
-
| _ -> (exit, ast :: cs))
584
-
| Exit.Zero _ as ctx -> (ctx, ast :: cs))
585
-
(ctx, []) ast
596
+
let rec loop_commands (ctx, cs) (c : Ast.complete_commands) =
597
+
match c with
598
+
| [] -> (ctx, cs)
599
+
| command :: commands -> (
600
+
let ctx = Exit.value ctx in
601
+
let exit = execute ctx command in
602
+
match exit with
603
+
| Exit.Nonzero { exit_code; message; should_exit; _ } -> (
604
+
Option.iter (Fmt.epr "%s\n%!") message;
605
+
match
606
+
( should_exit.interactive,
607
+
should_exit.non_interactive,
608
+
ctx.interactive )
609
+
with
610
+
| `Yes, _, true | _, `Yes, false -> Stdlib.exit exit_code
611
+
| _ -> loop_commands (exit, c :: cs) commands)
612
+
| Exit.Zero _ as ctx -> loop_commands (ctx, c :: cs) commands)
613
+
in
614
+
loop_commands (ctx, []) ast
586
615
in
587
616
(ctx, List.rev cs)
588
617
end
+3
-6
src/lib/job.ml
+3
-6
src/lib/job.ml
···
4
4
type t = {
5
5
state : [ `Running ];
6
6
id : int;
7
-
bang : bool;
8
7
(* Process list is in reverse order *)
9
8
processes : [ `Process of E.process | `Built_in of unit Exit.t ] Nlist.t;
10
9
}
11
10
12
-
let make ?(state = `Running) ~bang id processes =
13
-
{ state; id; processes; bang }
11
+
let make ?(state = `Running) id processes = { state; id; processes }
14
12
15
13
let add_process proc t =
16
14
{ t with processes = Nlist.cons (`Process proc) t.processes }
···
21
19
(* Section 2.9.2 https://pubs.opengroup.org/onlinepubs/9799919799/ *)
22
20
let await_exit ~pipefail t =
23
21
let await = function `Process p -> E.await p | `Built_in b -> b in
24
-
match (pipefail, t.bang) with
25
-
| false, false -> await (Nlist.hd t.processes)
26
-
| false, true -> await (Nlist.hd t.processes) |> Exit.not
22
+
match pipefail with
23
+
| false -> await (Nlist.hd t.processes)
27
24
| _ -> Fmt.failwith "TODO: pipefail"
28
25
end
+25
src/lib/merry_stubs.c
+25
src/lib/merry_stubs.c
···
1
+
#include <caml/mlvalues.h>
2
+
#include <caml/memory.h>
3
+
#include <caml/alloc.h>
4
+
#include <caml/fail.h>
5
+
6
+
#include <unistd.h>
7
+
8
+
9
+
value caml_merry_tcsetpgrp(value v_fd, value v_pid_t) {
10
+
CAMLparam2(v_fd, v_pid_t);
11
+
int res;
12
+
13
+
res = tcsetpgrp(Int_val(v_fd), Long_val(v_pid_t));
14
+
15
+
CAMLreturn(Val_int(res));
16
+
}
17
+
18
+
value caml_merry_setpgid(value v_fd, value v_pid_t) {
19
+
CAMLparam2(v_fd, v_pid_t);
20
+
int res;
21
+
22
+
res = setpgid(Long_val(v_fd), Long_val(v_pid_t));
23
+
24
+
CAMLreturn(Val_int(res));
25
+
}
+1
-1
src/lib/sast.ml
+1
-1
src/lib/sast.ml