JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

The collector walks Map storage, arrays of strings or structs are map keys, map-keys and map-values are prelude generics, and spike/ is gone

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 16:10:38 +07:00
commit 78261fccda
111 changed files with 863 additions and 3240 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
TODO.org
View File

@ -522,7 +522,7 @@ Func, Fnptr.
CLOSED: [2026-09-25] CLOSED: [2026-09-25]
Only a capturing =fn= that may outlive its frame gets a collector environment; one 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. 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. tag bit on the environment word and a heap environment for every closure.
** WAIT CFn and C's calling convention ** 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 actually occur are lexical can now be answered. The next thing to look at, not the
next thing to build. 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 ** DONE (vec-new [u8]) is refused
CLOSED: [2026-09-25] CLOSED: [2026-09-25]
The type positions of =vec-new= and =map-new= take a type expression: brackets, or 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] 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. =[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 ** TODO (slice d 1) over a dyn vec traps where the typed Vec's works
The typed and dyn spaces disagree about a spelling, which the standing rule A text slices to a copy, which is the typed view's meaning because a text is
forbids. A dyn slice should exist. 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 ** 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 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 LLVM build down to stderr. =docs/BUILT.md=, "The hand-written x86 backend, and
the four measurements behind it", is the account. 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 ** DONE Reading (uninit) before writing it is undefined behaviour
CLOSED: [2026-09-25] 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. 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 same read is reported. The two stay two claims — different tools reaching
different people. 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. 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 WAIT on the between-batches sweep slot: the switches are
runtime's design and a leak check produces a suppression list. A green sweep =ASAN_OPTIONS=detect_leaks=1 dune build @sanitize= and =FLAN_LEAKS=1 dune build @valgrind=.
therefore says nothing about who frees the newly allocating =(bytes s)=. Worth A 22-program LSan sample found no runtime leak; program leaks in map-remove and
asking on purpose one day, across the whole corpus and not one program. 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 ** DONE trap_oom has no site
CLOSED: [2026-09-25] CLOSED: [2026-09-25]

2
docs/BUGS-2026-09-18.md
View File

@ -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 `bits-1` explicitly (TODO.org, "A shift count is bounded two different ways", records
this as the language's rule). Six this as the language's rule). Six
confirmed divergences, e.g. `(<< x 32)` on i32: LLVM 1, x86 0; `(>> i8min 8)`: LLVM 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. 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` 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 gives 0 on x86 (64-bit `cvttsd2si` then truncate) vs INT_MIN on LLVM. Acknowledged-UB

25
docs/BUILT.md
View File

@ -1265,8 +1265,8 @@ looked wrong.
### Proved by comparing output, never by reading bytes ### 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 `test/survey-x86.sh` builds each program in `test/programs`, the `x86-p*` probes among them, twice — once through LLVM
`--x86`, **with the same bounds-check setting on both sides** — runs both, and compares stdout, stderr and the exit 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 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 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. 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 **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 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 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 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 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 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 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. 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 `-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; 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 `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. 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 **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. 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 `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. 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 #### 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 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 sources driving `ocamlfind` and `clang` by hand against the `flan.cmxa` dune already builds, deleted since and kept in
wired into the build. What it answered is why the shape above was safe to commit to. 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 **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 `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 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 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 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. 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, **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 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. 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 `Map`'s values are walked the same way** (`fn-in-map.flan`). A descriptor's `maps` table names each `Map` header
A bare `Fn` field, global or array element is still refused for its zero; `(Option (Fn ...))` holds one. 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 **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 code, so making one counts toward the same gate a string literal does. A capturing `fn` typed at the dev prompt takes

1
docs/SPIKE-GENERICS.md
View File

@ -10,6 +10,7 @@
> and nested inside `[$t]` or `(Option $t)`, and bare `t` only where a type's *name* is an argument in > 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. > 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. > 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 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 decision. **Feasible, and smaller than expected.** A generic function written in Flan goes through the ordinary

2
docs/handoffs/HANDOFF-arith.md
View File

@ -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 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. `-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` `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 overflow is where the two backends disagreed *silently* rather than both dying, and it is the only thing that

4
docs/handoffs/HANDOFF-cimport-ptr.md
View File

@ -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 `defstruct`, every hand-written `declare-c` and every mapped constant against
`raylib-5.5.h` and refuses to write when they disagree. `raylib-5.5.h` and refuses to write when they disagree.
- `bash web/examples/check.sh` green. - `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 — 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 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 changed is `test/programs/raylib-codepoints.flan`. Run it detached — `setsid timeout
2400 spike/x86/survey.sh > log 2>&1 </dev/null` — because a foreground run takes the 2400 test/survey-x86.sh > log 2>&1 </dev/null` — because a foreground run takes the
signal sent to its process group and returns a spurious 143. signal sent to its process group and returns a spurious 143.
## Still open ## Still open

4
docs/handoffs/HANDOFF-devtest-noise.md
View File

@ -98,9 +98,9 @@ should be reading on a green run.
Baseline not regressed, all three measured after the change: Baseline not regressed, all three measured after the change:
- `dune test --root .` — exit 0. - `dune test --root .` — exit 0.
- `spike/x86/survey.sh` — **101 MATCH / 0 DIFFER / 0 REFUSED / 0 NOX86**, 36 skipped (28 does-not-compile, 6 no-main, - `test/survey-x86.sh` — **101 MATCH / 0 DIFFER / 0 REFUSED / 0 NOX86**, 36 skipped (28 does-not-compile, 6 no-main,
2 runs-forever). 2 runs-forever).
- `spike/x86/cells.sh` — **4/4**, exit 0. - `test/cells.sh` — **4/4**, exit 0.
One thing not to re-derive: a first attempt at the survey came back `SURVEY_EXIT=143` with a bare `Terminated`. That One thing not to re-derive: a first attempt at the survey came back `SURVEY_EXIT=143` with a bare `Terminated`. That
was the harness killing the process group of a long background command, not a survey failure and nothing to do with was the harness killing the process group of a long background command, not a survey failure and nothing to do with

4
docs/handoffs/HANDOFF-emacs-flake.md
View File

@ -134,8 +134,8 @@ reason. The 600s watchdogs are what actually bound the run.
- `dune test --root .` — three runs, 232 checks, 0 failures, exit 0 each time. - `dune test --root .` — three runs, 232 checks, 0 failures, exit 0 each time.
All three under sixteen busy loops; two of them alongside a running All three under sixteen busy loops; two of them alongside a running
`spike/x86/survey.sh`. `test/survey-x86.sh`.
- `spike/x86/survey.sh` — 103 MATCH / 0 DIFFER / 0 REFUSED. - `test/survey-x86.sh` — 103 MATCH / 0 DIFFER / 0 REFUSED.
## Open questions for the author ## Open questions for the author

2
docs/handoffs/HANDOFF-lowering-buffer.md
View File

@ -2,7 +2,7 @@
Branch `dev-loop`, worktree `agent-a9d4028fa5752ba39`, from `f772162`. Branch `dev-loop`, worktree `agent-a9d4028fa5752ba39`, from `f772162`.
`spike/x86/dump.sh` landed at `f772162` and prints four lowerings of one function side by side: the LLVM IR `tools/dump.sh` landed at `f772162` and 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. 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. A shell script that prints all four Reading one against another is the only way to check a lowering by eye. A shell script that prints all four
into a scrollback is not how anyone reads them, though: three of the four are noise on any given day, and the into a scrollback is not how anyone reads them, though: three of the four are noise on any given day, and the

8
docs/handoffs/HANDOFF-rot.md
View File

@ -1,7 +1,7 @@
# The checks nobody runs # The checks nobody runs
Twice now a script in this repository has been quietly wrong for weeks, and both Twice now a script in this repository has been quietly wrong for weeks, and both
times it was found by accident rather than by anything failing. `spike/x86/survey.sh` times it was found by accident rather than by anything failing. `test/survey-x86.sh`
had two programs refused by name for about a month. `web/examples/check.sh` had been had two programs refused by name for about a month. `web/examples/check.sh` had been
red since September 12th. This is the inventory of everything in the tree that red since September 12th. This is the inventory of everything in the tree that
asserts something and is not reached by `dune test`, what each one says today, and asserts something and is not reached by `dune test`, what each one says today, and
@ -18,8 +18,8 @@ Everything executable or fixture-shaped outside `dune test`, run rather than ass
|---|---|---|---| |---|---|---|---|
| `web/examples/check.sh` | each `web/examples/*.flan` against the `.out` beside it, plus `flan shim` on shimdemo and a killed `--dev` build of breakdemo | now `@page` | **passes**, 21 checks | | `web/examples/check.sh` | each `web/examples/*.flan` against the `.out` beside it, plus `flan shim` on shimdemo and a killed `--dev` build of breakdemo | now `@page` | **passes**, 21 checks |
| `web/examples/quotes.sh` | every block on `index.html` that is not a program — usage text, refusal messages, the LLVM excerpt, the renderer's output, the Emacs keys — re-derived and looked for on the page | now `@page` | **was red, 11 of 42**; fixed, now passes | | `web/examples/quotes.sh` | every block on `index.html` that is not a program — usage text, refusal messages, the LLVM excerpt, the renderer's output, the Emacs keys — re-derived and looked for on the page | now `@page` | **was red, 11 of 42**; fixed, now passes |
| `spike/x86/survey.sh` | stdout, stderr and exit status of every corpus program, x86 backend against LLVM | `@x86`, and by hand | **passes**, 103 match / 0 differ / 0 refused / 38 skip | | `test/survey-x86.sh` | stdout, stderr and exit status of every corpus program, x86 backend against LLVM | `@x86`, and by hand | **passes**, 103 match / 0 differ / 0 refused / 38 skip |
| `spike/x86/cells.sh` | a `--dev` build really calls through its indirection cell: an `LD_PRELOAD`ed constructor stores a different body, four builds, `22 22` against `42 42` | nothing — now `@cells` | **passes**, 4 checks | | `test/cells.sh` | a `--dev` build really calls through its indirection cell: an `LD_PRELOAD`ed constructor stores a different body, four builds, `22 22` against `42 42` | nothing — now `@cells` | **passes**, 4 checks |
| `tools/colon-to-dot.py --check` | every `.flan` uses the dot spelling for field labels | nothing | **reports 20 hits, all false.** See below — this one is a hazard, not a check | | `tools/colon-to-dot.py --check` | every `.flan` uses the dot spelling for field labels | nothing | **reports 20 hits, all false.** See below — this one is a hazard, not a check |
| `tools/unit-return.py --check` | every `defn` states a return type, `Unit` spelled `()` | nothing | **reports 30 hits, all false.** Same hazard | | `tools/unit-return.py --check` | every `defn` states a return type, `Unit` spelled `()` | nothing | **reports 30 hits, all false.** Same hazard |
| `emacs/test-flan-dape.el` | dape driving lldb-dap sets a breakpoint from a `.flan` buffer and reports Flan frames | nothing loads it | **cannot run here** — `require 'dape` fails, dape is not installed. Its own header says it is out of `dune test` on purpose | | `emacs/test-flan-dape.el` | dape driving lldb-dap sets a breakpoint from a `.flan` buffer and reports Flan frames | nothing loads it | **cannot run here** — `require 'dape` fails, dape is not installed. Its own header says it is out of `dune test` on purpose |
@ -131,7 +131,7 @@ gone stale, not when the compiler has regressed, and a suite that goes red becau
prose drifted teaches whoever runs it to skim past red. `dune test` should mean "the prose drifted teaches whoever runs it to skim past red. `dune test` should mean "the
language broke". `@page` should mean "the page is lying". language broke". `@page` should mean "the page is lying".
**`@cells`** runs `spike/x86/cells.sh`, which was a real four-check pass/fail script **`@cells`** runs `test/cells.sh`, which was a real four-check pass/fail script
that nothing in the tree ran. It is not folded into `@x86` because it asks a different that nothing in the tree ran. It is not folded into `@x86` because it asks a different
question: the survey asks whether the backend agrees with LLVM about what a program question: the survey asks whether the backend agrees with LLVM about what a program
prints, and no program can answer this one, because a dev build starts with every cell prints, and no program can answer this one, because a dev build starts with every cell

2
docs/handoffs/HANDOFF-tidy.md
View File

@ -96,7 +96,7 @@ everything else explains itself. They are grouped and explained now, and
- `dune build --root .` exits 0. - `dune build --root .` exits 0.
- `dune test --root . --force` reports 232 checks, 0 failures. - `dune test --root . --force` reports 232 checks, 0 failures.
- `spike/x86/survey.sh`, run detached, reports 103 MATCH, 0 DIFFER, 0 REFUSED, - `test/survey-x86.sh`, run detached, reports 103 MATCH, 0 DIFFER, 0 REFUSED,
0 NOX86 and 38 SKIP — the baseline, unchanged. 0 NOX86 and 38 SKIP — the baseline, unchanged.
The resolver reports sixteen unresolved citations and all sixteen are expected. The resolver reports sixteen unresolved citations and all sixteen are expected.

6
docs/handoffs/HANDOFF-x86-abi-marker.md
View File

@ -149,9 +149,9 @@ merely intended, and these two crossed tests are what will catch a half-done ver
| | before | after | | | before | after |
|---|---|---| |---|---|---|
| `spike/x86/survey.sh` | 103 MATCH / 0 DIFFER / 0 REFUSED / 0 NOX86 | **103 / 0 / 0 / 0** | | `test/survey-x86.sh` | 103 MATCH / 0 DIFFER / 0 REFUSED / 0 NOX86 | **103 / 0 / 0 / 0** |
| skip breakdown | 28 does-not-compile / 8 no-main / 2 runs-forever | **28 / 8 / 2** | | skip breakdown | 28 does-not-compile / 8 no-main / 2 runs-forever | **28 / 8 / 2** |
| `spike/x86/cells.sh` | 4/4 ok | **4/4 ok** | | `test/cells.sh` | 4/4 ok | **4/4 ok** |
| `dune test --root .` | exit 0, 232 checks, 0 failures | **exit 0, 232 checks, 0 failures** | | `dune test --root .` | exit 0, 232 checks, 0 failures | **exit 0, 232 checks, 0 failures** |
The survey is the measurement that could have moved and did not, which is the point of running it: both The survey is the measurement that could have moved and did not, which is the point of running it: both
@ -159,7 +159,7 @@ backends now emit a symbol into every `--dev` build, and the survey's default is
so an unguarded marker would have shown up as 103 identical-but-different objects rather than as a wrong so an unguarded marker would have shown up as 103 identical-but-different objects rather than as a wrong
answer. It agrees byte-for-byte on what the programs print. answer. It agrees byte-for-byte on what the programs print.
Run it detached — `setsid timeout 2400 spike/x86/survey.sh > log 2>&1 </dev/null` — or a signal to this Run it detached — `setsid timeout 2400 test/survey-x86.sh > log 2>&1 </dev/null` — or a signal to this
harness's process group comes back as `SURVEY_EXIT=143`, which is not a result. The log is block-buffered harness's process group comes back as `SURVEY_EXIT=143`, which is not a result. The log is block-buffered
through the redirect and stays empty until the end; that is not a hang. through the redirect and stays empty until the end; that is not a hang.

4
docs/handoffs/HANDOFF-x86-aggregates.md
View File

@ -138,9 +138,9 @@ together, the marker is what makes the choice checkable rather than merely inten
| | before | after | | | before | after |
|---|---|---| |---|---|---|
| `spike/x86/survey.sh` | 99 MATCH / 0 DIFFER / 0 REFUSED / 0 NOX86 | **99 / 0 / 0 / 0** | | `test/survey-x86.sh` | 99 MATCH / 0 DIFFER / 0 REFUSED / 0 NOX86 | **99 / 0 / 0 / 0** |
| skip breakdown | 28 does-not-compile / 6 no-main / 2 runs-forever | 28 / **8** / 2 | | skip breakdown | 28 does-not-compile / 6 no-main / 2 runs-forever | 28 / **8** / 2 |
| `spike/x86/cells.sh` | 4/4 ok | **4/4 ok** | | `test/cells.sh` | 4/4 ok | **4/4 ok** |
| `dune test --root .` | exit 0 | **exit 0** | | `dune test --root .` | exit 0 | **exit 0** |
The `no-main` count moving from 6 to 8 is the two new fixtures existing: `survey.sh` globs The `no-main` count moving from 6 to 8 is the two new fixtures existing: `survey.sh` globs

8
docs/handoffs/HANDOFF-x86-annotate.md
View File

@ -19,7 +19,7 @@ compiler adds has a name where it appears and an explanation once, in a legend a
| `lib/x86.ml` | the annotation machinery: a queue of pending comments on `buf`, the per-form hook in `lower`, `frame_map`, the bookkeeping `note`s, and the legend | | `lib/x86.ml` | the annotation machinery: a queue of pending comments on `buf`, the per-form hook in `lower`, `frame_map`, the bookkeeping `note`s, and the legend |
| `bin/main.ml` | `emit --x86` annotates; `--no-annotate` is the bare spelling | | `bin/main.ml` | `emit --x86` annotates; `--no-annotate` is the bare spelling |
| `spike/x86/annot.sh` | **new** — emits every program in the corpus both ways, assembles both, and compares every section of the two objects byte for byte, in all three of default, `--dev` and `--debug` | | `spike/x86/annot.sh` | **new** — emits every program in the corpus both ways, assembles both, and compares every section of the two objects byte for byte, in all three of default, `--dev` and `--debug` |
| `spike/x86/dump.sh` | its x86 section now shows the annotated listing *and* the disassembly of the object that listing assembles to — why beside what | | `tools/dump.sh` | its x86 section now shows the annotated listing *and* the disassembly of the object that listing assembles to — why beside what |
`lib/build.ml` was not touched. A `--x86` build emits exactly the assembly it emitted before. `lib/build.ml` was not touched. A `--x86` build emits exactly the assembly it emitted before.
@ -102,7 +102,7 @@ transfer exit and C's `main` carry a prose block each.
## A worked sample ## A worked sample
`spike/x86/dump.sh small.flan twice`, on `tools/dump.sh small.flan twice`, on
``` ```
(defn twice [n i64] i64 (defn twice [n i64] i64
@ -205,14 +205,14 @@ reject corpus and the generic-milestone ones — and are the same set the survey
`dune build @cells` both exit 0; `@cells` reports `x86 --dev: 22 22` and `x86 : 42 42`, which is the check `dune build @cells` both exit 0; `@cells` reports `x86 --dev: 22 22` and `x86 : 42 42`, which is the check
that the indirection cells and the ABI marker still come out where they were. that the indirection cells and the ABI marker still come out where they were.
**`spike/x86/survey.sh` has NOT been run on this work.** Two runs were started and both were invalidated by **`test/survey-x86.sh` has NOT been run on this work.** Two runs were started and both were invalidated by
racing with a `dune build` that replaced `bin/main.exe` underneath them; a third was killed on instruction racing with a `dune build` that replaced `bin/main.exe` underneath them; a third was killed on instruction
before it finished. **Whoever picks this up must not assume the 103 MATCH / 0 DIFFER / 0 REFUSED baseline before it finished. **Whoever picks this up must not assume the 103 MATCH / 0 DIFFER / 0 REFUSED baseline
still holds — it is the one check that matters and it is outstanding.** Run it detached and with the still holds — it is the one check that matters and it is outstanding.** Run it detached and with the
compiler pinned, so it cannot race a rebuild: compiler pinned, so it cannot race a rebuild:
``` ```
FLAN=_build/default/bin/main.exe setsid timeout 2400 spike/x86/survey.sh > log 2>&1 </dev/null FLAN=_build/default/bin/main.exe setsid timeout 2400 test/survey-x86.sh > log 2>&1 </dev/null
``` ```
What makes an unwelcome result unlikely rather than impossible: the survey builds through `flan build --x86`, What makes an unwelcome result unlikely rather than impossible: the survey builds through `flan build --x86`,

2
docs/handoffs/HANDOFF-x86-cost.md
View File

@ -16,7 +16,7 @@ reason: it builds every corpus program twice and runs both, which is minutes whe
dune build --root . @x86 dune build --root . @x86
It is a `(rule ...)` with no `(executable ...)` beside it, which is where it differs from its two neighbours. The It is a `(rule ...)` with no `(executable ...)` beside it, which is where it differs from its two neighbours. The
check already exists — `spike/x86/survey.sh` is what every handoff quotes its counts from — and a second check already exists — `test/survey-x86.sh` is what every handoff quotes its counts from — and a second
implementation of it in OCaml would be a second thing to drift, which is exactly the failure this alias is meant implementation of it in OCaml would be a second thing to drift, which is exactly the failure this alias is meant
to prevent. So the rule runs the script, and the script grew three environment variables to make that possible: to prevent. So the rule runs the script, and the script grew three environment variables to make that possible:

4
docs/handoffs/HANDOFF-x86-debug.md
View File

@ -212,8 +212,8 @@ multi-file case: its directory table has one entry and its file table two, `gene
| | before (`957ba07`) | after, on `957ba07` | after, rebased onto `eacf7c4` | | | before (`957ba07`) | after, on `957ba07` | after, rebased onto `eacf7c4` |
|---|---|---|---| |---|---|---|---|
| `spike/x86/survey.sh` | 99 MATCH / 0 DIFFER / 0 REFUSED / 0 NOX86, skips 28 + 6 + 2 | **99 / 0 / 0 / 0**, skips 28 + 6 + 2 | **101 / 0 / 0 / 0**, skips 28 + 6 + 2 | | `test/survey-x86.sh` | 99 MATCH / 0 DIFFER / 0 REFUSED / 0 NOX86, skips 28 + 6 + 2 | **99 / 0 / 0 / 0**, skips 28 + 6 + 2 | **101 / 0 / 0 / 0**, skips 28 + 6 + 2 |
| `spike/x86/cells.sh` | 4/4 ok | 4/4 ok | **4/4 ok** | | `test/cells.sh` | 4/4 ok | 4/4 ok | **4/4 ok** |
| `dune test --root .` | exit 0 | exit 0 | **exit 0**, run without a pipe; acceptance reports **232 checks, 0 failures** | | `dune test --root .` | exit 0 | exit 0 | **exit 0**, run without a pipe; acceptance reports **232 checks, 0 failures** |
The MATCH count went from 99 to 101 across the rebase and neither is this lane's doing: the The MATCH count went from 99 to 101 across the rebase and neither is this lane's doing: the

8
docs/handoffs/HANDOFF-x86-devloop.md
View File

@ -221,9 +221,9 @@ Two things the numbers say that the headline does not:
| | before (`f459352`) | after | | | before (`f459352`) | after |
|---|---|---| |---|---|---|
| `dune test --root .` | exit 0, 232 checks, 0 failures | **exit 0, 232 checks, 0 failures**, three runs | | `dune test --root .` | exit 0, 232 checks, 0 failures | **exit 0, 232 checks, 0 failures**, three runs |
| `spike/x86/survey.sh` | 103 MATCH / 0 DIFFER / 0 REFUSED / 0 NOX86 | **103 / 0 / 0 / 0** | | `test/survey-x86.sh` | 103 MATCH / 0 DIFFER / 0 REFUSED / 0 NOX86 | **103 / 0 / 0 / 0** |
| skip breakdown | 28 does-not-compile / 8 no-main / 2 runs-forever | 28 / **9** / 2 | | skip breakdown | 28 does-not-compile / 8 no-main / 2 runs-forever | 28 / **9** / 2 |
| `spike/x86/cells.sh` | 4/4 ok | **4/4 ok** | | `test/cells.sh` | 4/4 ok | **4/4 ok** |
| `bash web/examples/check.sh` | green | **green** | | `bash web/examples/check.sh` | green | **green** |
The `no-main` count moving from 8 to 9 is `reload-v6.flan` existing: `survey.sh` globs The `no-main` count moving from 8 to 9 is `reload-v6.flan` existing: `survey.sh` globs
@ -242,7 +242,7 @@ unchanged tree print nothing and exit 0 without having executed anything. If wha
Run `dune test --root .` **without a pipe** — piping to `tail` gives you `tail`'s exit status, and the Run `dune test --root .` **without a pipe** — piping to `tail` gives you `tail`'s exit status, and the
`dev-robust` fixture puts `ld` and `clang` failure text in the output either way. Run the survey **detached** `dev-robust` fixture puts `ld` and `clang` failure text in the output either way. Run the survey **detached**
(`setsid timeout 2400 spike/x86/survey.sh > log 2>&1 </dev/null`) or a signal to the harness's process group (`setsid timeout 2400 test/survey-x86.sh > log 2>&1 </dev/null`) or a signal to the harness's process group
comes back as 143, which is not a result. And do not run the survey while `dune test` is running: both take the comes back as 143, which is not a result. And do not run the survey while `dune test` is running: both take the
`_build` lock, and the loser reports a lock error rather than a count. `_build` lock, and the loser reports a lock error rather than a count.
@ -257,4 +257,4 @@ comes back as 143, which is not a result. And do not run the survey while `dune
the client neither knows nor can say which backend a session uses — the flag is `flan dev`'s and the protocol the client neither knows nor can say which backend a session uses — the flag is `flan dev`'s and the protocol
above it is identical. The real editor path for *this* lane is `test_dev.ml`, which drives the daemon's own above it is identical. The real editor path for *this* lane is `test_dev.ml`, which drives the daemon's own
verbs and is where the case went. Worth revisiting only if `--x86` ever grows a spelling in the protocol. verbs and is where the case went. Worth revisiting only if `--x86` ever grows a spelling in the protocol.
- Items 2–7 of `HANDOFF-x86-rt.md` §6, unchanged. And still worth doing: **run `spike/x86/survey.sh` in CI**. - Items 2–7 of `HANDOFF-x86-rt.md` §6, unchanged. And still worth doing: **run `test/survey-x86.sh` in CI**.

16
docs/handoffs/HANDOFF-x86-guards.md
View File

@ -19,7 +19,7 @@ and the caller that matters here is `guard`, the two-load-and-branch check emitt
condition reads, in source terms: **a function that has a defer and makes no guarded call at all** — neither in the condition reads, in source terms: **a function that has a defer and makes no guarded call at all** — neither in the
body nor in the defers, which are spliced onto the normal exit path and so are lowered as part of the body. body nor in the defers, which are spliced onto the normal exit path and so are lowered as part of the body.
That is not an exotic shape. It is any leaf function with a defer. `spike/x86/p9-dead-defers.flan` is ten lines: That is not an exotic shape. It is any leaf function with a defer. `test/programs/x86-p9-dead-defers.flan` is ten lines:
```flan ```flan
(defn quiet [n i32] i32 (defn quiet [n i32] i32
@ -94,7 +94,7 @@ named `cleanup` is the innermost one, and anything that finds the channel set ag
**Is the block emitted?** Yes, whenever a defer body contains a guarded call in a function that can unwind. `used` is **Is the block emitted?** Yes, whenever a defer body contains a guarded call in a function that can unwind. `used` is
a `bool ref` set by `current_pad`, so a defer that only assigns — which is what `p6-transfer.flan`'s `middle` does — a `bool ref` set by `current_pad`, so a defer that only assigns — which is what `p6-transfer.flan`'s `middle` does —
never emits it. `objdump -d` over `spike/x86/p10-defer-transfer.flan` built with `--x86` finds two references to never emits it. `objdump -d` over `test/programs/x86-p10-defer-transfer.flan` built with `--x86` finds two references to
`flan_transfer_fail`. `flan_transfer_fail`.
**Does anything arrive there?** Yes. The thing that makes this hard to construct is that `lib/check.ml`'s **Does anything arrive there?** Yes. The thing that makes this hard to construct is that `lib/check.ml`'s
@ -104,7 +104,7 @@ remaining case lives: "this is the one that reaches a function through a call, w
So the probe puts the `invoke-restart` in an ordinary `defn` and has the defer call it. The checker has nothing to So the probe puts the `invoke-restart` in an ordinary `defn` and has the defer call it. The checker has nothing to
object to, because from where it stands `second` is a function like any other. object to, because from where it stands `second` is a function like any other.
`spike/x86/p10-defer-transfer.flan` is that program. `outer` establishes two nested restart-cases and a handler-bind `test/programs/x86-p10-defer-transfer.flan` is that program. `outer` establishes two nested restart-cases and a handler-bind
and calls `middle`; `deep` signals; the handler aims a transfer at `esc-one`; the transfer unwinds `deep` and then and calls `middle`; `deep` signals; the handler aims a transfer at `esc-one`; the transfer unwinds `deep` and then
`middle`; `middle`'s transfer exit clears the channel and runs its defers; and the defer calls `second`, which aims a `middle`; `middle`'s transfer exit clears the channel and runs its defers; and the defer calls `second`, which aims a
second transfer at `esc-two`. The restart frames are both still pushed at that moment — it is `outer`'s own pad that second transfer at `esc-two`. The restart frames are both still pushed at that moment — it is `outer`'s own pad that
@ -115,7 +115,7 @@ is why the second restart-case has to be established *outside* the first.
Both backends, verbatim and identical, at exit status 134: Both backends, verbatim and identical, at exit status 134:
``` ```
spike/x86/p10-defer-transfer.flan:39:7: a defer invoked a restart, which a defer may not do — it is the cleanup a transfer runs on its way out test/programs/x86-p10-defer-transfer.flan:39:7: a defer invoked a restart, which a defer may not do — it is the cleanup a transfer runs on its way out
``` ```
The location is `Loc.to_string fn.Tast.floc` — `middle`'s own `defer` form — on both sides, which is the part a The location is `Loc.to_string fn.Tast.floc` — `middle`'s own `defer` form — on both sides, which is the part a
@ -132,14 +132,14 @@ has for the case, and the corpus simply had no program that started a transfer f
| file | state | what | | file | state | what |
|---|---|---| |---|---|---|
| `lib/x86.ml` — `emit_fn`, tail of the transfer exit | working | the item-5 refusal removed; one hunk, six lines out, a comment in. Nothing else in the file | | `lib/x86.ml` — `emit_fn`, tail of the transfer exit | working | the item-5 refusal removed; one hunk, six lines out, a comment in. Nothing else in the file |
| `spike/x86/p9-dead-defers.flan` | working, MATCH | a leaf function with a defer and no call. Was the refusal | | `test/programs/x86-p9-dead-defers.flan` | working, MATCH | a leaf function with a defer and no call. Was the refusal |
| `spike/x86/p10-defer-transfer.flan` | working, MATCH at 134 | a defer that calls a function that invokes a restart, while a first transfer unwinds | | `test/programs/x86-p10-defer-transfer.flan` | working, MATCH at 134 | a defer that calls a function that invokes a restart, while a first transfer unwinds |
`lib/emit.ml`, `lib/check.ml` and `runtime/flan_rt.c` were not modified; no change to any of them was needed. `lib/emit.ml`, `lib/check.ml` and `runtime/flan_rt.c` were not modified; no change to any of them was needed.
## The survey ## The survey
`bash spike/x86/survey.sh p9 p10` — the two new probes, both sides, built and run: `bash test/survey-x86.sh p9 p10` — the two new probes, both sides, built and run:
``` ```
MATCH 2 MATCH 2
@ -153,7 +153,7 @@ Worth saying what that second row proves for `p10`, because it is not obvious: t
hand-encoded backend that got the `.rodata` label or the length register wrong would still exit 134 and would still hand-encoded backend that got the `.rodata` label or the length register wrong would still exit 134 and would still
look like a match to anything comparing only exit statuses. look like a match to anything comparing only exit statuses.
And the full run, `SURVEY_QUIET=1 spike/x86/survey.sh`, over `test/programs` and `spike/x86` together: And the full run, `SURVEY_QUIET=1 test/survey-x86.sh`, over `test/programs` and `spike/x86` together:
``` ```
MATCH 99 MATCH 99

2
docs/handoffs/HANDOFF-x86-macro-visibility.md
View File

@ -118,7 +118,7 @@ new one. `macro_module` deletes its `.ll` unless `opts.keep`, so the `hidden:tru
stands behind the new path is `nm -D` on the linked object above — three thunks and nothing else of Flan's, stands behind the new path is `nm -D` on the linked object above — three thunks and nothing else of Flan's,
which is the property being claimed, read off the artefact rather than off the text that made it. which is the property being claimed, read off the artefact rather than off the text that made it.
`spike/x86/survey.sh` was **not** run here — it is forty minutes and this lane changes no lowering. It will `test/survey-x86.sh` was **not** run here — it is forty minutes and this lane changes no lowering. It will
report one more `runs-forever` when it next runs: `dev-macro.flan` waits on an agent that is not there, which report one more `runs-forever` when it next runs: `dev-macro.flan` waits on an agent that is not there, which
is what `dev-loop.flan` and `dev-repl.flan` already do. is what `dev-loop.flan` and `dev-repl.flan` already do.

10
docs/handoffs/HANDOFF-x86-redef.md
View File

@ -10,8 +10,8 @@ module publishes a new body into the host's cell, and the host's un-rebuilt call
| | before (`b1cc67b`) | after | | | before (`b1cc67b`) | after |
|---|---|---| |---|---|---|
| `spike/x86/survey.sh` | 97 MATCH / 0 DIFFER / 0 refused | (see §"After", below) | | `test/survey-x86.sh` | 97 MATCH / 0 DIFFER / 0 refused | (see §"After", below) |
| `spike/x86/cells.sh` | 4/4 ok | 4/4 ok | | `test/cells.sh` | 4/4 ok | 4/4 ok |
| `dune test --root .` | exit 0 | exit 0 | | `dune test --root .` | exit 0 | exit 0 |
`dune test` prints two `ld` / `clang` failures from inside the `dev-robust` fixture and still exits 0. Check the `dune test` prints two `ld` / `clang` failures from inside the `dev-robust` fixture and still exits 0. Check the
@ -98,14 +98,14 @@ That is `C-c C-c` on an existing `defn`, which is the demo, and it is what `test
path; add a fixture beside it. path; add a fixture beside it.
5. Items 2–7 of `HANDOFF-x86-rt.md` §6, unchanged. 5. Items 2–7 of `HANDOFF-x86-rt.md` §6, unchanged.
Also still true and still worth doing: **run `spike/x86/survey.sh` in CI**. Also still true and still worth doing: **run `test/survey-x86.sh` in CI**.
## After, measured ## After, measured
| | before (`b1cc67b`) | after | | | before (`b1cc67b`) | after |
|---|---|---| |---|---|---|
| `spike/x86/survey.sh` | 97 MATCH / 0 DIFFER / 0 refused | **97 / 0 / 0**, skips `28 does-not-compile / 6 no-main / 2 runs-forever` — identical | | `test/survey-x86.sh` | 97 MATCH / 0 DIFFER / 0 refused | **97 / 0 / 0**, skips `28 does-not-compile / 6 no-main / 2 runs-forever` — identical |
| `spike/x86/cells.sh` | 4/4 ok | **4/4 ok** | | `test/cells.sh` | 4/4 ok | **4/4 ok** |
| `dune test --root .` | exit 0 | **exit 0**, run without a pipe | | `dune test --root .` | exit 0 | **exit 0**, run without a pipe |
The skip breakdown is the line that matters beyond the MATCH count, because the no-`main` relaxation is the one The skip breakdown is the line that matters beyond the MATCH count, because the no-`main` relaxation is the one

22
docs/handoffs/HANDOFF-x86-rt.md
View File

@ -49,7 +49,7 @@ repeated it. Verified with the survey: `Vec`/`Map` via `vec.flan`, `vec-of-vec.f
## 2. Survey counts, measured ## 2. Survey counts, measured
`spike/x86/survey.sh`, unchanged in what it compares (stdout + stderr + exit status, same bounds-check setting both `test/survey-x86.sh`, unchanged in what it compares (stdout + stderr + exit status, same bounds-check setting both
sides). sides).
| | brief said | measured before | after | | | brief said | measured before | after |
@ -63,7 +63,7 @@ sides).
two refusals — `slice-from-ptr.flan` and `bounds.flan` — both reported as `x86: primitive with 2 arguments`. Fixing two refusals — `slice-from-ptr.flan` and `bounds.flan` — both reported as `x86: primitive with 2 arguments`. Fixing
that is commit 1 and is reported separately so the "after" number is not misread as this lane's work. that is commit 1 and is reported separately so the "after" number is not misread as this lane's work.
Also measured, opt-in and new: `SURVEY_FLAGS=--dev spike/x86/survey.sh` → **97 MATCH / 0 DIFFER**. Also measured, opt-in and new: `SURVEY_FLAGS=--dev test/survey-x86.sh` → **97 MATCH / 0 DIFFER**.
## 3. What was built, file by file ## 3. What was built, file by file
@ -81,11 +81,11 @@ All **working and verified**; nothing in this list is unverified or reverted.
| `lib/x86.ml` — `program` | working | now `~checks ?dev`; emits cells and the `flan_dev_reg_enable` ctor when `dev` | | `lib/x86.ml` — `program` | working | now `~checks ?dev`; emits cells and the `flan_dev_reg_enable` ctor when `dev` |
| `lib/x86.ml` — `layout_ctx` | working | now `~checks ~dev`; `Emit.m.dev` is no longer hardcoded `false` | | `lib/x86.ml` — `layout_ctx` | working | now `~checks ~dev`; `Emit.m.dev` is no longer hardcoded `false` |
| `lib/build.ml` | working | `--dev` removed from the `--x86` refusal list; `~dev:opts.dev` threaded to `X86.program` | | `lib/build.ml` | working | `--dev` removed from the `--x86` refusal list; `~dev:opts.dev` threaded to `X86.program` |
| `spike/x86/survey.sh` | working | `SURVEY_FLAGS`, given to **both** sides. Default unchanged | | `test/survey-x86.sh` | working | `SURVEY_FLAGS`, given to **both** sides. Default unchanged |
| `spike/x86/p7-slice-from-ptr.flan` | working, MATCH | negative length through a parameter and a `restart-case` | | `test/programs/x86-p7-slice-from-ptr.flan` | working, MATCH | negative length through a parameter and a `restart-case` |
| `spike/x86/p8-cell.flan` | working, MATCH | direct call + function value, for `cells.sh` | | `test/programs/x86-p8-cell.flan` | working, MATCH | direct call + function value, for `cells.sh` |
| `spike/x86/cell-override.c` | working | `dlsym("flan.cell.twice")` + store, in a constructor | | `test/cell-override.c` | working | `dlsym("flan.cell.twice")` + store, in a constructor |
| `spike/x86/cells.sh` | working, 4/4 ok | the only test of the cell that can exist | | `test/cells.sh` | working, 4/4 ok | the only test of the cell that can exist |
`lib/emit.ml` was **not** modified. No change to it was needed. `lib/emit.ml` was **not** modified. No change to it was needed.
@ -94,10 +94,10 @@ All **working and verified**; nothing in this list is unverified or reverted.
Nothing fought for an hour. Four short false starts, all mine and all one-line: Nothing fought for an hour. Four short false starts, all mine and all one-line:
- `handler-bind` clause syntax guessed as an `fn` literal: - `handler-bind` clause syntax guessed as an `fn` literal:
`spike/x86/p7-slice-from-ptr.flan:30:18: a handler-bind clause is (Type [name] body ...)`. `test/programs/x86-p7-slice-from-ptr.flan:30:18: a handler-bind clause is (Type [name] body ...)`.
The form is `(BoundsError [c] body ...)`; `test/programs/bounds-condition.flan:112` is the model. The form is `(BoundsError [c] body ...)`; `test/programs/bounds-condition.flan:112` is the model.
- `(defn show [name [u8] ...])` for a literal argument: - `(defn show [name [u8] ...])` for a literal argument:
`spike/x86/p7-slice-from-ptr.flan:37:14: expected [u8], found string`. A string literal wants `string`, not `[u8]`, `test/programs/x86-p7-slice-from-ptr.flan:37:14: expected [u8], found string`. A string literal wants `string`, not `[u8]`,
even though they are the same two words at the machine level. even though they are the same two words at the machine level.
- `cmp_imm` takes `~dst` and an `int`, not `~reg` and an `Int64`. - `cmp_imm` takes `~dst` and an `int`, not `~reg` and an `Int64`.
- `cell-override.c`: `error: 'NULL' undeclared` — needs `<stddef.h>` beside `<dlfcn.h>`. - `cell-override.c`: `error: 'NULL' undeclared` — needs `<stddef.h>` beside `<dlfcn.h>`.
@ -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 **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 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 `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: 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 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. 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. month-old lane's new prim, and nothing noticed. A backend that refuses by name does not rot quietly, but it does rot.

2
emacs/MANUAL.md
View File

@ -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 `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 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 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 only way to check a lowering by eye, and the reason the second backend is
trustworthy is that the two agree. trustworthy is that the two agree.

2
emacs/flan-lower.el
View File

@ -19,7 +19,7 @@
;; to is not an Emacs package and cannot be listed here either -- emacs/MANUAL.md ;; to is not an Emacs package and cannot be listed here either -- emacs/MANUAL.md
;; says what has to be on PATH. ;; 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, ;; 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 ;; 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 ;; the only way to check a lowering by eye, and the whole reason the second

14
lib/build.ml
View File

@ -690,11 +690,23 @@ let compile_c ~opts ?tflags ?(warn = []) ~src ~name () =
built against, so repointing either must not serve a stale .o. *) 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 tflags = match tflags with Some f -> f | None -> target_flags opts in
let cc = compiler 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 = let key =
Digest.to_hex Digest.to_hex
(Digest.string (Digest.string
(String.concat "\000" (String.concat "\000"
[ name; src; stamp_of cc; opts.opt; [ name; src; header; stamp_of cc; opts.opt;
String.concat " " (cflags opts); String.concat " " (cflags opts);
String.concat " " tflags; String.concat " " tflags;
String.concat " " warn ])) String.concat " " warn ]))

221
lib/check.ml
View File

@ -3662,14 +3662,9 @@ let rec key_pair env loc (k : Types.t) : Tast.fnref * Tast.fnref =
fail loc fail loc
"%s is a union, and a union is not a map key — key on the member you \ "%s is a union, and a union is not a map key — key on the member you \
meant" n meant" n
| Types.Array (_, e) -> (* A bytewise array took the arm above; this is one whose elements need
(* A fixed array of a struct or of strings would need the same per-element their own pair, a string's or a struct's. *)
walk a struct key gets, driven by a loop rather than by a field list. | Types.Array (n, e) -> array_key_pair env loc n e
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)
| Types.Float _ -> | Types.Float _ ->
(* Not a milestone question, which is why it is said separately: NaN is not (* 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 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 Tast.Flanfn hname, Tast.Flanfn ename
end 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 (* The pair as two expressions, ready to be passed. Their Flan type is
[(Ptr ())]: one opaque word, which is all the backend needs. *) [(Ptr ())]: one opaque word, which is all the backend needs. *)
let key_fns env loc k = 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)) (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 The prelude's map-keys and map-values are this loop over a generic key.
K, and a prelude defn cannot be written at every K. That one is generics,
not iteration, and it stays refused for that reason.
No hash and no equality pair go with it — walking asks nothing about a 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, 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. *) 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" -> | "map-next" ->
arity ctx loc name 4 args;
(match args with (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 target = check_target ctx target in
let kt, vt = map_kv loc "map-next" target.Tast.ty 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 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 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 = let found =
rt loc (Types.Int Types.I8) "flan_map_next" rt loc (Types.Int Types.I8) "flan_map_next"
[ target; cur; k; v; size_of loc kt; size_of loc vt; here loc ] [ 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 (* 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. *) compiler can see, and a Vec's is a word the runtime reads. *)
| Types.Vec elem -> vec_slice ctx ~want loc target elem bounds | 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 (* 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 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.Dyn -> None
| Types.Array (_, e) -> hidden_dyn p seen e | Types.Array (_, e) -> hidden_dyn p seen e
| Types.Vec e | Types.Option e -> under 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) -> | 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 (* 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. *) note above. What they point at is checked where it is declared. *)
| Types.Ptr (_, e) | Types.Slice (_, e) -> hidden_dyn p seen e | 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) | None -> false)
| _ -> 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 dyn_descriptors (p : Tast.program) =
let check loc what (t : Types.t) = 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 (match hidden_dyn p [] t with
| Some at -> | Some at ->
Loc.failk "check/dyn-descriptor" loc Loc.failk "check/dyn-descriptor" loc

130
lib/emit.ml
View File

@ -81,7 +81,7 @@ let cellname n = "@" ^ quoted (Mangle.cell n)
{ ptr body, i64 word, ptr text } { ptr body, i64 word, ptr text }
The body is first, so everything that only ever wanted the body — a load 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. same address it always did.
The word is what makes a signature change installable. A redefinition that 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. *) pointer is four bytes and [goff] would name the wrong word. *)
type gcword = { goff : int; gpath : (string * string list) list } 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 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 = { type gclayout = {
gdyn : gcword list; gdyn : gcword list;
genv : gcword list; genv : gcword list;
gvec : (gcword * Types.t) list; gvec : (gcword * Types.t) list;
gmap : (gcword * Types.t) list;
} }
(* A descriptor this module has to write out: its symbol, the words, the (* 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 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 = { type desc = {
dsym : string; dsym : string;
dlay : gclayout; dlay : gclayout;
dsize : int; dsize : int;
dvecs : string list; dvecs : string list;
dmaps : string list;
} }
(* ── Module-level state ────────────────────────────────────────────── *) (* ── 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. — which is a run-time question a static descriptor cannot answer.
Refused in [Check] rather than described wrongly here. *) Refused in [Check] rather than described wrongly here. *)
| None -> acc) | None -> acc)
(* [Types.Option], [Types.Vec] and [Types.Map] fall through here with no (* [Types.Option] and [Types.Vec] fall through here with no arm of their
arm of their own and answer no offsets, which is correct only because own and answer no offsets, which is correct only because nothing
nothing reaches this function holding one with a dyn inside it: reaches this function holding one with a dyn inside it:
[Check.hidden_dyn] refuses that at every global, parameter, return and [Check.hidden_dyn] refuses that at every global, parameter, return and
frame slot first. If that gate is ever relaxed — the typed-container frame slot first. A [Types.Map]'s dyn values are not words of the
view the M2 queue's item 3 is building is exactly the kind of change instance at all; [gc_layout] names the header in its [gmap] table. *)
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. *)
| _ -> acc | _ -> acc
in in
List.sort_uniq compare (go [] 0 t []) List.sort_uniq compare (go [] 0 t [])
@ -794,7 +793,7 @@ let desc_mangle (t : Types.t) =
symbol. *) symbol. *)
let rec desc_of m (t : Types.t) : string option = let rec desc_of m (t : Types.t) : string option =
let l = gc_layout m t in 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 else
let key = Types.to_string t in let key = Types.to_string t in
match Hashtbl.find_opt m.descs key with 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 (* Claimed before the elements are asked for, so the counter a nested
element's symbol takes cannot be this one's. *) element's symbol takes cannot be this one's. *)
Hashtbl.replace m.descs key 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 = [] };
let dvecs = let elems what l =
List.map List.map
(fun (_, e) -> (fun (_, e) ->
match desc_of m e with match desc_of m e with
| Some s -> s | Some s -> s
| None -> internal "a Vec entry whose element has no words") | None -> internal "a %s entry whose element has no words" what)
l.gvec l
in in
let dvecs = elems "Vec" l.gvec in
let dmaps = elems "Map" l.gmap in
Hashtbl.replace m.descs key 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 Some sym
(* ── The words the collector follows ───────────────────────────────── (* ── 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 at the same x86-64 offset and at different wasm32 ones, and marking a word
twice costs nothing. *) twice costs nothing. *)
and gc_layout m (t : Types.t) : gclayout = 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 step ty idx path = path @ [ (ty, idx) ] in
let rec go ~full seen off path (t : Types.t) = let rec go ~full seen off path (t : Types.t) =
match t with 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. *) [desc_of] claims before it recurses, is what closes that loop. *)
| Types.Vec e when m.gcfn -> | Types.Vec e when m.gcfn ->
if reaches_fn m [] e then vec := ({ goff = off; gpath = path }, e) :: !vec 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) -> | Types.Array (n, e) ->
let s, _ = lay m e in let s, _ = lay m e in
for i = 0 to Int64.to_int n - 1 do for i = 0 to Int64.to_int n - 1 do
@ -924,7 +932,8 @@ and gc_layout m (t : Types.t) : gclayout =
in in
let uniq l = List.sort_uniq order l in let uniq l = List.sort_uniq order l in
{ gdyn = uniq !dyn; genv = uniq !env; { 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 (* 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 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) = and reaches_fn m seen (t : Types.t) =
match t with match t with
| Types.Fn _ -> true | 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) -> | Types.Named nm when not (List.mem nm seen) ->
let seen = nm :: seen in let seen = nm :: seen in
let fields = 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 List.exists (fun (fl : Tast.field) -> reaches_fn m seen fl.Tast.fty) fields
| _ -> false | _ -> 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 — (* Whether the collector has anything to follow in a value of this type —
the question every rooting decision asks. [dyn_offsets <> []] was that the question every rooting decision asks. [dyn_offsets <> []] was that
question until an [Fn] could hold an environment. *) question until an [Fn] could hold an environment. *)
let traced m (t : Types.t) = let traced m (t : Types.t) =
t = Types.Dyn 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 (* 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 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 word, each Vec header's pointer and length, and each Map header's block
[gpath] instead; see [zero_words]. *) pointer and capacity. The LLVM backend walks [gpath] instead; see
[zero_words]. *)
let gc_zero_offsets m (t : Types.t) : int list = let gc_zero_offsets m (t : Types.t) : int list =
if t = Types.Dyn then [ 0 ] if t = Types.Dyn then [ 0 ]
else 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.gdyn
@ List.map (fun w -> w.goff) l.genv @ 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 + 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 (* A [gpath] as an LLVM constant expression over [base]: nested constant
[getelementptr]s, one per step. Over [ptr null] and through [ptrtoint] it [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), _) -> (fun ((w : gcword), _) ->
store "ptr null" (w.gpath @ [ ("%vec", [ "i32 0"; "i32 0" ]) ]); store "ptr null" (w.gpath @ [ ("%vec", [ "i32 0"; "i32 0" ]) ]);
store "i64 0" (w.gpath @ [ ("%vec", [ "i32 0"; "i32 1" ]) ])) 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 end
in in
let push base (ty : Types.t) = 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_eq(i64, i64)
declare i64 @flan_dyn_len(i64) declare i64 @flan_dyn_len(i64)
declare i64 @flan_dyn_at(i64, i64, ptr, 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_set_at(i64, i64, i64, ptr, i64)
declare void @flan_dyn_push(i64, i64, ptr, i64) declare void @flan_dyn_push(i64, i64, ptr, i64)
declare void @flan_dyn_print(i64) declare void @flan_dyn_print(i64)
@ -5095,7 +5130,7 @@ let uses_dyn (p : Tast.program) =
let rec carries seen (t : Types.t) = let rec carries seen (t : Types.t) =
match t with match t with
| Types.Dyn -> true | 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) -> | Types.Named n when not (List.mem n seen) ->
(match Hashtbl.find_opt structs n with (match Hashtbl.find_opt structs n with
| Some st -> | 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 dyn global's initialiser runs in the startup function below, and the very
first thing it does is allocate. *) first thing it does is allocate. *)
if gc then Buffer.add_string b " call void @flan_gc_init()\n"; 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 (* Before anything can allocate a Vec or Map block: a program that can make
collector-owned closure environment has flan_rt.c report every Vec block a collector-owned closure environment, or that holds a dyn, has
to the collector, which reads a Vec's elements only through a block it flan_rt.c report every such block to the collector, which reads a
knows to be live (runtime/flan_dyn.c, "The Vec blocks a marker may container's elements only through a block it knows to be live
read"). *) (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"; 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 (* 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 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 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 l = d.dlay in
let offs = table d.dsym "offs" "i64" (List.map word l.gdyn) 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 envs = table d.dsym "envs" "i64" (List.map word l.genv) in
let vecs = let pairs suffix words syms =
table d.dsym "vecs" "{ i64, ptr }" table d.dsym suffix "{ i64, ptr }"
(List.map2 (List.map2
(fun ((w : gcword), _) e -> (fun ((w : gcword), _) e ->
Printf.sprintf "{ i64, ptr } { i64 %s, ptr @\"%s\" }" Printf.sprintf "{ i64, ptr } { i64 %s, ptr @\"%s\" }"
(offset_const w) e) (offset_const w) e)
l.gvec d.dvecs) words syms)
in in
let vecs = pairs "vecs" l.gvec d.dvecs in
let maps = pairs "maps" l.gmap d.dmaps in
Buffer.add_string b Buffer.add_string b
(Printf.sprintf (Printf.sprintf
"@\"%s\" = private unnamed_addr constant \ "@\"%s\" = private unnamed_addr constant \
{ i64, i64, ptr, i64, ptr, i64, ptr } \ { i64, i64, ptr, i64, ptr, i64, ptr, i64, ptr } \
{ i64 %d, i64 %d, ptr %s, i64 %d, ptr %s, i64 %d, ptr %s }\n" { 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) 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 Buffer.contents b
(* The same table in the other backend's syntax. It lives here rather than in (* The same table in the other backend's syntax. It lives here rather than in
@ -5466,19 +5505,22 @@ let descriptors_asm m =
in in
let offs = table "offs" (List.map (fun w -> string_of_int w.goff) l.gdyn) 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 envs = table "envs" (List.map (fun w -> string_of_int w.goff) l.genv) in
let vecs = let pairs suffix words syms =
table "vecs" table suffix
(List.concat (List.concat
(List.map2 (List.map2
(fun ((w : gcword), _) e -> [ string_of_int w.goff; ".L" ^ e ]) (fun ((w : gcword), _) e -> [ string_of_int w.goff; ".L" ^ e ])
l.gvec d.dvecs)) words syms))
in in
let vecs = pairs "vecs" l.gvec d.dvecs in
let maps = pairs "maps" l.gmap d.dmaps in
Buffer.add_string b Buffer.add_string b
(Printf.sprintf (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.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 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; rows;
Buffer.contents b Buffer.contents b

2
lib/js.ml
View File

@ -135,7 +135,7 @@
{1 Where this stops, and what the next lane picks up} {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 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: file's own two probes. What the refusals say about the order to work in:

39
lib/prelude.ml
View File

@ -554,16 +554,42 @@ let source = {flan|
;; in. Owned by the caller: (free v), or let a (free-all a) take the region. ;; 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 ;; 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 ;; runtime needed no change at all, because SizeOf and AlignOf are computed at
;; the instantiation site, where the element type is concrete. ;; the instantiation site, where the element type is concrete.
(defn filter [s [const $t] keep? (Fn [$t] bool)] (Vec $t) (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)] (dotimes [i (length s)]
(when (keep? (at s i)) (when (keep? (at s i))
(push v (at s i)))) (push v (at s i))))
v)) 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 sign questions, over every numeric type at once ───────────────
;; ;;
;; The family the whole of generics was asked for. Three questions about a ;; 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 ;; that did not come with them, because it is one copy
;; per *ordered pair* of types rather than per type, ;; per *ordered pair* of types rather than per type,
;; which is where a per-type family stops being honest. ;; 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 ;; Builder Not refused — declined. strings.Builder in Odin
;; wraps a [dynamic]u8; here the (Vec u8) *is* that and ;; wraps a [dynamic]u8; here the (Vec u8) *is* that and

13
lib/x86.ml
View File

@ -1,6 +1,6 @@
(** Tast -> x86-64, by hand. The dev backend; LLVM stays the release one. (** 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, here is everything the spike enumerated and did not do: aggregates, floats,
globals, string literals, the transfer channel, and a whole program rather globals, string literals, the transfer channel, and a whole program rather
than one function. 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 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 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 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 of it. [emit.ml]'s [emit_fn] writes the whole exit under the same
[if f.unwound], and so drops them too. [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; xor_rr b ~dst:rax ~src:rax;
call_sym b "flan_gc_init" call_sym b "flan_gc_init"
end; end;
(* A program that can make a collector-owned closure environment has the (* A program that can make a collector-owned closure environment, or holds
collector told of every Vec block from here on; see [Emit.emit_main]. *) a dyn, has the collector told of every Vec and Map block from here on;
if md.Emit.gcfn then begin see [Emit.emit_main]. *)
if md.Emit.gcfn || gc then begin
xor_rr b ~dst:rax ~src:rax; xor_rr b ~dst:rax ~src:rax;
call_sym b "flan_dyn_track_vecs" call_sym b "flan_dyn_track_vecs"
end; 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\ # installed while the process runs is reached by the next call.\n\
#\n\ #\n\
# What is not here are mnemonics. The bytes are a blob so that every\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\ # disassembly of this same object beside this file: that one says what,\n\
# and this one says why.\n"; # and this one says why.\n";
(* A numbered [.file] is what stops clang's integrated assembler from (* A numbered [.file] is what stops clang's integrated assembler from

2
plan.org
View File

@ -525,7 +525,7 @@ on.
machine code directly and is selected with ~--x86~; it exists because ~llc~ is 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 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 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 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, 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 indirection cells, redefinition modules and DWARF line tables; what it does not

145
runtime/flan_dyn.c
View File

@ -131,6 +131,8 @@ typedef uint64_t flan_dyn;
* - [vecs]: a (Vec T) header whose elements hold words of their own, with the * - [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 * element's descriptor. The marker reads the header's pointer and length
* where they are, so a push that reallocated is seen. * 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 * [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 * 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; const int64_t *envs;
int64_t nvec; int64_t nvec;
const flan_desc_vec *vecs; const flan_desc_vec *vecs;
int64_t nmap;
const flan_desc_vec *maps;
} flan_desc; } flan_desc;
#define DYN_QNAN 0xFFF8000000000000ULL #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); 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 /* 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 * 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 * 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 vec_work *vstack;
static int64_t vstack_n, vstack_cap; 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 /* 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 * against the live blocks above and queued; [mark_desc] drains the queue
* before it returns. */ * before it returns. */
@ -1266,17 +1360,17 @@ static void mark_words(char *base, const flan_desc *d) {
int64_t j; int64_t j;
for (j = 0; j < d->n; j++) mark_value(*(flan_dyn *)(base + d->offs[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->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++) { for (j = 0; j < d->nvec; j++) {
flan_dyn_vec_hdr *h = (flan_dyn_vec_hdr *)(base + d->vecs[j].off); flan_dyn_vec_hdr *h = (flan_dyn_vec_hdr *)(base + d->vecs[j].off);
const flan_desc *e = d->vecs[j].elem; const flan_desc *e = d->vecs[j].elem;
vblock *b; vblock *b;
int64_t n; int64_t n;
if (e == NULL || e->size <= 0 || h->len <= 0) continue; 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 == NULL) continue;
if (b->alloc != NULL
&& (int64_t)((flan_dyn_alloc_hdr *)b->alloc)->epoch != b->epoch)
continue;
n = b->bytes / e->size; n = b->bytes / e->size;
if (h->len < n) n = h->len; if (h->len < n) n = h->len;
if (vstack_n == vstack_cap) { 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) { static void mark_desc(char *base, const flan_desc *d) {
mark_words(base, d); mark_words(base, d);
while (vstack_n > 0) { while (vstack_n > 0 || mapstack_n > 0) {
vec_work w = vstack[--vstack_n];
int64_t i; int64_t i;
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); 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) { void *flan_dyn_env_new(int64_t size, const flan_desc *d) {
flan_obj *o = gc_alloc(OBJ_ENV, size); flan_obj *o = gc_alloc(OBJ_ENV, size);
o->len = 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; ? d : NULL;
memset(o + 1, 0, (size_t)size); memset(o + 1, 0, (size_t)size);
envset_put((uintptr_t)(o + 1)); 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 * 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 * 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. */ * 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) { void flan_dyn_root_push_desc(void *base, const flan_desc *d) {
root_add(base, d == NULL ? &desc_empty : 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]; 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, void flan_dyn_set_at(flan_dyn v, flan_dyn i, flan_dyn x, const uint8_t *loc,
int64_t loclen) { int64_t loclen) {
int64_t k; int64_t k;

18
runtime/flan_dyn.h
View File

@ -56,8 +56,11 @@ typedef uint64_t flan_dyn;
* pointer-sized, holding a collector-allocated environment, null, or a * pointer-sized, holding a collector-allocated environment, null, or a
* widened function's code address, told apart by the collector's own set of * 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) * environments and never by dereferencing — and [vecs], each a (Vec T)
* header at [off] whose live elements are marked through [elem]. A descriptor * header at [off] whose live elements are marked through [elem] — and
* with only dyn words leaves the last four fields zero. * [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] * Nothing in this ABI ever writes a descriptor. See [flan_dyn_root_push_desc]
* and [flan_dyn_env_new]. */ * and [flan_dyn_env_new]. */
@ -75,6 +78,8 @@ typedef struct flan_desc {
const int64_t *envs; const int64_t *envs;
int64_t nvec; int64_t nvec;
const flan_desc_vec *vecs; const flan_desc_vec *vecs;
int64_t nmap;
const flan_desc_vec *maps;
} flan_desc; } flan_desc;
/* ── Constructors ──────────────────────────────────────────────────── */ /* ── 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, flan_dyn flan_dyn_at(flan_dyn v, flan_dyn i, const uint8_t *loc,
int64_t loclen); 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. */ /* 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, void flan_dyn_set_at(flan_dyn v, flan_dyn i, flan_dyn x, const uint8_t *loc,
int64_t loclen); int64_t loclen);
@ -498,6 +508,10 @@ void flan_gc_set_floor(int64_t bytes);
* otherwise does. */ * otherwise does. */
void flan_dyn_vec_hdr_layout(int64_t out[6]); 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 #ifdef __cplusplus
} }
#endif #endif

40
runtime/flan_rt.c
View File

@ -2561,13 +2561,14 @@ void flan_vec_region_only(flan_vec *v, const uint8_t *loc, int64_t loclen) {
loc, loclen); loc, loclen);
} }
/* Told of every Vec block this file allocates, moves or frees: the old block /* Told of every Vec block and every Map block this file allocates, moves or
* (or NULL), the new one (or NULL), its size in bytes, and the allocator and * frees: the old block (or NULL), the new one (or NULL), its size in bytes,
* epoch it was made under. NULL unless flan_dyn.c's [flan_dyn_track_vecs] has * and the allocator and epoch it was made under. NULL unless flan_dyn.c's
* installed its own — a program that can make a collector-owned closure * [flan_dyn_track_vecs] has installed its own — a program that can make a
* environment, which may sit in a Vec, installs it so the collector never * collector-owned closure environment or holds a dyn, either of which may sit
* reads a block a stale header copy still names. A pointer rather than a * in a Vec or a Map, installs it so the collector never reads a block a stale
* call so this file names nothing in flan_dyn.c. */ * 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, void (*flan_vec_block_hook)(void *old, void *fresh, int64_t bytes, void *alloc,
int64_t epoch) = NULL; int64_t epoch) = NULL;
@ -2824,6 +2825,22 @@ typedef struct flan_map {
int64_t epoch; int64_t epoch;
} flan_map; } 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 ────────────────────────────────────────────────────────── /* ── Hashing ──────────────────────────────────────────────────────────
* *
* FNV-1a over the bytes, then a final avalanche. FNV alone leaves the low bits * 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, a->proc(a, FLAN_ALLOC_FREE, m->data,
flan_map_block_size(ksize, vsize, old_cap), 0, FLAN_MAP_ALIGN); 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->data = fresh.data;
m->log2cap = fresh.log2cap; m->log2cap = fresh.log2cap;
return 1; 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++) { for (; i < cap; i++) {
if (!(g.ctrl[i] & FLAN_CTRL_FULL)) continue; if (!(g.ctrl[i] & FLAN_CTRL_FULL)) continue;
memcpy(kout, flan_map_k(&g, i), (size_t)ksize); 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; *cursor = i + 1;
return 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, m->alloc->proc(m->alloc, FLAN_ALLOC_FREE, m->data,
flan_map_block_size(ksize, vsize, flan_map_cap(m)), 0, flan_map_block_size(ksize, vsize, flan_map_cap(m)), 0,
FLAN_MAP_ALIGN); FLAN_MAP_ALIGN);
if (m->data && flan_vec_block_hook)
flan_vec_block_hook(m->data, NULL, 0, NULL, 0);
m->data = NULL; m->data = NULL;
m->len = 0; m->len = 0;
m->log2cap = 0; m->log2cap = 0;

177
spike/backend/driver.ml
View File

@ -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

87
spike/backend/hist.ml
View File

@ -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

100
spike/backend/jit_stubs.c
View File

@ -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 <caml/mlvalues.h>
#include <caml/memory.h>
#include <caml/alloc.h>
#include <caml/fail.h>
#include <sys/mman.h>
#include <string.h>
#include <stdint.h>
#include <stdio.h>
#include <dlfcn.h>
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. */

24
spike/backend/probe.flan
View File

@ -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)

48
spike/backend/run.sh
View File

@ -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

379
spike/backend/x86.ml
View File

@ -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

14
spike/embed/.gitignore vendored
View File

@ -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

4
spike/embed/baseline.c
View File

@ -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 <stdio.h>
int main(void) { printf("baseline\n"); return 0; }

149
spike/embed/dynload_stubs.c
View File

@ -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 <caml/mlvalues.h>
#include <caml/alloc.h>
#include <caml/memory.h>
#include <caml/fail.h>
#include <dlfcn.h>
#include <stdlib.h>
#include <string.h>
#include <stdint.h>
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);
}

21
spike/embed/gc_ml.ml
View File

@ -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

14
spike/embed/harness1.c
View File

@ -1,14 +0,0 @@
/* A C main() that owns the process and starts the OCaml runtime underneath it. */
#include <caml/callback.h>
#include <caml/mlvalues.h>
#include <stdio.h>
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;
}

54
spike/embed/harness2.c
View File

@ -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 <caml/callback.h>
#include <caml/alloc.h>
#include <caml/mlvalues.h>
#include <stdio.h>
#include <time.h>
#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;
}

14
spike/embed/harness3.c
View File

@ -1,14 +0,0 @@
/* Step 3: does -output-complete-obj carry the project's C stubs through? */
#include <caml/callback.h>
#include <caml/mlvalues.h>
#include <stdio.h>
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;
}

106
spike/embed/harness4.c
View File

@ -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 <caml/callback.h>
#include <caml/alloc.h>
#include <caml/mlvalues.h>
#include <caml/threads.h>
#include <pthread.h>
#include <stdatomic.h>
#include <stdio.h>
#include <string.h>
#include <time.h>
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;
}

91
spike/embed/harness5.c
View File

@ -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 <caml/callback.h>
#include <caml/mlvalues.h>
#include <setjmp.h>
#include <signal.h>
#include <stdio.h>
#include <string.h>
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;
}

110
spike/embed/harness5b.c
View File

@ -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 <caml/callback.h>
#include <caml/mlvalues.h>
#include <caml/memory.h>
#include <signal.h>
#include <stdio.h>
#include <string.h>
#include <unistd.h>
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

61
spike/embed/harness6.c
View File

@ -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 <caml/callback.h>
#include <caml/mlvalues.h>
#include <caml/memory.h>
#include <stdint.h>
#include <stdio.h>
#include <stdlib.h>
#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;
}

5
spike/embed/hello_ml.ml
View File

@ -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 ()))

66
spike/embed/merged.sh
View File

@ -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: $?"

77
spike/embed/merged_main.c
View File

@ -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 <caml/callback.h>
#include <caml/alloc.h>
#include <caml/mlvalues.h>
#include <caml/threads.h>
#include <pthread.h>
#include <stdatomic.h>
#include <stdio.h>
#include <time.h>
/* 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;
}

76
spike/embed/run.sh
View File

@ -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'

23
spike/embed/sig.sh
View File

@ -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: $?"

34
spike/embed/sig_ml.ml
View File

@ -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

26
spike/embed/stubs_ml.ml
View File

@ -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

50
spike/embed/symbols.sh
View File

@ -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

32
spike/embed/thread_ml.ml
View File

@ -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 ()))

40
spike/embed/whole_ml.ml
View File

@ -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")

7
spike/generics/id.flan
View File

@ -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)))

171
spike/generics/measure.ml
View File

@ -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)

51
spike/generics/prelude-shapes.flan
View File

@ -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))))

4
spike/generics/reject.flan
View File

@ -1,4 +0,0 @@
(defn add2 [a $t b $t] t (+ a b))
(defn main [] ()
(println (add2 1 2)))

28
spike/generics/run.sh
View File

@ -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"

3
spike/generics/runaway.flan
View File

@ -1,3 +0,0 @@
(defn grow [x $t] ()
(grow [x x]))
(defn main [] () (grow 1))

25
spike/generics/sort.flan
View File

@ -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)))))

19
spike/generics/swap.flan
View File

@ -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))))

5
spike/generics/two-vars.flan
View File

@ -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)))

210
spike/x86/COST.md
View File

@ -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.<something>`. The runtime's C is `flan_<something>` 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 <flan.step>
mov -0x18(%rbp),%r11 ; the condition frame, from its own slot
mov 0x0(%r11),%r11 ; ... dereferenced
test %r11,%r11
jne <unwind>
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.

101
spike/x86/annot.sh
View File

@ -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 ]

86
spike/x86/bench.sh
View File

@ -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
t1=$(date +%s%N)
d=$(( (t1 - t0) / 1000 ))
if [ -z "$min" ] || [ "$d" -lt "$min" ]; then min=$d; fi
done
echo "$min"
}
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}'
}
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

20
spike/x86/bench/b1-calls.flan
View File

@ -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)

20
spike/x86/bench/b2-bounds.flan
View File

@ -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)

21
spike/x86/bench/b3-spill.flan
View File

@ -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)

20
spike/x86/bench/b4-copy.flan
View File

@ -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)

5
spike/x86/cost-bench.tsv
View File

@ -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
1 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
2 b1-calls 2108 36764 104266 1959 103336 26827 100874 82 200 807 83018
3 b2-bounds 4711 27047 112567 4548 104951 4663 111295 355 407 1390 83596
4 b3-spill 22184 28982 137347 22772 132053 22659 132913 168 248 1117 83323
5 b4-copy 2043 7170 20792 1980 19559 2058 18497 140 348 877 83083

98
spike/x86/cost-corpus.tsv
View File

@ -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
1 name llvm_file llvm_text llvm_own o0_own x86_file x86_text x86_own llvm_us x86_us
2 agent-longname 82224 42002 79 134 82264 42450 519 -1 -1
3 agent-queue 82352 42306 340 567 86488 43698 1747 2491 2546
4 agent 82336 42434 454 798 86472 44162 2218 2609 2496
5 algorithms 76680 39282 6776 16616 101296 63234 30875 2499 2605
6 allocators 67760 33650 1297 1719 71896 37490 5130 3170 3034
7 array-ctor 67784 32722 357 1840 71920 36242 3880 2442 2664
8 bounds-condition 76416 37074 4641 6963 84648 45858 13493 2673 2469
9 bounds 67720 32738 363 1951 71856 36418 4039 3194 2654
10 break 82296 42754 819 1182 86432 44482 2549 -1 -1
11 bytes2 72120 37010 4576 10893 88544 52018 19654 2573 2510
12 cleanup 68176 33986 1583 2077 72312 36946 4583 2351 2402
13 conditions 68064 33586 1212 1209 68104 35346 2984 2436 2513
14 debug-permuted 67720 32610 261 410 67760 33794 1433 2479 2442
15 debug 67720 32610 261 429 67760 33794 1433 2494 2494
16 defer-let 67928 34018 1625 1784 72064 36754 4396 2548 2543
17 destructure 67792 33650 1290 4577 80120 40946 8583 2534 2523
18 dev-break-bounds 82440 42546 588 648 86576 43762 1830 -1 -1
19 dev-break 82368 42418 459 715 86504 43682 1755 -1 -1
20 dev-globals 82456 42162 206 534 86584 43538 1614 -1 -1
21 dev-inspect 82408 42610 652 704 86544 43698 1765 -1 -1
22 dev-locals 82336 42418 465 623 86472 43650 1721 -1 -1
23 dev-noagent 67720 32434 83 109 67760 32866 507 3116 2939
24 dev-pause 82336 42066 112 244 82376 42802 877 -1 -1
25 dev-ptr 86632 43954 1970 2859 90768 47490 5543 -1 -1
26 dev-repl 82336 42066 112 244 82376 42802 877 -1 -1
27 dev-robust 82336 42066 112 244 82376 42802 877 -1 -1
28 edn 91208 44706 12057 34556 124016 80898 48532 3218 3165
29 embed 67800 33330 977 2461 71936 37906 5550 2440 2650
30 enum-compare 67752 32562 201 581 67792 33970 1611 2607 2805
31 enum-convert 67752 33202 830 1522 71888 37042 4675 2737 2512
32 error 67744 32498 131 163 67784 32946 591 2614 2587
33 exhausted-unhandled 67688 33090 749 1156 67728 34850 2491 2442 2591
34 exhausted 76192 35778 3415 5139 80336 42674 10321 2409 2469
35 fn-values 68296 34226 1745 5124 80632 43026 10672 2405 2406
36 format 76032 36802 4413 7076 84264 45394 13038 2449 2388
37 frame-rollback 68440 34466 2020 3424 80768 39762 7402 2383 2394
38 free-all-refused 67688 32370 28 28 67728 32658 299 2418 2497
39 generics 81368 42786 10137 20427 114184 71602 39241 2474 2516
40 handles 75880 35826 3482 6289 84112 46338 13981 2520 2470
41 higher-order 76648 37154 4652 10329 88976 51314 18948 2413 2439
42 into 80256 40658 8277 12345 92584 53682 21320 2428 2412
43 loops 67736 33378 1016 1720 71872 37634 5269 2370 2315
44 machine 67960 33186 821 1925 72096 37394 5042 2515 2456
45 macro-unless 67720 32642 288 615 67760 34610 2243 2466 2457
46 macros 67688 32802 461 793 67728 35250 2896 2532 2409
47 map-exhausted 76152 36162 3805 5994 84392 44530 12171 2393 2506
48 map-iter 76096 39586 7211 10374 92520 54082 21715 2541 2531
49 map-stale-region 67688 33650 1307 2106 71824 36898 4537 2354 2407
50 maps 88504 45266 12833 19850 117216 72802 40445 3162 3082
51 math 67832 33986 1611 3288 72024 39362 7000 2384 2405
52 math2 67784 33506 1148 2862 72024 39010 6644 2300 2482
53 pkg-diamond 67880 32626 252 616 67928 34162 1801 2353 2227
54 pkg-macro-idle 67688 32338 3 3 67728 32562 210 2440 2410
55 pkg-macro 67800 32722 354 450 67840 33986 1626 2455 2429
56 pkg-return 78416 39570 7024 23635 103032 64082 31716 2432 2375
57 pkg-shadow 67848 32642 277 371 67888 33618 1258 2408 2236
58 pkg-shared 74560 34066 1676 5593 86888 45650 13283 2422 2648
59 pkg-unused 69704 32386 35 35 69744 34658 2298 2351 2271
60 pool-stale-region 67688 33282 932 1675 71824 35746 3379 2389 2466
61 printers 82464 42098 168 452 82504 43282 1348 -1 -1
62 println 76256 36098 3737 7587 88584 50114 17753 2312 2460
63 raylib-audio 79536 35522 2478 5610 87768 44178 11225 2574 2769
64 raylib-ffi 85848 39538 6245 11506 102272 55650 22537 2607 2852
65 raylib-font 79088 35538 2622 6260 83232 43186 10350 2661 2658
66 raylib-image 80152 37698 4504 8285 88384 47058 13966 2684 2946
67 raylib-imported 70344 33202 612 1003 74480 36658 4066 2688 2602
68 reach-walk 67992 33170 774 1082 68032 34802 2443 2552 2308
69 recur 67792 34594 2233 4070 76024 40674 8314 2468 62674
70 registry 72008 35330 2940 4604 80240 41010 8608 2515 2329
71 reload-generic 67944 32930 520 1390 67992 35442 3076 2341 2241
72 restarts 77200 39010 6430 9268 89528 49442 17065 2356 2304
73 rl-with 69704 32386 35 35 69744 34658 2298 2550 2461
74 sand-headless 74728 34546 2139 6326 87056 47634 15269 2783 9172
75 signedness 67688 32594 246 386 67728 33938 1576 2418 2411
76 slice-from-ptr 67752 33106 755 2549 75984 37458 5101 2421 2367
77 slices 68128 34802 2393 9057 88648 50114 17753 2504 2271
78 slurp-unhandled 67688 33522 1173 1601 67728 35298 2945 2340 2354
79 slurp 80288 42114 9744 14813 100808 57010 24656 2358 2408
80 stale-region 67688 33490 1148 1681 71824 35842 3483 2332 2286
81 string-of-bytes 67856 33490 981 1925 71992 36338 3817 2319 2353
82 strings 88912 45890 13395 22681 109432 65618 33265 2455 2391
83 text 72296 37122 4666 8007 84624 49378 17018 2310 2397
84 unions 76016 36498 4131 17714 92440 55810 23456 2323 2413
85 unit-main 67688 32386 33 33 67728 32674 307 2459 2377
86 utf8 81216 39714 7170 21515 114024 73106 40745 2563 2380
87 values 67720 32530 180 667 67760 34082 1719 2531 2378
88 vec 80080 40402 8039 12089 92408 55122 22770 2370 2389
89 virtual-controls-headless 70896 33666 1271 1295 75032 38962 6601 2319 3201
90 web-files 67736 33058 706 1000 67776 34610 2246 2321 2382
91 p1-exit 67688 32338 3 3 67728 32562 210 2436 2377
92 p2-loop-print 67688 32626 283 106 67728 32930 577 2269 2364
93 p3-fizz 67720 32530 169 225 67760 33282 928 2512 2359
94 p4-convention 67824 32786 405 1005 67864 35138 2778 2436 2332
95 p5-core 67792 33346 993 1507 71928 37218 4865 2346 2444
96 p6-transfer 68096 34354 1944 2801 72232 37618 5252 2386 2310
97 p7-slice-from-ptr 67840 33698 1336 1498 71984 35682 3318 2493 2392
98 p8-cell 67752 32514 146 270 67800 33202 847 2402 2381

135
spike/x86/cost.sh
View File

@ -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.<name>`
# -- the program's *own* code and nothing else. The runtime's C is
# `flan_<name>` 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 )
rc=$?
t1=$(date +%s%N)
[ -n "$rc0" ] || rc0=$rc
[ "$rc" = "$rc0" ] || { echo "-1"; return; }
d=$(( (t1 - t0) / 1000 ))
[ "$d" -lt 15000000 ] || { echo "-1"; return; }
if [ -z "$min" ] || [ "$d" -lt "$min" ]; then min=$d; fi
done
echo "$min"
}
printf 'name\tllvm_file\tllvm_text\tllvm_own\to0_own\tx86_file\tx86_text\tx86_own\tllvm_us\tx86_us\n'
for src in "$root"/test/programs/*.flan "$root"/spike/x86/*.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
case " $forever " in *" $name "*) continue;; esac
rm -f "$out/l" "$out/x" "$out/d"
"$flan" build "$src" "${extra[@]}" -o "$out/l" >/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

2
spike/x86/cell-override.c → test/cell-override.c
View File

@ -13,7 +13,7 @@
* *
* A release build has no cells, dlsym answers NULL, and this does nothing -- * 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 * 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 #define _GNU_SOURCE
#include <dlfcn.h> #include <dlfcn.h>

4
spike/x86/cells.sh → test/cells.sh
View File

@ -23,7 +23,7 @@
# from ordinary symbol interposition. # from ordinary symbol interposition.
set -u set -u
here=$(cd "$(dirname "$0")" && pwd) 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 # 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 # @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 # 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 out=$(mktemp -d); trap 'rm -rf "$out"' EXIT
cc -shared -fPIC -o "$out/override.so" "$here/cell-override.c" || exit 1 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 fail=0
run() { # run <label> <expected> <build flags...> run() { # run <label> <expected> <build flags...>

50
test/dune
View File

@ -112,11 +112,6 @@
(alias corpus) (alias corpus)
(source_tree syntax) (source_tree syntax)
(file %{workspace_root}/conditions-play.flan) (file %{workspace_root}/conditions-play.flan)
(glob_files %{workspace_root}/spike/backend/*.flan)
(glob_files %{workspace_root}/spike/generics/*.flan)
(glob_files %{workspace_root}/spike/js/*.flan)
(glob_files %{workspace_root}/spike/x86/*.flan)
(glob_files %{workspace_root}/spike/x86/bench/*.flan)
(glob_files %{workspace_root}/web/examples/*.flan) (glob_files %{workspace_root}/web/examples/*.flan)
(glob_files %{workspace_root}/web/examples/geom/*.flan))) (glob_files %{workspace_root}/web/examples/geom/*.flan)))
@ -139,13 +134,8 @@
(deps (deps
(alias corpus) (alias corpus)
test_sanitize.exe test_sanitize.exe
; p13-dyn-collect.flan, which lives with the x86 probes because that is the ; ASAN_OPTIONS=detect_leaks=1 asks the leak question; see test_sanitize.ml.
; lane that wrote it, and is in this sweep because of what it does rather (env_var ASAN_OPTIONS)
; than where it is: it is the only program anywhere that allocates past
; flan_dyn.c's one-megabyte floor, so it is the only one under which a mark
; and a sweep actually run. Every other Flan program here agrees with ASan
; by never collecting at all.
(glob_files %{workspace_root}/spike/x86/*.flan)
; The dyn runtime's C main, which is the one thing in this sweep that is not ; The dyn runtime's C main, which is the one thing in this sweep that is not
; a Flan program: flan_dyn.c has no Flan spelling yet. It is also the one ; a Flan program: flan_dyn.c has no Flan spelling yet. It is also the one
; translation unit here that frees the most, which is what makes it worth a ; translation unit here that frees the most, which is what makes it worth a
@ -177,7 +167,9 @@
test_valgrind.exe test_valgrind.exe
; The suppression file, which is all reasons and no suppressions; its own ; The suppression file, which is all reasons and no suppressions; its own
; header says why that is the finding rather than an oversight. ; header says why that is the finding rather than an oversight.
(file valgrind.supp)) (file valgrind.supp)
; FLAN_LEAKS=1 turns memcheck's leak check on; see test_valgrind.ml.
(env_var FLAN_LEAKS))
(action (run ./test_valgrind.exe))) (action (run ./test_valgrind.exe)))
; The corpus a fourth time, through the hand-written x86-64 backend, compared ; The corpus a fourth time, through the hand-written x86-64 backend, compared
@ -189,12 +181,13 @@
; second backend still lowers the language: it refuses by name rather than ; second backend still lowers the language: it refuses by name rather than
; miscompiling, so when another lane adds a primitive the backend says so ; miscompiling, so when another lane adds a primitive the backend says so
; loudly, and nothing was listening. Two such refusals sat in the tree for a ; loudly, and nothing was listening. Two such refusals sat in the tree for a
; month. Now they fail a build somebody can run. ; month. Now they fail a build somebody can run. The LLVM side is built at
; -O0, the level this backend corresponds to.
; ;
; dune build --root . @x86 ; dune build --root . @x86
; ;
; A rule with no executable beside it, unlike @sanitize and @valgrind: the ; A rule with no executable beside it, unlike @sanitize and @valgrind: the
; check already exists as spike/x86/survey.sh, which is what every handoff ; check already exists as survey-x86.sh, which is what every handoff
; quotes its counts from, and a second implementation in OCaml would be a ; quotes its counts from, and a second implementation in OCaml would be a
; second thing to drift. SURVEY_STRICT=1 turns its report into an exit ; second thing to drift. SURVEY_STRICT=1 turns its report into an exit
; status. FLAN is passed because the script otherwise runs `dune build` on ; status. FLAN is passed because the script otherwise runs `dune build` on
@ -205,19 +198,13 @@
(alias x86) (alias x86)
(deps (deps
(alias corpus) (alias corpus)
(file %{workspace_root}/spike/x86/survey.sh) (file survey-x86.sh)
(glob_files %{workspace_root}/spike/x86/*.flan)
; The js spike's programs are plain flan programs and the sweep reads them
; now, so they have to be in the build tree the sweep runs from -- otherwise
; the glob matches nothing, and nothing is exactly what it was reporting
; while p1-int-semantics.flan sat there with a wrong shift in it.
(glob_files %{workspace_root}/spike/js/*.flan)
(file %{workspace_root}/bin/main.exe)) (file %{workspace_root}/bin/main.exe))
(action (action
(setenv SURVEY_STRICT 1 (setenv SURVEY_STRICT 1
(setenv SURVEY_QUIET 1 (setenv SURVEY_QUIET 1
(setenv FLAN %{workspace_root}/bin/main.exe (setenv FLAN %{workspace_root}/bin/main.exe
(run bash %{workspace_root}/spike/x86/survey.sh)))))) (run bash survey-x86.sh))))))
; The reference page, checked against the compiler that is supposed to have ; The reference page, checked against the compiler that is supposed to have
; produced everything on it. Two scripts, one alias, because they are halves of ; produced everything on it. Two scripts, one alias, because they are halves of
@ -284,7 +271,7 @@
(setenv FLAN %{workspace_root}/bin/main.exe (setenv FLAN %{workspace_root}/bin/main.exe
(run sh %{workspace_root}/web/examples/quotes.sh))))) (run sh %{workspace_root}/web/examples/quotes.sh)))))
; The indirection cell, driven from outside the language. spike/x86/cells.sh ; The indirection cell, driven from outside the language. cells.sh
; preloads a shared object whose constructor stores a different body into ; preloads a shared object whose constructor stores a different body into
; flan.cell.twice with dlsym, and checks that a --dev build notices and a ; flan.cell.twice with dlsym, and checks that a --dev build notices and a
; release build does not -- 22 22 against 42 42, both backends, four builds. ; release build does not -- 22 22 against 42 42, both backends, four builds.
@ -300,13 +287,13 @@
(rule (rule
(alias cells) (alias cells)
(deps (deps
(file %{workspace_root}/spike/x86/cells.sh) (file cells.sh)
(file %{workspace_root}/spike/x86/cell-override.c) (file cell-override.c)
(glob_files %{workspace_root}/spike/x86/*.flan) (file programs/x86-p8-cell.flan)
(file %{workspace_root}/bin/main.exe)) (file %{workspace_root}/bin/main.exe))
(action (action
(setenv FLAN %{workspace_root}/bin/main.exe (setenv FLAN %{workspace_root}/bin/main.exe
(run bash %{workspace_root}/spike/x86/cells.sh)))) (run bash cells.sh))))
; Everything that checks something and is not `dune test`, in one word. ; Everything that checks something and is not `dune test`, in one word.
; ;
@ -358,16 +345,15 @@
; should say so and stop, not report zero of everything. And SURVEY_STRICT ; should say so and stop, not report zero of everything. And SURVEY_STRICT
; means something narrower here: a refusal is a *decision* in a dialect, not ; means something narrower here: a refusal is a *decision* in a dialect, not
; a gap, so only a DIFFER and a CRASH fail the alias. See the header of ; a gap, so only a DIFFER and a CRASH fail the alias. See the header of
; spike/js/survey.sh. ; survey-js.sh.
(rule (rule
(alias js) (alias js)
(deps (deps
(alias corpus) (alias corpus)
(file %{workspace_root}/spike/js/survey.sh) (file survey-js.sh)
(glob_files %{workspace_root}/spike/js/*.flan)
(file %{workspace_root}/bin/main.exe)) (file %{workspace_root}/bin/main.exe))
(action (action
(setenv SURVEY_STRICT 1 (setenv SURVEY_STRICT 1
(setenv SURVEY_QUIET 1 (setenv SURVEY_QUIET 1
(setenv FLAN %{workspace_root}/bin/main.exe (setenv FLAN %{workspace_root}/bin/main.exe
(run bash %{workspace_root}/spike/js/survey.sh)))))) (run bash survey-js.sh))))))

18
test/dyn_ops.c
View File

@ -61,6 +61,7 @@ void flan_rt_init(int32_t argc, char **argv);
void flan_vec_free(void *v, int64_t size, int64_t align, const uint8_t *loc, void flan_vec_free(void *v, int64_t size, int64_t align, const uint8_t *loc,
int64_t loclen); int64_t loclen);
void flan_vec_layout(int64_t out[6]); void flan_vec_layout(int64_t out[6]);
void flan_map_layout(int64_t out[10]);
static int failures; static int failures;
@ -597,6 +598,23 @@ static void layout(void) {
fail(msg); fail(msg);
} }
} }
{
/* The Map header and its block geometry, restated in flan_dyn.c so the
collector can walk a map's slots. Two copies, compared directly. */
int64_t mrt[10], mdyn[10];
static const char *const mnames[10] =
{ "sizeof", "offset of data", "offset of len", "offset of log2cap",
"offset of alloc", "offset of epoch", "head bytes", "group",
"alignment", "full bit" };
flan_map_layout(mrt);
flan_dyn_map_hdr_layout(mdyn);
for (i = 0; i < 10; i++)
if (mrt[i] != mdyn[i]) {
snprintf(msg, sizeof msg, "flan_map vs. flan_dyn_map_hdr's %s: %lld vs. %lld",
mnames[i], (long long)mrt[i], (long long)mdyn[i]);
fail(msg);
}
}
printf(failures == 0 ? "layout ok\n" : "layout failed\n"); printf(failures == 0 ? "layout ok\n" : "layout failed\n");
} }

17
test/programs/dyn-slice.flan Normal file
View File

@ -0,0 +1,17 @@
;; (slice d ...) over a dyn text, in the three spellings the typed slice has.
;; The result is a text of its own; the source is untouched.
;;
;; With an argument, the last slice runs past the end and traps.
(defn main [args [string]] i32
(let [d (the dyn "hello")]
(println (slice d))
(println (slice d 1))
(println (slice d 1 3))
(println (slice d 5))
(println (length (slice d 2)))
(println (= (slice d 0 2) "he"))
(println d)
(when (> (length args) 1)
(println (slice d 2 9))))
0)

65
test/programs/fn-in-map.flan
View File

@ -1,9 +1,58 @@
;; A closure's environment is found by walking the storage its function value ;; A Map holding closures and a Map holding dyn values, both kept alive by the
;; sits in — a frame slot, a global, a struct, an Option, a Vec's elements — ;; collector across enough allocation that it runs many times. A Map's block is
;; and a Map's storage is not walked. An (Fn ...) as a Map's value would hold ;; walked like a Vec's: the full slots' values are marked through the value
;; an environment the collector cannot see and would free. A Vec holds them, ;; type's descriptor. A lost value is a use of freed memory here, not a wrong
;; and a (CFn ...) carries no environment and may go in a Map. ;; number.
(defn adder [n i32] (Fn [i32] i32)
(fn [x] (+ x n)))
;; Garbage, and plenty of it: every pass boxes and drops a vector of four.
(defn churn [n i32] ()
(dotimes [i n]
(let [junk (vec-new dyn)]
(push junk i)
(push junk "row")
(push junk 2.5)
(push junk true))))
(defn main [] i32 (defn main [] i32
(let [ops (map-new string (Fn [i32] i32))] (let [ops (map-new string (Fn [i32] i32))
(put ops "id" (fn [x] x)) many (map-new i32 (Fn [i32] i32))
0)) rows (map-new i32 dyn)]
(put ops "one" (adder 1))
(put ops "ten" (adder 10))
(put ops "hundred" (adder 100))
;; Each value a dyn vector the collector allocated, reachable from
;; nothing but the map.
(dotimes [i 64]
(let [row (vec-new dyn)]
(push row i)
(push row "row")
(put rows i row)))
(churn 40000)
;; Grown after the churn, so a rebuilt block is walked too.
(dotimes [i 64]
(put many i (adder i)))
(churn 40000)
(let [total 0]
(dotimes [i 64]
(set total (+ total (match (get many i) (Some f) (f 0) None 0))))
(println total))
(dotimes [i 3]
(let [name (at ["one" "ten" "hundred"] i)]
(println (match (get ops name) (Some f) (f 1) None -1))))
(let [cur (i64 0)
k 0
v (the dyn nil)
sum 0
n 0]
(while (map-next rows (addr cur) (addr k) (addr v))
(set sum (+ sum (i32 (at v 0))))
(set n (+ n 1)))
(println n)
(println sum))
(free ops)
(free many)
(free rows))
0)

0
spike/js/p1-int-semantics.flan → test/programs/js-p1-int-semantics.flan
View File

0
spike/js/p2-value-copies.flan → test/programs/js-p2-value-copies.flan
View File

30
test/programs/map-array-key.flan Normal file
View File

@ -0,0 +1,30 @@
;; A fixed array of strings, and of structs holding a string, as a map key.
;; Each element is hashed and compared by its own pair, so two keys built from
;; different storage with the same bytes are the same key.
(defstruct Tag [name string n i32])
(defn main [] i32
(let [m (map-new [2 string] i32)
a (the [2 string] ["ab" "cd"])
b (the [2 string] [(slice "xab" 1) (slice "cdx" 0 2)])
c (the [2 string] ["ab" "ce"])]
(put m a 1)
(put m c 3)
(println (or-else (get m b) -1))
(println (or-else (get m c) -1))
(println (length m))
(put m b 2)
(println (length m))
(println (or-else (get m a) -1))
(free m))
(let [t (map-new [3 Tag] i32)
x (the [3 Tag] [(Tag "a" 1) (Tag "b" 2) (Tag "c" 3)])
y (the [3 Tag] [(Tag "a" 1) (Tag "b" 2) (Tag "c" 4)])]
(put t x 10)
(put t y 20)
(println (or-else (get t (the [3 Tag] [(Tag "a" 1) (Tag "b" 2) (Tag "c" 3)])) -1))
(println (or-else (get t y) -1))
(println (length t))
(free t))
0)

59
test/programs/map-keys.flan Normal file
View File

@ -0,0 +1,59 @@
;; map-keys and map-values: the prelude's two generic walks over a map. Block
;; order is the hash's, so what comes back is sorted before it is printed.
;;
;; The three globals are named after the prelude's type variables. A generic's
;; body names its element type as $t, $k or $v, never bare, because a bare
;; name there is an expression and would find these.
(defonce t i32 0)
(defonce k i32 0)
(defonce v i32 0)
(defn adder [n i32] (Fn [i32] i32)
(fn [x] (+ x n)))
(defn main [] i32
(let [m (map-new i32 i64)]
(put m 30 (i64 300))
(put m 10 (i64 100))
(put m 20 (i64 200))
(let [ks (map-keys m)
vs (map-values m)]
(sort (slice ks))
(sort (slice vs))
(dotimes [i (length ks)] (print (at ks i)) (print " "))
(println "")
(dotimes [i (length vs)] (print (at vs i)) (print " "))
(println "")
(free ks)
(free vs))
(free m))
;; A string key, and a map that never allocated.
(let [names (map-new string i32)
none (map-new string i32)]
(put names "b" 2)
(put names "a" 1)
(let [ks (map-keys names)
nk (map-keys none)
total 0]
(dotimes [i (length ks)] (set total (+ total (or-else (get names (at ks i)) 0))))
(println total)
(println (length nk))
(free ks)
(free nk))
(free names)
(free none))
;; Closures as the values: a function value cannot be zeroed, so the walk
;; must not need a place for one.
(let [fs (map-new i32 (Fn [i32] i32))]
(put fs 1 (adder 1))
(put fs 2 (adder 2))
(let [ks (map-keys fs)
vs (map-values fs)
total 0]
(dotimes [i (length vs)] (set total (+ total ((at vs i) 10))))
(println (length ks))
(println total)
(free ks)
(free vs))
(free fs))
0)

3
test/programs/map-remove.flan
View File

@ -123,7 +123,8 @@
(print (length t)) (println "") ; 150 (print (length t)) (println "") ; 150
(match (get t 299) (Some v) (do (print v) (println "")) None (println "?")) ; 598 (match (get t 299) (Some v) (do (print v) (println "")) None (println "?")) ; 598
(print (has-key? t 298)) (println ""))) ; false (print (has-key? t 298)) (println ""))) ; false
(free-all ar)) (free-all ar)
(arena-destroy ar))
;; (7) Churn at a steady size, checked against a plain array. Keys are drawn ;; (7) Churn at a steady size, checked against a plain array. Keys are drawn
;; from 512 and the map holds about two thirds of them, so removals leave ;; from 512 and the map holds about two thirds of them, so removals leave

0
spike/x86/p1-exit.flan → test/programs/x86-p1-exit.flan
View File

0
spike/x86/p10-defer-transfer.flan → test/programs/x86-p10-defer-transfer.flan
View File

0
spike/x86/p11-reversed-slice.flan → test/programs/x86-p11-reversed-slice.flan
View File

0
spike/x86/p11-shift-edges.flan → test/programs/x86-p11-shift-edges.flan
View File

0
spike/x86/p12-handler-value.flan → test/programs/x86-p12-handler-value.flan
View File

0
spike/x86/p13-dyn-collect.flan → test/programs/x86-p13-dyn-collect.flan
View File

0
spike/x86/p2-loop-print.flan → test/programs/x86-p2-loop-print.flan
View File

0
spike/x86/p3-fizz.flan → test/programs/x86-p3-fizz.flan
View File

0
spike/x86/p4-convention.flan → test/programs/x86-p4-convention.flan
View File

0
spike/x86/p5-core.flan → test/programs/x86-p5-core.flan
View File

Some files were not shown because too many files have changed in this diff Show More