diff --git a/FIX.org b/FIX.org index aef70c6..b421948 100644 --- a/FIX.org +++ b/FIX.org @@ -4143,6 +4143,30 @@ took compiler, socket and session down together. the no-channel traps — the daemon stays alive, describe answers :condition "SegFault", evals still run. Release builds are untouched. +** Found by review, fixed on the same branch +- The park had the original bug inside it. sigaction without SA_NODEFER + blocks the handler's own signal for the whole handler, and here the + handler *is* the park — it never returns. A hardware SIGSEGV delivered + while SIGSEGV is blocked is not handled at all: the kernel forces the + default action. So fault, park, evaluate something at the break loop that + faults, and the daemon died exactly the way the author's session did. + Measured both ways before and after the flag. SA_NODEFER added, + flan_crash_entered cleared before the hook so each break-loop fault gets + its own line, and the case is pinned (trap_park ~refault:true) — the pin + was confirmed to fail without the flag rather than pass vacuously. +- A disposition is per process, and a merged `flan dev' is one process with + the daemon in it: the handler was shadowing OCaml's SIGSEGV handler for + the daemon's whole life, including after the program run ended, which + turns a daemon-side stack overflow into a park instead of Stack_overflow. + Scoped to the thread it was armed on; other threads chain to whatever was + installed before. Arming per *run* was considered and is wrong — a + finished program still runs Flan from flan_merged_park's poll, so every + C-x C-e at the parked prompt would have been left unprotected. The thread + test also makes the per-thread sigaltstack honest, since only the armed + thread has one. +- wasm32 compiles flan_dev.c and has no signals; the section is guarded and + flan_dev_crash_enable is a no-op there. + ** Open directions left here - Read-only slice types. bytes-view is read-only *by convention* only: the type system has no way to say a [u8] cannot be stored through, so the diff --git a/lib/check.ml b/lib/check.ml index 445adeb..529ae1d 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -7550,7 +7550,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = mk loc index_ty (Tast.Int (-1L, Types.I32)); size_of loc u8; here loc ] in - expect loc ~want + expect ctx loc ~want (mk loc (Types.Slice u8) (Tast.Let ([ (sv, s); diff --git a/lib/emit.ml b/lib/emit.ml index f5d59b7..88ee26a 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -3831,7 +3831,6 @@ declare void @flan_dyn_root_globals_begin() declare void @flan_dyn_root_globals_end() declare void @flan_gc_init() declare void @flan_dev_reg_enable() -declare void @flan_dev_crash_enable() declare void @flan_dev_reg_note_vec(ptr, i64, ptr, i64) declare void @flan_dev_reg_note_map(ptr, i64, i64, ptr, i64) declare i8 @flan_vec_init(ptr, ptr, i64, i64, i64, ptr, i64) @@ -4354,6 +4353,14 @@ let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = []) "@llvm.global_ctors = appending global [2 x { i32, ptr, ptr }] \ [{ i32, ptr, ptr } { i32 65535, ptr @flan_dev_reg_enable, ptr null }, \ { i32, ptr, ptr } { i32 65535, ptr @flan_dev_crash_enable, ptr null }]\n"; + (* Declared here rather than in the preamble, which is the one place a + declare is worth gating: this lane then adds no dev-only text at all to + a release module, and the only line it does add there — + [flan_bytes_dup] — is a function release builds really call, since + (bytes s) allocates in every build. The neighbouring + [flan_dev_reg_enable] stays in the preamble ungated; it predates this + and moving it is not this lane's to make. *) + Buffer.add_string m.out "declare void @flan_dev_crash_enable()\n"; Buffer.add_char m.out '\n' end; List.iter (emit_global m ~hidden) p.Tast.globals; diff --git a/runtime/flan_dev.c b/runtime/flan_dev.c index 84cd82f..9c8205a 100644 --- a/runtime/flan_dev.c +++ b/runtime/flan_dev.c @@ -1863,22 +1863,67 @@ static void flan_reg_report(void) { * because the commonest dev segfault is a stack overflow and a handler * on the overflowed stack never runs. Thunks evaluated while parked run * on that stack too, so it is a real stack, not a landing pad. - * - A fault inside the handler (or a second fault while parked) restores - * the default disposition and re-raises: one loud death, never a loop. - * - In a merged `flan dev' this shadows the OCaml runtime's own SIGSEGV - * handler, which it uses to turn daemon-side stack overflow into a - * Stack_overflow exception. That trade is accepted with eyes open: the - * program faulting is the case that happens, the daemon overflowing its - * OCaml stack is not. + * - A fault inside the *reporting* restores the default disposition and + * re-raises: one loud death, never a loop. A fault raised by something + * evaluated while parked is a different case and gets its own line and + * its own break — see the clear of [flan_crash_entered] below, and + * SA_NODEFER, without which neither could happen at all. + * - A disposition is per *process*, and in a merged `flan dev' the daemon + * is that same process: the compiler thread and the agent's listener run + * alongside the program, and OCaml installs a SIGSEGV handler of its own + * to turn a daemon-side stack overflow into [Stack_overflow] (lib/dev.ml + * deliberately lets that propagate). So this handler is scoped to the + * ONE thread it was armed on — the thread the constructor ran on, which + * is the thread that runs the program, since .init_array runs before any + * other is spawned and [flan_program_main] wants the main thread for + * raylib's sake. A fault on any other thread chains to whatever was + * installed before, which is OCaml's handler, so the daemon keeps its + * own behaviour unchanged. + * + * Scoping by thread rather than by run is deliberate. The obvious + * alternative — arm at the start of a run and restore when it ends — + * is wrong here, because a finished program does not stop running Flan: + * [flan_merged_park] polls from the parked process and every C-x C-e + * typed at that prompt executes program code on this same thread. + * Restoring at the end of the run would leave exactly those evaluations + * unprotected, which is the crash this whole section exists to stop. + * The thread test holds for the whole life of the process instead, and + * needs nothing to remember where a run began or ended. + * + * It is also what keeps the alternate stack honest: [sigaltstack] is + * per-thread, so only the armed thread has one, and a thread without one + * would run this handler on the stack that just overflowed. Those are + * now the same set of threads by construction. * - Under ASan the sanitizer's handler is the better report and arrives * armed before any constructor here; detected (the weak __asan_init) - * and left alone. + * and left alone. That skip is the one path here no test drives — it + * needs the @sanitize sweep, not `dune test'. + * - The report goes to fd 2 by write(2), where the break loop's own + * listing already goes. What nobody has checked is whether a merged + * build that routes fd 1 into a pipe leaves fd 2 somewhere an editor + * actually shows; if a session ever reports a park with no line above + * it, that is the first thing to look at, and the park itself is + * visible over the socket regardless (describe answers "SegFault"). * * Installed by a global constructor the compiler emits ONLY into dev builds, * next to the one that arms the allocation registry — a release build never * calls this, links no constructor naming it, and dies the way it always * did. */ +/* wasm32 has no signals at all — its is an #error unless a build + * asks for emulation — and it has no daemon to keep alive either: there is + * no merged `flan dev' in a browser, so the crash this section exists to + * survive cannot happen there. The symbol still has to resolve, because the + * constructor the emitter writes for a dev build does not know the target, + * so the whole section reduces to a no-op. Same guard shape flan_rt.c uses + * for the two things it cannot have there. */ +#if defined(__wasm__) + +void flan_dev_crash_enable(void) {} + +#else + +#include #include #include @@ -1887,6 +1932,34 @@ extern void __asan_init(void) __attribute__((weak)); static volatile sig_atomic_t flan_crash_entered; +/* The thread this was armed on, and what was installed before it — the two + * halves of the scoping the header describes. [crash_prev] is kept per + * signal so that a chained SIGBUS is not handed SIGSEGV's old handler. */ +static pthread_t crash_thread; +static struct sigaction crash_prev_segv, crash_prev_bus; + +/* Hand the fault to whoever had the signal before this did. Three + * dispositions to honour and they are not interchangeable: a handler is + * called (SA_SIGINFO decides with which signature), SIG_DFL means restore + * and re-raise so the process dies the way it would have, and SIG_IGN on a + * hardware fault is not ignorable at all — the kernel forces the default — + * so it takes the same path as SIG_DFL rather than returning into an + * instruction that would fault again forever. */ +static void crash_chain(int sig, siginfo_t *si, void *uc) { + const struct sigaction *p = sig == SIGBUS ? &crash_prev_bus : &crash_prev_segv; + if ((p->sa_flags & SA_SIGINFO) != 0 && p->sa_sigaction != NULL) { + p->sa_sigaction(sig, si, uc); + return; + } + if (p->sa_handler != SIG_DFL && p->sa_handler != SIG_IGN + && p->sa_handler != NULL) { + p->sa_handler(sig); + return; + } + signal(sig, SIG_DFL); + raise(sig); +} + /* write(2) and byte-spelling only: the fault may have landed anywhere, * including inside stdio. */ static void crash_puts(const char *s, size_t n) { @@ -1904,7 +1977,12 @@ static void crash_hex(uintptr_t x) { } static void crash_handler(int sig, siginfo_t *si, void *uc) { - (void)uc; + /* Not the program's thread: this is the daemon's own fault to deal with, + * and OCaml's handler is the one that knows how. See the header. */ + if (!pthread_equal(pthread_self(), crash_thread)) { + crash_chain(sig, si, uc); + return; + } if (flan_crash_entered++) goto die; crash_puts("\nflan: ", 7); if (sig == SIGBUS) crash_puts("SIGBUS", 6); else crash_puts("SIGSEGV", 7); @@ -1928,6 +2006,15 @@ static void crash_handler(int sig, siginfo_t *si, void *uc) { crash_puts(why, sizeof why - 1); } if (flan_trap_hook != NULL) { + /* Cleared before the park, not after it, and this is the whole reason + * the guard is armed so narrowly. The park below runs arbitrary Flan — + * every C-x C-e typed at the break loop — so a *second* fault down there + * is a new fault in new code and deserves its own line and its own + * break, not the guard's silent death. What the guard still covers is a + * fault in the reporting above, where a second attempt would only fault + * again. The break loop's own BREAK_MAX is what stops a loop of these + * from nesting forever. */ + flan_crash_entered = 0; /* Parks for good, exactly like NullAllocator and the other no-channel * traps: there is no address to resume *at* — the faulting instruction * would fault again — so this is a place to stand and read. */ @@ -1956,8 +2043,23 @@ void flan_dev_crash_enable(void) { if (ss.ss_sp == NULL || sigaltstack(&ss, NULL) != 0) return; memset(&sa, 0, sizeof sa); sa.sa_sigaction = crash_handler; - sa.sa_flags = SA_SIGINFO | SA_ONSTACK; + /* SA_NODEFER is load-bearing and was the original bug relocated. Without + * it the kernel blocks this signal for the whole handler — which here is + * the whole *park*, since the loop never returns — and a hardware SIGSEGV + * delivered while SIGSEGV is blocked is not queued or handled: the kernel + * forces the default action and the process dies on the spot, with no + * message. That is exactly the author's vanished session, one level in: + * fault, park, evaluate something at the break loop that faults, daemon + * gone. With SA_NODEFER the second fault re-enters this handler, which is + * what makes [flan_crash_entered] a guard that can actually run. */ + sa.sa_flags = SA_SIGINFO | SA_ONSTACK | SA_NODEFER; sigemptyset(&sa.sa_mask); - sigaction(SIGSEGV, &sa, NULL); - sigaction(SIGBUS, &sa, NULL); + /* Recorded before the install, not after: once [sigaction] returns, a + * fault can arrive, and a handler that has not yet learned which thread it + * belongs to would take the daemon's faults as the program's. */ + crash_thread = pthread_self(); + sigaction(SIGSEGV, &sa, &crash_prev_segv); + sigaction(SIGBUS, &sa, &crash_prev_bus); } + +#endif /* !__wasm__ */ diff --git a/test/programs/exhausted.flan b/test/programs/exhausted.flan index 6a4eb97..34688d9 100644 --- a/test/programs/exhausted.flan +++ b/test/programs/exhausted.flan @@ -86,6 +86,35 @@ (free v))) (println (> failures 0)) ; true + ;; And (bytes s), which became an allocating operation when it stopped + ;; aliasing the string (FIX.org, the INSERTIONSORT crash). It is under the + ;; same rule as everything above and had better prove it: the copy is one + ;; request for the string's whole length, so a ceiling below that fails it + ;; outright, the handler raises the ceiling and retries, and what comes back + ;; is the complete copy rather than a short one. + ;; + ;; The retry is the half worth pinning. The string is bound to a slot before + ;; the guard's loop — the same rule push follows for its element — so a + ;; retry re-attempts the *copy* and never re-evaluates the expression that + ;; produced the string. A second evaluation would be invisible here if the + ;; bytes were right, which is exactly why the count is asserted too. + (set-alloc-budget tight 8) + (set failures 0) + (handler-bind + [(StorageExhausted [c] + (set failures (+ failures 1)) + (set-alloc-budget tight 4096) + (invoke-restart 'retry))] + (let [b (bytes "INSERTIONSORT" tight)] + (println (len b)) ; 13 — the whole string, not a prefix + (println (at b 0)) ; 73 — \I + (println (at b 12)) ; 84 — \T, the last byte + ;; Writable, which is the point of the copy, and the literal is untouched. + (set (at b 0) \Z) + (println (at b 0)) ; 90 + (println "INSERTIONSORT"))) ; INSERTIONSORT + (println failures) ; 1 — failed once, retried once + ;; And the restart is not once-per-program: it is established at each ;; allocation, so a later one offers it again. (set-alloc-budget tight 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 43a33e7..bb781ce 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -1538,7 +1538,10 @@ let () = the whole block at once and clone asks for the source's length. At -O0 because the retry loop and the guard after the error are control flow an optimiser would otherwise launder. *) - let exhausted_out = "64\n0\n126\ntrue\ntrue\n4\ntrue\n0\n8\n7\ntrue\n" in + let exhausted_out = + "64\n0\n126\ntrue\ntrue\n4\ntrue\n0\n8\n7\ntrue\n\ + 13\n73\n84\n90\nINSERTIONSORT\n1\n" + in outputs "storage exhausted, retried" "programs/exhausted.flan" exhausted_out; outputs ~opt:"-O0" "storage exhausted, retried, -O0" "programs/exhausted.flan" exhausted_out; diff --git a/test/test_dev.ml b/test/test_dev.ml index 1ef0b4e..fb53d20 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -1527,7 +1527,7 @@ let () = standalone half of the same claim is test_acceptance.ml's free-all-refused, which still exits 134: nothing installs the hook in a program that did not import the agent. *) - let trap_park what prog cond restarts = + let trap_park ?(refault = false) what prog cond restarts = let tsock = tmp (prog ^ ".sock") and tout = tmp (prog ^ ".out") in (try Sys.remove tsock with Sys_error _ -> ()); let tfd = @@ -1643,6 +1643,39 @@ let () = if Wire.string_field r "value" <> Some "4" then fail "an expression while parked at the %s trap: %s" what (Option.value ~default:(status r) (Wire.string_field r "message")); + (* And the fault taken *while already parked*, which is the first + bug this whole section fixed, relocated one level in. A handler + installed without SA_NODEFER leaves its own signal blocked for + the life of the park — and the park never returns — so a second + hardware SIGSEGV is not delivered to it at all: the kernel + forces the default action and the process dies on the spot with + no message. Fault, park, evaluate something at the break loop + that faults, daemon gone, exactly the way the author's session + went. Measured before the flag was added: the evaluation below + got no reply and the next request found a dead socket. + + What is asserted is only the part that matters — that the + daemon is still there afterwards. The faulting evaluation's own + reply is an error either way (the thunk never reaches a frame + boundary) and is not worth pinning a sentence of. *) + if refault then begin + let faulting = + "(:op \"eval-expr\" :code \ + \"(let [v (bytes-view \\\"refault\\\")] (set (at v 0) 90) 1)\" \ + :file \"/tmp/buf.flan\")" + in + (match ask faulting with _ -> () | exception _ -> ()); + let r = + try + ask "(:op \"eval-expr\" :code \"(+ 2 2)\" :file \"/tmp/buf.flan\")" + with _ -> Wire.parse "(:status \"gone\")" + in + if Wire.string_field r "value" <> Some "4" then + fail + "a second fault at the %s break killed the daemon — the park \ + is only as good as SA_NODEFER: %s" + what (status r) + end; (* Torn down by [abort], not by [close]: a trap parks for good, so there is no resume to wait for and nothing to gain by waiting. @@ -1683,7 +1716,7 @@ let () = asserts for them holds here too: stopped and describable, an eval still answered, a resume refused. The program writes through bytes-view, which is the surviving spelling of that crash. *) - trap_park "segfault" "dev-segv.flan" "SegFault" []; + trap_park ~refault:true "segfault" "dev-segv.flan" "SegFault" []; (* ── The locals of a stopped frame ─────────────────────────────── *)