Joseph Ferano
263b9bb627
The argument vector's malloc was unchecked, and a failure there would have published a null pointer with a length beside it. It now dies naming what it was building, because argv has no allocation site for a condition to hang on. flan_slurp_into read a capacity of elements as a capacity of bytes and skipped the epoch check every other container operation runs. The element size is now a parameter and the length it publishes counts whole elements, so the day slurp answers something other than (Vec u8) it does not answer with bytes nobody wrote. A string with a NUL in it is refused at the C boundary, which is the policy flan_path_cstr has always had for a path: C reads to the first NUL, so what crosses is a prefix of what was passed, and a window title is no different from a filename in that respect. The refusal names the declare-c, which is the name the program's author wrote. The runtime's two translation units are compiled with -Wall -Wextra. They were already clean under both; the flag is there so the next one is caught rather than read. The generation word keeps its place and loses its "yet": a reader for it is a third word on every slice in the language, which is a spec amendment rather than a runtime patch, and the comment now says so where someone deciding to trust the word would read it.
698 lines
30 KiB
OCaml
698 lines
30 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 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 returned
|
|
[const char *] 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"
|
|
|
|
(* ── 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
|
|
|
|
(* [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.datas n then
|
|
fail loc
|
|
"%s is %s, a data type, and a Flan data type has no C layout — the shim \
|
|
cannot be generated for it"
|
|
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 — a \
|
|
union has a C layout but nothing here emits the declaration for \
|
|
it yet. Pass (Ptr %s) and let the C side read it"
|
|
what n 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
|
|
(* 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 — 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.
|
|
|
|
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. *)
|
|
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 <= 0 ? 0 : (size_t)n;\n\
|
|
\ char *d = buf;\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) {\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;
|
|
(* 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);
|
|
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)
|