Joseph Ferano
19aa10158a
declare-c generates the wrapper, the typedefs and the prototype from one declaration, so they cannot disagree with each other. What nothing checked was whether the declaration matched the library — BUILT.md records that as trusted rather than guaranteed, because no header was ever read. This reads one. clang is asked for a JSON AST dump of the header and shelled out to, not linked: -Xclang -ast-dump=json is the same binary on PATH that every build already runs, which is plan.org's "Why LLVM IR as text" applied a second time. Zig's old @cImport linked clang as a library and that is precisely the dependency plan.org rejected. cjson.ml is enough JSON to read the dump and no more, so this adds no opam package to parse it. What comes out of the header is signatures and nothing else — not structs, not enums, not macros. The bound on how much is imported is the package's own defstructs: a function whose signature mentions a struct the package has not described is refused with that reason, so vendor/raylib describing thirteen structs is what makes the import thirteen structs wide. Keeping the layouts hand-written is also what makes checking them against the header's records worth doing — a _Static_assert was rejected in BUILT.md as circular, and this is not, because the two sides have different authors. Refusals are demotions, taken from Zig's translator: it never drops a declaration it cannot handle, it binds the name to a @compileError carrying the reason so the failure lands at the use site. Load.refuse_hidden is already that mechanism. So a returned char * does not kill the header — it makes one name unavailable, with the reason attached. flan import-c prints what it would produce, what it refused, how the package's defstructs compare with the header's records, and how the hand-written declare-c lines compare with the header's signatures. Against raylib 5.5, the version whose .so vendor/raylib/link names: all 16 defstructs and all 172 hand-written declare-c agree exactly. Against the 5.1-dev header installed in /usr/local it reports ten differences, nine functions that version does not have and one that gained a parameter — so the check has teeth and the clean run is not a vacuous one.
396 lines
17 KiB
OCaml
396 lines
17 KiB
OCaml
(* flan — milestone 2 driver. *)
|
|
|
|
let with_errors path f =
|
|
try f () with
|
|
| Flan.Loc.Error (loc, msg) ->
|
|
Printf.eprintf "%s: %s\n" (Flan.Loc.to_string loc) msg;
|
|
ignore path;
|
|
exit 1
|
|
|
|
let summarise (d : Flan.Ast.decl) =
|
|
let open Flan.Ast in
|
|
match d.d with
|
|
| Package n -> Printf.sprintf "package %s" n
|
|
| Import (a, p) -> Printf.sprintf "import %s %S" a p
|
|
| Defalias (n, _) -> Printf.sprintf "defalias %s" n
|
|
| Defstruct (n, fs) -> Printf.sprintf "defstruct %s (%d fields)" n (List.length fs)
|
|
| Defunion (n, vs) -> Printf.sprintf "defunion %s (%d cases)" n (List.length vs)
|
|
| Defvar (n, _, _) -> Printf.sprintf "defvar %s" n
|
|
| Defconst (n, _, _) -> Printf.sprintf "defconst %s" n
|
|
| 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)"
|
|
fn.name (List.length fn.params)
|
|
(match fn.ret with None -> "Unit" | Some _ -> "explicit")
|
|
(List.length fn.fbody)
|
|
|
|
(* Every path past [parse] goes through [Load]: an import is resolved into the
|
|
declarations it stands for, and the package's C shim and linker arguments
|
|
come back with them. *)
|
|
let load path : Flan.Load.t =
|
|
Flan.Load.program ~file:path (Flan.Parse.program (Flan.Reader.read_file path))
|
|
|
|
let checked path = Flan.Check.program (load path).decls
|
|
|
|
(* What the source called each parameter, per function. The typed IR refers to
|
|
locals by slot index and records no names — [Check] has them in its scope
|
|
list and drops them — so the debug info would otherwise print [p0] for
|
|
every argument. Slots 0..n-1 are the parameters in order ([Tast.fn]), which
|
|
is what makes this recoverable here, from declarations that are already in
|
|
hand, rather than needing a change to the typed IR. It stops at the
|
|
parameters: a let-bound local's name is genuinely not available without one.
|
|
Only gathered for a debug build. *)
|
|
let param_names (l : Flan.Load.t) =
|
|
List.filter_map
|
|
(fun (d : Flan.Ast.decl) ->
|
|
match d.Flan.Ast.d with
|
|
| Flan.Ast.Defn fn ->
|
|
Some (fn.Flan.Ast.name,
|
|
List.map (fun (p : Flan.Ast.field) -> p.Flan.Ast.fname)
|
|
fn.Flan.Ast.params)
|
|
| _ -> None)
|
|
l.Flan.Load.decls
|
|
|
|
(* Bounds checks are on unless a build asks for them off — the release
|
|
decision, not the optimisation level (NEXT.md, Bounds checks). *)
|
|
let no_checks_flag = "--no-bounds-checks"
|
|
|
|
(* A dev build is the one a REPL can attach to: every call goes through a cell
|
|
so a redefinition can be installed, and the cells and globals are exported
|
|
so a loaded module can reach them (NEXT.md, the dev loop). *)
|
|
let dev_flag = "--dev"
|
|
|
|
(* Source-level debugging: DWARF in the IR, -g on the C, and -O0 forced.
|
|
Its own flag and not a mode of --dev, because the two answer different
|
|
questions — --dev is "can I redefine this while it runs", --debug is "can I
|
|
stop it and read it". See [Build.opts]. *)
|
|
let debug_flag = "--debug"
|
|
|
|
(* ASan and UBSan over the whole program, the runtime's C and the Flan alike.
|
|
Its own flag for the same reason --debug is: it answers "is this program
|
|
touching memory it does not own", which is neither of the other two
|
|
questions. It does not imply -O0 — see [Build.opts], which also records
|
|
what each of the two sanitizers actually reaches. *)
|
|
let sanitize_flag = "--sanitize"
|
|
|
|
let flags = [ no_checks_flag; dev_flag; debug_flag; sanitize_flag ]
|
|
|
|
(* [--target=wasm32-wasi] and [--target=web], the two cross targets. Unlike
|
|
the flags above, a target
|
|
carries a value, so it is matched by prefix and stripped from the residual
|
|
arguments by the same test — otherwise [-o out --target=X] falls into the
|
|
usage error. *)
|
|
let target_prefix = "--target="
|
|
|
|
let is_flag a =
|
|
List.mem a flags || String.starts_with ~prefix:target_prefix a
|
|
|
|
let target_of args =
|
|
List.find_map
|
|
(fun a ->
|
|
if String.starts_with ~prefix:target_prefix a then
|
|
Some (String.sub a (String.length target_prefix)
|
|
(String.length a - String.length target_prefix))
|
|
else None)
|
|
args
|
|
|
|
let () =
|
|
match Array.to_list Sys.argv with
|
|
| _ :: "read" :: files when files <> [] ->
|
|
List.iter
|
|
(fun path ->
|
|
with_errors path (fun () ->
|
|
Flan.Reader.read_file path
|
|
|> List.iter (fun f -> print_endline (Flan.Form.to_string f))))
|
|
files
|
|
| _ :: "parse" :: files when files <> [] ->
|
|
List.iter
|
|
(fun path ->
|
|
with_errors path (fun () ->
|
|
Flan.Reader.read_file path
|
|
|> Flan.Parse.program
|
|
|> List.iter (fun d -> print_endline (summarise d))))
|
|
files
|
|
| _ :: "check" :: files when files <> [] ->
|
|
List.iter
|
|
(fun path ->
|
|
with_errors path (fun () ->
|
|
let p = checked path in
|
|
List.iter
|
|
(fun (g : Flan.Tast.global) ->
|
|
Printf.printf "%s %s %s\n"
|
|
(if g.gconst then "defconst" else "defvar")
|
|
g.gname (Flan.Types.to_string g.gty))
|
|
p.globals;
|
|
List.iter
|
|
(fun (f : Flan.Tast.fn) ->
|
|
Printf.printf "defn %s : (Fn [%s] %s) %d slots\n" f.name
|
|
(String.concat " "
|
|
(List.map Flan.Types.to_string f.params))
|
|
(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
|
|
| [] -> Printf.printf "%s: no declare-c, so no generated C\n" path
|
|
| parts -> List.iter (fun (_, src) -> print_string src) parts))
|
|
files
|
|
(* A header, read. The importer is a pure function of the header and the
|
|
package beside it, so it can be looked at without building anything —
|
|
which is what makes the diff against a hand-written binding possible, and
|
|
what makes "generate once and commit the result" a usable option rather
|
|
than a description of one. Prints the declarations it would produce, then
|
|
what it refused and why, then how the package's defstructs compare with
|
|
the header's records. *)
|
|
| _ :: "import-c" :: header :: rest ->
|
|
with_errors header (fun () ->
|
|
let pkg = List.filter (fun a -> Filename.check_suffix a ".flan") rest in
|
|
let flags =
|
|
List.filter (fun a -> not (Filename.check_suffix a ".flan")) rest
|
|
in
|
|
let ds =
|
|
List.concat_map
|
|
(fun f -> Flan.Parse.program (Flan.Reader.read_file f)) pkg
|
|
in
|
|
let structs =
|
|
List.filter_map
|
|
(fun (d : Flan.Ast.decl) ->
|
|
match d.Flan.Ast.d with
|
|
| Flan.Ast.Defstruct (n, fs) -> Some (n, fs)
|
|
| _ -> None)
|
|
ds
|
|
in
|
|
let known_enums =
|
|
List.filter_map
|
|
(fun (d : Flan.Ast.decl) ->
|
|
match d.Flan.Ast.d with
|
|
| Flan.Ast.Defenum (n, _) -> Some n
|
|
| _ -> None)
|
|
ds
|
|
in
|
|
let taken = Hashtbl.create 64 in
|
|
List.iter
|
|
(fun d ->
|
|
match Flan.Ast.declared_name d with
|
|
| Some n -> Hashtbl.replace taken n ()
|
|
| None -> ())
|
|
ds;
|
|
let bound_syms =
|
|
List.filter_map
|
|
(fun (d : Flan.Ast.decl) ->
|
|
match d.Flan.Ast.d with
|
|
| Flan.Ast.Declare (_, s) | Flan.Ast.DeclareC (_, s) -> Some s
|
|
| _ -> None)
|
|
ds
|
|
in
|
|
let imported, dump, env =
|
|
Flan.Cimport.header ~loc:(Flan.Loc.make header 0 0) ~header ~flags
|
|
~known_structs:(List.map fst structs) ~known_enums ~taken ~bound_syms
|
|
in
|
|
List.iter
|
|
(fun d -> print_endline (Flan.Cimport.decl_source d))
|
|
imported.Flan.Cimport.decls;
|
|
Printf.printf "\n;; %d imported, %d refused, of %d functions in %s\n"
|
|
(List.length imported.Flan.Cimport.decls)
|
|
(List.length imported.Flan.Cimport.hidden)
|
|
(List.length dump.Flan.Cimport.fns) header;
|
|
List.iter
|
|
(fun (n, why) -> Printf.printf ";; refused %s: %s\n" n why)
|
|
imported.Flan.Cimport.hidden;
|
|
(match Flan.Cimport.check_structs ~env ~structs dump with
|
|
| [] ->
|
|
if structs <> [] then
|
|
Printf.printf ";; every defstruct agrees with the header\n"
|
|
| bad ->
|
|
List.iter
|
|
(fun (n, why) -> Printf.printf ";; DISAGREES %s: %s\n" n why)
|
|
bad);
|
|
(* And the bindings the package already wrote by hand, against the
|
|
header's own signatures. Nothing else in the build can do this: a
|
|
wrong declare-c is wrong in the generated prototype too, so the two
|
|
agree with each other and only the library disagrees. *)
|
|
let bound =
|
|
List.filter_map
|
|
(fun (d : Flan.Ast.decl) ->
|
|
match d.Flan.Ast.d with
|
|
| Flan.Ast.DeclareC (fn, sym) -> Some (fn, sym)
|
|
| _ -> None)
|
|
ds
|
|
in
|
|
if bound <> [] then
|
|
match Flan.Cimport.diff_bound ~env ~bound dump with
|
|
| [] ->
|
|
Printf.printf
|
|
";; all %d hand-written declare-c agree with the header\n"
|
|
(List.length bound)
|
|
| ds ->
|
|
Printf.printf ";; %d of %d hand-written declare-c disagree\n"
|
|
(List.length ds) (List.length bound);
|
|
List.iter
|
|
(fun (x : Flan.Cimport.sig_diff) ->
|
|
Printf.printf ";; DIFFERS %s (%s): %s\n"
|
|
x.Flan.Cimport.dflan x.Flan.Cimport.dsym x.Flan.Cimport.dwhy)
|
|
ds)
|
|
|
|
(* 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
|
|
swallowing a flag is the shape the house rule exists to prevent. *)
|
|
| _ :: "emit" :: args when target_of args <> None ->
|
|
prerr_endline
|
|
"flan emit: --target is refused — the emitted IR carries no triple and \
|
|
no datalayout, and the target is chosen at build.";
|
|
exit 2
|
|
| _ :: "emit" :: args when List.exists (fun a -> not (is_flag a)) args ->
|
|
let checks = not (List.mem no_checks_flag args) in
|
|
let dev = List.mem dev_flag args in
|
|
let debug = List.mem debug_flag args in
|
|
(* --sanitize changes the IR — every [define] names the attribute group
|
|
ASan's pass selects on — so [emit] has to honour it or what this prints
|
|
is not what a sanitized build compiles. *)
|
|
let sanitize = List.mem sanitize_flag args in
|
|
let files = List.filter (fun a -> not (is_flag a)) args in
|
|
List.iter
|
|
(fun path ->
|
|
with_errors path (fun () ->
|
|
let l = load path in
|
|
let pnames = if debug then param_names l else [] in
|
|
Flan.Check.program l.decls
|
|
|> Flan.Emit.program ~checks ~dev ~debug ~pnames ~sanitize
|
|
|> print_string))
|
|
files
|
|
| _ :: "build" :: path :: rest ->
|
|
let checks = not (List.mem no_checks_flag rest) in
|
|
let dev = List.mem dev_flag rest in
|
|
let debug = List.mem debug_flag rest in
|
|
let sanitize = List.mem sanitize_flag rest in
|
|
let target = target_of rest in
|
|
let out =
|
|
match List.filter (fun a -> not (is_flag a)) rest with
|
|
| [ "-o"; o ] -> o
|
|
| [] ->
|
|
let base = Filename.remove_extension (Filename.basename path) in
|
|
(* A wasm module is not an executable and must not be named like one:
|
|
the extension is what tells a runtime, and a reader, what it is. *)
|
|
(* A web build is three files — the page, its JS and the module — and
|
|
the page is the one named here: emcc derives the other two from it,
|
|
and it is the one a browser opens. *)
|
|
(match target with
|
|
| Some t when Flan.Build.is_web t -> base ^ ".html"
|
|
| Some t when String.starts_with ~prefix:"wasm32" t -> base ^ ".wasm"
|
|
| _ -> base)
|
|
| _ ->
|
|
prerr_endline
|
|
"usage: flan build <file.flan> [-o out] [--no-bounds-checks] \
|
|
[--dev] [--debug] [--sanitize] [--target=wasm32-wasi|web]";
|
|
exit 2
|
|
in
|
|
with_errors path (fun () ->
|
|
let l = load path in
|
|
let p = Flan.Check.program l.decls in
|
|
(* The link follows the program, not the import list: a package nothing
|
|
reachable calls into contributes no C and no linker argument, and its
|
|
functions are not emitted either. That is what lets one file import
|
|
raylib and still be buildable for wasm32. *)
|
|
let p, csrcs, lflags = Flan.Reach.link ~dev l p in
|
|
ignore (Flan.Build.executable
|
|
~opts:{ Flan.Build.default with checks; dev; debug; sanitize;
|
|
target }
|
|
~csrcs ~lflags ~pnames:(if debug then param_names l else [])
|
|
p ~out))
|
|
(* The daemon an editor talks to: one session, the program it belongs to
|
|
running beside it, and a socket. Unlike [flan reload] the session persists,
|
|
so a defvar added by one evaluation is part of what the next one is checked
|
|
against — and it owns the build, which is what makes its layout rules
|
|
describe the process that is actually running. *)
|
|
| _ :: "dev" :: path :: rest ->
|
|
(* --debug builds the host *and* every module this daemon sends with DWARF,
|
|
which is one flag because it is one decision: a line breakpoint in a
|
|
.flan buffer needs a line table on the host to fire at all, and one in
|
|
each redefinition module to still be firing after C-c C-c. It implies
|
|
-O0 on both, so it is asked for rather than assumed. *)
|
|
let debug = List.mem debug_flag rest in
|
|
let rest = List.filter (fun a -> not (is_flag a)) rest in
|
|
let sock =
|
|
match rest with
|
|
| [ "-s"; s ] -> s
|
|
| [] -> Filename.concat (Filename.dirname path) ".flan-dev.sock"
|
|
| _ ->
|
|
prerr_endline "usage: flan dev <program.flan> [-s socket] [--debug]";
|
|
exit 2
|
|
in
|
|
with_errors path (fun () -> Flan.Dev.start ~debug ~file:path ~sock ())
|
|
|
|
(* One redefinition, built the way an editor will ask for it: a session over
|
|
the program the process was built from, and a file of the forms that
|
|
changed. The session works out which names are new and whether the change
|
|
is one a running process can be told at all — neither of which a command
|
|
given only a list of function names could. *)
|
|
| _ :: "reload" :: prog :: forms :: rest ->
|
|
let debug = List.mem debug_flag rest in
|
|
let rest = List.filter (fun a -> not (is_flag a)) rest in
|
|
let out =
|
|
match rest with
|
|
| [ "-o"; o ] -> o
|
|
| [] -> Filename.remove_extension (Filename.basename forms) ^ ".so"
|
|
| _ ->
|
|
prerr_endline
|
|
"usage: flan reload <program.flan> <forms.flan> [-o out.so] [--debug]";
|
|
exit 2
|
|
in
|
|
with_errors forms (fun () ->
|
|
let t, _ = Flan.Session.create ~debug ~file:prog () in
|
|
let src = In_channel.with_open_bin forms In_channel.input_all in
|
|
let c = Flan.Session.eval ~origin:forms t src in
|
|
let opts = { Flan.Build.default with dev = true; debug } in
|
|
let timing = Flan.Build.shared ~opts ~ir:c.Flan.Session.ir ~out () in
|
|
Printf.eprintf "%s %s llc %.1fms ld %.1fms\n" out
|
|
(String.concat " " c.Flan.Session.fns) timing.Flan.Build.llc_ms
|
|
timing.Flan.Build.link_ms)
|
|
(* [run] builds and execs. A .wasm is not executable, and picking a runtime
|
|
for it is a decision this command has no business making, so a cross
|
|
target is refused here by name rather than half-supported. *)
|
|
| _ :: "run" :: _ :: args when target_of args <> None ->
|
|
prerr_endline
|
|
"flan run: --target is refused — a cross-built module is not something \
|
|
this host can exec. Use flan build --target=... and a wasm runtime.";
|
|
exit 2
|
|
| _ :: "run" :: path :: args ->
|
|
with_errors path (fun () ->
|
|
let exe =
|
|
Filename.concat (Filename.get_temp_dir_name ())
|
|
(Printf.sprintf "flan-run-%d" (Unix.getpid ()))
|
|
in
|
|
let l = load path in
|
|
let p = Flan.Check.program l.decls in
|
|
let p, csrcs, lflags = Flan.Reach.link l p in
|
|
ignore (Flan.Build.executable ~csrcs ~lflags p ~out:exe);
|
|
let code =
|
|
Sys.command (String.concat " " (List.map Filename.quote (exe :: args)))
|
|
in
|
|
(try Sys.remove exe with Sys_error _ -> ());
|
|
exit code)
|
|
| _ ->
|
|
prerr_endline
|
|
"usage: flan (read|parse|check|emit|shim) <file.flan>...\n\
|
|
\ flan import-c <header.h> [package.flan...] [clang flags...]\n\
|
|
\ flan build <file.flan> [-o out] [--no-bounds-checks] [--dev] \
|
|
[--debug] [--sanitize] [--target=wasm32-wasi|web]\n\
|
|
\ flan run <file.flan> [args...]\n\
|
|
\ flan reload <program.flan> <forms.flan> [-o out.so]\n\
|
|
\ flan dev <program.flan> [-s socket]";
|
|
exit 2
|