Joseph Ferano
5aa6c16209
spec-memory.md says ownership is structural: a struct containing a Vec is itself move-only, free recurses into owning fields, and a field cannot be freed on its own. None of that machinery exists — it is the recursive teardown drop brings — and the move rule as written covered only the types Vec appears in directly. Three ways past it, each of which hands out a second owner of one buffer: A struct field of Vec type. The struct copies its header on assignment and nothing records a move. A global of Vec type. The dead set is per function, so two functions each freeing it is a double free nothing could see, and a global read does not go through the move path at all — even the one-function case was accepted. Half a rule is worse than none, so the type is refused where it is declared. A global Allocator is not this and stays legal: an allocator is a copyable handle, and it is what makes a handler that owns the arena expressible. A Vec of a Vec. The runtime is type-erased and copies elements bytewise, so clone would duplicate inner headers rather than copying what they own and free would drop their buffers. Shipping the shallow answer under the deep name was the alternative. All three name drop as what they wait on. Also: match arms shared one dead set, so `(match o (Some k) (free v) None (free v))` reported the second arm as a use after the first arm's move — a legal program refused, the same case that was already fixed for `if`. Arms are alternatives, so each starts from the state before the match and the union survives the join. And a Vec reaching declare-c now says what to pass instead. It was already refused, by the shim generator's catch-all for a type it does not know; the reason it is refused is that handing a header that owns storage to C hands out an owner, and that is worth saying at the declaration.
661 lines
28 KiB
OCaml
661 lines
28 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 string] i32 "flan_agent_start")] and
|
|
[(declare-c init-window [w i32 h i32 title string] "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 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 union — 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 would convert the trusted half into a checked one is including the
|
|
real header when one is installed, and that is not built. *)
|
|
|
|
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"
|
|
|
|
(* ── The declarations in scope ──────────────────────────────────────── *)
|
|
|
|
type env = {
|
|
structs : (string, Ast.field list) Hashtbl.t;
|
|
enums : (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;
|
|
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.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
|
|
|
|
(* [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 ->
|
|
(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.unions n then
|
|
fail loc
|
|
"%s is %s, a union, and a Flan union has no C layout — the shim \
|
|
cannot be generated for it"
|
|
what n
|
|
else if String.equal n "string" then
|
|
fail loc
|
|
"%s is a string, and a string only crosses as a parameter — a C \
|
|
function that *returns* one returns something Flan has no owner for"
|
|
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 ("Option", _) ->
|
|
fail loc
|
|
"%s is an Option, which is a Flan shape and not a C one — declare what C \
|
|
returns and build the Option in Flan"
|
|
what
|
|
| Ast.Tslice _ ->
|
|
fail loc
|
|
"%s is a slice, which crosses as ptr+len with an i64 length, and the \
|
|
count parameter the C function actually takes has a type this \
|
|
declaration does not say — declare (Ptr T) with an explicit count and \
|
|
pass (addr (at s 0)) and (len 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
|
|
| Ast.Tmap _ -> 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 — handing its header to C hands out \
|
|
an owner. Pass (as-slice v) as (Ptr T) and (len v), the same shape a \
|
|
slice crosses in"
|
|
what
|
|
| Ast.Tfn _ ->
|
|
fail loc "%s is a function type, and a C callback is not implemented" what
|
|
| Ast.Tapp (n, _) ->
|
|
fail loc "%s is %s, which is not a type this shim generator knows" 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 "string" -> (Pstr, "const char *")
|
|
| 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. *)
|
|
let cstr_helpers =
|
|
"static char *flan_shim_cstr(const char *p, int64_t n, char *buf, size_t cap) {\n\
|
|
\ size_t len = n <= 0 ? 0 : (size_t)n;\n\
|
|
\ char *d = buf;\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) {\n\
|
|
\ if (d != buf) free(d);\n\
|
|
}\n\n"
|
|
|
|
let cstr_cap = 256
|
|
|
|
(* 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 ];
|
|
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 ]
|
|
| _ -> 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
|
|
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 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;
|
|
Printf.bprintf b
|
|
" char *%s = flan_shim_cstr(%s_p, %s_n, %s_b, sizeof %s_b);\n" a a a
|
|
a a
|
|
| _ -> ())
|
|
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);
|
|
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);\n" a a
|
|
| _ -> ())
|
|
s.sargs;
|
|
match s.sret with
|
|
| `Scalar _ -> 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
|
|
| _ -> ())
|
|
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
|
|
|
|
(* ── 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 }
|
|
| _ -> { 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 (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)) )
|
|
| _ -> ([ call args ], fn.Ast.ret)
|
|
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 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 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 _ -> 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 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 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 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;
|
|
(* 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)
|