From 2b35085358685d24f1637b0d61637e648f4c48bc Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 22:10:07 +0700 Subject: [PATCH 01/10] flan run removes its executable and work directory when it is sent SIGTERM or SIGHUP, and the one-shot commands' empty work directory is gone from TODO.org since the exit handler already removes it --- TODO.org | 5 ----- bin/main.ml | 34 ++++++++++++++++++++++++++++++---- 2 files changed, 30 insertions(+), 9 deletions(-) diff --git a/TODO.org b/TODO.org index 1fc05579..4d9a7af9 100644 --- a/TODO.org +++ b/TODO.org @@ -1795,11 +1795,6 @@ Intermittent, on an unmodified tree too: the =--llvm= half-write daemon in =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- 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 diff --git a/bin/main.ml b/bin/main.ml index baa14c73..78ad8cef 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -949,12 +949,38 @@ 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. *) + let pid = + Unix.create_process exe (Array.of_list (exe :: prog_args)) + Unix.stdin Unix.stdout Unix.stderr 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 _ | Unix.WSTOPPED _) -> 255 + | 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) ...\n flan check ... [--warn-memory]\n flan emit [--x86] [--dev] [--debug] [--no-bounds-checks]\n\ From e0f71bba9caabc0c8c5ed1a8946d28e8f95193be Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 22:18:52 +0700 Subject: [PATCH 02/10] A unix socket path too long for sun_path is bound and reached through its directory, so flan dev runs under any TMPDIR and -s path --- lib/dev.ml | 35 +++++--------- lib/wire.ml | 32 +++++++++++++ test/test_dev.ml | 97 ++++++++++++++++++++++++++++++++------- test/test_support.ml | 9 +++- vendor/agent/flan_agent.c | 33 +++++++++++-- 5 files changed, 160 insertions(+), 46 deletions(-) diff --git a/lib/dev.ml b/lib/dev.ml index 0ee5f343..94983a82 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -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. *) @@ -5357,20 +5356,15 @@ 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) (* 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 +5372,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 +5379,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 +5573,7 @@ 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); + 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.); @@ -6448,7 +6435,7 @@ 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); + 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 diff --git a/lib/wire.ml b/lib/wire.ml index cabf274a..f1b2e581 100644 --- a/lib/wire.ml +++ b/lib/wire.ml @@ -29,6 +29,38 @@ 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 + +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 diff --git a/test/test_dev.ml b/test/test_dev.ml index 72a203bb..836fdc09 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -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,80 @@ 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; (* ── A build that fails is a refusal, not the end of the session ── *) @@ -6241,7 +6304,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 _ -> ()) diff --git a/test/test_support.ml b/test/test_support.ml index 33622278..5e739ecc 100644 --- a/test/test_support.ml +++ b/test/test_support.ml @@ -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; diff --git a/vendor/agent/flan_agent.c b/vendor/agent/flan_agent.c index e0b4c4f2..e5c687f7 100644 --- a/vendor/agent/flan_agent.c +++ b/vendor/agent/flan_agent.c @@ -43,6 +43,7 @@ #endif #include #include +#include #include #include #include @@ -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; From 285bb1047f23759911d7bd619556cdab556b76dc Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 22:24:08 +0700 Subject: [PATCH 03/10] The half-write test reports a session that closes under a question as a failure instead of ending test_dev --- TODO.org | 6 ------ test/test_dev.ml | 8 +++++++- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/TODO.org b/TODO.org index 4d9a7af9..c1920e68 100644 --- a/TODO.org +++ b/TODO.org @@ -1789,12 +1789,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. - ** 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 diff --git a/test/test_dev.ml b/test/test_dev.ml index 836fdc09..3dd86d92 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -7034,6 +7034,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 @@ -7072,7 +7075,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 From c41d27ec456169954156d3c619aae08f0c420583 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 22:26:11 +0700 Subject: [PATCH 04/10] A frame whose slots are all the compiler's own is compared against the slot count its record carries, so a frame that prints keeps its globals and locals --- TODO.org | 3 --- lib/dev.ml | 10 +++++----- lib/emit.ml | 11 +++++++++++ test/programs/dev-parity.flan | 21 ++++++++++----------- 4 files changed, 26 insertions(+), 19 deletions(-) diff --git a/TODO.org b/TODO.org index c1920e68..fa59faf1 100644 --- a/TODO.org +++ b/TODO.org @@ -1657,9 +1657,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. diff --git a/lib/dev.ml b/lib/dev.ml index 94983a82..33e10e3a 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -2588,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 @@ -2628,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 @@ -2677,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" ] @@ -3457,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 \ diff --git a/lib/emit.ml b/lib/emit.ml index fd4f6423..0ea86354 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -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 diff --git a/test/programs/dev-parity.flan b/test/programs/dev-parity.flan index f91e2993..277838a6 100644 --- a/test/programs/dev-parity.flan +++ b/test/programs/dev-parity.flan @@ -54,18 +54,17 @@ (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. (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) + (println "") (error (Boom {.why 3})) 0) From d07c7b4e2c6c7d197bbe96d414047d054dce8fff Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 22:28:58 +0700 Subject: [PATCH 05/10] A prelude function shadowed live keeps the prelude's own calls on the prelude's body, as a rebuild does --- TODO.org | 5 ----- lib/session.ml | 45 +++++++++++++++++++++++++++++++++++++++++++- test/test_session.ml | 21 +++++++++++++++++++++ 3 files changed, 65 insertions(+), 6 deletions(-) diff --git a/TODO.org b/TODO.org index fa59faf1..232707a1 100644 --- a/TODO.org +++ b/TODO.org @@ -1480,11 +1480,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 diff --git a/lib/session.ml b/lib/session.ml index 8369e89a..a759824a 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -1158,9 +1158,52 @@ let eval ?(origin = "") ?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) -> + if Check.internal_name f.Tast.name then + (if known t f.Tast.name || SM.mem f.Tast.name t.built then None + else 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 <> "" -> 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 diff --git a/test/test_session.ml b/test/test_session.ml index 241a5ef7..2f64cf33 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -265,6 +265,27 @@ 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)); + (* 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 From ccdadeeb6e478ac930febb6fc746ec6ab82a5d58 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 22:34:28 +0700 Subject: [PATCH 06/10] A mark or a step spliced into a program that defines its own pause or step-point calls the prelude's --- TODO.org | 2 ++ lib/ast.ml | 40 +++++++++++++++++++++------------------- lib/session.ml | 30 +++++++++++++++++++++++++++--- test/test_session.ml | 33 +++++++++++++++++++++++++++++++++ 4 files changed, 83 insertions(+), 22 deletions(-) diff --git a/TODO.org b/TODO.org index 232707a1..939ae6dc 100644 --- a/TODO.org +++ b/TODO.org @@ -1919,6 +1919,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] diff --git a/lib/ast.ml b/lib/ast.ml index 7ab6b16e..210a5738 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -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 diff --git a/lib/session.ml b/lib/session.ml index a759824a..b60917ed 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -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 = "") ?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 = "") ?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 @@ -2323,7 +2344,10 @@ let eval_expr ?(origin = "") ?(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 diff --git a/test/test_session.ml b/test/test_session.ml index 2f64cf33..2beb7a28 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -286,6 +286,39 @@ let () = fail "redefining a shadowed rand-int again installed %s" (String.concat " " c.Session.fns)); + (* 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 From eb08f1300df3840dd4db6ff5ca894f6fd684b691 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 22:40:04 +0700 Subject: [PATCH 07/10] dev-parity keeps its pointer global named beside the prints, since a pointer prints without reading it --- test/programs/dev-parity.flan | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/test/programs/dev-parity.flan b/test/programs/dev-parity.flan index 277838a6..f079ec36 100644 --- a/test/programs/dev-parity.flan +++ b/test/programs/dev-parity.flan @@ -56,6 +56,8 @@ ;; The innermost frame names every global above, so the break loop's section ;; 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 without +;; reading the variable, so printing it alone would not name it. (defn inner [] i64 (print small) (print mid) (print large) (print huge) (print neg) (print ratio) (print far) (print odd) (print yes) @@ -63,7 +65,7 @@ (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) + (print un) (print anything) (print pair) (set nowhere nowhere) (println "") (error (Boom {.why 3})) 0) From 6583392504f3f9767a9253b31f264e8b09b7a2f6 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 22:51:02 +0700 Subject: [PATCH 08/10] A prelude body moved by one live shadowing is compiled again when a later shadowing moves a call inside it --- lib/session.ml | 9 ++++-- test/test_dev.ml | 77 ++++++++++++++++++++++++++++++++++++++++++++ test/test_session.ml | 18 +++++++++++ 3 files changed, 101 insertions(+), 3 deletions(-) diff --git a/lib/session.ml b/lib/session.ml index b60917ed..dc4683b5 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -1209,9 +1209,12 @@ let eval ?(origin = "") ?base ?forms ?pause ?(step = false) ?(running = tr in List.filter_map (fun (f : Tast.fn) -> - if Check.internal_name f.Tast.name then - (if known t f.Tast.name || SM.mem f.Tast.name t.built then None - else Some f.Tast.name) + (* 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 -> diff --git a/test/test_dev.ml b/test/test_dev.ml index 3dd86d92..46a4eb4c 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -5955,6 +5955,83 @@ let () = [ [||]; [| "--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 ── *) (* Evaluating runs a compiler, and a compiler can fail in ways the diff --git a/test/test_session.ml b/test/test_session.ml index 2beb7a28..3fdda3f9 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -286,6 +286,24 @@ let () = 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. *) From 69ac194ba714df5e1fe4fae1da3d547835f41ad4 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 22:54:44 +0700 Subject: [PATCH 09/10] An editor socket path too long to connect to is linked at a short path the Emacs client computes the same way --- emacs/flan.el | 22 +++++++++++++++- lib/dev.ml | 33 ++++++++++++++++++++++- lib/wire.ml | 18 +++++++++++++ test/test_emacs.ml | 66 ++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 137 insertions(+), 2 deletions(-) diff --git a/emacs/flan.el b/emacs/flan.el index 6f5f576e..1f8ca0db 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -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)) diff --git a/lib/dev.ml b/lib/dev.ml index 33e10e3a..028e350a 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -5366,6 +5366,33 @@ let socket_fits ~what ~fix path = 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 hold one is said once, at the start, in words. *) @@ -5573,6 +5600,7 @@ 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 + 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 @@ -5585,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 @@ -6435,6 +6464,7 @@ 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 + link_short_socket sock; Wire.bind_socket ls sock; Unix.listen ls 4; merged_state := Some (t, ls, sock); @@ -6495,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; diff --git a/lib/wire.ml b/lib/wire.ml index f1b2e581..a2d161b8 100644 --- a/lib/wire.ml +++ b/lib/wire.ml @@ -58,6 +58,24 @@ let with_socket_addr path k = (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) diff --git a/test/test_emacs.ml b/test/test_emacs.ml index c2b2ebe1..13364e97 100644 --- a/test/test_emacs.ml +++ b/test/test_emacs.ml @@ -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 From bdda16a4618acab35ccc762720fd7a31848e162b Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 22:57:02 +0700 Subject: [PATCH 10/10] flan run's program dies with flan, and a program killed by a signal ends flan run with 128 plus its number --- bin/main.ml | 10 +++---- lib/build.ml | 14 ++++++++-- lib/dune | 2 +- lib/spawn.ml | 6 +++++ lib/spawn_stubs.c | 58 +++++++++++++++++++++++++++++++++++++++++ test/test_acceptance.ml | 9 +++++++ 6 files changed, 90 insertions(+), 9 deletions(-) create mode 100644 lib/spawn.ml create mode 100644 lib/spawn_stubs.c diff --git a/bin/main.ml b/bin/main.ml index 78ad8cef..324fced9 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -954,11 +954,9 @@ let () = 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. *) - let pid = - Unix.create_process exe (Array.of_list (exe :: prog_args)) - Unix.stdin Unix.stdout Unix.stderr - in + 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 _ -> @@ -972,7 +970,7 @@ let () = let rec wait () = match Unix.waitpid [] pid with | _, Unix.WEXITED c -> c - | _, (Unix.WSIGNALED _ | Unix.WSTOPPED _) -> 255 + | _, (Unix.WSIGNALED s | Unix.WSTOPPED s) -> 128 + Flan.Spawn.host_signal s | exception Unix.Unix_error (Unix.EINTR, _, _) -> wait () in let code = wait () in diff --git a/lib/build.ml b/lib/build.ml index 9b25b1d9..f52fb648 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -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 diff --git a/lib/dune b/lib/dune index c2d5b71a..be79d9f4 100644 --- a/lib/dune +++ b/lib/dune @@ -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 diff --git a/lib/spawn.ml b/lib/spawn.ml new file mode 100644 index 00000000..85baac85 --- /dev/null +++ b/lib/spawn.ml @@ -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" diff --git a/lib/spawn_stubs.c b/lib/spawn_stubs.c new file mode 100644 index 00000000..f8ab49a0 --- /dev/null +++ b/lib/spawn_stubs.c @@ -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 +#include +#include +#include +/* Exported by the runtime, declared only under CAML_INTERNALS. */ +extern int caml_convert_signal_number(int); +#include +#include +#include +#include +#include +#ifdef __linux__ +#include +#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))); +} diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index dd1821ca..1d8b7ed1 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -7316,6 +7316,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