Joseph Ferano
22cc0bc1c2
Editing a defvar or a defn is a symbol the host exports. Adding one is not: there is nothing to bind to and ELF cannot grow a symbol. runtime/flan_dev.c is the two lookups that cover it - flan_dev_cell for a new function's cell, flan_dev_global for a new global's storage - both idempotent, so the second module to mention a name gets what the first one got. That is the whole point: two modules with their own copy of a new function would each call their own, and redefining it would update one of them. The compiler picks per name. A name the host has is a symbol and costs one load at a call site; a name it lacks is a registry lookup cached at install time in a module-local slot, and costs two. The common case pays nothing for the general one. The redefinition unit is now a list of top-level forms rather than one function. It has to be: v3 of the fixture adds a var and uses it from a redefined bump, and splitting that into two loads leaves a module referring to storage that does not exist yet. C-c C-c passes one name, C-c C-k passes a file's worth, one path either way. Four rules, each silent if broken. Every lookup resolves before any body is published, or a caller reaches a function whose slots are still null - asserted on the emitted flan_reload_install, since it cannot be race-tested. flan_dev_global refuses a size change, which is the layout-drift rule's first enforcement point rather than another exception to it. Nothing is ever dlclosed, because a cell holds an address inside a module's text. And the table is fixed capacity, because a module holds a cell's address for as long as it is loaded and a realloc would strand it. The test that separates this from a plausible wrong version is v4, which redefines a name v3 introduced at run time. v3's bump is already installed and is not rebuilt, so it picks v4 up only if its call goes through a cell both modules found by the same name. Had v3 cached the function's address instead, every other assertion would still pass and the transcript would read 246 instead of 432. Sizes are spelled LLVM's way, ptrtoint getelementptr null 1, rather than by a layout calculator in OCaml that would have to agree with LLVM's on every target.
208 lines
8.2 KiB
OCaml
208 lines
8.2 KiB
OCaml
(** Driver: typed IR → an executable, via LLVM IR text and clang.
|
|
|
|
The release path from plan.org, Compilation:
|
|
|
|
{v flan → typed IR → .ll → clang --target={native,wasm32} v}
|
|
|
|
Not the dev path — that one never invokes the clang driver, because the
|
|
driver *is* the cost, and goes llc + ld -shared + dlopen instead. That is
|
|
[shared], at the bottom of this file, measured at ~19ms. *)
|
|
|
|
let clang = try Sys.getenv "FLAN_CLANG" with Not_found -> "clang"
|
|
|
|
let write path contents =
|
|
let ch = open_out path in
|
|
output_string ch contents;
|
|
close_out ch
|
|
|
|
(* One temporary directory per build, so the .ll is findable by name when
|
|
something is wrong with it. *)
|
|
let workdir () =
|
|
let d =
|
|
Filename.concat (Filename.get_temp_dir_name ())
|
|
(Printf.sprintf "flan-%d" (Unix.getpid ()))
|
|
in
|
|
(try Unix.mkdir d 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
|
|
d
|
|
|
|
(* The object cache, which unlike [workdir] is stable across builds. The C that
|
|
goes into a build — the host shim and the packages' shims — is the same on
|
|
every build and never the thing being edited, yet it was being recompiled
|
|
each time: 40ms of a 140ms build for [flan_rt.c] alone. *)
|
|
let cachedir () =
|
|
let d = Filename.concat (Filename.get_temp_dir_name ()) "flan-objcache" in
|
|
(try Unix.mkdir d 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
|
|
d
|
|
|
|
type opts = {
|
|
target : string option; (* None is the host; "wasm32-wasi" is the other *)
|
|
opt : string;
|
|
keep : bool; (* leave the .ll behind *)
|
|
checks : bool; (* bounds-check [at] and [slice] *)
|
|
(* A dev build is the one a REPL can attach to. Two things, and they belong
|
|
together because either alone is useless: every cross-function call goes
|
|
through a cell so a redefinition can be installed, and [-rdynamic] exports
|
|
those cells (and the globals) so a dlopen'd module can reach them. *)
|
|
dev : bool;
|
|
}
|
|
|
|
(* Checks are deliberately independent of [opt]: the acceptance table runs the
|
|
same programs at -O0 and -O2 to compare the emitted IR against what mem2reg
|
|
makes of it, and that comparison is only meaningful if both emit the same
|
|
checks. Dropping them is a release decision, not an optimisation one. *)
|
|
let default =
|
|
{ target = None; opt = "-O2"; keep = false; checks = true; dev = false }
|
|
|
|
(* What the compiler itself is, cheaply: its path, size and mtime. A clang
|
|
upgrade changes one of those, so the key changes with it — without paying a
|
|
[clang --version] subprocess on every build, which would cost most of what
|
|
the cache buys. *)
|
|
let clang_stamp =
|
|
lazy
|
|
(let path =
|
|
if Filename.is_relative clang then
|
|
let dirs = String.split_on_char ':' (try Sys.getenv "PATH" with Not_found -> "") in
|
|
(try List.find (fun d -> Sys.file_exists (Filename.concat d clang))
|
|
dirs |> fun d -> Filename.concat d clang
|
|
with Not_found -> clang)
|
|
else clang
|
|
in
|
|
match Unix.stat path with
|
|
| st -> Printf.sprintf "%s:%d:%f" path st.Unix.st_size st.Unix.st_mtime
|
|
| exception Unix.Unix_error _ -> path)
|
|
|
|
(* Compile one C translation unit to an object file, reusing a cached one when
|
|
the source text, the compiler and the flags are all unchanged. The key has
|
|
to carry [opt] and [target]: the acceptance table builds the same programs
|
|
at -O0 and -O2, and an -O2 object must not serve an -O0 build. *)
|
|
let compile_c ~opts ~src ~name =
|
|
let key =
|
|
Digest.to_hex
|
|
(Digest.string
|
|
(String.concat "\000"
|
|
[ name; src; Lazy.force clang_stamp; opts.opt;
|
|
(match opts.target with None -> "" | Some t -> t) ]))
|
|
in
|
|
let obj = Filename.concat (cachedir ()) (key ^ ".o") in
|
|
if not (Sys.file_exists obj) then begin
|
|
let dir = workdir () in
|
|
let c = Filename.concat dir name in
|
|
write c src;
|
|
(* A distinct temporary target, renamed into place, so two builds running
|
|
at once cannot see a half-written object. *)
|
|
let tmp = Printf.sprintf "%s.%d.tmp" obj (Unix.getpid ()) in
|
|
let cmd =
|
|
String.concat " "
|
|
([ Filename.quote clang; opts.opt; "-c" ]
|
|
@ (match opts.target with None -> [] | Some t -> [ "--target=" ^ t ])
|
|
@ [ Filename.quote c; "-o"; Filename.quote tmp ])
|
|
in
|
|
let code = Sys.command cmd in
|
|
if code <> 0 then
|
|
failwith (Printf.sprintf "%s failed (exit %d) on %s" clang code name);
|
|
(try Unix.rename tmp obj with Unix.Unix_error _ -> ());
|
|
(try Sys.remove c with Sys_error _ -> ())
|
|
end;
|
|
obj
|
|
|
|
let read_file path =
|
|
let ch = open_in_bin path in
|
|
let n = in_channel_length ch in
|
|
let s = really_input_string ch n in
|
|
close_in ch;
|
|
s
|
|
|
|
(* [csrcs] and [lflags] come from the imported packages (see [Load]): the C
|
|
shim a package binds through, and the arguments needed to link the library
|
|
it binds to. *)
|
|
let executable ?(opts = default) ?(csrcs = []) ?(lflags = [])
|
|
(p : Tast.program) ~out =
|
|
let dir = workdir () in
|
|
let ll = Filename.concat dir (Filename.basename out ^ ".ll") in
|
|
write ll (Emit.program ~checks:opts.checks ~dev:opts.dev p);
|
|
let objs =
|
|
compile_c ~opts ~src:Runtime_src.source ~name:"flan_rt.c"
|
|
:: (if opts.dev then
|
|
[ compile_c ~opts ~src:Runtime_src.dev_source ~name:"flan_dev.c" ]
|
|
else [])
|
|
@ List.map
|
|
(fun c ->
|
|
compile_c ~opts ~src:(read_file c) ~name:(Filename.basename c))
|
|
csrcs
|
|
in
|
|
let cmd =
|
|
String.concat " "
|
|
([ Filename.quote clang; opts.opt; "-Wno-override-module" ]
|
|
@ (if opts.dev then [ "-rdynamic" ] else [])
|
|
@ (match opts.target with None -> [] | Some t -> [ "--target=" ^ t ])
|
|
@ [ Filename.quote ll ]
|
|
@ List.map Filename.quote objs
|
|
@ lflags
|
|
@ [ "-o"; Filename.quote out ])
|
|
in
|
|
let code = Sys.command cmd in
|
|
if code <> 0 then
|
|
failwith (Printf.sprintf "%s failed (exit %d); the IR is at %s" clang code ll);
|
|
if not opts.keep then (try Sys.remove ll with Sys_error _ -> ());
|
|
out
|
|
|
|
(* ── The dev path: one function into a loadable object ──────────────── *)
|
|
|
|
(* Step 1 of the dev loop (NEXT.md): [Emit.redefinition] text → a [.so] the
|
|
running process can [dlopen]. This never invokes the clang driver — the
|
|
driver is most of what a build costs and none of what it does is needed
|
|
here, since the input is already IR and the output has no libc to find.
|
|
|
|
[ld -shared] rather than [clang -shared] for the same reason. A shared
|
|
object is allowed undefined symbols, which is the whole mechanism: the
|
|
redefined function's calls to other Flan functions, to the globals and to
|
|
the runtime are all left for the loader to bind back to the host.
|
|
|
|
PIC has to be asked for. [llc] defaults to the static relocation model on
|
|
this target, and the failure is at link time, not at codegen: "relocation
|
|
R_X86_64_32S against ... can not be used when making a shared object". *)
|
|
|
|
let llc = try Sys.getenv "FLAN_LLC" with Not_found -> "llc"
|
|
let linker = try Sys.getenv "FLAN_LD" with Not_found -> "ld"
|
|
|
|
(* Times in milliseconds, per stage, because a single total does not say
|
|
whether the number is worth chasing. *)
|
|
type timing = { llc_ms : float; link_ms : float }
|
|
|
|
let time f =
|
|
let t0 = Unix.gettimeofday () in
|
|
let x = f () in
|
|
(x, (Unix.gettimeofday () -. t0) *. 1000.)
|
|
|
|
let run what cmd =
|
|
let code = Sys.command cmd in
|
|
if code <> 0 then failwith (Printf.sprintf "%s failed (exit %d)" what code)
|
|
|
|
let shared ?(opts = default) ~ir ~out () : timing =
|
|
let dir = workdir () in
|
|
let base = Filename.remove_extension (Filename.basename out) in
|
|
let ll = Filename.concat dir (base ^ ".ll") in
|
|
let obj = Filename.concat dir (base ^ ".o") in
|
|
write ll ir;
|
|
let (), llc_ms =
|
|
time (fun () ->
|
|
run llc
|
|
(String.concat " "
|
|
([ Filename.quote llc; opts.opt; "-filetype=obj";
|
|
"-relocation-model=pic" ]
|
|
@ (match opts.target with None -> [] | Some t -> [ "-mtriple=" ^ t ])
|
|
@ [ Filename.quote ll; "-o"; Filename.quote obj ])))
|
|
in
|
|
let (), link_ms =
|
|
time (fun () ->
|
|
run linker
|
|
(String.concat " "
|
|
[ Filename.quote linker; "-shared"; Filename.quote obj; "-o";
|
|
Filename.quote out ]))
|
|
in
|
|
if not opts.keep then begin
|
|
(try Sys.remove ll with Sys_error _ -> ());
|
|
(try Sys.remove obj with Sys_error _ -> ())
|
|
end;
|
|
{ llc_ms; link_ms }
|