JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

A frame that prints shows its globals, live prelude shadowing matches a rebuild, flan run cleans up and dies with flan, and a long socket path works from Emacs

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 22:59:50 +07:00
commit 93e614e239
19 changed files with 692 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
TODO.org
View File

@ -1473,11 +1473,6 @@ Its signature changes in the session but its body is not recompiled, so every ca
stops on StaleCall naming a type nobody wrote. Proposal: recompile such callers.
Postponed 2026-09-25 while .fln takes priority.
** TODO A prelude function shadowed live is reached by the prelude's own calls
A defn of a prelude function's name sent to a running =flan dev= installs into the
host's cell for that name, so the prelude's calls compiled into the host follow it;
a rebuild gives them the prelude's again, as =Check.shadow_prelude= intends.
** DONE The dev loop, step 1: the reload primitive
A list of top-level forms is recompiled and installed into a running process, and
call sites compiled before those forms existed follow them through an indirection
@ -1650,9 +1645,6 @@ CLOSED: [2026-09-25]
** TODO The inspector holds a value
Reading needs no module now, so an address and a type are enough to keep a value on the daemon's side between requests, the way CIDER keeps a JVM object. Nothing holds one yet: the Emacs stack is still a stack of expressions.
** TODO A frame that prints is skipped from the globals section
A frame whose body calls =print= comes back in =:skipped= as "running a body that has been redefined since" though nothing was redefined: its global-reference fingerprint differs between the build and the daemon. test/programs/dev-parity.flan stores each global to itself instead of printing it for this reason.
** DONE The watch table stays pushed
CLOSED: [2026-09-25]
The watch table stays pushed, and shares the push channel program output moves to.
@ -1782,17 +1774,6 @@ crashed session keeping its directory.
The fork pool is drained before anything reads the failure count, and a nonzero
count is an exit status. A red row used to be able to print and pass.
** TODO test_dev dies on Wire.Closed after the half-write abort
Intermittent, on an unmodified tree too: the =--llvm= half-write daemon in
=test_dev.ml='s =half_written= sometimes exits before it replies to =abort=, and
=request= raises =Wire.Closed= uncaught, so test_dev ends with a fatal, no =FAIL=
line and every later row unrun.
** TODO flan build and flan run leave an empty flan-<pid> directory
=Build.workdir= is created per process and nothing removes it once the IR is
gone. The dev daemon now removes its own on a clean end; the one-shot commands do
not.
** WAIT An x86 dev session's read of a dyn global after an allocating thunk failed once
WAIT on a recurrence; the test now prints the failing read's own reply.
The one failure's message came from a second read, which said "kept"; the failing
@ -1931,6 +1912,8 @@ and an =eval-expr= of the =get=, all succeed. In a session every installed
function of no arguments returning =()= has the type =(CFn [] ())=, not only
=pause= — a bare =pause= or =tick= asked of the session says so — so the
keyword may not be what resolved. The next report wants the exact form sent.
Nor (2026-09-25) by a mark at the =:pause= or the =when=, frame evaluation, the
indented syntax, or =load-file= after slot changes and with a program =pause=.
** DONE A digit does not take the restart RET takes
CLOSED: [2026-09-25]

32
bin/main.ml
View File

@ -949,12 +949,36 @@ let () =
~csrcs:f.csrcs ~lflags:f.lflags
~pnames:(if debug then param_names f.load else [])
f.program ~out:exe);
let code =
Sys.command
(String.concat " " (List.map Filename.quote (exe :: prog_args)))
(* Spawned and waited on here rather than through [Sys.command], so a
SIGTERM or SIGHUP sent to flan reaches the program and flan still
removes the executable and its work directory: the default action
would end flan inside the wait with neither removed. SIGINT and
SIGQUIT are ignored while the program runs, as [system] does, since
the terminal sends them to the program too. A flan killed outright
takes the program with it ([Spawn.dying]). *)
let pid = Flan.Spawn.dying exe (Array.of_list (exe :: prog_args)) in
let caught = ref None in
let forward s =
Sys.Signal_handle (fun _ ->
caught := Some s;
try Unix.kill pid s with Unix.Unix_error _ -> ())
in
Sys.set_signal Sys.sigterm (forward Sys.sigterm);
Sys.set_signal Sys.sighup (forward Sys.sighup);
Sys.set_signal Sys.sigint Sys.Signal_ignore;
Sys.set_signal Sys.sigquit Sys.Signal_ignore;
let rec wait () =
match Unix.waitpid [] pid with
| _, Unix.WEXITED c -> c
| _, (Unix.WSIGNALED s | Unix.WSTOPPED s) -> 128 + Flan.Spawn.host_signal s
| exception Unix.Unix_error (Unix.EINTR, _, _) -> wait ()
in
let code = wait () in
(try Sys.remove exe with Sys_error _ -> ());
exit code)
exit (match !caught with
| Some s when s = Sys.sigterm -> 143
| Some _ -> 129
| None -> code))
| _ ->
prerr_endline
"usage: flan (read|parse|check|emit|shim) <file.flan>...\n flan check <file.flan>... [--warn-memory]\n flan emit <file.flan> [--x86] [--dev] [--debug] [--no-bounds-checks]\n\

22
emacs/flan.el
View File

@ -673,6 +673,26 @@ Set to nil to leave the program's state to whatever replies happen to say."
flan-socket-name)))
(and dir (expand-file-name flan-socket-name dir))))
(defun flan--short-socket (socket)
"The path to connect to SOCKET by.
A unix socket path holds at most 107 bytes, and a longer one cannot be
connected to by name. For such a SOCKET the daemon makes a symlink at a
short path computed from it, and this computes the same one: see
`Wire.short_socket_path' in lib/wire.ml."
(let ((abs (expand-file-name socket)))
(if (<= (string-bytes abs) 107)
socket
(let* ((env (getenv "XDG_RUNTIME_DIR"))
(dir (if (and env (not (string= env "")) (file-directory-p env))
env
"/tmp")))
(expand-file-name
(concat "flan-"
(substring (secure-hash 'md5 (encode-coding-string abs 'utf-8))
0 16)
".sock")
dir)))))
(defun flan--open (socket)
"Open a connection to SOCKET and make it the current one."
(when (process-live-p flan--connection)
@ -683,7 +703,7 @@ Set to nil to leave the program's state to whatever replies happen to say."
(with-current-buffer buf (erase-buffer) (set-buffer-multibyte nil))
(setq flan--connection
(make-network-process
:name "flan" :buffer buf :family 'local :service socket
:name "flan" :buffer buf :family 'local :service (flan--short-socket socket)
:coding 'binary :noquery t
:filter #'flan--filter :sentinel #'flan--sentinel))
(setq flan--socket socket))

40
lib/ast.ml
View File

@ -486,7 +486,9 @@ let map_children f (e : expr) : expr =
in
{ e with e = kind }
let pause_call loc = { e = Call ({ e = Var "pause"; loc }, []); loc }
(* [fn] is the name the prelude's function answers to, which is not its own
when the program defines one of that name: see [Session.prelude_fn]. *)
let pause_call ?(fn = "pause") loc = { e = Call ({ e = Var fn; loc }, []); loc }
(* The stepper. [instrument_step ds] is [ds] with every [defn] rebuilt so a
call stops before each form of its body, at any depth of body: the forms of
@ -504,36 +506,36 @@ let pause_call loc = { e = Call ({ e = Var "pause"; loc }, []); loc }
the local is visibly the compiler's and hidden from the locals listing. *)
let step_flag = "flan~step"
let step_point loc =
let step_point fn loc =
let v = { e = Var step_flag; loc } in
{ e =
If (v,
{ e = Set (Pvar step_flag, { e = Call ({ e = Var "step-point"; loc }, []); loc });
{ e = Set (Pvar step_flag, { e = Call ({ e = Var fn; loc }, []); loc });
loc },
None);
loc }
let rec step_body (es : expr list) : expr list =
List.concat_map (fun (e : expr) -> [ step_point e.loc; step_expr e ]) es
let rec step_body fn (es : expr list) : expr list =
List.concat_map (fun (e : expr) -> [ step_point fn e.loc; step_expr fn e ]) es
and step_expr (e : expr) : expr =
and step_expr fn (e : expr) : expr =
let branch (x : expr) =
match x.e with
| Do _ -> step_expr x
| _ -> { e = Do [ step_point x.loc; step_expr x ]; loc = x.loc }
| Do _ -> step_expr fn x
| _ -> { e = Do [ step_point fn x.loc; step_expr fn x ]; loc = x.loc }
in
match e.e with
| Do es -> { e with e = Do (step_body es) }
| Let (bs, es) -> { e with e = Let (bs, step_body es) }
| Do es -> { e with e = Do (step_body fn es) }
| Let (bs, es) -> { e with e = Let (bs, step_body fn es) }
| If (c, a, b) -> { e with e = If (c, branch a, Option.map branch b) }
| While (l, c, es) -> { e with e = While (l, c, step_body es) }
| Loop (bs, es) -> { e with e = Loop (bs, step_body es) }
| Dotimes (l, n, b, es) -> { e with e = Dotimes (l, n, b, step_body es) }
| While (l, c, es) -> { e with e = While (l, c, step_body fn es) }
| Loop (bs, es) -> { e with e = Loop (bs, step_body fn es) }
| Dotimes (l, n, b, es) -> { e with e = Dotimes (l, n, b, step_body fn es) }
| Match (sc, arms) ->
{ e with e = Match (sc, List.map (fun a -> { a with body = step_body a.body }) arms) }
{ e with e = Match (sc, List.map (fun a -> { a with body = step_body fn a.body }) arms) }
| _ -> e
let instrument_step (ds : decl list) : decl list option =
let instrument_step ?(fn = "step-point") (ds : decl list) : decl list option =
let hit = ref false in
let ds =
List.map
@ -546,7 +548,7 @@ let instrument_step (ds : decl list) : decl list option =
bval = { e = Var "true"; loc = d.dloc }; bloc = d.dloc }
in
{ d with
d = Defn { f with fbody = [ { e = Let ([ on ], step_body f.fbody);
d = Defn { f with fbody = [ { e = Let ([ on ], step_body fn f.fbody);
loc = d.dloc } ] } }
| _ -> d)
ds
@ -568,7 +570,7 @@ let instrument_step (ds : decl list) : decl list option =
A whole top-level [defn] is the third target from §9 and cannot be wrapped:
[(do (pause) (defn ...))] is not an expression. Marking one means stopping
on entry, so the call goes at the front of its body. *)
let mark_pause ~line ~col (ds : decl list) : decl list option =
let mark_pause ?fn ~line ~col (ds : decl list) : decl list option =
let at (l : Loc.t) = l.Loc.line = line && l.Loc.col = col in
let hit = ref false in
let rec walk (e : expr) =
@ -578,7 +580,7 @@ let mark_pause ~line ~col (ds : decl list) : decl list option =
(* The [Do] takes the target's own location, and the target keeps its
own: a wrapper at [Loc.unknown] would put the frame the break loop
reports, and the line DWARF names, nowhere. *)
{ e with e = Do [ pause_call e.loc; e ] }
{ e with e = Do [ pause_call ?fn e.loc; e ] }
end
else map_children walk e
in
@ -587,7 +589,7 @@ let mark_pause ~line ~col (ds : decl list) : decl list option =
match d.d with
| Defn f when (not !hit) && at d.dloc ->
hit := true;
{ d with d = Defn { f with fbody = pause_call d.dloc :: f.fbody } }
{ d with d = Defn { f with fbody = pause_call ?fn d.dloc :: f.fbody } }
| Defn f -> { d with d = Defn { f with fbody = body f.fbody } }
(* A method's body and a defmulti's dispatch body are code someone wrote
and can stop inside, so both are walked. Marking the whole declaration

14
lib/build.ml
View File

@ -64,8 +64,18 @@ let workdir () =
workdir_exit := Some d;
let pid = Unix.getpid () in
at_exit (fun () ->
if Unix.getpid () = pid then
try Unix.rmdir d with Unix.Unix_error _ -> ())
if Unix.getpid () = pid then begin
(* The dyn header [compile_c] leaves for every compile in the process
to include, and not a build's own: gone when it is all that is
left, kept beside a failed build's C that includes it. *)
(match Sys.readdir d with
| [| "flan_dyn.h" |] ->
(try Unix.unlink (Filename.concat d "flan_dyn.h")
with Unix.Unix_error _ -> ())
| _ -> ()
| exception Sys_error _ -> ());
try Unix.rmdir d with Unix.Unix_error _ -> ()
end)
end;
d

78
lib/dev.ml
View File

@ -213,7 +213,7 @@ let over_socket t line =
Fun.protect
~finally:(fun () -> try Unix.close s with Unix.Unix_error _ -> ())
(fun () ->
Unix.connect s (Unix.ADDR_UNIX t.agent);
Wire.connect_socket s t.agent;
let msg = line ^ "\n" in
ignore (Unix.write_substring s msg 0 (String.length msg));
let b = Bytes.create 4096 in
@ -940,8 +940,7 @@ let refusal ~parked reply =
frame boundary is the next one it reaches. That includes a running program
whose agent socket is not bound. The agent package binds it in a
constructor before [main], so the one way to be running and unbound with
the agent linked is a bind that failed — a socket path longer than
[max_socket_path], which [session_dir] refuses before building — and there
the agent linked is a bind that failed, and there
the module is still queued through the in-process call. A note saying the
program "has not called (agent/start ...)" named a cause that was not the
cause, so there is none. *)
@ -2589,11 +2588,11 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result =
up" is a claim about the body this session holds, and a
zero-slot frame whose body has since been replaced by one
with slots is a frame that claim is false about. *)
if nslots <> Array.length fn.Tast.slots then
if nslots <> Emit.recorded_slots fn then
Error
(Printf.sprintf
"%s on the stack has %d slots and the %s this session holds has %d — the frame is running a body that has been redefined since"
name nslots name (Array.length fn.Tast.slots))
name nslots name (Emit.recorded_slots fn))
else if sig_ <> Emit.slot_fingerprint fn then
(* The count matching is not the same as the body matching.
A redefinition that renames a local, or changes its type
@ -2629,7 +2628,7 @@ let eval_expr ?frame ?at_stop t ~code ~origin ~pause =
(* A frame with no slots has no locals to bind, and the program
has no table to answer for it: the expression sees globals. *)
let bound =
if Array.length fn.Tast.slots = 0 then Ok []
if Emit.recorded_slots fn = 0 then Ok []
else bound_slots t ~frame:index
in
(* [at_stop] is the stop the editor drew the frame at. It is not
@ -2678,7 +2677,7 @@ let locals t ~frame =
match stopped_frame t ~frame ~what:"locals" with
| Error m -> error m
| Ok (name, fn) ->
if Array.length fn.Tast.slots = 0 then
if Emit.recorded_slots fn = 0 then
ok
[ ":frame " ^ Wire.quote name; ":locals ()"; ":refused ()";
":note " ^ Wire.quote "this frame has no named locals" ]
@ -3458,7 +3457,7 @@ let globals_op t =
"not a function this session holds; a lifted handler clause \
has no declaration of its own to read references from"
| Some fn ->
if nslots <> Array.length fn.Tast.slots then
if nslots <> Emit.recorded_slots fn then
skip
"the frame is running a body that has been redefined \
since, so what this session holds is a different body's \
@ -5357,20 +5356,42 @@ let remove_session_dirs t =
remove t.dir;
remove (Build.workdir ())
(* The longest path a unix socket can be bound at: [sun_path] is 108 bytes on
Linux and the path is written into it with its terminating NUL. A longer one
fails at the bind, where the reason reaches nobody — the agent's constructor
drops it, and [connect] later answers "File name too long" with no path. *)
let max_socket_path = 107
(* A socket path longer than [Wire.max_socket_path] is bound through its
directory, so only a file name too long for that is refused. *)
let socket_fits ~what ~fix path =
let n = String.length path in
if n > max_socket_path then
if not (Wire.socket_fits path) then
failwith
(Printf.sprintf
"%s would be at %s, which is %d bytes long, and a unix socket path \
can be at most %d bytes. %s"
what path n max_socket_path fix)
"%s would be at %s, and its file name, %s, is too long for a unix \
socket. %s"
what path (Filename.basename path) fix)
(* An editor socket too long to connect to by path gets a symlink at
[Wire.short_socket_path], made before the bind so it is there by the time
the socket is, and removed on a clean end only while it is still this
socket's. *)
let absolute p =
if Filename.is_relative p then Filename.concat (Sys.getcwd ()) p else p
let link_short_socket sock =
if String.length sock > Wire.max_socket_path then begin
let s = Wire.short_socket_path sock in
(match (Unix.lstat s).Unix.st_kind with
| Unix.S_LNK -> (try Unix.unlink s with Unix.Unix_error _ -> ())
| _ -> ()
| exception Unix.Unix_error _ -> ());
try Unix.symlink (absolute sock) s with Unix.Unix_error _ -> ()
end
let unlink_short_socket sock =
if String.length sock > Wire.max_socket_path then begin
let s = Wire.short_socket_path sock in
match Unix.readlink s with
| target when String.equal target (absolute sock) ->
(try Unix.unlink s with Unix.Unix_error _ -> ())
| _ -> ()
| exception Unix.Unix_error _ -> ()
end
(* The directory a session keeps its program, its modules and the agent's
socket in, checked before anything is built so that a TMPDIR that cannot
@ -5378,11 +5399,6 @@ let socket_fits ~what ~fix path =
let session_dir ~file ~sock =
let tmp = Filename.get_temp_dir_name () in
let dir = Filename.concat tmp (Printf.sprintf "flan-dev-%d" (Unix.getpid ())) in
let shorter =
Printf.sprintf
"Set TMPDIR to a shorter directory, for example: TMPDIR=/tmp flan dev %s"
(Filename.quote file)
in
if not (Sys.file_exists tmp && Sys.is_directory tmp) then
failwith
(Printf.sprintf
@ -5390,10 +5406,8 @@ let session_dir ~file ~sock =
program there. Create it, or set TMPDIR to a directory that exists, \
for example: TMPDIR=/tmp flan dev %s"
tmp (Filename.quote file));
socket_fits ~what:"the program's agent socket" ~fix:shorter
(Filename.concat dir "agent.sock");
socket_fits ~what:"the editor's socket"
~fix:"Give flan dev -s a shorter path." sock;
~fix:"Give flan dev -s a shorter file name." sock;
dir
(* Made only once the program has been found to have something to run, so a
@ -5586,7 +5600,8 @@ let two_process ?(debug = false) ?(sanitize = false) ?(x86 = true) ~file ~sock (
ignore_sigpipe ();
(try Unix.unlink sock with Unix.Unix_error _ -> ());
let ls = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
Unix.bind ls (Unix.ADDR_UNIX sock);
link_short_socket sock;
Wire.bind_socket ls sock;
Unix.listen ls 4;
Printf.eprintf "flan dev: %s ready on %s (%.0fms)\n%!" file sock
((Unix.gettimeofday () -. t0) *. 1000.);
@ -5598,7 +5613,8 @@ let two_process ?(debug = false) ?(sanitize = false) ?(x86 = true) ~file ~sock (
| None -> ());
(try Unix.close ls with Unix.Unix_error _ -> ());
(try Unix.close t.stdout with Unix.Unix_error _ -> ());
(try Unix.unlink sock with Unix.Unix_error _ -> ()))
(try Unix.unlink sock with Unix.Unix_error _ -> ());
unlink_short_socket sock)
(fun () -> accept_loop t ls);
(* Here only when the loop returned: an exception out of it has already
left through the [finally]. A child killed by a signal is the crash that
@ -6448,7 +6464,8 @@ let merged_setup () =
ignore_sigpipe ();
(try Unix.unlink sock with Unix.Unix_error _ -> ());
let ls = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
Unix.bind ls (Unix.ADDR_UNIX sock);
link_short_socket sock;
Wire.bind_socket ls sock;
Unix.listen ls 4;
merged_state := Some (t, ls, sock);
Printf.eprintf "flan dev: %s ready on %s (%.0fms, one process)\n%!" file
@ -6508,6 +6525,7 @@ let merged_serve () =
in
(try Unix.close ls with Unix.Unix_error _ -> ());
(try Unix.unlink sock with Unix.Unix_error _ -> ());
unlink_short_socket sock;
(* The program is this process, so a program that crashed never gets here;
the one end that does and is not clean is the loop raising. *)
if clean then remove_session_dirs t;

2
lib/dune
View File

@ -13,7 +13,7 @@
; only C the compiler itself is built from. See lib/dynload_stubs.c.
(foreign_stubs
(language c)
(names dynload_stubs))
(names dynload_stubs spawn_stubs))
; No (c_library_flags (-ldl)): since glibc 2.34 dlopen lives in libc itself
; and libdl is a stub, and naming it breaks the merged build -- the partial
; link -output-complete-obj performs cannot resolve -ldl, so `flan dev` in

11
lib/emit.ml
View File

@ -2022,6 +2022,17 @@ let slot_fingerprint (fn : Tast.fn) =
fn.Tast.slots;
Hashtbl.hash (Buffer.contents b) land 0x3fffffff
(* How many slots a frame's record says it has: all of them when any is named,
and none otherwise, since only a function with a named slot gets a slot
table (see the shadow stack's push in [emit_fn]). Both backends write it and
[Dev] compares a frame against it, so a body whose slots are all the
compiler's own — a [print]'s temporaries — reads as the same body at both
ends. *)
let recorded_slots (fn : Tast.fn) =
if Array.exists (fun n -> n <> None) fn.Tast.snames then
Array.length fn.Tast.slots
else 0
let fninfo m (fn : Tast.fn) ~nslots =
let nid, nlen = fi_bytes m fn.Tast.name in
let lid, llen = fi_bytes m (Loc.to_string fn.Tast.floc) in

78
lib/session.ml
View File

@ -812,6 +812,21 @@ let shadowing_fns t origin =
| _ -> None)
t.decls
(* The name a prelude function the session splices a call to — [pause] for a
mark, [step-point] for the stepper — answers to in [decls]. A program's own
function or global of that name takes the name over and the prelude's is
renamed (see [Check.shadow_prelude]), and the spliced call is the
prelude's, not the program's. *)
let prelude_fn (decls : Ast.decl list) n =
let takes (d : Ast.decl) =
match d.Ast.d with
| Ast.Defn fn | Ast.Declare (fn, _) | Ast.DeclareC (fn, _) ->
String.equal fn.Ast.name n
| Ast.Defvar (m, _, _, _) | Ast.Defconst (m, _, _) -> String.equal m n
| _ -> false
in
if List.exists takes decls then Check.prelude_alias ^ "/" ^ n else n
(* [forms], when given, are [src] already read — [pruned] runs this over a
file a form fewer each round and has no text for the subset. [base] is the
file an [(import ...)] in them is resolved against, the session's own when
@ -901,7 +916,10 @@ let eval ?(origin = "<eval>") ?base ?forms ?pause ?(step = false) ?(running = tr
match pause with
| None -> incoming
| Some (line, col) ->
(match Ast.mark_pause ~line ~col incoming with
(match
Ast.mark_pause ~fn:(prelude_fn (t.decls @ incoming) "pause") ~line ~col
incoming
with
| Some ds -> ds
| None ->
fail loc "nothing to pause at line %d, column %d of the form sent"
@ -912,7 +930,10 @@ let eval ?(origin = "<eval>") ?base ?forms ?pause ?(step = false) ?(running = tr
let incoming =
if not step then incoming
else
match Ast.instrument_step incoming with
match
Ast.instrument_step ~fn:(prelude_fn (t.decls @ incoming) "step-point")
incoming
with
| Some ds -> ds
| None -> fail loc "there is no defn in the form sent to step through"
in
@ -1158,9 +1179,55 @@ let eval ?(origin = "<eval>") ?base ?forms ?pause ?(step = false) ?(running = tr
| None -> None)
program.Tast.fns
in
(* A name that takes over a prelude function's moves the prelude's body to
[Check.prelude_alias] and the prelude's own calls with it (see
[Check.shadow_prelude]). The process was built with those calls going
through the name's cell, which the new body is about to be installed
into, so the prelude's body is installed under its new name and every
body whose calls moved is compiled again: the prelude keeps its own
function, as a rebuild would give it. *)
let prelude_moved =
if not (List.exists (fun (f : Tast.fn) -> Check.internal_name f.Tast.name)
program.Tast.fns)
then []
else
let calls_moved (f : Tast.fn) (b : built) =
let hit = ref false in
let see (e : Tast.expr) =
match e.Tast.e with
| Tast.Call (m, _)
| Tast.FnAddr (Tast.Fnval m) | Tast.Closure (Tast.Fnval m, _)
when Check.internal_name m
&& not (List.exists
(fun (s : site) -> String.equal s.callee m) b.sites) ->
hit := true
| _ -> ()
in
List.iter (Tast.walk see) f.Tast.body;
List.iter (Tast.walk see) f.Tast.fdefers;
!hit
in
List.filter_map
(fun (f : Tast.fn) ->
(* A moved body not yet in the process is installed; one that is
— moved by an earlier shadowing — is compiled again like any
other when a later shadowing moves a call inside it. *)
if Check.internal_name f.Tast.name
&& not (known t f.Tast.name || SM.mem f.Tast.name t.built)
then Some f.Tast.name
else
match SM.find_opt f.Tast.name t.built with
| Some b when calls_moved f b ->
(* A lifted clause is compiled with the body it came from. *)
(match f.Tast.fparent with
| Some p when p <> "<thick>" -> Some p
| _ -> Some f.Tast.name)
| _ -> None)
program.Tast.fns
in
let fns =
List.sort_uniq String.compare
(declared_fns @ def_inits @ from_generics @ new_instances)
(declared_fns @ def_inits @ from_generics @ new_instances @ prelude_moved)
in
(* A constant that changed and can be published: known to the host, not
consumed by the checker. The module stores its new value at the frame
@ -2280,7 +2347,10 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) ?frame t src : change =
the break loop reports reads it. *)
let parsed =
if pause then
{ Ast.e = Ast.Do [ Ast.pause_call parsed.Ast.loc; parsed ];
{ Ast.e =
Ast.Do
[ Ast.pause_call ~fn:(prelude_fn t.decls "pause") parsed.Ast.loc;
parsed ];
Ast.loc = parsed.Ast.loc }
else parsed
in

6
lib/spawn.ml Normal file
View File

@ -0,0 +1,6 @@
(** Starting a program that dies with this process; see spawn_stubs.c. *)
external dying : string -> string array -> int = "flan_spawn_dying"
(** The host number of an OCaml signal number. *)
external host_signal : int -> int = "flan_host_signal"

58
lib/spawn_stubs.c Normal file
View File

@ -0,0 +1,58 @@
/* Starting a program that dies with the process that started it.
*
* `flan run` builds a program, runs it and deletes it. A flan killed by
* SIGKILL runs nothing on the way out, so without this the program would go on
* running with nobody waiting for it. On Linux the child asks the kernel for
* SIGKILL when its parent dies, between the fork and the exec; elsewhere it is
* an ordinary fork and exec.
*/
#include <caml/mlvalues.h>
#include <caml/alloc.h>
#include <caml/memory.h>
#include <caml/fail.h>
/* Exported by the runtime, declared only under CAML_INTERNALS. */
extern int caml_convert_signal_number(int);
#include <errno.h>
#include <signal.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#ifdef __linux__
#include <sys/prctl.h>
#endif
value flan_spawn_dying(value path, value argv) {
CAMLparam2(path, argv);
mlsize_t n = Wosize_val(argv), i;
char **args = malloc((n + 1) * sizeof(char *));
char *file = strdup(String_val(path));
pid_t parent = getpid(), pid;
if (args == NULL || file == NULL) caml_failwith("flan_spawn_dying: out of memory");
for (i = 0; i < n; i++) args[i] = strdup(String_val(Field(argv, i)));
args[n] = NULL;
pid = fork();
if (pid == 0) {
sigset_t none;
sigemptyset(&none);
sigprocmask(SIG_SETMASK, &none, NULL);
#ifdef __linux__
prctl(PR_SET_PDEATHSIG, SIGKILL);
/* The parent may have died before the request was made. */
if (getppid() != parent) _exit(137);
#endif
execv(file, args);
_exit(127);
}
for (i = 0; i < n; i++) free(args[i]);
free(args);
free(file);
if (pid < 0) caml_failwith(strerror(errno));
CAMLreturn(Val_int(pid));
}
/* OCaml numbers the signals it knows by negative constants; a shell's exit
* status wants the host's number. */
value flan_host_signal(value s) {
return Val_int(caml_convert_signal_number(Int_val(s)));
}

50
lib/wire.ml
View File

@ -29,6 +29,56 @@ let quote s =
let list items = "(" ^ String.concat " " items ^ ")"
let strings ss = list (List.map quote ss)
(* A unix socket path is at most 107 bytes: [sun_path] is 108 and holds the
terminating NUL. A longer one is reached through its directory instead,
opened and named as [/proc/self/fd/N/], which Linux resolves like the path
itself, so only the file's own name has to fit. The descriptor is closed as
soon as the bind or connect returns; the socket file stays where it was
made. *)
let max_socket_path = 107
let proc_prefix = String.length "/proc/self/fd/2147483647/"
let socket_fits path =
String.length path <= max_socket_path
|| String.length (Filename.basename path) + proc_prefix <= max_socket_path
let with_socket_addr path k =
if String.length path <= max_socket_path then k (Unix.ADDR_UNIX path)
else begin
let d =
Unix.openfile (Filename.dirname path) [ Unix.O_RDONLY; Unix.O_CLOEXEC ] 0
in
Fun.protect
~finally:(fun () -> try Unix.close d with Unix.Unix_error _ -> ())
(fun () ->
(* A [file_descr] is the fd number on Unix. *)
k (Unix.ADDR_UNIX
(Printf.sprintf "/proc/self/fd/%d/%s" (Obj.magic d : int)
(Filename.basename path))))
end
(* Where a client that cannot use the directory route above — Emacs, whose
[make-network-process] takes only a path — finds a socket whose own path is
too long: a symlink the daemon makes at a short path computed from the long
one, the same way on both sides. emacs/flan.el's [flan--short-socket] is
the other copy of this rule. *)
let short_socket_path path =
let abs =
if Filename.is_relative path then Filename.concat (Sys.getcwd ()) path
else path
in
let dir =
match Sys.getenv_opt "XDG_RUNTIME_DIR" with
| Some d when d <> "" && Sys.file_exists d && Sys.is_directory d -> d
| _ -> "/tmp"
in
Filename.concat dir
("flan-" ^ String.sub (Digest.to_hex (Digest.string abs)) 0 16 ^ ".sock")
let bind_socket s path = with_socket_addr path (Unix.bind s)
let connect_socket s path = with_socket_addr path (Unix.connect s)
let send fd payload =
let framed = Printf.sprintf "%d\n%s" (String.length payload) payload in
let n = String.length framed in

23
test/programs/dev-parity.flan
View File

@ -54,18 +54,19 @@
(defonce pair (Pair i32))
;; The innermost frame names every global above, so the break loop's section
;; holds all of them; then it stops. Each is stored back to itself rather than
;; printed: a frame that prints is refused attribution today (TODO.org, "A
;; frame that prints is skipped from the globals section"), and this is about
;; the values.
;; holds all of them; then it stops. It prints them, and a frame whose only
;; slots are the printer's temporaries is still attributed its globals.
;; [nowhere] is stored to itself as well: a pointer prints as <ptr> without
;; reading the variable, so printing it alone would not name it.
(defn inner [] i64
(set small small) (set mid mid) (set large large) (set huge huge)
(set neg neg) (set ratio ratio) (set far far) (set odd odd) (set yes yes)
(set byte byte) (set text text) (set colour colour) (set stray stray)
(set some some) (set none none) (set wide wide) (set deep deep)
(set dot dot) (set empty empty) (set row row) (set words words)
(set nums nums) (set live live) (set dead dead) (set nowhere nowhere)
(set un un) (set anything anything) (set pair pair)
(print small) (print mid) (print large) (print huge)
(print neg) (print ratio) (print far) (print odd) (print yes)
(print byte) (print text) (print colour) (print stray)
(print some) (print none) (print wide) (print deep)
(print dot) (print empty) (print row) (print words)
(print nums) (print live) (print dead) (print nowhere)
(print un) (print anything) (print pair) (set nowhere nowhere)
(println "")
(error (Boom {.why 3}))
0)

9
test/test_acceptance.ml
View File

@ -7340,6 +7340,15 @@ level "1"
(Printf.sprintf "run %s" (Filename.quote nomain)) ~code:1
~says:[ "has no main"; "(defn main [] i32" ];
Sys.remove nomain;
(* A program killed by a signal ends [flan run] with the shell's
128 + n for it, SIGSEGV's 139 here, not a flat 255. *)
let killed = Filename.concat scratch "killed.flan" in
Out_channel.with_open_bin killed (fun oc ->
output_string oc
"(declare-c raise [s i32] i32 \"raise\")\n(defn main [] i32 (raise 11))\n");
cli_case "run of a program killed by a signal exits 128 + n"
(Printf.sprintf "run %s" (Filename.quote killed)) ~code:139 ~says:[];
Sys.remove killed;
(* Every row above that went through the pool has been forked; nothing
after this point may look at [failures] until every one of them has

182
test/test_dev.ml
View File

@ -5832,14 +5832,11 @@ let () =
(* ── What stops a session from starting, said at the start ─────────
Three things a session cannot start without, each refused before
anything is built, in both shapes, with the fix named: a TMPDIR that
does not exist (it was an uncaught ENOENT out of mkdir), one so deep
that the agent's socket path does not fit in a unix socket address
(the bind failed where nobody heard it, and every reply after that
said "File name too long" or asked about (agent/start ...)), and a
program with no main (a link error, or a sentence about the merged
build's internals). *)
Two things a session cannot start without, each refused before
anything is built, with the fix named: a TMPDIR that does not exist (it
was an uncaught ENOENT out of mkdir), and a program with no main (a
link error, or a sentence about the merged build's internals). A TMPDIR
too deep for a socket path is not one of them; see the session below. *)
let refused_at_start what ~tmpdir ~prog ~mode want =
let out = tmp "start-refusal.out" in
let fd = Unix.openfile out [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
@ -5870,17 +5867,10 @@ let () =
want
in
let here = Filename.get_temp_dir_name () in
let deep =
Filename.concat here (String.make (max 1 (110 - String.length here)) 'd')
in
Unix.mkdir deep 0o700;
let missing = Filename.concat here "no-such-directory" in
let nomain = "programs/dev-nomain.flan" in
List.iter
(fun mode ->
refused_at_start "a TMPDIR too deep for a socket path" ~tmpdir:deep
~prog:"programs/dev-lateagent.flan" ~mode
[ "at most 107 bytes"; "TMPDIR=/tmp flan dev" ];
refused_at_start "a TMPDIR that does not exist" ~tmpdir:missing
~prog:"programs/dev-lateagent.flan" ~mode
[ missing ^ " does not exist"; "TMPDIR=/tmp flan dev" ];
@ -5890,7 +5880,157 @@ let () =
refused_at_start "a program with no main" ~tmpdir:here ~prog:nomain
~mode [ "has no main"; "(defn main [] i32"; "without --two-process" ])
[ [||]; [| "--two-process" |] ];
(try Unix.rmdir deep with Unix.Unix_error _ -> ());
(* ── A session under a TMPDIR too deep for a socket path ────────────
Both sockets are past the 107 bytes a unix socket address holds: the
editor's, named with -s, and the agent's, which the daemon puts under
TMPDIR. Both are bound and reached through their directory, so the
session starts and an evaluation reaches the program, in both shapes.
It used to be refused, and before that it failed at the bind. *)
let deep =
Filename.concat here (String.make (max 1 (110 - String.length here)) 'd')
in
Unix.mkdir deep 0o700;
List.iter
(fun mode ->
let shape = if mode = [||] then "one process" else "--two-process" in
let dsock = Filename.concat deep "editor-socket-for-a-deep-tmpdir.sock"
and dout = tmp "deep.out" in
let fd =
Unix.openfile dout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let env =
Array.append [| "TMPDIR=" ^ deep |]
(Array.of_list
(List.filter
(fun v -> not (String.starts_with ~prefix:"TMPDIR=" v))
(Array.to_list (Unix.environment ()))))
in
let pid =
Unix.create_process_env flan
(Array.append
[| flan; "dev"; "programs/dev-pause.flan"; "-s"; dsock |] mode)
env Unix.stdin fd fd
in
Unix.close fd;
if not (listening ~pid dsock) then begin
fail "a deep TMPDIR (%s): the daemon %s (%S)" shape !listen_why
(In_channel.with_open_bin dout In_channel.input_all);
(try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect dsock in
let said r =
Option.value ~default:(status r) (Wire.string_field r "message")
in
let r =
request c
"(:op \"eval\" :code \"(defn boom [] i64 7)\" :file \
\"programs/dev-pause.flan\")"
in
if status r <> "ok" then
fail "a deep TMPDIR (%s): eval: %s" shape (said r);
let answered = ref "" in
let seven () =
let r =
request c
"(:op \"eval-expr\" :code \"(boom)\" :file \
\"programs/dev-pause.flan\")"
in
answered := Option.value ~default:(said r) (Wire.string_field r "value");
!answered = "7"
in
if not (await ~ms:20000 seven) then
fail "a deep TMPDIR (%s): (boom) answered %S" shape !answered;
(try
ignore (Wire.send c "(:op \"close\")");
ignore (Wire.recv c)
with _ -> ());
(try Unix.close c with Unix.Unix_error _ -> ());
(try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] pid) with Unix.Unix_error _ -> ())
end;
(try Sys.remove dout with Sys_error _ -> ()))
[ [||]; [| "--two-process" |] ];
Own_tmp.remove deep;
(* ── Prelude functions shadowed live keep the prelude's own calls ──
[rand] and then [rand-int] redefined in a running program: the
prelude's [rand-float-range] still reaches the prelude's [rand], which
still reaches the prelude's [rand-int], so it answers something other
than what 4096 would make of it. The second shadowing moves a call
inside a body the first one had already moved. Both backends. *)
List.iter
(fun backend ->
let ssock = tmp ("shadow" ^ backend ^ ".sock")
and sout = tmp ("shadow" ^ backend ^ ".out") in
(try Sys.remove ssock with Sys_error _ -> ());
let fd =
Unix.openfile sout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let pid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-pause.flan"; "-s"; ssock; backend |]
Unix.stdin fd Unix.stderr
in
Unix.close fd;
if not (listening ~pid ssock) then begin
fail "the %s shadowing daemon %s" backend !listen_why;
(try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect ssock in
let said r =
Option.value ~default:(status r) (Wire.string_field r "message")
in
(try
List.iter
(fun code ->
let r =
request c
(Printf.sprintf
"(:op \"eval\" :code %S :file \"programs/dev-pause.flan\")"
code)
in
if status r <> "ok" then
fail "%s: %s: %s" backend code (said r))
[ "(defn rand [] f64 0.5)"; "(defn rand-int [] u64 4096)" ];
let ask code =
let r =
request c
(Printf.sprintf
"(:op \"eval-expr\" :code %S :file \"programs/dev-pause.flan\")"
code)
in
Option.value ~default:(said r) (Wire.string_field r "value")
in
(match ask "(rand-int)", ask "(rand)" with
| "4096", "0.5" -> ()
| a, b ->
fail "%s: the shadowing bodies answer %s and %s" backend a b);
(* 4096 through the prelude's rand is 2^-52, which is what the
prelude's calls answered when they followed the new body. *)
let v = ask "(rand-float-range 0.0 1.0)" in
match float_of_string_opt v with
| Some x when x > 1e-9 && x < 1.0 -> ()
| _ ->
fail "%s: the prelude's rand-float-range followed a shadowing \
body: %s" backend v
with (Wire.Closed | Unix.Unix_error _) as e ->
fail "%s: the shadowing session ended: %s" backend
(Printexc.to_string e));
(try
ignore (Wire.send c "(:op \"close\")");
ignore (Wire.recv c)
with _ -> ());
(try Unix.close c with Unix.Unix_error _ -> ());
(try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] pid) with Unix.Unix_error _ -> ())
end;
(try Sys.remove sout with Sys_error _ -> ()))
[ "--llvm"; "--x86" ];
(* ── A build that fails is a refusal, not the end of the session ── *)
@ -6241,7 +6381,7 @@ let () =
let hit_and_run () =
let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
(try
Unix.connect s (Unix.ADDR_UNIX rsock);
Wire.connect_socket s rsock;
Wire.send s "(:op \"describe\")"
with Unix.Unix_error _ -> ());
(try Unix.close s with Unix.Unix_error _ -> ())
@ -6971,6 +7111,9 @@ let () =
:: _); _ } -> n
| _ -> ""
in
(* A daemon that goes away mid-question is a failure named here, not
a [Wire.Closed] that ends the binary with every later row unrun. *)
(try
if not (await (fun () -> inside () = "in-local")) then
fail "%s: the program never stopped inside the local's assignment" flag
else begin
@ -7009,7 +7152,10 @@ let () =
(String.concat ", "
(List.map (fun (n, ty, v) -> n ^ " " ^ ty ^ " = " ^ v) got))
end
end;
end
with (Wire.Closed | Unix.Unix_error _) as e ->
fail "%s: the half-write session ended under a question: %s" flag
(Printexc.to_string e));
(* No [close]: the program is stopped with nothing left to resume into,
so the way out is the abort, and the daemon follows the program. An
abort is refused by a program that is *running*, which is what a

66
test/test_emacs.ml
View File

@ -148,3 +148,69 @@ let () =
exit 1
end
end
(* A socket path longer than a unix socket address holds, which Emacs cannot
connect to by name: the daemon links it at a short path, the client
computes the same one, and the link goes when the session is closed. *)
let () =
let have = Test_support.have in
if have "emacs" && have "clang" && have "llc" then begin
let deep =
Filename.concat Test_support.scratch
(String.make (max 1 (110 - String.length Test_support.scratch)) 'd')
in
Unix.mkdir deep 0o700;
let sock = Filename.concat deep "an-editor-socket-past-the-limit.sock"
and err = tmp "long.err" in
let efd = Unix.openfile err [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
let flan = "../bin/main.exe" in
let pid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-pause.flan"; "-s"; sock |]
Unix.stdin efd efd
in
Unix.close efd;
let short = Flan.Wire.short_socket_path sock in
let failed = ref false in
let fail fmt =
Printf.ksprintf (fun s -> failed := true; print_endline ("FAIL " ^ s)) fmt
in
if not (listening ~pid sock) then fail "the long-socket daemon %s" !listen_why
else begin
let code =
Sys.command
(Printf.sprintf
"emacs -Q --batch -L ../../../emacs -l flan --eval %s 2>&1"
(Filename.quote
(Printf.sprintf
"(progn (flan--open %S) \
(flan--send flan--connection '(:op \"describe\")) \
(let ((r (flan--read-reply flan--connection))) \
(flan--send flan--connection '(:op \"close\")) \
(ignore-errors (flan--read-reply flan--connection)) \
(delete-process flan--connection) \
(kill-emacs (if (equal (plist-get r :status) \"ok\") 0 1))))"
sock)))
in
if code <> 0 then
fail "emacs could not talk to a daemon on a %d-byte socket path \
(exit %d; daemon: %s)" (String.length sock) code
(In_channel.with_open_bin err In_channel.input_all)
end;
if not (await ~ms:5000 (fun () ->
match Unix.waitpid [ Unix.WNOHANG ] pid with
| 0, _ -> false
| _ -> true
| exception Unix.Unix_error _ -> true))
then begin
(try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] pid) with Unix.Unix_error _ -> ());
fail "the long-socket daemon did not end when the client left"
end
else if (try ignore (Unix.lstat short); true with Unix.Unix_error _ -> false)
then fail "the short link %s was left after a clean end" short;
(try Unix.unlink short with Unix.Unix_error _ -> ());
(try Sys.remove err with Sys_error _ -> ());
Own_tmp.remove deep;
if !failed then exit 1 else print_endline "emacs: a long socket path connects"
end

72
test/test_session.ml
View File

@ -265,6 +265,78 @@ let () =
if has c.Session.ir "flan_dev_cell" then
fail "a name the host has went through the registry";
(* A defn of a prelude function's name, sent live. The host's prelude calls
[rand-int] through the cell the new body goes into, so the prelude's body
moves to its own name and its callers are compiled again to call it, as
a rebuild would have them. Once: a second redefinition moves nothing. *)
(let t, _ = Session.create ~file:"programs/reload.flan" () in
let c =
Session.eval ~origin:"programs/reload.flan" t "(defn rand-int [] u64 4096)"
in
List.iter
(fun n ->
if not (List.mem n c.Session.fns) then
fail "shadowing rand-int live did not install %s: %s" n
(String.concat " " c.Session.fns))
[ "rand-int"; "prelude~/rand-int"; "rand"; "rand-int-range" ];
let c =
Session.eval ~origin:"programs/reload.flan" t "(defn rand-int [] u64 8)"
in
if c.Session.fns <> [ "rand-int" ] then
fail "redefining a shadowed rand-int again installed %s"
(String.concat " " c.Session.fns));
(* Two shadowings, in either order: the prelude body the first one moved is
compiled again when the second moves a call inside it. *)
List.iter
(fun (first, second, want) ->
let t, _ = Session.create ~file:"programs/reload.flan" () in
ignore (Session.eval ~origin:"programs/reload.flan" t first);
let c = Session.eval ~origin:"programs/reload.flan" t second in
List.iter
(fun n ->
if not (List.mem n c.Session.fns) then
fail "shadowing %S after %S did not install %s: %s" second first
n (String.concat " " c.Session.fns))
want)
[ ("(defn rand [] f64 0.5)", "(defn rand-int [] u64 4096)",
[ "rand-int"; "prelude~/rand-int"; "prelude~/rand" ]);
("(defn rand-int [] u64 4096)", "(defn rand [] f64 0.5)",
[ "rand"; "prelude~/rand" ]) ];
(* And a mark or a step once the program has a [pause] and a [step-point] of
its own: the call spliced in is still the prelude's, or a mark would run
the program's function and never stop. *)
(let t, _ = Session.create ~file:"programs/reload.flan" () in
ignore (Session.eval t "(defn pause [] i64 0)");
ignore (Session.eval t "(defn step-point [] bool false)");
let calls name want =
match
List.find_opt (fun (f : Tast.fn) -> f.Tast.name = name)
t.Session.program.Tast.fns
with
| None -> false
| Some f ->
let hit = ref false in
List.iter
(Tast.walk (fun (e : Tast.expr) ->
match e.Tast.e with
| Tast.Call (m, _) when m = want -> hit := true
| _ -> ()))
f.Tast.body;
!hit
in
ignore
(Session.eval ~pause:(1, 1) t
"(defn bump [] i64 (set counter (+ counter 5)) counter)");
if not (calls "bump" "prelude~/pause") then
fail "a mark with the program's own pause defined does not call the prelude's";
ignore
(Session.eval ~step:true t
"(defn bump [] i64 (set counter (+ counter 5)) counter)");
if not (calls "bump" "prelude~/step-point") then
fail "a step with the program's own step-point defined does not call the prelude's");
(* DWARF in a redefinition module, which is a property of the session and
not of the call. [Emit.redefinition] has taken a ~debug argument all
along and was tested with it; what was missing was anyone passing it, so

9
test/test_support.ml
View File

@ -89,7 +89,12 @@ let scratch = Own_tmp.dir
same time under dune, so "flan-agent-dev.sock" and "flan-repl-dev.sock"
being different files is what keeps two suites from unlinking each other's
sockets. *)
let tmp prefix name = Filename.concat scratch (prefix ^ name)
let tmp prefix name =
(* A socket goes without the prefix: [scratch] is this binary's alone, and a
unix socket path is short (see [Wire.max_socket_path]), which an emacs
client connecting by the plain path cannot get around. *)
if Filename.check_suffix name ".sock" then Filename.concat scratch name
else Filename.concat scratch (prefix ^ name)
(* ── Toolchain probes ─────────────────────────────────────────────── *)
@ -126,7 +131,7 @@ let rec await ?(ms = 5000) f =
disk, so the race this does catch is the only one left. *)
let rec connect ?(ms = 5000) path =
let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
match Unix.connect s (Unix.ADDR_UNIX path) with
match Wire.connect_socket s path with
| () -> s
| exception Unix.Unix_error (Unix.ECONNREFUSED, _, _) when ms > 0 ->
Unix.close s;

33
vendor/agent/flan_agent.c vendored
View File

@ -43,6 +43,7 @@
#endif
#include <dlfcn.h>
#include <errno.h>
#include <fcntl.h>
#include <stdlib.h>
#include <pthread.h>
#include <setjmp.h>
@ -1015,6 +1016,10 @@ int32_t flan_agent_poll(void);
* came from. */
static char bound_sock[sizeof(((struct sockaddr_un *)0)->sun_path)];
/* The directory a socket path too long for sun_path was bound through, or -1;
* see [start_on]. */
static int sock_dir_fd = -1;
/* A socket file outlives the process that bound it, and a stale one answers
* the next client with ECONNREFUSED — which reads like a program that is there
* and refusing rather than one that has gone. So the bind registers its own
@ -2732,10 +2737,32 @@ static int32_t start_on(const char *path) {
int made = 0;
if (atomic_exchange(&started, 1)) return 1;
len = strlen(path);
if (len == 0 || len >= sizeof addr.sun_path) goto failed;
if (len == 0) goto failed;
memset(&addr, 0, sizeof addr);
addr.sun_family = AF_UNIX;
memcpy(addr.sun_path, path, len);
if (len < sizeof addr.sun_path) {
memcpy(addr.sun_path, path, len);
} else {
/* Too long for sun_path: bound through its directory, opened and named
* as /proc/self/fd/N/, which Linux resolves like the path itself. The
* descriptor stays open for the life of the process, because the unlinks
* at exit go through the same name. */
const char *slash = strrchr(path, '/');
char dir[4096];
int n;
size_t dlen = slash == NULL ? 0 : (size_t)(slash - path);
if (slash == NULL || dlen >= sizeof dir) goto failed;
memcpy(dir, path, dlen);
dir[dlen] = '\0';
if (sock_dir_fd < 0)
sock_dir_fd = open(dlen == 0 ? "/" : dir,
O_RDONLY | O_DIRECTORY | O_CLOEXEC);
if (sock_dir_fd < 0) goto failed;
n = snprintf(addr.sun_path, sizeof addr.sun_path, "/proc/self/fd/%d/%s",
sock_dir_fd, slash + 1);
if (n < 0 || (size_t)n >= sizeof addr.sun_path) goto failed;
len = (size_t)n;
}
unlink(addr.sun_path);
fd = socket(AF_UNIX, SOCK_STREAM, 0);
if (fd < 0) goto failed;
@ -2814,7 +2841,7 @@ static const char *daemon_socket(void) {
* and guessing wrong fails silently: everything compiles, the module is built,
* and nothing ever receives it. */
int32_t flan_agent_start(const uint8_t *path, int64_t len) {
char buf[sizeof(((struct sockaddr_un *)0)->sun_path)];
char buf[4096];
const char *env = daemon_socket();
if (env != NULL) return start_on(env) < 0 ? -1 : 0;
if (len <= 0 || (size_t)len >= sizeof buf) return -1;