789 lines
36 KiB
OCaml
789 lines
36 KiB
OCaml
(* flan — milestone 2 driver. *)
|
|
|
|
(* Both error channels, in the one place that prints them. A single refusal
|
|
still exits 1 and still opens with [file:line:col: message]; a driver that
|
|
got to the end of the file hands over everything it found, sorted, with a
|
|
count after it. Nothing here parses the message — the squiggle comes from
|
|
the span and the classification from the kind. *)
|
|
let with_errors path f =
|
|
try f () with
|
|
| Flan.Loc.Error d ->
|
|
prerr_endline (Flan.Loc.report d);
|
|
ignore path;
|
|
exit 1
|
|
| Flan.Loc.Errors ds ->
|
|
prerr_endline (Flan.Loc.report_all ds);
|
|
ignore path;
|
|
exit 1
|
|
(* The dev backend's own refusal, which is not a program error: the program
|
|
is fine and this backend does not lower it. Its own exit status, so that
|
|
a sweep comparing the two backends can count "refused by name" apart from
|
|
"did not compile". *)
|
|
| Flan.X86.Unsupported m ->
|
|
prerr_endline ("x86: " ^ m);
|
|
ignore path;
|
|
exit 3
|
|
(* The JS dialect's refusal, and the same status for the same reason. It is
|
|
a wider category than the x86 one — that backend is behind on a node, and
|
|
this one is a dialect that deliberately does not carry the memory model —
|
|
but a sweep counts them the same way: refused by name, not a failure. *)
|
|
| Flan.Js.Unsupported m ->
|
|
prerr_endline ("js: " ^ m);
|
|
ignore path;
|
|
exit 3
|
|
(* A refusal with no location: a combination of flags this command does not
|
|
offer, or a build step that failed. Every [failwith] this binary can reach
|
|
is one of those, and a sentence is what a user can act on where an
|
|
uncaught OCaml exception and its backtrace are not. *)
|
|
| Failure m ->
|
|
prerr_endline ("flan: " ^ m);
|
|
ignore path;
|
|
exit 1
|
|
(* A file that is not there, or that cannot be read. The exception already
|
|
carries the path and the reason the operating system gave, which is the
|
|
whole of what anybody can act on, so it is passed through as it is —
|
|
[lib/dev.ml]'s [message_of_exn] does the same for the same reason, and
|
|
the daemon has had this arm since before the CLI did. Without it
|
|
[flan check nosuch.flan] ends in [Fatal error: exception Sys_error(...)],
|
|
which is the compiler telling the user it did not expect to be asked. *)
|
|
| Sys_error m ->
|
|
prerr_endline ("flan: " ^ m);
|
|
ignore path;
|
|
exit 1
|
|
(* The backstop. Nothing in this binary reaches it today: every [Hashtbl.find]
|
|
on a path a command can take is guarded by a [find_opt]. It is here so
|
|
that the day one is not, the failure is a sentence naming the file being
|
|
worked on rather than a bare [Fatal error: exception Not_found] — which
|
|
says nothing at all, not even which file. Its own exit status, because a
|
|
compiler bug is not a refusal of the program and a script should be able
|
|
to tell the two apart. *)
|
|
| Not_found ->
|
|
prerr_endline
|
|
("flan: internal error — a lookup failed with no name to report, while \
|
|
working on " ^ path
|
|
^ ". This is a bug in the compiler and not a fault in the program; \
|
|
please report the file that provoked it.");
|
|
exit 4
|
|
|
|
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)
|
|
| Defdata (n, vs) -> Printf.sprintf "defdata %s (%d cases)" n (List.length vs)
|
|
| Defunion (n, ms) ->
|
|
Printf.sprintf "defunion %s (%d members)" n (List.length ms)
|
|
| 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. *)
|
|
(* Every driver here is the batch case, which is the one the workflow is: write
|
|
everything, compile at the end, work through the list. So every one of them
|
|
asks for the whole list rather than the first thing wrong. *)
|
|
let load path : Flan.Load.t =
|
|
Flan.Load.program ~file:path
|
|
~parse:Flan.Parse.program_all (Flan.Reader.read_file path)
|
|
|
|
let checked path = Flan.Check.program_all (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"
|
|
|
|
(* [flan dev] builds one binary that is the program and holds the compiler,
|
|
and serves the editor from a thread inside it. This asks for the old shape
|
|
instead — a compiler process that launches the program and talks to it over
|
|
a socket. It is the escape hatch for a machine that cannot build the
|
|
compiler object (no ocamlfind, no flan.cmxa beside this binary), not a
|
|
preference, and it goes away with the transport it drives. *)
|
|
let two_process_flag = "--two-process"
|
|
|
|
(* The hand-written x86-64 backend (lib/x86.ml) instead of LLVM. The dev
|
|
backend from docs/DISCUSS.md item 15, off by default and named explicitly:
|
|
LLVM stays the release path and the default one. It covers a subset of the
|
|
IR and refuses the rest by name, so a build that succeeds is one it really
|
|
compiled. *)
|
|
let x86_flag = "--x86"
|
|
|
|
(* [flan emit --x86] annotates, because it exists to be read. This turns that
|
|
off, and the only caller who wants it is the test that assembles the listing
|
|
both ways and compares the object's sections byte for byte -- a claim that
|
|
comments and the splitting of a [.byte] directive are invisible to the
|
|
assembler is worth measuring rather than asserting. *)
|
|
let no_annotate_flag = "--no-annotate"
|
|
|
|
let flags =
|
|
[ no_checks_flag; dev_flag; debug_flag; sanitize_flag; two_process_flag;
|
|
x86_flag; no_annotate_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="
|
|
|
|
(* The optimisation level, which until now had no spelling at all: [Build.default]
|
|
pinned -O2 and [--debug] was the only route to anything else. Four levels and
|
|
not five — -Os is clang's and llc rejects it outright ("invalid optimization
|
|
level"), and the same string reaches both ([Build] at the clang compile and
|
|
again at the llc step of the live loop), so offering a level one of the two
|
|
tools does not know would be a flag that works for [flan build] and breaks
|
|
[C-c C-c].
|
|
|
|
Last one wins, which is what every compiler does with a repeated -O and the
|
|
only rule that does not need explaining. *)
|
|
let opt_levels = [ "-O0"; "-O1"; "-O2"; "-O3" ]
|
|
|
|
let opt_of args =
|
|
List.fold_left
|
|
(fun acc a -> if List.mem a opt_levels then Some a else acc)
|
|
None args
|
|
|
|
let is_flag a =
|
|
List.mem a flags || List.mem a opt_levels
|
|
|| String.starts_with ~prefix:target_prefix a
|
|
|
|
(* [--debug] forces -O0 in [Build] and says why there: [llvm.dbg.declare]
|
|
describes an alloca and mem2reg deletes the alloca, so a debug build at -O2
|
|
has a line table over code whose locals are gone. That is a good rule, and
|
|
it makes [--debug -O2] a request that cannot be honoured — so it is refused
|
|
here by name instead of being quietly overruled two modules away. *)
|
|
let check_opt_against_debug ~debug ~opt =
|
|
match (debug, opt) with
|
|
| true, Some o when o <> "-O0" ->
|
|
prerr_endline
|
|
("flan: --debug and " ^ o
|
|
^ " ask for opposite things — a debug build is -O0 because \
|
|
llvm.dbg.declare describes an alloca and mem2reg at any higher level \
|
|
deletes it, leaving a line table over locals that are not there. \
|
|
Drop one of the two.");
|
|
exit 2
|
|
| _ -> ()
|
|
|
|
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_all
|
|
|> 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 unions =
|
|
List.filter_map
|
|
(fun (d : Flan.Ast.decl) ->
|
|
match d.Flan.Ast.d with
|
|
| Flan.Ast.Defunion (n, ms) -> Some (n, ms)
|
|
| _ -> 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_unions:(List.map fst unions) ~known_enums ~taken ~bound_syms
|
|
~config:
|
|
(match pkg with
|
|
| f :: _ -> Flan.Load.binding_config (Filename.dirname f)
|
|
| [] -> Flan.Cimport.no_config)
|
|
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);
|
|
(match Flan.Cimport.check_unions ~env ~unions dump with
|
|
| [] ->
|
|
if unions <> [] then
|
|
Printf.printf ";; every defunion 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)
|
|
| diffs ->
|
|
Printf.printf ";; %d of %d hand-written declare-c disagree\n"
|
|
(List.length diffs) (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)
|
|
diffs);
|
|
(* And the constants, which until now nothing read at all: a wrong flag
|
|
bit or a wrong enum member is the one kind of error here that is
|
|
completely silent. *)
|
|
let enums =
|
|
List.filter_map
|
|
(fun (d : Flan.Ast.decl) ->
|
|
match d.Flan.Ast.d with
|
|
| Flan.Ast.Defenum (n, ms) -> Some (n, ms)
|
|
| _ -> None)
|
|
ds
|
|
and pconsts =
|
|
List.filter_map
|
|
(fun (d : Flan.Ast.decl) ->
|
|
match d.Flan.Ast.d with
|
|
| Flan.Ast.Defconst (n, _, e) -> Some (n, e)
|
|
| _ -> None)
|
|
ds
|
|
in
|
|
let config =
|
|
match pkg with
|
|
| f :: _ -> Flan.Load.binding_config (Filename.dirname f)
|
|
| [] -> Flan.Cimport.no_config
|
|
in
|
|
(match Flan.Cimport.check_constants ~config ~enums ~consts:pconsts dump with
|
|
| [] ->
|
|
if enums <> [] then
|
|
Printf.printf ";; every defenum member agrees with the header\n"
|
|
| bad ->
|
|
List.iter
|
|
(fun (x : Flan.Cimport.const_diff) ->
|
|
Printf.printf ";; %s %s: %s\n"
|
|
(if x.Flan.Cimport.cmapping then "UNMAPPED" else "DISAGREES")
|
|
x.Flan.Cimport.cname x.Flan.Cimport.cwhy)
|
|
bad))
|
|
|
|
(* Regeneration. [import-c] prints what it would produce; this writes it, and
|
|
the difference between the two is that this one cannot skip the check.
|
|
|
|
It reads the header out of the package's own `headers`, not off the
|
|
command line, because the version that may be read is a property of the
|
|
package — `headers` is where it says which one, and `link` is where it
|
|
says which library that has to match. And it reads every .flan in the
|
|
directory *except* the file it writes, so the hand-written declarations
|
|
still win and the generated ones are not mistaken for them on the next
|
|
run.
|
|
|
|
Non-zero and nothing written when the package and the header disagree.
|
|
That is the whole point: the committed file is the one thing here with no
|
|
second opinion, so the moment of writing it is the only moment left at
|
|
which the library can contradict it. *)
|
|
| _ :: "generate-c" :: dir :: _ ->
|
|
with_errors dir (fun () ->
|
|
let loc = Flan.Loc.make dir 0 0 in
|
|
let out = Filename.concat dir "generated.flan" in
|
|
let ds =
|
|
List.concat_map
|
|
(fun f -> Flan.Parse.program (Flan.Reader.read_file f))
|
|
(List.filter
|
|
(fun f -> not (String.equal f out))
|
|
(Flan.Load.entries dir ".flan"))
|
|
in
|
|
let config = Flan.Load.binding_config dir in
|
|
match Flan.Load.header_specs ~loc dir with
|
|
| [] ->
|
|
Printf.eprintf
|
|
"flan generate-c: %s/headers names no header that is there. \
|
|
Regeneration reads the library's own header, at the version \
|
|
%s/link names — export it and run this again.\n" dir dir;
|
|
exit 2
|
|
| _ :: _ :: _ ->
|
|
Printf.eprintf
|
|
"flan generate-c: %s/headers names more than one header, and one \
|
|
generated file cannot come from several — the declarations would \
|
|
depend on which was read last.\n" dir;
|
|
exit 2
|
|
| [ (h, flags) ] ->
|
|
let r = Flan.Cimport.regenerate ~loc ~header:h ~flags ~ds ~config ~out in
|
|
List.iter
|
|
(fun (n, why) -> Printf.printf ";; refused %s: %s\n" n why)
|
|
r.Flan.Cimport.ghidden;
|
|
List.iter
|
|
(fun (n, why) -> Printf.eprintf "DISAGREES %s: %s\n" n why)
|
|
r.Flan.Cimport.gstructs;
|
|
List.iter
|
|
(fun (x : Flan.Cimport.sig_diff) ->
|
|
Printf.eprintf "DIFFERS %s (%s): %s\n"
|
|
x.Flan.Cimport.dflan x.Flan.Cimport.dsym x.Flan.Cimport.dwhy)
|
|
r.Flan.Cimport.gsigs;
|
|
List.iter
|
|
(fun (x : Flan.Cimport.const_diff) ->
|
|
Printf.eprintf "%s %s: %s\n"
|
|
(if x.Flan.Cimport.cmapping then "UNMAPPED" else "DISAGREES")
|
|
x.Flan.Cimport.cname x.Flan.Cimport.cwhy)
|
|
r.Flan.Cimport.gconsts;
|
|
if r.Flan.Cimport.gwrote then
|
|
Printf.printf
|
|
"wrote %s: %d declarations, %d refused, of %d functions in %s.\n\
|
|
Every defstruct, every hand-written declare-c and every mapped\n\
|
|
constant agrees with it.\n"
|
|
out r.Flan.Cimport.gdecls
|
|
(List.length r.Flan.Cimport.ghidden) r.Flan.Cimport.gfns h
|
|
else begin
|
|
Printf.eprintf
|
|
"flan generate-c: %s does not agree with %s — %d struct layouts, \
|
|
%d hand-written signatures and %d constants, of which %d are a \
|
|
mapping the package has not declared. Nothing was written: a \
|
|
generated file made against a header the library does not match \
|
|
is the silent failure this check exists to prevent, and a \
|
|
constant nothing is mapped to is one nothing checks.\n"
|
|
dir h
|
|
(List.length r.Flan.Cimport.gstructs)
|
|
(List.length r.Flan.Cimport.gsigs)
|
|
(List.length r.Flan.Cimport.gconsts)
|
|
(List.length
|
|
(List.filter
|
|
(fun (x : Flan.Cimport.const_diff) -> x.Flan.Cimport.cmapping)
|
|
r.Flan.Cimport.gconsts));
|
|
exit 1
|
|
end)
|
|
|
|
(* 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
|
|
(* --x86 prints the hand-written backend's assembly where the default prints
|
|
LLVM IR. The two are the same act — here is what this program compiles to,
|
|
before an assembler or an optimiser has touched it — and reading one
|
|
against the other is the only way to check a lowering by eye. --sanitize
|
|
is refused rather than ignored: ASan is an LLVM pass and this backend has
|
|
no arm for it, so honouring the flag is impossible and dropping it
|
|
silently would print something that is not what --sanitize builds. *)
|
|
| _ :: "emit" :: args
|
|
when List.mem x86_flag args && List.exists (fun a -> not (is_flag a)) args ->
|
|
if List.mem sanitize_flag args then begin
|
|
prerr_endline
|
|
"flan emit --x86: --sanitize is an LLVM pass and this backend has no \
|
|
arm for it — emit without --x86 to see what a sanitized build compiles.";
|
|
exit 2
|
|
end;
|
|
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
|
|
(* The listing is annotated because a listing is what this command is for:
|
|
a person asked to see what their program compiles to, and a wall of
|
|
[.byte] with nothing saying which form produced which run answers the
|
|
letter of that and not the question. --no-annotate is here for the one
|
|
consumer that wants the bare spelling, which is the check that says
|
|
annotation changed no byte of the object. *)
|
|
let annotate = not (List.mem no_annotate_flag args) in
|
|
let files = List.filter (fun a -> not (is_flag a)) args in
|
|
List.iter
|
|
(fun path ->
|
|
with_errors path (fun () ->
|
|
load path |> fun l ->
|
|
Flan.Check.program_all l.decls
|
|
|> Flan.X86.program ~checks ~dev ~debug ~annotate
|
|
|> print_string))
|
|
files
|
|
| _ :: "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_all 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 x86 = List.mem x86_flag rest in
|
|
let opt = opt_of rest in
|
|
check_opt_against_debug ~debug ~opt;
|
|
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. *)
|
|
(* The JS dialect's output is one file and it is source, so it is
|
|
named the way source is: node runs it by name. *)
|
|
(match target with
|
|
| Some t when Flan.Build.is_web t -> base ^ ".html"
|
|
| Some t when Flan.Build.is_js t -> base ^ ".js"
|
|
| Some t when String.starts_with ~prefix:"wasm32" t -> base ^ ".wasm"
|
|
| _ -> base)
|
|
| _ ->
|
|
prerr_endline
|
|
"usage: flan build <file.flan> [-o out] [-O0|-O1|-O2|-O3] \
|
|
[--no-bounds-checks] \
|
|
[--dev] [--debug] [--sanitize] [--target=wasm32-wasi|web|js]";
|
|
exit 2
|
|
in
|
|
with_errors path (fun () ->
|
|
let l = load path in
|
|
let p = Flan.Check.program_all 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; x86;
|
|
opt = Option.value opt
|
|
~default:Flan.Build.default.Flan.Build.opt }
|
|
~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
|
|
(* One flag for both halves of the session, which is what makes it safe at
|
|
all: the host and every module this daemon sends are compiled by the
|
|
same backend, because there is one place that says which. The two
|
|
conventions agree on every scalar and disagree on every aggregate, so a
|
|
crossed pair is correct until the first redefined function takes or
|
|
returns a struct — and [flan.abi.x86] refuses that pair at [dlopen] if
|
|
this is ever got wrong. Off by default: LLVM stays the default path
|
|
here exactly as it is for [flan build]. *)
|
|
let x86 = List.mem x86_flag rest in
|
|
let merged = not (List.mem two_process_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] [--x86] \
|
|
[--two-process]";
|
|
exit 2
|
|
in
|
|
with_errors path (fun () ->
|
|
Flan.Dev.start ~debug ~merged ~x86 ~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
|
|
(* The same flag, for the same reason, and it had to arrive with [flan
|
|
dev]'s: a command that could build a module for a host the other backend
|
|
compiled is how the crossed pair was reachable from the CLI at all.
|
|
Building an --x86 host with [flan build --x86 --dev] and then reloading
|
|
into it now has a spelling that produces a module it can load. *)
|
|
let x86 = List.mem x86_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] [--x86]";
|
|
exit 2
|
|
in
|
|
with_errors forms (fun () ->
|
|
let t, _ = Flan.Session.create ~debug ~x86 ~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; x86 } in
|
|
let timing =
|
|
if c.Flan.Session.x86 then
|
|
Flan.Build.shared_x86 ~opts ~asm:c.Flan.Session.ir ~out ()
|
|
else Flan.Build.shared ~opts ~ir:c.Flan.Session.ir ~out ()
|
|
in
|
|
(* [as] where the other path has [llc], which is the number the whole
|
|
backend exists to move. Named for what ran. *)
|
|
Printf.eprintf "%s %s %s %.1fms ld %.1fms\n" out
|
|
(String.concat " " c.Flan.Session.fns)
|
|
(if x86 then "as " else "llc") 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 ->
|
|
(* One command, two argument lists, and until now no rule saying which was
|
|
which: [flan run game.flan --debug] built at -O2 and handed the game a
|
|
[--debug] it had never heard of. Nothing reported that, because neither
|
|
side thought it had been given anything wrong.
|
|
|
|
The rule, in one line: a build flag is the build's, [--] ends the build
|
|
flags, and everything after [--] is the program's whatever it looks
|
|
like. Before [--], an argument that starts with a dash and is not a
|
|
build flag this command offers is refused by name — not guessed at,
|
|
because guessing is the failure this exists to stop, and a program of
|
|
one's own that wants [-v] has [--] to ask for it. Plain arguments need
|
|
no ceremony: they were never ambiguous and they still go straight
|
|
through, so [flan run calc-me.flan "1+2"] is unchanged. *)
|
|
(* --dev is deliberately not on this list, and its absence is the point:
|
|
a dev build's indirection cells exist so that something can attach and
|
|
redefine through them, and nothing can attach to a process this command
|
|
builds, execs, waits for and deletes. Leaving it off means it lands in
|
|
the refusal below with a sentence, rather than quietly producing a
|
|
spelling [Build] says does not exist — [flan build]'s --x86 arm records
|
|
that `flan dev` never reaches its fork because --x86 is read only by
|
|
[flan build], and an --x86 --dev route through here would have made that
|
|
sentence false. *)
|
|
let run_flags =
|
|
[ no_checks_flag; debug_flag; sanitize_flag; x86_flag ] @ opt_levels
|
|
in
|
|
let build_args, prog_args =
|
|
let rec split acc = function
|
|
| "--" :: rest -> (List.rev acc, rest)
|
|
| a :: rest when String.length a > 1 && a.[0] = '-' ->
|
|
if List.mem a run_flags then split (a :: acc) rest
|
|
else begin
|
|
prerr_endline
|
|
("flan run: " ^ a
|
|
^ " is not a flag this command offers, and it will not be \
|
|
guessed at — a build flag belongs to the build and \
|
|
anything else belongs to the program. Write it after -- to \
|
|
send it to the program: flan run "
|
|
^ Filename.basename path ^ " -- " ^ a);
|
|
exit 2
|
|
end
|
|
| a :: rest -> let l, r = split acc rest in (l, a :: r)
|
|
| [] -> (List.rev acc, [])
|
|
in
|
|
split [] args
|
|
in
|
|
let checks = not (List.mem no_checks_flag build_args) in
|
|
let debug = List.mem debug_flag build_args in
|
|
let sanitize = List.mem sanitize_flag build_args in
|
|
let x86 = List.mem x86_flag build_args in
|
|
let opt = opt_of build_args in
|
|
check_opt_against_debug ~debug ~opt;
|
|
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_all l.decls in
|
|
let p, csrcs, lflags = Flan.Reach.link l p in
|
|
ignore (Flan.Build.executable
|
|
~opts:{ Flan.Build.default with checks; debug; sanitize;
|
|
x86;
|
|
opt = Option.value opt
|
|
~default:Flan.Build.default.Flan.Build.opt }
|
|
~csrcs ~lflags ~pnames:(if debug then param_names l else [])
|
|
p ~out:exe);
|
|
let code =
|
|
Sys.command
|
|
(String.concat " " (List.map Filename.quote (exe :: prog_args)))
|
|
in
|
|
(try Sys.remove exe with Sys_error _ -> ());
|
|
exit code)
|
|
| _ ->
|
|
prerr_endline
|
|
"usage: flan (read|parse|check|emit|shim) <file.flan>...\n flan emit <file.flan> [--x86] [--dev] [--debug] [--no-bounds-checks]\n\
|
|
\ flan import-c <header.h> [package.flan...] [clang flags...]\n\
|
|
\ flan generate-c <package-dir>\n\
|
|
\ flan build <file.flan> [-o out] [-O0|-O1|-O2|-O3] \
|
|
[--no-bounds-checks] [--dev] \
|
|
[--debug] [--sanitize] [--x86] [--target=wasm32-wasi|web|js]\n\
|
|
\ flan run <file.flan> [build flags...] [--] [program args...]\n\
|
|
\ flan reload <program.flan> <forms.flan> [-o out.so] [--x86]\n\
|
|
\ flan dev <program.flan> [-s socket] [--x86]";
|
|
exit 2
|