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

A defer the text never reached is not cleanup the unwind owes

Browse Source 
The report was that handler-case segfaults in a top-level global
initialiser. It does not, and never did. What crashes is one frame
further down, in a position that has nothing to do with startup:

    (defn read-file [path string] dyn
      (let [src (slurp path (heap-allocator))]
        (defer (free src))
        (read (as-slice src))))

slurp signals FileError, a handler further out unwinds, and the
transfer leaves this frame through its defers -- all of them. But src
was never written: the form that would have written it is the form
that transferred. free then reads whatever the stack held under that
slot, which at -O0 in a small program is zero and at -O2 is a live
pointer, which is why the same program looked like an optimiser bug
from one direction and a startup bug from the other.

return never had this. The checker splices the defers registered above
it and no others, and says so where it does it. The transfer exit took
the whole list, because it is one landing block per function and
nothing in the IR said where each defer had come into being.

So the count is kept. The first defer in a function mints an i64 slot
zeroed at the top of the body; each defer leaves a store of its own
number where it was written; and fdefers -- the transfer path's copy,
and only that copy -- tests the count before running each one. The
normal paths are untouched and still need no test. It is all in the
checker: what reaches a backend is a slot, a store and an if, so
neither emitter learned anything and the x86 one needed no frame of
its own.

test/programs/init-conditions.flan is the survey. The top half is the
part of the report that was never true: handler-case with its
condition firing and with its body completing, handler-bind, and a
restart-case, all four in a global initialiser, all four answering
what they answer anywhere. The bottom half is the part that was: a
defer below the signalling form, which must not run, beside one above
it, which must -- a fix that took the unregistered one off by taking
them all off would have traded the crash for a leak, and 302/2 is the
line that would catch it. Three acceptance rows, LLVM, -O0 and --x86.

The detector was valgrind, not ASan: reading a stack slot nobody wrote
is not ASan's bug class and it reported nothing on the broken binary,
while memcheck named the conditional jump in flan_vec_free with the
unwinding frame directly above it. The program is in both lists --
test_valgrind.ml because that is what saw it, test_sanitize.ml because
that is where the transfer exit's frames are already watched.

spec-conditions.md section 5 now says which defers a transfer runs.
The author's (defvar game-data dyn (handler-case (edn/read-file ...)
[(FileError [c] nil)])) works.
This commit is contained in:
Joseph Ferano 2026-09-19 21:40:23 +07:00
parent c3e0703642
commit 4c667cf062
7 changed files with 309 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

115
lib/check.ml
View File

@ -237,6 +237,22 @@ type ctx = {
function and not to a block — see [defer_ok] for where one may be written
and [check_fn] for where the list is spliced onto the exit paths. *)
mutable defers : Tast.expr list;
(* The slot that counts how many of them have registered, minted on the
first [defer] this function writes and [None] until then.
The normal exit paths need no such thing: falling off the end is below
every defer in the text, and a [return] splices the ones registered
above it, both of which are decided while checking. The *transfer* exit
is the one path that is not, because a transfer can start anywhere,
including in the initialiser of the very [let] whose body the defer is
written in — and that defer has not registered yet. Running it there is
not a leak the other way round; it is cleanup over a binding nothing has
written, which is [(free v)] on whatever the stack held.
So the count is kept at run time, one store per defer, and the transfer
path's copy of each is guarded on it. One i64 and one compare per defer
on a path that is already unwinding. *)
mutable defer_slot : int option;
(* Where a [defer] may be written, which is exactly: a form whose extent is
the whole function body. Two things have that extent and only two — a
top-level form of the body, and a form in the body of a [let] that itself
@ -1542,7 +1558,7 @@ let hash_ty = Types.Int Types.U64
none of these is a body anyone wrote. *)
let invented_ctx env ret =
{ env; ret; slots = 0; slot_tys = []; slot_names = []; scope = [];
defers = []; outer = []; outer_what = None; in_frames = None; loops = []; tail = false;
defers = []; defer_slot = None; outer = []; outer_what = None; in_frames = None; loops = []; tail = false;
in_defer = false; defer_ok = false; defer_block = "a nested form";
owner = "<none>" }
@ -2345,7 +2361,7 @@ and check_fn ctx ~want loc (params : string list) body =
is really refused for. *)
let fctx =
{ env = ctx.env; ret; slots = 0; slot_tys = []; slot_names = [];
scope = []; defers = []; outer = ctx.scope;
scope = []; defers = []; defer_slot = None; outer = ctx.scope;
outer_what = Some "an fn"; in_frames = None; loops = []; tail = false;
in_defer = false; defer_ok = false; defer_block = "a nested form";
owner = ctx.owner }
@ -2427,7 +2443,7 @@ and check_handler_bind ctx ?want ?(what = "handler-bind") loc clauses body =
the enclosing one. *)
let hctx =
{ env = ctx.env; ret = Types.Unit; slots = 0; slot_tys = []; slot_names = [];
scope = []; defers = []; outer = ctx.scope; outer_what = Some "a handler"; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; owner = "<none>" }
scope = []; defers = []; defer_slot = None; outer = ctx.scope; outer_what = Some "a handler"; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; owner = "<none>" }
in
(* The condition crosses as a pointer, because the handler runs while
the signalling frame is still alive and there is nothing to copy.
@ -2710,8 +2726,11 @@ and check_handler_case ctx ?want loc body clauses =
let tbody = check_handler_bind ctx ?want ~what loc handlers [ body ] in
restart_clauses ctx ?want ~what loc tbody landings
(* The forms of a [defer], checked in place and hung on the function. It emits
nothing where it stands, so what is left behind is [unit]. *)
(* The forms of a [defer], checked in place and hung on the function. What is
left where it stands is one store: this defer's number into the counter
[defer_slot] describes, which is how the transfer exit tells a defer that
has registered from one the text has not reached yet. The form's type is
still [unit], which is all a reader of the value can see. *)
and register_defer ctx loc forms =
ctx.in_defer <- true;
(* A barrier, for the reason [defer] itself exists: these forms are *copied*
@ -2723,7 +2742,49 @@ and register_defer ctx loc forms =
in
ctx.in_defer <- false;
ctx.defers <- mk loc Types.Unit (Tast.Do forms) :: ctx.defers;
unit_at loc
let slot =
match ctx.defer_slot with
| Some s -> s
| None ->
let s = fresh_slot ctx (Types.Int Types.I64) in
ctx.defer_slot <- Some s;
s
in
mk loc Types.Unit
(Tast.Set
(Tast.Plocal slot,
mk loc (Types.Int Types.I64)
(Tast.Int (Int64.of_int (List.length ctx.defers), Types.I64))))
(* The transfer exit's copy of the defers, each under the count that says it
registered. [ds] is innermost first, so the last one registered is at the
head and the [j]th from the end is defer number [j].
The zero the counter starts at is written by [defer_counter_zero] below, at
the top of the body: a slot is an alloca like any other and holds whatever
the stack held until something stores to it, which at -O2 is not zero and
is exactly how this was found. *)
and guarded_defers slot (ds : Tast.expr list) =
let n = List.length ds in
List.mapi
(fun i (d : Tast.expr) ->
let loc = d.Tast.loc in
let i64 = Types.Int Types.I64 in
let test =
mk loc Types.Bool
(Tast.Prim
(Tast.Ge,
[ mk loc i64 (Tast.Local slot);
mk loc i64 (Tast.Int (Int64.of_int (n - i), Types.I64)) ]))
in
mk loc Types.Unit (Tast.If (test, d, unit_at loc)))
ds
and defer_counter_zero slot loc =
mk loc Types.Unit
(Tast.Set
(Tast.Plocal slot,
mk loc (Types.Int Types.I64) (Tast.Int (0L, Types.I64))))
(* [defer_ok] says whether *this* let has the function's extent. If it does, so
does every form in its body, including a nested let — which is why the flag
@ -6560,7 +6621,7 @@ let collect env (decls : Ast.decl list) =
not check once no progress is left has a real error, so the last round is
run without swallowing it. *)
let infer (_, v) =
(check { env; ret = Types.Unit; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = [];
(check { env; ret = Types.Unit; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = []; defer_slot = None;
outer = []; outer_what = None; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; owner = "<none>" } v).Tast.ty
in
let pending = ref (List.rev !untyped) in
@ -6689,7 +6750,7 @@ let check_union_members env =
let rec check_fn env (fn : Ast.fn) : Tast.fn =
let params, ret = Hashtbl.find env.fns fn.Ast.name in
let ctx = { env; ret; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = [];
let ctx = { env; ret; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = []; defer_slot = None;
outer = []; outer_what = None; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form";
owner = fn.Ast.name } in
List.iter2
@ -6767,12 +6828,27 @@ let rec check_fn env (fn : Ast.fn) : Tast.fn =
init @ [ mk loc ret
(Tast.Let ([ (s, last) ], ds @ [ mk loc ret (Tast.Local s) ])) ]
in
(* The counter's zero, at the top of the body and above every store to it.
Nothing else in the function reads the slot, so this is the whole of its
cost on the path that never transfers. *)
let body =
match ctx.defer_slot with
| None -> body
| Some s -> defer_counter_zero s fn.Ast.nloc :: body
in
{ Tast.name = fn.Ast.name; params;
slots = Array.of_list (List.rev ctx.slot_tys);
snames = Array.of_list (List.rev ctx.slot_names);
(* The same defers again, for the transfer exit path §5 describes. The
normal path has them spliced into [body] above. *)
ret; body; fdefers = ctx.defers; fparent = None; floc = fn.Ast.nloc }
normal path has them spliced into [body] above; this one is guarded on
the count, because a transfer can start above a defer that the text has
not reached and cleanup over an unwritten binding is not cleanup. *)
ret; body;
fdefers =
(match ctx.defer_slot with
| None -> ctx.defers
| Some s -> guarded_defers s ctx.defers);
fparent = None; floc = fn.Ast.nloc }
(* The generic body, checked once with its variables abstract. Nothing is kept
— the [Tast.fn] it produces is thrown away, and so is anything it lifted —
@ -6996,13 +7072,26 @@ let lift_ginit ctx loc n ty (v : Tast.expr) =
{ Tast.name = fname; params = [];
slots = Array.of_list (List.rev ctx.slot_tys);
snames = Array.of_list (List.rev ctx.slot_names);
ret = ty; body = [ v ]; fdefers = ctx.defers;
(* An initialiser is a nested form as far as [defer_ok] is concerned, so
nothing can register one here and both of these are empty. Written the
same way [check_fn] writes them anyway, so that the day the rule
widens this does not quietly become the one exit path that runs a
defer nobody reached. *)
ret = ty;
body =
(match ctx.defer_slot with
| None -> [ v ]
| Some s -> [ defer_counter_zero s loc; v ]);
fdefers =
(match ctx.defer_slot with
| None -> ctx.defers
| Some s -> guarded_defers s ctx.defers);
fparent = Some n; floc = loc }
:: ctx.env.lifted;
{ Tast.e = Tast.Call (fname, []); ty; loc }
let check_global env (d : Ast.decl) : Tast.global option =
let ctx () = { env; ret = Types.Unit; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = [];
let ctx () = { env; ret = Types.Unit; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = []; defer_slot = None;
outer = []; outer_what = None; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; owner = "<none>" } in
match d.Ast.d with
| Ast.Defvar (n, _, init) ->
@ -7461,7 +7550,7 @@ let instances_since env mark =
let expressions env (es : (Types.t option * Ast.expr) list) :
Tast.expr list * Types.t array * string option array =
let ctx =
{ env; ret = Types.Unit; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = [];
{ env; ret = Types.Unit; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = []; defer_slot = None;
outer = []; outer_what = None; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; owner = "<none>" }
in
(* Folded rather than mapped, because [List.map]'s order is unspecified and

10
lib/tast.ml
View File

@ -271,7 +271,15 @@ type fn = {
(* The defers again, innermost first. [body] already has them spliced onto
the normal exit path; this is the same list for the *transfer* exit path,
which leaves through a landing block the backend builds and no form in
[body] can reach. spec-conditions.md §5: they run, and errdefer does not. *)
[body] can reach. spec-conditions.md §5: they run, and errdefer does not.
Not quite the same list: each one here is wrapped in a test of the
counter [Check.register_defer] stores into, because a transfer can start
above a defer the text has not reached — in the initialiser of the very
[let] whose body it is written in, which is [slurp]'s shape — and a
cleanup over a binding nothing wrote is not cleanup. The normal paths
need no test: falling off the end is below every defer, and a [return]
carries only the ones above it. A backend runs this list as it stands. *)
fdefers : expr list;
(* Set on a function the checker made up rather than one anyone wrote: a
handler-bind clause, lifted out of the function named here. It is reached

14
spec-conditions.md
View File

@ -108,7 +108,19 @@ must be refused with the reason rather than accepted and dropped.
Invoking a restart transfers control outward past zero or more frames.
- `defer` forms in every frame between the `invoke-restart` and the target
`restart-case` **do run**, innermost first, before the clause body starts.
`restart-case` **do run**, innermost first, before the clause body starts —
every one that had *registered* when the transfer started, and no others. A
`defer` is registered where it is written, so a transfer that begins above it
leaves it alone. The shape that makes this matter is `slurp`'s own:
(let [src (slurp path (heap-allocator))]
(defer (free src))
...)
If `slurp` signals and a handler further out unwinds, `src` was never
written; a `free` there reads whatever the stack held under that slot. This
is the same rule `return` has always had — the defers above it run and the
ones below it do not — and the transfer exit now has it too.
- `errdefer` forms **do not run**. `errdefer` is bound to the `Result` failure
path (`try` returning `Err`) only. A restart transfer is not a failure — it is
a chosen recovery, and the recovery may well want the resource.

140
test/programs/init-conditions.flan Normal file
View File

@ -0,0 +1,140 @@
;;;; Conditions where the program has not started yet, and the defer that has
;;;; not registered yet.
;;;;
;;;; The report that opened this file said handler-case segfaults in a global
;;;; initialiser. It does not, and the top half here is what says so: all three
;;;; condition forms run in that position, before main, and answer the same
;;;; numbers they would answer anywhere. §5 of spec-conditions.md is not
;;;; suspended at startup, because an initialiser is a call from main and not a
;;;; constructor the loader runs.
;;;;
;;;; What did crash was underneath, and had nothing to do with startup:
;;;;
;;;; (defn read-file [path string] dyn
;;;; (let [src (slurp path (heap-allocator))]
;;;; (defer (free src))
;;;; (read (as-slice src))))
;;;;
;;;; `slurp` signals FileError and the handler further out unwinds. The
;;;; transfer leaves this frame through its defers — and `src` was never
;;;; written, because the form that would have written it is the one that
;;;; transferred. `free` then read whatever the stack held under that slot,
;;;; which at -O0 in a small program is zero and at -O2 is a pointer.
;;;;
;;;; A [return] never had this: the checker splices the defers registered
;;;; *above* it and no others, and says so. The transfer exit took the whole
;;;; list. The bottom half of this file is that distinction, pinned from both
;;;; sides — the defer below the signal must not run, the one above it must.
;;;;
;;;; [log] is a digit trace and not a running sum, for handler-case.flan's
;;;; reason: a sum commutes and would score a wrong order right.
(import edn "vendor:edn")
(defstruct Missing [id i32])
(defstruct Late [id i32])
(defvar log i64)
;;; A counter of its own, because two computed globals that both wrote [log]
;;; would be asserting the order the initialiser sort happened to pick between
;;; two that do not depend on each other — and that order is not this file's
;;; subject.
(defvar late i64)
(defn note [n i64] () (set log (+ (* log 10) n)))
(defn raise [n i32] i32
(error (Missing {.id n}))
0)
;;; A defer written *below* the form that transfers. Nothing reached it when
;;; the unwind starts, so it must not run: there is no v for it to run on, and
;;; in the shape this was found in the cleanup was a free.
(defn unreached [n i32] i32
(let [v (raise n)]
(defer (note 1))
(+ v 1)))
;;; And one written above it, which did register. It must still run — a fix
;;; that dropped this one would turn the crash into a leak, which is the same
;;; bug wearing a quieter coat.
(defn reached [n i32] i32
(defer (note 2))
(let [v (raise n)]
(+ v 1)))
;;; Both at once, so the trace says which of the two ran rather than how many.
(defn both [n i32] i32
(defer (note 2))
(let [v (raise n)]
(defer (note 1))
(+ v 1)))
;;; And the ordinary case, where nothing transfers: every defer registers and
;;; every one runs, innermost first.
(defn no-signal [n i32] i32
(defer (note 2))
(let [v (+ n 1)]
(defer (note 1))
(+ v 1)))
;;; ── The three forms, in a global initialiser ──────────────────────
;;;
;;; Each of these runs before main. A handler-case whose condition fires, one
;;; whose body completes and whose clause therefore never runs, a handler-bind
;;; that returns normally and lets signal carry on, and a restart-case with a
;;; handler-bind inside it — which is slurp's own shape and the reason the
;;; checker lets a condition form stand here at all.
(defvar fired i32
(handler-case (both 4)
[(Missing [c] (+ 100 (.id c)))]))
(defvar quiet i32
(handler-case (+ 1 40)
[(Missing [c] -1)]))
(defvar bound i32
(handler-bind [(Late [c] (set late 5))]
(do (signal (Late {.id 1}))
7)))
(defvar restarted i32
(restart-case
(handler-bind [(Missing [c] (invoke-restart 'use-zero 9))]
(raise 3))
(use-zero [k i32] k)))
;;; The author's own form, which is what sent anyone looking: a dyn global read
;;; out of a file that is not there, with the FileError answered by nil. The
;;; path is never present in a build directory, so the condition always fires.
(defvar game-data dyn
(handler-case (edn/read-file "no-such-file-here.edn")
[(FileError [c] nil)]))
(defn main [] i32
;; The initialisers ran above; this is what they left.
(println fired)
(println quiet)
(println bound)
(println restarted)
(println game-data)
(println late)
;; The 2 is `both`'s registered defer. The 1 is the one that never
;; registered, and its absence here is the whole fix.
(println log)
(set log 0)
;; The same three shapes from an ordinary function, where they always worked
;; and must go on working.
(println (handler-case (unreached 1) [(Missing [c] (+ 200 (.id c)))]))
(println log)
(set log 0)
(println (handler-case (reached 2) [(Missing [c] (+ 300 (.id c)))]))
(println log)
(set log 0)
(println (handler-case (both 3) [(Missing [c] (+ 400 (.id c)))]))
(println log)
(set log 0)
(println (no-signal 5))
(println log)
0)

30
test/test_acceptance.ml
View File

@ -507,6 +507,36 @@ let () =
handler_case_out;
outputs ~x86:true "handler-case, --x86" "programs/handler-case.flan"
handler_case_out;
(* Conditions in a global initialiser, and the defer that has not
registered when a transfer starts. The two halves are one program
because the second was found underneath a report about the first: a
handler-case around (edn/read-file ...) in a defvar segfaulted, and
what segfaulted was read-file's own (defer (free src)) running on the
way out of a frame where slurp had transferred before src was written.
The numbers that carry it are the defer traces. 0 is the defer written
below the signalling form and never reached — the whole fix, and the
number that was 1 before it. 2 is the one written above it, which did
register and must still run; a fix that took the unregistered one off
by taking them all off would print 0 there and trade a crash for a
leak. 12 is the no-transfer path, where both run and the order is
innermost-first.
All three backends, because the transfer exit is where the two of them
have separate copies of the same landing pad, and -O0 as well because
the slot that was being read uninitialised reads as zero at -O0 in a
small program and as a live pointer at -O2 — which is why the report
came in as crashing under both from a large program and reproduced
under neither from a small one. *)
let init_conditions_out =
"104\n41\n7\n9\nnil\n5\n2\n201\n0\n302\n2\n403\n2\n7\n12\n"
in
outputs "conditions in a global initialiser"
"programs/init-conditions.flan" init_conditions_out;
outputs ~opt:"-O0" "conditions in a global initialiser, -O0"
"programs/init-conditions.flan" init_conditions_out;
outputs ~x86:true "conditions in a global initialiser, --x86"
"programs/init-conditions.flan" init_conditions_out;
(* The other way a transfer starts is the break loop, which chooses a
restart by position and has nothing to fill parameters in with. It
reaches the clause through the same channel an invoke-restart writes, so

9
test/test_sanitize.ml
View File

@ -149,6 +149,15 @@ let corpus =
with-allocator case is the one that reaches the heap — the region it
rebound is released after the unwind has carried a value out of it. *)
"programs/handler-case.flan", [];
(* The same transfer exit, asked about the defers rather than the frames.
The bug this program was written for was a defer running over a binding
the form that would have written it had transferred out of, and the
cleanup was a free: the second run of that path frees a pointer nobody
stored. ASan is the regression guard and not the detector — an
uninitialised stack slot is not its bug class, and it reported nothing
on the broken binary; what named it was valgrind, and test_valgrind.ml
runs this program for that reason. *)
"programs/init-conditions.flan", [];
(* The JSON reader, which is the corpus's densest allocator: every string
in the document is a (Vec u8) grown a byte at a time and then handed
out as a view of its own block, and the block is never freed because

6
test/test_valgrind.ml
View File

@ -217,6 +217,12 @@ let corpus =
"programs/exhausted-unhandled.flan", [];
"programs/files.flan", [];
"programs/free-all-refused.flan", [];
(* The detector for the defer that had not registered yet. Memcheck is the
tool that named it — a conditional jump in flan_vec_free depending on
an uninitialised value, with the unwinding frame right above it in the
trace — where ASan saw nothing, because reading a stack slot nobody
wrote is not ASan's bug class. *)
"programs/init-conditions.flan", [];
"programs/machine.flan", [];
"programs/map-exhausted.flan", [];
"programs/map-stale-region.flan", [];