1069 lines
46 KiB
OCaml
1069 lines
46 KiB
OCaml
(** [declare-c]: a foreign function written in the C library's own terms, with
|
|
the crossing generated rather than hand-written.
|
|
|
|
[declare] says "this Flan signature *is* the C signature" — the symbol it
|
|
names already trades in scalars and ptr+len, because somebody wrote it that
|
|
way ([flan_agent_start], [sqrtf], the runtime's own shims). That form is
|
|
unchanged and this module never touches one.
|
|
|
|
[declare-c] says the other thing: the signature is the *library's*, structs
|
|
by value and all, and the compiler is to produce whatever flattening makes
|
|
it crossable. The two cannot be one form —
|
|
[(declare start-raw [path str] i32 "flan_agent_start")] and
|
|
[(declare-c init-window [w i32 h i32 title str] "InitWindow")] are the
|
|
same shape and mean opposite things about who NUL-terminates the string.
|
|
|
|
Why the crossing is still C, and not [emit.ml]: a small aggregate's calling
|
|
convention is a per-target *classification*, not part of its layout.
|
|
x86-64 hands [Vector2] over as [<2 x float>] and returns [Rectangle] as
|
|
[{i64,i64}]; arm64 and wasm32 each do something else. Reproducing that in
|
|
the backend is three classifiers to keep correct forever, and a mistake
|
|
reads as a field full of garbage rather than as a link error. clang already
|
|
does it, per target, for free. So the C shim stays; what stops is writing
|
|
it by hand.
|
|
|
|
What this module does with one [declare-c]:
|
|
|
|
- emits a C [typedef] for every struct in the signature, from the Flan
|
|
[defstruct], transitively and once each;
|
|
- emits an [extern] prototype for the real function, in its true signature;
|
|
- emits a wrapper that flattens — a struct returns through an out-pointer,
|
|
a struct argument goes by pointer, a Flan string arrives as ptr+len and
|
|
the wrapper NUL-terminates a copy, and a returned string goes back as a
|
|
pointer and a length for the Flan side to copy;
|
|
- and rewrites the declaration into the flattened [declare] the Flan side
|
|
calls, with an ordinary Flan [defn] above it carrying the nice signature.
|
|
|
|
{2 What is guaranteed and what is trusted}
|
|
|
|
Guaranteed: the C typedef and the Flan struct come from the same
|
|
[defstruct], so they cannot disagree — permute the [defstruct] and the
|
|
typedef permutes with it. And clang type-checks the wrapper against the
|
|
[extern] prototype, so the flattening cannot disagree with the prototype.
|
|
|
|
Padding is not a separate hazard, which is worth saying because it reads
|
|
like one. For every field type this generator admits — the machine
|
|
integers, the two floats, [bool], a pointer and a nested struct — LLVM's
|
|
struct layout is C's, and [emit.ml] writes no datalayout, so clang applies
|
|
the target's own rules to both halves and they land in the same place.
|
|
Everything where the two could diverge — a fixed array, a slice, an
|
|
[Option], a map, a data type — is refused at the field, by name.
|
|
|
|
Trusted: that the [defstruct] describes the library's real struct, and that
|
|
the [declare-c] signature is the function's real signature. No library
|
|
header is read — deliberately, so a build needs the shared library and not
|
|
the -devel package — so nothing here can check either. Two consequences
|
|
worth stating plainly:
|
|
|
|
- the prototype is now generated *from the declaration*, so a scalar's
|
|
width carries ABI weight it did not before. [f64] where the library says
|
|
[float] used to be narrowed by clang at the hand-written call site; now
|
|
it emits [double] and the library reads garbage.
|
|
- the only thing that catches a wrong [defstruct] is a test that makes the
|
|
library *compute* with the fields — which is why the raylib acceptance
|
|
cases pin layouts by arithmetic and go red when a [defstruct] is
|
|
permuted.
|
|
|
|
A [_Static_assert] on [sizeof] and [offsetof] was considered and left out:
|
|
both sides of it would come from the same field list, so it would check
|
|
this module's arithmetic against clang's and say nothing about the library.
|
|
What converts the trusted half into a checked one is reading the real
|
|
header, and that is built: [Cimport] asks clang for a JSON dump of one
|
|
and compares both halves against it — every [defstruct] against the
|
|
header's record, and every [declare-c] against the header's signature.
|
|
Nothing in this module changed for it. The refusals below still raise,
|
|
which is right for a signature a human named; the importer makes the
|
|
same judgements and merely skips instead, since one variadic function
|
|
must not kill a header of five hundred functions. *)
|
|
|
|
let fail = Loc.fail
|
|
|
|
(* ── Names ──────────────────────────────────────────────────────────
|
|
A Flan name may contain '/', '-', '?' and '!', none of which a C identifier
|
|
may. Squashing them all to '_' is not injective — [valid?] and [valid_]
|
|
would collide — so the readable squash carries a digest of the original,
|
|
which makes it injective without making it unreadable. *)
|
|
|
|
let squash s =
|
|
let b = Buffer.create (String.length s) in
|
|
String.iter
|
|
(fun c ->
|
|
let ok =
|
|
(c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')
|
|
|| (c >= '0' && c <= '9')
|
|
in
|
|
Buffer.add_char b (if ok then c else '_'))
|
|
s;
|
|
Buffer.contents b
|
|
|
|
let mangle s =
|
|
Printf.sprintf "%s_%s" (squash s)
|
|
(String.sub (Digest.to_hex (Digest.string s)) 0 8)
|
|
|
|
let shim_symbol flan_name = "flan_shim_" ^ mangle flan_name
|
|
let ctype_name struct_name = "flan_ty_" ^ mangle struct_name
|
|
|
|
(* The Flan name the generated flattened declaration gets. It is visible, as
|
|
the hand-written [-raw] names were, because there is no visibility rule
|
|
yet. *)
|
|
let raw_name flan_name = flan_name ^ "-c"
|
|
|
|
(* Locals the generated Flan wrapper binds. A parameter is not an assignable
|
|
place (spec-memory.md), so a struct argument needs a copy to take the
|
|
address of — and the hand-written wrappers had to rename around their own
|
|
parameters to do it ([draw-triangle] bound [d] for [v3] to keep [c] for the
|
|
colour). These cannot collide with anything: the reader does not produce a
|
|
name beginning with '%'. *)
|
|
let tmp i = Printf.sprintf "%%a%d" i
|
|
let out_tmp = "%out"
|
|
let len_tmp = "%n"
|
|
let ptr_tmp = "%p"
|
|
|
|
(* ── The declarations in scope ──────────────────────────────────────── *)
|
|
|
|
type env = {
|
|
structs : (string, Ast.field list) Hashtbl.t;
|
|
enums : (string, unit) Hashtbl.t;
|
|
datas : (string, unit) Hashtbl.t;
|
|
unions : (string, unit) Hashtbl.t;
|
|
aliases : (string, Ast.texpr) Hashtbl.t;
|
|
}
|
|
|
|
let scan (decls : Ast.decl list) =
|
|
let env =
|
|
{ structs = Hashtbl.create 32; enums = Hashtbl.create 32;
|
|
datas = Hashtbl.create 8; unions = Hashtbl.create 8;
|
|
aliases = Hashtbl.create 16 }
|
|
in
|
|
List.iter
|
|
(fun (d : Ast.decl) ->
|
|
match d.Ast.d with
|
|
| Ast.Defstruct (n, fs, _) -> Hashtbl.replace env.structs n fs
|
|
| Ast.Defenum (n, _) -> Hashtbl.replace env.enums n ()
|
|
| Ast.Defdata (n, _) -> Hashtbl.replace env.datas n ()
|
|
| Ast.Defunion (n, _) -> Hashtbl.replace env.unions n ()
|
|
| Ast.Defalias (n, t) -> Hashtbl.replace env.aliases n t
|
|
| _ -> ())
|
|
decls;
|
|
env
|
|
|
|
(* An alias is a name for a type expression, so follow it before deciding what
|
|
a type is. [check.ml] rejects a cyclic alias, but this runs before it does,
|
|
so the walk is bounded rather than trusting. *)
|
|
let unalias env (t : Ast.texpr) =
|
|
let rec go fuel t =
|
|
if fuel = 0 then t
|
|
else
|
|
match t.Ast.t with
|
|
| Ast.Tname n ->
|
|
(match Hashtbl.find_opt env.aliases n with
|
|
| Some t' -> go (fuel - 1) t'
|
|
| None -> t)
|
|
| _ -> t
|
|
in
|
|
go 100 t
|
|
|
|
(* ── Flan type → C type ─────────────────────────────────────────────
|
|
One function, used for a struct's fields and for a function's parameters
|
|
alike, so the two cannot drift: a [bool] field and a [bool] argument are the
|
|
same C [bool] and never an [int]. *)
|
|
|
|
let prim_cty = function
|
|
| "i8" -> Some "int8_t" | "i16" -> Some "int16_t"
|
|
| "i32" -> Some "int32_t" | "i64" -> Some "int64_t"
|
|
| "u8" -> Some "uint8_t" | "u16" -> Some "uint16_t"
|
|
| "u32" -> Some "uint32_t" | "u64" -> Some "uint64_t"
|
|
| "f32" -> Some "float" | "f64" -> Some "double"
|
|
| "bool" -> Some "bool"
|
|
| _ -> None
|
|
|
|
(* ── Generic structs ──────────────────────────────────────────────────
|
|
A defstruct whose fields introduce [$t] is a template, and C only ever sees
|
|
one of its copies: the fields with the arguments written in, laid out the
|
|
way [Check] lays the same copy out. The copy is registered here under its
|
|
written spelling, [(G u8)], which [ctype_name] turns into a C name. *)
|
|
|
|
let sigil n = n <> "" && n.[0] = '$'
|
|
let bare n = if sigil n then String.sub n 1 (String.length n - 1) else n
|
|
|
|
(* A template's parameters, in the order its fields first introduce them, and
|
|
whether each is a length — [Check]'s reading, repeated over the AST
|
|
because this runs before [Check] does. *)
|
|
let rec template_params ?(fuel = 16) env n =
|
|
match Hashtbl.find_opt env.structs n with
|
|
| None -> []
|
|
| Some fs ->
|
|
let acc = ref [] in
|
|
let add m is_len =
|
|
if sigil m && not (List.mem_assoc (bare m) !acc) then
|
|
acc := (bare m, is_len) :: !acc
|
|
in
|
|
let rec walk (t : Ast.texpr) =
|
|
match t.Ast.t with
|
|
| Ast.Tname m -> add m false
|
|
| Ast.Tslice (_, e) -> walk e
|
|
| Ast.Tarray (Ast.Lname m, e) -> add m true; walk e
|
|
| Ast.Tarray (_, e) -> walk e
|
|
| Ast.Tmap (k, v) -> walk k; walk v
|
|
| Ast.Tapp (h, args) ->
|
|
let kinds =
|
|
if fuel = 0 || String.equal h n then []
|
|
else List.map snd (template_params ~fuel:(fuel - 1) env h)
|
|
in
|
|
if List.length kinds = List.length args then
|
|
List.iter2
|
|
(fun is_len (a : Ast.texpr) ->
|
|
match a.Ast.t with
|
|
| Ast.Tname m when is_len -> add m true
|
|
| _ -> walk a)
|
|
kinds args
|
|
else List.iter walk args
|
|
| Ast.Tfn (_, ps, r) -> List.iter walk ps; walk r
|
|
| Ast.Tlen _ | Ast.Tinfer -> ()
|
|
in
|
|
List.iter (fun (f : Ast.field) -> walk f.Ast.fty) fs;
|
|
List.rev !acc
|
|
|
|
let rec source (t : Ast.texpr) =
|
|
match t.Ast.t with
|
|
| Ast.Tname n -> n
|
|
| Ast.Tlen n -> Int64.to_string n
|
|
| Ast.Tinfer -> "_"
|
|
| Ast.Tapp (n, args) ->
|
|
Printf.sprintf "(%s %s)" n (String.concat " " (List.map source args))
|
|
| Ast.Tslice (c, e) -> Printf.sprintf "[%s%s]" (if c then "const " else "") (source e)
|
|
| Ast.Tarray (Ast.Lint n, e) -> Printf.sprintf "[%Ld %s]" n (source e)
|
|
| Ast.Tarray (Ast.Lname n, e) -> Printf.sprintf "[%s %s]" n (source e)
|
|
| Ast.Tmap (k, v) -> Printf.sprintf "(Map %s %s)" (source k) (source v)
|
|
| Ast.Tfn (env, ps, r) ->
|
|
Printf.sprintf "(%s [%s] %s)" (if env then "Fn" else "CFn")
|
|
(String.concat " " (List.map source ps)) (source r)
|
|
|
|
(* The copy of template [n] at [args], registered and named. *)
|
|
let copy env ~loc n (args : Ast.texpr list) =
|
|
let ps = template_params env n in
|
|
if List.length ps <> List.length args then
|
|
fail loc "%s takes %d argument%s, and this gives %d" n (List.length ps)
|
|
(if List.length ps = 1 then "" else "s") (List.length args);
|
|
let key = source { Ast.t = Ast.Tapp (n, args); tloc = loc } in
|
|
if not (Hashtbl.mem env.structs key) then begin
|
|
let sub = List.combine (List.map fst ps) args in
|
|
let rec go (t : Ast.texpr) =
|
|
let k =
|
|
match t.Ast.t with
|
|
| Ast.Tname m when List.mem_assoc (bare m) sub ->
|
|
(List.assoc (bare m) sub).Ast.t
|
|
| Ast.Tname _ | Ast.Tlen _ | Ast.Tinfer -> t.Ast.t
|
|
| Ast.Tslice (c, e) -> Ast.Tslice (c, go e)
|
|
| Ast.Tarray (Ast.Lname m, e) when List.mem_assoc (bare m) sub ->
|
|
let l =
|
|
match (List.assoc (bare m) sub).Ast.t with
|
|
| Ast.Tlen k -> Ast.Lint k
|
|
| Ast.Tname c -> Ast.Lname c
|
|
| _ -> fail loc "%s's $%s is a length" n (bare m)
|
|
in
|
|
Ast.Tarray (l, go e)
|
|
| Ast.Tarray (l, e) -> Ast.Tarray (l, go e)
|
|
| Ast.Tmap (k, v) -> Ast.Tmap (go k, go v)
|
|
| Ast.Tapp (h, a) -> Ast.Tapp (h, List.map go a)
|
|
| Ast.Tfn (b, ps, r) -> Ast.Tfn (b, List.map go ps, go r)
|
|
in
|
|
{ t with Ast.t = k }
|
|
in
|
|
Hashtbl.replace env.structs key
|
|
(List.map (fun (f : Ast.field) -> { f with Ast.fty = go f.Ast.fty })
|
|
(Hashtbl.find env.structs n))
|
|
end;
|
|
key
|
|
|
|
let is_template env n = template_params env n <> []
|
|
|
|
(* [needed] collects the structs whose typedefs this signature pulls in, in the
|
|
order they were first met. Order is the program's and never a hash fold's:
|
|
the object cache keys on the generated text, so a reordering would be a
|
|
rebuild. *)
|
|
let rec cty env ~needed ~loc ~what (t : Ast.texpr) : string =
|
|
let t = unalias env t in
|
|
match t.Ast.t with
|
|
| Ast.Tname n when Hashtbl.mem env.structs n && is_template env n ->
|
|
fail loc "%s is %s, a generic struct, which is a type only at its \
|
|
arguments — write them, as in (%s %s)" what n n
|
|
(String.concat " "
|
|
(List.map (fun (_, l) -> if l then "8" else "i32")
|
|
(template_params env n)))
|
|
| Ast.Tapp (n, args) when Hashtbl.mem env.structs n && is_template env n ->
|
|
cty env ~needed ~loc ~what { t with Ast.t = Ast.Tname (copy env ~loc n args) }
|
|
| Ast.Tname n ->
|
|
(match prim_cty n with
|
|
| Some c -> c
|
|
| None ->
|
|
if Hashtbl.mem env.structs n then begin
|
|
if not (List.mem n !needed) then needed := !needed @ [ n ];
|
|
ctype_name n
|
|
end
|
|
else if Hashtbl.mem env.enums n then
|
|
(* A C enum is an int, and Flan's [Enum] is an i32 — the same thing on
|
|
every target this compiles for. *)
|
|
"int32_t"
|
|
else if Hashtbl.mem env.datas n then
|
|
fail loc
|
|
"%s is %s, a data type, which has no C layout"
|
|
what n
|
|
(* A union is the one refusal here that is not about the type. It has a
|
|
C layout — it *is* a C layout, which is the whole reason it exists —
|
|
and what is missing is the generator: [typedefs] writes structs, and
|
|
a union would need its own spelling and its own closure over the
|
|
member types. Refused by name rather than written untested, and the
|
|
way through is the way every other aggregate crosses. *)
|
|
else if Hashtbl.mem env.unions n then
|
|
fail loc
|
|
"%s is %s, a union, and the shim generator writes structs only. \
|
|
Pass (Ptr %s) and let the C side read it"
|
|
what n n
|
|
else if String.equal n "str" then
|
|
fail loc
|
|
"%s is a string, and a string crosses only as a parameter or a \
|
|
return value — declare (Ptr u8) and read it in Flan"
|
|
what
|
|
else if String.equal n "Unit" || String.equal n "Never" then
|
|
fail loc "%s is %s, which is not a value C can carry" what n
|
|
else
|
|
fail loc "%s is %s, which is not a type this shim generator knows" what n)
|
|
| Ast.Tapp ("Ptr", [ e ]) -> cty env ~needed ~loc ~what e ^ " *"
|
|
| Ast.Tapp ("Ptr", [ { Ast.t = Ast.Tname "const"; _ }; e ]) ->
|
|
"const " ^ cty env ~needed ~loc ~what e ^ " *"
|
|
| Ast.Tapp ("Option", _) ->
|
|
fail loc
|
|
"%s is an Option, which C has no shape for — declare what C returns and \
|
|
build the Option in Flan"
|
|
what
|
|
| Ast.Tslice _ ->
|
|
fail loc
|
|
"%s is a slice, and nothing here says what type the C count parameter \
|
|
is — declare (Ptr T) with an explicit count, and pass \
|
|
(addr (at s 0)) and (length s) from Flan"
|
|
what
|
|
| Ast.Tarray _ ->
|
|
fail loc
|
|
"%s is a fixed array, which C passes as a pointer and Flan as a value — \
|
|
declare (Ptr T) and say which"
|
|
what
|
|
(* Two spellings reach the same type: [Ast.Tmap], which only [Cimport]
|
|
builds now, and [(Map K V)], which is what source writes since the brace
|
|
spelling was withdrawn from type position. Both are refused here. *)
|
|
| Ast.Tmap _ | Ast.Tapp ("Map", _) ->
|
|
fail loc "%s is a map, which has no C representation" what
|
|
(* A Vec owns its storage, so handing its header to C hands out an owner and
|
|
there is no rule for what C would then be allowed to do with it. The
|
|
elements cross the way any other run of elements does. *)
|
|
| Ast.Tapp ("Vec", _) ->
|
|
fail loc
|
|
"%s is a Vec, which owns its storage. Pass (slice v) as (Ptr T) and \
|
|
(length v)"
|
|
what
|
|
| Ast.Tfn _ ->
|
|
fail loc "%s is a function type, and a C callback is not implemented" what
|
|
| Ast.Tinfer ->
|
|
fail loc "%s is _, and a C signature writes every type out" what
|
|
| Ast.Tapp (n, _) ->
|
|
fail loc "%s is %s, which is not a type this shim generator knows" what n
|
|
| Ast.Tlen n -> fail loc "%s is %Ld, which is not a type" what n
|
|
|
|
(* ── What one parameter does at the boundary ────────────────────────── *)
|
|
|
|
type pkind =
|
|
| Pscalar (* crosses as itself: an int, a float, a Ptr *)
|
|
| Pstruct of string (* by value in C; by pointer across the boundary *)
|
|
| Pstr (* ptr+len in, a NUL-terminated copy out *)
|
|
|
|
let classify env ~needed ~loc ~what (t : Ast.texpr) =
|
|
let t' = unalias env t in
|
|
match t'.Ast.t with
|
|
| Ast.Tname "str" -> (Pstr, "const char *")
|
|
(* A copy crosses behind a pointer only: by value, the Flan half this
|
|
generator writes would have to spell the copy's type, and it builds its
|
|
wrapper from struct names. *)
|
|
| Ast.Tapp (n, _) when Hashtbl.mem env.structs n && is_template env n ->
|
|
fail loc
|
|
"%s is %s, a generic struct's copy, which crosses to C behind a pointer \
|
|
only — declare (Ptr %s) and let the C side read it"
|
|
what (source t') (source t')
|
|
| Ast.Tname n when Hashtbl.mem env.structs n ->
|
|
ignore (cty env ~needed ~loc ~what t');
|
|
(Pstruct n, ctype_name n)
|
|
| _ -> (Pscalar, cty env ~needed ~loc ~what t')
|
|
|
|
(* ── The C text ─────────────────────────────────────────────────────── *)
|
|
|
|
let header =
|
|
"/* Generated by Flan from the (declare-c ...) forms in this program. Do not\n\
|
|
\ * edit it: it is rebuilt from the declarations on every build, and the\n\
|
|
\ * object cache is keyed by the text below, so an edit here is either\n\
|
|
\ * overwritten or — worse — kept after the declarations have moved on.\n\
|
|
\ *\n\
|
|
\ * Every wrapper exists so that no aggregate crosses the Flan/C boundary. A\n\
|
|
\ * small struct's calling convention is a per-target classification rather\n\
|
|
\ * than part of its layout, so clang does it here, correctly, for whichever\n\
|
|
\ * target this build is for, and the backend never learns x86-64 from arm64\n\
|
|
\ * from wasm32.\n\
|
|
\ *\n\
|
|
\ * No library header is included, deliberately: the prototypes below are the\n\
|
|
\ * declarations, so a build needs the shared library to be linkable and not\n\
|
|
\ * the -devel package to be installed. The price is that a prototype here is\n\
|
|
\ * only as right as the declare-c it came from.\n\
|
|
\ */\n\n\
|
|
#include <stdbool.h>\n\
|
|
#include <stddef.h>\n\
|
|
#include <stdint.h>\n\
|
|
#include <stdlib.h>\n\
|
|
#include <string.h>\n\n"
|
|
|
|
(* A Flan string is ptr+len and never NUL-terminated, so a C API that wants a C
|
|
string needs a copy. The hand-written wrappers sized the buffer per call
|
|
site — 256 for a window title, PATH_MAX for a path, 512 for drawn text — and
|
|
truncated past it. A generator has no call site to look at, so it must not
|
|
be the thing deciding a string is too long: what does not fit the stack
|
|
buffer is copied to the heap and freed after the call. The stack buffer is
|
|
what keeps that allocation-free in the overwhelmingly common case, and it is
|
|
256 because that covers a title, a path and a line of text without making
|
|
every foreign call carry a page of stack. The only truncation left is when
|
|
malloc itself fails, where the alternative is handing C a null pointer.
|
|
|
|
An embedded NUL is refused rather than copied, which is the policy
|
|
flan_path_cstr has always had for a path and which a title, a name or a
|
|
query needs for the same reason: C reads to the first NUL, so what crosses
|
|
would be a prefix of the string the program passed and the function would
|
|
act on a value nobody wrote. The refusal is the runtime's — the shim has no
|
|
condition channel — and it names the declare-c it came from.
|
|
|
|
A literal is the one string that crosses uncopied. Both backends write a
|
|
NUL after a literal's bytes, and at a declare-c call whose argument is a
|
|
literal the checker passes it with its length encoded as -(n+1)
|
|
([Check.c_literals]). No other Flan string has a negative length, so the
|
|
wrapper hands such a pointer to C as it is, after the same embedded-NUL
|
|
refusal. Every other string is copied, whatever its last byte is. *)
|
|
let cstr_helpers =
|
|
"_Noreturn void flan_shim_nul_fail(const char *site);\n\n\
|
|
static char *flan_shim_cstr(const char *p, int64_t n, char *buf, size_t cap,\n\
|
|
\ const char *site) {\n\
|
|
\ size_t len;\n\
|
|
\ char *d = buf;\n\
|
|
\ if (n < 0) { /* a literal, NUL-terminated by the compiler */\n\
|
|
\ len = (size_t)(-(n + 1));\n\
|
|
\ if (len != 0 && memchr(p, '\\0', len) != NULL) flan_shim_nul_fail(site);\n\
|
|
\ return (char *)p;\n\
|
|
\ }\n\
|
|
\ len = (size_t)n;\n\
|
|
\ if (len != 0 && memchr(p, '\\0', len) != NULL) flan_shim_nul_fail(site);\n\
|
|
\ if (len + 1 > cap) {\n\
|
|
\ d = (char *)malloc(len + 1);\n\
|
|
\ if (d == NULL) { d = buf; len = cap - 1; } /* out of memory: truncate */\n\
|
|
\ }\n\
|
|
\ if (len != 0) memcpy(d, p, len);\n\
|
|
\ d[len] = '\\0';\n\
|
|
\ return d;\n\
|
|
}\n\n\
|
|
static void flan_shim_cstr_free(char *d, char *buf, const char *p) {\n\
|
|
\ if (d != buf && d != p) free(d);\n\
|
|
}\n\n"
|
|
|
|
let cstr_cap = 256
|
|
|
|
(* The return direction. C hands back a [const char *] Flan has no owner for:
|
|
it may be the library's static buffer, overwritten by the next call, or a
|
|
pointer into an argument. The wrapper answers the pointer and its length,
|
|
and the generated Flan wrapper copies the bytes into the context allocator
|
|
before anything else can run — which is where the owner comes from, and why
|
|
the copy is Flan's and not C's: it goes through the same guard and the same
|
|
registry note as (bytes s).
|
|
|
|
[flan_shim_ret_len] is the whole of it when the call took no string, since
|
|
nothing the wrapper frees can be under the pointer. [flan_shim_ret_keep] is
|
|
for when it did: the argument copies die when the wrapper returns, so the
|
|
text is moved first to one scratch buffer the shim owns and reuses. A null
|
|
is the empty string. The length is an [i32] because a slice's is; a C
|
|
string past two gigabytes is cut there, and malloc failing is cut at the
|
|
buffer that exists, which is the argument copy's policy too. *)
|
|
let ret_helpers =
|
|
"static const char *flan_shim_ret_len(const char *r, int32_t *n) {\n\
|
|
\ size_t len = r == NULL ? 0 : strlen(r);\n\
|
|
\ *n = len > INT32_MAX ? INT32_MAX : (int32_t)len;\n\
|
|
\ return r;\n\
|
|
}\n\n\
|
|
static const char *flan_shim_ret_keep(const char *r, int32_t *n) {\n\
|
|
\ static char *buf = NULL;\n\
|
|
\ static size_t cap = 0;\n\
|
|
\ size_t len = r == NULL ? 0 : strlen(r);\n\
|
|
\ if (len > INT32_MAX) len = INT32_MAX;\n\
|
|
\ if (len > cap) {\n\
|
|
\ char *d = (char *)realloc(buf, len);\n\
|
|
\ if (d != NULL) { buf = d; cap = len; } else len = cap;\n\
|
|
\ }\n\
|
|
\ if (len != 0) memcpy(buf, r, len);\n\
|
|
\ *n = (int32_t)len;\n\
|
|
\ return buf;\n\
|
|
}\n\n"
|
|
|
|
(* One [declare-c], reduced to what both halves need. *)
|
|
type shim = {
|
|
sflan : string; (* the Flan name as written *)
|
|
ssym : string; (* the C symbol being bound *)
|
|
swrap : string; (* the generated wrapper's symbol *)
|
|
sargs : (pkind * string) list; (* kind and C type, per parameter *)
|
|
sret : [ `Void | `Scalar of string | `Struct of string * string | `Str ];
|
|
sloc : Loc.t;
|
|
}
|
|
|
|
let arg_name i = Printf.sprintf "a%d" i
|
|
|
|
(* The wrapper's own parameter list: a struct by pointer, a string as ptr+len,
|
|
anything else as itself — plus the out-pointer when C returns a struct. *)
|
|
let wrapper_params s =
|
|
let ps =
|
|
List.concat
|
|
(List.mapi
|
|
(fun i (k, c) ->
|
|
let a = arg_name i in
|
|
match k with
|
|
| Pstruct _ -> [ Printf.sprintf "const %s *%s" c a ]
|
|
| Pstr ->
|
|
[ Printf.sprintf "const char *%s_p" a;
|
|
Printf.sprintf "int64_t %s_n" a ]
|
|
| Pscalar ->
|
|
[ (if String.length c > 0 && c.[String.length c - 1] = '*' then
|
|
Printf.sprintf "%s%s" c a
|
|
else Printf.sprintf "%s %s" c a) ])
|
|
s.sargs)
|
|
in
|
|
match s.sret with
|
|
| `Struct (_, c) -> ps @ [ Printf.sprintf "%s *out" c ]
|
|
| `Str -> ps @ [ "int32_t *out_n" ]
|
|
| _ -> ps
|
|
|
|
let c_for (s : shim) =
|
|
let b = Buffer.create 512 in
|
|
Printf.bprintf b "/* %s */\n" s.sflan;
|
|
(* The prototype, in the library's own terms. *)
|
|
let proto_args =
|
|
List.map
|
|
(fun (k, c) ->
|
|
match k with Pstruct _ -> c | Pstr -> "const char *" | Pscalar -> c)
|
|
s.sargs
|
|
in
|
|
let proto_ret =
|
|
match s.sret with
|
|
| `Void -> "void" | `Scalar c -> c | `Struct (_, c) -> c
|
|
| `Str -> "const char *"
|
|
in
|
|
Printf.bprintf b "extern %s %s(%s);\n" proto_ret s.ssym
|
|
(match proto_args with [] -> "void" | _ -> String.concat ", " proto_args);
|
|
let wret =
|
|
match s.sret with
|
|
| `Struct _ | `Void -> "void" | `Scalar c -> c | `Str -> "const char *"
|
|
in
|
|
let wparams = wrapper_params s in
|
|
Printf.bprintf b "%s %s(%s) {\n" wret s.swrap
|
|
(match wparams with [] -> "void" | _ -> String.concat ", " wparams);
|
|
(* The NUL-terminated copies, before the call. *)
|
|
List.iteri
|
|
(fun i (k, _) ->
|
|
match k with
|
|
| Pstr ->
|
|
let a = arg_name i in
|
|
Printf.bprintf b " char %s_b[%d];\n" a cstr_cap;
|
|
(* The Flan name travels with the copy so that a refusal names the
|
|
call the way every other runtime trap names its site. *)
|
|
Printf.bprintf b
|
|
" char *%s = flan_shim_cstr(%s_p, %s_n, %s_b, sizeof %s_b, %S);\n"
|
|
a a a a a s.sflan
|
|
| _ -> ())
|
|
s.sargs;
|
|
let call_args =
|
|
List.mapi
|
|
(fun i (k, _) ->
|
|
let a = arg_name i in
|
|
match k with Pstruct _ -> "*" ^ a | Pstr | Pscalar -> a)
|
|
s.sargs
|
|
in
|
|
let call = Printf.sprintf "%s(%s)" s.ssym (String.concat ", " call_args) in
|
|
let has_str = List.exists (fun (k, _) -> k = Pstr) s.sargs in
|
|
(match s.sret with
|
|
| `Void -> Printf.bprintf b " %s;\n" call
|
|
| `Struct _ -> Printf.bprintf b " *out = %s;\n" call
|
|
| `Scalar c ->
|
|
(* The result is named rather than returned straight through when there
|
|
are copies to free: the free has to happen after the call. *)
|
|
if has_str then Printf.bprintf b " %s r = %s;\n" c call
|
|
else Printf.bprintf b " return %s;\n" call
|
|
(* A returned string may point into one of the argument copies —
|
|
GetFileName answers a pointer into the path it was given — and those die
|
|
below or when this function returns. So when there are copies it is
|
|
moved to the scratch buffer first. Without them it points at the
|
|
library's own storage, which outlives the call, and the length is all
|
|
that is needed. *)
|
|
| `Str ->
|
|
Printf.bprintf b " const char *r = %s(%s, out_n);\n"
|
|
(if has_str then "flan_shim_ret_keep" else "flan_shim_ret_len") call);
|
|
(match s.sret with
|
|
| `Str when not has_str -> Buffer.add_string b " return r;\n"
|
|
| _ -> ());
|
|
if has_str then begin
|
|
List.iteri
|
|
(fun i (k, _) ->
|
|
match k with
|
|
| Pstr ->
|
|
let a = arg_name i in
|
|
Printf.bprintf b " flan_shim_cstr_free(%s, %s_b, %s_p);\n" a a a
|
|
| _ -> ())
|
|
s.sargs;
|
|
match s.sret with
|
|
| `Scalar _ | `Str -> Buffer.add_string b " return r;\n"
|
|
| _ -> ()
|
|
end;
|
|
Buffer.add_string b "}\n\n";
|
|
Buffer.contents b
|
|
|
|
(* The typedefs, forward-declared first so a struct may hold a pointer to one
|
|
defined below it — or to itself — and then defined in dependency order, so a
|
|
struct held *by value* is complete before it is used. *)
|
|
let typedefs env needed =
|
|
let b = Buffer.create 512 in
|
|
(* The transitive closure, in first-met order. *)
|
|
let rec close acc n =
|
|
if List.mem n acc then acc
|
|
else
|
|
let acc = acc @ [ n ] in
|
|
match Hashtbl.find_opt env.structs n with
|
|
| None -> acc
|
|
| Some fs ->
|
|
List.fold_left
|
|
(fun acc (f : Ast.field) ->
|
|
let sink = ref [] in
|
|
(* The type mapper is reused here purely to discover the struct
|
|
names a field mentions; its text is not wanted. Mapping it now
|
|
is also what refuses an unrepresentable field, at the field. *)
|
|
ignore
|
|
(cty env ~needed:sink ~loc:f.Ast.floc
|
|
~what:(Printf.sprintf "field %s of %s" f.Ast.fname n)
|
|
f.Ast.fty);
|
|
List.fold_left close acc !sink)
|
|
acc fs
|
|
in
|
|
let all = List.fold_left close [] needed in
|
|
List.iter
|
|
(fun n ->
|
|
Printf.bprintf b "typedef struct %s_s %s;\n" (ctype_name n) (ctype_name n))
|
|
all;
|
|
if all <> [] then Buffer.add_char b '\n';
|
|
(* Define a struct after every struct it holds by value. *)
|
|
let defined = ref [] in
|
|
let rec define n =
|
|
if not (List.mem n !defined) then begin
|
|
defined := n :: !defined;
|
|
let fs = Hashtbl.find env.structs n in
|
|
List.iter
|
|
(fun (f : Ast.field) ->
|
|
match (unalias env f.Ast.fty).Ast.t with
|
|
| Ast.Tname m when Hashtbl.mem env.structs m -> define m
|
|
| Ast.Tapp (m, args) when Hashtbl.mem env.structs m && is_template env m ->
|
|
define (copy env ~loc:f.Ast.floc m args)
|
|
| _ -> ())
|
|
fs;
|
|
Printf.bprintf b "struct %s_s { /* %s */\n" (ctype_name n) n;
|
|
List.iter
|
|
(fun (f : Ast.field) ->
|
|
let c =
|
|
cty env ~needed:(ref []) ~loc:f.Ast.floc
|
|
~what:(Printf.sprintf "field %s of %s" f.Ast.fname n) f.Ast.fty
|
|
in
|
|
let star = String.length c > 0 && c.[String.length c - 1] = '*' in
|
|
(* A field name needs no digest: it is scoped to this struct, and
|
|
two Flan fields that squash together are a duplicate member
|
|
clang refuses by name. *)
|
|
Printf.bprintf b " %s%s%s;\n" c (if star then "" else " ")
|
|
(squash f.Ast.fname))
|
|
fs;
|
|
Buffer.add_string b "};\n\n"
|
|
end
|
|
in
|
|
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 }
|
|
let ex loc e = { Ast.e; loc }
|
|
|
|
(* The flattened declaration the Flan side actually calls: a struct parameter
|
|
becomes (Ptr T), a struct return becomes a trailing out-parameter. *)
|
|
let flattened (fn : Ast.fn) (s : shim) name : Ast.fn =
|
|
let loc = fn.Ast.nloc in
|
|
let params =
|
|
List.map2
|
|
(fun (p : Ast.field) (k, _) ->
|
|
match k with
|
|
| Pstruct n ->
|
|
{ p with
|
|
Ast.fty =
|
|
ty p.Ast.floc
|
|
(Ast.Tapp ("Ptr", [ ty p.Ast.floc (Ast.Tname n) ])) }
|
|
| _ -> p)
|
|
fn.Ast.params s.sargs
|
|
in
|
|
match s.sret with
|
|
| `Struct (n, _) ->
|
|
{ fn with
|
|
Ast.name;
|
|
params =
|
|
params
|
|
@ [ { Ast.fname = "out"; floc = loc;
|
|
fty = ty loc (Ast.Tapp ("Ptr", [ ty loc (Ast.Tname n) ])) } ];
|
|
ret = None }
|
|
| `Str ->
|
|
{ fn with
|
|
Ast.name;
|
|
params =
|
|
params
|
|
@ [ { Ast.fname = "out-n"; floc = loc;
|
|
fty = ty loc (Ast.Tapp ("Ptr", [ ty loc (Ast.Tname "i32") ])) } ];
|
|
ret = Some (ty loc (Ast.Tapp ("Ptr", [ ty loc (Ast.Tname "u8") ]))) }
|
|
| _ -> { fn with Ast.name; params }
|
|
|
|
(* The ordinary Flan function that carries the nice signature: it copies each
|
|
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 ?track (fn : Ast.fn) (s : shim) raw : Ast.decl_kind =
|
|
let loc = fn.Ast.nloc in
|
|
let binds = ref [] in
|
|
let args =
|
|
List.mapi
|
|
(fun i ((p : Ast.field), (k, _)) ->
|
|
match k with
|
|
| Pstruct _ ->
|
|
let t = tmp i in
|
|
binds :=
|
|
!binds
|
|
@ [ { Ast.bname = t; bty = None;
|
|
bval = ex p.Ast.floc (Ast.Var p.Ast.fname);
|
|
bloc = p.Ast.floc } ];
|
|
ex p.Ast.floc
|
|
(Ast.Call
|
|
(ex p.Ast.floc (Ast.Var "addr"), [ ex p.Ast.floc (Ast.Var t) ]))
|
|
| _ -> ex p.Ast.floc (Ast.Var p.Ast.fname))
|
|
(List.combine fn.Ast.params s.sargs)
|
|
in
|
|
let call args = ex loc (Ast.Call (ex loc (Ast.Var raw), args)) in
|
|
let body, ret =
|
|
match s.sret with
|
|
| `Struct (n, _) ->
|
|
binds :=
|
|
!binds
|
|
@ [ { Ast.bname = out_tmp; bty = None;
|
|
bval = ex loc (Ast.Struct (n, [])); bloc = loc } ];
|
|
let out = ex loc (Ast.Var out_tmp) in
|
|
( [ call (args @ [ ex loc (Ast.Call (ex loc (Ast.Var "addr"), [ out ])) ]);
|
|
out ],
|
|
Some (ty loc (Ast.Tname n)) )
|
|
| `Str ->
|
|
(* (str (bytes (str (slice-from p n)))): a view of C's bytes,
|
|
copied by [bytes] into the context allocator, and seen as a string
|
|
again. The length is bound before the pointer is, so its address
|
|
exists to be written through. *)
|
|
let v n = ex loc (Ast.Var n) in
|
|
let app f xs = ex loc (Ast.Call (v f, xs)) in
|
|
binds :=
|
|
!binds
|
|
@ [ { Ast.bname = len_tmp; bty = Some (ty loc (Ast.Tname "i32"));
|
|
bval = ex loc (Ast.Int 0L); bloc = loc };
|
|
{ Ast.bname = ptr_tmp; bty = None;
|
|
bval = call (args @ [ app "addr" [ v len_tmp ] ]); bloc = loc } ];
|
|
( [ app "str"
|
|
[ app "bytes"
|
|
[ app "str"
|
|
[ app "slice-from" [ v ptr_tmp; v len_tmp ] ] ] ] ],
|
|
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 ~tracks (fn : Ast.fn) csym loc =
|
|
let needed = ref [] in
|
|
let sargs =
|
|
List.map
|
|
(fun (p : Ast.field) ->
|
|
classify env ~needed ~loc:p.Ast.floc
|
|
~what:(Printf.sprintf "parameter %s of %s" p.Ast.fname fn.Ast.name)
|
|
p.Ast.fty)
|
|
fn.Ast.params
|
|
in
|
|
let what = Printf.sprintf "the return type of %s" fn.Ast.name in
|
|
let sret =
|
|
match fn.Ast.ret with
|
|
| None -> `Void
|
|
| Some t ->
|
|
let t' = unalias env t in
|
|
(match t'.Ast.t with
|
|
| Ast.Tname "Unit" -> `Void
|
|
| Ast.Tname "str" -> `Str
|
|
| Ast.Tname n when Hashtbl.mem env.structs n ->
|
|
ignore (cty env ~needed ~loc ~what t');
|
|
`Struct (n, ctype_name n)
|
|
| _ -> `Scalar (cty env ~needed ~loc ~what t'))
|
|
in
|
|
let s =
|
|
{ sflan = fn.Ast.name; ssym = csym; swrap = shim_symbol fn.Ast.name; sargs;
|
|
sret; sloc = loc }
|
|
in
|
|
(* A declaration whose Flan face already equals its flattened face needs no
|
|
Flan function on top of it; only the ones with a struct in the signature
|
|
do. A string is not one of those — it crosses as ptr+len either way, and
|
|
it is the C wrapper that terminates it. *)
|
|
let needs_flan =
|
|
(match sret with `Struct _ | `Str -> true | _ -> false)
|
|
|| List.exists (fun (k, _) -> match k with Pstruct _ -> true | _ -> false)
|
|
sargs
|
|
in
|
|
let decls =
|
|
if needs_flan then
|
|
let raw = raw_name fn.Ast.name in
|
|
(* The flattened declaration's name is made up, so it can collide with
|
|
one somebody wrote. Refused here, naming both, rather than arriving as
|
|
the checker's "declared twice" about a name not in the file. *)
|
|
if Hashtbl.mem taken raw then
|
|
fail 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 ?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)
|
|
|
|
(* 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. *)
|
|
(* The C comes back in parts rather than as one string: a wrapper belongs to
|
|
the binding it serves, and [Reach.link] drops the bindings nothing reachable
|
|
calls. One TU holding every wrapper would reference every C symbol in the
|
|
library, so a program that imports raylib and never draws would still fail
|
|
to link without libraylib — which is the whole thing [Reach] exists to
|
|
avoid. The key is the flattened declaration's name; "" is the preamble. *)
|
|
let expand (decls : Ast.decl list) : Ast.decl list * (string * string) list =
|
|
let env = scan decls in
|
|
(* The flattened declaration's name is made up, so it can collide with one
|
|
somebody wrote. Refused here, naming both, rather than surfacing as the
|
|
checker's "declared twice" about a name that is not in the file. *)
|
|
let taken = Hashtbl.create 64 in
|
|
List.iter
|
|
(fun (d : Ast.decl) ->
|
|
match Ast.declared_name d with
|
|
| 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 =
|
|
List.concat_map
|
|
(fun (d : Ast.decl) ->
|
|
match d.Ast.d with
|
|
| Ast.DeclareC (fn, csym) ->
|
|
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 ])
|
|
n;
|
|
List.map (fun k -> { d with Ast.d = k }) ds
|
|
| _ -> [ d ])
|
|
decls
|
|
in
|
|
match !shims with
|
|
| [] -> (out, [])
|
|
| shims ->
|
|
(* Two Flan names may not bind one C symbol: the prototype would be emitted
|
|
twice, and a second Flan name for the same function is a [defn] and not
|
|
a second declaration. *)
|
|
let seen = Hashtbl.create 16 in
|
|
List.iter
|
|
(fun s ->
|
|
match Hashtbl.find_opt seen s.ssym with
|
|
| Some other ->
|
|
fail s.sloc
|
|
"%s and %s both bind the C function %s — one declare-c per C \
|
|
function, and another Flan name for it is a defn"
|
|
other s.sflan s.ssym
|
|
| None -> Hashtbl.replace seen s.ssym s.sflan)
|
|
shims;
|
|
let b = Buffer.create 4096 in
|
|
Buffer.add_string b header;
|
|
if List.exists (fun s -> List.exists (fun (k, _) -> k = Pstr) s.sargs) shims
|
|
then Buffer.add_string b cstr_helpers;
|
|
if List.exists (fun s -> s.sret = `Str) shims then
|
|
Buffer.add_string b ret_helpers;
|
|
(* Every typedef the program needs, kept whole even when wrappers are
|
|
dropped: an unused typedef costs nothing, and working out which ones a
|
|
surviving subset still needs is a second dependency walk for no gain. *)
|
|
Buffer.add_string b (typedefs env !needed);
|
|
(out,
|
|
("", Buffer.contents b)
|
|
(* Keyed by the wrapper's own C symbol, not by a Flan name: the flattened
|
|
declaration is named [foo-c] when a Flan wrapper is generated over it
|
|
and [foo] when none is needed, so the Flan name is not one thing.
|
|
[swrap] is what the declaration binds either way. *)
|
|
:: List.map (fun s -> (s.swrap, c_for s)) shims)
|