diff --git a/lib/cimport.ml b/lib/cimport.ml index a019d9f..a330cf2 100644 --- a/lib/cimport.ml +++ b/lib/cimport.ml @@ -379,15 +379,44 @@ let rec named env (n : string) : Ast.texpr = few calls where it matters, not a reason to refuse the other five hundred. *) tname "i32" - else if List.mem_assoc n env.d.typedefs then begin - let u = bare (List.assoc n env.d.typedefs) in - if u = n then refuse "%s is a typedef of itself" n else named env u - end else if List.exists (fun r -> r.rname = n) env.d.records then - refuse - "%s is a struct the package does not describe — add a defstruct for it, \ - or keep a hand-written declare-c" - n + (* Checked before the typedef table, because C's usual idiom + [typedef struct Vector3 { ... } Vector3;] puts the same name in both and + following it would arrive straight back here. + + One step first, in the other direction: the package may already describe + this record under one of its *other* typedef names. raylib's record is + [struct Texture] and [Texture2D], [TextureCubemap] and the package's own + [defstruct Texture2D] are all names for it, so [LoadTextureCubemap] + returns the same struct the package has described and refusing it would + be wrong. Any known struct whose typedef bottoms out at this record + will do; they denote the same layout by construction. *) + match + List.find_opt + (fun k -> + match List.assoc_opt k env.d.typedefs with + | Some u -> String.equal (bare u) n + | None -> false) + env.known_structs + with + | Some k -> tname k + | None -> + refuse + "%s is a struct the package does not describe — add a defstruct for \ + it, or keep a hand-written declare-c" + n + else if List.mem_assoc n env.d.typedefs then begin + let u = List.assoc n env.d.typedefs in + if bare u = n then + refuse "%s is a typedef of itself, which is not a type" n + else + (* Back through [value_ty] and not straight to [named]: a typedef may + name a pointer or a function pointer — raylib's [AudioCallback] is + one — and only [value_ty] knows what to say about either. Going + straight to [named] reported a callback as an unknown type rather + than as the callback it is. *) + value_ty env u + end else if List.mem n width_varies then refuse "%s has a width that differs between this project's own targets (64 \ @@ -607,7 +636,7 @@ let check_structs ~env ~(structs : (string * Ast.field list) list) (d : dump) = (* ── The entry point ───────────────────────────────────────────────── *) -let dump_of ~loc ~header ~flags = +let dump_of_clang ~loc ~header ~flags = let text = run_clang ~loc ~header ~flags in let json = try Cjson.parse text @@ -616,6 +645,79 @@ let dump_of ~loc ~header ~flags = in read_dump ~header json +(* ── The cache ─────────────────────────────────────────────────────── *) + +(* Measured, not assumed: reading raylib.h costs 64ms — 30ms for clang to write + 1.8 MB of JSON and the rest to parse it and map it — against an 8ms check + for the whole program without it. The dev loop rebuilds constantly and the + header does not change between two of those rebuilds, so paying it every + time is eight times the cost of everything else put together. + + What is cached is the *extracted* dump and not clang's JSON: it is the + parse that is half the cost, and what comes out is a few hundred signatures + rather than megabytes of source ranges. + + Keyed the way the object cache is keyed, and for the same reason — on + everything that could change the answer. The header's path, its size and + mtime, and the full flag list, because a flag changes what clang sees; plus + a format version, because the cached value is a marshalled OCaml value and a + compiler whose [dump] type has changed must not read one written by the old + one. *) + +let cache_format = 1 + +let cachedir () = + let d = Filename.concat (Filename.get_temp_dir_name ()) "flan-cimport" in + (try Unix.mkdir d 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()); + d + +let dump_of ~loc ~header ~flags = + let st = try Some (Unix.stat header) with Unix.Unix_error _ -> None in + match st with + | None -> dump_of_clang ~loc ~header ~flags + | Some st -> + let key = + Digest.to_hex + (Digest.string + (String.concat "\000" + [ string_of_int cache_format; + (try Unix.realpath header with Unix.Unix_error _ -> header); + string_of_int st.Unix.st_size; + Printf.sprintf "%.6f" st.Unix.st_mtime; + String.concat " " flags ])) + in + let path = Filename.concat (cachedir ()) (key ^ ".dump") in + let cached = + if not (Sys.file_exists path) then None + else + try + let ch = open_in_bin path in + Fun.protect + ~finally:(fun () -> close_in_noerr ch) + (fun () -> Some (Marshal.from_channel ch : dump)) + with _ -> + (* A truncated or stale file is not worth a build failure: the header + is right there and can be read again. *) + (try Sys.remove path with Sys_error _ -> ()); + None + in + (match cached with + | Some d -> d + | None -> + let d = dump_of_clang ~loc ~header ~flags in + (* Written to a distinct name and renamed, so two builds running at + once cannot see a half-written file — the object cache does the + same. *) + (try + let tmp = Printf.sprintf "%s.%d.tmp" path (Unix.getpid ()) in + let ch = open_out_bin tmp in + Fun.protect + ~finally:(fun () -> close_out_noerr ch) + (fun () -> Marshal.to_channel ch d []); + Sys.rename tmp path + with Sys_error _ -> ()); + d) + let env_of ~known_structs ~known_enums d = { known_structs; known_enums; d } let header ~loc ~header:h ~flags ~known_structs ~known_enums ~taken ~bound_syms = diff --git a/lib/load.ml b/lib/load.ml index 5514be6..f92872f 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -54,7 +54,14 @@ type t = { (see [Reach.link]). The aggregate fields remain what a dev build uses, where "not called yet" is not "not called". *) and pkg = { alias : string; dir : string; owns : string list; - pcsrcs : string list; plflags : string list } + pcsrcs : string list; plflags : string list; + (* Names a [headers] file could have supplied and deliberately did + not, each with the reason — already qualified, so [rl/…]. A + wholesale header import refuses a great many functions and the + caller cares about the one they wrote, so the reason is attached + to the name and raised where it is used rather than printed at + import. See [Cimport]. *) + phidden : (string * string) list } let fail loc fmt = Printf.ksprintf (fun m -> raise (Loc.Error (loc, m))) fmt @@ -466,6 +473,103 @@ let link_flags dir = close_in ch; r end +(* The [headers] file: C headers to read signatures out of, one per line, a + path followed by any clang flags that header needs. Blank lines and + comments ignored, [${NAME}] expanded from the environment, and a relative + path taken against the package's own directory. + + A sidecar rather than a new form, for the same reason [link] is one. The + thing being named is a property of the *package* and not of any one + declaration in it, the importing program should not have to know the header + exists — [(import rl "vendor:raylib")] is unchanged at every call site — and + a package whose headers move is edited in one place. It also means the + reader, the parser and the AST are untouched: what comes back is ordinary + [declare-c] declarations, which is the only thing downstream understands. *) +let expand_env ~loc ~what line = + let b = Buffer.create (String.length line) in + let n = String.length line in + let i = ref 0 in + while !i < n do + if !i + 1 < n && line.[!i] = '$' && line.[!i + 1] = '{' then + match String.index_from_opt line !i '}' with + | None -> Buffer.add_char b line.[!i]; incr i + | Some close -> + let name = String.sub line (!i + 2) (close - !i - 2) in + (match Sys.getenv_opt name with + | Some v -> Buffer.add_string b v + | None -> + fail loc + "%s names ${%s} and %s is not set in the environment" what name name); + i := close + 1 + else (Buffer.add_char b line.[!i]; incr i) + done; + Buffer.contents b + +let read_lines path = + if not (Sys.file_exists path) then [] + else begin + let ch = open_in path in + let rec go acc = + match input_line ch with + | line -> + let line = String.trim line in + go (if line = "" || line.[0] = '#' then acc else line :: acc) + | exception End_of_file -> List.rev acc + in + let r = go [] in + close_in ch; r + end + +(* Split on whitespace: the first word is the header, the rest are clang's. *) +let words line = + String.split_on_char ' ' line + |> List.concat_map (String.split_on_char '\t') + |> List.filter (fun w -> w <> "") + +(* A line may begin with [?], meaning "read this header if it is there and say + nothing if it is not". + + That marker is what lets a package offer the check without requiring it. + [vendor/raylib] builds today against a shared library alone — BUILT.md's "no + raylib headers are needed", which is a real property: a build needs + libraylib linkable and not raylib-devel installed. A required header would + take that away from everyone in order to give the check to the people who + have one. Optional, the default build is exactly what it was, and a + developer with the matching header exports one variable and gets every + signature checked against it. It is the same shape as [${FLAN_RAYLIB_WEB}] + in [link], and for the same reason. + + An unset [${NAME}] on an optional line skips it rather than failing, since + "not set" is precisely how the line is turned off. On a required line it is + still an error that names the variable. *) +let header_specs ~loc dir = + let path = Filename.concat dir "headers" in + List.filter_map + (fun line -> + let optional = String.length line > 0 && line.[0] = '?' in + let line = + if optional then String.trim (String.sub line 1 (String.length line - 1)) + else line + in + match + if optional then + match expand_env ~loc ~what:path line with + | v -> Some v + | exception Loc.Error _ -> None + else Some (expand_env ~loc ~what:path line) + with + | None -> None + | Some expanded -> + (match words expanded with + | [] -> None + | h :: flags -> + let h = + if Filename.is_relative h then Filename.concat dir h else h + in + if optional && not (Sys.file_exists h) then None + else Some (h, flags))) + (read_lines path) + let real dir = try Unix.realpath dir with Unix.Unix_error _ -> dir (* One package, and whatever it imports. @@ -527,6 +631,62 @@ let rec import ~seen ~loc alias dir = | _ -> None) ds in + (* Every header the package names, read, and turned into the same + [declare-c] declarations a human would have written. Done here, before + anything below looks at what the package declares, so the generated ones + are owned and qualified exactly like the hand-written ones and nothing + downstream can tell which is which. + + A single file is not a package with a directory, so it carries no + headers, for the same reason it carries no [.c] and no [link]. *) + let imported = + if one_file then [] + else + List.map + (fun (h, flags) -> + let taken = Hashtbl.create 64 in + List.iter + (fun d -> + match Ast.declared_name d with + | Some n -> Hashtbl.replace taken n () + | None -> ()) + ds; + let known_structs = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.Defstruct (n, _) -> Some n + | _ -> None) + ds + and known_enums = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.Defenum (n, _) -> Some n + | _ -> None) + ds + (* A C symbol the package already binds by hand is left alone: + the hand-written line wins, and [Shim] would refuse the + program outright if one symbol arrived under two Flan names. + That is what keeps [declare-c] the escape hatch — a signature + the importer gets wrong, or a nicer face than the header can + describe, is fixed by writing the line. *) + and bound_syms = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.Declare (_, sym) | Ast.DeclareC (_, sym) -> Some sym + | _ -> None) + ds + in + let r, _, _ = + Cimport.header ~loc ~header:h ~flags ~known_structs ~known_enums + ~taken ~bound_syms + in + r) + (header_specs ~loc dir) + in + let ds = ds @ List.concat_map (fun r -> r.Cimport.decls) imported in let own = List.filter (fun (d : Ast.decl) -> match d.Ast.d with @@ -540,9 +700,18 @@ let rec import ~seen ~loc alias dir = let decls = List.map (qualify_decl owned alias) own in let lflags = if one_file then [] else link_flags dir in let csrcs = if one_file then [] else entries dir ".c" in + let phidden = + List.concat_map + (fun r -> + List.map + (fun (n, why) -> (qualify alias n, qualify alias n ^ ": " ^ why)) + r.Cimport.hidden) + imported + in let here = { decls; csrcs; lflags; - pkgs = [ { alias; dir; owns = owned; pcsrcs = csrcs; plflags = lflags } ] } + pkgs = [ { alias; dir; owns = owned; pcsrcs = csrcs; plflags = lflags; + phidden } ] } in List.fold_left (fun acc p -> @@ -555,7 +724,8 @@ let rec import ~seen ~loc alias dir = (* What an import did *not* bring: the names an importer might reasonably write and that are not there, each with the reason it is not. *) let hidden_of (t : t) = - List.filter_map + List.concat_map (fun (p : pkg) -> p.phidden) t.pkgs + @ List.filter_map (fun (p : pkg) -> let ds = List.concat_map (fun f -> Parse.program (Reader.read_file f)) diff --git a/vendor/raylib/headers b/vendor/raylib/headers new file mode 100644 index 0000000..4f001e7 --- /dev/null +++ b/vendor/raylib/headers @@ -0,0 +1,32 @@ +# C headers this package reads function signatures out of. One per line: a +# path, then any clang flags that header needs. A relative path is against +# this directory, ${NAME} expands from the environment, and a leading `?` +# means "if it is there" — an optional line with nothing behind it is simply +# not read. +# +# Why this exists. The declare-c lines in raylib.flan were transcribed by +# hand from raylib's documentation, and until now nothing could check that +# any of them matched the real function — BUILT.md records that as trusted +# rather than guaranteed. Point this at raylib's own header and the compiler +# reads the signatures instead: every hand-written line is compared against +# the library's, every defstruct against the header's record, and any raylib +# function the package has not bound becomes available under its own name. +# +# Why it is optional. A build needs libraylib linkable and *not* raylib-devel +# installed, which is a property worth keeping; requiring a header would take +# it from everyone to give the check to whoever has one. So the default build +# is unchanged and this is opt-in, the same shape as ${FLAN_RAYLIB_WEB} in +# `link`. +# +# The version must match the shared library `link` names — 5.5, libraylib.so.550. +# Reading one version's header while linking another's library is exactly the +# silent disagreement this exists to prevent, and `flan import-c` will say so: +# against a 5.1-dev header it reports ten differences that are all real. +# +# export FLAN_RAYLIB_H=/path/to/raylib-5.5/src/raylib.h +# +# To see what it would do without building anything: +# +# flan import-c $FLAN_RAYLIB_H vendor/raylib/raylib.flan +# +?${FLAN_RAYLIB_H}