diff --git a/TODO.org b/TODO.org index 899c9b6e..d2c3d726 100644 --- a/TODO.org +++ b/TODO.org @@ -522,7 +522,7 @@ Func, Fnptr. CLOSED: [2026-09-25] Only a capturing =fn= that may outlive its frame gets a collector environment; one only called or passed down keeps its stack environment, as every handler does. -Capture stays by value, and a =Map= of function values is refused. Rules out a +Capture stays by value; a =Map= walks its values as a =Vec= does. Rules out a tag bit on the environment word and a heap environment for every closure. ** WAIT CFn and C's calling convention @@ -911,16 +911,6 @@ there is a =Vec= to write real arena programs with, so whether the escapes that actually occur are lexical can now be answered. The next thing to look at, not the next thing to build. -** TODO A fixed array of structs or of strings is not a map key -Refused by name, narrower than the spec's key set; a struct holding the array -works. It needs the per-element walk a struct key gets, driven by a loop rather -than a field list. - -** TODO map-keys and map-values cannot be prelude functions -Iteration is built; the remaining refusal is generics. A =defn= has to name its -types and =(defn map-keys [m (Map K V)] (Vec K))= has no =K=. The loop is three -lines at the call site, where =K= is known. - ** DONE (vec-new [u8]) is refused CLOSED: [2026-09-25] The type positions of =vec-new= and =map-new= take a type expression: brackets, or @@ -944,9 +934,10 @@ pairs. Rules out a type slot in =let=. CLOSED: [2026-09-25] =[const T]= and =(Ptr const T)=; a =[T]= or =(Ptr T)= converts at the top of a type or under another const one, never inside a writable one. The const is shallow: an element of a =[const [u8]]= and a Vec's buffer are writable. The address of read-only storage, a string's byte included, is a =(Ptr const T)=, and a C =const T *= parameter takes one. -** TODO (slice d 1) over a dyn string is refused where (at d i) works -The typed and dyn spaces disagree about a spelling, which the standing rule -forbids. A dyn slice should exist. +** TODO (slice d 1) over a dyn vec traps where the typed Vec's works +A text slices to a copy, which is the typed view's meaning because a text is +immutable. A vec's slice has to share the vec's elements, so it needs a view +object over a dyn vec; a copy would compute something else. ** TODO (slice "abc" 0 99) is not refused at compile time A string type carries no length, so there is nothing to compare the bound against @@ -1085,13 +1076,6 @@ Every program in the corpus that compiles, has a =main= and terminates agrees wi the LLVM build down to stderr. =docs/BUILT.md=, "The hand-written x86 backend, and the four measurements behind it", is the account. -** NEXT Nothing pins the LLVM side at -O0 when the two backends are compared -Decided 2026-09-25: the x86 parity survey compares against LLVM at -O0 only; -O2 is never its target. The acceptance suite's paired -O2/-O0 rows stay, being the check for undefined behaviour in emitted IR, which is a different question. -The survey builds both sides at the default =-O2=, so a construct LLVM folds is -compared as a constant rather than as a lowering. That is how the float =%= gap -survived. Two things would close it: an =-O0= pass of the sweep, and something -that walks the two backends' primitive match arms mechanically. Neither is queued. - ** DONE Reading (uninit) before writing it is undefined behaviour CLOSED: [2026-09-25] Reading an =(uninit)= value before writing it is undefined behaviour, and the backends may differ on it. An exhausted match stays =ud2= on x86. @@ -1447,12 +1431,14 @@ through a pointer into it is answerable; memcheck is told the same fact, so the same read is reported. The two stay two claims — different tools reaching different people. -** NEXT The leak question across the corpus +** WAIT The leak question across the corpus Decided 2026-09-25: one pass over the whole corpus with LeakSanitizer and memcheck's leak check on. Memory an allocator holds by design is set aside; memory nothing owns is a leak and is fixed. The sweeps' default stays leak-checking off. -Both sweeps run with leak checking off, because allocate-once-never-free is this -runtime's design and a leak check produces a suppression list. A green sweep -therefore says nothing about who frees the newly allocating =(bytes s)=. Worth -asking on purpose one day, across the whole corpus and not one program. +WAIT on the between-batches sweep slot: the switches are +=ASAN_OPTIONS=detect_leaks=1 dune build @sanitize= and =FLAN_LEAKS=1 dune build @valgrind=. +A 22-program LSan sample found no runtime leak; program leaks in map-remove and +map-keys are fixed. Needs a decision: =(bytes s)= and =(clone slice)= with no +allocator answer a =[T]= over a heap block nothing can free (bytes-copy.flan). +Temp-allocator by default, as =i64->bytes= is, or a =(Vec T)= the caller frees? ** DONE trap_oom has no site CLOSED: [2026-09-25] diff --git a/docs/BUGS-2026-09-18.md b/docs/BUGS-2026-09-18.md index 094ec6e4..b7f923e8 100644 --- a/docs/BUGS-2026-09-18.md +++ b/docs/BUGS-2026-09-18.md @@ -64,7 +64,7 @@ claims the hardware masks to operand width; it masks to 63. `emit.ml:2041` masks `bits-1` explicitly (TODO.org, "A shift count is bounded two different ways", records this as the language's rule). Six confirmed divergences, e.g. `(<< x 32)` on i32: LLVM 1, x86 0; `(>> i8min 8)`: LLVM --128, x86 -1. Invisible because `spike/x86/survey.sh:80` never globs `spike/js/*.flan`, +-128, x86 -1. Invisible because `test/survey-x86.sh:80` never globs `spike/js/*.flan`, where `p1-int-semantics.flan` already catches it — widen the glob in the same lane. Same wide-compute root, second divergence: float→int overflow under `--no-bounds-checks` gives 0 on x86 (64-bit `cvttsd2si` then truncate) vs INT_MIN on LLVM. Acknowledged-UB diff --git a/docs/BUILT.md b/docs/BUILT.md index 2fc8b761..3ded16d5 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -1265,8 +1265,8 @@ looked wrong. ### Proved by comparing output, never by reading bytes -`spike/x86/survey.sh` builds each program in `test/programs` and each probe in `spike/x86` twice — once default, once -`--x86`, **with the same bounds-check setting on both sides** — runs both, and compares stdout, stderr and the exit +`test/survey-x86.sh` builds each program in `test/programs`, the `x86-p*` probes among them, twice — once through LLVM +at `-O0`, once `--x86`, **with the same bounds-check setting on both sides** — runs both, and compares stdout, stderr and the exit status. stderr is not a detail: every message the condition machinery produces goes there, each carrying a location this backend emits by hand as a `.rodata` label and a length in a register, and an exit status of 134 with the wrong text beside it is exactly the failure that reads as a match. @@ -1374,7 +1374,7 @@ must not land in the middle of one; and the `flan_dev_reg_enable` constructor, w **The corpus structurally cannot test this.** A dev build starts with every cell pointing at the body this build compiled, so it prints what a release build prints whether or not anything reads the cell — the property that makes -the whole corpus a safe test of the cells is the property that makes it a useless one. `spike/x86/cells.sh` preloads +the whole corpus a safe test of the cells is the property that makes it a useless one. `test/cells.sh` preloads a shared object whose constructor looks up `flan.cell.twice` with `dlsym` and stores a different body there: the one store a redefinition ends in, done from outside with no compiler involved. Four builds, and the two release rows are half the test — they answer `42 42` because there is no cell and `dlsym` finds nothing, which is what says the change @@ -1400,7 +1400,7 @@ refused. What it does not emit is locals and types, and that is deliberate — a temporary whose lifetime this backend does not model, so there is nothing honest for a `DW_TAG_variable` to point at. A backtrace names files, functions and lines; `print x` says the name is not in the current context. A `flan dev --debug` session still takes LLVM's side, because `X86.redefinition` emits no line table. -- **Code size and speed** are measured, in `spike/x86/COST.md`. This backend emits **3.84× the code LLVM does at +- **Code size and speed** were measured in `spike/x86/COST.md`, since deleted with `spike/` and in git history. This backend emits **3.84× the code LLVM does at `-O2` and 1.92× what LLVM emits at `-O0`** — half the factor is the optimiser and not the backend. Of the five suspected costs, the frame-slot round trip on every intermediate is most of everything and is the one worth fixing; `rep movsb` is twenty cycles a copy and worth fixing cheaply; the bounds check's three temporaries cost 241 bytes @@ -1562,7 +1562,7 @@ least two" — and lets the old caller fail at run time with a wrong-number-of-a count at run time to fail on, so the run-time half is a check it has to emit. **A dev cell is three words**: `{ ptr body, i64 word, ptr text }`. The body is first, so a plain load of the cell is -still the body and `spike/x86/cells.sh`'s store through `dlsym` still works. The word is a hash (FNV-1a) of the +still the body and `test/cells.sh`'s store through `dlsym` still works. The word is a hash (FNV-1a) of the signature spelled the way a `defn` writes it — `[i64 i64] i64` — and the text is that spelling as a C string. `Emit.sig_text` and `Emit.sig_word` are the one definition both backends use. A redefinition module's installer stores the word and the text beside the body; a registry cell (`flan_dev_cell`) is three zeroed words until then. @@ -1841,8 +1841,8 @@ the merged entry point uses to flush and park. #### What the embedding spike measured, and the three rules it left behind The merge was taken on a spike run before any of it was built — `spike/embed/`, four shell scripts and sixteen small -sources driving `ocamlfind` and `clang` by hand against the `flan.cmxa` dune already builds. Nothing under `spike/` is -wired into the build. What it answered is why the shape above was safe to commit to. +sources driving `ocamlfind` and `clang` by hand against the `flan.cmxa` dune already builds, deleted since and kept in +git history. What it answered is why the shape above was safe to commit to. **Linking.** `ocamlopt -output-complete-obj`, not `-output-obj`: it bundles the runtime, so there is no hunt for `libasmrun`. The final link needs `-lm -lpthread -ldl` and, on 5.x, **`-lzstd`** — the marshaller is compressed, and @@ -1861,7 +1861,7 @@ specific capability the merged design needs. expected conflict does not exist. The reason is structural: OCaml 5 detects stack overflow with an explicit stack-limit check rather than with a guard page and a SIGSEGV handler. So the break loop can take `SIGSEGV` outright and does not have to install first or last. **This is an `x86_64-pc-linux-gnu` measurement only** — re-run -`spike/embed/sig.sh` on macOS/arm64 before relying on it there. `flan_agent.c` needs nothing from it either way; it +`spike/embed/sig.sh` (git history) on macOS/arm64 before relying on it there. `flan_agent.c` needs nothing from it either way; it sends with `MSG_NOSIGNAL` throughout. **The GC and raw memory.** An 8 MiB arena filled with a checkable pattern, 64 raw interior pointers taken into it, @@ -4575,8 +4575,13 @@ read of a local. So the prelude's `map`, `filter` and `reduce` are as cheap in a closure as in one that makes none: a map, filter and reduce loop measured 1.77G instructions at LLVM `-O2` with and without one unrelated escaping closure. -**What is refused.** A `Map` whose values hold a function value (`fn-in-map.flan`): a `Map`'s storage is not walked. -A bare `Fn` field, global or array element is still refused for its zero; `(Option (Fn ...))` holds one. +**A `Map`'s values are walked the same way** (`fn-in-map.flan`). A descriptor's `maps` table names each `Map` header +and the value type's descriptor; `flan_rt.c` reports each `Map` block through the same hook, and the marker walks the +full slots of a live block, reading the slot count from the header and the stride and value offset from the block's +own head. It covers a dyn value as well as a closure, so `(Map K dyn)` holds dyn values the collector keeps. The hook +is installed by any program holding a dyn, not only one making heap closures. + +**What is refused.** A bare `Fn` field, global or array element, for its zero; `(Option (Fn ...))` holds one. **A module that makes a heap closure is never unloaded**: the environment points at the module's descriptor and code, so making one counts toward the same gate a string literal does. A capturing `fn` typed at the dev prompt takes diff --git a/docs/SPIKE-GENERICS.md b/docs/SPIKE-GENERICS.md index 1533da17..d7dfa36e 100644 --- a/docs/SPIKE-GENERICS.md +++ b/docs/SPIKE-GENERICS.md @@ -10,6 +10,7 @@ > and nested inside `[$t]` or `(Option $t)`, and bare `t` only where a type's *name* is an argument in > expression position, as in `(vec-new t)` and the cast `(t x)`. `(Option t)` does not compile. > plan.org's Types section and spec-memory.md's Generics section are the current account. +> `spike/`, which held every file this report names, was deleted on 2026-09-25; the files are in git history. Milestone 5's parametric polymorphism, run early and deliberately out of order, as a spike rather than as a decision. **Feasible, and smaller than expected.** A generic function written in Flan goes through the ordinary diff --git a/docs/handoffs/HANDOFF-arith.md b/docs/handoffs/HANDOFF-arith.md index 0b512cd6..6f673f1b 100644 --- a/docs/handoffs/HANDOFF-arith.md +++ b/docs/handoffs/HANDOFF-arith.md @@ -76,7 +76,7 @@ because `load_loc` has already widened both operands according to their own sign backends used to diverge silently rather than both dying: x86 divided in 64 bits and truncated on the store, producing `-2147483648` for an `i32`, where LLVM emitted poison. `arith.flan` has an `i32` case for exactly that reason. -`spike/x86/survey.sh` is 101 MATCH / 0 DIFFER / 0 REFUSED, with the two programs this change adds among them. +`test/survey-x86.sh` is 101 MATCH / 0 DIFFER / 0 REFUSED, with the two programs this change adds among them. `arith.flan` carries an `i32` overflow case and an `f32` cast case on purpose, and neither is padding. The `i32` overflow is where the two backends disagreed *silently* rather than both dying, and it is the only thing that diff --git a/docs/handoffs/HANDOFF-cimport-ptr.md b/docs/handoffs/HANDOFF-cimport-ptr.md index ac32f351..6349a518 100644 --- a/docs/handoffs/HANDOFF-cimport-ptr.md +++ b/docs/handoffs/HANDOFF-cimport-ptr.md @@ -124,11 +124,11 @@ actually about is a **pointer reinterpretation**, which is not a checker arm. `defstruct`, every hand-written `declare-c` and every mapped constant against `raylib-5.5.h` and refuses to write when they disagree. - `bash web/examples/check.sh` green. -- `spike/x86/survey.sh` on the finished tree: **103 MATCH, 0 DIFFER, 0 REFUSED** (38 skip +- `test/survey-x86.sh` on the finished tree: **103 MATCH, 0 DIFFER, 0 REFUSED** (38 skip — 28 that do not compile on purpose, 8 with no main, 2 that run forever). Expected rather than surprising: nothing here is below the IR, and the one surveyed program that changed is `test/programs/raylib-codepoints.flan`. Run it detached — `setsid timeout - 2400 spike/x86/survey.sh > log 2>&1 log 2>&1 log 2>&1 log 2>&1 log 2>&1 log 2>&1 log 2>&1 log 2>&1 ` beside ``. @@ -112,7 +112,7 @@ fixtures did **not** fail here — `/tmp` had room throughout (6% used at start **Yes, reached and tested.** And the test is the interesting part, because *the corpus cannot do it*: a dev build starts with every cell pointing at the body that build compiled, so it prints exactly what a release build prints -whether or not anything reads the cell. `spike/x86/cells.sh` preloads a `.so` whose constructor `dlsym`s +whether or not anything reads the cell. `test/cells.sh` preloads a `.so` whose constructor `dlsym`s `flan.cell.twice` (the cells are in `.dynsym` — a dev build is `-rdynamic`) and stores a different body there. Four builds; the two release rows are the control that says the effect is the indirection and not symbol interposition: @@ -162,5 +162,5 @@ returned a struct. `cells.sh` does not reach it: the body it installs is `(i64, bounds check, every intermediate in memory, `rep movsb` block copies, and now an extra load per call site in a dev build — which is the one item `emit.ml` pays too. -**Also worth doing and not a backend item: run `spike/x86/survey.sh` in CI.** The 2 refusals this lane found were a +**Also worth doing and not a backend item: run `test/survey-x86.sh` in CI.** The 2 refusals this lane found were a month-old lane's new prim, and nothing noticed. A backend that refuses by name does not rot quietly, but it does rot. diff --git a/emacs/MANUAL.md b/emacs/MANUAL.md index 34130ffa..7c4a4b01 100644 --- a/emacs/MANUAL.md +++ b/emacs/MANUAL.md @@ -1052,7 +1052,7 @@ it is written in the compiler, so there is no file to open. `C-c C-l` on a name opens `*flan-lowering*`: the LLVM IR the frontend emits for that function, what `llc` makes of it at `-O0` and at `-O2`, and what the hand-written x86 backend emits, all narrowed to the one function. It is -`spike/x86/dump.sh` with a buffer around it. Reading one against another is the +`tools/dump.sh` with a buffer around it. Reading one against another is the only way to check a lowering by eye, and the reason the second backend is trustworthy is that the two agree. diff --git a/emacs/flan-lower.el b/emacs/flan-lower.el index 4fdd3268..87197096 100644 --- a/emacs/flan-lower.el +++ b/emacs/flan-lower.el @@ -19,7 +19,7 @@ ;; to is not an Emacs package and cannot be listed here either -- emacs/MANUAL.md ;; says what has to be on PATH. -;; `spike/x86/dump.sh' prints four lowerings of one function side by side -- +;; `tools/dump.sh' prints four lowerings of one function side by side -- ;; the LLVM IR the frontend emits, what `llc' makes of it at -O0 and at -O2, ;; and what the hand-written x86 backend emits. Reading one against another is ;; the only way to check a lowering by eye, and the whole reason the second diff --git a/lib/build.ml b/lib/build.ml index 70e94449..9b25b1d9 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -690,11 +690,23 @@ let compile_c ~opts ?tflags ?(warn = []) ~src ~name () = built against, so repointing either must not serve a stale .o. *) let tflags = match tflags with Some f -> f | None -> target_flags opts in let cc = compiler opts in + (* A source that includes the dyn header was compiled against it, so the + header is part of what the object depends on. Without it a change to a + struct the header declares served an object built against the old layout + — test/dyn_ops.c read a descriptor's new fields past the end of its own. *) + let header = + let needle = "flan_dyn.h" in + let n = String.length needle and m = String.length src in + let rec has i = + i + n <= m && (String.sub src i n = needle || has (i + 1)) + in + if has 0 then Runtime_src.dyn_header else "" + in let key = Digest.to_hex (Digest.string (String.concat "\000" - [ name; src; stamp_of cc; opts.opt; + [ name; src; header; stamp_of cc; opts.opt; String.concat " " (cflags opts); String.concat " " tflags; String.concat " " warn ])) diff --git a/lib/check.ml b/lib/check.ml index 7a300980..9ca97cf7 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -3662,14 +3662,9 @@ let rec key_pair env loc (k : Types.t) : Tast.fnref * Tast.fnref = fail loc "%s is a union, and a union is not a map key — key on the member you \ meant" n - | Types.Array (_, e) -> - (* A fixed array of a struct or of strings would need the same per-element - walk a struct key gets, driven by a loop rather than by a field list. - Nothing has wanted one, so it is refused by name rather than written - untested — and refused with the shape that does work named beside it. *) - fail loc - "a fixed array of %s is not a map key — a struct holding the array is" - (Types.to_string e) + (* A bytewise array took the arm above; this is one whose elements need + their own pair, a string's or a struct's. *) + | Types.Array (n, e) -> array_key_pair env loc n e | Types.Float _ -> (* Not a milestone question, which is why it is said separately: NaN is not equal to itself, and 0.0 and -0.0 are equal while differing bytewise. A @@ -3801,6 +3796,129 @@ and struct_key_pair env loc n = Tast.Flanfn hname, Tast.Flanfn ename end +(* The pair for a fixed array whose elements are not bytewise: the struct + pair's shape, with the field list replaced by a loop over the elements, so + [[64 string]] is one call site in a loop and not sixty-four. Each element is + hashed and compared by its own pair, so an array of structs holding strings + is served by the same recursion. *) +and array_key_pair env loc n e = + if Int64.compare n 0L <= 0 then + fail loc + "%s has no elements, so it is not a map key — every value of it would be \ + the same key" (Types.to_string (Types.Array (n, e))); + let aty = Types.Array (n, e) in + (* The type's printed form, with what a symbol cannot hold replaced. *) + let tag = + String.map + (fun c -> match c with + | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' -> c + | _ -> '_') + (Types.to_string aty) + in + (* The mangle is many-to-one — [a+b] and [a_b] come out alike — so a digest + of the printed type, which is an identity, keeps two such keys apart. *) + let tag = + tag ^ "/" ^ String.sub (Digest.to_hex (Digest.string (Types.to_string aty))) 0 12 + in + let hname = "map/hash/array/" ^ tag and ename = "map/eq/array/" ^ tag in + let known name = + List.exists (fun (f : Tast.fn) -> f.Tast.name = name) env.lifted + in + if known hname then Tast.Flanfn hname, Tast.Flanfn ename + else begin + let pty = Types.Ptr (Types.Mut, aty) in + let hparams = [ pty; hash_ty; Types.Int Types.I64 ] in + let eparams = [ pty; pty; Types.Int Types.I64 ] in + let placeholder name ret params = + { Tast.name; params; slots = Array.of_list params; + snames = Array.make (List.length params) None; + ret; body = []; fdefers = []; fenv = None; fparent = None; floc = loc } + in + env.lifted <- + placeholder hname hash_ty hparams + :: placeholder ename (Types.Int Types.I8) eparams + :: env.lifted; + let h, eq = key_pair env loc e in + let call ret f args = + match f with + | Tast.Rtfn s -> rt loc ret (direct s) args + | Tast.Flanfn s | Tast.Fnval s -> mk loc ret (Tast.Call (s, args)) + in + let elem_addr p i = + let target = mk loc aty (Tast.Deref (mk loc pty (Tast.Local p))) in + mk loc (Types.Ptr (Types.Mut, e)) + (Tast.Addr (Tast.Pindex (target, [ mk loc index_ty (Tast.Local i) ]))) + in + (* The counter and its loop, which carries no break and no continue — the + condition tast.ml puts on a [While] the checker invents. *) + let loop ctx body = + let i = fresh_slot ~name:"i" ctx index_ty in + let iv = mk loc index_ty (Tast.Local i) in + let limit = mk loc index_ty (Tast.Int (n, Types.I32)) in + let one = mk loc index_ty (Tast.Int (1L, Types.I32)) in + let cond = mk loc Types.Bool (Tast.Prim (Tast.Lt, [ iv; limit ])) in + let step = + mk loc Types.Unit + (Tast.Set (Tast.Plocal i, + mk loc index_ty (Tast.Prim (Tast.Add, [ iv; one ])))) + in + mk loc Types.Unit + (Tast.Let ([ (i, mk loc index_ty (Tast.Int (0L, Types.I32))) ], + [ mk loc Types.Unit (Tast.While (cond, [ body i ], [ step ])) ])) + in + let hctx = invented_ctx env hash_ty in + let kp = fresh_slot ~name:"key" hctx pty in + let seed = fresh_slot ~name:"seed" hctx hash_ty in + ignore (fresh_slot ~name:"size" hctx (Types.Int Types.I64)); + let acc = fresh_slot ~name:"h" hctx hash_ty in + let hbody = + [ mk loc Types.Unit + (Tast.Set (Tast.Plocal acc, mk loc hash_ty (Tast.Local seed))); + loop hctx (fun i -> + let one = + call hash_ty h + [ elem_addr kp i; mk loc hash_ty (Tast.Local seed); + size_of loc e ] + in + mk loc Types.Unit + (Tast.Set (Tast.Plocal acc, + rt loc hash_ty "flan_hash_combine" + [ mk loc hash_ty (Tast.Local acc); one ]))); + mk loc hash_ty (Tast.Local acc) ] + in + let ectx = invented_ctx env (Types.Int Types.I8) in + let ap = fresh_slot ~name:"a" ectx pty in + let bp = fresh_slot ~name:"b" ectx pty in + ignore (fresh_slot ~name:"size" ectx (Types.Int Types.I64)); + let i8 v = mk loc (Types.Int Types.I8) (Tast.Int (v, Types.I8)) in + let ebody = + [ loop ectx (fun i -> + let same = + call (Types.Int Types.I8) eq + [ elem_addr ap i; elem_addr bp i; size_of loc e ] + in + mk loc Types.Unit + (Tast.If (mk loc Types.Bool (Tast.Prim (Tast.Eq, [ same; i8 0L ])), + mk loc Types.Never (Tast.Return (Some (i8 0L))), + unit_at loc))); + i8 1L ] + in + let finish name ret params ctx body = + { Tast.name; params; + slots = Array.of_list (List.rev ctx.slot_tys); + snames = Array.of_list (List.rev ctx.slot_names); + ret; body; fdefers = []; fenv = None; fparent = None; floc = loc } + in + env.lifted <- + finish hname hash_ty hparams hctx hbody + :: finish ename (Types.Int Types.I8) eparams ectx ebody + :: List.filter + (fun (f : Tast.fn) -> + f.Tast.name <> hname && f.Tast.name <> ename) + env.lifted; + Tast.Flanfn hname, Tast.Flanfn ename + end + (* The pair as two expressions, ready to be passed. Their Flan type is [(Ptr ())]: one opaque word, which is all the backend needs. *) let key_fns env loc k = @@ -9460,22 +9578,33 @@ and named_call ?(qualified = false) ctx ~want loc name args = (while (map-next m (addr cur) (addr k) (addr v)) ...)) - It is *not* a generic (map-keys m): a Vec of them needs a signature naming - K, and a prelude defn cannot be written at every K. That one is generics, - not iteration, and it stays refused for that reason. + The prelude's map-keys and map-values are this loop over a generic key. No hash and no equality pair go with it — walking asks nothing about a key — so this is the one map entry point whose signature carries neither, and the sizes are still needed because the runtime is type-erased. *) + (* (map-next m cur k) walks the keys alone. It is what lets a walk need no + place for a value, which matters when the value is a function value: one + cannot be zeroed to make the place, and a key never is one. *) | "map-next" -> - arity ctx loc name 4 args; (match args with - | [ target; cur; k; v ] -> + | [ _; _; _ ] | [ _; _; _; _ ] -> () + | _ -> + fail loc + "map-next is (map-next m (addr cursor) (addr k) (addr v)) or, for \ + the keys alone, (map-next m (addr cursor) (addr k)) — given %d \ + arguments" (List.length args)); + (match args with + | target :: cur :: k :: rest -> let target = check_target ctx target in let kt, vt = map_kv loc "map-next" target.Tast.ty in let cur = check ctx ~want:(Types.Ptr (Types.Mut, (Types.Int Types.I64))) cur in let k = check ctx ~want:(Types.Ptr (Types.Mut, kt)) k in - let v = check ctx ~want:(Types.Ptr (Types.Mut, vt)) v in + let vp = Types.Ptr (Types.Mut, vt) in + let v = match rest with + | [ v ] -> check ctx ~want:vp v + | _ -> mk loc vp (Tast.Zero vp) + in let found = rt loc (Types.Int Types.I8) "flan_map_next" [ target; cur; k; v; size_of loc kt; size_of loc vt; here loc ] @@ -9894,6 +10023,20 @@ and named_call ?(qualified = false) ctx ~want loc name args = (* A Vec leaves here: everything below is written around a length the compiler can see, and a Vec's is a word the runtime reads. *) | Types.Vec elem -> vec_slice ctx ~want loc target elem bounds + (* A dyn leaves too, as [at] over one does: the bounds are dyn, like + [at]'s index, and a missing [hi] is nil, which the runtime reads as + the length. *) + | Types.Dyn -> + let bound b = check ctx ~want:Types.Dyn b in + let nil () = rt loc Types.Dyn "flan_dyn_nil" [] in + let lo, hi = match bounds with + | [] -> box loc (mk loc dyn_i64 (Tast.Int (0L, Types.I64))), nil () + | [ lo ] -> bound lo, nil () + | [ lo; hi ] -> bound lo, bound hi + | _ -> assert false + in + expect ctx loc ~want + (rt loc Types.Dyn "flan_dyn_slice" [ target; lo; hi; here loc ]) | _ -> (* A string slices to a string, not to a [u8]: the result views the same bytes and is read-only for the same reason the source is, and @@ -13540,8 +13683,11 @@ let rec hidden_dyn p seen (t : Types.t) : Types.t option = | Types.Dyn -> None | Types.Array (_, e) -> hidden_dyn p seen e | Types.Vec e | Types.Option e -> under e + (* A Map's values are walked through the value type's own descriptor, so a + dyn there is found wherever that descriptor finds one. A key never holds + one: dyn is not a key type. *) | Types.Map (k, v) -> - if dyn_anywhere p seen k || dyn_anywhere p seen v then Some t else None + if dyn_anywhere p seen k then Some t else hidden_dyn p seen v (* A pointer and a slice are views of storage something else roots; see the note above. What they point at is checked where it is declared. *) | Types.Ptr (_, e) | Types.Slice (_, e) -> hidden_dyn p seen e @@ -13661,53 +13807,8 @@ let rec holds_fn p seen (t : Types.t) = | None -> false) | _ -> false -(* The first Map under this type whose values hold a function value. A - closure's environment is found by walking the storage a function value - sits in, and a Map's storage is not walked — so an (Fn ...) there would be - one the collector frees under it. A Vec's is, which is the container to - use; and a (CFn ...) carries no environment and may go in a Map freely. *) -let rec map_of_fn p seen (t : Types.t) : Types.t option = - match t with - | Types.Map (k, v) when holds_fn p [] k || holds_fn p [] v -> Some t - | Types.Array (_, e) | Types.Vec e | Types.Option e - | Types.Ptr (_, e) | Types.Slice (_, e) -> map_of_fn p seen e - | Types.Map (_, v) -> map_of_fn p seen v - | Types.Named n when not (List.mem n seen) -> - let seen = n :: seen in - let fields = - match List.find_opt (fun (s : Tast.structure) -> s.Tast.sname = n) - p.Tast.structs with - | Some s -> s.Tast.fields - | None -> - match List.find_opt (fun (u : Tast.data) -> u.Tast.dname = n) - p.Tast.datas with - | Some u -> List.concat_map (fun (c : Tast.variant) -> c.Tast.vfields) u.Tast.cases - | None -> - match List.find_opt (fun (u : Tast.structure) -> u.Tast.sname = n) - p.Tast.unions with - | Some u -> u.Tast.fields - | None -> [] - in - List.fold_left - (fun acc (fl : Tast.field) -> - match acc with Some _ -> acc | None -> map_of_fn p seen fl.Tast.fty) - None fields - | _ -> None - let dyn_descriptors (p : Tast.program) = let check loc what (t : Types.t) = - (match map_of_fn p [] t with - | Some at -> - Loc.failk "check/fn-in-map" loc - "%s is %s%s, a Map whose values are function values. A function \ - value's environment is found by walking the storage it sits in, \ - and a Map's storage is not walked, so the collector would free an \ - environment still in use. Keep the function values in a Vec, or \ - make them (CFn ...) if they capture nothing" - what (Types.to_string t) - (if Types.equal t at then "" - else Printf.sprintf ", and holds %s" (Types.to_string at)) - | None -> ()); (match hidden_dyn p [] t with | Some at -> Loc.failk "check/dyn-descriptor" loc diff --git a/lib/emit.ml b/lib/emit.ml index 3572b27b..edd3773a 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -81,7 +81,7 @@ let cellname n = "@" ^ quoted (Mangle.cell n) { ptr body, i64 word, ptr text } The body is first, so everything that only ever wanted the body — a load - of the cell, [spike/x86/cells.sh]'s store through [dlsym] — reads the + of the cell, [test/cells.sh]'s store through [dlsym] — reads the same address it always did. The word is what makes a signature change installable. A redefinition that @@ -459,23 +459,26 @@ let align_up x a = if a <= 1 then x else ((x + a - 1) / a) * a pointer is four bytes and [goff] would name the wrong word. *) type gcword = { goff : int; gpath : (string * string list) list } -(* Every word of an instance the collector follows, by kind — the three +(* Every word of an instance the collector follows, by kind — the four tables of runtime/flan_dyn.h's [flan_desc]. [gvec] carries each Vec's - element type, whose own descriptor the entry points at. *) + element type and [gmap] each Map's value type, whose own descriptor the + entry points at. *) type gclayout = { gdyn : gcword list; genv : gcword list; gvec : (gcword * Types.t) list; + gmap : (gcword * Types.t) list; } (* A descriptor this module has to write out: its symbol, the words, the instance size, and the symbol of each Vec entry's element descriptor in - [gvec]'s order. *) + [gvec]'s order and of each Map entry's value descriptor in [gmap]'s. *) type desc = { dsym : string; dlay : gclayout; dsize : int; dvecs : string list; + dmaps : string list; } (* ── Module-level state ────────────────────────────────────────────── *) @@ -741,16 +744,12 @@ and dyn_offsets m (t : Types.t) : int list = — which is a run-time question a static descriptor cannot answer. Refused in [Check] rather than described wrongly here. *) | None -> acc) - (* [Types.Option], [Types.Vec] and [Types.Map] fall through here with no - arm of their own and answer no offsets, which is correct only because - nothing reaches this function holding one with a dyn inside it: + (* [Types.Option] and [Types.Vec] fall through here with no arm of their + own and answer no offsets, which is correct only because nothing + reaches this function holding one with a dyn inside it: [Check.hidden_dyn] refuses that at every global, parameter, return and - frame slot first. If that gate is ever relaxed — the typed-container - view the M2 queue's item 3 is building is exactly the kind of change - that would relax it for [Vec]/[Map] — this arm has to grow alongside - it, the way the array and struct arms above already walk their own - storage; until then a silent [] here would be an unrooted dyn, not a - refusal. *) + frame slot first. A [Types.Map]'s dyn values are not words of the + instance at all; [gc_layout] names the header in its [gmap] table. *) | _ -> acc in List.sort_uniq compare (go [] 0 t []) @@ -794,7 +793,7 @@ let desc_mangle (t : Types.t) = symbol. *) let rec desc_of m (t : Types.t) : string option = let l = gc_layout m t in - if l.gdyn = [] && l.genv = [] && l.gvec = [] then None + if l.gdyn = [] && l.genv = [] && l.gvec = [] && l.gmap = [] then None else let key = Types.to_string t in match Hashtbl.find_opt m.descs key with @@ -806,17 +805,19 @@ let rec desc_of m (t : Types.t) : string option = (* Claimed before the elements are asked for, so the counter a nested element's symbol takes cannot be this one's. *) Hashtbl.replace m.descs key - { dsym = sym; dlay = l; dsize = fst (lay m t); dvecs = [] }; - let dvecs = + { dsym = sym; dlay = l; dsize = fst (lay m t); dvecs = []; dmaps = [] }; + let elems what l = List.map (fun (_, e) -> match desc_of m e with | Some s -> s - | None -> internal "a Vec entry whose element has no words") - l.gvec + | None -> internal "a %s entry whose element has no words" what) + l in + let dvecs = elems "Vec" l.gvec in + let dmaps = elems "Map" l.gmap in Hashtbl.replace m.descs key - { dsym = sym; dlay = l; dsize = fst (lay m t); dvecs }; + { dsym = sym; dlay = l; dsize = fst (lay m t); dvecs; dmaps }; Some sym (* ── The words the collector follows ───────────────────────────────── @@ -845,7 +846,7 @@ let rec desc_of m (t : Types.t) : string option = at the same x86-64 offset and at different wasm32 ones, and marking a word twice costs nothing. *) and gc_layout m (t : Types.t) : gclayout = - let dyn = ref [] and env = ref [] and vec = ref [] in + let dyn = ref [] and env = ref [] and vec = ref [] and map = ref [] in let step ty idx path = path @ [ (ty, idx) ] in let rec go ~full seen off path (t : Types.t) = match t with @@ -858,6 +859,13 @@ and gc_layout m (t : Types.t) : gclayout = [desc_of] claims before it recurses, is what closes that loop. *) | Types.Vec e when m.gcfn -> if reaches_fn m [] e then vec := ({ goff = off; gpath = path }, e) :: !vec + (* A Map's values, when they hold a function value's environment or a + dyn. The key never does: neither is a key type. The value type's own + descriptor is what the entry points at, so a Map of Maps is walked + through the inner one's. *) + | Types.Map (_, v) -> + if (m.gcfn && reaches_fn m [] v) || reaches_dyn m [] v then + map := ({ goff = off; gpath = path }, v) :: !map | Types.Array (n, e) -> let s, _ = lay m e in for i = 0 to Int64.to_int n - 1 do @@ -924,7 +932,8 @@ and gc_layout m (t : Types.t) : gclayout = in let uniq l = List.sort_uniq order l in { gdyn = uniq !dyn; genv = uniq !env; - gvec = List.sort_uniq (fun (a, _) (b, _) -> order a b) !vec } + gvec = List.sort_uniq (fun (a, _) (b, _) -> order a b) !vec; + gmap = List.sort_uniq (fun (a, _) (b, _) -> order a b) !map } (* Whether an [(Fn ...)] is anywhere in a value's storage, a Vec's elements included. A type met again on the way contributes nothing more, which @@ -933,7 +942,8 @@ and gc_layout m (t : Types.t) : gclayout = and reaches_fn m seen (t : Types.t) = match t with | Types.Fn _ -> true - | Types.Array (_, e) | Types.Vec e | Types.Option e -> reaches_fn m seen e + | Types.Array (_, e) | Types.Vec e | Types.Option e | Types.Map (_, e) -> + reaches_fn m seen e | Types.Named nm when not (List.mem nm seen) -> let seen = nm :: seen in let fields = @@ -950,17 +960,35 @@ and reaches_fn m seen (t : Types.t) = List.exists (fun (fl : Tast.field) -> reaches_fn m seen fl.Tast.fty) fields | _ -> false +(* Whether a dyn word is anywhere [gc_layout] records one: directly, in a + fixed array, in a struct field, or in a Map's values. The other places a + dyn could sit are refused by [Check.hidden_dyn]. *) +and reaches_dyn m seen (t : Types.t) = + match t with + | Types.Dyn -> true + | Types.Array (_, e) | Types.Map (_, e) -> reaches_dyn m seen e + | Types.Named nm when not (List.mem nm seen) -> + (match Hashtbl.find_opt m.structs nm with + | Some st -> + List.exists + (fun (fl : Tast.field) -> reaches_dyn m (nm :: seen) fl.Tast.fty) + st.Tast.fields + | None -> false) + | _ -> false + (* Whether the collector has anything to follow in a value of this type — the question every rooting decision asks. [dyn_offsets <> []] was that question until an [Fn] could hold an environment. *) let traced m (t : Types.t) = t = Types.Dyn - || (let l = gc_layout m t in l.gdyn <> [] || l.genv <> [] || l.gvec <> []) + || (let l = gc_layout m t in + l.gdyn <> [] || l.genv <> [] || l.gvec <> [] || l.gmap <> []) (* The words to clear before an instance at a pushed root can be marked, as x86-64 byte offsets of eight-byte words: each dyn word, each environment - word, and each Vec header's pointer and length. The LLVM backend walks - [gpath] instead; see [zero_words]. *) + word, each Vec header's pointer and length, and each Map header's block + pointer and capacity. The LLVM backend walks [gpath] instead; see + [zero_words]. *) let gc_zero_offsets m (t : Types.t) : int list = if t = Types.Dyn then [ 0 ] else @@ -968,6 +996,7 @@ let gc_zero_offsets m (t : Types.t) : int list = List.map (fun w -> w.goff) l.gdyn @ List.map (fun w -> w.goff) l.genv @ List.concat_map (fun (w, _) -> [ w.goff; w.goff + 8 ]) l.gvec + @ List.concat_map (fun (w, _) -> [ w.goff; w.goff + 16 ]) l.gmap (* A [gpath] as an LLVM constant expression over [base]: nested constant [getelementptr]s, one per step. Over [ptr null] and through [ptrtoint] it @@ -4273,7 +4302,12 @@ let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) = (fun ((w : gcword), _) -> store "ptr null" (w.gpath @ [ ("%vec", [ "i32 0"; "i32 0" ]) ]); store "i64 0" (w.gpath @ [ ("%vec", [ "i32 0"; "i32 1" ]) ])) - l.gvec + l.gvec; + List.iter + (fun ((w : gcword), _) -> + store "ptr null" (w.gpath @ [ ("%map", [ "i32 0"; "i32 0" ]) ]); + store "i64 0" (w.gpath @ [ ("%map", [ "i32 0"; "i32 2" ]) ])) + l.gmap end in let push base (ty : Types.t) = @@ -4941,6 +4975,7 @@ declare i64 @flan_dyn_ge(i64, i64, ptr, i64) declare i64 @flan_dyn_eq(i64, i64) declare i64 @flan_dyn_len(i64) declare i64 @flan_dyn_at(i64, i64, ptr, i64) +declare i64 @flan_dyn_slice(i64, i64, i64, ptr, i64) declare void @flan_dyn_set_at(i64, i64, i64, ptr, i64) declare void @flan_dyn_push(i64, i64, ptr, i64) declare void @flan_dyn_print(i64) @@ -5095,7 +5130,7 @@ let uses_dyn (p : Tast.program) = let rec carries seen (t : Types.t) = match t with | Types.Dyn -> true - | Types.Array (_, e) -> carries seen e + | Types.Array (_, e) | Types.Map (_, e) -> carries seen e | Types.Named n when not (List.mem n seen) -> (match Hashtbl.find_opt structs n with | Some st -> @@ -5129,12 +5164,13 @@ let emit_main m ?(startup = false) ?(gc = false) ?(dyn_globals = []) (fn : Tast. dyn global's initialiser runs in the startup function below, and the very first thing it does is allocate. *) if gc then Buffer.add_string b " call void @flan_gc_init()\n"; - (* Before anything can allocate a Vec block: a program that can make a - collector-owned closure environment has flan_rt.c report every Vec block - to the collector, which reads a Vec's elements only through a block it - knows to be live (runtime/flan_dyn.c, "The Vec blocks a marker may - read"). *) - if m.gcfn then Buffer.add_string b " call void @flan_dyn_track_vecs()\n"; + (* Before anything can allocate a Vec or Map block: a program that can make + a collector-owned closure environment, or that holds a dyn, has + flan_rt.c report every such block to the collector, which reads a + container's elements only through a block it knows to be live + (runtime/flan_dyn.c, "The Vec blocks a marker may read"). *) + if m.gcfn || gc then + Buffer.add_string b " call void @flan_dyn_track_vecs()\n"; (* The dyn globals, rooted here and never popped, which is the whole of what a global's extent means. They go on the stack *before* the startup function runs, because that function is what fills them and its first @@ -5408,21 +5444,24 @@ let descriptors m = let l = d.dlay in let offs = table d.dsym "offs" "i64" (List.map word l.gdyn) in let envs = table d.dsym "envs" "i64" (List.map word l.genv) in - let vecs = - table d.dsym "vecs" "{ i64, ptr }" + let pairs suffix words syms = + table d.dsym suffix "{ i64, ptr }" (List.map2 (fun ((w : gcword), _) e -> Printf.sprintf "{ i64, ptr } { i64 %s, ptr @\"%s\" }" (offset_const w) e) - l.gvec d.dvecs) + words syms) in + let vecs = pairs "vecs" l.gvec d.dvecs in + let maps = pairs "maps" l.gmap d.dmaps in Buffer.add_string b (Printf.sprintf "@\"%s\" = private unnamed_addr constant \ - { i64, i64, ptr, i64, ptr, i64, ptr } \ - { i64 %d, i64 %d, ptr %s, i64 %d, ptr %s, i64 %d, ptr %s }\n" + { i64, i64, ptr, i64, ptr, i64, ptr, i64, ptr } \ + { i64 %d, i64 %d, ptr %s, i64 %d, ptr %s, i64 %d, ptr %s, \ + i64 %d, ptr %s }\n" d.dsym d.dsize (List.length l.gdyn) offs (List.length l.genv) - envs (List.length l.gvec) vecs)); + envs (List.length l.gvec) vecs (List.length l.gmap) maps)); Buffer.contents b (* The same table in the other backend's syntax. It lives here rather than in @@ -5466,19 +5505,22 @@ let descriptors_asm m = in let offs = table "offs" (List.map (fun w -> string_of_int w.goff) l.gdyn) in let envs = table "envs" (List.map (fun w -> string_of_int w.goff) l.genv) in - let vecs = - table "vecs" + let pairs suffix words syms = + table suffix (List.concat (List.map2 (fun ((w : gcword), _) e -> [ string_of_int w.goff; ".L" ^ e ]) - l.gvec d.dvecs)) + words syms)) in + let vecs = pairs "vecs" l.gvec d.dvecs in + let maps = pairs "maps" l.gmap d.dmaps in Buffer.add_string b (Printf.sprintf "\t.align\t8\n.L%s:\n\t.quad\t%d\n\t.quad\t%d\n\t.quad\t%s\n\ - \t.quad\t%d\n\t.quad\t%s\n\t.quad\t%d\n\t.quad\t%s\n" + \t.quad\t%d\n\t.quad\t%s\n\t.quad\t%d\n\t.quad\t%s\n\ + \t.quad\t%d\n\t.quad\t%s\n" d.dsym d.dsize (List.length l.gdyn) offs (List.length l.genv) envs - (List.length l.gvec) vecs)) + (List.length l.gvec) vecs (List.length l.gmap) maps)) rows; Buffer.contents b diff --git a/lib/js.ml b/lib/js.ml index 221faf9e..74f86563 100644 --- a/lib/js.ml +++ b/lib/js.ml @@ -135,7 +135,7 @@ {1 Where this stops, and what the next lane picks up} - [spike/js/survey.sh] is the standing measurement: 24 MATCH, 0 DIFFER, 77 + [test/survey-js.sh] is the standing measurement: 24 MATCH, 0 DIFFER, 77 refused by name, 0 that node would not run, over the corpus and this file's own two probes. What the refusals say about the order to work in: diff --git a/lib/prelude.ml b/lib/prelude.ml index 904da3c9..92110375 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -554,16 +554,42 @@ let source = {flan| ;; in. Owned by the caller: (free v), or let a (free-all a) take the region. ;; ;; This is the one that proves the containers and the generics compose. It -;; allocates — (vec-new t), push, returns (Vec t) — and the type-erased Vec +;; allocates — (vec-new $t), push, returns (Vec $t) — and the type-erased Vec ;; runtime needed no change at all, because SizeOf and AlignOf are computed at ;; the instantiation site, where the element type is concrete. (defn filter [s [const $t] keep? (Fn [$t] bool)] (Vec $t) - (let [v (vec-new t)] + (let [v (vec-new $t)] (dotimes [i (length s)] (when (keep? (at s i)) (push v (at s i)))) v)) +;; A map's keys, and its values, as a new Vec the caller owns. In block order, +;; which is the hash's and not the insertion's — sort what comes back if the +;; order matters. A string key is copied as the view it is, so the Vec reads +;; the map's own key bytes and is good for as long as they are. +(defn map-keys [m (Map $k $v)] (Vec $k) + {:where (hashable? $k)} + (let [out (vec-new $k) + cur (i64 0) + key (the $k (zeroed))] + (while (map-next m (addr cur) (addr key)) + (push out key)) + out)) + +(defn map-values [m (Map $k $v)] (Vec $v) + {:where (hashable? $k)} + ;; Walked by key and read back with get, because a place to copy a value + ;; into would have to be zeroed first, and a function value cannot be. + (let [out (vec-new $v) + cur (i64 0) + key (the $k (zeroed))] + (while (map-next m (addr cur) (addr key)) + (match (get m key) + (Some val) (push out val) + None (do))) + out)) + ;; ── The sign questions, over every numeric type at once ─────────────── ;; ;; The family the whole of generics was asked for. Three questions about a @@ -1925,15 +1951,6 @@ let source = {flan| ;; that did not come with them, because it is one copy ;; per *ordered pair* of types rather than per type, ;; which is where a per-type family stops being honest. -;; map-keys, map-values Generics — and the reason changed, which is the -;; point of naming them separately. It used to be the -;; missing Map iterator; `map-next` is that iterator -;; and walking a map is expressible now. What a defn -;; still cannot say is (defn map-keys [m {K V}] (Vec K)): -;; a prelude function has to name its types, and there -;; is no K. The loop is three lines at the call site, -;; where K is known, and that is where it stays until -;; there are generics. ;; ;; Builder Not refused — declined. strings.Builder in Odin ;; wraps a [dynamic]u8; here the (Vec u8) *is* that and diff --git a/lib/x86.ml b/lib/x86.ml index bcf1ae79..6c474fa7 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -1,6 +1,6 @@ (** Tast -> x86-64, by hand. The dev backend; LLVM stays the release one. - Grown out of [spike/backend/x86.ml], which proved the shape. What is new + Grown out of a spike's [x86.ml], which proved the shape and is in git history. What is new here is everything the spike enumerated and did not do: aggregates, floats, globals, string literals, the transfer channel, and a whole program rather than one function. @@ -4273,7 +4273,7 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false) transfer exit are dead because no path names that exit. This used to be a refusal, on the theory that a function with a defer and no transfer exit was a sign the reasoning had gone wrong. It is not — it is every leaf - function with a defer, and [spike/x86/p9-dead-defers.flan] is ten lines + function with a defer, and [test/programs/x86-p9-dead-defers.flan] is ten lines of it. [emit.ml]'s [emit_fn] writes the whole exit under the same [if f.unwound], and so drops them too. @@ -4512,9 +4512,10 @@ let emit_main ?(ann = false) ?(startup = false) ?(gc = false) xor_rr b ~dst:rax ~src:rax; call_sym b "flan_gc_init" end; - (* A program that can make a collector-owned closure environment has the - collector told of every Vec block from here on; see [Emit.emit_main]. *) - if md.Emit.gcfn then begin + (* A program that can make a collector-owned closure environment, or holds + a dyn, has the collector told of every Vec and Map block from here on; + see [Emit.emit_main]. *) + if md.Emit.gcfn || gc then begin xor_rr b ~dst:rax ~src:rax; call_sym b "flan_dyn_track_vecs" end; @@ -5048,7 +5049,7 @@ let program ~checks ?(dev = false) ?(debug = false) ?(annotate = false) # installed while the process runs is reached by the next call.\n\ #\n\ # What is not here are mnemonics. The bytes are a blob so that every\n\ - # offset stays exactly known, and spike/x86/dump.sh puts objdump's\n\ + # offset stays exactly known, and tools/dump.sh puts objdump's\n\ # disassembly of this same object beside this file: that one says what,\n\ # and this one says why.\n"; (* A numbered [.file] is what stops clang's integrated assembler from diff --git a/plan.org b/plan.org index 060ad2dd..cc973a99 100644 --- a/plan.org +++ b/plan.org @@ -525,7 +525,7 @@ on. machine code directly and is selected with ~--x86~; it exists because ~llc~ is most of the 19ms above. It is a different route from the same typed IR to the same observable behaviour, not a different semantics, and what holds it to that -is ~spike/x86/survey.sh~: every program in the corpus is built both ways and +is ~test/survey-x86.sh~: every program in the corpus is built both ways and byte-compared on stdout, stderr and exit status. At the time of writing that is 103 MATCH, 0 DIFFER, 0 refused by name. It handles conditions, bounds checks, indirection cells, redefinition modules and DWARF line tables; what it does not diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index 208f1952..ea488a33 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -131,6 +131,8 @@ typedef uint64_t flan_dyn; * - [vecs]: a (Vec T) header whose elements hold words of their own, with the * element's descriptor. The marker reads the header's pointer and length * where they are, so a push that reallocated is seen. + * - [maps]: a (Map K V) header whose values hold words of their own, with the + * value's descriptor. Read the same way, and walked over the full slots. * * [size] is the stride of one instance as the compiler's element-size * arithmetic counts it, which is what a Vec's elements are laid out at. The @@ -149,6 +151,8 @@ typedef struct flan_desc { const int64_t *envs; int64_t nvec; const flan_desc_vec *vecs; + int64_t nmap; + const flan_desc_vec *maps; } flan_desc; #define DYN_QNAN 0xFFF8000000000000ULL @@ -248,6 +252,38 @@ void flan_dyn_vec_hdr_layout(int64_t out[6]) { out[5] = (int64_t)offsetof(flan_dyn_vec_hdr, epoch); } +/* flan_map, restated for the same reason and read the same way: only + * [data], [log2cap], [alloc] and [epoch]. With it, the three numbers of the + * block's geometry the marker needs — flan_rt.c's FLAN_MAP_HEAD, _GROUP and + * _ALIGN. If either file's table changes, change both. */ +typedef struct flan_dyn_map_hdr { + void *data; + int64_t len; + int64_t log2cap; + void *alloc; + int64_t epoch; +} flan_dyn_map_hdr; + +#define DYN_MAP_HEAD 24 +#define DYN_MAP_GROUP 8 +#define DYN_MAP_ALIGN 64 +#define DYN_MAP_FULL 0x80 + +/* This mirror's numbers, compared against flan_rt.c's [flan_map_layout] by + * test/dyn_ops.c's "layout" mode. */ +void flan_dyn_map_hdr_layout(int64_t out[10]) { + out[0] = (int64_t)sizeof(flan_dyn_map_hdr); + out[1] = (int64_t)offsetof(flan_dyn_map_hdr, data); + out[2] = (int64_t)offsetof(flan_dyn_map_hdr, len); + out[3] = (int64_t)offsetof(flan_dyn_map_hdr, log2cap); + out[4] = (int64_t)offsetof(flan_dyn_map_hdr, alloc); + out[5] = (int64_t)offsetof(flan_dyn_map_hdr, epoch); + out[6] = DYN_MAP_HEAD; + out[7] = DYN_MAP_GROUP; + out[8] = DYN_MAP_ALIGN; + out[9] = DYN_MAP_FULL; +} + /* flan_allocator's prefix, far enough to read the one word a stale-container * check needs. The struct has more fields after [epoch]; this file never * touches them; and the alignment of a leading same-typed prefix is the same @@ -1259,6 +1295,64 @@ typedef struct { char *p; int64_t n; const flan_desc *e; } vec_work; static vec_work *vstack; static int64_t vstack_n, vstack_cap; +/* Maps still to walk: a live block's control run, its slots, the slot count, + * the stride and value offset the block's own head records, and the value's + * descriptor. Queued for the Vec queue's reason. */ +typedef struct { + const uint8_t *ctrl; char *slots; int64_t cap, stride, voff; + const flan_desc *e; +} map_work; +static map_work *mapstack; +static int64_t mapstack_n, mapstack_cap; + +/* A live block, not reset since it was made: the checks a Vec's block and a + * Map's share. The allocator header is never freed, so its epoch is always + * readable. */ +static vblock *live_block(void *p) { + vblock *b = vblock_find((uintptr_t)p); + if (b == NULL) return NULL; + if (b->alloc != NULL + && (int64_t)((flan_dyn_alloc_hdr *)b->alloc)->epoch != b->epoch) + return NULL; + return b; +} + +/* Queue the map whose header is at [h]. The slot count comes from the + * header and everything else from the block, and the walk is bounded by the + * block's recorded size, so a stale header copy naming a block another map + * now owns reads nothing outside that block. */ +static void queue_map(const flan_dyn_map_hdr *h, const flan_desc *e) { + vblock *b; + const int64_t *head; + int64_t cap, ctrl, stride, voff; + if (e == NULL || h->data == NULL || h->log2cap <= 0 || h->log2cap > 40) + return; + b = live_block(h->data); + if (b == NULL || b->bytes < DYN_MAP_HEAD) return; + cap = (int64_t)1 << h->log2cap; + ctrl = (DYN_MAP_HEAD + cap + (DYN_MAP_GROUP - 1) + (DYN_MAP_ALIGN - 1)) + & ~(int64_t)(DYN_MAP_ALIGN - 1); + head = (const int64_t *)h->data; + stride = head[1]; + voff = head[2]; + if (stride <= 0 || voff < 0 || voff + e->size > stride) return; + if (ctrl > b->bytes || (b->bytes - ctrl) / stride < cap) return; + if (mapstack_n == mapstack_cap) { + int64_t c = mapstack_cap ? mapstack_cap * 2 : 16; + map_work *m = (map_work *)realloc(mapstack, (size_t)c * sizeof *m); + if (m == NULL) trap_oom(NULL, 0, c * (int64_t)sizeof *m); + mapstack = m; + mapstack_cap = c; + } + mapstack[mapstack_n].ctrl = (const uint8_t *)h->data + DYN_MAP_HEAD; + mapstack[mapstack_n].slots = (char *)h->data + ctrl; + mapstack[mapstack_n].cap = cap; + mapstack[mapstack_n].stride = stride; + mapstack[mapstack_n].voff = voff; + mapstack[mapstack_n].e = e; + mapstack_n++; +} + /* The words [d] names inside the instance at [base]. A Vec entry is checked * against the live blocks above and queued; [mark_desc] drains the queue * before it returns. */ @@ -1266,17 +1360,17 @@ static void mark_words(char *base, const flan_desc *d) { int64_t j; for (j = 0; j < d->n; j++) mark_value(*(flan_dyn *)(base + d->offs[j])); for (j = 0; j < d->nenv; j++) mark_env(*(uintptr_t *)(base + d->envs[j])); + for (j = 0; j < d->nmap; j++) + queue_map((const flan_dyn_map_hdr *)(base + d->maps[j].off), + d->maps[j].elem); for (j = 0; j < d->nvec; j++) { flan_dyn_vec_hdr *h = (flan_dyn_vec_hdr *)(base + d->vecs[j].off); const flan_desc *e = d->vecs[j].elem; vblock *b; int64_t n; if (e == NULL || e->size <= 0 || h->len <= 0) continue; - b = vblock_find((uintptr_t)h->ptr); + b = live_block(h->ptr); if (b == NULL) continue; - if (b->alloc != NULL - && (int64_t)((flan_dyn_alloc_hdr *)b->alloc)->epoch != b->epoch) - continue; n = b->bytes / e->size; if (h->len < n) n = h->len; if (vstack_n == vstack_cap) { @@ -1295,10 +1389,17 @@ static void mark_words(char *base, const flan_desc *d) { static void mark_desc(char *base, const flan_desc *d) { mark_words(base, d); - while (vstack_n > 0) { - vec_work w = vstack[--vstack_n]; + while (vstack_n > 0 || mapstack_n > 0) { int64_t i; - for (i = 0; i < w.n; i++) mark_words(w.p + i * w.e->size, w.e); + if (vstack_n > 0) { + vec_work w = vstack[--vstack_n]; + for (i = 0; i < w.n; i++) mark_words(w.p + i * w.e->size, w.e); + } else { + map_work w = mapstack[--mapstack_n]; + for (i = 0; i < w.cap; i++) + if (w.ctrl[i] & DYN_MAP_FULL) + mark_words(w.slots + i * w.stride + w.voff, w.e); + } } } @@ -1355,7 +1456,8 @@ static void gc_sweep(void) { void *flan_dyn_env_new(int64_t size, const flan_desc *d) { flan_obj *o = gc_alloc(OBJ_ENV, size); o->len = size; - o->u.env.desc = (d != NULL && (d->n > 0 || d->nenv > 0 || d->nvec > 0)) + o->u.env.desc = (d != NULL && (d->n > 0 || d->nenv > 0 || d->nvec > 0 + || d->nmap > 0)) ? d : NULL; memset(o + 1, 0, (size_t)size); envset_put((uintptr_t)(o + 1)); @@ -1384,7 +1486,7 @@ void flan_dyn_root_push(flan_dyn *slot) { root_add(slot, NULL); } * compiler found no dyn in — but it still occupies an entry, because the count * is what the epilogue knows, and it is turned into an empty descriptor rather * than stored as NULL, which on this stack means something else. */ -static const flan_desc desc_empty = { 0, 0, NULL, 0, NULL, 0, NULL }; +static const flan_desc desc_empty = { 0, 0, NULL, 0, NULL, 0, NULL, 0, NULL }; void flan_dyn_root_push_desc(void *base, const flan_desc *d) { root_add(base, d == NULL ? &desc_empty : d); @@ -2930,6 +3032,33 @@ flan_dyn flan_dyn_at(flan_dyn v, flan_dyn i, const uint8_t *loc, return o->u.v.items[k]; } +/* (slice s lo) and (slice s lo hi) over a text; nil for [hi] is the length. + * The typed slice of a string is a view, and this is a copy: a text is + * immutable, so no program can tell the two apart. A vec's slice would have + * to share its elements with the vec to mean what the typed one means, which + * a copy does not, so a vec traps by type rather than answering differently. */ +flan_dyn flan_dyn_slice(flan_dyn v, flan_dyn lo, flan_dyn hi, + const uint8_t *loc, int64_t loclen) { + int64_t a, b, len; + flan_obj *o; + if (!is_text(v)) + trap2(loc, loclen, TYPE_TRAP, "slice", "only a text is sliced", v, lo); + o = dyn_obj(v); + len = o->len; + a = need_index(loc, loclen, "slice", v, lo); + b = flan_dyn_tag(hi) == FLAN_DYN_TAG_NIL + ? len : need_index(loc, loclen, "slice", v, hi); + if (a < 0 || b < a || b > len) { + char sv[SAY_MAX]; + say(sv, SAY_MAX, v); + flan_say(loc, loclen, + "dyn slice: [%lld %lld) is out of bounds for text of length %lld " + "— %s", (long long)a, (long long)b, (long long)len, sv); + flan_trap((const uint8_t *)"DynRange", 8); + } + return flan_dyn_from_bytes(obj_text_bytes(o) + a, b - a); +} + void flan_dyn_set_at(flan_dyn v, flan_dyn i, flan_dyn x, const uint8_t *loc, int64_t loclen) { int64_t k; diff --git a/runtime/flan_dyn.h b/runtime/flan_dyn.h index abe83d2a..7667650b 100644 --- a/runtime/flan_dyn.h +++ b/runtime/flan_dyn.h @@ -56,8 +56,11 @@ typedef uint64_t flan_dyn; * pointer-sized, holding a collector-allocated environment, null, or a * widened function's code address, told apart by the collector's own set of * environments and never by dereferencing — and [vecs], each a (Vec T) - * header at [off] whose live elements are marked through [elem]. A descriptor - * with only dyn words leaves the last four fields zero. + * header at [off] whose live elements are marked through [elem] — and + * [maps], each a (Map K V) header at [off] whose full slots' values are marked + * through [elem]; a key never holds a word the collector follows, because no + * such type is a key. A descriptor with only dyn words leaves the last six + * fields zero. * * Nothing in this ABI ever writes a descriptor. See [flan_dyn_root_push_desc] * and [flan_dyn_env_new]. */ @@ -75,6 +78,8 @@ typedef struct flan_desc { const int64_t *envs; int64_t nvec; const flan_desc_vec *vecs; + int64_t nmap; + const flan_desc_vec *maps; } flan_desc; /* ── Constructors ──────────────────────────────────────────────────── */ @@ -217,6 +222,11 @@ flan_dyn flan_dyn_len(flan_dyn v); flan_dyn flan_dyn_at(flan_dyn v, flan_dyn i, const uint8_t *loc, int64_t loclen); +/* A copy of the text's bytes [lo, hi); nil for [hi] is the length. A vec, or + * any other value, traps: see the definition. */ +flan_dyn flan_dyn_slice(flan_dyn v, flan_dyn lo, flan_dyn hi, + const uint8_t *loc, int64_t loclen); + /* Vec only — a text is immutable and says so rather than being copied. */ void flan_dyn_set_at(flan_dyn v, flan_dyn i, flan_dyn x, const uint8_t *loc, int64_t loclen); @@ -498,6 +508,10 @@ void flan_gc_set_floor(int64_t bytes); * otherwise does. */ void flan_dyn_vec_hdr_layout(int64_t out[6]); +/* flan_dyn.c's mirror of flan_map and of the block geometry the marker reads, + * compared against flan_rt.c's [flan_map_layout] the same way. */ +void flan_dyn_map_hdr_layout(int64_t out[10]); + #ifdef __cplusplus } #endif diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index b759c63a..a02103e8 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -2561,13 +2561,14 @@ void flan_vec_region_only(flan_vec *v, const uint8_t *loc, int64_t loclen) { loc, loclen); } -/* Told of every Vec block this file allocates, moves or frees: the old block - * (or NULL), the new one (or NULL), its size in bytes, and the allocator and - * epoch it was made under. NULL unless flan_dyn.c's [flan_dyn_track_vecs] has - * installed its own — a program that can make a collector-owned closure - * environment, which may sit in a Vec, installs it so the collector never - * reads a block a stale header copy still names. A pointer rather than a - * call so this file names nothing in flan_dyn.c. */ +/* Told of every Vec block and every Map block this file allocates, moves or + * frees: the old block (or NULL), the new one (or NULL), its size in bytes, + * and the allocator and epoch it was made under. NULL unless flan_dyn.c's + * [flan_dyn_track_vecs] has installed its own — a program that can make a + * collector-owned closure environment or holds a dyn, either of which may sit + * in a Vec or a Map, installs it so the collector never reads a block a stale + * header copy still names. A pointer rather than a call so this file names + * nothing in flan_dyn.c. */ void (*flan_vec_block_hook)(void *old, void *fresh, int64_t bytes, void *alloc, int64_t epoch) = NULL; @@ -2824,6 +2825,22 @@ typedef struct flan_map { int64_t epoch; } flan_map; +/* The header's layout and the block geometry's constants, for the same check + * [flan_vec_layout] exists for: flan_dyn.c restates both to walk a map's full + * slots, and test/dyn_ops.c's "layout" mode compares the two. */ +void flan_map_layout(int64_t out[10]) { + out[0] = (int64_t)sizeof(flan_map); + out[1] = (int64_t)offsetof(flan_map, data); + out[2] = (int64_t)offsetof(flan_map, len); + out[3] = (int64_t)offsetof(flan_map, log2cap); + out[4] = (int64_t)offsetof(flan_map, alloc); + out[5] = (int64_t)offsetof(flan_map, epoch); + out[6] = FLAN_MAP_HEAD; + out[7] = FLAN_MAP_GROUP; + out[8] = FLAN_MAP_ALIGN; + out[9] = FLAN_CTRL_FULL; +} + /* ── Hashing ────────────────────────────────────────────────────────── * * FNV-1a over the bytes, then a final avalanche. FNV alone leaves the low bits @@ -3339,6 +3356,10 @@ static int8_t flan_map_rebuild(flan_map *m, int64_t log2cap, int64_t ksize, a->proc(a, FLAN_ALLOC_FREE, m->data, flan_map_block_size(ksize, vsize, old_cap), 0, FLAN_MAP_ALIGN); } + if (flan_vec_block_hook) + flan_vec_block_hook(m->data, fresh.data, + flan_map_block_size(ksize, vsize, flan_map_cap(&fresh)), + m->alloc, m->epoch); m->data = fresh.data; m->log2cap = fresh.log2cap; return 1; @@ -3546,7 +3567,8 @@ int8_t flan_map_next(flan_map *m, int64_t *cursor, void *kout, void *vout, for (; i < cap; i++) { if (!(g.ctrl[i] & FLAN_CTRL_FULL)) continue; memcpy(kout, flan_map_k(&g, i), (size_t)ksize); - memcpy(vout, flan_map_v(&g, i), (size_t)vsize); + /* NULL from (map-next m cur k), the keys-only walk. */ + if (vout) memcpy(vout, flan_map_v(&g, i), (size_t)vsize); *cursor = i + 1; return 1; } @@ -3586,6 +3608,8 @@ void flan_map_free(flan_map *m, int64_t ksize, int64_t vsize, m->alloc->proc(m->alloc, FLAN_ALLOC_FREE, m->data, flan_map_block_size(ksize, vsize, flan_map_cap(m)), 0, FLAN_MAP_ALIGN); + if (m->data && flan_vec_block_hook) + flan_vec_block_hook(m->data, NULL, 0, NULL, 0); m->data = NULL; m->len = 0; m->log2cap = 0; diff --git a/spike/backend/driver.ml b/spike/backend/driver.ml deleted file mode 100644 index fde8ce49..00000000 --- a/spike/backend/driver.ml +++ /dev/null @@ -1,177 +0,0 @@ -(* The spike's harness: run the real frontend, lower the functions it produced - with [X86], put the bytes in executable memory, call them, and compare with - what the language says they should answer. - - The comparison is the whole point. Reading the bytes proves nothing -- a - disassembly that looks right and a program that returns the wrong number is - the normal outcome of hand-encoding, which is why the oracle here is the - arithmetic and not objdump. [oracle.sh] disassembles the same buffer, and - that is a debugging aid, not the evidence. *) - -external jit_alloc : int -> nativeint = "spike_jit_alloc" -external jit_write : nativeint -> string -> unit = "spike_jit_write" -external jit_protect : nativeint -> int -> unit = "spike_jit_protect" -external call1 : nativeint -> int64 -> int64 = "spike_call1" -external call2 : nativeint -> int64 -> int64 -> int64 = "spike_call2" -external sym : string -> nativeint = "spike_sym" - -let failures = ref 0 -let checks = ref 0 - -let check name got want = - incr checks; - if got = want then Printf.printf " ok %-28s = %Ld\n" name got - else begin - incr failures; - Printf.printf " FAIL %-28s = %Ld, want %Ld\n" name got want - end - -(* One page per function, so that a function that runs off its own end lands in - an unmapped page and segfaults at the fault rather than in the middle of the - next function. This is the crudest possible version of the code-object - question the whole exercise is really about. *) -let page = 4096 - -let install (code : string) : nativeint = - if String.length code > page then failwith "function exceeds one page"; - let p = jit_alloc page in - jit_write p code; - jit_protect p page; - p - -let run src = - let decls = - Flan.Load.program ~file:src (Flan.Parse.program_all (Flan.Reader.read_file src)) - in - let prog = Flan.Check.program_all decls.Flan.Load.decls in - Printf.printf "frontend: %d fns, %d globals, %d structs, %d externs\n" - (List.length prog.Flan.Tast.fns) (List.length prog.Flan.Tast.globals) - (List.length prog.Flan.Tast.structs) (List.length prog.Flan.Tast.externs); - - (* Two passes, because [spike-calls] calls functions whose addresses are not - known until they are installed. Pass one installs every function at a - fixed page; pass two emits the real code into it. A real backend does this - with relocations; the spike does it by emitting twice, which is the same - answer with none of the machinery. *) - let addrs : (string, nativeint) Hashtbl.t = Hashtbl.create 16 in - let unsupported = ref [] in - let lowerable = - List.filter - (fun (fd : Flan.Tast.fn) -> - try - ignore (X86.fn ~resolve:(fun _ -> 0L) fd); - true - with X86.Unsupported m -> - unsupported := (fd.Flan.Tast.name, m) :: !unsupported; - false) - prog.Flan.Tast.fns - in - List.iter - (fun (fd : Flan.Tast.fn) -> - Hashtbl.replace addrs fd.Flan.Tast.name (jit_alloc page)) - lowerable; - let resolve name = - match Hashtbl.find_opt addrs name with - | Some p -> Int64.of_nativeint p - | None -> - (* Not a Flan function: a runtime entry point, looked up the way a dev - build already reaches the host's symbols -- through the dynamic symbol - table, which --dev links with -rdynamic. *) - Int64.of_nativeint (sym name) - in - let bytes = Hashtbl.create 16 in - List.iter - (fun (fd : Flan.Tast.fn) -> - let code = X86.fn ~resolve fd in - Hashtbl.replace bytes fd.Flan.Tast.name code; - let p = Hashtbl.find addrs fd.Flan.Tast.name in - jit_write p code; - jit_protect p page) - lowerable; - - Printf.printf "lowered: %d of %d functions\n" - (List.length lowerable) (List.length prog.Flan.Tast.fns); - List.iter (fun (n, m) -> Printf.printf " skipped %-20s %s\n" n m) - (List.rev !unsupported); - Hashtbl.iter (fun n c -> Printf.printf " %-20s %4d bytes at %nx\n" - n (String.length c) (Hashtbl.find addrs n)) bytes; - - (* The bytes that actually ran, dumped where run.sh can objdump them. - A debugging aid and not the evidence: a disassembly that reads correctly - next to a function that answers 656 when it should answer 650 is the - normal outcome of hand-encoding, which is why the checks below compare - numbers. *) - (match Sys.getenv_opt "SPIKE_DUMP" with - | None -> () - | Some dir -> - Hashtbl.iter - (fun n c -> - let oc = open_out_bin (Filename.concat dir (n ^ ".bin")) in - output_string oc c; close_out oc) - bytes); - - (* ── The SysV boundary ────────────────────────────────────────────── - Three synthetic functions, built as Tast by hand rather than written in - Flan, because the surface language has no way to spell a call to an - arbitrary C symbol with eight arguments. [Tast.Rt] is the node a runtime - call already uses and the one a [declare-c] shim lands on, so this is the - real path with a made-up callee. *) - let loc = Flan.Loc.unknown in - let i64 = Flan.Types.Int Flan.Types.I64 in - let ex e = { Flan.Tast.e; ty = i64; loc } in - let lit n = ex (Flan.Tast.Int (Int64.of_int n, Flan.Types.I64)) in - let probe name params body = - { Flan.Tast.name; params; slots = Array.make (List.length params) i64; - snames = Array.make (List.length params) None; ret = i64; - body = [ body ]; fdefers = []; fparent = None; floc = loc } - in - let arg0 = ex (Flan.Tast.Local 0) in - let probes = [ - (* Eight integers: six in registers and two on the stack, which is the case - a register-only convention gets silently wrong. *) - probe "abi-8" [ i64 ] - (ex (Flan.Tast.Prim (Flan.Tast.Rt "spike_probe8", - [ arg0; lit 2; lit 3; lit 4; lit 5; lit 6; lit 7; lit 8 ]))); - (* rsp % 16 == 0 at the call. The callee does an aligned 16-byte spill and - answers -1 if it was entered misaligned. *) - probe "abi-align" [ i64 ] - (ex (Flan.Tast.Prim (Flan.Tast.Rt "spike_probe_align", [ arg0 ]))); - (* The same call, but underneath a binary operator -- so it is evaluated - with the left operand spilled on the stack. This is the one that matters: - alignment at a call site is not a property of the prologue, it is a - property of how much the expression evaluator has pushed. *) - probe "abi-align-nested" [ i64 ] - (ex (Flan.Tast.Prim (Flan.Tast.Add, - [ lit 0; - ex (Flan.Tast.Prim (Flan.Tast.Rt "spike_probe_align", [ arg0 ])) ]))); - ] in - List.iter - (fun (fd : Flan.Tast.fn) -> - let code = X86.fn ~resolve fd in - let p = jit_alloc page in - jit_write p code; jit_protect p page; - Hashtbl.replace addrs fd.Flan.Tast.name p) - probes; - - print_endline "results:"; - let at n = Hashtbl.find addrs n in - check "spike-add 3 4" (call2 (at "spike-add") 3L 4L) 7L; - check "spike-add -5 2" (call2 (at "spike-add") (-5L) 2L) (-3L); - check "spike-arith 10 4" (call2 (at "spike-arith") 10L 4L) 19L; - check "spike-let 6" (call1 (at "spike-let") 6L) 1332L; - check "spike-if 1 2" (call2 (at "spike-if") 1L 2L) 1L; - check "spike-if 9 2" (call2 (at "spike-if") 9L 2L) 7L; - check "spike-calls 5" (call1 (at "spike-calls") 5L) 656L; - check "abi-8 1" (call1 (at "abi-8") 1L) 87654321L; - check "abi-align 10" (call1 (at "abi-align") 10L) 13L; - check "abi-align-nested 10" (call1 (at "abi-align-nested") 10L) 13L; - - Printf.printf "\n%d checks, %d failures\n" !checks !failures; - exit (if !failures = 0 then 0 else 1) - -(* The frontend's diagnostics printed rather than swallowed: a spike that says - [Fatal error: exception Errors(_)] costs an hour. *) -let () = - try run Sys.argv.(1) with - | Flan.Loc.Error d -> prerr_endline (Flan.Loc.report d); exit 2 - | Flan.Loc.Errors ds -> prerr_endline (Flan.Loc.report_all ds); exit 2 diff --git a/spike/backend/hist.ml b/spike/backend/hist.ml deleted file mode 100644 index b8d05ea1..00000000 --- a/spike/backend/hist.ml +++ /dev/null @@ -1,87 +0,0 @@ -(* Histogram of Tast expr_kind constructors over the reachable program. A - measurement, not a backend: it answers "what would a whole-program x86 - build actually have to lower for this input", which is the question that - decides whether whole-program coverage is reachable at all. *) -let tbl : (string, int) Hashtbl.t = Hashtbl.create 64 - -let bump k = - Hashtbl.replace tbl k (1 + (try Hashtbl.find tbl k with Not_found -> 0)) - -let name (k : Flan.Tast.expr_kind) = - match k with - | Int _ -> "Int" | Float _ -> "Float" | Bool _ -> "Bool" | Str _ -> "Str" - | Unit -> "Unit" | Zero _ -> "Zero" | Uninit _ -> "Uninit" - | Local _ -> "Local" | Global _ -> "Global" | Prim _ -> "Prim" - | Call _ -> "Call" | FnAddr _ -> "FnAddr" | CallPtr _ -> "CallPtr" - | Do _ -> "Do" | Let _ -> "Let" | If _ -> "If" | While _ -> "While" - | Return _ -> "Return" | Break _ -> "Break" | Continue _ -> "Continue" - | Set _ -> "Set" | Field _ -> "Field" | Addr _ -> "Addr" | Deref _ -> "Deref" - | Make _ -> "Make" | MakeCase _ -> "MakeCase" | CaseField _ -> "CaseField" - | Arr _ -> "Arr" | Some_ _ -> "Some" | None_ -> "None" | Match _ -> "Match" - | UnwrapSome _ -> "UnwrapSome" | Signal _ -> "Signal" | Handled _ -> "Handled" - | RestartCase _ -> "RestartCase" | WithAlloc _ -> "WithAlloc" - | InvokeRestart _ -> "InvokeRestart" - -let pname (p : Flan.Tast.prim) = - match p with - | Add -> "Add" | Sub -> "Sub" | Mul -> "Mul" | Div -> "Div" | Rem -> "Rem" - | Eq -> "Eq" | Ne -> "Ne" | Lt -> "Lt" | Le -> "Le" | Gt -> "Gt" | Ge -> "Ge" - | Not -> "Not" | BitAnd -> "BitAnd" | BitOr -> "BitOr" | BitXor -> "BitXor" - | Shl -> "Shl" | Shr -> "Shr" | Len -> "Len" | At -> "At" | Slice -> "Slice" - | Bytes -> "Bytes" | BytesToF64 -> "BytesToF64" | BytesToI64 -> "BytesToI64" - | F64ToBytes -> "F64ToBytes" | I64ToBytes -> "I64ToBytes" - | StrOfBytes -> "StrOfBytes" | U64ToBytes -> "U64ToBytes" - | EscapeBytes -> "EscapeBytes" | WriteStdout -> "WriteStdout" | Exit -> "Exit" - | Argv -> "Argv" | Rt s -> "Rt:" ^ s | SizeOf _ -> "SizeOf" - | AlignOf _ -> "AlignOf" | AddrOf -> "AddrOf" | Cast _ -> "Cast" - -let rec ex (e : Flan.Tast.expr) = - bump (name e.e); - match e.e with - | Prim (p, xs) -> bump ("prim/" ^ pname p); List.iter ex xs - | Call (_, xs) | Arr xs -> List.iter ex xs - | Make (_, xs) | MakeCase (_, _, xs) -> List.iter ex xs - | CallPtr (f, xs) -> ex f; List.iter ex xs - | Do xs | Handled (_, xs) -> List.iter ex xs - | Let (bs, body) -> List.iter (fun (_, x) -> ex x) bs; List.iter ex body - | If (a, b, c) -> ex a; ex b; ex c - | While (c, b, l) -> ex c; List.iter ex b; List.iter ex l - | Return (Some x) | Some_ x | Deref x | UnwrapSome x | Field (x, _) - | CaseField (x, _, _) | Signal (_, _, x) -> ex x - | Set (p, x) -> pl p; ex x - | Addr p -> pl p - | Match (x, arms) -> - ex x; - List.iter (fun (a : Flan.Tast.arm) -> List.iter ex a.abody) arms - | RestartCase (cs, x) -> - List.iter (fun (c : Flan.Tast.rclause) -> List.iter ex c.rbody) cs; ex x - | WithAlloc (a, b) -> ex a; List.iter ex b - | InvokeRestart (_, _, xs, _, _, _) -> List.iter ex xs - | _ -> () - -and pl (p : Flan.Tast.place) = - match p with - | Plocal _ -> bump "place/Plocal" - | Pglobal _ -> bump "place/Pglobal" - | Pfield (x, _) -> bump "place/Pfield"; ex x - | Pindex (x, ys) -> bump "place/Pindex"; ex x; List.iter ex ys - | Pderef x -> bump "place/Pderef"; ex x - -let () = - let src = Sys.argv.(1) in - let l = - Flan.Load.program ~file:src - (Flan.Parse.program_all (Flan.Reader.read_file src)) - in - let p = Flan.Check.program_all l.Flan.Load.decls in - let p, _, _ = Flan.Reach.link l p in - List.iter - (fun (f : Flan.Tast.fn) -> List.iter ex f.body; List.iter ex f.fdefers) - p.Flan.Tast.fns; - List.iter (fun (g : Flan.Tast.global) -> ex g.Flan.Tast.ginit) - p.Flan.Tast.globals; - Printf.printf "%s: %d reachable fns\n" (Filename.basename src) - (List.length p.Flan.Tast.fns); - let rows = Hashtbl.fold (fun k v a -> (k, v) :: a) tbl [] in - let rows = List.sort (fun (a, _) (b, _) -> compare a b) rows in - List.iter (fun (k, v) -> Printf.printf " %-24s %d\n" k v) rows diff --git a/spike/backend/jit_stubs.c b/spike/backend/jit_stubs.c deleted file mode 100644 index 04f78441..00000000 --- a/spike/backend/jit_stubs.c +++ /dev/null @@ -1,100 +0,0 @@ -/* The three things OCaml cannot do for itself: get executable memory, put - * bytes in it, and jump to them. Everything interesting is in x86.ml; this - * file is deliberately dumb. - * - * Shaped after lib/dynload_stubs.c's rule, which spike/embed took verbatim for - * the same reason: the boundary passes pointers and scalars, never an OCaml - * [value] into foreign storage. Nothing here keeps anything. - * - * RW then mprotect to R+X, never RWX in one mmap: a hardened kernel may refuse - * a writable-executable anonymous mapping outright, and a policy denial that - * comes back as a null pointer reads exactly like an encoding bug. */ - -#include -#include -#include -#include - -#include -#include -#include -#include -#include - -value spike_jit_alloc(value vlen) { - size_t len = (size_t)Long_val(vlen); - void *p = mmap(NULL, len, PROT_READ | PROT_WRITE, - MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); - if (p == MAP_FAILED) caml_failwith("spike_jit_alloc: mmap failed"); - return caml_copy_nativeint((intnat)p); -} - -value spike_jit_write(value vp, value vbytes) { - char *p = (char *)Nativeint_val(vp); - memcpy(p, String_val(vbytes), caml_string_length(vbytes)); - return Val_unit; -} - -value spike_jit_protect(value vp, value vlen) { - void *p = (void *)Nativeint_val(vp); - if (mprotect(p, (size_t)Long_val(vlen), PROT_READ | PROT_EXEC) != 0) - caml_failwith("spike_jit_protect: mprotect failed"); - return Val_unit; -} - -/* Every Flan function's emitted signature is its parameters followed by the - * transfer channel (emit.ml, [signature]), so the trampolines below all pass a - * trailing pointer. Nothing in the spike transfers, so it is NULL. */ -typedef int64_t (*fn1)(int64_t, void *); -typedef int64_t (*fn2)(int64_t, int64_t, void *); - -value spike_call1(value vp, value a) { - return caml_copy_int64(((fn1)Nativeint_val(vp))(Int64_val(a), NULL)); -} -value spike_call2(value vp, value a, value b) { - return caml_copy_int64(((fn2)Nativeint_val(vp))(Int64_val(a), Int64_val(b), NULL)); -} - -value spike_sym(value vname) { - void *h = dlsym(RTLD_DEFAULT, String_val(vname)); - if (h == NULL) caml_failwith("spike_sym: not found"); - return caml_copy_nativeint((intnat)h); -} - -/* ── The C side of the ABI probes ──────────────────────────────────── */ - -/* Eight integers: six in registers, two on the stack, which is the case a - * register-only convention silently gets wrong. The answer is positional so a - * swapped pair cannot pass. */ -int64_t spike_probe8(int64_t a, int64_t b, int64_t c, int64_t d, - int64_t e, int64_t f, int64_t g, int64_t h) { - return a * 1 + b * 10 + c * 100 + d * 1000 + e * 10000 + f * 100000 - + g * 1000000 + h * 10000000; -} - -/* The alignment check, and it has to be done with an aligned load rather than - * by reading rsp, because that is how raylib finds out: the SysV ABI promises - * rsp % 16 == 0 at the call instruction, so on entry rsp+8 is aligned, and a - * callee that spills an __m128 to its frame faults when it is not. -O2 is what - * turns this into an actual movaps; without it the bug hides. */ -__attribute__((noinline)) -int64_t spike_probe_align(int64_t x) { - volatile double v[2] __attribute__((aligned(16))) = { 1.0, 2.0 }; - /* Reading rsp as well, so a failure says which of the two it was. */ - uintptr_t sp; - __asm__ volatile ("mov %%rsp, %0" : "=r"(sp)); - if ((sp % 16) != 8) return -1; /* entry rsp is call-site rsp minus 8 */ - return x + (int64_t)(v[0] + v[1]); -} - -/* No float probe either, for a plainer reason: this emitter has no SSE, so - * there is nothing here that could call one. Floats are counted as work in - * docs/BUILT.md, "Layout was already owned, and that is why the drift fear - * was misplaced", rather than claimed as done. - * - * And no struct-by-value probe, and that is a finding rather than an - * omission: check.ml rejects an aggregate in a [declare] signature and the - * generated shim flattens every one, so no Flan-emitted call ever passes a - * struct to C. The aggregate problem is real but it is on the Flan-to-Flan - * side, which is measured in docs/BUILT.md, "The obstacle that was named - * first, and dissolved", and not from here. */ diff --git a/spike/backend/probe.flan b/spike/backend/probe.flan deleted file mode 100644 index 0fab0e65..00000000 --- a/spike/backend/probe.flan +++ /dev/null @@ -1,24 +0,0 @@ -;; The spike's input. Ordinary Flan, run through the ordinary frontend -- -;; Reader, Parse, Load, Check -- so that what the emitter below lowers is the -;; same Tast.fn the LLVM backend gets and not a literal someone typed to make -;; the exercise come out. - -(defn spike-add [a i64 b i64] i64 - (+ a b)) - -(defn spike-arith [a i64 b i64] i64 - (- (* a 3) (+ b 7))) - -(defn spike-let [a i64] i64 - (let [x (* a a) - y (+ x 1)] - (* x y))) - -(defn spike-if [a i64 b i64] i64 - (if (< a b) (- b a) (- a b))) - -(defn spike-calls [a i64] i64 - (spike-add (spike-arith a 2) (spike-let a))) - -(defn main [] i32 - 0) diff --git a/spike/backend/run.sh b/spike/backend/run.sh deleted file mode 100644 index bdef39bc..00000000 --- a/spike/backend/run.sh +++ /dev/null @@ -1,48 +0,0 @@ -#!/usr/bin/env bash -# The spike, end to end: the real frontend produces a Tast, x86.ml turns it -# into bytes, the bytes go into an mmap, and the mmap gets called. -# -# Driven by hand with ocamlfind and clang against the flan.cmxa dune already -# builds, exactly as spike/embed does and for the same reason: nothing under -# spike/ is wired into the build, so there is no dune file here and `dune test` -# cannot see any of it. -set -u -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -cd "$root" || exit 1 - -dune build --root . lib/flan.cmxa 2>&1 | head -20 - -out=$(mktemp -d); trap 'rm -rf "$out"' EXIT - -# The C stubs. -O2 on purpose: spike_probe_align's aligned load only becomes a -# real movaps with optimisation on, and an alignment bug that only shows up in -# a release build is the one this is looking for. -clang -O2 -c -I"$(ocamlopt -where)" "$here/jit_stubs.c" -o "$out/jit_stubs.o" || exit 1 - -ocamlfind ocamlopt -thread -package unix,threads.posix -linkpkg \ - -I "$root/_build/default/lib/.flan.objs/byte" \ - -I "$root/_build/default/lib/.flan.objs/native" \ - -I "$out" -I "$here" \ - -o "$out/spike" \ - "$root/_build/default/lib/flan.cmxa" \ - -cclib -rdynamic -ccopt -L"$root/_build/default/lib" \ - "$out/jit_stubs.o" \ - "$here/x86.ml" "$here/driver.ml" 2>&1 | head -40 - -test -x "$out/spike" || { echo "build failed"; exit 1; } - -SPIKE_DUMP=$out "$out/spike" "$here/probe.flan" -rc=$? - -# Disassembly on request. objdump over the raw buffer, which is what to reach -# for when a function answers the wrong number -- not what proves it answers -# the right one. -if [ "${SPIKE_DISASM:-}" = 1 ]; then - for f in "$out"/*.bin; do - echo; echo "== $(basename "$f" .bin)" - objdump -D -b binary -m i386:x86-64 -M intel "$f" | tail -n +7 - done -fi -echo "exit: $rc" -exit $rc diff --git a/spike/backend/x86.ml b/spike/backend/x86.ml deleted file mode 100644 index 9f486fed..00000000 --- a/spike/backend/x86.ml +++ /dev/null @@ -1,379 +0,0 @@ -(* A spike: Tast -> x86-64 machine code, in memory, called. Not a backend. - The point is to find out what breaks, so the subset is deliberately tiny - and every case it cannot do raises with the node that defeated it -- an - honest [Unsupported] is the measurement, and a silently wrong answer is - the one outcome that would waste the exercise. - - Register allocation is the trivial one the brief allows: every slot is a - stack slot at [rbp - 8*(i+1)], every value is computed into rax, and a - binary operator pushes its left operand. Two registers are enough for - everything below and nothing is kept live across a statement. That is what - makes an instruction selector tractable in an afternoon; it is also why the - code it produces is four times the size of clang -O0's. - - Conventions, all of them SysV's, because raylib is called from this code: - - integer arguments in rdi rsi rdx rcx r8 r9, then right-to-left on the - stack; integer result in rax. - - rsp % 16 == 0 at the [call] instruction. raylib spills xmm registers - with movaps and faults far from the cause when this is wrong. - - rbx rbp r12-r15 are callee-saved. This emitter touches none of them - except rbp, which it saves. - - every Flan function takes the transfer channel as a trailing ptr - (emit.ml, [signature]), so a Flan function of n parameters is an n+1 - argument C function. *) - -exception Unsupported of string - -let unsupported fmt = Printf.ksprintf (fun s -> raise (Unsupported s)) fmt - -(* ── Bytes ───────────────────────────────────────────────────────────── *) - -type buf = { mutable bytes : Buffer.t } - -let create () = { bytes = Buffer.create 256 } -let len b = Buffer.length b.bytes -let contents b = Buffer.contents b.bytes -let u8 b n = Buffer.add_char b.bytes (Char.chr (n land 0xff)) - -let u32 b n = - for i = 0 to 3 do u8 b ((n asr (i * 8)) land 0xff) done - -let i32 b (n : int) = - if n < -0x80000000 || n > 0x7fffffff then unsupported "displacement %d" n; - u32 b n - -let u64 b (n : int64) = - for i = 0 to 7 do - u8 b (Int64.to_int (Int64.logand (Int64.shift_right_logical n (i * 8)) 0xffL)) - done - -(* ── Registers and modrm ─────────────────────────────────────────────── *) - -(* The encoding order, not the ABI order: this numbering *is* the three bits - the modrm byte wants, which is why rsp is 4 and rbp is 5 rather than - anything more memorable. *) -let rax = 0 and rcx = 1 and rdx = 2 and _rbx = 3 -let rsp = 4 and rbp = 5 and rsi = 6 and rdi = 7 -let r8 = 8 and r9 = 9 - -(* REX.W is always set: everything here is 64-bit. R extends the reg field and - B the r/m field, which is the whole of what r8-r15 need. *) -let rex b ~r ~m = u8 b (0x48 lor (if r >= 8 then 4 else 0) lor (if m >= 8 then 1 else 0)) -let modrm b ~md ~r ~m = u8 b ((md lsl 6) lor ((r land 7) lsl 3) lor (m land 7)) - -(* reg, reg *) -let rr b op ~r ~m = rex b ~r ~m; u8 b op; modrm b ~md:3 ~r ~m - -(* reg, [rbp + disp32]. Always disp32 rather than the shorter disp8 form: a - frame can outgrow 128 bytes and a one-byte displacement that silently wraps - is exactly the bug this spike would not find. *) -let rm_rbp b op ~r ~disp = - rex b ~r ~m:rbp; u8 b op; modrm b ~md:2 ~r ~m:rbp; i32 b disp - -let mov_rr b ~dst ~src = rr b 0x89 ~r:src ~m:dst (* mov dst, src *) -let mov_load b ~dst ~disp = rm_rbp b 0x8b ~r:dst ~disp (* mov dst, [rbp+d] *) -let mov_store b ~src ~disp = rm_rbp b 0x89 ~r:src ~disp (* mov [rbp+d], src *) - -let movabs b ~dst (n : int64) = - rex b ~r:0 ~m:dst; u8 b (0xb8 lor (dst land 7)); u64 b n - -let push b r = if r >= 8 then u8 b 0x41; u8 b (0x50 lor (r land 7)) -let pop b r = if r >= 8 then u8 b 0x41; u8 b (0x58 lor (r land 7)) - -let add_rr b ~dst ~src = rr b 0x01 ~r:src ~m:dst -let sub_rr b ~dst ~src = rr b 0x29 ~r:src ~m:dst -let and_rr b ~dst ~src = rr b 0x21 ~r:src ~m:dst -let or_rr b ~dst ~src = rr b 0x09 ~r:src ~m:dst -let xor_rr b ~dst ~src = rr b 0x31 ~r:src ~m:dst -let imul_rr b ~dst ~src = (* 0f af /r *) - rex b ~r:dst ~m:src; u8 b 0x0f; u8 b 0xaf; modrm b ~md:3 ~r:dst ~m:src -let cmp_rr b ~a ~bb = rr b 0x39 ~r:bb ~m:a (* cmp a, b *) - -let add_imm32 b ~dst n = rex b ~r:0 ~m:dst; u8 b 0x81; modrm b ~md:3 ~r:0 ~m:dst; i32 b n -let sub_imm32 b ~dst n = rex b ~r:0 ~m:dst; u8 b 0x81; modrm b ~md:3 ~r:5 ~m:dst; i32 b n - -let call_r b r = if r >= 8 then u8 b 0x41; u8 b 0xff; modrm b ~md:3 ~r:2 ~m:r -let leave b = u8 b 0xc9 -let ret b = u8 b 0xc3 -let ud2 b = u8 b 0x0f; u8 b 0x0b - -(* setcc al, then movzx rax, al -- a compare's result is a bool, which is one - byte in Flan's layout (i1 in LLVM, and the ABI zero-extends it). *) -let setcc b cc = u8 b 0x0f; u8 b (0x90 lor cc); modrm b ~md:3 ~r:0 ~m:rax -let movzx_al b = u8 b 0x48; u8 b 0x0f; u8 b 0xb6; modrm b ~md:3 ~r:rax ~m:rax - -(* jcc rel32 and jmp rel32, patched once the target is known. *) -let jcc b cc = u8 b 0x0f; u8 b (0x80 lor cc); let at = len b in u32 b 0; at -let jmp b = u8 b 0xe9; let at = len b in u32 b 0; at - -let patch b ~at ~target = - let rel = target - (at + 4) in - let s = Buffer.contents b.bytes in - let s = Bytes.of_string s in - for i = 0 to 3 do - Bytes.set s (at + i) (Char.chr ((rel asr (i * 8)) land 0xff)) - done; - let nb = Buffer.create (Bytes.length s) in - Buffer.add_bytes nb s; - b.bytes <- nb - -(* ── Lowering ────────────────────────────────────────────────────────── *) - -type fnctx = { - b : buf; - nslots : int; - (* How many 8-byte words this expression's evaluation has pushed since the - prologue. rsp is 16-aligned at the end of the prologue, so [depth] even - means rsp is aligned and [depth] odd means it is 8 out. - - This counter is the answer to the one bug the ABI probe found. Alignment - is not a property of the prologue: the evaluator spills the left operand - across the right one's evaluation, so a call written in the right operand - runs with one word outstanding. Deriving it from a count kept here is the - only way that stays correct as the evaluator grows cases, and it is what - clang's [sub rsp, 8] before a call is doing. *) - mutable depth : int; - (* A symbol the code calls, resolved to an absolute address by the driver - before emission. movabs + call r is what a JIT does anyway: a rel32 call - cannot reach an arbitrary mmap, and the 2-byte indirect call is cheaper - than the relocation machinery a real backend would grow here. *) - resolve : string -> int64; -} - -let slot_disp i = -8 * (i + 1) - -(* Every stack movement goes through these two, so that nothing can move rsp - without the counter noticing. *) -let pushv f r = push f.b r; f.depth <- f.depth + 1 -let popv f r = pop f.b r; f.depth <- f.depth - 1 - -(* Every type this spike handles is one 8-byte integer register. Everything - else is the real backend's problem and is enumerated in the verdict rather - than guessed at here. *) -let word_ty (t : Flan.Types.t) = - match t with - | Flan.Types.Int _ | Flan.Types.Bool | Flan.Types.Ptr _ -> true - | _ -> false - -let check_word what (t : Flan.Types.t) = - if not (word_ty t) then - unsupported "%s of type %s: not a single integer register" what - (Flan.Types.to_string t) - -let cc_of signed (p : Flan.Tast.prim) = - match p, signed with - | Flan.Tast.Eq, _ -> 0x4 | Flan.Tast.Ne, _ -> 0x5 - | Flan.Tast.Lt, true -> 0xc | Flan.Tast.Lt, false -> 0x2 - | Flan.Tast.Le, true -> 0xe | Flan.Tast.Le, false -> 0x6 - | Flan.Tast.Gt, true -> 0xf | Flan.Tast.Gt, false -> 0x7 - | Flan.Tast.Ge, true -> 0xd | Flan.Tast.Ge, false -> 0x3 - | _ -> assert false - -let arg_regs = [| rdi; rsi; rdx; rcx; r8; r9 |] - -(* Value into rax. Everything is a subexpression of something that will - immediately consume rax, so nothing is kept live and no allocator is - needed. *) -let rec value f (e : Flan.Tast.expr) : unit = - let b = f.b in - match e.Flan.Tast.e with - | Flan.Tast.Int (n, _) -> movabs b ~dst:rax n - | Flan.Tast.Bool v -> movabs b ~dst:rax (if v then 1L else 0L) - | Flan.Tast.Local i -> - check_word "local" e.Flan.Tast.ty; - if i >= f.nslots then unsupported "slot %d out of range" i; - mov_load b ~dst:rax ~disp:(slot_disp i) - | Flan.Tast.Do body -> block f body - | Flan.Tast.Let (binds, body) -> - List.iter - (fun (i, e) -> - value f e; - check_word "binding" e.Flan.Tast.ty; - mov_store b ~src:rax ~disp:(slot_disp i)) - binds; - block f body - | Flan.Tast.Set (Flan.Tast.Plocal i, rhs) -> - value f rhs; - check_word "assignment" rhs.Flan.Tast.ty; - mov_store b ~src:rax ~disp:(slot_disp i) - | Flan.Tast.If (c, t, e') -> emit_if f c t e' - | Flan.Tast.Return (Some x) -> - value f x; - leave b; ret b - | Flan.Tast.Return None -> leave b; ret b - | Flan.Tast.Prim (p, args) -> prim f e p args - | Flan.Tast.Call (name, args) -> call f (f.resolve name) args ~xfer:true - | Flan.Tast.Unit -> () - | k -> unsupported "expression: %s" (node_name k) - -and block f body = - match body with - | [] -> () - | [ last ] -> value f last - | x :: rest -> value f x; block f rest - -and prim f e (p : Flan.Tast.prim) args = - let b = f.b in - match p, args with - | (Flan.Tast.Add | Flan.Tast.Sub | Flan.Tast.Mul - | Flan.Tast.BitAnd | Flan.Tast.BitOr | Flan.Tast.BitXor), [ x; y ] -> - check_word "arithmetic" x.Flan.Tast.ty; - binop f x y; - (* left in rax, right in rcx *) - (match p with - | Flan.Tast.Add -> add_rr b ~dst:rax ~src:rcx - | Flan.Tast.Sub -> sub_rr b ~dst:rax ~src:rcx - | Flan.Tast.Mul -> imul_rr b ~dst:rax ~src:rcx - | Flan.Tast.BitAnd -> and_rr b ~dst:rax ~src:rcx - | Flan.Tast.BitOr -> or_rr b ~dst:rax ~src:rcx - | _ -> xor_rr b ~dst:rax ~src:rcx) - | (Flan.Tast.Eq | Flan.Tast.Ne | Flan.Tast.Lt | Flan.Tast.Le - | Flan.Tast.Gt | Flan.Tast.Ge), [ x; y ] -> - let signed = - match x.Flan.Tast.ty with - | Flan.Types.Int k -> Flan.Types.signed k - | Flan.Types.Bool -> false - | t -> unsupported "comparison on %s" (Flan.Types.to_string t) - in - binop f x y; - cmp_rr b ~a:rax ~bb:rcx; - setcc b (cc_of signed p); - movzx_al b - | Flan.Tast.Rt sym, args -> call f (f.resolve sym) args ~xfer:false - | _ -> unsupported "primitive in %s" (Flan.Types.to_string e.Flan.Tast.ty) - -(* Left into rax, right into rcx, with the left spilled across the right's - evaluation. Left-to-right, which emit.ml's [map_lr] is explicit about being - required rather than a preference -- a call in either operand has effects. - The push/pop pair keeps rsp 16-aligned in pairs, which matters only because - [call] below re-derives alignment from a counter rather than tracking rsp. *) -and binop f x y = - let b = f.b in - value f x; - pushv f rax; - value f y; - mov_rr b ~dst:rcx ~src:rax; - popv f rax - -and emit_if f c t e = - let b = f.b in - value f c; - (* cmp rax, 0: 48 83 f8 00 -- written out because the helper above takes - registers only and a zero-compare is the one immediate form worth having. *) - u8 b 0x48; u8 b 0x83; modrm b ~md:3 ~r:7 ~m:rax; u8 b 0x00; - let to_else = jcc b 0x4 in (* je *) - value f t; - let to_end = jmp b in - patch b ~at:to_else ~target:(len b); - value f e; - patch b ~at:to_end ~target:(len b) - -(* A call, and this is the part that has to be exactly right. - - [xfer] appends the transfer channel, which every Flan function's signature - carries and a C entry point does not. The spike passes NULL: nothing here - signals, and a real backend would pass the caller's own channel pointer. - - Alignment: rsp is 16-aligned at function entry minus the 8 the [call] - pushed, so after [push rbp] it is aligned again, and the frame is rounded to - a multiple of 16. Every push here is paired with a pop before the next call - can happen, so rsp is aligned at every call site by construction. Stack - arguments are pushed in pairs to keep it that way -- an odd count gets a - dummy push, which is what clang's [sub rsp, 8] is doing when you see it. *) -and call f (addr : int64) args ~xfer = - let b = f.b in - let n = List.length args + (if xfer then 1 else 0) in - (* Bring rsp to 16 first, so everything below can count in pairs. *) - let pad = f.depth land 1 = 1 in - if pad then (sub_imm32 b ~dst:rsp 8; f.depth <- f.depth + 1); - let stacked = List.filteri (fun i _ -> i >= 6) args in - let nstack = List.length stacked + (if xfer && n > 6 then 1 else 0) in - (* The stack half, evaluated right to left so that the seventh argument ends - up at [rsp] and the eighth above it. The transfer channel is the last - argument of all, so it is pushed first. *) - if nstack land 1 = 1 then (sub_imm32 b ~dst:rsp 8; f.depth <- f.depth + 1); - if xfer && n > 6 then (movabs b ~dst:rax 0L; pushv f rax); - List.iter (fun a -> value f a; pushv f rax) (List.rev stacked); - (* The register half needs a spill of its own: rdi..r9 are argument registers - and rax is where every value lands, so an earlier argument would be - clobbered by a later one's evaluation. Push each, then pop them into their - registers in reverse. *) - let inreg = List.filteri (fun i _ -> i < 6) args in - List.iter (fun a -> value f a; pushv f rax) inreg; - let nreg = List.length inreg in - List.iteri (fun i _ -> popv f arg_regs.(nreg - 1 - i)) inreg; - if xfer && n <= 6 then movabs b ~dst:arg_regs.(nreg) 0L; - (* al = the number of vector registers used. Required only for a variadic - callee and set unconditionally because it is two bytes: a wrong al on a - printf-shaped entry point -- raylib's TraceLog is one -- is a crash that - looks like anything else. After the argument registers, since al is rax's - low byte. *) - u8 b 0xb0; u8 b 0x00; (* mov al, 0 *) - (* r11 always, never r9: r11 is the scratch register SysV reserves and is the - one register guaranteed not to be carrying an argument. Choosing the - target conditionally is how a six-argument call gets quietly wrong. *) - u8 b 0x49; u8 b 0xbb; u64 b addr; (* movabs r11, addr *) - assert (f.depth land 1 = 0); - call_r b 11; - let back = 8 * (nstack + (nstack land 1)) in - if back > 0 then (add_imm32 b ~dst:rsp back; f.depth <- f.depth - (back / 8)); - if pad then (add_imm32 b ~dst:rsp 8; f.depth <- f.depth - 1) - -and node_name (k : Flan.Tast.expr_kind) = - match k with - | Flan.Tast.Int _ -> "Int" | Flan.Tast.Float _ -> "Float" - | Flan.Tast.Bool _ -> "Bool" | Flan.Tast.Str _ -> "Str" - | Flan.Tast.Unit -> "Unit" | Flan.Tast.Zero _ -> "Zero" - | Flan.Tast.Uninit _ -> "Uninit" | Flan.Tast.Local _ -> "Local" - | Flan.Tast.Global _ -> "Global" | Flan.Tast.Prim _ -> "Prim" - | Flan.Tast.Call _ -> "Call" | Flan.Tast.FnAddr _ -> "FnAddr" - | Flan.Tast.CallPtr _ -> "CallPtr" | Flan.Tast.Do _ -> "Do" - | Flan.Tast.Let _ -> "Let" | Flan.Tast.If _ -> "If" - | Flan.Tast.While _ -> "While" | Flan.Tast.Return _ -> "Return" - | Flan.Tast.Break _ -> "Break" | Flan.Tast.Continue _ -> "Continue" - | Flan.Tast.Set _ -> "Set" | Flan.Tast.Field _ -> "Field" - | Flan.Tast.Addr _ -> "Addr" | Flan.Tast.Deref _ -> "Deref" - | Flan.Tast.Make _ -> "Make" | Flan.Tast.MakeCase _ -> "MakeCase" - | Flan.Tast.CaseField _ -> "CaseField" | Flan.Tast.Arr _ -> "Arr" - | Flan.Tast.Some_ _ -> "Some" | Flan.Tast.None_ -> "None" - | Flan.Tast.Match _ -> "Match" | Flan.Tast.UnwrapSome _ -> "UnwrapSome" - | Flan.Tast.Signal _ -> "Signal" | Flan.Tast.Handled _ -> "Handled" - | Flan.Tast.RestartCase _ -> "RestartCase" - | Flan.Tast.WithAlloc _ -> "WithAlloc" - | Flan.Tast.InvokeRestart _ -> "InvokeRestart" - -(* ── A whole function ────────────────────────────────────────────────── *) - -let fn ~resolve (fd : Flan.Tast.fn) : string = - let b = create () in - let nslots = Array.length fd.Flan.Tast.slots in - let f = { b; nslots; resolve; depth = 0 } in - push b rbp; - mov_rr b ~dst:rbp ~src:rsp; - (* Round the frame to 16 so that rsp is aligned at every call site. One - extra word for the transfer channel's slot, which is not a Flan slot and - has no index -- the spike never reads it, but a real backend must, and - leaving no room for it is the kind of thing that is cheap now and - expensive later. *) - let frame = (nslots + 1) * 8 in - let frame = (frame + 15) land lnot 15 in - if frame > 0 then sub_imm32 b ~dst:rsp frame; - (* Parameters arrive in registers and are stored into their slots at once, - which is also emit.ml's rule: slots 0..n-1 are the parameters, in order. *) - let np = List.length fd.Flan.Tast.params in - if np > 6 then unsupported "more than six parameters"; - List.iteri - (fun i ty -> - check_word "parameter" ty; - mov_store b ~src:arg_regs.(i) ~disp:(slot_disp i)) - fd.Flan.Tast.params; - (* The transfer channel is the last argument and goes just past the slots. *) - if np < 6 then mov_store b ~src:arg_regs.(np) ~disp:(slot_disp nslots); - block f fd.Flan.Tast.body; - leave b; ret b; - (* Anything that falls off the end of a Never-returning body lands here and - traps rather than running into the next function. LLVM's [unreachable] is - undefined behaviour; ud2 is a defined SIGILL, and the difference is one of - the audit's findings. *) - ud2 b; - contents b diff --git a/spike/embed/.gitignore b/spike/embed/.gitignore deleted file mode 100644 index 441349b2..00000000 --- a/spike/embed/.gitignore +++ /dev/null @@ -1,14 +0,0 @@ -# Spike artifacts. run.sh rebuilds all of them from the sources beside it. -*.o -*.cmi -*.cmx -baseline -spike1 -spike2 -spike3 -spike4 -spike5 -spike6 -spike5b -spike5b_std -stubs5b.o diff --git a/spike/embed/baseline.c b/spike/embed/baseline.c deleted file mode 100644 index 4c181ae7..00000000 --- a/spike/embed/baseline.c +++ /dev/null @@ -1,4 +0,0 @@ -/* The floor: what a C binary with no OCaml in it weighs, so the delta the dev - build actually pays can be stated honestly. */ -#include -int main(void) { printf("baseline\n"); return 0; } diff --git a/spike/embed/dynload_stubs.c b/spike/embed/dynload_stubs.c deleted file mode 100644 index e32add72..00000000 --- a/spike/embed/dynload_stubs.c +++ /dev/null @@ -1,149 +0,0 @@ -/* Loading a compiled macro into the compiler's own process. - * - * TODO.org, "The expander design: running a macro means dlopening it": there - * is no interpreter, so running a macro means - * compiling it and dlopening it. The reload primitive does exactly this - * already, but its host is a running Flan program written in C; here the host - * is the OCaml compiler, which has no dlopen of its own -- Dynlink loads - * OCaml, not ELF. So the boundary needs stubs, and this is all of them. - * - * Two rules shape what is here: - * - * - Nothing but pointers and scalars crosses. A Flan `string`/slice is - * {ptr,len} and a `Form` is {i32, [2 x i64]}, and LLVM's calling - * convention for an aggregate passed or returned *by value* in hand-written - * IR is not promised to be clang's C ABI for the equivalent struct. The - * unions lane verified memory layout, so memory is the agreement we have: - * every macro is reached through a thunk taking (ptr,i64,ptr,ptr) and - * writing its result through the out pointer. - * - * - The macro module is self-contained: it links the runtime in and has no - * undefined Flan symbols, so the OCaml executable needs no -rdynamic and - * nothing in it has to be exported. - * - * The peek/poke family is how the marshaller writes a Form image into memory - * the macro can read. OCaml cannot address raw memory, so the bytes are laid - * out from here one field at a time. - */ - -#include -#include -#include -#include - -#include -#include -#include -#include - -CAMLprim value flan_dl_open(value path) { - CAMLparam1(path); - void *h = dlopen(String_val(path), RTLD_NOW | RTLD_LOCAL); - if (!h) caml_failwith(dlerror()); - CAMLreturn(caml_copy_nativeint((intnat)h)); -} - -CAMLprim value flan_dl_sym(value handle, value name) { - CAMLparam2(handle, name); - void *p = dlsym((void *)Nativeint_val(handle), String_val(name)); - if (!p) caml_failwith(dlerror()); - CAMLreturn(caml_copy_nativeint((intnat)p)); -} - -CAMLprim value flan_dl_close(value handle) { - dlclose((void *)Nativeint_val(handle)); - return Val_unit; -} - -/* The one call shape a macro is reached through. See the thunk Emit writes. */ -typedef void (*flan_macro_fn)(void *args, int64_t n, void *out, void *xfer); - -CAMLprim value flan_macro_call(value fn, value args, value n, value out) { - CAMLparam4(fn, args, n, out); - /* The transfer channel every Flan signature carries (spec-conditions.md, - section 6). A macro that signals a condition with nothing above it to - handle it aborts inside the compiler, which is loud rather than silent; - the channel still has to be a real, zeroed slot. */ - int64_t xfer[4] = { 0, 0, 0, 0 }; - ((flan_macro_fn)Nativeint_val(fn))((void *)Nativeint_val(args), - Int64_val(n), - (void *)Nativeint_val(out), xfer); - CAMLreturn(Val_unit); -} - -CAMLprim value flan_mem_alloc(value n) { - CAMLparam1(n); - /* Zeroed, because ZII is the language's rule and an unwritten Form field - must read as the zero of its type rather than as whatever malloc had. */ - void *p = calloc((size_t)Long_val(n), 1); - if (!p) caml_failwith("out of memory laying out a macro's arguments"); - CAMLreturn(caml_copy_nativeint((intnat)p)); -} - -CAMLprim value flan_mem_free(value p) { - free((void *)Nativeint_val(p)); - return Val_unit; -} - -CAMLprim value flan_poke_i32(value p, value off, value x) { - int32_t v = (int32_t)Int32_val(x); - memcpy((char *)Nativeint_val(p) + Long_val(off), &v, 4); - return Val_unit; -} - -CAMLprim value flan_poke_i64(value p, value off, value x) { - int64_t v = Int64_val(x); - memcpy((char *)Nativeint_val(p) + Long_val(off), &v, 8); - return Val_unit; -} - -CAMLprim value flan_poke_f64(value p, value off, value x) { - double v = Double_val(x); - memcpy((char *)Nativeint_val(p) + Long_val(off), &v, 8); - return Val_unit; -} - -CAMLprim value flan_poke_ptr(value p, value off, value q) { - void *v = (void *)Nativeint_val(q); - memcpy((char *)Nativeint_val(p) + Long_val(off), &v, sizeof v); - return Val_unit; -} - -CAMLprim value flan_poke_bytes(value p, value off, value s) { - memcpy((char *)Nativeint_val(p) + Long_val(off), String_val(s), - caml_string_length(s)); - return Val_unit; -} - -CAMLprim value flan_peek_i32(value p, value off) { - int32_t v; - memcpy(&v, (char *)Nativeint_val(p) + Long_val(off), 4); - return caml_copy_int32(v); -} - -CAMLprim value flan_peek_i64(value p, value off) { - int64_t v; - memcpy(&v, (char *)Nativeint_val(p) + Long_val(off), 8); - return caml_copy_int64(v); -} - -CAMLprim value flan_peek_f64(value p, value off) { - double v; - memcpy(&v, (char *)Nativeint_val(p) + Long_val(off), 8); - return caml_copy_double(v); -} - -CAMLprim value flan_peek_ptr(value p, value off) { - void *v; - memcpy(&v, (char *)Nativeint_val(p) + Long_val(off), sizeof v); - return caml_copy_nativeint((intnat)v); -} - -CAMLprim value flan_peek_bytes(value p, value off, value n) { - CAMLparam3(p, off, n); - CAMLlocal1(s); - s = caml_alloc_string((mlsize_t)Long_val(n)); - memcpy((char *)Bytes_val(s), (char *)Nativeint_val(p) + Long_val(off), - (size_t)Long_val(n)); - CAMLreturn(s); -} diff --git a/spike/embed/gc_ml.ml b/spike/embed/gc_ml.ml deleted file mode 100644 index e8b63ebf..00000000 --- a/spike/embed/gc_ml.ml +++ /dev/null @@ -1,21 +0,0 @@ -(* Step 6: the OCaml GC beside Flan's arenas. - Allocate hard, then compact -- the most disruptive thing the collector does, - since compaction is what actually moves blocks. C checks its arena after. *) - -external note : nativeint -> unit = "spike_note_arena" - -let () = - Callback.register "spike_churn" (fun (rounds : int) -> - let keep = ref [] in - for i = 1 to rounds do - (* Garbage, plus a little that survives, so the heap really grows. *) - for _ = 1 to 2000 do ignore (Bytes.create 512) done; - if i mod 10 = 0 then keep := Bytes.create 4096 :: !keep - done; - Gc.full_major (); - Gc.compact (); - let s = Gc.quick_stat () in - Printf.sprintf - "allocated %.0f words, %d major collections, %d compactions, heap %d words" - s.Gc.minor_words s.Gc.major_collections s.Gc.compactions s.Gc.heap_words); - ignore note diff --git a/spike/embed/harness1.c b/spike/embed/harness1.c deleted file mode 100644 index 63d6c29a..00000000 --- a/spike/embed/harness1.c +++ /dev/null @@ -1,14 +0,0 @@ -/* A C main() that owns the process and starts the OCaml runtime underneath it. */ -#include -#include -#include - -int main(int argc, char **argv) { - (void)argc; - caml_startup(argv); - const value *f = caml_named_value("spike_greet"); - if (!f) { fprintf(stderr, "spike: greet not registered\n"); return 1; } - printf("%s\n", String_val(caml_callback(*f, Val_int(42)))); - printf("spike: C main still owns the process\n"); - return 0; -} diff --git a/spike/embed/harness2.c b/spike/embed/harness2.c deleted file mode 100644 index ab960f51..00000000 --- a/spike/embed/harness2.c +++ /dev/null @@ -1,54 +0,0 @@ -/* Step 2: the whole compiler inside a C binary, and what it costs to start. - * - * The startup number is measured around caml_startup itself, not with time(1) - * on the process -- what a merged dev build would pay is the runtime coming up - * and every module initialiser running, not exec and dynamic linking, which it - * pays today anyway. */ -#include -#include -#include -#include -#include - -#ifndef FLANSRC -#define FLANSRC "test/programs/edn.flan" -#endif - -static double ms_since(struct timespec a) { - struct timespec b; - clock_gettime(CLOCK_MONOTONIC, &b); - return (b.tv_sec - a.tv_sec) * 1e3 + (b.tv_nsec - a.tv_nsec) / 1e6; -} - -static const value *need(const char *n) { - const value *f = caml_named_value(n); - if (!f) fprintf(stderr, "spike: %s not registered\n", n); - return f; -} - -int main(int argc, char **argv) { - struct timespec t0; - const char *src = argc > 1 ? argv[1] : FLANSRC; - const value *f; - - clock_gettime(CLOCK_MONOTONIC, &t0); - caml_startup(argv); - printf("caml_startup (runtime + every module initialiser): %.3f ms\n", ms_since(t0)); - - f = need("spike_footprint"); - if (f) printf("linked-module footprint: %s\n", String_val(caml_callback(*f, Val_unit))); - - f = need("spike_compile"); - if (f) { - clock_gettime(CLOCK_MONOTONIC, &t0); - printf("%s\n", String_val(caml_callback(*f, caml_copy_string(src)))); - printf("first in-process compile (read+parse+check+emit): %.3f ms\n", ms_since(t0)); - - clock_gettime(CLOCK_MONOTONIC, &t0); - caml_callback(*f, caml_copy_string(src)); - printf("second, warm: %.3f ms\n", ms_since(t0)); - } - - printf("spike: C main() still owns the process\n"); - return 0; -} diff --git a/spike/embed/harness3.c b/spike/embed/harness3.c deleted file mode 100644 index 09b069f4..00000000 --- a/spike/embed/harness3.c +++ /dev/null @@ -1,14 +0,0 @@ -/* Step 3: does -output-complete-obj carry the project's C stubs through? */ -#include -#include -#include - -int main(int argc, char **argv) { - const value *f; - (void)argc; - caml_startup(argv); - f = caml_named_value("spike_stubs"); - if (!f) { fprintf(stderr, "spike: stubs not registered\n"); return 1; } - printf("stubs reached from embedded runtime: %s\n", String_val(caml_callback(*f, Val_unit))); - return 0; -} diff --git a/spike/embed/harness4.c b/spike/embed/harness4.c deleted file mode 100644 index 49e789d8..00000000 --- a/spike/embed/harness4.c +++ /dev/null @@ -1,106 +0,0 @@ -/* Step 4: the macOS shape, and the discriminating test of the whole spike. - * - * main() is the game: it takes the thread the window needs and runs a loop it - * never leaves until the compiler says stop. The OCaml runtime is started on a - * pthread that C spawned -- exactly where vendor/agent/flan_agent.c already - * puts its listener. - * - * Two separate claims get tested: - * a. caml_startup works on a non-main, C-created thread at all. - * b. a *different* C thread, one the runtime never created, can call into - * OCaml after caml_c_thread_register(). - * (b) is the one that matters for the agent: its listener thread is spawned by - * flan_agent_start and would have to be able to reach the compiler. - */ -#include -#include -#include -#include -#include -#include -#include -#include -#include - -static char **g_argv; -static const char *g_src = "test/programs/edn.flan"; -static atomic_int compiler_up = 0; -static atomic_int quit = 0; -static pthread_t main_tid; - -static void nap(long ms) { - struct timespec t = { ms / 1000, (ms % 1000) * 1000000L }; - nanosleep(&t, NULL); -} - -static const value *need(const char *n) { - const value *f = caml_named_value(n); - if (!f) fprintf(stderr, "spike: %s not registered\n", n); - return f; -} - -/* The compiler thread: starts the OCaml runtime off the main thread. */ -static void *compiler_thread(void *unused) { - const value *f; - (void)unused; - printf(" [compiler thread] is main thread? %s\n", - pthread_equal(pthread_self(), main_tid) ? "YES (wrong)" : "no (correct)"); - caml_startup(g_argv); - printf(" [compiler thread] caml_startup returned off the main thread\n"); - - f = need("spike_domains"); - if (f) printf(" [compiler thread] %s\n", String_val(caml_callback(*f, Val_unit))); - - f = need("spike_thread_compile"); - if (f) printf(" [compiler thread] %s\n", - String_val(caml_callback(*f, caml_copy_string(g_src)))); - - /* Hand the runtime over so another C thread can borrow it, and prove the - main loop kept running throughout. */ - atomic_store(&compiler_up, 1); - caml_release_runtime_system(); - nap(300); - caml_acquire_runtime_system(); - atomic_store(&quit, 1); - return NULL; -} - -/* A second C thread, like the agent's listener: never created by OCaml. */ -static void *listener_thread(void *unused) { - const value *f; - (void)unused; - while (!atomic_load(&compiler_up)) nap(5); - if (caml_c_thread_register() == 0) { - printf(" [listener thread] caml_c_thread_register FAILED\n"); - return NULL; - } - caml_acquire_runtime_system(); - f = need("spike_thread_compile"); - if (f) printf(" [listener thread] %s\n", - String_val(caml_callback(*f, caml_copy_string(g_src)))); - caml_release_runtime_system(); - caml_c_thread_unregister(); - printf(" [listener thread] registered, called OCaml, unregistered\n"); - return NULL; -} - -int main(int argc, char **argv) { - pthread_t comp, lst; - long frames = 0; - g_argv = argv; - if (argc > 1) g_src = argv[1]; - main_tid = pthread_self(); - - if (pthread_create(&comp, NULL, compiler_thread, NULL) != 0) return 1; - if (pthread_create(&lst, NULL, listener_thread, NULL) != 0) return 1; - - /* The game loop. This thread never calls into OCaml and never blocks on it -- - it is the window's thread, and on macOS it has to be this one. */ - while (!atomic_load(&quit)) { frames++; nap(1); } - - pthread_join(comp, NULL); - pthread_join(lst, NULL); - printf(" [main thread] ran %ld frames without ever entering OCaml\n", frames); - printf("spike: the game kept the main thread\n"); - return 0; -} diff --git a/spike/embed/harness5.c b/spike/embed/harness5.c deleted file mode 100644 index 0e9f2143..00000000 --- a/spike/embed/harness5.c +++ /dev/null @@ -1,91 +0,0 @@ -/* Step 5: who owns SIGSEGV. - * - * The OCaml runtime installs a SIGSEGV handler to turn a stack-guard-page hit - * into the Stack_overflow exception. The break loop wants SIGSEGV for the - * crash case. This is the one real collision, so it is measured in both - * directions: - * - * a. what the disposition is before caml_startup, and after it; - * b. whether a handler installed AFTER caml_startup actually receives a - * genuine fault in program memory -- i.e. whether the break loop can have - * what it wants by installing last. - * - * SIGPIPE is not probed: flan_agent.c sends with MSG_NOSIGNAL throughout and - * does not rely on a disposition. - */ -#include -#include -#include -#include -#include -#include - -static void describe(const char *when, int sig) { - struct sigaction old; - memset(&old, 0, sizeof old); - sigaction(sig, NULL, &old); - printf(" %-22s %-8s handler=%p flags=%#x %s%s\n", when, - sig == SIGSEGV ? "SIGSEGV" : sig == SIGINT ? "SIGINT" : "SIGFPE", - (old.sa_flags & SA_SIGINFO) ? (void *)old.sa_sigaction : (void *)old.sa_handler, - (unsigned)old.sa_flags, - (old.sa_flags & SA_ONSTACK) ? "ONSTACK " : "", - old.sa_handler == SIG_DFL ? "(SIG_DFL)" - : old.sa_handler == SIG_IGN ? "(SIG_IGN)" : "(custom)"); -} - -static sigjmp_buf escape; -static volatile sig_atomic_t ours_ran = 0; - -static void our_segv(int sig, siginfo_t *info, void *ctx) { - (void)sig; (void)ctx; - ours_ran = 1; - /* What a break loop would do here is stop and serve; the spike just proves - the handler was reached, with the faulting address in hand. */ - printf(" our SIGSEGV handler ran, fault address = %p\n", info->si_addr); - siglongjmp(escape, 1); -} - -int main(int argc, char **argv) { - struct sigaction sa, ocaml_segv; - volatile int *bad = (int *)0x10; - (void)argc; - - printf("before caml_startup:\n"); - describe("before startup", SIGSEGV); - describe("before startup", SIGINT); - describe("before startup", SIGFPE); - - caml_startup(argv); - - printf("after caml_startup:\n"); - describe("after startup", SIGSEGV); - describe("after startup", SIGINT); - describe("after startup", SIGFPE); - memset(&ocaml_segv, 0, sizeof ocaml_segv); - sigaction(SIGSEGV, NULL, &ocaml_segv); - - /* Now install ours last, the way the break loop would. */ - memset(&sa, 0, sizeof sa); - sa.sa_sigaction = our_segv; - sa.sa_flags = SA_SIGINFO | SA_ONSTACK; - sigemptyset(&sa.sa_mask); - sigaction(SIGSEGV, &sa, NULL); - printf("break loop installs last:\n"); - describe("after break loop", SIGSEGV); - - if (sigsetjmp(escape, 1) == 0) { - printf(" dereferencing %p ...\n", (void *)bad); - *bad = 1; - printf(" no fault -- UNEXPECTED\n"); - } else { - printf(" recovered; a handler installed after caml_startup does receive " - "a real fault: %s\n", ours_ran ? "yes" : "no"); - } - - /* And the cost of taking it: OCaml's own handler is now displaced, so its - stack-overflow detection is gone unless ours chains to the saved one. */ - printf(" OCaml's displaced SIGSEGV handler was %p -- chaining to it is what " - "keeps Stack_overflow working\n", - (void *)ocaml_segv.sa_sigaction); - return 0; -} diff --git a/spike/embed/harness5b.c b/spike/embed/harness5b.c deleted file mode 100644 index 1b164121..00000000 --- a/spike/embed/harness5b.c +++ /dev/null @@ -1,110 +0,0 @@ -/* Step 5b: the SIGSEGV question, asked properly. - * - * 5a read the disposition either side of caml_startup and found SIG_DFL both - * times, which would mean no collision at all. That is too good, and it is - * because OCaml 5 installs the handler per *domain*, on the domain's own - * thread, not once during startup. So this asks at four moments, and then asks - * the only question that decides anything: with the break loop holding SIGSEGV, - * does an OCaml stack overflow still raise Stack_overflow, or does it become a - * hard crash? - * - * Two ways of taking it are compared: - * take_segv -- install ours and discard OCaml's, the naive thing; - * chain_segv -- install ours, keep OCaml's, and forward to it. - */ -#include -#include -#include -#include -#include -#include -#include - -static struct sigaction ocaml_segv; -static int have_ocaml_segv = 0; - -CAMLprim value spike_show_segv(value when) { - struct sigaction cur; - memset(&cur, 0, sizeof cur); - sigaction(SIGSEGV, NULL, &cur); - printf(" SIGSEGV %-46s handler=%p flags=%#x%s\n", String_val(when), - (cur.sa_flags & SA_SIGINFO) ? (void *)cur.sa_sigaction - : (void *)cur.sa_handler, - (unsigned)cur.sa_flags, - cur.sa_handler == SIG_DFL ? " (SIG_DFL)" : ""); - fflush(stdout); - return Val_unit; -} - -/* The break loop's handler. It does not long-jump here -- the point is only to - * see whether it is reached and whether OCaml still works around it. */ -static void break_segv(int sig, siginfo_t *info, void *ctx) { - (void)sig; - if (have_ocaml_segv && ocaml_segv.sa_sigaction && - ocaml_segv.sa_handler != SIG_DFL && ocaml_segv.sa_handler != SIG_IGN) { - /* Chained: hand the fault to OCaml, which turns a guard-page hit into - * Stack_overflow and re-raises anything else. */ - ocaml_segv.sa_sigaction(sig, info, ctx); - return; - } - /* Taken outright: nothing below us. A real break loop would stop and serve; - * here we can only abort, which is the honest cost of discarding OCaml's. */ - printf(" break loop caught SIGSEGV at %p with nothing to chain to\n", - info->si_addr); - fflush(stdout); - _exit(9); -} - -static void install(int keep_old) { - struct sigaction sa; - memset(&sa, 0, sizeof sa); - memset(&ocaml_segv, 0, sizeof ocaml_segv); - sigaction(SIGSEGV, NULL, &ocaml_segv); - have_ocaml_segv = keep_old; - sa.sa_sigaction = break_segv; - sa.sa_flags = SA_SIGINFO | SA_ONSTACK | SA_NODEFER; - sigemptyset(&sa.sa_mask); - sigaction(SIGSEGV, &sa, NULL); -} - -/* A sweep, so "the OCaml runtime installs handlers" can be stated as a list - * rather than a worry. Called from OCaml with the runtime and a domain up. */ -CAMLprim value spike_sweep(value u) { - static const int sigs[] = { SIGSEGV, SIGBUS, SIGFPE, SIGILL, SIGINT, SIGTERM, - SIGPIPE, SIGCHLD, SIGUSR1, SIGUSR2, SIGABRT, - SIGALRM, SIGPROF, SIGVTALRM, SIGWINCH }; - static const char *names[] = { "SEGV", "BUS", "FPE", "ILL", "INT", "TERM", - "PIPE", "CHLD", "USR1", "USR2", "ABRT", - "ALRM", "PROF", "VTALRM", "WINCH" }; - struct sigaction c; - unsigned i; - (void)u; - for (i = 0; i < sizeof sigs / sizeof *sigs; i++) { - memset(&c, 0, sizeof c); - sigaction(sigs[i], NULL, &c); - if (c.sa_handler != SIG_DFL) - printf(" SIG%-8s %s\n", names[i], - c.sa_handler == SIG_IGN ? "SIG_IGN" : "custom handler"); - } - printf(" (every signal not named above is SIG_DFL)\n"); - fflush(stdout); - return Val_unit; -} - -CAMLprim value spike_take_segv(value u) { (void)u; install(0); return Val_unit; } -CAMLprim value spike_chain_segv(value u) { (void)u; install(1); return Val_unit; } - -#ifndef SPIKE_NO_MAIN -int main(int argc, char **argv) { - struct sigaction cur; - (void)argc; - memset(&cur, 0, sizeof cur); - sigaction(SIGSEGV, NULL, &cur); - printf(" SIGSEGV %-46s handler=%p%s\n", "before caml_startup", - (void *)cur.sa_handler, cur.sa_handler == SIG_DFL ? " (SIG_DFL)" : ""); - /* Everything else runs from sig_ml.ml's module initialiser, so the readings - * happen on the runtime's own thread at the moments that matter. */ - caml_startup(argv); - return 0; -} -#endif diff --git a/spike/embed/harness6.c b/spike/embed/harness6.c deleted file mode 100644 index 670e854e..00000000 --- a/spike/embed/harness6.c +++ /dev/null @@ -1,61 +0,0 @@ -/* Step 6: does OCaml's collector touch memory it does not own? - * - * Flan's arenas, Vecs and Maps are plain malloc'd memory. The claim is that - * OCaml never sees them, so a compaction cannot move or scribble on them. The - * probe: fill an arena with a checkable pattern, hold raw interior pointers - * into it across a full major collection AND a compaction, then verify every - * byte and every pointer. - * - * What this proves is narrow and worth stating narrowly: OCaml traces its own - * roots only. It does NOT license storing an OCaml `value` in this arena -- - * that would need caml_register_global_root, and is the way the assumption - * actually breaks. - */ -#include -#include -#include -#include -#include -#include - -#define ARENA (8u << 20) /* 8 MiB, the shape of a Flan arena */ - -static uint8_t *arena; -static uint64_t *interior[64]; - -CAMLprim value spike_note_arena(value p) { (void)p; return Val_unit; } - -static uint8_t pattern(size_t i) { return (uint8_t)(i * 31u + 7u); } - -int main(int argc, char **argv) { - const value *f; - size_t i, bad = 0; - uint8_t *before; - (void)argc; - - arena = malloc(ARENA); - if (!arena) return 1; - for (i = 0; i < ARENA; i++) arena[i] = pattern(i); - for (i = 0; i < 64; i++) interior[i] = (uint64_t *)(arena + i * 4096); - before = arena; - - caml_startup(argv); - - f = caml_named_value("spike_churn"); - if (!f) { fprintf(stderr, "spike: churn not registered\n"); return 1; } - printf("%s\n", String_val(caml_callback(*f, Val_int(200)))); - - for (i = 0; i < ARENA; i++) if (arena[i] != pattern(i)) bad++; - printf("arena base %s (%p -> %p)\n", before == arena ? "unmoved" : "MOVED", - (void *)before, (void *)arena); - printf("arena bytes altered by the GC: %zu of %u\n", bad, ARENA); - - bad = 0; - for (i = 0; i < 64; i++) - if (interior[i] != (uint64_t *)(arena + i * 4096)) bad++; - printf("raw interior pointers invalidated: %zu of 64\n", bad); - printf("spike: %s\n", bad == 0 ? "foreign memory is invisible to the collector" - : "FOREIGN MEMORY WAS DISTURBED"); - free(arena); - return 0; -} diff --git a/spike/embed/hello_ml.ml b/spike/embed/hello_ml.ml deleted file mode 100644 index dbef30c1..00000000 --- a/spike/embed/hello_ml.ml +++ /dev/null @@ -1,5 +0,0 @@ -(* Step 1: the smallest thing that proves OCaml code can be reached from a C - [main]. One function, registered by name, called back from C. *) -let () = - Callback.register "spike_greet" (fun (n : int) -> - Printf.sprintf "ocaml saw %d, unix says pid %d" n (Unix.getpid ())) diff --git a/spike/embed/merged.sh b/spike/embed/merged.sh deleted file mode 100644 index c9639640..00000000 --- a/spike/embed/merged.sh +++ /dev/null @@ -1,66 +0,0 @@ -#!/usr/bin/env bash -# Step 8: the thing the whole spike is really asking about -- ONE binary that -# is both a compiled Flan program and the OCaml compiler, with clang doing the -# final link. -# -# Everything before this proved a piece. This proves the shape: the Flan -# program's own main() is renamed out of the way, a C main() takes the main -# thread and runs the program there, and caml_startup happens on a side thread -# beside it. That is exactly item 11's inversion, built for real. -# -# It is NOT the merged architecture -- nothing is wired up, the compiler and the -# program do not talk. It is a link and a size and a startup number. -set -u -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -src=${1:-test/programs/edn.flan} -cd "$root" || exit 1 -out=$(mktemp -d); trap 'rm -rf "$out"' EXIT - -FLAN=_build/default/bin/main.exe -OCAMLLIB=$(ocamlopt -where) -SYSLIBS="-lm -lpthread -ldl -lzstd" - -echo "program: $src" - -# 1. The Flan program, as it is built today, for the baseline sizes. -"$FLAN" build "$src" -o "$out/rel" || exit 1 -"$FLAN" build "$src" --dev -o "$out/dev" || exit 1 - -# 2. The same program as an object, with its main renamed so a C main can own -# the process. Emit writes @main literally; sed is enough to move it. -"$FLAN" emit "$src" --dev > "$out/prog.ll" || exit 1 -sed -i 's/define i32 @main(/define i32 @flan_program_main(/' "$out/prog.ll" -grep -q 'define i32 @flan_program_main(' "$out/prog.ll" || { - echo "could not find @main in the emitted IR -- adjust the rename"; exit 1; } -clang -c -x ir "$out/prog.ll" -o "$out/prog.o" || exit 1 - -# 3. The runtime the program needs, and the agent beside it. -clang -c -O2 runtime/flan_rt.c -o "$out/rt.o" || exit 1 -clang -c -O2 runtime/flan_dev.c -o "$out/dev.o" || exit 1 -clang -c -O2 vendor/agent/flan_agent.c -o "$out/ag.o" || exit 1 - -# 4. The whole OCaml compiler as one object. -ocamlfind ocamlopt -thread -package unix,threads.posix -linkpkg \ - -output-complete-obj \ - -I "$root/_build/default/lib/.flan.objs/byte" \ - -I "$root/_build/default/lib/.flan.objs/native" \ - -o "$out/compiler.o" "$root/_build/default/lib/flan.cmxa" \ - "$here/thread_ml.ml" || exit 1 - -# 5. One link. clang, as the project already does it. -clang -I"$OCAMLLIB" "$here/merged_main.c" "$out/prog.o" "$out/rt.o" "$out/dev.o" \ - "$out/ag.o" "$out/compiler.o" -o "$out/merged" $SYSLIBS || exit 1 - -echo -echo "sizes:" -for f in rel dev merged; do - printf ' %-30s %9d bytes\n' "$f" "$(stat -c%s "$out/$f")" -done -printf ' %-30s %9d bytes\n' "what the compiler adds to a dev build" \ - "$(( $(stat -c%s "$out/merged") - $(stat -c%s "$out/dev") ))" - -echo -echo "running the merged binary:" -"$out/merged" "$src" -echo "exit: $?" diff --git a/spike/embed/merged_main.c b/spike/embed/merged_main.c deleted file mode 100644 index 85d0bccf..00000000 --- a/spike/embed/merged_main.c +++ /dev/null @@ -1,77 +0,0 @@ -/* One process: the Flan program on the main thread, the OCaml compiler beside - * it on a domain of its own. - * - * This is the shape item 11 settles on, and the reason it is written this way - * round rather than the other: on macOS the window has to be on the main - * thread, so the game keeps main() and the compiler moves to the side -- - * beside the listener vendor/agent/flan_agent.c already starts there. - * - * The program and the compiler do not talk to each other here. Wiring them up - * is the real work; this only shows they can share an address space, a link, - * and a process, with clang doing the final link. */ -#include -#include -#include -#include -#include -#include -#include -#include - -/* The Flan program's entry point, renamed out of main's way by merged.sh. */ -extern int flan_program_main(int argc, char **argv); - -static char **g_argv; -static const char *g_src; -/* The Flan program's main calls exit(), so the compiler has to be up before it - * starts -- which is the honest ordering anyway: the image comes up and serves, - * then the program runs, the way starting an SBCL image does. */ -static atomic_int compiler_ready = 0; - -static double ms_since(struct timespec a) { - struct timespec b; - clock_gettime(CLOCK_MONOTONIC, &b); - return (b.tv_sec - a.tv_sec) * 1e3 + (b.tv_nsec - a.tv_nsec) / 1e6; -} - -static void *compiler_side(void *unused) { - struct timespec t0; - const value *f; - (void)unused; - clock_gettime(CLOCK_MONOTONIC, &t0); - caml_startup(g_argv); - printf("[compiler] up on a side thread in %.3f ms\n", ms_since(t0)); - f = caml_named_value("spike_thread_compile"); - if (f) { - clock_gettime(CLOCK_MONOTONIC, &t0); - printf("[compiler] %s\n", String_val(caml_callback(*f, caml_copy_string(g_src)))); - printf("[compiler] compiled the running program from inside it, in %.3f ms\n", - ms_since(t0)); - } - caml_release_runtime_system(); - atomic_store(&compiler_ready, 1); - return NULL; -} - -int main(int argc, char **argv) { - pthread_t comp; - int rc; - g_argv = argv; - g_src = argc > 1 ? argv[1] : "test/programs/edn.flan"; - - if (pthread_create(&comp, NULL, compiler_side, NULL) != 0) return 1; - - while (!atomic_load(&compiler_ready)) { - struct timespec t = { 0, 2000000L }; - nanosleep(&t, NULL); - } - - /* The main thread is the program's, and it never enters OCaml. */ - printf("[program] running on the main thread\n"); - rc = flan_program_main(argc, argv); - printf("[program] returned %d\n", rc); - - pthread_join(comp, NULL); - printf("one process: a Flan program and the OCaml compiler, same binary\n"); - return 0; -} diff --git a/spike/embed/run.sh b/spike/embed/run.sh deleted file mode 100644 index 51fdcc10..00000000 --- a/spike/embed/run.sh +++ /dev/null @@ -1,76 +0,0 @@ -#!/usr/bin/env bash -# Spike: what it costs to link the OCaml compiler into a native Flan dev build. -# -# Deliberately NOT a dune target. The root `dune` only excludes old-ocaml/, so a -# dune file here would land in @default and make the spike part of the build. -# Instead this drives ocamlfind and clang by hand, against the flan.cmxa that -# dune already produces. Run it from anywhere: bash spike/embed/run.sh -set -u - -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -cd "$here" || exit 1 - -OCAMLLIB=$(ocamlopt -where) -CAMLINC="-I$OCAMLLIB" -# OCaml 5.2's marshaller is compressed, so -output-complete-obj pulls in zstd. -SYSLIBS="-lm -lpthread -ldl -lzstd" - -step() { printf '\n=== %s ===\n' "$1"; } - -# ---------------------------------------------------------------- 1. smallest -step "1. smallest link: C main() -> caml_startup -> OCaml callback" -ocamlfind ocamlopt -package unix -linkpkg -output-complete-obj \ - -o embed1.o hello_ml.ml || exit 1 -clang $CAMLINC harness1.c embed1.o -o spike1 $SYSLIBS || exit 1 -./spike1 || echo "spike1 FAILED" -ls -l spike1 | awk '{print "spike1 size: " $5 " bytes"}' - -# ------------------------------------------------------- 2. the real compiler -step "2. link the whole flan compiler (flan.cmxa) into a C binary" -CMXA="$root/_build/default/lib/flan.cmxa" -if [ ! -f "$CMXA" ]; then - echo "no $CMXA -- run 'dune build --root .' first"; exit 1 -fi -ocamlfind ocamlopt -package unix -linkpkg -output-complete-obj \ - -I "$root/_build/default/lib/.flan.objs/byte" \ - -I "$root/_build/default/lib/.flan.objs/native" \ - -o embed2.o "$CMXA" whole_ml.ml || exit 1 -clang $CAMLINC harness2.c embed2.o -o spike2 $SYSLIBS || exit 1 -(cd "$root" && "$here/spike2" test/programs/edn.flan) || echo "spike2 FAILED" -ls -l spike2 | awk '{print "spike2 size: " $5 " bytes"}' -ls -l "$root/_build/default/bin/main.exe" | awk '{print "main.exe size: " $5 " bytes"}' -clang $CAMLINC baseline.c -o baseline -ls -l baseline | awk '{print "bare C baseline: " $5 " bytes"}' - -# ------------------------------------------------------------- 3. with stubs -step "3. the same, with the project's own C stubs compiled in" -ocamlfind ocamlopt -package unix -linkpkg -output-complete-obj \ - -I "$root/_build/default/lib/.flan.objs/byte" \ - -I "$root/_build/default/lib/.flan.objs/native" \ - -o embed3.o "$CMXA" stubs_ml.ml dynload_stubs.c || exit 1 -clang $CAMLINC harness3.c embed3.o -o spike3 $SYSLIBS || exit 1 -./spike3 || echo "spike3 FAILED" - -# ------------------------------------------ 4. threads: game owns main thread -step "4. threads: C main runs the 'game loop', OCaml starts on another thread" -ocamlfind ocamlopt -thread -package unix,threads.posix -linkpkg -output-complete-obj \ - -I "$root/_build/default/lib/.flan.objs/byte" \ - -I "$root/_build/default/lib/.flan.objs/native" \ - -o embed4.o "$CMXA" thread_ml.ml || exit 1 -clang $CAMLINC harness4.c embed4.o -o spike4 $SYSLIBS || exit 1 -(cd "$root" && "$here/spike4" test/programs/edn.flan) || echo "spike4 FAILED" - -# ------------------------------------------------------------ 5. signals -step "5. signals: who owns SIGSEGV across caml_startup" -clang $CAMLINC harness5.c embed2.o -o spike5 $SYSLIBS || exit 1 -./spike5 || echo "spike5 exited nonzero" - -# ------------------------------------------------------- 6. GC vs raw memory -step "6. GC: does a compaction move or touch a C-owned arena" -ocamlfind ocamlopt -package unix -linkpkg -output-complete-obj \ - -o embed6.o gc_ml.ml || exit 1 -clang $CAMLINC harness6.c embed6.o -o spike6 $SYSLIBS || exit 1 -./spike6 || echo "spike6 FAILED" - -printf '\nspike: done\n' diff --git a/spike/embed/sig.sh b/spike/embed/sig.sh deleted file mode 100644 index 6b6a2383..00000000 --- a/spike/embed/sig.sh +++ /dev/null @@ -1,23 +0,0 @@ -#!/usr/bin/env bash -# Step 5b on its own: the SIGSEGV question, embedded and standalone side by -# side. The standalone build is the control -- if OCaml behaves the same in a -# plain ocamlopt executable, then embedding changed nothing about signals. -set -u -here=$(cd "$(dirname "$0")" && pwd) -cd "$here" || exit 1 -OCAMLLIB=$(ocamlopt -where) -SYSLIBS="-lm -lpthread -ldl -lzstd" - -echo "=== 5b-embedded: caml_startup called from a C main() ===" -ocamlfind ocamlopt -package unix -linkpkg -output-complete-obj \ - -o embed5b.o sig_ml.ml || exit 1 -clang -I"$OCAMLLIB" harness5b.c embed5b.o -o spike5b $SYSLIBS || exit 1 -./spike5b; echo "exit: $?" - -echo -echo "=== 5b-standalone: the same OCaml, as a plain ocamlopt executable ===" -# The control. Same stubs, but OCaml owns main(). -clang -c -I"$OCAMLLIB" -DSPIKE_NO_MAIN harness5b.c -o stubs5b.o || exit 1 -ocamlfind ocamlopt -package unix -linkpkg -o spike5b_std sig_ml.ml stubs5b.o \ - -cclib -lzstd || exit 1 -./spike5b_std; echo "exit: $?" diff --git a/spike/embed/sig_ml.ml b/spike/embed/sig_ml.ml deleted file mode 100644 index 5d96ba2b..00000000 --- a/spike/embed/sig_ml.ml +++ /dev/null @@ -1,34 +0,0 @@ -(* Step 5b: OCaml 5.2 installs its SIGSEGV handler per-domain, not once at - startup, so "read the disposition after caml_startup" is not the whole - question. This asks it at four moments, and then asks the thing that - actually matters: does Stack_overflow still get raised once the break loop - has taken SIGSEGV? *) - -external show : string -> unit = "spike_show_segv" -external take_segv : unit -> unit = "spike_take_segv" -external chain_segv : unit -> unit = "spike_chain_segv" -external sweep : unit -> unit = "spike_sweep" - -let rec deep n = if n <= 0 then 0 else 1 + deep (n - 1) + (if n < 0 then deep n else 0) - -let overflow_result () = - try - let n = deep 100_000_000 in - Printf.sprintf "returned %d (no overflow)" n - with Stack_overflow -> "Stack_overflow raised" - -let () = - show "at module init (main domain up)"; - let d = Domain.spawn (fun () -> show "inside a spawned domain") in - Domain.join d; - show "after Domain.join"; - print_endline "every signal the OCaml runtime is holding:"; - sweep (); - Printf.sprintf "before touching SIGSEGV: %s" (overflow_result ()) |> print_endline; - take_segv (); - show "after the break loop takes SIGSEGV outright"; - Printf.sprintf "with SIGSEGV taken outright: %s" (overflow_result ()) - |> print_endline; - chain_segv (); - show "after the break loop chains to OCaml's handler"; - Printf.sprintf "with SIGSEGV chained: %s" (overflow_result ()) |> print_endline diff --git a/spike/embed/stubs_ml.ml b/spike/embed/stubs_ml.ml deleted file mode 100644 index 34a2664a..00000000 --- a/spike/embed/stubs_ml.ml +++ /dev/null @@ -1,26 +0,0 @@ -(* Step 3: the project's own C stubs, in the same link as the compiler. - lib/dynload_stubs.c is taken verbatim from 9e0ae3a (the unmerged dlopen - branch) -- it is the only C the compiler itself is built from, and it is the - case that -output-complete-obj has to carry through. *) - -external dl_open : string -> nativeint = "flan_dl_open" -external dl_sym : nativeint -> string -> nativeint = "flan_dl_sym" -external mem_alloc : int -> nativeint = "flan_mem_alloc" -external mem_free : nativeint -> unit = "flan_mem_free" -external poke_i64 : nativeint -> int -> int64 -> unit = "flan_poke_i64" -external peek_i64 : nativeint -> int -> int64 = "flan_peek_i64" - -let () = - Callback.register "spike_stubs" (fun () -> - (* peek/poke: the raw memory the marshaller lays a Form image out in. *) - let p = mem_alloc 64 in - poke_i64 p 8 0xfeedfacedeadbeefL; - let got = peek_i64 p 8 in - mem_free p; - (* dlopen from inside the embedded runtime, on the process's own image. *) - let h = dl_open "libm.so.6" in - let s = dl_sym h "sqrt" in - Printf.sprintf "peek/poke %s; dlopen+dlsym %s" - (if got = 0xfeedfacedeadbeefL then "ok" else "WRONG") - (if s <> 0n then "ok" else "WRONG")); - ignore dl_open diff --git a/spike/embed/symbols.sh b/spike/embed/symbols.sh deleted file mode 100644 index 34e4bed8..00000000 --- a/spike/embed/symbols.sh +++ /dev/null @@ -1,50 +0,0 @@ -#!/usr/bin/env bash -# Step 7: the integration hazard nobody asks about until the link fails. -# -# Today runtime/flan_rt.c, runtime/flan_dev.c and vendor/agent/flan_agent.c are -# compiled into the *program*, and lib/dynload_stubs.c into the *compiler*. -# Merging the processes puts all four and the OCaml runtime in one link. This -# checks, symbol by symbol, whether anything collides. -set -u -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -out=$(mktemp -d) -trap 'rm -rf "$out"' EXIT -cd "$root" || exit 1 - -defs() { nm --defined-only "$@" 2>/dev/null | awk 'NF==3 {print $3}' | sort -u; } - -clang -c runtime/flan_rt.c -o "$out/rt.o" || exit 1 -clang -c runtime/flan_dev.c -o "$out/dev.o" || exit 1 -clang -c vendor/agent/flan_agent.c -o "$out/ag.o" || exit 1 -clang -c -I"$(ocamlopt -where)" "$here/dynload_stubs.c" -o "$out/dl.o" || exit 1 - -defs "$out/rt.o" "$out/dev.o" "$out/ag.o" "$out/dl.o" > "$out/flan.syms" -defs /home/joe/.opam/default/lib/ocaml/libasmrun.a > "$out/ml.syms" 2>/dev/null -[ -s "$out/ml.syms" ] || defs "$(ocamlopt -where)/libasmrun.a" > "$out/ml.syms" - -echo "Flan's own C defines $(wc -l < "$out/flan.syms") symbols;" \ - "libasmrun defines $(wc -l < "$out/ml.syms")." -echo "collisions between Flan's C and the OCaml runtime:" -if comm -12 "$out/flan.syms" "$out/ml.syms" | grep . ; then - echo " ^^ those would have to be renamed" -else - echo " none" -fi - -echo "collisions among Flan's own four .c files:" -for a in rt dev ag dl; do defs "$out/$a.o" > "$out/$a.syms"; done -found=0 -for a in rt dev ag dl; do - for b in rt dev ag dl; do - [ "$a" \< "$b" ] || continue - c=$(comm -12 "$out/$a.syms" "$out/$b.syms") - [ -n "$c" ] && { echo " $a vs $b:"; echo "$c" | sed 's/^/ /'; found=1; } - done -done -[ $found -eq 0 ] && echo " none" - -echo "what Flan's C needs that the OCaml runtime also exports (shared libc etc):" -nm --undefined-only "$out/rt.o" "$out/ag.o" 2>/dev/null | awk 'NF==2{print $2}' \ - | sort -u > "$out/need.syms" -comm -12 "$out/need.syms" "$out/ml.syms" | sed 's/^/ /' | head -20 diff --git a/spike/embed/thread_ml.ml b/spike/embed/thread_ml.ml deleted file mode 100644 index 81d0fad2..00000000 --- a/spike/embed/thread_ml.ml +++ /dev/null @@ -1,32 +0,0 @@ -(* Step 4: the macOS shape. The game owns the main thread; the compiler and the - listener run beside it. - - The question is NOT "can OCaml use threads" -- it is whether caml_startup can - be called from a pthread that C spawned, while main() goes on to run a - window loop it never returns from. That is the inversion item 11 settles on, - and it is the one that has to be measured rather than assumed. *) - -let compile file = - let l = Flan.Load.program ~file (Flan.Parse.program (Flan.Reader.read_file file)) in - let p = Flan.Check.program l.Flan.Load.decls in - String.length (Flan.Emit.program ~dev:true p) - -let () = - Callback.register "spike_thread_compile" (fun (file : string) -> - let tid = Thread.id (Thread.self ()) in - match compile file with - | n -> - Printf.sprintf "compiled on OCaml thread %d: %d bytes of LLVM IR" tid n - | exception e -> Printf.sprintf "FAILED: %s" (Printexc.to_string e)); - Callback.register "spike_domains" (fun () -> - (* A second domain doing real work while the main thread is elsewhere -- - 5.2's multicore runtime, which is the objection item 12 says has gone - away. Confirmed rather than assumed. *) - let d = Domain.spawn (fun () -> - let s = ref 0 in - for i = 1 to 5_000_000 do s := !s + i done; - (Domain.self () :> int), !s) - in - let id, s = Domain.join d in - Printf.sprintf "domain %d summed to %d; recommended_domain_count = %d" - id s (Domain.recommended_domain_count ())) diff --git a/spike/embed/whole_ml.ml b/spike/embed/whole_ml.ml deleted file mode 100644 index 38c0197b..00000000 --- a/spike/embed/whole_ml.ml +++ /dev/null @@ -1,40 +0,0 @@ -(* Step 2: reach enough of the compiler that the linker cannot drop it, and do - real compiler work in-process so the measurement is of a working compiler - rather than of dead code that happened to link. - - The work is the driver's own path, the one bin/main.ml takes: - read -> Parse.program -> Load.program -> Check.program -> Emit.program. That - is the whole front end and the whole back end short of [llc]. Check.program - prepends the prelude itself, so the prelude is in the measurement without - being fed in twice. *) - -let compile file = - let l = Flan.Load.program ~file (Flan.Parse.program (Flan.Reader.read_file file)) in - let p = Flan.Check.program l.Flan.Load.decls in - let ir = Flan.Emit.program ~dev:true p in - (List.length l.Flan.Load.decls, String.length ir) - -(* Touched only so the linker keeps the modules a merged dev build would carry. - Nothing here is called for its effect. *) -let footprint () = - String.concat "," - [ Flan.Build.clang; - string_of_int (String.length Flan.Shim.header); - string_of_int (String.length Flan.Runtime_src.source); - string_of_int (String.length Flan.Runtime_src.dev_source); - string_of_int (List.length Flan.Session.externs); - string_of_int (Flan.Render.max_span); - string_of_int (String.length (Flan.Wire.ints [ 1; 2 ])) ] - -let () = - Callback.register "spike_compile" (fun (file : string) -> - match compile file with - | d, n -> Printf.sprintf "%s: %d decls, %d bytes of LLVM IR" file d n - | exception e -> Printf.sprintf "FAILED: %s" (Printexc.to_string e)); - Callback.register "spike_footprint" footprint; - (* Dev.start and Cimport are never run here, but naming them keeps the socket - server and the C importer in the link -- a dev build pays for them. *) - Callback.register "spike_unused" (fun () -> - ignore (Flan.Dev.start : ?debug:bool -> file:string -> sock:string -> unit -> unit); - ignore (Flan.Cimport.decl_source : Flan.Ast.decl -> string); - "ok") diff --git a/spike/generics/id.flan b/spike/generics/id.flan deleted file mode 100644 index 4e029682..00000000 --- a/spike/generics/id.flan +++ /dev/null @@ -1,7 +0,0 @@ -(defn id [x $t] t x) - -(defn main [] () - (println (id 3)) - (println (id 4.5)) - (println (id 7)) - (println (id true))) diff --git a/spike/generics/measure.ml b/spike/generics/measure.ml deleted file mode 100644 index 457795a5..00000000 --- a/spike/generics/measure.ml +++ /dev/null @@ -1,171 +0,0 @@ -(* What redefining a generic function costs the dev loop, measured. - - The question the spike exists to answer: C-c C-c on a concrete function is - about 35 ms today, and a generic function that is redefined has to rebuild - *every* instantiation. So the sweep is one generic called at N concrete - types, N = 1..8, against the handwritten N-copies program it replaces, and - the three things a C-c C-c actually pays for are timed separately: - - check Check.program_with_env over the whole accumulated program — - which is what Session.eval does on every evaluation, so this is - paid whether the redefined function is generic or not. - emit Emit.redefinition for the fns being installed. - build llc + ld -shared, from Build.shared — the dominant term. - - Nothing here modifies the session or the dev loop; it drives the real ones. *) - -let tys = [| "i8"; "i16"; "i32"; "i64"; "u8"; "u16"; "u32"; "f32" |] - -let time f = - let t0 = Unix.gettimeofday () in - let x = f () in - (x, (Unix.gettimeofday () -. t0) *. 1000.) - -(* Best of k, because llc and the linker are processes and the machine is - noisy; a median would hide a systematic cost and a mean would report the - scheduler. *) -let best k f = - let rec go i acc = if i = 0 then acc else - let _, ms = time f in go (i - 1) (min acc ms) in - go k infinity - -let generic_src n = - let b = Buffer.create 1024 in - Buffer.add_string b - "(defn gswap [xs [$t] i i32 j i32] ()\n\ - \ (let [tmp (at xs i)]\n\ - \ (set (at xs i) (at xs j))\n\ - \ (set (at xs j) tmp)))\n\n\ - (defn gsort [s [$t] before? (Fn [$t $t] bool)] ()\n\ - \ (let [i 1]\n\ - \ (while (< i (length s))\n\ - \ (let [j i]\n\ - \ (while (and (> j 0) (before? (at s j) (at s (- j 1))))\n\ - \ (gswap s (- j 1) j)\n\ - \ (set j (- j 1))))\n\ - \ (set i (+ i 1)))))\n\n"; - for i = 0 to n - 1 do - Buffer.add_string b (Printf.sprintf "(defonce xs-%s [8 %s])\n" tys.(i) tys.(i)) - done; - Buffer.add_string b "\n(defn main [] ()\n"; - for i = 0 to n - 1 do - Buffer.add_string b - (Printf.sprintf " (gsort (slice xs-%s 0 8) (fn [a b] (< a b)))\n" tys.(i)) - done; - Buffer.add_string b " )\n"; - Buffer.contents b - -(* The same program as it is written today: one copy of each function per - element type, by hand. This is prelude.ml's shape. *) -let mono_src n = - let b = Buffer.create 1024 in - for i = 0 to n - 1 do - let t = tys.(i) in - Buffer.add_string b - (Printf.sprintf - "(defn mswap-%s [xs [%s] i i32 j i32] ()\n\ - \ (let [tmp (at xs i)]\n\ - \ (set (at xs i) (at xs j))\n\ - \ (set (at xs j) tmp)))\n\n\ - (defn msort-%s [s [%s] before? (Fn [%s %s] bool)] ()\n\ - \ (let [i 1]\n\ - \ (while (< i (length s))\n\ - \ (let [j i]\n\ - \ (while (and (> j 0) (before? (at s j) (at s (- j 1))))\n\ - \ (mswap-%s s (- j 1) j)\n\ - \ (set j (- j 1))))\n\ - \ (set i (+ i 1)))))\n\n" - t t t t t t t); - Buffer.add_string b (Printf.sprintf "(defonce xs-%s [8 %s])\n\n" t t) - done; - Buffer.add_string b "(defn main [] ()\n"; - for i = 0 to n - 1 do - Buffer.add_string b - (Printf.sprintf " (msort-%s (slice xs-%s 0 8) (fn [a b] (< a b)))\n" - tys.(i) tys.(i)) - done; - Buffer.add_string b " )\n"; - Buffer.contents b - -let write path s = - let oc = open_out path in output_string oc s; close_out oc - -let dir = - let d = Filename.concat (Filename.get_temp_dir_name ()) "flan-generics-spike" in - (try Unix.mkdir d 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()); - d - -let decls_of path = - (Flan.Load.program ~file:path - (Flan.Parse.program (Flan.Reader.read_file path))).Flan.Load.decls - -(* Every function the program ended up with whose name starts with one of the - generic names — the instantiations, which is exactly what a redefinition of - the generic would have to rebuild. *) -let instantiations (p : Flan.Tast.program) = - List.filter_map - (fun (f : Flan.Tast.fn) -> - let n = f.Flan.Tast.name in - if String.length n > 6 && String.sub n 0 6 = "gswap-" then Some n - else if String.length n > 6 && String.sub n 0 6 = "gsort-" then Some n - else None) - p.Flan.Tast.fns - -let build_ms ir = - let out = Filename.concat dir "redef.so" in - best 3 (fun () -> - ignore - (Flan.Build.shared - ~opts:{ Flan.Build.default with dev = true } ~ir ~out ())) - -let () = - Printf.printf - "n check-gen check-mono emit-1 emit-N build-1 build-N fns\n"; - (try - for n = 1 to 8 do - let gpath = Filename.concat dir (Printf.sprintf "gen%d.flan" n) in - let mpath = Filename.concat dir (Printf.sprintf "mono%d.flan" n) in - write gpath (generic_src n); - write mpath (mono_src n); - let gd = decls_of gpath and md = decls_of mpath in - let check_gen = best 3 (fun () -> ignore (Flan.Check.program_with_env gd)) in - let check_mono = best 3 (fun () -> ignore (Flan.Check.program_with_env md)) in - let p, _ = Flan.Check.program_with_env gd in - let insts = instantiations p in - let one = [ List.hd insts ] in - let ir_one = - Flan.Emit.redefinition ~dev:true ~known:(fun _ -> true) p ~fns:one - in - let ir_all = - Flan.Emit.redefinition ~dev:true ~known:(fun _ -> true) p ~fns:insts - in - let emit1 = - best 3 (fun () -> - ignore (Flan.Emit.redefinition ~dev:true ~known:(fun _ -> true) p ~fns:one)) - and emitn = - best 3 (fun () -> - ignore (Flan.Emit.redefinition ~dev:true ~known:(fun _ -> true) p ~fns:insts)) - in - let b1 = build_ms ir_one and bn = build_ms ir_all in - Printf.printf "%d %8.1f %10.1f %7.1f %7.1f %8.1f %8.1f %d\n%!" - n check_gen check_mono emit1 emitn b1 bn (List.length insts) - done - with Flan.Loc.Error d -> prerr_endline (Flan.Loc.report d); exit 1); - (* And what the session actually does when the generic itself is redefined. - This is the real C-c C-c path — Session.eval on the form the editor sent - — and what it reports is the finding, not the timing. *) - let gpath = Filename.concat dir "gen4.flan" in - let t, _ = Flan.Session.create ~file:gpath () in - let form = - "(defn gswap [xs [$t] i i32 j i32] ()\n\ - \ (let [tmp (at xs i)]\n\ - \ (set (at xs i) (at xs j))\n\ - \ (set (at xs j) tmp)))\n" - in - let c, ms = time (fun () -> Flan.Session.eval ~origin:gpath t form) in - Printf.printf - "\nSession.eval on the generic gswap itself: %.1f ms, installs=%b, \ - fns=[%s], names=[%s]\n" - ms c.Flan.Session.installs - (String.concat " " c.Flan.Session.fns) - (String.concat " " c.Flan.Session.names) diff --git a/spike/generics/prelude-shapes.flan b/spike/generics/prelude-shapes.flan deleted file mode 100644 index 519a737a..00000000 --- a/spike/generics/prelude-shapes.flan +++ /dev/null @@ -1,51 +0,0 @@ -;; Which of prelude.ml's per-type families collapse as they are written, and -;; which need their signature changed. Nothing here is installed in the -;; prelude; it is the same bodies, over $t, checked and run. - -(defn keep [s [$t] keep? (Fn [$t] bool)] (Vec $t) - (let [v (vec-new t)] - (dotimes [i (length s)] - (when (keep? (at s i)) - (push v (at s i)))) - v)) - -(defn apply! [s [$t] f (Fn [$t] $t)] () - (dotimes [i (length s)] - (set (at s i) (f (at s i))))) - -(defn fold [s [$t] init $t f (Fn [$t $t] $t)] t - (let [acc init] - (dotimes [i (length s)] - (set acc (f acc (at s i)))) - acc)) - -(defn flip! [s [$t]] () - (let [i 0 - j (- (length s) 1)] - (while (< i j) - (let [tmp (at s i)] - (set (at s i) (at s j)) - (set (at s j) tmp)) - (set i (+ i 1)) - (set j (- j 1))))) - -(defonce ns [5 i32]) -(defonce fs [5 f32]) - -(defn main [] () - (let [xs (slice ns 0 5) - ys (slice fs 0 5)] - (dotimes [i 5] - (set (at xs i) (+ i 1)) - (set (at ys i) (f32 (* 2 (+ i 1))))) - (apply! xs (fn [x] (* x 10))) - (apply! ys (fn [x] (* x (f32 2)))) - (flip! xs) - (flip! ys) - (println (fold xs 0 (fn [a b] (+ a b)))) - (println (fold ys (f32 0) (fn [a b] (+ a b)))) - (let [evens (keep xs (fn [x] (= (% x 20) 0)))] - (println (length evens)) - (free evens)) - (println (at xs 0)) - (println (at ys 0)))) diff --git a/spike/generics/reject.flan b/spike/generics/reject.flan deleted file mode 100644 index 8aeb7f96..00000000 --- a/spike/generics/reject.flan +++ /dev/null @@ -1,4 +0,0 @@ -(defn add2 [a $t b $t] t (+ a b)) - -(defn main [] () - (println (add2 1 2))) diff --git a/spike/generics/run.sh b/spike/generics/run.sh deleted file mode 100644 index 7771e36b..00000000 --- a/spike/generics/run.sh +++ /dev/null @@ -1,28 +0,0 @@ -#!/usr/bin/env bash -# The generics spike's measurement, driven by hand with ocamlfind against the -# flan.cmxa dune already builds — the same arrangement spike/backend uses, and -# for the same reason: nothing under spike/ is wired into the build, there is -# no dune file here, and `dune test --root .` cannot see any of it. -# -# The three .flan programs beside this file are run with the ordinary driver: -# dune exec --root . bin/main.exe -- run spike/generics/sort.flan -set -u -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -cd "$root" || exit 1 - -dune build --root . lib/flan.cmxa 2>&1 | head -20 - -out=$(mktemp -d); trap 'rm -rf "$out"' EXIT - -ocamlfind ocamlopt -thread -package unix,threads.posix -linkpkg \ - -I "$root/_build/default/lib/.flan.objs/byte" \ - -I "$root/_build/default/lib/.flan.objs/native" \ - -I "$out" -I "$here" \ - -o "$out/measure" \ - "$root/_build/default/lib/flan.cmxa" \ - -cclib -rdynamic -ccopt -L"$root/_build/default/lib" \ - "$here/measure.ml" 2>&1 | head -40 - -test -x "$out/measure" || { echo "build failed"; exit 1; } -"$out/measure" diff --git a/spike/generics/runaway.flan b/spike/generics/runaway.flan deleted file mode 100644 index 9423840a..00000000 --- a/spike/generics/runaway.flan +++ /dev/null @@ -1,3 +0,0 @@ -(defn grow [x $t] () - (grow [x x])) -(defn main [] () (grow 1)) diff --git a/spike/generics/sort.flan b/spike/generics/sort.flan deleted file mode 100644 index 632ed1bb..00000000 --- a/spike/generics/sort.flan +++ /dev/null @@ -1,25 +0,0 @@ -;; The shape prelude.ml's sort-i32-by! / sort-f32-by! pair would collapse into: -;; one generic body, the comparison passed in as a function value because an -;; unconstrained type variable has no < of its own. - -(defn swap! [xs [$t] i i32 j i32] () - (let [tmp (at xs i)] - (set (at xs i) (at xs j)) - (set (at xs j) tmp))) - -(defn sort-by! [s [$t] before? (Fn [$t $t] bool)] () - (let [i 1] - (while (< i (length s)) - (let [j i] - (while (and (> j 0) (before? (at s j) (at s (- j 1)))) - (swap! s (- j 1) j) - (set j (- j 1)))) - (set i (+ i 1))))) - -(defn main [] () - (let [ns [5 3 9 1] - fs [2.5 0.5 1.5]] - (sort-by! (slice ns 0 4) (fn [a b] (< a b))) - (sort-by! (slice fs 0 3) (fn [a b] (> a b))) - (dotimes [i 4] (println (at ns i))) - (dotimes [i 3] (println (at fs i))))) diff --git a/spike/generics/swap.flan b/spike/generics/swap.flan deleted file mode 100644 index 8d69ae4b..00000000 --- a/spike/generics/swap.flan +++ /dev/null @@ -1,19 +0,0 @@ -;; One generic function over one type variable, called at two concrete types -;; in one program. The sigil binds ($t), a bare use reads it (t). - -(defn swap! [xs [$t] i i32 j i32] () - (let [tmp (at xs i)] - (set (at xs i) (at xs j)) - (set (at xs j) tmp))) - -(defn main [] () - (let [ns [10 20 30] - fs [1.5 2.5 3.5]] - (swap! (slice ns 0 3) 0 2) - (swap! (slice fs 0 3) 0 1) - (swap! (slice ns 0 3) 1 2) - (println (at ns 0)) - (println (at ns 1)) - (println (at ns 2)) - (println (at fs 0)) - (println (at fs 1)))) diff --git a/spike/generics/two-vars.flan b/spike/generics/two-vars.flan deleted file mode 100644 index fe3b300a..00000000 --- a/spike/generics/two-vars.flan +++ /dev/null @@ -1,5 +0,0 @@ -(defn fst [a $t b $u] t a) -(defn main [] () - (println (fst 1 2.5)) - (println (fst true (i64 9))) - (println (fst 3 false))) diff --git a/spike/x86/COST.md b/spike/x86/COST.md deleted file mode 100644 index 1500e62e..00000000 --- a/spike/x86/COST.md +++ /dev/null @@ -1,210 +0,0 @@ -# What the hand-written x86-64 backend costs - -`survey.sh` has said for three handoffs that this backend agrees with LLVM on all 97 corpus programs it can build. -Item 7 of `docs/handoffs/HANDOFF-x86-rt.md` is the other half of that sentence — nobody had a number for what the agreement -costs — and it came with a list of suspects: a guard after every call, three frame temporaries per bounds check, -every intermediate in memory, `rep movsb` block copies, and an extra load per call site in a dev build. This is -the measurement. It does not change anything; two of the five suspects turn out not to matter, and the one that -matters most is not on the list. - -Produced by `spike/x86/cost.sh` (the corpus, for size) and `spike/x86/bench.sh` (four purpose-written programs, -for speed). Both are documented in their own headers. Machine: 16-core x86-64, Fedora, clang as the assembler and -linker on both sides, and other work running on it throughout — which is why every time below is the *minimum* of -five or seven runs and why nothing here rests on a difference of a few percent. - -The rows behind the tables are committed beside this file as `cost-corpus.tsv` and `cost-bench.tsv`, so a later -lane can recompute a ratio rather than believe one. - -## What is being compared, and against what - -The interesting column is not the size of the executable. A Flan binary is mostly `flan_rt.o` and libc glue, the -same object on both sides, and it drowns the signal: over the corpus the whole file is only **1.09×** bigger -through this backend and `.text` only **1.18×**, which would be a reassuring number and a meaningless one. - -So the measurement is the sum of the sizes of the defined symbols the compiler *named itself* — everything called -`flan.`. The runtime's C is `flan_` with an underscore, so the two never collide, and a -runtime symbol has the same size on both sides (`flan_map_clone`, `0x4b3` either way), which is the check that -says the difference really is codegen and not a differently-linked runtime. - -There is a third column, and it is what makes the second readable: **LLVM with `--debug`, which forces `-O0`**. -This backend has no optimiser at all, so measuring it against LLVM at `-O2` charges it for the whole of mem2reg, -inlining and constant folding. `-O0` is LLVM's instruction selection with none of that, which is the comparison -that says something about *this* backend rather than about the absence of a middle end. (`--x86 --debug` is -refused — the backend emits no DWARF — so the column exists on one side only. DWARF lands in `.debug_*` sections -and not in `.text`, checked, so it does not contaminate the symbol sums.) - -## The corpus: size - -Ninety-seven programs — the same set `survey.sh` matches on, minus the two that run forever. Summed over all of -them: - -| | LLVM -O2 | LLVM -O0 | x86 | -|---|---|---|---| -| own code, all 97 programs | 221,608 | 444,504 | 851,638 | -| against LLVM -O2 | 1.00× | 2.01× | **3.84×** | -| against LLVM -O0 | | 1.00× | **1.92×** | - -So the headline is two numbers, not one. **This backend emits 3.8× the code LLVM does at `-O2`, and half of that -factor is the optimiser Flan ships with rather than anything about the backend; against LLVM with the optimiser -off it is 1.9×.** Per program the second ratio is tight — median 2.21, quartiles 1.94 and 2.98, the whole range -1.32 to 5.44 — which is itself a finding: the cost is not a few bad nodes, it is a constant tax on everything. - -The ten largest programs, which are where the bytes actually are: - -| program | LLVM -O2 | LLVM -O0 | x86 | x86 / -O2 | x86 / -O0 | -|---|---|---|---|---|---| -| `strings` | 13,395 | 22,681 | 33,265 | 2.48× | 1.47× | -| `maps` | 12,833 | 19,850 | 40,445 | 3.15× | 2.04× | -| `edn` | 12,057 | 34,556 | 48,532 | 4.03× | 1.40× | -| `generics` | 10,137 | 20,427 | 39,241 | 3.87× | 1.92× | -| `slurp` | 9,744 | 14,813 | 24,656 | 2.53× | 1.66× | -| `into` | 8,277 | 12,345 | 21,320 | 2.58× | 1.73× | -| `vec` | 8,039 | 12,089 | 22,770 | 2.83× | 1.88× | -| `map-iter` | 7,211 | 10,374 | 21,715 | 3.01× | 2.09× | -| `algorithms` | 6,776 | 16,616 | 30,875 | 4.56× | 1.86× | -| `slices` | 2,393 | 9,057 | 17,753 | 7.42× | 1.96× | - -And the two ends of the distribution, both of which are more interesting than the middle: - -| program | LLVM -O2 | LLVM -O0 | x86 | x86 / -O2 | x86 / -O0 | why | -|---|---|---|---|---|---|---| -| `bounds` | 363 | 1,951 | 4,039 | **11.13×** | 2.07× | LLVM at `-O2` proves the indices and deletes the checks | -| `array-ctor` | 357 | 1,840 | 3,880 | 10.87× | 2.11× | the same, over a constructor's worth of stores | -| `p2-loop-print` | 283 | 106 | 577 | 2.04× | **5.44×** | a `-O0` build *smaller* than `-O2`: LLVM unrolls the five-iteration loop and `-O0` does not | -| `pkg-return` | 7,024 | 23,635 | 31,716 | 4.52× | 1.34× | mostly prelude, where `-O0` is already fat | - -`bounds` is the clearest case in the table of why the `-O0` column had to exist. Eleven times is a shocking -number and it is not about this backend at all: the program's whole point is indexing, LLVM at `-O2` can see the -indices are in range and removes the check, and neither LLVM at `-O0` nor this backend can. Against the compiler -that also keeps every check, `bounds` is 2.07× — a completely ordinary row. - -## Where the size goes - -Every one of these is from the disassembly of the benchmark programs, which are small enough to read whole. - -**Every intermediate goes through the frame, and so does every constant.** This is the big one and it is not one -feature, it is the shape of the whole backend. `(step acc 1)` in `b1-calls` compiles to: - - movabs $0x1,%rax ; a 10-byte immediate ... - mov %rax,-0x30(%rbp) ; ... stored to a frame slot ... - mov -0x30(%rbp),%rsi ; ... and loaded back into the argument register - -Three instructions and 24 bytes where LLVM writes `mov $1,%esi`, five. The loop bound gets the same treatment -*every iteration* — `movabs $0x1312d00` into a slot, sign-extended out of it, compared — because nothing is -hoisted. So does the loop condition: `cmp`/`setl`/`movzbq`/store a byte to the frame/reload it/`test`/`jne`, -seven instructions for what is `cmp`/`jge` anywhere else. This is most of the 2× against `-O0` and essentially -all of the difference on the programs at the bottom of the table, which have no calls, no bounds checks and no -aggregates in them at all. - -**The guard after every call is four instructions and one dependent load.** - - call 4009f8 - mov -0x18(%rbp),%r11 ; the condition frame, from its own slot - mov 0x0(%r11),%r11 ; ... dereferenced - test %r11,%r11 - jne - -Roughly 25 bytes per call site. Real, cheap, and third in size behind the two above it — on a program that is -nothing *but* calls (`b1`) the whole backend is 2.8× LLVM `-O0`, and the guard is a minority of that. - -**The bounds check is three frame temporaries, as suspected, and it costs code and not time.** The index is -widened, stored, reloaded, stored again, the limit goes to a third slot, and then `cmp`/`jb` — with the failure -path, its `.rodata` location string and its length, inline at the branch target. On `b2-bounds`, `flan.main` is -`0x4b1` with checks and `0x3c0` without: **241 bytes, a quarter of the function.** In time it is 112.6ms against -105.0ms over 20.5 million checked loads — **about 0.4ns, a cycle or two a check** — because the branch predicts -perfectly and the loads were going to memory anyway. That contradicts the way the handoff's list reads. The three -temporaries are a code-size item. They are not a speed item. - -**`rep movsb` is real and it is the most expensive single instruction here.** A 64-byte struct copy lowers to -`lea`/`lea`/`movabs $0x40,%rcx`/`rep movsb`, and `b4-copy` runs 2 million of them in 20.8ms against LLVM `-O0`'s -7.2ms: **about 6.8ns of the difference per copy, some twenty cycles**, which is `rep movsb`'s startup cost and -almost none of it the 64 bytes. It is also the one place where the backend loses to `-O0` by a factor (2.9×) it -does not lose by on straight-line code, and the one item on the suspect list where a targeted fix — inline -16-byte moves under some size threshold — would pay for itself. - -## The corpus: speed, and why there is barely any - -Almost nothing. **Every program in `test/programs` runs in about 2.5 milliseconds, nearly all of it `execve` and -the dynamic loader**, and both backends produce the same 2.5 milliseconds. Best-of-five does not rescue a signal -that is not there. There is exactly one corpus program whose own code is a measurable part of its runtime, and it -is the right one: - -| program | LLVM -O2 | LLVM -O0 | x86 | what it is | -|---|---|---|---|---| -| `recur` | ~1ms | 10ms | 60ms | a ten-million-iteration counting loop, written to prove `recur` is a jump | - -Read that carefully, because the 25× against `-O2` is not a fact about this backend: LLVM folds the loop to its -answer and runs nothing. Against `-O0`, which also runs ten million iterations, it is **6×** — about 6ns an -iteration against 1ns, or roughly eighteen cycles for `i+1` and a compare. That is the frame-slot round trip -above, four or five times over, and it is the honest number. - -## The benchmarks - -Four programs in `spike/x86/bench/`, each written so that one suspected cost is most of what the program does. -They are in a subdirectory on purpose: `survey.sh` globs `spike/x86/*.flan` and a benchmark is not a case. -Times are best-of-seven, in milliseconds. - -| bench | what it is | LLVM -O2 | LLVM -O0 | x86 | x86 / -O0 | own code, -O0 → x86 | -|---|---|---|---|---|---|---| -| `b1-calls` | 20M calls of a one-instruction function | 2.1 | 36.8 | 104.3 | 2.8× | 200 → 807 | -| `b2-bounds` | 20.5M bounds-checked array loads | 4.7 | 27.0 | 112.6 | 4.2× | 407 → 1390 | -| `b3-spill` | 5M iterations of a six-deep arithmetic tree | 22.2 | 29.0 | 137.3 | 4.7× | 248 → 1117 | -| `b4-copy` | 2M copies of a 64-byte struct | 2.0 | 7.2 | 20.8 | 2.9× | 348 → 877 | - -`b2` with `--no-bounds-checks` on both sides: LLVM 4.5ms, x86 105.0ms — the 7.6ms the check costs over 20.5 -million of them, and the 241 bytes it costs in `flan.main`, are the whole of it. - -`b3`'s ratio is the one to distrust slightly: its expression ends in a `%`, which is an `idiv`, and an `idiv` is -twenty-odd cycles on every side. That is most of LLVM's own 22.2ms and a good part of its 29.0ms, so the -denominator is largely a hardware latency this backend cannot do anything about. The absolute gap — 108ms over -5 million iterations, about 21ns of extra work each — is the honest reading of that row. - - - -`b1-calls` and `b3-spill` are the pair to read together, with the `idiv` caveat above in mind. `b1` is 20 million -calls of a one-instruction function and lands at 2.8× `-O0`; `b3` has no calls at all and pays 21ns an iteration -for six dependent arithmetic temporaries. **The backend is worse at arithmetic than it is at calling**, which is -the opposite of what the suspect list implies, and it is because a call already costs enough that four extra -instructions beside it disappear, while an add that should be one instruction costs five. `recur`, which is a -counting loop and nothing else, says the same thing on a corpus program: 6× LLVM `-O0`. - -The `-O2` column in `b1` and `b4` is 2ms — the loop is gone. That is a true fact about the toolchain Flan ships -and a useless one about code generation, which is the whole reason the `-O0` column exists. - -## `--dev`, which is the one axis both backends pay - -`SURVEY_FLAGS=--dev` reported 97 MATCH for the lane before this one, so the comparison is available. The suspected cost was the extra -load per call site — every cross-function call going through its indirection cell. **It is not measurable.** On -`b1-calls`, 20 million calls, x86 release is 104.3ms and x86 `--dev` is 100.9ms: the same number, and the dev -build is nominally the *faster* of the two, which is what a difference below the noise floor looks like. The load -is from a `.data` cell that is in L1 after the first call and the machine was already waiting on the frame. - -What a dev build actually costs is something else entirely, and both backends pay it. `b1-calls` is a program -with two functions in it: - -| build | own code | -|---|---| -| LLVM, release | 82 bytes | -| x86, release | 807 bytes | -| LLVM, `--dev` | 32,714 bytes | -| x86, `--dev` | 83,018 bytes | - -**A dev build emits the entire prelude**, because anything might be redefined and so nothing may be dropped. That -is four hundred times the code for this program, and it dwarfs every item on the suspect list put together. It is -also not a backend cost — LLVM pays a 400× of its own — so it is `Reach`'s business and not `x86.ml`'s. The -backend's share of it is the same ~2.5× it charges everywhere else. - -## What this says to the lane rewriting `lib/x86.ml` - -Ranked by what the numbers actually support, and not by the order of the list in the handoff: - -1. **Keep values in registers across a single expression.** Not a register allocator — just not routing every - constant and every subexpression through a frame slot, and not re-materialising a loop bound every iteration. - This is most of the 2× against `-O0` and most of `recur`'s 6×, and it is what `b3`'s 21ns an iteration buys. -2. **Inline small aggregate copies** instead of `rep movsb`. One instruction, twenty cycles, on a copy that is - four `movdqu` pairs. -3. **`flan_dev_reg_note` in a release build** (item 2 of the old handoff's list) is worth doing and is small. -4. **The call guard is fine.** Four instructions and 25 bytes, invisible in time. Leave it. -5. **The bounds check is fine on time and fat on code.** If it is ever worth touching, it is worth touching for - the 241 bytes — hoisting the failure path out of line would get most of that back without changing a cycle. -6. **The dev call cell is free.** Whatever the redefinition emitter costs, it does not cost this. diff --git a/spike/x86/annot.sh b/spike/x86/annot.sh deleted file mode 100755 index cb5991c6..00000000 --- a/spike/x86/annot.sh +++ /dev/null @@ -1,101 +0,0 @@ -#!/usr/bin/env bash -# Does annotation change a single byte of what the backend emits? -# -# `flan emit --x86` annotates: a comment per Flan form, a frame map per -# function, and a name for each piece of bookkeeping the compiler adds. All of -# that is comments, plus the splitting of one long `.byte` directive into -# several. Both are supposed to be invisible to the assembler -- and "supposed -# to be" is exactly the kind of claim this repo measures rather than asserts, -# because the whole licence for annotating at all is that the bytes are the -# bytes. -# -# So: emit every program in the corpus both ways, assemble both, and compare -# each section of the two objects byte for byte. No linking and no running -- -# survey.sh is what says the programs still behave, and this says nothing they -# are built from moved. -# -# Three settings, because they are three different emitters. The default; --dev, -# which adds the indirection cells and the ABI marker; and --debug, which adds -# the line table, the labels its rows hang off, and the CFI directives. The -# debug case is the sharp one: a `.debug_line` row is an address expressed as a -# label, and annotation emits no labels precisely so that those cannot move. -# -# Usage: spike/x86/annot.sh [name-substring ...] -set -u -orig=$(pwd) -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -cd "$root" || exit 1 - -if [ -n "${FLAN:-}" ]; then - case $FLAN in /*) flan=$FLAN;; *) flan=$orig/$FLAN;; esac -else - dune build --root . bin/main.exe 2>&1 | head -30 - flan=$root/_build/default/bin/main.exe -fi -test -x "$flan" || { echo "build failed"; exit 1; } - -corpus=${SURVEY_CORPUS:-$root} -tmp=$(mktemp -d "${TMPDIR:-/tmp}/flan-annot.XXXXXX") -trap 'rm -rf "$tmp"' EXIT - -same=0; differ=0; skip=0 - -# Every section either object has, not a fixed list: a section that exists on -# one side and not the other is itself a difference, and comparing a named list -# would miss one that annotation invented. -sections () { - objdump -h "$1" | awk '$1 ~ /^[0-9]+$/ { print $2 }' -} - -check () { - src=$1; shift - name=$(basename "$src" .flan) - tag="$name${*:+ $*}" - a=$tmp/a.s; b=$tmp/b.s - - if ! "$flan" emit --x86 "$@" "$src" > "$a" 2>"$tmp/err"; then - skip=$((skip + 1)); echo "SKIP $tag"; return - fi - if ! "$flan" emit --x86 --no-annotate "$@" "$src" > "$b" 2>/dev/null; then - skip=$((skip + 1)); echo "SKIP $tag"; return - fi - if ! as --64 -o "$tmp/a.o" "$a" 2>"$tmp/err"; then - differ=$((differ + 1)) - echo "BADASM $tag -- the annotated listing does not assemble" - head -3 "$tmp/err"; return - fi - if ! as --64 -o "$tmp/b.o" "$b" 2>/dev/null; then - skip=$((skip + 1)); echo "SKIP $tag"; return - fi - - bad= - for sec in $(sections "$tmp/a.o"; sections "$tmp/b.o"); do - case " $bad " in *" $sec "*) continue;; esac - objcopy -O binary --only-section="$sec" "$tmp/a.o" "$tmp/a.bin" 2>/dev/null - objcopy -O binary --only-section="$sec" "$tmp/b.o" "$tmp/b.bin" 2>/dev/null - cmp -s "$tmp/a.bin" "$tmp/b.bin" || bad="$bad $sec" - done - - if [ -z "$bad" ]; then - same=$((same + 1)); echo "SAME $tag" - else - differ=$((differ + 1)); echo "DIFFER $tag --$bad" - fi -} - -for src in "$corpus"/test/programs/*.flan "$corpus"/spike/x86/*.flan; do - [ -f "$src" ] || continue - if [ $# -gt 0 ]; then - hit= - for pat in "$@"; do case $src in *"$pat"*) hit=1;; esac; done - [ -n "$hit" ] || continue - fi - check "$src" - check "$src" --dev - check "$src" --debug -done - -echo -echo "$same SAME / $differ DIFFER / $skip SKIP" -[ "$differ" -eq 0 ] diff --git a/spike/x86/bench.sh b/spike/x86/bench.sh deleted file mode 100755 index 0899f150..00000000 --- a/spike/x86/bench.sh +++ /dev/null @@ -1,86 +0,0 @@ -#!/usr/bin/env bash -# The speed half of cost.sh, on programs that are long enough to time. -# -# Why this exists beside cost.sh rather than inside it: every program in -# test/programs runs in about two and a half milliseconds, of which nearly -# all is fork, exec and the dynamic loader. Best-of-five does not rescue a -# signal that is not there, and a table of 97 rows that all say "2.5ms vs -# 2.6ms" would be a measurement of execve. So the corpus answers the size -# question and these four answer the speed one, each written so that one -# suspected cost is most of what the program does. -# -# Four builds of each, and the third column is the one to read: -# -# llvm as shipped, -O2. Frequently the loop is simply gone; that is a -# true number about the toolchain and a useless one about codegen. -# llvm -O0 via --debug, which forces it. LLVM's instruction selection with -# its optimiser off -- the fair comparison for a backend that has -# no optimiser. -# x86 this backend. -# x86 nbc --no-bounds-checks, for b2, where the difference is the check. -# -# And --dev on both sides, which is the one suspected cost the two backends -# share: every cross-function call goes through an indirection cell, so it is -# a load and an indirect call where a release build has a direct one. b1 is -# where that has to show. -# -# Usage: spike/x86/bench.sh [name-substring ...] -set -u -orig=$(pwd) -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -cd "$root" || exit 1 - -if [ -n "${FLAN:-}" ]; then - case $FLAN in /*) flan=$FLAN;; *) flan=$orig/$FLAN;; esac -else - dune build --root . bin/main.exe 2>&1 | head -30 - flan=$root/_build/default/bin/main.exe -fi -test -x "$flan" || { echo "build failed" >&2; exit 1; } - -out=${COST_OUT:-${TMPDIR:-/tmp}/flan-bench.$$} -mkdir -p "$out" || exit 1 -trap 'rm -rf "$out"' EXIT - -REPS=${COST_REPS:-5} - -best () { - min= - for i in $(seq "$REPS"); do - t0=$(date +%s%N) - timeout 120 "$1" >/dev/null 2>&1 /dev/null \ - | awk 'NF==4 && ($3=="T"||$3=="t") && $4 ~ /^flan\./ {n+=strtonum("0x"$2)} END{print n+0}' -} - -printf 'name\tllvm_us\to0_us\tx86_us\tllvm_nbc_us\tx86_nbc_us\tllvm_dev_us\tx86_dev_us\tllvm_own\to0_own\tx86_own\tx86_dev_own\n' - -for src in "$root"/spike/x86/bench/*.flan; do - name=$(basename "$src" .flan) - if [ $# -gt 0 ]; then - want=0 - for pat in "$@"; do case "$name" in *"$pat"*) want=1;; esac; done - [ $want = 1 ] || continue - fi - "$flan" build "$src" -o "$out/l" >/dev/null 2>&1 || { echo "$name: llvm build failed" >&2; continue; } - "$flan" build "$src" --debug -o "$out/d" >/dev/null 2>&1 || { echo "$name: -O0 build failed" >&2; continue; } - "$flan" build "$src" --x86 -o "$out/x" >/dev/null 2>&1 || { echo "$name: x86 build failed" >&2; continue; } - "$flan" build "$src" --no-bounds-checks -o "$out/ln" >/dev/null 2>&1 - "$flan" build "$src" --x86 --no-bounds-checks -o "$out/xn" >/dev/null 2>&1 - "$flan" build "$src" --dev -o "$out/lv" >/dev/null 2>&1 - "$flan" build "$src" --x86 --dev -o "$out/xv" >/dev/null 2>&1 - printf '%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\n' "$name" \ - "$(best "$out/l")" "$(best "$out/d")" "$(best "$out/x")" \ - "$(best "$out/ln")" "$(best "$out/xn")" \ - "$(best "$out/lv")" "$(best "$out/xv")" \ - "$(own "$out/l")" "$(own "$out/d")" "$(own "$out/x")" "$(own "$out/xv")" -done diff --git a/spike/x86/bench/b1-calls.flan b/spike/x86/bench/b1-calls.flan deleted file mode 100644 index 2cf2f50c..00000000 --- a/spike/x86/bench/b1-calls.flan +++ /dev/null @@ -1,20 +0,0 @@ -;;;; A hot loop that does nothing but call. -;;;; -;;;; The suspected cost is the guard this backend emits after every call -- -;;;; and, in a dev build, the load of the indirection cell before it. Neither -;;;; is visible in the corpus, where a program's whole run is process startup. -;;;; Here the call is the program: the body is one add, so whatever separates -;;;; this from LLVM at -O0 is the call sequence and not the arithmetic. -;;;; -;;;; Not in spike/x86 proper, where survey.sh would pick it up: the survey's -;;;; counts are quoted in three handoffs and a benchmark is not a case. - -(defn step [a i64 b i64] i64 - (+ a b)) - -(defn main [] i32 - (let [acc (i64 0)] - (dotimes [i 20000000] - (set acc (step acc 1))) - (print acc) (println "")) - 0) diff --git a/spike/x86/bench/b2-bounds.flan b/spike/x86/bench/b2-bounds.flan deleted file mode 100644 index 3df3841e..00000000 --- a/spike/x86/bench/b2-bounds.flan +++ /dev/null @@ -1,20 +0,0 @@ -;;;; A hot loop that does nothing but index a bounds-checked array. -;;;; -;;;; The suspected cost is three frame temporaries per check. This one has an -;;;; A/B that the others do not: --no-bounds-checks builds the same program -;;;; with the check gone, on both sides, so the difference between the two -;;;; x86 numbers is the check and nothing else, and the same difference on -;;;; the LLVM side says what the check costs when a compiler is allowed to -;;;; hoist it out of the loop. - -(defonce xs [1024 i32]) - -(defn main [] i32 - (dotimes [i 1024] - (set (at xs i) i)) - (let [acc (i64 0)] - (dotimes [r 20000] - (dotimes [i 1024] - (set acc (+ acc (i64 (at xs i)))))) - (print acc) (println "")) - 0) diff --git a/spike/x86/bench/b3-spill.flan b/spike/x86/bench/b3-spill.flan deleted file mode 100644 index d0bdd9fd..00000000 --- a/spike/x86/bench/b3-spill.flan +++ /dev/null @@ -1,21 +0,0 @@ -;;;; A hot loop of arithmetic and nothing else: no calls, no arrays, no -;;;; copies. -;;;; -;;;; The suspected cost is that every intermediate lives in a frame slot -- -;;;; this backend allocates no registers, so an expression tree becomes a -;;;; chain of stores and reloads. The tree here is deliberately deep and -;;;; entirely dependent, so a register allocator would keep all of it in -;;;; registers and this backend cannot keep any of it. - -(defn main [] i32 - (let [acc (i64 1)] - (dotimes [i 5000000] - (let [a (+ acc 3) - b (* a 2) - c (- b 1) - d (bit-xor c 7) - e (+ d (* a 5)) - f (- e (bit-and d 15))] - (set acc (+ (% f 1000003) 1)))) - (print acc) (println "")) - 0) diff --git a/spike/x86/bench/b4-copy.flan b/spike/x86/bench/b4-copy.flan deleted file mode 100644 index 200c2452..00000000 --- a/spike/x86/bench/b4-copy.flan +++ /dev/null @@ -1,20 +0,0 @@ -;;;; A hot loop of struct copies. -;;;; -;;;; The suspected cost is `rep movsb`: this backend copies an aggregate by -;;;; block-moving bytes, where LLVM either keeps the thing in registers or -;;;; emits a handful of wide moves. Eight i64 fields is 64 bytes -- big -;;;; enough that a copy is a real copy, small enough that `rep movsb` is -;;;; paying its setup cost on every one of them, which is the shape the -;;;; instruction is worst at. - -(defstruct Big [a i64 b i64 c i64 d i64 e i64 f i64 g i64 h i64]) - -(defn main [] i32 - (let [acc (i64 0) - v (Big {.a 1 .b 2 .c 3 .d 4 .e 5 .f 6 .g 7 .h 8})] - (dotimes [i 2000000] - (let [w v] - (set (.a v) (+ (.h w) 1)) - (set acc (+ acc (.a w))))) - (print acc) (println "")) - 0) diff --git a/spike/x86/cost-bench.tsv b/spike/x86/cost-bench.tsv deleted file mode 100644 index a231e38d..00000000 --- a/spike/x86/cost-bench.tsv +++ /dev/null @@ -1,5 +0,0 @@ -name llvm_us o0_us x86_us llvm_nbc_us x86_nbc_us llvm_dev_us x86_dev_us llvm_own o0_own x86_own x86_dev_own -b1-calls 2108 36764 104266 1959 103336 26827 100874 82 200 807 83018 -b2-bounds 4711 27047 112567 4548 104951 4663 111295 355 407 1390 83596 -b3-spill 22184 28982 137347 22772 132053 22659 132913 168 248 1117 83323 -b4-copy 2043 7170 20792 1980 19559 2058 18497 140 348 877 83083 diff --git a/spike/x86/cost-corpus.tsv b/spike/x86/cost-corpus.tsv deleted file mode 100644 index d8b36d4c..00000000 --- a/spike/x86/cost-corpus.tsv +++ /dev/null @@ -1,98 +0,0 @@ -name llvm_file llvm_text llvm_own o0_own x86_file x86_text x86_own llvm_us x86_us -agent-longname 82224 42002 79 134 82264 42450 519 -1 -1 -agent-queue 82352 42306 340 567 86488 43698 1747 2491 2546 -agent 82336 42434 454 798 86472 44162 2218 2609 2496 -algorithms 76680 39282 6776 16616 101296 63234 30875 2499 2605 -allocators 67760 33650 1297 1719 71896 37490 5130 3170 3034 -array-ctor 67784 32722 357 1840 71920 36242 3880 2442 2664 -bounds-condition 76416 37074 4641 6963 84648 45858 13493 2673 2469 -bounds 67720 32738 363 1951 71856 36418 4039 3194 2654 -break 82296 42754 819 1182 86432 44482 2549 -1 -1 -bytes2 72120 37010 4576 10893 88544 52018 19654 2573 2510 -cleanup 68176 33986 1583 2077 72312 36946 4583 2351 2402 -conditions 68064 33586 1212 1209 68104 35346 2984 2436 2513 -debug-permuted 67720 32610 261 410 67760 33794 1433 2479 2442 -debug 67720 32610 261 429 67760 33794 1433 2494 2494 -defer-let 67928 34018 1625 1784 72064 36754 4396 2548 2543 -destructure 67792 33650 1290 4577 80120 40946 8583 2534 2523 -dev-break-bounds 82440 42546 588 648 86576 43762 1830 -1 -1 -dev-break 82368 42418 459 715 86504 43682 1755 -1 -1 -dev-globals 82456 42162 206 534 86584 43538 1614 -1 -1 -dev-inspect 82408 42610 652 704 86544 43698 1765 -1 -1 -dev-locals 82336 42418 465 623 86472 43650 1721 -1 -1 -dev-noagent 67720 32434 83 109 67760 32866 507 3116 2939 -dev-pause 82336 42066 112 244 82376 42802 877 -1 -1 -dev-ptr 86632 43954 1970 2859 90768 47490 5543 -1 -1 -dev-repl 82336 42066 112 244 82376 42802 877 -1 -1 -dev-robust 82336 42066 112 244 82376 42802 877 -1 -1 -edn 91208 44706 12057 34556 124016 80898 48532 3218 3165 -embed 67800 33330 977 2461 71936 37906 5550 2440 2650 -enum-compare 67752 32562 201 581 67792 33970 1611 2607 2805 -enum-convert 67752 33202 830 1522 71888 37042 4675 2737 2512 -error 67744 32498 131 163 67784 32946 591 2614 2587 -exhausted-unhandled 67688 33090 749 1156 67728 34850 2491 2442 2591 -exhausted 76192 35778 3415 5139 80336 42674 10321 2409 2469 -fn-values 68296 34226 1745 5124 80632 43026 10672 2405 2406 -format 76032 36802 4413 7076 84264 45394 13038 2449 2388 -frame-rollback 68440 34466 2020 3424 80768 39762 7402 2383 2394 -free-all-refused 67688 32370 28 28 67728 32658 299 2418 2497 -generics 81368 42786 10137 20427 114184 71602 39241 2474 2516 -handles 75880 35826 3482 6289 84112 46338 13981 2520 2470 -higher-order 76648 37154 4652 10329 88976 51314 18948 2413 2439 -into 80256 40658 8277 12345 92584 53682 21320 2428 2412 -loops 67736 33378 1016 1720 71872 37634 5269 2370 2315 -machine 67960 33186 821 1925 72096 37394 5042 2515 2456 -macro-unless 67720 32642 288 615 67760 34610 2243 2466 2457 -macros 67688 32802 461 793 67728 35250 2896 2532 2409 -map-exhausted 76152 36162 3805 5994 84392 44530 12171 2393 2506 -map-iter 76096 39586 7211 10374 92520 54082 21715 2541 2531 -map-stale-region 67688 33650 1307 2106 71824 36898 4537 2354 2407 -maps 88504 45266 12833 19850 117216 72802 40445 3162 3082 -math 67832 33986 1611 3288 72024 39362 7000 2384 2405 -math2 67784 33506 1148 2862 72024 39010 6644 2300 2482 -pkg-diamond 67880 32626 252 616 67928 34162 1801 2353 2227 -pkg-macro-idle 67688 32338 3 3 67728 32562 210 2440 2410 -pkg-macro 67800 32722 354 450 67840 33986 1626 2455 2429 -pkg-return 78416 39570 7024 23635 103032 64082 31716 2432 2375 -pkg-shadow 67848 32642 277 371 67888 33618 1258 2408 2236 -pkg-shared 74560 34066 1676 5593 86888 45650 13283 2422 2648 -pkg-unused 69704 32386 35 35 69744 34658 2298 2351 2271 -pool-stale-region 67688 33282 932 1675 71824 35746 3379 2389 2466 -printers 82464 42098 168 452 82504 43282 1348 -1 -1 -println 76256 36098 3737 7587 88584 50114 17753 2312 2460 -raylib-audio 79536 35522 2478 5610 87768 44178 11225 2574 2769 -raylib-ffi 85848 39538 6245 11506 102272 55650 22537 2607 2852 -raylib-font 79088 35538 2622 6260 83232 43186 10350 2661 2658 -raylib-image 80152 37698 4504 8285 88384 47058 13966 2684 2946 -raylib-imported 70344 33202 612 1003 74480 36658 4066 2688 2602 -reach-walk 67992 33170 774 1082 68032 34802 2443 2552 2308 -recur 67792 34594 2233 4070 76024 40674 8314 2468 62674 -registry 72008 35330 2940 4604 80240 41010 8608 2515 2329 -reload-generic 67944 32930 520 1390 67992 35442 3076 2341 2241 -restarts 77200 39010 6430 9268 89528 49442 17065 2356 2304 -rl-with 69704 32386 35 35 69744 34658 2298 2550 2461 -sand-headless 74728 34546 2139 6326 87056 47634 15269 2783 9172 -signedness 67688 32594 246 386 67728 33938 1576 2418 2411 -slice-from-ptr 67752 33106 755 2549 75984 37458 5101 2421 2367 -slices 68128 34802 2393 9057 88648 50114 17753 2504 2271 -slurp-unhandled 67688 33522 1173 1601 67728 35298 2945 2340 2354 -slurp 80288 42114 9744 14813 100808 57010 24656 2358 2408 -stale-region 67688 33490 1148 1681 71824 35842 3483 2332 2286 -string-of-bytes 67856 33490 981 1925 71992 36338 3817 2319 2353 -strings 88912 45890 13395 22681 109432 65618 33265 2455 2391 -text 72296 37122 4666 8007 84624 49378 17018 2310 2397 -unions 76016 36498 4131 17714 92440 55810 23456 2323 2413 -unit-main 67688 32386 33 33 67728 32674 307 2459 2377 -utf8 81216 39714 7170 21515 114024 73106 40745 2563 2380 -values 67720 32530 180 667 67760 34082 1719 2531 2378 -vec 80080 40402 8039 12089 92408 55122 22770 2370 2389 -virtual-controls-headless 70896 33666 1271 1295 75032 38962 6601 2319 3201 -web-files 67736 33058 706 1000 67776 34610 2246 2321 2382 -p1-exit 67688 32338 3 3 67728 32562 210 2436 2377 -p2-loop-print 67688 32626 283 106 67728 32930 577 2269 2364 -p3-fizz 67720 32530 169 225 67760 33282 928 2512 2359 -p4-convention 67824 32786 405 1005 67864 35138 2778 2436 2332 -p5-core 67792 33346 993 1507 71928 37218 4865 2346 2444 -p6-transfer 68096 34354 1944 2801 72232 37618 5252 2386 2310 -p7-slice-from-ptr 67840 33698 1336 1498 71984 35682 3318 2493 2392 -p8-cell 67752 32514 146 270 67800 33202 847 2402 2381 diff --git a/spike/x86/cost.sh b/spike/x86/cost.sh deleted file mode 100755 index 59fba226..00000000 --- a/spike/x86/cost.sh +++ /dev/null @@ -1,135 +0,0 @@ -#!/usr/bin/env bash -# What does the hand-written backend cost, against LLVM, on the same programs? -# -# survey.sh answers "does it agree". This answers "what does agreeing cost", -# which is item 7 of docs/handoffs/HANDOFF-x86-rt.md and the one thing about this backend -# nobody had a number for. It builds each program the same two ways the -# survey does, and for each records three sizes and a time: -# -# file the whole executable on disk. Mostly runtime and libc glue, and -# the least interesting of the three -- it is here because it is -# the number anybody looks at first, and it should be visible how -# much of it is noise. -# text the .text section, from `size -A`. Still contains flan_rt.o, -# which is the same object on both sides. -# own the sum of the sizes of the defined symbols named `flan.` -# -- the program's *own* code and nothing else. The runtime's C is -# `flan_` with an underscore, so the two do not collide, and -# spot-checking a runtime symbol on both sides (flan_map_clone, -# 0x4b3 either way) says the runtime really is byte-identical and -# the difference in `own` is all codegen. -# -# The `own` column is the measurement; the other two are context. -# -# A fourth build, LLVM with --debug, is the reference that makes the number -# readable. --debug forces -O0, so it is LLVM's codegen with its optimiser -# switched off -- the closest thing available to what this backend is doing, -# which has no optimiser at all. Without it every ratio silently blames the -# backend for the whole of mem2reg and inlining. (--x86 --debug is refused, -# so the column exists on one side only, and that is the point of it.) -# -# Time is best-of-N, not a mean: a mean measures the other tenants of the -# machine. Even so, a corpus program is mostly process startup -- these are -# milliseconds -- so read the time column only where it is tens of -# milliseconds or more, and read the rest as size. -# -# Usage: spike/x86/cost.sh [name-substring ...] -> a TSV on stdout -# COST_FLAGS=--dev extra flags, given to both sides, as SURVEY_FLAGS is -# COST_REPS=5 timing repetitions -# COST_O0=0 skip the LLVM -O0 reference column -set -u -orig=$(pwd) -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -cd "$root" || exit 1 - -if [ -n "${FLAN:-}" ]; then - case $FLAN in /*) flan=$FLAN;; *) flan=$orig/$FLAN;; esac -else - dune build --root . bin/main.exe 2>&1 | head -30 - flan=$root/_build/default/bin/main.exe -fi -test -x "$flan" || { echo "build failed" >&2; exit 1; } - -# Not mktemp under /tmp by default: this writes a few hundred executables of -# a megabyte or two, and a full /tmp on this machine has already frozen one -# session. The guard is cheap and a wedged run is not. -# A directory of this run's own, made with a plain mkdir so that a second -# copy of this script cannot land in the first one's: two runs sharing a -# scratch directory overwrite each other's `l` and `x` between the build and -# the timing, and the result is a row of numbers that belong to two different -# programs. That happened once here and the numbers looked entirely ordinary. -work=${COST_OUT:-${TMPDIR:-/tmp}/flan-cost} -mkdir -p "$work" || exit 1 -out=$work/run.$$ -mkdir "$out" || exit 1 -trap 'rm -rf "$out"' EXIT -free=$(df -Pk "$out" | awk 'NR==2 {print $4}') -[ "$free" -gt 2000000 ] || { echo "less than 2GB free at $out" >&2; exit 1; } - -forever="dev-loop dev-watch" -REPS=${COST_REPS:-5} -read -r -a extra <<<"${COST_FLAGS:-}" -o0=${COST_O0:-1} -[ -z "${COST_FLAGS:-}" ] || o0=0 - -# The sum of the defined text symbols the compiler itself named. `nm -S` -# prints value, size, type, name; a symbol with no size is not printed with -# four fields at all, which is why the guard is on NF. -own () { - nm --defined-only -S "$1" 2>/dev/null \ - | awk 'NF==4 && ($3=="T"||$3=="t") && $4 ~ /^flan\./ {n+=strtonum("0x"$2)} END{print n+0}' -} -text () { size -A "$1" 2>/dev/null | awk '$1==".text" {print $2}'; } - -# Best of REPS, in whole microseconds. A program that fails on one run and -# not another would make this meaningless, so the exit status of the first -# run is remembered and a run that disagrees with it poisons the row as -1. -# A program that hits the timeout is not timed at all: several of the corpus -# programs are agents or daemons that sit waiting for something that is not -# there, and five repetitions of a twenty-second wait, twice, is most of an -# afternoon spent measuring `timeout`. -best () { - exe=$1; min=; rc0= - for i in $(seq "$REPS"); do - t0=$(date +%s%N) - ( cd "$out" && timeout 20 "$exe" >/dev/null 2>&1 /dev/null 2>&1 || continue - # No main is a link failure, and it leaves nothing behind to measure. - test -x "$out/l" || continue - "$flan" build "$src" --x86 "${extra[@]}" -o "$out/x" >/dev/null 2>&1 || continue - test -x "$out/x" || continue - - d0=0 - if [ "$o0" = 1 ] && "$flan" build "$src" --debug -o "$out/d" >/dev/null 2>&1; then - d0=$(own "$out/d") - fi - - printf '%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\n' "$name" \ - "$(stat -c %s "$out/l")" "$(text "$out/l")" "$(own "$out/l")" "$d0" \ - "$(stat -c %s "$out/x")" "$(text "$out/x")" "$(own "$out/x")" \ - "$(best "$out/l")" "$(best "$out/x")" -done diff --git a/spike/x86/cell-override.c b/test/cell-override.c similarity index 94% rename from spike/x86/cell-override.c rename to test/cell-override.c index 98be2686..d9c8a3d4 100644 --- a/spike/x86/cell-override.c +++ b/test/cell-override.c @@ -13,7 +13,7 @@ * * A release build has no cells, dlsym answers NULL, and this does nothing -- * which is the control: it shows the change below comes from the indirection - * and not from ordinary symbol interposition. See spike/x86/cells.sh. + * and not from ordinary symbol interposition. See test/cells.sh. */ #define _GNU_SOURCE #include diff --git a/spike/x86/cells.sh b/test/cells.sh similarity index 97% rename from spike/x86/cells.sh rename to test/cells.sh index 81c1d4f2..3935df90 100755 --- a/spike/x86/cells.sh +++ b/test/cells.sh @@ -23,7 +23,7 @@ # from ordinary symbol interposition. set -u here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) +root=$(cd "$here/.." && pwd) # FLAN overrides the compiler, and when it is set nothing is built here. The # @cells alias sets it, because a dune action that shells out to dune waits on a # lock it cannot get; main.exe is in that rule's deps instead. Resolved to an @@ -47,7 +47,7 @@ test -x "$flan" || { echo "no compiler at $flan"; exit 1; } out=$(mktemp -d); trap 'rm -rf "$out"' EXIT cc -shared -fPIC -o "$out/override.so" "$here/cell-override.c" || exit 1 -src=$here/p8-cell.flan +src=$here/programs/x86-p8-cell.flan fail=0 run() { # run