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

A library resource is known by its identifying field, a Get or a consuming Load is counted as raylib means it, bare pointers are not resources, the report waits for FLAN_DEV_LEAKS, and a release build emits the code it did before the tracker

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 11:27:41 +07:00
parent 8bebff61eb
commit 05d86b243f
10 changed files with 507 additions and 249 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
TODO.org
View File

@ -1795,13 +1795,13 @@ deliberately silent, each for its own reason.
** DONE A debug tracking allocator over the raylib boundary
CLOSED: [2026-09-25]
A dev build counts calls to bindings named =Unload*= against the bindings that
return the same type (not =Get*=), at the call site, keyed by a hash of the
value's leaf fields, and reports at exit what is still held by type and load
site, and each unload that matched nothing. Release builds drop the notes. Rules
out tracking in the C wrapper, which cannot know the call site, and keying on
the struct's bytes, which include padding. docs/BUILT.md, "A dev build counts a
library's resources".
return the same struct type (not =Get*=, except =GetClipboardImage=), noting
the release and acquisition in the generated wrapper and the site at the call.
A resource is keyed by its first pointer field, or its =id=, so writing other
fields keeps the match. The report at exit is behind =FLAN_DEV_LEAKS=. Release
builds emit what they did before. Rules out keying on the whole value and
tracking bare pointers. docs/BUILT.md, "A dev build counts a library's
resources".
** DONE --dev --sanitize was unbuildable, and nothing built it
CLOSED: [2026-09-21]
clang's sanitizer pass faulted on a constructor table naming a function the

55
docs/BUILT.md
View File

@ -692,7 +692,7 @@ string.
The importer follows `const`. `const char *` returned is text the caller only reads, so it becomes `string`; `char *`
without `const` is text the caller owns and releases through the library (`LoadFileText` and `UnloadFileText`), and a
copy would leave the original with nothing to release it through, so that one stays refused and a hand-written
`declare-c` saying `(Ptr u8)` binds it. `TextFormat` stays unbound because it is variadic. Twenty raylib functions came
`declare-c` saying `(Ptr u8)` binds it. `TextFormat` stays unbound because it is variadic. Eighteen raylib functions came
in with this — the path helpers, the case conversions, `GetClipboardText`, `GetMonitorName`, `GetGamepadName`.
`test/programs/cstr-return.flan` runs all three shapes against a package with its own C, so it needs no library:
@ -730,33 +730,42 @@ A texture, an image's pixels, a sound: memory raylib allocated, which ASan does
it, and which the allocation registry does not see because no Flan allocator did. What does see it is the call that made
it, so a dev build counts there.
**Which calls.** `Shim.resources` reads it off the `declare-c` forms by raylib's naming convention. A type is a resource
when a binding whose C symbol begins with `Unload` takes one of it and nothing else — a struct, or a pointer for the
arrays raylib hands out bare (`LoadFileData`, `LoadImageColors`). Any other binding returning that type acquires one,
except a C symbol beginning with `Get`: `GetFontDefault` and `GetShapesTexture` answer something raylib keeps. A binding
taking a `(Ptr T)` to a resource struct may change it in place — `ImageFormat` reallocates the pixels — and is a re-key.
**Which calls.** `Shim.resources` reads it off the `declare-c` forms by raylib's naming convention. A struct type is a
resource when a binding whose C symbol begins with `Unload` takes one of it and nothing else. Any other binding returning
that type acquires one, except a C symbol beginning with `Get` — `GetFontDefault` and `GetShapesTexture` answer
something raylib keeps. That rule has one exception in raylib 5.5, `GetClipboardImage`, which builds a new image with
`LoadImageFromMemory` and hands it over; `owned_gets` names it. `consumes` names the one call that takes a resource
over: `LoadModelFromMesh` stores the mesh in the model, and `UnloadModel` frees it, so the mesh counts as released at
that call. `LoadTextureFromImage`, `LoadSoundFromWave` and `LoadFontFromImage` copy what they need and leave their
argument to the caller. A binding that takes a `(Ptr T)` to a resource and returns nothing may change it in place —
`ImageFormat` reallocates the pixels — and moves its key. Pointers are not resources: raylib's bare buffers are freed by
calls not named for them (`CompressData` by `MemFree`), and a half-fitting rule would report leaks that are not there.
A library that names its pairs differently is not tracked.
**Where.** At the call, in the checker, not in the wrapper: the call site is the only place that knows the source
location, which is what the report is for. Each call to a tracked binding binds its arguments and is wrapped in
`flan_dev_reg_note_res_*` calls, the family a release build drops before building the arguments. A release build keeps
the argument slots and nothing else.
**Where.** The wrapper `Shim` generates for a tracked binding — every one has a wrapper, since each passes or returns a
struct — notes the release of its arguments and the acquisition of its result, over the locals it already binds. The
call site, in `Check`, notes where the call is, because only it knows the source location; the runtime pairs the two by
the binding's name, on a stack, so a tracked call inside another's arguments names its own column. All of it is
`flan_dev_reg_note_*` calls, the family a release build drops before building their arguments, and none of it binds a
slot. A release build therefore emits the same machine code it emitted before the tracker existed: compared function by
function against master over six raylib programs, on both backends, the only differences are string-constant numbering
and the length of the source path baked into a bounds message.
**Identity.** A resource is matched by a hash of its value, because an `Unload` is handed the value a `Load` answered and
not an address. The hash is over each leaf field's own bytes, combined in order — the struct-key walk a `Map` uses —
so padding never reaches it: `Sound`, `Music` and `Model` all have padding, and an LLVM aggregate copy does not preserve
it. Two resources with identical values share a key; a release then removes one of them, the counts stay right, and
only which load site is named can be wrong. Headless textures all have id 0 and are the realistic case of that.
**Identity.** A resource is matched by one field, not its whole value, because a program sets `looping` on a Music or
the `transform` of a Model and still unloads the same resource. The field is the first pointer in the struct, depth
first — an Image's pixels, a Sound's buffer, a Mesh's vertices, a Model's meshes, a Font's rectangles — and in a
struct with no pointer, a field named `id`, which is how a Texture2D or a RenderTexture2D names its GPU object. A
struct with neither is keyed by every leaf field, hashed one at a time so padding never reaches the key. Two resources
with the same identifying field share a key; a release then removes one of them and the count stays right. Headless
textures all have id 0 and are the realistic case of that.
**The report**, at exit and only when there is something to say: what is still held, grouped by type and load site in
the order loaded, and each `Unload` that matched no load — twice over, or of a value raylib keeps. It is registered by
the first note, so a program that touches no tracked binding registers nothing, and it cannot run for a program ended by
a signal, the same limit the block report has.
**The report**, at exit, when `FLAN_DEV_LEAKS` is set — the switch the block report uses: what is still held, grouped by
type and load site in the order loaded, and each `Unload` that matched no load. It cannot run for a program ended by a
signal. A binding reached through a function value opened no site, and its entries say so instead of naming one.
What it cannot see: a call through a function value, which has no name to look up; and a resource whose fields the
program changes itself, whose key no longer matches its load — it reports as held and its unload as unmatched.
`test/programs/res-leaks.flan` runs all of it against a stub package with its own C — padding, a re-key, a pointer
resource, a stray release — so it needs no library and no window.
`test/programs/res-leaks.flan` runs all of it against a stub package with its own C — field writes before an unload, a
pointerless struct keyed by its id, a re-key, the clipboard override, a consumed mesh, a nested load, a stray release —
so it needs no library and no window.
## Packages

175
lib/check.ml
View File

@ -3343,24 +3343,56 @@ let given_once ~noun ?(known = fun _ _ -> ()) kvs =
kvs;
seen
(* ── Counting a library's resources at the call ──────────────────────
(* ── Counting a library's resources ─────────────────────────────────
[Shim.resources] says which bindings acquire, release or change a resource
in place; this is the call to one of them, with the notes around it. The
arguments are bound first, in order, so each is evaluated once and the notes
read the same values the call is given.
in place. The generated wrapper of each one carries [%res-acquire],
[%res-release] and [%res-done] forms over its own locals — names the reader
cannot produce, so no program can write them — and the call site opens the
note with where it is. The runtime pairs the two by the binding's name.
A resource is known by a hash of its value — every leaf field's own bytes,
combined in order, so a struct's padding never reaches it. That is the
identity an Unload call can be matched on: it is handed the value the Load
answered, not an address. Two resources with identical values share a key,
which costs nothing but the load site the report names for one of them: a
release removes one entry with that key, and the counts stay right.
A resource is known by one field, not by its whole value: a program sets
[looping] on a Music or the [transform] of a Model and still unloads the
same resource. The field is the first pointer in the struct, depth first —
an Image's pixels, a Sound's audio buffer, a Mesh's vertices, a Model's
meshes — and, in a struct that holds no pointer, a field named [id], which
is how a Texture2D or a RenderTexture2D names its GPU object. A struct with
neither is keyed by every leaf field, hashed separately so padding never
reaches the key.
Every note is a [flan_dev_reg_note_] call, which is the family a release
build drops before its arguments are built — the hashes included. What a
release build keeps is the argument slots, which the optimiser folds away. *)
let rec res_key loc env (e : Tast.expr) : Tast.expr =
Every note is a [flan_dev_reg_note_] call. A release build drops that
family before building its arguments, and none of the notes binds a slot,
so what a release build emits is exactly what it emitted before the notes
existed. *)
let res_field env (t : Types.t) : int list option =
let fields n =
match Hashtbl.find_opt env.structs n with
| Some s -> s.Tast.fields
| None -> []
in
let rec first_ptr t =
match t with
| Types.Named n when Hashtbl.mem env.structs n ->
List.find_map
(fun (i, (f : Tast.field)) ->
match f.Tast.fty with
| Types.Ptr _ -> Some [ i ]
| ft -> Option.map (fun p -> i :: p) (first_ptr ft))
(List.mapi (fun i f -> (i, f)) (fields n))
| _ -> None
in
match first_ptr t with
| Some p -> Some p
| None ->
(match t with
| Types.Named n ->
List.find_map
(fun (i, (f : Tast.field)) ->
if String.equal f.Tast.fname "id" then Some [ i ] else None)
(List.mapi (fun i f -> (i, f)) (fields n))
| _ -> None)
let rec res_hash loc env (e : Tast.expr) : Tast.expr =
let seed = mk loc hash_ty (Tast.Int (0L, Types.U64)) in
match e.Tast.ty with
| Types.Named n when Hashtbl.mem env.structs n ->
@ -3370,33 +3402,63 @@ let rec res_key loc env (e : Tast.expr) : Tast.expr =
(fun (i, acc) (fl : Tast.field) ->
let leaf = mk loc fl.Tast.fty (Tast.Field (e, i)) in
(i + 1,
rt loc hash_ty "flan_hash_combine" [ acc; res_key loc env leaf ]))
rt loc hash_ty "flan_hash_combine" [ acc; res_hash loc env leaf ]))
(0, seed) fields)
| t -> rt loc hash_ty "flan_key_hash_flat" [ addr_of loc e; seed; size_of loc t ]
let tracked_call ctx loc name (tr : Shim.track) params ret
(args : Tast.expr list) =
let env = ctx.env in
let binds = List.map2 (fun p a -> (fresh_slot ctx p, a)) params args in
let locals = List.map2 (fun p (s, _) -> mk loc p (Tast.Local s)) params binds in
let res_key loc env (e : Tast.expr) : Tast.expr =
match res_field env e.Tast.ty with
| None -> res_hash loc env e
| Some path ->
let leaf =
List.fold_left
(fun (x : Tast.expr) i ->
match x.Tast.ty with
| Types.Named n ->
let f = List.nth (Hashtbl.find env.structs n).Tast.fields i in
mk loc f.Tast.fty (Tast.Field (x, i))
| _ -> x)
e path
in
res_hash loc env leaf
(* An argument that can be evaluated a second time and mean the same thing:
a name, or the address of one or of a field of one. The in-place re-key
reads its argument before and after the call, and anything with an effect
in it is not re-keyed. *)
let rec res_pure (e : Tast.expr) =
match e.Tast.e with
| Tast.Local _ | Tast.Global _ -> true
| Tast.Field (x, _) -> res_pure x
| Tast.Addr p | Tast.Prim (Tast.AddrOf, [ { Tast.e = Tast.Addr p; _ } ]) ->
res_place p
| Tast.Prim (Tast.AddrOf, [ x ]) -> res_pure x
| _ -> false
and res_place (p : Tast.place) =
match p with
| Tast.Plocal _ | Tast.Pglobal _ -> true
| Tast.Pfield (t, _) -> res_pure t
| _ -> false
let tracked_call loc env name (tr : Shim.track) ret (args : Tast.expr list) =
let str x = mk loc Types.String (Tast.Str x) in
let note sym key ty =
rt loc Types.Unit sym [ key; str (Types.to_string ty); here loc ]
in
let releases =
match (tr.Shim.release, locals) with
| true, [ a ] ->
[ note "flan_dev_reg_note_res_release" (res_key loc env a) a.Tast.ty ]
| _ -> []
let call = mk loc ret (Tast.Call (name, args)) in
let opened =
if tr.Shim.acquire || tr.Shim.releases <> [] then
[ rt loc Types.Unit "flan_dev_reg_note_res_site" [ str name; here loc ] ]
else []
in
let rekeyed =
List.filter_map
(fun i ->
match List.nth_opt locals i with
| Some ({ Tast.ty = Types.Ptr t; _ } as p) ->
Some (mk loc t (Tast.Deref p), t)
| _ -> None)
tr.Shim.rekey
if ret <> Types.Unit then []
else
List.filter_map
(fun i ->
match List.nth_opt args i with
| Some ({ Tast.ty = Types.Ptr t; _ } as p) when res_pure p ->
Some (mk loc t (Tast.Deref p), t)
| _ -> None)
tr.Shim.rekey
in
(* The old keys go to the runtime before the call and the new ones after,
in the reverse order, so it can pair them on a stack. *)
@ -3413,21 +3475,9 @@ let tracked_call ctx loc name (tr : Shim.track) params ret
[ res_key loc env v; str (Types.to_string t) ])
rekeyed
in
let call = mk loc ret (Tast.Call (name, locals)) in
let body =
match ret with
| Types.Unit -> (call :: after) @ [ unit_at loc ]
| _ ->
let r = fresh_slot ctx ret in
let rv = mk loc ret (Tast.Local r) in
let acquired =
if tr.Shim.acquire then
[ note "flan_dev_reg_note_res_acquire" (res_key loc env rv) ret ]
else []
in
[ mk loc ret (Tast.Let ([ (r, call) ], acquired @ after @ [ rv ])) ]
in
mk loc ret (Tast.Let (binds, releases @ before @ body))
match opened @ before, after with
| [], [] -> call
| pre, post -> mk loc ret (Tast.Do (pre @ [ call ] @ post))
let rec check ctx ?want (e : Ast.expr) : Tast.expr =
let loc = e.Ast.loc in
@ -6358,6 +6408,29 @@ and indexed ?place ctx (target : Tast.expr) (idx : Ast.expr list) =
and check_call ctx ~want loc (head : Ast.expr) (args : Ast.expr list) =
match head.Ast.e with
(* The resource notes [Shim] writes into a tracked binding's wrapper; see
[res_key]. The reader never produces a name beginning with '%'. *)
| Ast.Var (("%res-acquire" | "%res-release") as which) ->
(match args with
| [ v; { Ast.e = Ast.Str owner; _ } ] ->
let v = check ctx v in
let sym =
if which = "%res-acquire" then "flan_dev_reg_note_res_acquire"
else "flan_dev_reg_note_res_release"
in
expect ctx loc ~want
(rt loc Types.Unit sym
[ res_key loc ctx.env v;
mk loc Types.String (Tast.Str (Types.to_string v.Tast.ty));
mk loc Types.String (Tast.Str owner) ])
| _ -> fail loc "internal: %s takes a local and a name — a compiler bug" which)
| Ast.Var "%res-done" ->
(match args with
| [ { Ast.e = Ast.Str owner; _ } ] ->
expect ctx loc ~want
(rt loc Types.Unit "flan_dev_reg_note_res_done"
[ mk loc Types.String (Tast.Str owner) ])
| _ -> fail loc "internal: %%res-done takes a name — a compiler bug")
| Ast.Var name -> named_call ctx ~want loc name args
(* A computed head: ((choose k) 3). The head is an ordinary expression and
the only thing asked of it is that it be a function. *)
@ -9228,7 +9301,7 @@ and ordinary_call ctx ~want loc name args =
map2_lr (fun p a -> incr i; check_arg ctx name !i p a) params args
in
(match Hashtbl.find_opt ctx.env.tracks name with
| Some tr -> expect ctx loc ~want (tracked_call ctx loc name tr params ret args)
| Some tr -> expect ctx loc ~want (tracked_call loc ctx.env name tr ret args)
| None -> expect ctx loc ~want (mk loc ret (Tast.Call (name, args))))
| None ->
if Hashtbl.mem ctx.env.datas name then

2
lib/emit.ml
View File

@ -4283,6 +4283,8 @@ declare void @flan_dev_reg_note_res_acquire(i64, ptr, i64, ptr, i64)
declare void @flan_dev_reg_note_res_release(i64, ptr, i64, ptr, i64)
declare void @flan_dev_reg_note_res_rekey_from(i64)
declare void @flan_dev_reg_note_res_rekey_to(i64, ptr, i64)
declare void @flan_dev_reg_note_res_site(ptr, i64, ptr, i64)
declare void @flan_dev_reg_note_res_done(ptr, i64)
declare i8 @flan_vec_init(ptr, ptr, i64, i64, i64, ptr, i64)
declare i8 @flan_vec_reserve(ptr, i64, i64, i64, ptr, i64)
declare i8 @flan_vec_push(ptr, ptr, i64, i64, ptr, i64)

271
lib/shim.ml
View File

@ -552,6 +552,131 @@ let typedefs env needed =
List.iter define all;
Buffer.contents b
(* ── Resources a dev build counts ──────────────────────────────────
TODO.org, "A debug tracking allocator over the raylib boundary". A library
like raylib allocates memory Flan's allocators never see — a texture, an
image's pixels — and hands it back through a Load call that must be paired
with an Unload. ASan does not see that memory and the allocation registry
does not either. What does see every one of those calls is the declaration
of it, so a dev build counts them there.
Which bindings are tracked is read off the declarations, by the naming
convention raylib keeps throughout:
- a struct type is a resource when a declare-c whose C symbol begins with
[Unload] takes one of it and nothing else. That call releases one.
- any other declare-c that returns a resource type acquires one, except a
C symbol beginning with [Get]: GetFontDefault and GetShapesTexture answer
something raylib keeps. [owned_gets] names the [Get] calls that do hand
the caller a new one.
- [consumes] names the calls that take a resource over, so the caller no
longer releases it: the argument counts as released at that call.
- a declare-c taking a [(Ptr T)] to a resource struct and returning nothing
may change it in place — ImageFormat reallocates an image's pixels — so
the key it had before the call is moved to the key it has after.
Pointers are not resources: raylib returns bare buffers from calls whose
pairs are not named the same way (CompressData is freed with MemFree), and
a rule that half-fits them would report leaks that are not there.
A library that names its pairs some other way is not tracked, and nothing
is reported about it.
The notes go in two places. The generated Flan wrapper — which every
tracked binding has, since each one passes or returns a struct — notes the
acquisition or the release, because only there are the values in named
locals. The call site, in [Check], says where the call is, because only it
knows. Every note is a [flan_dev_reg_note_] call, which a release build
drops before building its arguments, so a release build's code is what it
was before any of this existed. *)
type track = {
acquire : bool; (* the result is a new resource *)
releases : int list; (* these arguments stop being the caller's *)
rekey : int list; (* these (Ptr T) arguments may be changed in place *)
}
let prefixed p s =
String.length s >= String.length p && String.sub s 0 (String.length p) = p
(* raylib 5.5 builds the clipboard image with LoadImageFromMemory and hands it
over (rcore_desktop_glfw.c); it is the one [Get] that is a load. *)
let owned_gets = [ "GetClipboardImage" ]
(* The model owns the mesh from here on: UnloadModel frees model.meshes, and
the mesh is model.meshes[0] (rmodels.c). No other raylib 5.5 call that
takes a resource by value keeps it — LoadTextureFromImage,
LoadSoundFromWave and LoadFontFromImage copy what they need and leave the
argument to the caller. *)
let consumes = [ ("LoadModelFromMesh", [ 0 ]) ]
let resources (decls : Ast.decl list) : (string * track) list =
let env = scan decls in
let struct_name (t : Ast.texpr) =
match (unalias env t).Ast.t with
| Ast.Tname n when Hashtbl.mem env.structs n -> Some n
| _ -> None
in
let decl_cs =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.DeclareC (fn, csym) -> Some (fn, csym)
| _ -> None)
decls
in
let released = Hashtbl.create 16 in
List.iter
(fun ((fn : Ast.fn), csym) ->
match fn.Ast.params with
| [ p ] when prefixed "Unload" csym ->
Option.iter (fun n -> Hashtbl.replace released n ()) (struct_name p.Ast.fty)
| _ -> ())
decl_cs;
let resource t =
match struct_name t with Some n -> Hashtbl.mem released n | None -> false
in
List.filter_map
(fun ((fn : Ast.fn), csym) ->
let unload = prefixed "Unload" csym in
let releases =
if unload then
(match fn.Ast.params with
| [ p ] when resource p.Ast.fty -> [ 0 ]
| _ -> [])
else
match List.assoc_opt csym consumes with
| Some is ->
List.filter
(fun i ->
match List.nth_opt fn.Ast.params i with
| Some p -> resource p.Ast.fty
| None -> false)
is
| None -> []
in
let acquire =
(not unload)
&& ((not (prefixed "Get" csym)) || List.mem csym owned_gets)
&& (match fn.Ast.ret with Some t -> resource t | None -> false)
in
let rekey =
if unload || fn.Ast.ret <> None then []
else
List.concat
(List.mapi
(fun i (p : Ast.field) ->
match (unalias env p.Ast.fty).Ast.t with
| Ast.Tapp ("Ptr", [ e ]) when resource e -> [ i ]
| _ -> [])
fn.Ast.params)
in
if acquire || releases <> [] || rekey <> [] then
Some (fn.Ast.name, { acquire; releases; rekey })
else None)
decl_cs
(* ── The Flan halves ────────────────────────────────────────────────── *)
let ty loc t = { Ast.t; tloc = loc }
@ -596,7 +721,7 @@ let flattened (fn : Ast.fn) (s : shim) name : Ast.fn =
struct argument into a local — a parameter is not an assignable place, so
there is no address to take without one — and, when C returns a struct,
zeroes one and hands over its address. *)
let flan_wrapper (fn : Ast.fn) (s : shim) raw : Ast.decl_kind =
let flan_wrapper ?track (fn : Ast.fn) (s : shim) raw : Ast.decl_kind =
let loc = fn.Ast.nloc in
let binds = ref [] in
let args =
@ -648,11 +773,36 @@ let flan_wrapper (fn : Ast.fn) (s : shim) raw : Ast.decl_kind =
fn.Ast.ret )
| _ -> ([ call args ], fn.Ast.ret)
in
(* The resource notes, when this binding is tracked: each released argument
before the call, the acquired result after it, and the note that closes
the call site [Check] opened. They read the locals the wrapper already
binds and bind none of their own. *)
let body =
match track with
| None -> body
| Some tr ->
let note f xs = ex loc (Ast.Call (ex loc (Ast.Var f), xs)) in
let name = ex loc (Ast.Str fn.Ast.name) in
let released =
List.map (fun i -> note "%res-release" [ ex loc (Ast.Var (tmp i)); name ])
tr.releases
in
let acquired =
match s.sret with
| `Struct _ when tr.acquire ->
[ note "%res-acquire" [ ex loc (Ast.Var out_tmp); name ] ]
| _ -> []
in
let fin = acquired @ [ note "%res-done" [ name ] ] in
(match s.sret, List.rev body with
| `Struct _, value :: rest -> released @ List.rev rest @ fin @ [ value ]
| _ -> released @ body @ fin)
in
Ast.Defn { fn with Ast.ret; fbody = [ ex loc (Ast.Let (!binds, body)) ] }
(* ── Expansion ──────────────────────────────────────────────────────── *)
let one env ~taken (fn : Ast.fn) csym loc =
let one env ~taken ~tracks (fn : Ast.fn) csym loc =
let needed = ref [] in
let sargs =
List.map
@ -700,121 +850,13 @@ let one env ~taken (fn : Ast.fn) csym loc =
"the declare-c of %s needs the name %s for the declaration it \
generates, and %s is declared already — rename one of them"
fn.Ast.name raw raw
else [ Ast.Declare (flattened fn s raw, s.swrap); flan_wrapper fn s raw ]
else
[ Ast.Declare (flattened fn s raw, s.swrap);
flan_wrapper ?track:(List.assoc_opt fn.Ast.name tracks) fn s raw ]
else [ Ast.Declare (flattened fn s fn.Ast.name, s.swrap) ]
in
(decls, s, !needed)
(* ── Resources a dev build counts ──────────────────────────────────
TODO.org, "A debug tracking allocator over the raylib boundary". A library
like raylib allocates memory Flan's allocators never see — a texture, an
image's pixels — and hands it back through a Load call that must be paired
with an Unload. ASan does not see that memory and the allocation registry
does not either. What does see every one of those calls is the declaration
of it, so a dev build counts them there: [Check] wraps each call to a
tracked binding in notes the runtime keeps a table of, and a release build
drops the notes before their arguments are built.
Which bindings are tracked is read off the declarations, by the naming
convention raylib keeps throughout:
- a type is a resource when a declare-c whose C symbol begins with
[Unload] takes one of it and nothing else — a struct, or a pointer for
the arrays raylib hands out as bare pointers (LoadFileData,
LoadImageColors). That call releases one.
- any other declare-c that returns a resource type acquires one, except a
C symbol beginning with [Get]. GetFontDefault and GetShapesTexture answer
something raylib keeps and frees itself; unloading one of those is a
bug, and it is reported as a release nothing acquired.
- a declare-c taking a [(Ptr T)] to a resource struct may change it in
place — ImageFormat reallocates an image's pixels — so the value it had
before the call is re-keyed to the value it has after. The count does
not change.
A library that names its pairs some other way is not tracked, and nothing
is reported about it. *)
type track = { acquire : bool; release : bool; rekey : int list }
let prefixed p s =
String.length s >= String.length p && String.sub s 0 (String.length p) = p
let resources (decls : Ast.decl list) : (string * track) list =
let env = scan decls in
(* The spelling a resource type is matched by: a struct's name, or a pointer
to anything. [None] for everything else, which is never a resource. *)
let rec spell (t : Ast.texpr) =
match (unalias env t).Ast.t with
| Ast.Tname n when Hashtbl.mem env.structs n -> Some n
| Ast.Tname n when prim_cty n <> None -> Some n
| Ast.Tapp ("Ptr", [ e ]) ->
Option.map (fun e -> "(Ptr " ^ e ^ ")") (spell e)
| _ -> None
in
let is_resource_type (t : Ast.texpr) =
match (unalias env t).Ast.t with
| Ast.Tname n -> Hashtbl.mem env.structs n
| Ast.Tapp ("Ptr", _) -> true
| _ -> false
in
let decl_cs =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.DeclareC (fn, csym) -> Some (fn, csym)
| _ -> None)
decls
in
let released = Hashtbl.create 16 in
List.iter
(fun ((fn : Ast.fn), csym) ->
match fn.Ast.params with
| [ p ] when prefixed "Unload" csym && is_resource_type p.Ast.fty ->
Option.iter (fun n -> Hashtbl.replace released n ()) (spell p.Ast.fty)
| _ -> ())
decl_cs;
List.filter_map
(fun ((fn : Ast.fn), csym) ->
let release =
prefixed "Unload" csym
&& (match fn.Ast.params with
| [ p ] ->
(match spell p.Ast.fty with
| Some n -> Hashtbl.mem released n
| None -> false)
| _ -> false)
in
let acquire =
(not (prefixed "Unload" csym)) && (not (prefixed "Get" csym))
&& (match fn.Ast.ret with
| Some t ->
(match spell t with
| Some n -> Hashtbl.mem released n
| None -> false)
| None -> false)
in
let rekey =
if prefixed "Unload" csym then []
else
List.concat
(List.mapi
(fun i (p : Ast.field) ->
match (unalias env p.Ast.fty).Ast.t with
| Ast.Tapp ("Ptr", [ e ]) ->
(match (unalias env e).Ast.t with
| Ast.Tname n
when Hashtbl.mem env.structs n
&& Hashtbl.mem released n -> [ i ]
| _ -> [])
| _ -> [])
fn.Ast.params)
in
if acquire || release || rekey <> [] then
Some (fn.Ast.name, { acquire; release; rekey })
else None)
decl_cs
(* Every [declare-c] in the program, rewritten, with the one C file they share.
The file is [None] when there are none, so a program that binds nothing pays
no C compile. *)
@ -836,6 +878,7 @@ let expand (decls : Ast.decl list) : Ast.decl list * (string * string) list =
| Some n -> Hashtbl.replace taken n d.Ast.dloc
| None -> ())
decls;
let tracks = resources decls in
let shims = ref [] in
let needed = ref [] in
let out =
@ -843,7 +886,7 @@ let expand (decls : Ast.decl list) : Ast.decl list * (string * string) list =
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.DeclareC (fn, csym) ->
let ds, s, n = one env ~taken fn csym d.Ast.dloc in
let ds, s, n = one env ~taken ~tracks fn csym d.Ast.dloc in
shims := !shims @ [ s ];
List.iter
(fun x -> if not (List.mem x !needed) then needed := !needed @ [ x ])

99
runtime/flan_dev.c
View File

@ -1909,27 +1909,24 @@ static void flan_reg_report(void) {
* or an image's pixels is memory raylib allocated, which neither ASan nor the
* registry above can see: nothing instrumented made it. What does see it is
* the call that made it. lib/shim.ml says which declare-c bindings acquire and
* release a resource, lib/check.ml wraps each call to one in the notes below,
* and this is the table they keep.
* release a resource and writes notes into their wrappers; lib/check.ml opens
* each call to one with where it is. This is the table they keep.
*
* An entry is one acquisition not yet released: the resource's key — a hash of
* its value, computed by the compiler from its fields — its type and the
* source location of the call that made it. A release removes one entry with
* the same key and type. A release that finds none is a release of something
* this run never loaded — an unload twice over, or of a value raylib keeps for
* itself — and is counted separately, by type and site, because it is a bug of
* its own.
* its identifying field, computed by the compiler — its type and the source
* location of the call that made it. A release removes one entry with the same
* key and type. A release that finds none is a release of something this run
* never loaded — an unload twice over, or of a value raylib keeps for itself —
* and is counted separately, by type and site, because it is a bug of its own.
*
* Only a dev build calls in here: the notes are [flan_dev_reg_note_] calls,
* which a release build drops. The report at exit is registered by the first
* note, so a program that never touches a tracked binding registers nothing.
* It prints only when something is still held or a release matched nothing,
* and like the block report above it cannot run for a program ended by a
* signal.
* which a release build drops. The report at exit is off unless
* FLAN_DEV_LEAKS is set, the same switch as the block report above, and like
* that one it cannot run for a program ended by a signal.
*
* One thread, the game's, calls these; nothing reads the table while the
* program runs. The type and site strings are literals the compiler emitted
* beside the call, and a module is never unloaded, so they outlive the table. */
* program runs. The strings are literals the compiler emitted beside the call,
* and a module is never unloaded, so they outlive the table. */
typedef struct {
uint64_t key;
@ -1952,13 +1949,68 @@ static void flan_res_report(void);
static void flan_res_arm(void) {
if (flan_res_armed) return;
flan_res_armed = 1;
atexit(flan_res_report);
if (getenv("FLAN_DEV_LEAKS") != NULL) atexit(flan_res_report);
}
static int flan_res_same(const char *a, int64_t an, const char *b, int64_t bn) {
return an == bn && memcmp(a, b, (size_t)an) == 0;
}
/* ── Where the call is ──
*
* The call site opens a note with the binding's name and its location, and
* the wrapper's notes read it and close it. A stack, because a tracked call
* can sit in the arguments of another — (load-texture-from-image
* (gen-image-color ...)) opens the outer site, then the inner one, and the
* inner wrapper runs and closes first. The wrapper names itself, so a site is
* only used by the call it was opened for; a wrapper reached through a
* function value opened none, finds a different name on top, and says it does
* not know where it was called from. A transfer out of a wrapper leaves its
* entry behind, under whatever is pushed next, which is why the depth is
* bounded and the oldest entry is the one dropped. */
#define FLAN_RES_SITES 64
static struct { const char *name; int64_t namelen; const char *site;
int64_t sitelen; } flan_res_sites[FLAN_RES_SITES];
static int flan_res_nsites;
void flan_dev_reg_note_res_site(const char *name, int64_t namelen,
const char *site, int64_t sitelen) {
if (flan_res_nsites == FLAN_RES_SITES) {
memmove(&flan_res_sites[0], &flan_res_sites[1],
(FLAN_RES_SITES - 1) * sizeof flan_res_sites[0]);
flan_res_nsites--;
}
flan_res_sites[flan_res_nsites].name = name;
flan_res_sites[flan_res_nsites].namelen = namelen;
flan_res_sites[flan_res_nsites].site = site;
flan_res_sites[flan_res_nsites].sitelen = sitelen;
flan_res_nsites++;
}
static int flan_res_top_is(const char *name, int64_t namelen) {
return flan_res_nsites > 0
&& flan_res_same(flan_res_sites[flan_res_nsites - 1].name,
flan_res_sites[flan_res_nsites - 1].namelen, name,
namelen);
}
static const char flan_res_unknown[] = "a call through a function value";
static void flan_res_site_of(const char *name, int64_t namelen,
const char **site, int64_t *sitelen) {
if (flan_res_top_is(name, namelen)) {
*site = flan_res_sites[flan_res_nsites - 1].site;
*sitelen = flan_res_sites[flan_res_nsites - 1].sitelen;
} else {
*site = flan_res_unknown;
*sitelen = (int64_t)(sizeof flan_res_unknown - 1);
}
}
void flan_dev_reg_note_res_done(const char *name, int64_t namelen) {
if (flan_res_top_is(name, namelen)) flan_res_nsites--;
}
static flan_res_entry *flan_res_push(flan_res_entry **v, int64_t *n,
int64_t *cap) {
if (*n == *cap) {
@ -1975,21 +2027,23 @@ static flan_res_entry *flan_res_push(flan_res_entry **v, int64_t *n,
}
void flan_dev_reg_note_res_acquire(uint64_t key, const char *type,
int64_t typelen, const char *site,
int64_t sitelen) {
int64_t typelen, const char *name,
int64_t namelen) {
flan_res_entry *e;
flan_res_arm();
e = flan_res_push(&flan_res_held, &flan_res_nheld, &flan_res_capheld);
if (e == NULL) return;
e->key = key; e->type = type; e->typelen = typelen;
e->site = site; e->sitelen = sitelen; e->count = 1;
e->key = key; e->type = type; e->typelen = typelen; e->count = 1;
flan_res_site_of(name, namelen, &e->site, &e->sitelen);
}
void flan_dev_reg_note_res_release(uint64_t key, const char *type,
int64_t typelen, const char *site,
int64_t sitelen) {
int64_t typelen, const char *name,
int64_t namelen) {
int64_t i;
flan_res_entry *e;
const char *site;
int64_t sitelen;
flan_res_arm();
/* Newest first: a resource loaded and unloaded in one frame is the common
case, and it is at the end. */
@ -2004,6 +2058,7 @@ void flan_dev_reg_note_res_release(uint64_t key, const char *type,
return;
}
}
flan_res_site_of(name, namelen, &site, &sitelen);
for (i = 0; i < flan_res_nstray; i++) {
e = &flan_res_stray[i];
if (flan_res_same(e->type, e->typelen, type, typelen)

42
test/programs/pkgs/res/res.c
View File

@ -1,10 +1,12 @@
/* A stand-in for a library that hands out resources the way raylib does — a
* Load that allocates, an Unload that frees, a Get that answers something the
* library keeps — for programs/res-leaks.flan. Nothing here needs a window or
* a library installed.
/* A stand-in for a library that hands out resources the way raylib does, for
* programs/res-leaks.flan. Nothing here needs a window or a library
* installed. Two names are raylib's own — GetClipboardImage and
* LoadModelFromMesh — because the tracker knows those two by name: the first
* is a Get that hands the caller a new resource, the second takes its
* argument over.
*
* Thing has padding after `flag` and after `w`, so a key made from its bytes
* would read whatever those bytes happened to hold. */
* Thing has padding after `flag`, and its pointer is what identifies it. Tex
* holds no pointer, so its `id` does, as a GPU handle would. */
#include <stdint.h>
#include <stdlib.h>
@ -36,6 +38,32 @@ Thing GetDefaultThing(void) {
return t;
}
unsigned char *LoadBytes(int32_t n) { return (unsigned char *)malloc((size_t)n); }
/* A Get that hands over a new one. */
Thing GetClipboardImage(void) { return LoadThing(99); }
typedef struct { uint32_t id; int32_t width; } Tex;
static uint32_t next_tex = 1;
Tex LoadTex(int32_t width) { Tex t = { next_tex++, width }; return t; }
void UnloadTex(Tex t) { (void)t; }
typedef struct { int32_t n; float *v; } Mesh;
typedef struct { int32_t count; Mesh *meshes; } Model;
Mesh GenMeshThing(void) { Mesh m = { 3, calloc(3, sizeof(float)) }; return m; }
void UnloadMesh(Mesh m) { free(m.v); }
Model LoadModelFromMesh(Mesh m) {
Model o = { 1, malloc(sizeof(Mesh)) };
o.meshes[0] = m;
return o;
}
void UnloadModel(Model o) {
for (int32_t i = 0; i < o.count; i++) UnloadMesh(o.meshes[i]);
free(o.meshes);
}
/* A bare buffer, freed by a call not named for it: not a resource. */
unsigned char *LoadBytes(int32_t n) { return (unsigned char *)malloc((size_t)n); }
void UnloadBytes(unsigned char *p) { free(p); }

10
test/programs/pkgs/res/res.flan
View File

@ -2,10 +2,20 @@
;;;; makes a dev build count them.
(defstruct Thing [id i32 flag u8 w f32 data (Ptr u8)])
(defstruct Tex [id u32 width i32])
(defstruct Mesh [n i32 v (Ptr f32)])
(defstruct Model [count i32 meshes (Ptr Mesh)])
(declare-c load-thing [id i32] Thing "LoadThing")
(declare-c unload-thing [t Thing] "UnloadThing")
(declare-c thing-grow [t (Ptr Thing)] "ThingGrow")
(declare-c get-default-thing [] Thing "GetDefaultThing")
(declare-c get-clipboard-image [] Thing "GetClipboardImage")
(declare-c load-tex [width i32] Tex "LoadTex")
(declare-c unload-tex [t Tex] "UnloadTex")
(declare-c gen-mesh-thing [] Mesh "GenMeshThing")
(declare-c unload-mesh [m Mesh] "UnloadMesh")
(declare-c load-model-from-mesh [m Mesh] Model "LoadModelFromMesh")
(declare-c unload-model [o Model] "UnloadModel")
(declare-c load-bytes [n i32] (Ptr u8) "LoadBytes")
(declare-c unload-bytes [p (Ptr u8)] "UnloadBytes")

31
test/programs/res-leaks.flan
View File

@ -1,23 +1,40 @@
;;;; A dev build counts what a library's Load calls hand out against its Unload
;;;; calls, and says at exit what was never released and where it was loaded.
;;;;
;;;; Three Things and two byte buffers are loaded. b is changed in place by
;;;; thing-grow before it is unloaded, so its key has to follow it. c and q are
;;;; never unloaded, and the report names their lines. The last unload is of
;;;; the library's own Thing, which nothing loaded, and is reported apart.
;;;; A release build prints "done" and nothing else.
;;;; Released, and so not reported: a, whose fields other than its pointer are
;;;; set before it is unloaded; b, changed in place by thing-grow; tx, a
;;;; pointerless Tex known by its id, whose width is set; the model, which took
;;;; the mesh over, with its count set and set back; and the buffers, which are
;;;; not resources. Reported: c, loaded and never unloaded; the clipboard Thing,
;;;; a Get that hands over a new one; on the last line, a Tex loaded inside
;;;; the arguments of a Thing's load, each named by its own column; and the
;;;; unload of the library's own Thing, which nothing loaded.
;;;;
;;;; The report is off unless FLAN_DEV_LEAKS is set, and a release build has
;;;; nothing to report either way.
(import res "pkgs/res")
(defn main [] i32
(let [a (res/load-thing 1)
b (res/load-thing 2)
c (res/load-thing 3)
p (res/load-bytes 8)
q (res/load-bytes 8)]
tx (res/load-tex 8)
clip (res/get-clipboard-image)
m (res/load-model-from-mesh (res/gen-mesh-thing))
p (res/load-bytes 8)]
(set (.w a) 9.0)
(set (.flag a) 0)
(set (.id a) 7)
(res/thing-grow (addr b))
(set (.width tx) 99)
(set (.count m) 0)
(set (.count m) 1)
(res/unload-thing a)
(res/unload-thing b)
(res/unload-tex tx)
(res/unload-model m)
(res/unload-bytes p)
(res/unload-thing (res/get-default-thing))
(println (.id (res/load-thing (.width (res/load-tex 5)))))
(println "done"))
0)

57
test/test_acceptance.ml
View File

@ -921,27 +921,48 @@ let () =
outputs ~dev:true "a string returned from C, dev" "programs/cstr-return.flan"
cstr_ret_out;
(* A library's resources, counted in a dev build. The package's C stands in
for raylib — Load, Unload, a Get that must not be unloaded and a call
that changes a resource in place — so this runs with no library
installed and through the same generated wrappers raylib's bindings
use. The report names the two loads never unloaded and the unload that
matched nothing; a release build prints none of it, because the notes
are dropped there. *)
for raylib — Load, Unload, a Get that must not be unloaded, one that
must, a call that changes a resource in place and one that takes its
argument over — so this runs with no library installed and through the
same generated wrappers raylib's bindings use. The program says what is
released and what is reported. The report is behind FLAN_DEV_LEAKS, so
the same dev build prints nothing without it; a release build has no
notes at all. *)
let res_dev_out =
"done\n\
flan: 2 resources still held at exit, loaded and never unloaded:\n\
flan: 1 res/Thing, loaded at programs/res-leaks.flan:14:11\n\
flan: 1 (Ptr u8), loaded at programs/res-leaks.flan:16:11\n\
flan: res/Thing released 1 time at programs/res-leaks.flan:21:5 with \
"5\ndone\n\
flan: 4 resources still held at exit, loaded and never unloaded:\n\
flan: 1 res/Thing, loaded at programs/res-leaks.flan:20:11\n\
flan: 1 res/Thing, loaded at programs/res-leaks.flan:22:14\n\
flan: 1 res/Tex, loaded at programs/res-leaks.flan:38:43\n\
flan: 1 res/Thing, loaded at programs/res-leaks.flan:38:19\n\
flan: res/Thing released 1 time at programs/res-leaks.flan:37:5 with \
nothing loaded to match\n"
in
outputs "library resources: a release build counts nothing"
"programs/res-leaks.flan" "done\n";
outputs ~dev:true "library resources: a dev build reports what is held"
"programs/res-leaks.flan" res_dev_out;
outputs ~dev:true ~x86:true
"library resources: a dev build reports what is held, x86"
"programs/res-leaks.flan" res_dev_out;
let leaks_run ?(x86 = false) ~dev ~env name expected =
let exe = compile ~dev ~x86 "programs/res-leaks.flan" in
let out = exe ^ ".out" in
let code =
Sys.command
(Printf.sprintf "%s%s > %s 2>&1"
(if env then "FLAN_DEV_LEAKS=1 " else "")
(Filename.quote exe) (Filename.quote out))
in
let text = In_channel.with_open_bin out In_channel.input_all in
(try Sys.remove out; Sys.remove exe with Sys_error _ -> ());
if code <> 0 || text <> expected then begin
incr failures;
Printf.printf "FAIL %s\n got: %S (exit %d)\n wanted: %S\n"
name text code expected
end
in
leaks_run ~dev:false ~env:true "library resources: a release build counts nothing"
"5\ndone\n";
leaks_run ~dev:true ~env:false
"library resources: no report without FLAN_DEV_LEAKS" "5\ndone\n";
leaks_run ~dev:true ~env:true
"library resources: a dev build reports what is held" res_dev_out;
leaks_run ~x86:true ~dev:true ~env:true
"library resources: a dev build reports what is held, x86" res_dev_out;
(* handler-bind and signal, spec-conditions.md §1 and §2: signal returns
Unit and carries on, an unhandled one is a no-op, a nested frame does
not displace the one outside it, and the stack is restored after. *)