(* 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. [?x86_hint] is the one thing here that is not the same for every command. A refusal from the dev backend is actionable in a different way depending on how that backend was chosen: somebody who typed [--x86] already knows they asked for it, and somebody who typed [flan dev] did not ask for anything. The second is the common case now that it is the default, so the command that takes it by default hands over the sentence naming the way out. *) let with_errors ?x86_hint 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); Option.iter prerr_endline x86_hint; 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. It covers a subset of the IR and refuses the rest by name, so a build that succeeds is one it really compiled. Where it is the default and where it is not is the whole of the split: it is the dev backend, so [flan dev] takes it unasked, and every other command here builds something that outlives the session and stays on LLVM. That is also what keeps [lib/x86.ml]'s calling convention licensed — a dev build is compiled entirely by it and a release build entirely by LLVM, so the two never meet in one process. On the commands that are still LLVM by default this flag is how you ask for the other backend; on [flan dev] it is how you say you meant it, which is what keeps [--x86 --debug] refused by name rather than reached by accident. *) let x86_flag = "--x86" (* The other direction, and it exists because [flan dev] changed sides: a dev session is the x86 backend now, and this is how to ask for the one that compiles every node. The two reasons to want it are the ones the backend itself names — a program it refuses, and [--debug], which it has no line table for in a redefinition module. Every other command already builds through LLVM, so there it names the default and is accepted and ignored. That is deliberate rather than an oversight in the flag table: a flag that states what a command was going to do anyway is a true sentence, and refusing it would make the one spelling mean two different things depending on which subcommand it followed. *) let llvm_flag = "--llvm" (* [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; llvm_flag; no_annotate_flag ] (* Which backend a command got, from the two flags and the default it would have taken. One function because there is one rule, and the only thing that varies is which way it falls with neither flag given: [flan dev] true, every other command false. Both flags together is refused rather than resolved. Last-one-wins is what [-O] does above, but an optimisation level is a dial and this is a fork: the two backends disagree on every aggregate, and someone who wrote both spellings does not know which half of their session they were asking about. A sentence is more use than a coin flip. *) let backend_x86 ~default args = let x86 = List.mem x86_flag args and llvm = List.mem llvm_flag args in if x86 && llvm then begin prerr_endline "flan: --x86 and --llvm together — one process is compiled by one \ backend, so this asks a question with no answer. Pick the one you \ meant."; exit 2 end; if x86 then true else if llvm then false else default (* [--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 (* LLVM by default, and deliberately not moved when [flan dev] moved: a release build is the one thing here that outlives the session, and the argument [lib/x86.ml] rests on is exactly that a dev build is compiled entirely by it and a release build entirely by LLVM. *) let x86 = backend_x86 ~default:false 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 [-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 decision 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. x86 by default, and this is the command where that is true. A dev session is the thing the backend was written for: it turns the round trip from 62ms to 28ms, and nothing it builds outlives the session, so the subset it covers is a subset of one editor's afternoon rather than of a shipped binary. [--llvm] is how to leave it — for a program it refuses by name, and for [--debug]. [--debug] takes [--llvm]'s side on its own, because it is not a preference: [X86.redefinition] emits no line table, so a [--debug] session on this backend would set breakpoints that stop firing at the first C-c C-c. Asking for the debugger is asking for the backend that has one. Writing [--x86] as well still reaches [Dev.start]'s refusal, which is the point of leaving it readable here — the combination stays refused by name, it is just no longer somewhere you arrive by typing one flag. *) let x86 = backend_x86 ~default:(not debug) rest in let asked_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 [-s socket] [--debug] [--llvm] \ [--two-process]"; exit 2 in (* Only this command hands one over, and only when it chose the backend itself. A refusal from a session nobody asked to be on this backend is one flag away from building, and the flag is the half of the sentence [X86.unsupported] cannot know to write. *) let x86_hint = if x86 && not asked_x86 then Some "flan dev: the x86 backend is the default for a dev session because \ it is about twice as fast, and it does not compile every program. \ Start this one with flan dev --llvm." else None in with_errors ?x86_hint 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 = backend_x86 ~default:false 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 [-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; llvm_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 = backend_x86 ~default:false 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) ...\n flan emit [--x86] [--dev] [--debug] [--no-bounds-checks]\n\ \ flan import-c [package.flan...] [clang flags...]\n\ \ flan generate-c \n\ \ flan build [-o out] [-O0|-O1|-O2|-O3] \ [--no-bounds-checks] [--dev] \ [--debug] [--sanitize] [--x86] [--target=wasm32-wasi|web|js]\n\ \ flan run [build flags...] [--] [program args...]\n\ \ flan reload [-o out.so] [--x86]\n\ \ flan dev [-s socket] [--x86]"; exit 2