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

The wrapper per binding was always mechanical, so write it here

Browse Source 
84 hand-written C wrappers is the shape of a job the compiler should be
doing. The reason the shim exists is unchanged and is not negotiable: a
small aggregate's calling convention is a per-target classification, not
part of its layout, and reproducing x86-64, arm64 and wasm32 inside
emit.ml is three classifiers to keep correct forever, where a mistake
reads as a field full of garbage rather than as a link error. clang does
it, per target, for free. So the C stays; the typing of it stops.

declare-c names the library's own function in the library's own
signature, and Shim emits the typedefs, the extern prototype, the
flattening wrapper and the flattened declaration the Flan side calls.

It is a second form rather than a change to declare because no
structural rule can separate them: (declare start-raw [path string] i32
"flan_agent_start") means the symbol takes ptr+len, and (declare-c
init-window [w i32 h i32 title string] "InitWindow") means it takes a
NUL-terminated char *. Same shape, opposite claims. declare is
untouched, so sqrtf and vendor/agent keep working unedited.

The generated C rides on Tast.program rather than beside it, so the CLI,
the REPL and the acceptance table all carry it without being told about
it. `flan shim` prints it, because a wrong binding is wrong in a wrapper
that is otherwise on no disk anywhere.
This commit is contained in:
Joseph Ferano 2026-09-11 20:26:00 +07:00
parent 66cd83d2a1
commit d2bc2bd714
8 changed files with 693 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
bin/main.ml
View File

@ -20,6 +20,9 @@ let summarise (d : Flan.Ast.decl) =
| Declare (fn, csym) ->
Printf.sprintf "declare %s (%d params) = %s" fn.name (List.length fn.params)
csym
| DeclareC (fn, csym) ->
Printf.sprintf "declare-c %s (%d params) = %s" fn.name
(List.length fn.params) csym
| Defenum (n, ms) -> Printf.sprintf "defenum %s (%d members)" n (List.length ms)
| Defn fn ->
Printf.sprintf "defn %s (%d params, %s return, %d body forms)"
@ -100,6 +103,18 @@ let () =
(Flan.Types.to_string f.ret) (Array.length f.slots))
p.fns))
files
(* The generated C, for looking at. A wrong FFI binding is wrong in the
wrapper, and the wrapper is not on disk anywhere — [Build] hands the text
straight to clang — so without this the only way to read one is to catch
it in the object cache. *)
| _ :: "shim" :: files when files <> [] ->
List.iter
(fun path ->
with_errors path (fun () ->
match (checked path).Flan.Tast.cshim with
| Some src -> print_string src
| None -> Printf.printf "%s: no declare-c, so no generated C\n" path))
files
(* The IR is target-independent — [Emit] writes no triple and no datalayout,
which is what lets one .ll serve both targets — so there is nothing for a
target to change here. Refused rather than accepted and ignored: silently
@ -205,7 +220,7 @@ let () =
exit code)
| _ ->
prerr_endline
"usage: flan (read|parse|check|emit) <file.flan>...\n\
"usage: flan (read|parse|check|emit|shim) <file.flan>...\n\
\ flan build <file.flan> [-o out] [--no-bounds-checks] [--dev] \
[--target=wasm32-wasi]\n\
\ flan run <file.flan> [args...]\n\

9
lib/ast.ml
View File

@ -113,6 +113,13 @@ and decl_kind =
it is actually called by (plan.org, Types — [declare] is kept only where
there is no body). *)
| Declare of fn * string
(* The same, but written in the C library's own terms — structs by value,
strings as strings. [Shim] generates the C that flattens it and rewrites
this into a [Declare] plus an ordinary [Defn], so nothing downstream sees
one. Two forms and not one because [(declare f [p string] ...)] already
means "the symbol takes ptr+len", which is the opposite of what this
means. *)
| DeclareC of fn * string
(* Inline name/value pairs, as everywhere else. The members are what a
keyword at a call site resolves against. *)
| Defenum of string * (string * int64) list
@ -132,5 +139,5 @@ let declared_name (d : decl) =
match d.d with
| Defenum (n, _) | Defalias (n, _) | Defstruct (n, _) | Defunion (n, _)
| Defvar (n, _, _) | Defconst (n, _, _) -> Some n
| Declare (fn, _) | Defn fn -> Some fn.name
| Declare (fn, _) | DeclareC (fn, _) | Defn fn -> Some fn.name
| Package _ | Import _ -> None

8
lib/build.ml
View File

@ -318,6 +318,14 @@ let executable ?(opts = default) ?(csrcs = []) ?(lflags = [])
:: [ cc Runtime_src.dev_source "flan_dev.c" ]
(* wasi-libc's entry point, which is not [main]. See [wasm_main_source]. *)
@ (if wasm_target opts then [ cc wasm_main_source "flan_wasm_main.c" ] else [])
(* The generated half of the FFI: one translation unit holding a typedef
per struct that crosses and a wrapper per (declare-c ...), compiled
exactly like a package's hand-written .c. It rides on the program
rather than on a parameter so that every caller of [executable] carries
it without having been changed to. See [Shim]. *)
@ (match p.Tast.cshim with
| None -> []
| Some src -> [ cc src "flan_shim.c" ])
@ List.map (fun c -> cc (read_file c) (Filename.basename c)) csrcs
in
let cmd =

13
lib/check.ml
View File

@ -1312,6 +1312,12 @@ let collect env (decls : Ast.decl list) =
| Ast.Import (alias, _) ->
fail loc "internal: the import of %s was not resolved before checking"
alias
(* [Shim.expand] rewrote every one of these into a [Declare] and a
[Defn] before [collect] ran, so one arriving here is a driver that
skipped that step. *)
| Ast.DeclareC (fn, _) ->
fail loc "internal: the declare-c of %s was not expanded before checking"
fn.Ast.name
| Ast.Declare (fn, csym) ->
if Hashtbl.mem env.fns fn.Ast.name then
fail loc "%s is declared twice" fn.Ast.name;
@ -1567,6 +1573,11 @@ let check_main env =
let program_with_env (decls : Ast.decl list) : Tast.program * env =
let env = new_env () in
let decls = Parse.program (Prelude.forms ()) @ decls in
(* Before anything is collected: every (declare-c ...) becomes an ordinary
flattened [declare] with a Flan [defn] over it, and the C that does the
flattening comes back to be compiled into the build. Nothing below this
line knows the form exists. *)
let decls, cshim = Shim.expand decls in
collect env decls;
check_finite env;
check_main env;
@ -1599,7 +1610,7 @@ let program_with_env (decls : Ast.decl list) : Tast.program * env =
in
({ Tast.structs = values (fun (s : Tast.structure) -> s.Tast.sname) env.structs;
unions = values (fun (u : Tast.union) -> u.Tast.uname) env.unions;
globals; externs; fns },
globals; externs; fns; cshim },
env)
let program (decls : Ast.decl list) : Tast.program = fst (program_with_env decls)

9
lib/load.ml
View File

@ -224,6 +224,15 @@ let qualify_decl owned alias (d : Ast.decl) : Ast.decl =
params = List.map (rename_field owned alias) fn.Ast.params;
ret = Option.map (rename_texpr owned alias) fn.Ast.ret },
csym)
(* The same as [Declare]: [Shim] has not run yet, so this is still the
library's own signature and the names in it are the package's. *)
| Ast.DeclareC (fn, csym) ->
Ast.DeclareC
({ fn with
Ast.name = qualify alias fn.Ast.name;
params = List.map (rename_field owned alias) fn.Ast.params;
ret = Option.map (rename_texpr owned alias) fn.Ast.ret },
csym)
| Ast.Defenum (n, ms) -> Ast.Defenum (qualify alias n, ms)
| Ast.Defalias (n, t) ->
Ast.Defalias (qualify alias n, rename_texpr owned alias t)

32
lib/parse.ml
View File

@ -435,22 +435,36 @@ let rec decl types (f : Form.t) : Ast.decl =
fbody = body; nloc = n.loc })
| _ -> fail f "defn is (defn name [param Type ...] ReturnType? body ...)")
| List ({ v = Sym "declare"; _ } :: args) ->
| List ({ v = Sym ("declare" | "declare-c" as which); _ } :: args) ->
(* (declare name [param Type ...] ReturnType? "c_symbol"). The C symbol is
last and is always written: a foreign name is not derivable from a Flan
one, and guessing it would fail at link time rather than here. *)
one, and guessing it would fail at link time rather than here.
[declare-c] is the same shape and a different claim about the symbol.
[declare]'s signature IS the C signature, already flattened by whoever
wrote the C; [declare-c]'s is the *library's* — structs by value — and
[Shim] generates the flattening. The two cannot be one form, because
(declare f [p string] ...) already means the symbol takes ptr+len and
(declare-c f [p string] ...) means it takes a NUL-terminated char *. *)
let mkd fn csym =
if String.equal which "declare-c" then Ast.DeclareC (fn, csym)
else Ast.Declare (fn, csym)
in
let usage =
Printf.sprintf
"%s is (%s name [param Type ...] ReturnType? \"c_symbol\")" which which
in
(match List.rev args with
| { v = Str csym; _ } :: rest ->
(match List.rev rest with
| [ n; { v = Form.Vec ps; _ } ] ->
mk (Ast.Declare ({ Ast.name = sym n; params = fields f ps;
ret = None; fbody = []; nloc = n.loc }, csym))
mk (mkd { Ast.name = sym n; params = fields f ps;
ret = None; fbody = []; nloc = n.loc } csym)
| [ n; { v = Form.Vec ps; _ }; r ] ->
mk (Ast.Declare ({ Ast.name = sym n; params = fields f ps;
ret = Some (texpr r); fbody = []; nloc = n.loc },
csym))
| _ -> fail f "declare is (declare name [param Type ...] ReturnType? \"c_symbol\")")
| _ -> fail f "declare is (declare name [param Type ...] ReturnType? \"c_symbol\")")
mk (mkd { Ast.name = sym n; params = fields f ps;
ret = Some (texpr r); fbody = []; nloc = n.loc } csym)
| _ -> fail f "%s" usage)
| _ -> fail f "%s" usage)
| List ({ v = Sym "defenum"; _ } :: args) ->
(match args with

611
lib/shim.ml Normal file
View File

@ -0,0 +1,611 @@
(** [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.
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
| 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 (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
[ 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. *)
let expand (decls : Ast.decl list) : Ast.decl list * string option =
let env = scan 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 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, None)
| 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;
Buffer.add_string b (typedefs env !needed);
List.iter (fun s -> Buffer.add_string b (c_for s)) shims;
(out, Some (Buffer.contents b))

6
lib/tast.ml
View File

@ -159,6 +159,12 @@ type program = {
globals : global list; (* in declaration order *)
externs : extern list;
fns : fn list;
(* The C the program's own (declare-c ...) forms generated, if any: one
translation unit, compiled into the build like a package's hand-written
.c file. It is on the program rather than beside it so that every driver
— the CLI, the REPL, the acceptance table — carries it without knowing
it exists. See [Shim]. *)
cshim : string option;
}
let field_index (s : structure) name =