diff --git a/bin/main.ml b/bin/main.ml index 07cc208..a3594e3 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -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) ...\n\ + "usage: flan (read|parse|check|emit|shim) ...\n\ \ flan build [-o out] [--no-bounds-checks] [--dev] \ [--target=wasm32-wasi]\n\ \ flan run [args...]\n\ diff --git a/lib/ast.ml b/lib/ast.ml index 7abd55f..3edf084 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -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 diff --git a/lib/build.ml b/lib/build.ml index 7733b88..7a0b297 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -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 = diff --git a/lib/check.ml b/lib/check.ml index 2be2aa2..34aed06 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -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) diff --git a/lib/load.ml b/lib/load.ml index 3fa5869..83cbc8e 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -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) diff --git a/lib/parse.ml b/lib/parse.ml index c5db730..efe8dc1 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -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 diff --git a/lib/shim.ml b/lib/shim.ml new file mode 100644 index 0000000..dfe6c99 --- /dev/null +++ b/lib/shim.ml @@ -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 \n\ + #include \n\ + #include \n\ + #include \n\ + #include \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)) diff --git a/lib/tast.ml b/lib/tast.ml index d79c2a8..de4f33b 100644 --- a/lib/tast.ml +++ b/lib/tast.ml @@ -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 =