diff --git a/TODO.org b/TODO.org index d721a04c..d909cd1d 100644 --- a/TODO.org +++ b/TODO.org @@ -522,7 +522,7 @@ Func, Fnptr. CLOSED: [2026-09-25] Only a capturing =fn= that may outlive its frame gets a collector environment; one only called or passed down keeps its stack environment, as every handler does. -Capture stays by value, and a =Map= of function values is refused. Rules out a +Capture stays by value; a =Map= walks its values as a =Vec= does. Rules out a tag bit on the environment word and a heap environment for every closure. ** WAIT CFn and C's calling convention @@ -911,16 +911,6 @@ there is a =Vec= to write real arena programs with, so whether the escapes that actually occur are lexical can now be answered. The next thing to look at, not the next thing to build. -** TODO A fixed array of structs or of strings is not a map key -Refused by name, narrower than the spec's key set; a struct holding the array -works. It needs the per-element walk a struct key gets, driven by a loop rather -than a field list. - -** TODO map-keys and map-values cannot be prelude functions -Iteration is built; the remaining refusal is generics. A =defn= has to name its -types and =(defn map-keys [m (Map K V)] (Vec K))= has no =K=. The loop is three -lines at the call site, where =K= is known. - ** DONE (vec-new [u8]) is refused CLOSED: [2026-09-25] The type positions of =vec-new= and =map-new= take a type expression: brackets, or @@ -944,9 +934,10 @@ pairs. Rules out a type slot in =let=. CLOSED: [2026-09-25] =[const T]= and =(Ptr const T)=; a =[T]= or =(Ptr T)= converts at the top of a type or under another const one, never inside a writable one. The const is shallow: an element of a =[const [u8]]= and a Vec's buffer are writable. The address of read-only storage, a string's byte included, is a =(Ptr const T)=, and a C =const T *= parameter takes one. -** TODO (slice d 1) over a dyn string is refused where (at d i) works -The typed and dyn spaces disagree about a spelling, which the standing rule -forbids. A dyn slice should exist. +** TODO (slice d 1) over a dyn vec traps where the typed Vec's works +A text slices to a copy, which is the typed view's meaning because a text is +immutable. A vec's slice has to share the vec's elements, so it needs a view +object over a dyn vec; a copy would compute something else. ** TODO (slice "abc" 0 99) is not refused at compile time A string type carries no length, so there is nothing to compare the bound against @@ -1085,13 +1076,6 @@ Every program in the corpus that compiles, has a =main= and terminates agrees wi the LLVM build down to stderr. =docs/BUILT.md=, "The hand-written x86 backend, and the four measurements behind it", is the account. -** NEXT Nothing pins the LLVM side at -O0 when the two backends are compared -Decided 2026-09-25: the x86 parity survey compares against LLVM at -O0 only; -O2 is never its target. The acceptance suite's paired -O2/-O0 rows stay, being the check for undefined behaviour in emitted IR, which is a different question. -The survey builds both sides at the default =-O2=, so a construct LLVM folds is -compared as a constant rather than as a lowering. That is how the float =%= gap -survived. Two things would close it: an =-O0= pass of the sweep, and something -that walks the two backends' primitive match arms mechanically. Neither is queued. - ** DONE Reading (uninit) before writing it is undefined behaviour CLOSED: [2026-09-25] Reading an =(uninit)= value before writing it is undefined behaviour, and the backends may differ on it. An exhausted match stays =ud2= on x86. @@ -1447,12 +1431,14 @@ through a pointer into it is answerable; memcheck is told the same fact, so the same read is reported. The two stay two claims — different tools reaching different people. -** NEXT The leak question across the corpus +** WAIT The leak question across the corpus Decided 2026-09-25: one pass over the whole corpus with LeakSanitizer and memcheck's leak check on. Memory an allocator holds by design is set aside; memory nothing owns is a leak and is fixed. The sweeps' default stays leak-checking off. -Both sweeps run with leak checking off, because allocate-once-never-free is this -runtime's design and a leak check produces a suppression list. A green sweep -therefore says nothing about who frees the newly allocating =(bytes s)=. Worth -asking on purpose one day, across the whole corpus and not one program. +WAIT on the between-batches sweep slot: the switches are +=ASAN_OPTIONS=detect_leaks=1 dune build @sanitize= and =FLAN_LEAKS=1 dune build @valgrind=. +A 22-program LSan sample found no runtime leak; program leaks in map-remove and +map-keys are fixed. Needs a decision: =(bytes s)= and =(clone slice)= with no +allocator answer a =[T]= over a heap block nothing can free (bytes-copy.flan). +Temp-allocator by default, as =i64->bytes= is, or a =(Vec T)= the caller frees? ** DONE trap_oom has no site CLOSED: [2026-09-25] diff --git a/bin/main.ml b/bin/main.ml index 1e208239..baa14c73 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -324,14 +324,31 @@ let () = List.iter (fun path -> with_errors path (fun () -> - Flan.Reader.read_file path + Flan.Source.read_file path |> List.iter (fun f -> print_endline (Flan.Form.to_string f)))) files + (* The other syntax, on stdout: a .flan file printed indented, a .fln file + printed with parentheses, comments and number spellings kept both + ways. *) + | [ _; "convert"; path ] -> + with_errors path (fun () -> + let forms = Flan.Source.read_file path in + let source = In_channel.with_open_bin path In_channel.input_all in + if Flan.Source.is_indented path then + print_string (Flan.Paren_printer.program ~source forms) + else + match Flan.Indent_printer.program ~source forms with + | text -> print_string text + | exception Flan.Indent_printer.Unprintable (f, why) -> + Flan.Loc.failk "convert/unprintable" f.Flan.Form.loc + "%s has no spelling in the indented syntax, so this file cannot \ + be converted. Rename it in the .flan file and convert again" + why) | _ :: "parse" :: files when files <> [] -> List.iter (fun path -> with_errors path (fun () -> - Flan.Reader.read_file path + Flan.Source.read_file path |> Flan.Parse.program_all |> List.iter (fun d -> print_endline (summarise d)))) files @@ -390,13 +407,13 @@ let () = the header's records. *) | _ :: "import-c" :: header :: rest -> with_errors header (fun () -> - let pkg = List.filter (fun a -> Filename.check_suffix a ".flan") rest in + let pkg = List.filter Flan.Source.is_source rest in let flags = - List.filter (fun a -> not (Filename.check_suffix a ".flan")) rest + List.filter (fun a -> not (Flan.Source.is_source a)) rest in let ds = List.concat_map - (fun f -> Flan.Parse.program (Flan.Reader.read_file f)) pkg + (fun f -> Flan.Parse.program (Flan.Source.read_file f)) pkg in let structs = List.filter_map @@ -554,10 +571,10 @@ let () = let out = Filename.concat dir "generated.flan" in let ds = List.concat_map - (fun f -> Flan.Parse.program (Flan.Reader.read_file f)) + (fun f -> Flan.Parse.program (Flan.Source.read_file f)) (List.filter (fun f -> not (String.equal f out)) - (Flan.Load.entries dir ".flan")) + (Flan.Load.source_entries dir)) in let config = Flan.Load.binding_config dir in match Flan.Load.header_specs ~loc dir with @@ -948,5 +965,6 @@ let () = [--debug] [--sanitize] [--x86] [--warn-memory] [--target=wasm32-wasi|web|js]\n\ \ flan run [build flags...] [--] [program args...]\n\ \ flan reload [-o out.so] [--x86]\n\ - \ flan dev [-s socket] [--x86]"; + \ flan dev [-s socket] [--x86]\n\ + \ flan convert "; exit 2 diff --git a/docs/BUGS-2026-09-18.md b/docs/BUGS-2026-09-18.md index 094ec6e4..b7f923e8 100644 --- a/docs/BUGS-2026-09-18.md +++ b/docs/BUGS-2026-09-18.md @@ -64,7 +64,7 @@ claims the hardware masks to operand width; it masks to 63. `emit.ml:2041` masks `bits-1` explicitly (TODO.org, "A shift count is bounded two different ways", records this as the language's rule). Six confirmed divergences, e.g. `(<< x 32)` on i32: LLVM 1, x86 0; `(>> i8min 8)`: LLVM --128, x86 -1. Invisible because `spike/x86/survey.sh:80` never globs `spike/js/*.flan`, +-128, x86 -1. Invisible because `test/survey-x86.sh:80` never globs `spike/js/*.flan`, where `p1-int-semantics.flan` already catches it — widen the glob in the same lane. Same wide-compute root, second divergence: float→int overflow under `--no-bounds-checks` gives 0 on x86 (64-bit `cvttsd2si` then truncate) vs INT_MIN on LLVM. Acknowledged-UB diff --git a/docs/BUILT.md b/docs/BUILT.md index d38d0ac1..02727c6e 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -1266,8 +1266,8 @@ looked wrong. ### Proved by comparing output, never by reading bytes -`spike/x86/survey.sh` builds each program in `test/programs` and each probe in `spike/x86` twice — once default, once -`--x86`, **with the same bounds-check setting on both sides** — runs both, and compares stdout, stderr and the exit +`test/survey-x86.sh` builds each program in `test/programs`, the `x86-p*` probes among them, twice — once through LLVM +at `-O0`, once `--x86`, **with the same bounds-check setting on both sides** — runs both, and compares stdout, stderr and the exit status. stderr is not a detail: every message the condition machinery produces goes there, each carrying a location this backend emits by hand as a `.rodata` label and a length in a register, and an exit status of 134 with the wrong text beside it is exactly the failure that reads as a match. @@ -1375,7 +1375,7 @@ must not land in the middle of one; and the `flan_dev_reg_enable` constructor, w **The corpus structurally cannot test this.** A dev build starts with every cell pointing at the body this build compiled, so it prints what a release build prints whether or not anything reads the cell — the property that makes -the whole corpus a safe test of the cells is the property that makes it a useless one. `spike/x86/cells.sh` preloads +the whole corpus a safe test of the cells is the property that makes it a useless one. `test/cells.sh` preloads a shared object whose constructor looks up `flan.cell.twice` with `dlsym` and stores a different body there: the one store a redefinition ends in, done from outside with no compiler involved. Four builds, and the two release rows are half the test — they answer `42 42` because there is no cell and `dlsym` finds nothing, which is what says the change @@ -1401,7 +1401,7 @@ refused. What it does not emit is locals and types, and that is deliberate — a temporary whose lifetime this backend does not model, so there is nothing honest for a `DW_TAG_variable` to point at. A backtrace names files, functions and lines; `print x` says the name is not in the current context. A `flan dev --debug` session still takes LLVM's side, because `X86.redefinition` emits no line table. -- **Code size and speed** are measured, in `spike/x86/COST.md`. This backend emits **3.84× the code LLVM does at +- **Code size and speed** were measured in `spike/x86/COST.md`, since deleted with `spike/` and in git history. This backend emits **3.84× the code LLVM does at `-O2` and 1.92× what LLVM emits at `-O0`** — half the factor is the optimiser and not the backend. Of the five suspected costs, the frame-slot round trip on every intermediate is most of everything and is the one worth fixing; `rep movsb` is twenty cycles a copy and worth fixing cheaply; the bounds check's three temporaries cost 241 bytes @@ -1563,7 +1563,7 @@ least two" — and lets the old caller fail at run time with a wrong-number-of-a count at run time to fail on, so the run-time half is a check it has to emit. **A dev cell is three words**: `{ ptr body, i64 word, ptr text }`. The body is first, so a plain load of the cell is -still the body and `spike/x86/cells.sh`'s store through `dlsym` still works. The word is a hash (FNV-1a) of the +still the body and `test/cells.sh`'s store through `dlsym` still works. The word is a hash (FNV-1a) of the signature spelled the way a `defn` writes it — `[i64 i64] i64` — and the text is that spelling as a C string. `Emit.sig_text` and `Emit.sig_word` are the one definition both backends use. A redefinition module's installer stores the word and the text beside the body; a registry cell (`flan_dev_cell`) is three zeroed words until then. @@ -1844,8 +1844,8 @@ the merged entry point uses to flush and park. #### What the embedding spike measured, and the three rules it left behind The merge was taken on a spike run before any of it was built — `spike/embed/`, four shell scripts and sixteen small -sources driving `ocamlfind` and `clang` by hand against the `flan.cmxa` dune already builds. Nothing under `spike/` is -wired into the build. What it answered is why the shape above was safe to commit to. +sources driving `ocamlfind` and `clang` by hand against the `flan.cmxa` dune already builds, deleted since and kept in +git history. What it answered is why the shape above was safe to commit to. **Linking.** `ocamlopt -output-complete-obj`, not `-output-obj`: it bundles the runtime, so there is no hunt for `libasmrun`. The final link needs `-lm -lpthread -ldl` and, on 5.x, **`-lzstd`** — the marshaller is compressed, and @@ -1864,7 +1864,7 @@ specific capability the merged design needs. expected conflict does not exist. The reason is structural: OCaml 5 detects stack overflow with an explicit stack-limit check rather than with a guard page and a SIGSEGV handler. So the break loop can take `SIGSEGV` outright and does not have to install first or last. **This is an `x86_64-pc-linux-gnu` measurement only** — re-run -`spike/embed/sig.sh` on macOS/arm64 before relying on it there. `flan_agent.c` needs nothing from it either way; it +`spike/embed/sig.sh` (git history) on macOS/arm64 before relying on it there. `flan_agent.c` needs nothing from it either way; it sends with `MSG_NOSIGNAL` throughout. **The GC and raw memory.** An 8 MiB arena filled with a checkable pattern, 64 raw interior pointers taken into it, @@ -4578,8 +4578,13 @@ read of a local. So the prelude's `map`, `filter` and `reduce` are as cheap in a closure as in one that makes none: a map, filter and reduce loop measured 1.77G instructions at LLVM `-O2` with and without one unrelated escaping closure. -**What is refused.** A `Map` whose values hold a function value (`fn-in-map.flan`): a `Map`'s storage is not walked. -A bare `Fn` field, global or array element is still refused for its zero; `(Option (Fn ...))` holds one. +**A `Map`'s values are walked the same way** (`fn-in-map.flan`). A descriptor's `maps` table names each `Map` header +and the value type's descriptor; `flan_rt.c` reports each `Map` block through the same hook, and the marker walks the +full slots of a live block, reading the slot count from the header and the stride and value offset from the block's +own head. It covers a dyn value as well as a closure, so `(Map K dyn)` holds dyn values the collector keeps. The hook +is installed by any program holding a dyn, not only one making heap closures. + +**What is refused.** A bare `Fn` field, global or array element, for its zero; `(Option (Fn ...))` holds one. **A module that makes a heap closure is never unloaded**: the environment points at the module's descriptor and code, so making one counts toward the same gate a string literal does. A capturing `fn` typed at the dev prompt takes diff --git a/docs/SPIKE-GENERICS.md b/docs/SPIKE-GENERICS.md index 1533da17..d7dfa36e 100644 --- a/docs/SPIKE-GENERICS.md +++ b/docs/SPIKE-GENERICS.md @@ -10,6 +10,7 @@ > and nested inside `[$t]` or `(Option $t)`, and bare `t` only where a type's *name* is an argument in > expression position, as in `(vec-new t)` and the cast `(t x)`. `(Option t)` does not compile. > plan.org's Types section and spec-memory.md's Generics section are the current account. +> `spike/`, which held every file this report names, was deleted on 2026-09-25; the files are in git history. Milestone 5's parametric polymorphism, run early and deliberately out of order, as a spike rather than as a decision. **Feasible, and smaller than expected.** A generic function written in Flan goes through the ordinary diff --git a/docs/handoffs/HANDOFF-arith.md b/docs/handoffs/HANDOFF-arith.md index 0b512cd6..6f673f1b 100644 --- a/docs/handoffs/HANDOFF-arith.md +++ b/docs/handoffs/HANDOFF-arith.md @@ -76,7 +76,7 @@ because `load_loc` has already widened both operands according to their own sign backends used to diverge silently rather than both dying: x86 divided in 64 bits and truncated on the store, producing `-2147483648` for an `i32`, where LLVM emitted poison. `arith.flan` has an `i32` case for exactly that reason. -`spike/x86/survey.sh` is 101 MATCH / 0 DIFFER / 0 REFUSED, with the two programs this change adds among them. +`test/survey-x86.sh` is 101 MATCH / 0 DIFFER / 0 REFUSED, with the two programs this change adds among them. `arith.flan` carries an `i32` overflow case and an `f32` cast case on purpose, and neither is padding. The `i32` overflow is where the two backends disagreed *silently* rather than both dying, and it is the only thing that diff --git a/docs/handoffs/HANDOFF-cimport-ptr.md b/docs/handoffs/HANDOFF-cimport-ptr.md index ac32f351..6349a518 100644 --- a/docs/handoffs/HANDOFF-cimport-ptr.md +++ b/docs/handoffs/HANDOFF-cimport-ptr.md @@ -124,11 +124,11 @@ actually about is a **pointer reinterpretation**, which is not a checker arm. `defstruct`, every hand-written `declare-c` and every mapped constant against `raylib-5.5.h` and refuses to write when they disagree. - `bash web/examples/check.sh` green. -- `spike/x86/survey.sh` on the finished tree: **103 MATCH, 0 DIFFER, 0 REFUSED** (38 skip +- `test/survey-x86.sh` on the finished tree: **103 MATCH, 0 DIFFER, 0 REFUSED** (38 skip — 28 that do not compile on purpose, 8 with no main, 2 that run forever). Expected rather than surprising: nothing here is below the IR, and the one surveyed program that changed is `test/programs/raylib-codepoints.flan`. Run it detached — `setsid timeout - 2400 spike/x86/survey.sh > log 2>&1 log 2>&1 log 2>&1 log 2>&1 log 2>&1 log 2>&1 log 2>&1 log 2>&1 ` beside ``. @@ -112,7 +112,7 @@ fixtures did **not** fail here — `/tmp` had room throughout (6% used at start **Yes, reached and tested.** And the test is the interesting part, because *the corpus cannot do it*: a dev build starts with every cell pointing at the body that build compiled, so it prints exactly what a release build prints -whether or not anything reads the cell. `spike/x86/cells.sh` preloads a `.so` whose constructor `dlsym`s +whether or not anything reads the cell. `test/cells.sh` preloads a `.so` whose constructor `dlsym`s `flan.cell.twice` (the cells are in `.dynsym` — a dev build is `-rdynamic`) and stores a different body there. Four builds; the two release rows are the control that says the effect is the indirection and not symbol interposition: @@ -162,5 +162,5 @@ returned a struct. `cells.sh` does not reach it: the body it installs is `(i64, bounds check, every intermediate in memory, `rep movsb` block copies, and now an extra load per call site in a dev build — which is the one item `emit.ml` pays too. -**Also worth doing and not a backend item: run `spike/x86/survey.sh` in CI.** The 2 refusals this lane found were a +**Also worth doing and not a backend item: run `test/survey-x86.sh` in CI.** The 2 refusals this lane found were a month-old lane's new prim, and nothing noticed. A backend that refuses by name does not rot quietly, but it does rot. diff --git a/emacs/MANUAL.md b/emacs/MANUAL.md index 34130ffa..7c4a4b01 100644 --- a/emacs/MANUAL.md +++ b/emacs/MANUAL.md @@ -1052,7 +1052,7 @@ it is written in the compiler, so there is no file to open. `C-c C-l` on a name opens `*flan-lowering*`: the LLVM IR the frontend emits for that function, what `llc` makes of it at `-O0` and at `-O2`, and what the hand-written x86 backend emits, all narrowed to the one function. It is -`spike/x86/dump.sh` with a buffer around it. Reading one against another is the +`tools/dump.sh` with a buffer around it. Reading one against another is the only way to check a lowering by eye, and the reason the second backend is trustworthy is that the two agree. diff --git a/emacs/flan-lower.el b/emacs/flan-lower.el index 4fdd3268..87197096 100644 --- a/emacs/flan-lower.el +++ b/emacs/flan-lower.el @@ -19,7 +19,7 @@ ;; to is not an Emacs package and cannot be listed here either -- emacs/MANUAL.md ;; says what has to be on PATH. -;; `spike/x86/dump.sh' prints four lowerings of one function side by side -- +;; `tools/dump.sh' prints four lowerings of one function side by side -- ;; the LLVM IR the frontend emits, what `llc' makes of it at -O0 and at -O2, ;; and what the hand-written x86 backend emits. Reading one against another is ;; the only way to check a lowering by eye, and the whole reason the second diff --git a/emacs/flan.el b/emacs/flan.el index 92e42a89..614e91b2 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -2579,7 +2579,8 @@ breakpoint is marked from the editor, without editing the buffer\"." ;; buffer-file-name so an error points at the file being edited ;; rather than at the daemon's placeholder. (append - (list :op "eval" :code code :file (or buffer-file-name "")) + (list :op "eval" :code code :file (or buffer-file-name "") + :syntax (flan--syntax)) (when pause (list :pause (flan--wire-position (car pause)))))))) ;; END as the place a value could go. Every caller of this sends a @@ -2615,27 +2616,35 @@ columns already were, because a top-level form starts at column 1." (concat (make-string (1- (line-number-at-pos start)) ?\n) (buffer-substring-no-properties start end))) +(defun flan--syntax () + "The `:syntax' of code sent from this buffer: the indented reader's for a +.fln file, the paren reader's for anything else. Sent explicitly because the +daemon cannot tell from `:file' — an expansion shown in parens is sent back +under the name of the .fln file it came from." + (if (and buffer-file-name (string-suffix-p ".fln" buffer-file-name)) + "indented" + "paren")) + +(defvar flan--code-fields nil + "Extra request fields for the code a command is about to send: its +`:syntax', and `:line'/`:col' when it is sent from the middle of a line.") + (defun flan--text-at (start end) - "The buffer text from START to END, on the line AND column it is written at. + "The buffer text from START to END, and where it starts, as +(TEXT :syntax S :line L :col C). -`flan--text' pads lines only, and says why it needs nothing more: a -top-level form starts at column 1, so the columns already agreed. A macro -call does not. It is written somewhere inside a `defn', and a refusal the -daemon reports against it — a macro that never settles is the one that -happens — carries a column that would otherwise be measured from the start of -the snippet and drawn at the start of the line. - -Leading newlines and leading spaces are both whitespace the reader skips, so -padding with each is the whole fix. Byte columns, for the reason -`flan--wire-position' gives: the reader walks the source a byte at a time, -and a space is one byte, so a byte count is exactly how many to write." +Sent unpadded, with its line and column as fields: the daemon starts its +reader there, so every location in a reply is the buffer's own. Padding +with spaces, which this used to do, cannot work for the indented syntax, +where leading spaces are an indentation. Byte columns, for the reason +`flan--wire-position' gives." (save-excursion (goto-char start) - (concat (make-string (1- (line-number-at-pos start)) ?\n) - (make-string (- (position-bytes start) - (position-bytes (line-beginning-position))) - ?\s) - (buffer-substring-no-properties start end)))) + (list (buffer-substring-no-properties start end) + :syntax (flan--syntax) + :line (line-number-at-pos start) + :col (1+ (- (position-bytes start) + (position-bytes (line-beginning-position))))))) (defun flan--defun-bounds () "Bounds of the top-level form containing or preceding point, as (START . END)." @@ -2799,15 +2808,18 @@ why one `C-u' and two mean the same thing here. `flan--text-at' rather than `flan--text': an expression is not a top-level form and does not start at column 1, so a refusal the daemon reports against -it carries a column measured from the start of the snippet. Padding both ways -is what puts the error overlay on the character it is about — and the overlay -this draws on success would otherwise be competing with one drawn at line 1." +it carries a column measured from the start of the snippet unless the request +says where the snippet starts. The `:line' and `:col' fields it sends are what +put the error overlay on the character it is about — and the overlay this +draws on success would otherwise be competing with one drawn at line 1." (flan--report (flan--request - (append - (list :op "eval-expr" :code (flan--text-at start end) - :file (or buffer-file-name "")) - (when arg (list :pause t)))) + (let ((at (flan--text-at start end))) + (append + (list :op "eval-expr" :code (car at) + :file (or buffer-file-name "")) + (cdr at) + (when arg (list :pause t))))) "expression" end)) @@ -2897,6 +2909,7 @@ the command signals, as `C-c C-c' does." (interactive) (let* ((reply (flan--request (list :op "load-file" :file (or buffer-file-name "") + :syntax (flan--syntax) :code (buffer-substring-no-properties (point-min) (point-max))))) (errors (plist-get reply :errors))) @@ -3230,8 +3243,9 @@ ALL asks for the fixpoint rather than one step. Answers the reply plist, or signals — having drawn the refusal where it happened, which is why the caller sends padded text." (let ((r (funcall flan-macroexpand-request-function - (list :op "macroexpand" :code code :file file - :all (if all t nil))))) + (append (list :op "macroexpand" :code code :file file + :all (if all t nil)) + flan--code-fields)))) (unless (equal (plist-get r :status) "ok") (let ((loc (plist-get r :loc)) (msg (plist-get r :message))) @@ -3264,7 +3278,8 @@ indentation, which lives in `flan-mode' and not in the compiler." (let ((inhibit-read-only t)) (erase-buffer) (flan-macroexpansion-mode) - (setq flan-macroexpand--origin (list :code code :file file :all all)) + (setq flan-macroexpand--origin (list :code code :file file :all all + :fields flan--code-fields)) (let ((start (point))) (insert (format "; macroexpansion, %s\n" (if all "all the way" "one step"))) @@ -3314,10 +3329,11 @@ rather than with what is typed." ;; Padded onto its own line *and column*, unlike `C-x C-e', because ;; the refusals this path can get name a location inside the snippet ;; and a macro call is written well inside a line. - (code (flan--text-at (car b) (cdr b))) + (at (flan--text-at (car b) (cdr b))) + (code (car at)) + (flan--code-fields (cdr at)) (r (flan-macroexpand--ask code file all))) - (flan-macroexpand--render r (buffer-substring-no-properties (car b) (cdr b)) - file all) + (flan-macroexpand--render r code file all) (pulse-momentary-highlight-region (car b) (cdr b)) (unless (plist-get r :expanded) (message "flan: %s" (or (plist-get r :note) "nothing expanded"))) @@ -3346,6 +3362,8 @@ non-nil ALL, take it all the way instead." ;; file, so there is no line or column for a refusal to be drawn at. ;; The file still goes on the wire — it is what tells the daemon which ;; session's macros to expand against. + ;; An expansion is printed in parens whatever its file is written in. + (flan--code-fields (list :syntax "paren")) (r (flan-macroexpand--ask code (plist-get flan-macroexpand--origin :file) all))) (if (not (plist-get r :expanded)) @@ -3377,6 +3395,7 @@ remove." (unless flan-macroexpand--origin (user-error "flan: this is not a macroexpansion buffer")) (let* ((o flan-macroexpand--origin) + (flan--code-fields (plist-get o :fields)) (r (flan-macroexpand--ask (plist-get o :code) (plist-get o :file) (plist-get o :all)))) (flan-macroexpand--render r (plist-get o :code) (plist-get o :file) diff --git a/lib/build.ml b/lib/build.ml index 70e94449..9b25b1d9 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -690,11 +690,23 @@ let compile_c ~opts ?tflags ?(warn = []) ~src ~name () = built against, so repointing either must not serve a stale .o. *) let tflags = match tflags with Some f -> f | None -> target_flags opts in let cc = compiler opts in + (* A source that includes the dyn header was compiled against it, so the + header is part of what the object depends on. Without it a change to a + struct the header declares served an object built against the old layout + — test/dyn_ops.c read a descriptor's new fields past the end of its own. *) + let header = + let needle = "flan_dyn.h" in + let n = String.length needle and m = String.length src in + let rec has i = + i + n <= m && (String.sub src i n = needle || has (i + 1)) + in + if has 0 then Runtime_src.dyn_header else "" + in let key = Digest.to_hex (Digest.string (String.concat "\000" - [ name; src; stamp_of cc; opts.opt; + [ name; src; header; stamp_of cc; opts.opt; String.concat " " (cflags opts); String.concat " " tflags; String.concat " " warn ])) diff --git a/lib/check.ml b/lib/check.ml index ee0c4daf..9ca97cf7 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -3662,14 +3662,9 @@ let rec key_pair env loc (k : Types.t) : Tast.fnref * Tast.fnref = fail loc "%s is a union, and a union is not a map key — key on the member you \ meant" n - | Types.Array (_, e) -> - (* A fixed array of a struct or of strings would need the same per-element - walk a struct key gets, driven by a loop rather than by a field list. - Nothing has wanted one, so it is refused by name rather than written - untested — and refused with the shape that does work named beside it. *) - fail loc - "a fixed array of %s is not a map key — a struct holding the array is" - (Types.to_string e) + (* A bytewise array took the arm above; this is one whose elements need + their own pair, a string's or a struct's. *) + | Types.Array (n, e) -> array_key_pair env loc n e | Types.Float _ -> (* Not a milestone question, which is why it is said separately: NaN is not equal to itself, and 0.0 and -0.0 are equal while differing bytewise. A @@ -3801,6 +3796,129 @@ and struct_key_pair env loc n = Tast.Flanfn hname, Tast.Flanfn ename end +(* The pair for a fixed array whose elements are not bytewise: the struct + pair's shape, with the field list replaced by a loop over the elements, so + [[64 string]] is one call site in a loop and not sixty-four. Each element is + hashed and compared by its own pair, so an array of structs holding strings + is served by the same recursion. *) +and array_key_pair env loc n e = + if Int64.compare n 0L <= 0 then + fail loc + "%s has no elements, so it is not a map key — every value of it would be \ + the same key" (Types.to_string (Types.Array (n, e))); + let aty = Types.Array (n, e) in + (* The type's printed form, with what a symbol cannot hold replaced. *) + let tag = + String.map + (fun c -> match c with + | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' -> c + | _ -> '_') + (Types.to_string aty) + in + (* The mangle is many-to-one — [a+b] and [a_b] come out alike — so a digest + of the printed type, which is an identity, keeps two such keys apart. *) + let tag = + tag ^ "/" ^ String.sub (Digest.to_hex (Digest.string (Types.to_string aty))) 0 12 + in + let hname = "map/hash/array/" ^ tag and ename = "map/eq/array/" ^ tag in + let known name = + List.exists (fun (f : Tast.fn) -> f.Tast.name = name) env.lifted + in + if known hname then Tast.Flanfn hname, Tast.Flanfn ename + else begin + let pty = Types.Ptr (Types.Mut, aty) in + let hparams = [ pty; hash_ty; Types.Int Types.I64 ] in + let eparams = [ pty; pty; Types.Int Types.I64 ] in + let placeholder name ret params = + { Tast.name; params; slots = Array.of_list params; + snames = Array.make (List.length params) None; + ret; body = []; fdefers = []; fenv = None; fparent = None; floc = loc } + in + env.lifted <- + placeholder hname hash_ty hparams + :: placeholder ename (Types.Int Types.I8) eparams + :: env.lifted; + let h, eq = key_pair env loc e in + let call ret f args = + match f with + | Tast.Rtfn s -> rt loc ret (direct s) args + | Tast.Flanfn s | Tast.Fnval s -> mk loc ret (Tast.Call (s, args)) + in + let elem_addr p i = + let target = mk loc aty (Tast.Deref (mk loc pty (Tast.Local p))) in + mk loc (Types.Ptr (Types.Mut, e)) + (Tast.Addr (Tast.Pindex (target, [ mk loc index_ty (Tast.Local i) ]))) + in + (* The counter and its loop, which carries no break and no continue — the + condition tast.ml puts on a [While] the checker invents. *) + let loop ctx body = + let i = fresh_slot ~name:"i" ctx index_ty in + let iv = mk loc index_ty (Tast.Local i) in + let limit = mk loc index_ty (Tast.Int (n, Types.I32)) in + let one = mk loc index_ty (Tast.Int (1L, Types.I32)) in + let cond = mk loc Types.Bool (Tast.Prim (Tast.Lt, [ iv; limit ])) in + let step = + mk loc Types.Unit + (Tast.Set (Tast.Plocal i, + mk loc index_ty (Tast.Prim (Tast.Add, [ iv; one ])))) + in + mk loc Types.Unit + (Tast.Let ([ (i, mk loc index_ty (Tast.Int (0L, Types.I32))) ], + [ mk loc Types.Unit (Tast.While (cond, [ body i ], [ step ])) ])) + in + let hctx = invented_ctx env hash_ty in + let kp = fresh_slot ~name:"key" hctx pty in + let seed = fresh_slot ~name:"seed" hctx hash_ty in + ignore (fresh_slot ~name:"size" hctx (Types.Int Types.I64)); + let acc = fresh_slot ~name:"h" hctx hash_ty in + let hbody = + [ mk loc Types.Unit + (Tast.Set (Tast.Plocal acc, mk loc hash_ty (Tast.Local seed))); + loop hctx (fun i -> + let one = + call hash_ty h + [ elem_addr kp i; mk loc hash_ty (Tast.Local seed); + size_of loc e ] + in + mk loc Types.Unit + (Tast.Set (Tast.Plocal acc, + rt loc hash_ty "flan_hash_combine" + [ mk loc hash_ty (Tast.Local acc); one ]))); + mk loc hash_ty (Tast.Local acc) ] + in + let ectx = invented_ctx env (Types.Int Types.I8) in + let ap = fresh_slot ~name:"a" ectx pty in + let bp = fresh_slot ~name:"b" ectx pty in + ignore (fresh_slot ~name:"size" ectx (Types.Int Types.I64)); + let i8 v = mk loc (Types.Int Types.I8) (Tast.Int (v, Types.I8)) in + let ebody = + [ loop ectx (fun i -> + let same = + call (Types.Int Types.I8) eq + [ elem_addr ap i; elem_addr bp i; size_of loc e ] + in + mk loc Types.Unit + (Tast.If (mk loc Types.Bool (Tast.Prim (Tast.Eq, [ same; i8 0L ])), + mk loc Types.Never (Tast.Return (Some (i8 0L))), + unit_at loc))); + i8 1L ] + in + let finish name ret params ctx body = + { Tast.name; params; + slots = Array.of_list (List.rev ctx.slot_tys); + snames = Array.of_list (List.rev ctx.slot_names); + ret; body; fdefers = []; fenv = None; fparent = None; floc = loc } + in + env.lifted <- + finish hname hash_ty hparams hctx hbody + :: finish ename (Types.Int Types.I8) eparams ectx ebody + :: List.filter + (fun (f : Tast.fn) -> + f.Tast.name <> hname && f.Tast.name <> ename) + env.lifted; + Tast.Flanfn hname, Tast.Flanfn ename + end + (* The pair as two expressions, ready to be passed. Their Flan type is [(Ptr ())]: one opaque word, which is all the backend needs. *) let key_fns env loc k = @@ -7144,6 +7262,32 @@ and unknown_name : 'a. ?setting:bool -> ctx -> Loc.t -> string -> 'a = (match no_such_rand name with | Some msg -> Loc.failk "check/unknown-name" loc "%s" msg | None -> ()); + (* In the indented syntax a binary operator needs spaces, so [x-1], [i+1] + and [x/2] are one name each. When the parts either side of an operator + character are a value in scope and a number or another value, that is + almost certainly the arithmetic, and the sentence says how to spell it. *) + (if Filename.check_suffix loc.Loc.file ".fln" then begin + let known s = + s <> "" + && (String.for_all (fun c -> (c >= '0' && c <= '9') || c = '.') s + || lookup ctx s <> None + || Hashtbl.mem ctx.env.globals s) + in + let n = String.length name in + let rec scan i = + if i < n - 1 then + match name.[i] with + | ('-' | '+' | '*' | '/') as c + when i > 0 && known (String.sub name 0 i) + && known (String.sub name (i + 1) (n - i - 1)) -> + Loc.failk "check/unknown-name" loc + "unknown name %s — an operator needs a space on each side, so \ + this is one name and not arithmetic. Did you mean %s %c %s?" + name (String.sub name 0 i) c (String.sub name (i + 1) (n - i - 1)) + | _ -> scan (i + 1) + in + scan 0 + end); let dot = String.index_opt name '.' in let head, field = match dot with @@ -9434,22 +9578,33 @@ and named_call ?(qualified = false) ctx ~want loc name args = (while (map-next m (addr cur) (addr k) (addr v)) ...)) - It is *not* a generic (map-keys m): a Vec of them needs a signature naming - K, and a prelude defn cannot be written at every K. That one is generics, - not iteration, and it stays refused for that reason. + The prelude's map-keys and map-values are this loop over a generic key. No hash and no equality pair go with it — walking asks nothing about a key — so this is the one map entry point whose signature carries neither, and the sizes are still needed because the runtime is type-erased. *) + (* (map-next m cur k) walks the keys alone. It is what lets a walk need no + place for a value, which matters when the value is a function value: one + cannot be zeroed to make the place, and a key never is one. *) | "map-next" -> - arity ctx loc name 4 args; (match args with - | [ target; cur; k; v ] -> + | [ _; _; _ ] | [ _; _; _; _ ] -> () + | _ -> + fail loc + "map-next is (map-next m (addr cursor) (addr k) (addr v)) or, for \ + the keys alone, (map-next m (addr cursor) (addr k)) — given %d \ + arguments" (List.length args)); + (match args with + | target :: cur :: k :: rest -> let target = check_target ctx target in let kt, vt = map_kv loc "map-next" target.Tast.ty in let cur = check ctx ~want:(Types.Ptr (Types.Mut, (Types.Int Types.I64))) cur in let k = check ctx ~want:(Types.Ptr (Types.Mut, kt)) k in - let v = check ctx ~want:(Types.Ptr (Types.Mut, vt)) v in + let vp = Types.Ptr (Types.Mut, vt) in + let v = match rest with + | [ v ] -> check ctx ~want:vp v + | _ -> mk loc vp (Tast.Zero vp) + in let found = rt loc (Types.Int Types.I8) "flan_map_next" [ target; cur; k; v; size_of loc kt; size_of loc vt; here loc ] @@ -9868,6 +10023,20 @@ and named_call ?(qualified = false) ctx ~want loc name args = (* A Vec leaves here: everything below is written around a length the compiler can see, and a Vec's is a word the runtime reads. *) | Types.Vec elem -> vec_slice ctx ~want loc target elem bounds + (* A dyn leaves too, as [at] over one does: the bounds are dyn, like + [at]'s index, and a missing [hi] is nil, which the runtime reads as + the length. *) + | Types.Dyn -> + let bound b = check ctx ~want:Types.Dyn b in + let nil () = rt loc Types.Dyn "flan_dyn_nil" [] in + let lo, hi = match bounds with + | [] -> box loc (mk loc dyn_i64 (Tast.Int (0L, Types.I64))), nil () + | [ lo ] -> bound lo, nil () + | [ lo; hi ] -> bound lo, bound hi + | _ -> assert false + in + expect ctx loc ~want + (rt loc Types.Dyn "flan_dyn_slice" [ target; lo; hi; here loc ]) | _ -> (* A string slices to a string, not to a [u8]: the result views the same bytes and is read-only for the same reason the source is, and @@ -13514,8 +13683,11 @@ let rec hidden_dyn p seen (t : Types.t) : Types.t option = | Types.Dyn -> None | Types.Array (_, e) -> hidden_dyn p seen e | Types.Vec e | Types.Option e -> under e + (* A Map's values are walked through the value type's own descriptor, so a + dyn there is found wherever that descriptor finds one. A key never holds + one: dyn is not a key type. *) | Types.Map (k, v) -> - if dyn_anywhere p seen k || dyn_anywhere p seen v then Some t else None + if dyn_anywhere p seen k then Some t else hidden_dyn p seen v (* A pointer and a slice are views of storage something else roots; see the note above. What they point at is checked where it is declared. *) | Types.Ptr (_, e) | Types.Slice (_, e) -> hidden_dyn p seen e @@ -13635,53 +13807,8 @@ let rec holds_fn p seen (t : Types.t) = | None -> false) | _ -> false -(* The first Map under this type whose values hold a function value. A - closure's environment is found by walking the storage a function value - sits in, and a Map's storage is not walked — so an (Fn ...) there would be - one the collector frees under it. A Vec's is, which is the container to - use; and a (CFn ...) carries no environment and may go in a Map freely. *) -let rec map_of_fn p seen (t : Types.t) : Types.t option = - match t with - | Types.Map (k, v) when holds_fn p [] k || holds_fn p [] v -> Some t - | Types.Array (_, e) | Types.Vec e | Types.Option e - | Types.Ptr (_, e) | Types.Slice (_, e) -> map_of_fn p seen e - | Types.Map (_, v) -> map_of_fn p seen v - | Types.Named n when not (List.mem n seen) -> - let seen = n :: seen in - let fields = - match List.find_opt (fun (s : Tast.structure) -> s.Tast.sname = n) - p.Tast.structs with - | Some s -> s.Tast.fields - | None -> - match List.find_opt (fun (u : Tast.data) -> u.Tast.dname = n) - p.Tast.datas with - | Some u -> List.concat_map (fun (c : Tast.variant) -> c.Tast.vfields) u.Tast.cases - | None -> - match List.find_opt (fun (u : Tast.structure) -> u.Tast.sname = n) - p.Tast.unions with - | Some u -> u.Tast.fields - | None -> [] - in - List.fold_left - (fun acc (fl : Tast.field) -> - match acc with Some _ -> acc | None -> map_of_fn p seen fl.Tast.fty) - None fields - | _ -> None - let dyn_descriptors (p : Tast.program) = let check loc what (t : Types.t) = - (match map_of_fn p [] t with - | Some at -> - Loc.failk "check/fn-in-map" loc - "%s is %s%s, a Map whose values are function values. A function \ - value's environment is found by walking the storage it sits in, \ - and a Map's storage is not walked, so the collector would free an \ - environment still in use. Keep the function values in a Vec, or \ - make them (CFn ...) if they capture nothing" - what (Types.to_string t) - (if Types.equal t at then "" - else Printf.sprintf ", and holds %s" (Types.to_string at)) - | None -> ()); (match hidden_dyn p [] t with | Some at -> Loc.failk "check/dyn-descriptor" loc diff --git a/lib/dev.ml b/lib/dev.ml index 299cfbbd..2ec66a11 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1166,7 +1166,7 @@ let errors_field (ds : Loc.diag list) = survives the reply is a refusal, with the first error where every other refusal puts it. *) let load_file t ~code ~origin = - match Reader.read_all ~file:origin code with + match Source.read_code ~file:origin code with | exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } -> error ~loc:(Loc.to_string l) msg | forms -> @@ -4438,7 +4438,27 @@ let memory_op t ~file = doing the only thing it can. See TODO.org, \"Memory diagnostics \ on demand\"" ] -let handle t req = +(* Every code-carrying request is read in the syntax it names and at the + position it names; see [Source.read_code]. *) +let rec handle t req = + let syntax = + match Wire.string_field req "syntax", Wire.string_field req "op", + Wire.string_field req "file" with + | (Some _ as s), _, _ -> Source.syntax_of_field s + (* A whole file named with no [:syntax] is in the syntax its name says: + that is not a guess, it is what [Source.read_file] would do. *) + | None, Some "load-file", Some f when Source.is_indented f -> Source.Indented + | None, _, _ -> Source.Paren + in + let at = + match Wire.int_field req "line", Wire.int_field req "col" with + | Some l, Some c -> Some (l, c) + | Some l, None -> Some (l, 1) + | _ -> None + in + Source.with_code ~syntax ~at (fun () -> handle_op t req) + +and handle_op t req = match Wire.string_field req "op" with | Some "eval" -> (match Wire.string_field req "code" with diff --git a/lib/emit.ml b/lib/emit.ml index 390aae7e..c1e0dc3f 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -81,7 +81,7 @@ let cellname n = "@" ^ quoted (Mangle.cell n) { ptr body, i64 word, ptr text } The body is first, so everything that only ever wanted the body — a load - of the cell, [spike/x86/cells.sh]'s store through [dlsym] — reads the + of the cell, [test/cells.sh]'s store through [dlsym] — reads the same address it always did. The word is what makes a signature change installable. A redefinition that @@ -459,23 +459,26 @@ let align_up x a = if a <= 1 then x else ((x + a - 1) / a) * a pointer is four bytes and [goff] would name the wrong word. *) type gcword = { goff : int; gpath : (string * string list) list } -(* Every word of an instance the collector follows, by kind — the three +(* Every word of an instance the collector follows, by kind — the four tables of runtime/flan_dyn.h's [flan_desc]. [gvec] carries each Vec's - element type, whose own descriptor the entry points at. *) + element type and [gmap] each Map's value type, whose own descriptor the + entry points at. *) type gclayout = { gdyn : gcword list; genv : gcword list; gvec : (gcword * Types.t) list; + gmap : (gcword * Types.t) list; } (* A descriptor this module has to write out: its symbol, the words, the instance size, and the symbol of each Vec entry's element descriptor in - [gvec]'s order. *) + [gvec]'s order and of each Map entry's value descriptor in [gmap]'s. *) type desc = { dsym : string; dlay : gclayout; dsize : int; dvecs : string list; + dmaps : string list; } (* ── Module-level state ────────────────────────────────────────────── *) @@ -747,16 +750,12 @@ and dyn_offsets m (t : Types.t) : int list = — which is a run-time question a static descriptor cannot answer. Refused in [Check] rather than described wrongly here. *) | None -> acc) - (* [Types.Option], [Types.Vec] and [Types.Map] fall through here with no - arm of their own and answer no offsets, which is correct only because - nothing reaches this function holding one with a dyn inside it: + (* [Types.Option] and [Types.Vec] fall through here with no arm of their + own and answer no offsets, which is correct only because nothing + reaches this function holding one with a dyn inside it: [Check.hidden_dyn] refuses that at every global, parameter, return and - frame slot first. If that gate is ever relaxed — the typed-container - view the M2 queue's item 3 is building is exactly the kind of change - that would relax it for [Vec]/[Map] — this arm has to grow alongside - it, the way the array and struct arms above already walk their own - storage; until then a silent [] here would be an unrooted dyn, not a - refusal. *) + frame slot first. A [Types.Map]'s dyn values are not words of the + instance at all; [gc_layout] names the header in its [gmap] table. *) | _ -> acc in List.sort_uniq compare (go [] 0 t []) @@ -800,7 +799,7 @@ let desc_mangle (t : Types.t) = symbol. *) let rec desc_of m (t : Types.t) : string option = let l = gc_layout m t in - if l.gdyn = [] && l.genv = [] && l.gvec = [] then None + if l.gdyn = [] && l.genv = [] && l.gvec = [] && l.gmap = [] then None else let key = Types.to_string t in match Hashtbl.find_opt m.descs key with @@ -812,17 +811,19 @@ let rec desc_of m (t : Types.t) : string option = (* Claimed before the elements are asked for, so the counter a nested element's symbol takes cannot be this one's. *) Hashtbl.replace m.descs key - { dsym = sym; dlay = l; dsize = fst (lay m t); dvecs = [] }; - let dvecs = + { dsym = sym; dlay = l; dsize = fst (lay m t); dvecs = []; dmaps = [] }; + let elems what l = List.map (fun (_, e) -> match desc_of m e with | Some s -> s - | None -> internal "a Vec entry whose element has no words") - l.gvec + | None -> internal "a %s entry whose element has no words" what) + l in + let dvecs = elems "Vec" l.gvec in + let dmaps = elems "Map" l.gmap in Hashtbl.replace m.descs key - { dsym = sym; dlay = l; dsize = fst (lay m t); dvecs }; + { dsym = sym; dlay = l; dsize = fst (lay m t); dvecs; dmaps }; Some sym (* ── The words the collector follows ───────────────────────────────── @@ -851,7 +852,7 @@ let rec desc_of m (t : Types.t) : string option = at the same x86-64 offset and at different wasm32 ones, and marking a word twice costs nothing. *) and gc_layout m (t : Types.t) : gclayout = - let dyn = ref [] and env = ref [] and vec = ref [] in + let dyn = ref [] and env = ref [] and vec = ref [] and map = ref [] in let step ty idx path = path @ [ (ty, idx) ] in let rec go ~full seen off path (t : Types.t) = match t with @@ -864,6 +865,13 @@ and gc_layout m (t : Types.t) : gclayout = [desc_of] claims before it recurses, is what closes that loop. *) | Types.Vec e when m.gcfn -> if reaches_fn m [] e then vec := ({ goff = off; gpath = path }, e) :: !vec + (* A Map's values, when they hold a function value's environment or a + dyn. The key never does: neither is a key type. The value type's own + descriptor is what the entry points at, so a Map of Maps is walked + through the inner one's. *) + | Types.Map (_, v) -> + if (m.gcfn && reaches_fn m [] v) || reaches_dyn m [] v then + map := ({ goff = off; gpath = path }, v) :: !map | Types.Array (n, e) -> let s, _ = lay m e in for i = 0 to Int64.to_int n - 1 do @@ -930,7 +938,8 @@ and gc_layout m (t : Types.t) : gclayout = in let uniq l = List.sort_uniq order l in { gdyn = uniq !dyn; genv = uniq !env; - gvec = List.sort_uniq (fun (a, _) (b, _) -> order a b) !vec } + gvec = List.sort_uniq (fun (a, _) (b, _) -> order a b) !vec; + gmap = List.sort_uniq (fun (a, _) (b, _) -> order a b) !map } (* Whether an [(Fn ...)] is anywhere in a value's storage, a Vec's elements included. A type met again on the way contributes nothing more, which @@ -939,7 +948,8 @@ and gc_layout m (t : Types.t) : gclayout = and reaches_fn m seen (t : Types.t) = match t with | Types.Fn _ -> true - | Types.Array (_, e) | Types.Vec e | Types.Option e -> reaches_fn m seen e + | Types.Array (_, e) | Types.Vec e | Types.Option e | Types.Map (_, e) -> + reaches_fn m seen e | Types.Named nm when not (List.mem nm seen) -> let seen = nm :: seen in let fields = @@ -956,17 +966,35 @@ and reaches_fn m seen (t : Types.t) = List.exists (fun (fl : Tast.field) -> reaches_fn m seen fl.Tast.fty) fields | _ -> false +(* Whether a dyn word is anywhere [gc_layout] records one: directly, in a + fixed array, in a struct field, or in a Map's values. The other places a + dyn could sit are refused by [Check.hidden_dyn]. *) +and reaches_dyn m seen (t : Types.t) = + match t with + | Types.Dyn -> true + | Types.Array (_, e) | Types.Map (_, e) -> reaches_dyn m seen e + | Types.Named nm when not (List.mem nm seen) -> + (match Hashtbl.find_opt m.structs nm with + | Some st -> + List.exists + (fun (fl : Tast.field) -> reaches_dyn m (nm :: seen) fl.Tast.fty) + st.Tast.fields + | None -> false) + | _ -> false + (* Whether the collector has anything to follow in a value of this type — the question every rooting decision asks. [dyn_offsets <> []] was that question until an [Fn] could hold an environment. *) let traced m (t : Types.t) = t = Types.Dyn - || (let l = gc_layout m t in l.gdyn <> [] || l.genv <> [] || l.gvec <> []) + || (let l = gc_layout m t in + l.gdyn <> [] || l.genv <> [] || l.gvec <> [] || l.gmap <> []) (* The words to clear before an instance at a pushed root can be marked, as x86-64 byte offsets of eight-byte words: each dyn word, each environment - word, and each Vec header's pointer and length. The LLVM backend walks - [gpath] instead; see [zero_words]. *) + word, each Vec header's pointer and length, and each Map header's block + pointer and capacity. The LLVM backend walks [gpath] instead; see + [zero_words]. *) let gc_zero_offsets m (t : Types.t) : int list = if t = Types.Dyn then [ 0 ] else @@ -974,6 +1002,7 @@ let gc_zero_offsets m (t : Types.t) : int list = List.map (fun w -> w.goff) l.gdyn @ List.map (fun w -> w.goff) l.genv @ List.concat_map (fun (w, _) -> [ w.goff; w.goff + 8 ]) l.gvec + @ List.concat_map (fun (w, _) -> [ w.goff; w.goff + 16 ]) l.gmap (* A [gpath] as an LLVM constant expression over [base]: nested constant [getelementptr]s, one per step. Over [ptr null] and through [ptrtoint] it @@ -4289,7 +4318,12 @@ let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) = (fun ((w : gcword), _) -> store "ptr null" (w.gpath @ [ ("%vec", [ "i32 0"; "i32 0" ]) ]); store "i64 0" (w.gpath @ [ ("%vec", [ "i32 0"; "i32 1" ]) ])) - l.gvec + l.gvec; + List.iter + (fun ((w : gcword), _) -> + store "ptr null" (w.gpath @ [ ("%map", [ "i32 0"; "i32 0" ]) ]); + store "i64 0" (w.gpath @ [ ("%map", [ "i32 0"; "i32 2" ]) ])) + l.gmap end in let push base (ty : Types.t) = @@ -4957,6 +4991,7 @@ declare i64 @flan_dyn_ge(i64, i64, ptr, i64) declare i64 @flan_dyn_eq(i64, i64) declare i64 @flan_dyn_len(i64) declare i64 @flan_dyn_at(i64, i64, ptr, i64) +declare i64 @flan_dyn_slice(i64, i64, i64, ptr, i64) declare void @flan_dyn_set_at(i64, i64, i64, ptr, i64) declare void @flan_dyn_push(i64, i64, ptr, i64) declare void @flan_dyn_print(i64) @@ -5113,7 +5148,7 @@ let uses_dyn (p : Tast.program) = let rec carries seen (t : Types.t) = match t with | Types.Dyn -> true - | Types.Array (_, e) -> carries seen e + | Types.Array (_, e) | Types.Map (_, e) -> carries seen e | Types.Named n when not (List.mem n seen) -> (match Hashtbl.find_opt structs n with | Some st -> @@ -5147,12 +5182,13 @@ let emit_main m ?(startup = false) ?(gc = false) ?(dyn_globals = []) (fn : Tast. dyn global's initialiser runs in the startup function below, and the very first thing it does is allocate. *) if gc then Buffer.add_string b " call void @flan_gc_init()\n"; - (* Before anything can allocate a Vec block: a program that can make a - collector-owned closure environment has flan_rt.c report every Vec block - to the collector, which reads a Vec's elements only through a block it - knows to be live (runtime/flan_dyn.c, "The Vec blocks a marker may - read"). *) - if m.gcfn then Buffer.add_string b " call void @flan_dyn_track_vecs()\n"; + (* Before anything can allocate a Vec or Map block: a program that can make + a collector-owned closure environment, or that holds a dyn, has + flan_rt.c report every such block to the collector, which reads a + container's elements only through a block it knows to be live + (runtime/flan_dyn.c, "The Vec blocks a marker may read"). *) + if m.gcfn || gc then + Buffer.add_string b " call void @flan_dyn_track_vecs()\n"; (* The dyn globals, rooted here and never popped, which is the whole of what a global's extent means. They go on the stack *before* the startup function runs, because that function is what fills them and its first @@ -5426,21 +5462,24 @@ let descriptors m = let l = d.dlay in let offs = table d.dsym "offs" "i64" (List.map word l.gdyn) in let envs = table d.dsym "envs" "i64" (List.map word l.genv) in - let vecs = - table d.dsym "vecs" "{ i64, ptr }" + let pairs suffix words syms = + table d.dsym suffix "{ i64, ptr }" (List.map2 (fun ((w : gcword), _) e -> Printf.sprintf "{ i64, ptr } { i64 %s, ptr @\"%s\" }" (offset_const w) e) - l.gvec d.dvecs) + words syms) in + let vecs = pairs "vecs" l.gvec d.dvecs in + let maps = pairs "maps" l.gmap d.dmaps in Buffer.add_string b (Printf.sprintf "@\"%s\" = private unnamed_addr constant \ - { i64, i64, ptr, i64, ptr, i64, ptr } \ - { i64 %d, i64 %d, ptr %s, i64 %d, ptr %s, i64 %d, ptr %s }\n" + { i64, i64, ptr, i64, ptr, i64, ptr, i64, ptr } \ + { i64 %d, i64 %d, ptr %s, i64 %d, ptr %s, i64 %d, ptr %s, \ + i64 %d, ptr %s }\n" d.dsym d.dsize (List.length l.gdyn) offs (List.length l.genv) - envs (List.length l.gvec) vecs)); + envs (List.length l.gvec) vecs (List.length l.gmap) maps)); Buffer.contents b (* The same table in the other backend's syntax. It lives here rather than in @@ -5484,19 +5523,22 @@ let descriptors_asm m = in let offs = table "offs" (List.map (fun w -> string_of_int w.goff) l.gdyn) in let envs = table "envs" (List.map (fun w -> string_of_int w.goff) l.genv) in - let vecs = - table "vecs" + let pairs suffix words syms = + table suffix (List.concat (List.map2 (fun ((w : gcword), _) e -> [ string_of_int w.goff; ".L" ^ e ]) - l.gvec d.dvecs)) + words syms)) in + let vecs = pairs "vecs" l.gvec d.dvecs in + let maps = pairs "maps" l.gmap d.dmaps in Buffer.add_string b (Printf.sprintf "\t.align\t8\n.L%s:\n\t.quad\t%d\n\t.quad\t%d\n\t.quad\t%s\n\ - \t.quad\t%d\n\t.quad\t%s\n\t.quad\t%d\n\t.quad\t%s\n" + \t.quad\t%d\n\t.quad\t%s\n\t.quad\t%d\n\t.quad\t%s\n\ + \t.quad\t%d\n\t.quad\t%s\n" d.dsym d.dsize (List.length l.gdyn) offs (List.length l.genv) envs - (List.length l.gvec) vecs)) + (List.length l.gvec) vecs (List.length l.gmap) maps)) rows; Buffer.contents b diff --git a/lib/front.ml b/lib/front.ml index fee00c6f..6ee0ad30 100644 --- a/lib/front.ml +++ b/lib/front.ml @@ -13,7 +13,7 @@ let load ?(all = false) path : Load.t = Load.program ~file:path ~parse:(if all then Parse.program_all else Parse.program) - (Reader.read_file path) + (Source.read_file path) let check ?(all = false) (l : Load.t) : Tast.program = (if all then Check.program_all else Check.program) l.Load.decls diff --git a/lib/indent_printer.ml b/lib/indent_printer.ml new file mode 100644 index 00000000..eb3bfd38 --- /dev/null +++ b/lib/indent_printer.ml @@ -0,0 +1,725 @@ +(** [Form.t] to indented text: the inverse of [Indent_reader], and what + [flan convert] writes. + + The one rule that keeps the round trip exact: a piece of sugar is printed + only when the form has exactly the shape that sugar reads back to, and + everything else goes through the fallback, [head(arg, ...)], or + [head(arg, ...):] with the trailing arguments as an indented block. The + fallback reads any form, so a form this printer cannot sweeten still + prints; what it cannot print at all is a name with no spelling in the + indented syntax, and that raises [Unprintable]. + + Comments are not in a [Form.t], so a converted file has none. *) + +module R = Indent_reader + +exception Unprintable of Form.t * string + +let width = 80 + +let unprintable (f : Form.t) why = raise (Unprintable (f, why)) + +(* Words a statement may start with that the reader takes as a header. A + statement whose text would lead with one is wrapped in parentheses, which + the reader takes as grouping and so as the plain name. *) +let reserved = + [ "fn"; "fn-"; "def"; "once"; "const"; "struct"; "union"; "data"; "enum"; + "import"; "if"; "elif"; "else"; "while"; "until"; "match"; "let"; "for"; + "return"; "break"; "continue"; "defer"; "handler-case"; "handler-bind"; + "restart-case"; "quote"; "on"; "restart" ] + +(* A symbol the reader gives back as itself when it is written bare. *) +let name_ok s = + let n = String.length s in + n > 0 + && (not (String.exists Reader.is_delimiter s)) + && (not (String.contains s ':')) + && s.[0] <> '\'' && s.[0] <> '\\' + && (not (Reader.is_digit s.[0])) + && (not ((s.[0] = '-' || s.[0] = '+') && n > 1 && Reader.is_digit s.[1])) + && (not (n > 1 && s.[0] = '-' && R.is_neg_char s.[1])) + && R.split_fields s = [ s ] + && (not (R.is_op_word s)) + && not (n >= 2 && s.[0] = '#' && s.[1] = '_') + +let kw_ok k = k <> "" && not (String.exists Reader.is_delimiter k) + +(* A name a definition's header can take: the reader reads a leading dot + there as a field access, so [.init-once.counter] keeps the fallback. *) +let def_name s = name_ok s && s.[0] <> '.' + +let paren s = "(" ^ s ^ ")" + +(* A number's own spelling, when the caller has the text it was read from: + [Form.Int] keeps only the value, so without this 0xFFF00FFF would print + as 4293922815. Set by [program ~source]. *) +let spelling : (Form.t -> string option) ref = ref (fun _ -> None) + +(* Whether a comment sits inside a form, on a line before its last: such a + form is not squeezed onto one line, or the comment would have no line of + its own to go to. Set by [program ~source]. *) +let inside : (Form.t -> bool) ref = ref (fun _ -> false) + +(* The same form, locations aside. *) +let rec same (a : Form.t) (b : Form.t) = + match a.v, b.v with + | Form.List x, Form.List y | Form.Vec x, Form.Vec y | Form.Map x, Form.Map y -> + List.length x = List.length y && List.for_all2 same x y + | x, y -> x = y + +let is_sym s (f : Form.t) = match f.v with Form.Sym x -> x = s | _ -> false + +(* ── Expressions ───────────────────────────────────────────────────── *) + +(* Text and syntactic level, the same scale [Indent_reader] reads: 10 an atom + or bracket, 9 a postfix chain, 8 a unary minus, 1-7 binary, 3 [not], 0 a + one-line [if] or a lambda. *) +let rec expr (f : Form.t) : string * int = + match f.v with + | Form.Sym s -> sym f s + | Form.Kw k -> + if kw_ok k then (":" ^ k, 10) else unprintable f "a keyword with no spelling" + | Form.Int i -> + let t = Option.value (!spelling f) ~default:(Int64.to_string i) in + (t, if t.[0] = '-' then 8 else 10) + | Form.UInt (_, s) -> (s, 10) + | Form.Float x -> + let s = Option.value (!spelling f) ~default:(Form.float_repr x) in + if not (Reader.is_digit s.[0] || (s.[0] = '-' && String.length s > 1 + && Reader.is_digit s.[1])) + then unprintable f "a float with no literal"; + (s, if s.[0] = '-' then 8 else 10) + | Form.Str s -> ("\"" ^ Form.escape s ^ "\"", 10) + | Form.Byte b -> (Form.byte_repr b, 10) + | Form.Vec xs -> ("[" ^ vec_text xs ^ "]", 10) + | Form.Map xs -> ("{" ^ map_text xs ^ "}", 10) + | Form.List [] -> ("()", 10) + | Form.List (h :: args) -> list f h args + +and sym f s = + if s = "==" then unprintable f "the name == (it reads as =)" + else if R.is_op_word s || s = "if" then (paren s, 10) + else if name_ok s then (s, 10) + else unprintable f (Printf.sprintf "the name %s" s) + +and at lvl f = + let t, l = expr f in + if l < lvl then paren t else t + +and comma_items xs = + let rec go = function + | [] -> [] + | ({ Form.v = Form.Sym "const"; _ }) :: y :: rest -> + ("const " ^ at 0 y) :: go rest + | x :: rest -> at 0 x :: go rest + in + go xs + +and commas xs = String.concat ", " (comma_items xs) + +(* Whitespace between single terms, as [[1 2 3]] and [[4 f32]] read; commas + as soon as one element has an operator in it. *) +and vec_text xs = + let ts = List.map expr xs in + if List.for_all (fun (_, l) -> l >= 8) ts then String.concat " " (List.map fst ts) + else String.concat ", " (List.map (fun (t, _) -> t) ts) + +and map_text xs = + let ts = List.map expr xs in + if List.for_all (fun (_, l) -> l >= 8) ts then String.concat " " (List.map fst ts) + else + let rec pairs = function + | (k, kl) :: (v, _) :: rest -> + ((if kl < 8 then paren k else k) ^ " " ^ v) :: pairs rest + | [ (k, _) ] -> [ k ] + | [] -> [] + in + String.concat ", " (pairs ts) + +and head_text (h : Form.t) = + match h.v with + | Form.Sym "==" -> unprintable h "the name ==" + | Form.Sym s when R.is_op_word s -> s + | Form.Sym s -> fst (sym h s) + | _ -> at 9 h + +and list _f h args = + let call () = (head_text h ^ "(" ^ commas args ^ ")", 9) in + match h.v, args with + | Form.Sym "quote", [ x ] -> ("'" ^ Form.to_source x, 10) + | Form.Sym "unquote", [ x ] -> ("~" ^ at 10 x, 10) + | Form.Sym "unquote-splicing", [ x ] -> ("~@" ^ at 10 x, 10) + | Form.Sym s, _ :: _ :: _ + when (R.is_binop s || s = "=") && s <> "==" && not (s = "!=" && List.length args > 2) -> + let op = if s = "=" then "==" else s in + let lvl = Option.get (R.binop_level op) in + let first = List.hd args and rest = List.tl args in + let ft, fl = expr first in + let same = match first.v with + | Form.List (h' :: _ :: _ :: _) -> is_sym s h' || lvl = 4 + | _ -> false + in + let ft = if fl < lvl || (fl = lvl && same) then paren ft else ft in + (String.concat (" " ^ op ^ " ") (ft :: List.map (at (lvl + 1)) rest), lvl) + | Form.Sym "-", [ x ] -> + let t, l = expr x in + if l >= 9 && t <> "" && R.is_neg_char t.[0] then ("-" ^ t, 8) + else ("-(" ^ at 0 x ^ ")", 9) + | Form.Sym "not", [ x ] -> ("not " ^ at 3 x, 3) + | Form.Sym "at", t :: (_ :: _ as idx) -> (at 9 t ^ "[" ^ commas idx ^ "]", 9) + | Form.Sym s, [ t ] + when String.length s > 1 && s.[0] = '.' && name_ok s + && not (String.contains (String.sub s 1 (String.length s - 1)) '.') -> + let tt, tl = expr t in + let glued = + tl >= 9 + && (match t.v with + | Form.Byte _ -> false + | Form.Sym x -> name_ok x && not (String.contains x '.') && not (R.capitalised x) + | _ -> + let c = tt.[String.length tt - 1] in + c = ')' || c = ']' || c = '}' || c = '"') + in + if glued then (tt ^ s, 9) else call () + | Form.Sym s, [ ({ v = Form.Map _; _ } as m) ] when name_ok s && R.capitalised s -> + (s ^ fst (expr m), 9) + | Form.Sym "fn", [ { v = Form.Vec ps; _ }; body ] when List.for_all sym_param ps -> + ("fn(" ^ commas ps ^ ") = " ^ at 0 body, 0) + | Form.Sym "if", [ c; a; b ] -> + ("if " ^ at 1 c ^ " then " ^ inline_text ~lvl:1 a ^ " else " ^ inline_text b, 0) + | _ -> call () + +(* A one-line slot's text — an arm's value, a then or an else, what follows + defer: the statements that fit on a line are written as statements, + everything else as a value. [lvl] is what a value in the slot needs. *) +and inline_text ?(lvl = 0) (f : Form.t) = + match f.v with + | Form.List [ { v = Form.Sym (("break" | "continue" | "return") as w); _ } ] -> w + | Form.List [ { v = Form.Sym (("break" | "continue") as w); _ }; { v = Form.Kw k; _ } ] + when kw_ok k -> + w ^ " :" ^ k + | Form.List [ { v = Form.Sym "return"; _ }; v ] -> "return " ^ at (max lvl 1) v + | Form.List [ { v = Form.Sym "set"; _ }; t; v ] -> assign_text ~lvl t v + | _ -> at lvl f + +(* [t = v], or [t += w] when [v] is [(+ t w)]. *) +and assign_text ?(lvl = 0) t v = + let tt = at 9 t in + match v.v with + | Form.List [ { v = Form.Sym (("+" | "-" | "*" | "/") as op); _ }; a; w ] when same a t -> + tt ^ " " ^ op ^ "= " ^ at (max lvl 1) w + | _ -> tt ^ " = " ^ at (max lvl 1) v + +and sym_param (p : Form.t) = + match p.v with Form.Sym s -> name_ok s | _ -> false + +(* A type after [:] or [->]: the function-type arrow at the top, a postfix + term below it. *) +let rec ty (f : Form.t) = + match f.v with + | Form.List [ { v = Form.Sym (("Fn" | "CFn") as h); _ }; { v = Form.Vec ps; _ }; r ] -> + h ^ "(" ^ commas ps ^ ") -> " ^ ty r + | _ -> at 9 f + +(* A [defn]'s parameter type the reader could not mistake for a name: a + primitive, a capitalised or [$] name, or a bracket. [[x y]] with a + lowercase [y] keeps the fallback, because what it means depends on + whether [y] names a type. *) +let type_shaped (f : Form.t) = + match f.v with + | Form.Sym t -> + List.mem t Types.primitive_names || (t <> "" && t.[0] = '$') || R.capitalised t + | Form.List [] | Form.List ({ v = Form.Sym _; _ } :: _) | Form.Vec _ -> true + | _ -> false + +let rec pairs = function + | a :: b :: rest -> Option.map (fun r -> (a, b) :: r) (pairs rest) + | [] -> Some [] + | [ _ ] -> None + +(* [(a: i32, b)] from [[a i32 b dyn]], when every name is a plain name. *) +let params_text ?(shaped = false) (ps : Form.t list) = + match pairs ps with + | None -> None + | Some prs -> + if List.for_all + (fun ((n : Form.t), t) -> + (match n.v with Form.Sym x -> def_name x | _ -> false) + && ((not shaped) || is_sym "dyn" t || type_shaped t)) + prs + then + Some + (String.concat ", " + (List.map + (fun ((n : Form.t), t) -> + let n = fst (expr n) in + if is_sym "dyn" t then n else n ^ ": " ^ ty t) + prs)) + else None + +(* ── Statements ────────────────────────────────────────────────────── *) + +let ind n = String.make n ' ' + +let lead_word text = + let n = String.length text in + let rec go i = if i < n && not (Reader.is_delimiter text.[i]) then go (i + 1) else i in + let i = go 0 in + (String.sub text 0 i, i = n || text.[i] = ' ') + +(* A statement whose text leads with a reserved word, parenthesised. *) +let guard text = + let w, spaced = lead_word text in + if spaced && List.mem w reserved then paren text else text + +let stmts_of (f : Form.t) = + match f.v with + | Form.List ({ v = Form.Sym "do"; _ } :: (_ :: _ :: _ as ss)) -> ss + | _ -> [ f ] + +(* Heads whose trailing arguments are a body, and how many come before it. *) +let body_split (h : Form.t) args = + match h.v with + | Form.Sym s -> + let base = + match String.rindex_opt s '/' with + | Some i -> String.sub s (i + 1) (String.length s - i - 1) + | None -> s + in + let lead = List.length (List.filter (fun (a : Form.t) -> + match a.v with Form.List _ -> false | _ -> true) args) in + (match base with + | "comment" | "do" -> Some 0 + | "unless" | "loop" -> Some 1 + | "defmacro" -> Some 2 + | "defmethod" -> Some 3 + | _ -> + (* A with- macro, or any call whose last argument is a statement — + a let, a loop, an assignment — has a body: the trailing run of + lists goes in the block. *) + let stmt_like (a : Form.t) = + match a.v with + | Form.List ({ v = Form.Sym h; _ } :: _) -> + List.mem h [ "let"; "set"; "when"; "unless"; "cond"; "while"; + "until"; "dotimes"; "match"; "handler-case"; + "handler-bind"; "restart-case"; "return"; "defer"; + "do"; "break"; "continue" ] + | _ -> false + in + let is_with = String.length base > 5 && String.sub base 0 5 = "with-" in + let last_stmt = + match List.rev args with a :: _ -> stmt_like a | [] -> false + in + ignore lead; + if is_with || last_stmt then begin + let k = ref 0 in + List.iteri + (fun i (a : Form.t) -> + match a.v with Form.List (_ :: _) -> () | _ -> k := i + 1) + args; + Some !k + end + else None) + | _ -> None + +let sugar_heads = + [ "let"; "set"; "if"; "when"; "cond"; "while"; "until"; "dotimes"; "match"; + "handler-case"; "handler-bind"; "restart-case"; "return"; "defer"; "do"; + "quasiquote" ] + +let rec block n (fs : Form.t list) : string list = + let rec go = function + | [] -> [] + | [ x ] -> stmt n ~last:true x + | x :: rest -> stmt n ~last:false x @ go rest + in + go fs + +and stmt n ~last (f : Form.t) : string list = + let ls = match sugar n ~last f with Some ls -> ls | None -> plain n f in + (* The first line carries the line the form came from, for + [Source_text.weave] to put the comments back by. *) + match ls with + | first :: rest -> Source_text.tag f.loc.Loc.line first :: rest + | [] -> [] + +and plain n (f : Form.t) : string list = + let text = + match f.v with + | Form.List [] -> "(())" + | Form.List [ { v = Form.Sym "do"; _ } ] -> "()" + | Form.Sym s when List.mem s reserved -> paren s + | _ -> guard (fst (expr f)) + in + let one = [ ind n ^ text ] in + match f.v with + | Form.List (h :: args) when args <> [] -> + (match body_split h args with + | Some k when k < List.length args -> + let fixed = List.filteri (fun i _ -> i < k) args in + let rest = List.filteri (fun i _ -> i >= k) args in + let opener = + match h.v, fixed with + (* No arguments before the block: [comment:] rather than + [comment():], the author's decision 85. *) + | Form.Sym s, [] when name_ok s && not (List.mem s reserved) -> s ^ ":" + | _ -> head_text h ^ "(" ^ commas fixed ^ "):" + in + [ ind n ^ guard opener ] @ block (n + 2) rest + | _ when n + String.length text > width && fst (expr f) = text -> + wrapped n "" f + | _ -> one) + | _ -> one + +(* A call too long for its line, broken after commas inside its + parentheses, where a line break is only whitespace. [prefix] is what + comes before the call on the first line. *) +and wrapped n prefix (f : Form.t) = + match f.v with + | Form.List (h :: (_ :: _ as args)) when (match h.v with + | Form.Sym ("at" | "quote" | "unquote" | "unquote-splicing") -> false + | Form.Sym s -> not (R.is_op_word s) && not (String.length s > 1 && s.[0] = '.') + | _ -> false) -> + let open_ = prefix ^ head_text h ^ "(" in + let col = n + String.length open_ in + let items = comma_items args in + let rec go line acc = function + | [] -> List.rev ((line ^ ")") :: acc) + | [ t ] -> + if String.length line = col || String.length line + String.length t + 1 <= width + then go (line ^ t) acc [] + else + let line = String.sub line 0 (String.length line - 1) in + go (ind col ^ t) (line :: acc) [] + | t :: rest -> + let piece = t ^ "," in + if String.length line = col || String.length line + String.length piece <= width + then go (line ^ piece ^ " ") acc rest + else + let line = String.sub line 0 (String.length line - 1) in + go (ind col ^ piece ^ " ") (line :: acc) rest + in + (* The last item on a line carries a trailing space; the break drops it. *) + let lines = go (ind n ^ open_) [] items in + List.map (fun l -> + let k = String.length l in + if k > 0 && l.[k - 1] = ' ' then String.sub l 0 (k - 1) else l) lines + | _ -> [ ind n ^ prefix ^ at 0 f ] + +(* [prefix = v], or [prefix =] and the value as an indented block when it is + too long for the line. *) +and value_lines n prefix (v : Form.t) = + let inline = prefix ^ " = " ^ at 0 v in + let is_do = + match v.v with + | Form.List ({ v = Form.Sym "do"; _ } :: _ :: _ :: _) -> true + | _ -> false + in + if is_do then [ ind n ^ prefix ^ " =" ] @ block (n + 2) (stmts_of v) + else if n + String.length inline <= width then [ ind n ^ inline ] + else + match v.v with + | Form.List ({ v = Form.Sym "fn"; _ } :: { v = Form.Vec ps; _ } :: (_ :: _ as body)) + when List.for_all sym_param ps -> + [ ind n ^ prefix ^ " = fn(" ^ commas ps ^ ")" ] @ block (n + 2) body + | Form.List ({ v = Form.Sym h; _ } :: _) + when not (List.mem h sugar_heads || h = "fn" || h = "if") -> + wrapped n (prefix ^ " = ") v + | Form.List (_ :: _) -> [ ind n ^ prefix ^ " =" ] @ block (n + 2) (stmts_of v) + | _ -> [ ind n ^ inline ] + +and slot n (f : Form.t) = block n (stmts_of f) + +and label_of = function + | ({ Form.v = Form.Kw k; _ }) :: rest when kw_ok k -> (":" ^ k ^ " ", rest) + | rest -> ("", rest) + +and sugar n ~last (f : Form.t) : string list option = + let i = ind n in + match f.v with + | Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs; _ } :: (_ :: _ as body)) -> + (match pairs bs with + | None | Some [] -> None + | Some prs -> Some (let_lines n ~last prs body)) + | Form.List [ { v = Form.Sym "set"; _ }; t; v ] -> + let line = i ^ guard (assign_text t v) in + if String.length line <= width then Some [ line ] + else Some (value_lines n (guard (at 9 t)) v) + | Form.List [ { v = Form.Sym "if"; _ }; c; a; b ] -> + let simple (x : Form.t) = + match x.v with + | Form.List ({ v = Form.Sym ("return" | "set" | "break" | "continue"); _ } :: _) -> true + | Form.List ({ v = Form.Sym h; _ } :: _) -> not (List.mem h sugar_heads) + | _ -> true + in + let line = i ^ fst (expr f) in + if simple a && simple b && String.length line <= width && not (!inside f) + then Some [ line ] + else + Some + ([ i ^ "if " ^ at 1 c ] @ slot (n + 2) a + @ [ Source_text.tag b.loc.Loc.line (i ^ "else") ] @ slot (n + 2) b) + | Form.List ({ v = Form.Sym "when"; _ } :: c :: (_ :: _ as body)) -> + Some ((i ^ "if " ^ at 1 c) :: block (n + 2) body) + | Form.List ({ v = Form.Sym "cond"; _ } :: args) -> + (match pairs args with + | None -> None + | Some prs -> + let tests, else_ = + match List.rev prs with + | (k, e) :: rest when is_else k -> (List.rev rest, Some (k, e)) + | _ -> (prs, None) + in + if List.length tests < 2 then None + else + Some + (List.concat + (List.mapi + (fun j (c, b) -> + (* Each test's line carries the test's own line, so a + comment written above a clause stays above it. *) + Source_text.tag (c : Form.t).loc.Loc.line + (i ^ (if j = 0 then "if " else "elif ") ^ at 1 c) + :: slot (n + 2) b) + tests) + @ (match else_ with + | Some ((k : Form.t), e) -> + Source_text.tag k.loc.Loc.line (i ^ "else") :: slot (n + 2) e + | None -> []))) + | Form.List ({ v = Form.Sym (("while" | "until") as w); _ } :: rest) -> + let lbl, rest = label_of rest in + (match rest with + | c :: (_ :: _ as body) -> Some ((i ^ w ^ " " ^ lbl ^ at 0 c) :: block (n + 2) body) + | _ -> None) + | Form.List ({ v = Form.Sym "dotimes"; _ } :: rest) -> + let lbl, rest = label_of rest in + (match rest with + | { v = Form.Vec ({ v = Form.Sym v; _ } :: bs); _ } :: (_ :: _ as body) + when def_name v && bs <> [] && List.length bs <= 3 && v <> "in" -> + Some + ((i ^ "for " ^ lbl ^ v ^ " in range(" ^ commas bs ^ ")") :: block (n + 2) body) + | _ -> None) + | Form.List [ { v = Form.Sym "return"; _ } ] -> Some [ i ^ "return" ] + | Form.List [ { v = Form.Sym "return"; _ }; v ] -> Some [ i ^ "return " ^ at 0 v ] + | Form.List [ { v = Form.Sym (("break" | "continue") as w); _ } ] -> Some [ i ^ w ] + | Form.List [ { v = Form.Sym (("break" | "continue") as w); _ }; { v = Form.Kw k; _ } ] + when kw_ok k -> + Some [ i ^ w ^ " :" ^ k ] + | Form.List [ { v = Form.Sym "defer"; _ }; x ] -> + let line = i ^ "defer " ^ inline_text x in + if String.length line <= width then Some [ line ] + else Some ((i ^ "defer") :: block (n + 2) [ x ]) + | Form.List ({ v = Form.Sym "defer"; _ } :: (_ :: _ :: _ as body)) -> + Some ((i ^ "defer") :: block (n + 2) body) + | Form.List ({ v = Form.Sym "match"; _ } :: s :: (_ :: _ as arms)) -> + (match pairs arms with + | None -> None + | Some prs -> + Some + ((i ^ "match " ^ at 0 s) + :: List.concat_map + (fun ((pat : Form.t), body) -> + List.mapi (fun k l -> if k = 0 then Source_text.tag pat.loc.Loc.line l else l) @@ + let pt = at 8 pat in + let line = ind (n + 2) ^ pt ^ " -> " ^ inline_text body in + match body.v with + | Form.List ({ v = Form.Sym "do"; _ } :: _ :: _ :: _) -> + (ind (n + 2) ^ pt ^ " ->") :: slot (n + 4) body + | Form.List (_ :: _) when String.length line > width -> + (ind (n + 2) ^ pt ^ " ->") :: slot (n + 4) body + | _ -> [ line ]) + prs)) + | Form.List [ { v = Form.Sym "handler-case"; _ }; body; { v = Form.Vec cls; _ } ] + when cls <> [] -> + Option.map + (fun cl -> ((i ^ "handler-case") :: slot (n + 2) body) @ cl) + (handler_clauses n cls) + | Form.List ({ v = Form.Sym "handler-bind"; _ } :: { v = Form.Vec cls; _ } :: (_ :: _ as body)) + when cls <> [] -> + Option.map + (fun cl -> ((i ^ "handler-bind") :: block (n + 2) body) @ cl) + (handler_clauses n cls) + | Form.List ({ v = Form.Sym "restart-case"; _ } :: body :: (_ :: _ as cls)) -> + let clause (c : Form.t) = + match c.v with + | Form.List ({ v = Form.Sym r; _ } :: { v = Form.Vec ps; _ } :: (_ :: _ as b)) + when def_name r -> + Option.map + (fun pt -> (i ^ "restart " ^ r ^ "(" ^ pt ^ ")") :: block (n + 2) b) + (params_text ps) + | _ -> None + in + let cs = List.map clause cls in + if List.mem None cs then None + else + Some (((i ^ "restart-case") :: slot (n + 2) body) + @ List.concat_map Option.get cs) + | Form.List [ { v = Form.Sym "quasiquote"; _ }; x ] -> + Some ((i ^ "quote") :: slot (n + 2) x) + | Form.List ({ v = Form.Sym "fn"; _ } :: { v = Form.Vec ps; _ } :: (_ :: _ :: _ as body)) + when List.for_all sym_param ps -> + Some ((guard (i ^ "fn(" ^ commas ps ^ ")")) :: block (n + 2) body) + | Form.List ({ v = Form.Sym (("defn" | "defn-") as d); _ } :: { v = Form.Sym name; _ } + :: { v = Form.Vec ps; _ } :: ret :: body) + when def_name name -> + (match params_text ~shaped:true ps with + | None -> None + | Some pt -> + let where_, body = + match body with + | { v = Form.Map [ { v = Form.Kw "where"; _ }; x ]; _ } :: rest -> + let preds = + match x.v with + | Form.Vec (_ :: _ :: _ as xs) -> commas xs + | _ -> at 0 x + in + (" where " ^ preds, rest) + | _ -> ("", body) + in + let head = + i ^ (if d = "defn" then "fn " else "fn- ") ^ name ^ "(" ^ pt ^ ") -> " + ^ ty ret ^ where_ + in + (match body with + | [] -> Some [ head ] + | [ x ] when (match x.v with + | Form.List ({ v = Form.Sym h; _ } :: _) -> not (List.mem h sugar_heads) + | _ -> true) + && String.length head + 3 + String.length (at 0 x) <= width + && not (!inside f) -> + Some [ head ^ " = " ^ at 0 x ] + | _ -> Some (head :: block (n + 2) body))) + | Form.List ({ v = Form.Sym (("def" | "defonce" | "defconst") as d); _ } + :: { v = Form.Sym name; _ } :: rest) + when def_name name -> + let w = match d with "def" -> "def" | "defonce" -> "once" | _ -> "const" in + let pre = i ^ w ^ " " ^ name in + (match d, rest with + | "defconst", [ v ] -> Some (value_lines n (w ^ " " ^ name) v) + | "defconst", [ t; v ] -> Some (value_lines n (w ^ " " ^ name ^ ": " ^ ty t) v) + | "defconst", _ -> None + | _, [ t; v ] when is_sym "dyn" t -> Some (value_lines n (w ^ " " ^ name) v) + | _, [ t ] when type_shaped t -> Some [ pre ^ ": " ^ ty t ] + | _, [ t; v ] -> Some (value_lines n (w ^ " " ^ name ^ ": " ^ ty t) v) + | _ -> None) + | Form.List [ { v = Form.Sym (("defstruct" | "defunion") as d); _ }; + { v = Form.Sym name; _ }; { v = Form.Vec fs; _ } ] + when def_name name -> + (match pairs fs with + | Some prs when List.for_all (fun ((f : Form.t), _) -> + match f.v with Form.Sym x -> def_name x | _ -> false) prs -> + Some + ((i ^ (if d = "defstruct" then "struct " else "union ") ^ name) + :: List.map + (fun ((f : Form.t), t) -> + let fname = fst (expr f) in + Source_text.tag f.loc.Loc.line + (ind (n + 2) ^ if is_sym "dyn" t then fname else fname ^ ": " ^ ty t)) + prs) + | _ -> None) + | Form.List [ { v = Form.Sym "defdata"; _ }; { v = Form.Sym name; _ }; { v = Form.Vec cs; _ } ] + when def_name name -> + let case (c : Form.t) = + Option.map (Source_text.tag c.loc.Loc.line) @@ + match c.v with + | Form.Sym s when def_name s -> Some s + | Form.List [ { v = Form.Sym s; _ }; { v = Form.Vec ps; _ } ] when def_name s -> + Option.map (fun pt -> s ^ "(" ^ pt ^ ")") (params_text ps) + | _ -> None + in + let cs = List.map case cs in + if List.mem None cs then None + else + Some ((i ^ "data " ^ name) + :: List.map (fun c -> + let tags, body = Source_text.untag (Option.get c) in + List.fold_left (fun l t -> Source_text.tag t l) (ind (n + 2) ^ body) tags) cs) + | Form.List [ { v = Form.Sym "defenum"; _ }; { v = Form.Sym name; _ }; { v = Form.Vec ms; _ } ] + when def_name name -> + let rec members = function + | ({ Form.v = Form.Sym m; _ } as mf) :: ({ Form.v = Form.Int _ | Form.UInt _; _ } as v) :: rest + when def_name m -> + Option.map (fun r -> (mf.loc.Loc.line, m ^ " = " ^ fst (expr v)) :: r) (members rest) + | ({ Form.v = Form.Sym m; _ } as mf) :: rest when def_name m -> + Option.map (fun r -> (mf.loc.Loc.line, m) :: r) (members rest) + | [] -> Some [] + | _ -> None + in + Option.map + (fun ms -> + (i ^ "enum " ^ name) + :: List.map (fun (l, m) -> Source_text.tag l (ind (n + 2) ^ m)) ms) + (members ms) + | Form.List [ { v = Form.Sym "import"; _ }; { v = Form.Sym a; _ }; ({ v = Form.Str _; _ } as p) ] + when def_name a -> + Some [ i ^ "import " ^ a ^ " " ^ fst (expr p) ] + | _ -> None + +and is_else (f : Form.t) = match f.v with Form.Kw "else" -> true | _ -> false + +and handler_clauses n cls = + let clause (c : Form.t) = + match c.v with + | Form.List (t :: { v = Form.Vec [ { v = Form.Sym v; _ } ]; _ } :: (_ :: _ as b)) + when def_name v -> + Some ((ind n ^ "on " ^ at 9 t ^ "(" ^ v ^ ")") :: block (n + 2) b) + | _ -> None + in + let cs = List.map clause cls in + if List.mem None cs then None else Some (List.concat_map Option.get cs) + +(* A [let] last in its block reads to the block's end, so it is written flat. + One with siblings after it takes its body as an indented block under the + first binding, and the rest of the bindings go inside that block. *) +and let_lines n ~last prs body = + (* [(let [x (the T v)])] is [let x: T = v]. *) + let bind ((t : Form.t), (v : Form.t)) = + match t.v, v.v with + | Form.Sym x, Form.List [ { v = Form.Sym "the"; _ }; ty_; w ] when def_name x -> + ("let " ^ x ^ ": " ^ ty ty_, w) + | _ -> ("let " ^ guard (at 8 t), v) + in + (* Each binding line carries its own source line, so a comment written + after a binding stays on it. *) + let tagged ((t : Form.t), _) = function + | first :: more -> Source_text.tag t.loc.Loc.line first :: more + | [] -> [] + in + let lines n b = let p, v = bind b in tagged b (value_lines n p v) in + if last then List.concat_map (lines n) prs @ block n body + else + match prs with + | b :: rest -> + let p, v = bind b in + tagged b [ ind n ^ p ^ " = " ^ at 0 v ] + @ List.concat_map (lines (n + 2)) rest + @ block (n + 2) body + | [] -> block n body + +(** A whole file: top-level forms with a blank line between them. *) +let program ?source (fs : Form.t list) : string = + spelling := + (match source with Some src -> Source_text.spelling src | None -> fun _ -> None); + let cs = match source with Some src -> Source_text.comments src | None -> [] in + (inside := + fun (f : Form.t) -> + List.exists + (fun (c : Source_text.comment) -> + f.loc.Loc.line <= c.line && c.line < f.loc.Loc.eline) + cs); + let rec go = function + | [] -> [] + | [ x ] -> [ String.concat "\n" (stmt 0 ~last:true x) ] + | x :: rest -> String.concat "\n" (stmt 0 ~last:false x) :: go rest + in + let text = + try String.concat "\n\n" (go fs) ^ "\n" + with e -> spelling := (fun _ -> None); inside := (fun _ -> false); raise e + in + spelling := (fun _ -> None); + inside := (fun _ -> false); + (* With the source, its comments go back where they were; without it the + tags come out and nothing goes in. *) + Source_text.weave ~starts:(Source_text.form_starts fs) + (match source with Some src -> Source_text.comments src | None -> []) + text diff --git a/lib/indent_reader.ml b/lib/indent_reader.ml new file mode 100644 index 00000000..a5ea3a81 --- /dev/null +++ b/lib/indent_reader.ml @@ -0,0 +1,1581 @@ +(** The indented reader: [.fln] text to exactly the [Form.t] tree the paren + reader ([Reader]) makes. Nothing after the reader knows which syntax a form + came from. spec-syntax.md is the grammar; this comment is only the shape. + + Three passes. [lex] turns text into tokens, reusing [Reader]'s own string, + character, number and quoted-datum readers so the atoms mean exactly what + they mean in a [.flan] file. [layout] adds NEWLINE, INDENT and DEDENT at + bracket depth zero from an indent stack of columns. The parser is a + statement parser (soft keywords at the start of a line) over a precedence + climber for expressions. + + Locations are spans, as [Reader] makes them: a form starts at its first + token and ends where its last one does. A form this reader invents — the + [dyn] of an untyped parameter, the [do] around a block, the [set] of an + assignment — takes the location of the text that asked for it. *) + +type tok = + | NAME of string (* a name run, after field splitting *) + | KW of string + | ATOM of Form.value (* number, string, character *) + | DATUM of Form.t (* 'x and '(a b), read by the paren reader *) + | LP | RP | LB | RB | LC | RC + | COMMA + | COLON (* x: T, and the trailing : of a call's block *) + | UNQ | SPLICE (* ~ and ~@ *) + | NEG (* the - glued to the front of a name *) + | NEWLINE | INDENT | DEDENT | EOF + +type token = { tok : tok; loc : Loc.t; sp : bool (* whitespace before it *) } + +let failk ?notes kind loc fmt = Loc.failk ?notes ("indent/" ^ kind) loc fmt + +let show = function + | NAME s -> s + | KW s -> ":" ^ s + | ATOM v -> Form.to_source (Form.make v Loc.unknown) + | DATUM f -> Form.to_source f + | LP -> "(" | RP -> ")" | LB -> "[" | RB -> "]" | LC -> "{" | RC -> "}" + | COMMA -> "," | COLON -> ":" | UNQ -> "~" | SPLICE -> "~@" | NEG -> "-" + | NEWLINE -> "the end of the line" + | INDENT -> "an indented line" + | DEDENT -> "the end of the block" + | EOF -> "the end of the file" + +(* ── Names ─────────────────────────────────────────────────────────── *) + +(* Binary operators and their levels, low to high (spec §2 "Precedence"). + [not] sits at 3 and unary minus at 8; neither is binary. *) +let binops = + [ ("or", 1); ("and", 2); + ("==", 4); ("!=", 4); ("<", 4); ("<=", 4); (">", 4); (">=", 4); + ("<<", 5); (">>", 5); ("+", 6); ("-", 6); ("*", 7); ("/", 7); ("%", 7) ] + +let binop_level s = List.assoc_opt s binops +let is_binop s = binop_level s <> None + +(* [==] is Flan's [=]; every other operator is its own name. *) +let op_sym = function "==" -> "=" | s -> s + +(* Words that are operators rather than names wherever a value is read. Alone + before a comma or a closer they are the symbol itself, [reduce(+, 0, xs)]; + glued to a parenthesis they are a call, [+(a, b, c)]. *) +let is_op_word s = is_binop s || s = "not" || s = "=" + +let assign_ops = [ ("+=", "+"); ("-=", "-"); ("*=", "*"); ("/=", "/") ] + +(* A [-] glued to one of these starts a negation: [-x] is [(- x)]. Anything + else keeps the Lisp reading, so [--], [->] and [-=] stay names. *) +let is_neg_char c = + (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || c = '$' || c = '_' + || c = '*' + +(* The segment a dot splits after, checked for a capital: [Shape.Rect] and + [tree/Node.Branch] are one qualified name, [camera.target.x] is two field + accesses. The part after a package's [/] is what is checked. *) +let capitalised seg = + let base = + match String.rindex_opt seg '/' with + | Some i -> String.sub seg (i + 1) (String.length seg - i - 1) + | None -> seg + in + base <> "" && base.[0] >= 'A' && base.[0] <= 'Z' + +let split_fields text = + if text = "" || text.[0] = '.' then [ text ] + else + let segs = String.split_on_char '.' text in + if List.length segs < 2 || List.mem "" segs || capitalised (List.hd segs) + then [ text ] + else segs + +(* ── Lexing ────────────────────────────────────────────────────────── *) + +let lex ?(line = 1) ?(col = 1) ~file src : token list = + let st = Reader.of_string ~file src in + (* Text taken from the middle of a buffer starts where it was written, so + every location read from it is the buffer's own. *) + st.Reader.line <- line; + st.Reader.col <- col; + let out = ref [] in + let sp = ref true in + let line_start = ref true in + let tab = ref None in + let emit tok loc = out := { tok; loc; sp = !sp } :: !out; sp := false in + let piece line col len = + { (Loc.make file line col) with Loc.eline = line; ecol = col + len } + in + let name_run () = + let l0 = Reader.here st in + let text = Reader.take_while st (fun c -> not (Reader.is_delimiter c)) in + let n = String.length text in + let line = l0.Loc.line and col = l0.Loc.col in + if n = 0 then + failk "unexpected-character" l0 "unexpected character %C" (Reader.peek st); + if text = ":" then emit COLON (piece line col 1) + else if text.[0] = ':' then emit (KW (String.sub text 1 (n - 1))) (piece line col n) + else begin + let body, colon = + if text.[n - 1] = ':' then (String.sub text 0 (n - 1), true) + else (text, false) + in + let bn = String.length body in + let bcol, body = + if bn > 1 && body.[0] = '-' && is_neg_char body.[1] then begin + emit NEG (piece line col 1); + (col + 1, String.sub body 1 (bn - 1)) + end + else (col, body) + in + let off = ref 0 in + List.iteri + (fun i seg -> + let s = if i = 0 then seg else "." ^ seg in + emit (NAME s) (piece line (bcol + !off) (String.length s)); + off := !off + String.length s) + (split_fields body); + if colon then emit COLON (piece line (col + n - 1) 1) + end + in + let token c = + let l0 = Reader.here st in + let simple t = Reader.advance st; emit t (Loc.upto l0 (Reader.here st)) in + match c with + | '(' -> simple LP | ')' -> simple RP + | '[' -> simple LB | ']' -> simple RB + | '{' -> simple LC | '}' -> simple RC + | ',' -> simple COMMA + | '"' -> let f = Reader.read_string st in emit (ATOM f.v) f.loc + | '\\' -> let f = Reader.read_byte st in emit (ATOM f.v) f.loc + (* The paren reader reads the quoted datum whole, so ['(a (b c))] is the + Lisp list it always was and nothing here re-invents it. *) + | '\'' -> let f = Reader.read_form st in emit (DATUM f) f.loc + | '`' -> + failk "backquote" l0 + "` is not read in a .fln file. A quasiquote is quote followed by an \ + indented block, or quasiquote(x) on one line" + | '~' -> + Reader.advance st; + if Reader.peek st = '@' then begin + Reader.advance st; + emit SPLICE (Loc.upto l0 (Reader.here st)) + end + else emit UNQ (Loc.upto l0 (Reader.here st)) + | c when Reader.is_digit c + || ((c = '-' || c = '+') && Reader.is_digit (Reader.peek2 st)) -> + (* [while x < 3:] — the colon is a mistake the parser explains, and not + part of the number, so the number is read without it. *) + let rec run i = + if i < String.length src && not (Reader.is_delimiter src.[i]) then run (i + 1) + else i + in + let stop = run st.Reader.pos in + if stop - st.Reader.pos > 1 && src.[stop - 1] = ':' then begin + let text = String.sub src st.Reader.pos (stop - st.Reader.pos - 1) in + let f = Reader.read_number (Reader.of_string ~file text) in + let n = String.length text in + for _ = 1 to n do Reader.advance st done; + emit (ATOM f.v) (piece l0.Loc.line l0.Loc.col n); + Reader.advance st; + emit COLON (piece l0.Loc.line (l0.Loc.col + n) 1) + end + else + let f = Reader.read_number st in + emit (ATOM f.v) f.loc + | _ -> name_run () + in + let rec go () = + if not (Reader.at_end st) then + match Reader.peek st with + | ' ' | '\r' -> Reader.advance st; sp := true; go () + | '\t' -> + if !line_start && !tab = None then tab := Some (Reader.here st); + Reader.advance st; sp := true; go () + | '\n' -> + Reader.advance st; sp := true; line_start := true; tab := None; go () + | ';' -> + while (not (Reader.at_end st)) && Reader.peek st <> '\n' do + Reader.advance st + done; + go () + | c -> + (match !tab with + | Some l when !line_start -> + failk "tab" l + "this line is indented with a tab. Indentation in a .fln file is \ + measured in columns, and a tab has no one width, so only spaces \ + indent. Replace the tab with spaces" + | _ -> ()); + line_start := false; + token c; + go () + in + go (); + List.rev !out + +(* ── Layout ────────────────────────────────────────────────────────── *) + +let point (l : Loc.t) = { l with Loc.line = l.Loc.eline; col = l.Loc.ecol } + +(* NEWLINE, INDENT and DEDENT, at bracket depth zero only: inside ( [ { a + line break is whitespace. A line continues the one before it when either + side of the break is a spaced binary operator (spec §2 "Continuation"). *) +let layout ?(snippet = false) ?(base = 1) (toks : token list) : token array = + let arr = Array.of_list toks in + let n = Array.length arr in + (* A snippet from the editor starts wherever it was written, and its first + line is its base: a later line may not go left of it. *) + let base = if snippet && n > 0 then arr.(0).loc.Loc.col else base in + let out = ref [] in + let add tok loc = out := { tok; loc; sp = true } :: !out in + let stack = ref [ base ] in + let depth = ref 0 in + let binop t = match t.tok with NAME s -> is_binop s | _ -> false in + for i = 0 to n - 1 do + let t = arr.(i) in + (if i = 0 then begin + if t.loc.Loc.col <> base then + failk "unexpected-indent" t.loc + "the first line starts at column %d, and a file's top-level lines \ + start at column %d. Remove the indentation" + t.loc.Loc.col base + end + else + let p = arr.(i - 1) in + if !depth = 0 && t.loc.Loc.line > p.loc.Loc.eline then begin + let spaced_after = + i + 1 < n && arr.(i + 1).loc.Loc.line = t.loc.Loc.line + && arr.(i + 1).sp + in + let continues = (binop p && p.sp) || (binop t && spaced_after) in + (* A continuation line sits deeper than the statement it continues. + One at or left of that statement's column is not read as joining + it: that would pull a line into a block it was written outside + of, silently. *) + if continues && t.loc.Loc.col <= List.hd !stack then + failk "continuation" t.loc + "%s" + (if binop t then + Printf.sprintf + "this line starts with the operator %s, so it continues the \ + line above, but it is not indented past the start of that \ + line (column %d). Indent it further to continue the line, \ + or give %s a value on its left" + (show t.tok) (List.hd !stack) (show t.tok) + else + Printf.sprintf + "the line above ends with the operator %s, so this line \ + continues it, but it is not indented past the start of \ + that line (column %d). Indent it further, or finish the \ + line above" + (show p.tok) (List.hd !stack)); + if not continues then begin + let at = point p.loc in + add NEWLINE at; + let col = t.loc.Loc.col in + let top = List.hd !stack in + if col > top then begin + stack := col :: !stack; + add INDENT at + end + else if col < top then begin + if col < base then + failk "dedent" t.loc + "%s" + (if snippet then + Printf.sprintf + "this line starts at column %d, left of column %d where \ + the code sent starts. Its first line sets its left \ + edge, and no later line can go left of it: send the \ + enclosing form, or line this up at column %d or right \ + of it" + col base base + else + Printf.sprintf + "this line starts at column %d, left of the top level at \ + column %d" col base); + let closed = ref top in + let rec pop () = + match !stack with + | top :: (_ :: _ as rest) when col < top -> + closed := top; stack := rest; add DEDENT at; pop () + | _ -> () + in + pop (); + if col <> List.hd !stack then + failk "dedent" t.loc + "this line starts at column %d, between the block at column \ + %d and the one at column %d it would close, so it belongs \ + to neither. The enclosing blocks start at column%s %s: line \ + it up with one of them" + col (List.hd !stack) !closed + (if List.length !stack > 1 then "s" else "") + (String.concat ", " + (List.rev_map string_of_int !stack)) + end + end + end); + out := t :: !out; + (match t.tok with + | LP | LB | LC -> incr depth + | RP | RB | RC -> if !depth > 0 then decr depth + | _ -> ()) + done; + (if n > 0 then + let at = point arr.(n - 1).loc in + add NEWLINE at; + List.iter (fun _ -> add DEDENT at) (List.tl !stack)); + let eof_loc = if n > 0 then point arr.(n - 1).loc else Loc.unknown in + add EOF eof_loc; + Array.of_list (List.rev !out) + +(* ── Parsing ───────────────────────────────────────────────────────── *) + +type p = { toks : token array; mutable i : int } + +let peek p = p.toks.(p.i) +let peek_at p k = p.toks.(min (p.i + k) (Array.length p.toks - 1)) +let advance p = + let t = peek p in + if t.tok <> EOF then p.i <- p.i + 1; + t +let last p = p.toks.(max 0 (p.i - 1)) + +(* From [l] to the end of the last token consumed. *) +let span p (l : Loc.t) = + let e = (last p).loc in + if e.Loc.eline > l.Loc.line + || (e.Loc.eline = l.Loc.line && e.Loc.ecol > l.Loc.col) + then { l with Loc.eline = e.Loc.eline; ecol = e.Loc.ecol } + else l + +let mk p l v = Form.make v (span p l) +let sym l s = Form.make (Form.Sym s) l + +(* Where a stray token is, pointing at the real token after a layout one. *) +let where_ p = + let t = peek p in + match t.tok with + | NEWLINE | INDENT | DEDENT -> (peek_at p 1).loc + | _ -> t.loc + +let starts_value = function + | NAME _ | KW _ | ATOM _ | DATUM _ | LP | LB | LC | UNQ | SPLICE | NEG -> true + | _ -> false + +let ends_value = function + | RP | RB | RC | COMMA | NEWLINE | EOF | INDENT | DEDENT -> true + | _ -> false + +let negative_literal = function + | ATOM (Form.Int i) -> Int64.compare i 0L < 0 + | ATOM (Form.Float f) -> f < 0. + | _ -> false + +(* Something followed a complete value where nothing may. The two shapes that + get their own sentence are the ones a Lisp hand writes: [a -1] and + [f (x)]. *) +let stray p ~after = + let t = peek p in + match t.tok with + | ATOM _ when t.sp && negative_literal t.tok -> + let text = show t.tok in + let digits = String.sub text 1 (String.length text - 1) in + failk "glued-minus" t.loc + "%s is read as the number %s, right after %s with nothing between them. \ + To subtract, space the minus: %s - %s. For two values, separate them \ + with a comma: %s, %s" + text text after after digits after text + | LP when t.sp -> + failk "spaced-call" t.loc + "there is a space before this (, so it does not call %s — a call has \ + none. Write %s(...), or put a comma before the ( if it is a separate \ + value" + after after + | LB when t.sp -> + failk "spaced-index" t.loc + "there is a space before this [, so it does not index %s — indexing has \ + none. Write %s[i]" + after after + | NEWLINE | INDENT | DEDENT | EOF -> + failk "unexpected-end" (where_ p) "the line ends after %s, which is not \ + finished here" after + | NAME "=" -> + failk "assign-in-test" t.loc + "this = follows %s, where it cannot assign: an assignment is a line \ + of its own, with one =. To compare two values, write == instead" + after + | COLON -> + failk "header-colon" t.loc + "this line ends in a colon after %s. A header (if, elif, else, while, \ + until, for, fn, match, ...) opens its block with no colon; only a call \ + takes one, as in f(x):. Remove the colon" + after + | _ -> + failk "unexpected-token" t.loc + "%s follows %s, and two values cannot sit side by side here. Separate \ + them with a comma, or join them with an operator" + (show t.tok) after + +let expect p tok ~what = + let t = peek p in + if t.tok = tok then ignore (advance p) + else + failk "expected" (where_ p) "expected %s here, and found %s" what + (show t.tok) + +let expect_name p s ~what = + match (peek p).tok with + | NAME n when n = s -> ignore (advance p) + | t -> failk "expected" (where_ p) "expected %s here, and found %s" what (show t) + +(* The end of a line that is not followed by a block. *) +let expect_eol p ~after = + match (peek p).tok with + | NEWLINE -> + ignore (advance p); + if (peek p).tok = INDENT then + failk "stray-indent" (peek_at p 1).loc + "this line is indented under %s, which takes no block. A call takes \ + an indented block only with a trailing colon, as in \ + rl/with-drawing():" + after + | EOF -> () + | _ -> stray p ~after + +let check_name (t : token) s = + if String.contains s ':' then + failk "colon-in-name" t.loc + "%s has a colon inside it, and a name cannot. A type annotation puts a \ + space after the colon: %s" + s + (match String.index_opt s ':' with + | Some i -> String.sub s 0 (i + 1) ^ " " ^ String.sub s (i + 1) (String.length s - i - 1) + | None -> s) + +(* A form's own text, for the "after" half of a message. *) +(* The text being read, so that a message quotes what the user wrote rather + than the paren form it became. Set for the length of one [read_all]. *) +let source : (string * string array) ref = ref ("", [||]) + +let text_of (f : Form.t) = + let file, lines = !source in + let l = f.loc in + let from_source = + if l.Loc.file <> file || l.Loc.line < 1 || l.Loc.line > Array.length lines then None + else + let text = lines.(l.Loc.line - 1) in + let a = l.Loc.col - 1 in + let b = if l.Loc.eline = l.Loc.line then l.Loc.ecol - 1 else String.length text in + if a < 0 || b > String.length text || b <= a then None + else + let t = String.trim (String.sub text a (b - a)) in + Some (if l.Loc.eline > l.Loc.line then t ^ " ..." else t) + in + let s = match from_source with Some t -> t | None -> Form.to_source f in + if String.length s > 40 then String.sub s 0 37 ^ "..." else s + +let unclosed p c l0 = + failk "unclosed" l0 + ~notes:[ Loc.note (where_ p) "the input ends here, still inside it" ] + "unclosed %C" c + +let refuse_ws ?(brace = false) loc e = + failk "separate-elements" loc + "%s has an operator in it and sits in a list separated by spaces, where \ + only single values are. Separate the %s with commas: %s" + (text_of e) + (if brace then "entries" else "elements") + (if brace then "{.x a + 1, .y 2}" else "[a - 1, b]") + +(* Expressions come back with their syntactic level: 10 an atom or a bracket, + 9 a postfix chain, 8 a unary minus, 1-7 a binary operator's level, 3 a + [not], 0 a one-line [if] or a lambda. Anything under 8 is "compound": it + has an operator at its top, so it cannot sit in a list separated only by + whitespace. *) +let rec expr p : Form.t * int = binary p 1 + +and binary p lvl : Form.t * int = + if lvl = 3 then not_ p + else if lvl > 7 then unary p + else + let l0 = (peek p).loc in + let ((first, _) as fst_) = binary p (lvl + 1) in + let close op operands = + match List.rev operands with + | [ x ] -> (x, lvl) + | ops -> + if op = "!=" && List.length ops > 2 then + failk "chained-not-equal" l0 + "a != b != c is not read. != with more than two values means all \ + of them are distinct, which is not what the chain says, so it is \ + written as a call: !=(a, b, c)"; + (mk p l0 (Form.List (sym l0 (op_sym op) :: ops)), lvl) + in + (* An operator glued to a parenthesis is a call, [+(a, b)], and never + the operator between two values. *) + let binary_here s = + binop_level s = Some lvl + && not ((peek_at p 1).tok = LP && not (peek_at p 1).sp) + in + let rec run op operands = + match (peek p).tok with + | NAME s when binary_here s -> + let ot = advance p in + if not (ot.sp && (peek p).sp) then + failk "unspaced-operator" ot.loc + "%s is an operator here, and a binary operator has a space on each \ + side: a %s b. Without them a-b is one name" + s s; + let rhs, _ = binary p (lvl + 1) in + if s = op then run op (rhs :: operands) + else begin + if lvl = 4 then + failk "mixed-comparison" ot.loc + "%s follows %s in one chain, and a chain compares with one \ + operator. Join the tests with and, or parenthesise one side" + s op; + let folded, _ = close op operands in + run s [ rhs; folded ] + end + | _ -> close op operands + in + (* [run] folds a different operator at the same level into the left + operand, so the first operator here only starts the first run. *) + match (peek p).tok with + | NAME s when binary_here s -> run s [ first ] + | _ -> fst_ + +and not_ p = + let t = peek p in + match t.tok with + | NAME "not" when (peek_at p 1).sp && starts_value (peek_at p 1).tok -> + ignore (advance p); + let x, _ = not_ p in + (mk p t.loc (Form.List [ sym t.loc "not"; x ]), 3) + | _ -> binary p 4 + +and unary p = + let t = peek p in + match t.tok with + | NEG -> + ignore (advance p); + let x, _ = postfix p in + (mk p t.loc (Form.List [ sym t.loc "-"; x ]), 8) + | _ -> postfix p + +and postfix p = + let l0 = (peek p).loc in + let rec loop ((f, _) as fp) = + let t = peek p in + if t.sp then fp + else + match t.tok with + | LP -> + ignore (advance p); + let args = items p RP t.loc ~what:"arguments" in + loop (mk p l0 (Form.List (f :: args)), 9) + | LB -> + ignore (advance p); + let idx = items p RB t.loc ~what:"indices" in + loop (mk p l0 (Form.List (sym t.loc "at" :: f :: idx)), 9) + | NAME s when String.length s > 1 && s.[0] = '.' -> + ignore (advance p); + loop (mk p l0 (Form.List [ sym t.loc s; f ]), 9) + | LC -> + ignore (advance p); + let m = map_items p t.loc in + loop (mk p l0 (Form.List [ f; Form.make (Form.Map m) (span p t.loc) ]), 9) + | _ -> fp + in + loop (primary p) + +and primary p : Form.t * int = + let t = peek p in + let l0 = t.loc in + match t.tok with + | NAME s -> + let nxt = peek_at p 1 in + let glued_lp = nxt.tok = LP && not nxt.sp in + if s = "if" && nxt.sp && starts_value nxt.tok then if_expr p + else if s = "fn" && glued_lp then fn_expr p + else if is_op_word s then begin + if glued_lp || ends_value nxt.tok then begin + ignore (advance p); + (sym l0 (op_sym s), 10) + end + else + failk "operator-operand" l0 + "%s is an operator, and nothing is on its left. As a value on its \ + own it goes before a comma or a closing bracket, reduce(%s, xs); \ + as a call it is glued to its parenthesis, %s(a, b)" + s s s + end + else begin + ignore (advance p); + check_name t s; + (sym l0 s, 10) + end + | KW k -> ignore (advance p); (Form.make (Form.Kw k) l0, 10) + | ATOM v -> + ignore (advance p); + (Form.make v l0, if negative_literal t.tok then 8 else 10) + | DATUM f -> ignore (advance p); (f, 10) + | LP -> + ignore (advance p); + if (peek p).tok = RP then begin + ignore (advance p); + (mk p l0 (Form.List []), 10) + end + else + let e, _ = expr p in + (match (peek p).tok with + | RP -> ignore (advance p) + | EOF -> unclosed p '(' l0 + | COMMA -> + failk "tuple" (peek p).loc + "parentheses group one value, and this comma starts a second. \ + Several values in a list are written in brackets, [a, b]; \ + arguments go glued to a name, f(a, b)" + | _ -> stray p ~after:(text_of e)); + (e, 10) + | LB -> + ignore (advance p); + let xs = vec_items p l0 in + (mk p l0 (Form.Vec xs), 10) + | LC -> + ignore (advance p); + let xs = map_items p l0 in + (mk p l0 (Form.Map xs), 10) + | UNQ | SPLICE -> + ignore (advance p); + let x, _ = primary p in + let name = if t.tok = UNQ then "unquote" else "unquote-splicing" in + (mk p l0 (Form.List [ sym l0 name; x ]), 10) + | NEG -> unary p + | tk -> + failk "expected-value" (where_ p) "expected a value here, and found %s" + (show tk) + +(* [if c then a else b]: the one-line form, for a value. *) +and if_expr p = + let t = advance p in + let c, _ = binary p 1 in + (match (peek p).tok with + | NAME "then" -> ignore (advance p) + | _ -> + failk "if-then" (where_ p) + "an if inside a line is if c then a else b, and there is no then \ + after %s. Write the then, or start the if on its own line with its \ + branches indented under it" + (text_of c)); + let a = inline_stmt p in + match (peek p).tok with + | NAME "else" -> + ignore (advance p); + let b = inline_stmt p in + (mk p t.loc (Form.List [ sym t.loc "if"; c; a; b ]), 0) + | NAME "elif" -> + failk "one-line-elif" (peek p).loc + "a one-line if has then and else and no elif. Chain another if after \ + the else — if a then x else if b then y else z — or write the if over \ + several lines, where elif goes" + | _ -> (mk p t.loc (Form.List [ sym t.loc "when"; c; a ]), 0) + +(* What a one-line slot takes — a match arm's value, a then or an else, the + thing after defer: a value, or one of the statements that fit on a line, + break, continue, return and an assignment. *) +and inline_stmt p : Form.t = + let t = peek p in + let glued = let n = peek_at p 1 in n.tok = LP && not n.sp in + match t.tok with + | NAME (("break" | "continue") as w) when not glued -> + ignore (advance p); + (match (peek p).tok with + | KW k -> + let kt = advance p in + mk p t.loc (Form.List [ sym t.loc w; Form.make (Form.Kw k) kt.loc ]) + | _ -> mk p t.loc (Form.List [ sym t.loc w ])) + | NAME "return" when not glued -> + ignore (advance p); + let n = peek p in + if starts_value n.tok && not (n.tok = NAME "else") then + let v, _ = expr p in + mk p t.loc (Form.List [ sym t.loc "return"; v ]) + else mk p t.loc (Form.List [ sym t.loc "return" ]) + | _ -> + let e, _ = expr p in + match (peek p).tok with + | NAME "=" -> + let eq = advance p in + let v, _ = expr p in + mk p t.loc (Form.List [ sym eq.loc "set"; e; v ]) + | NAME op when List.mem_assoc op assign_ops -> + let eq = advance p in + let v, _ = expr p in + mk p t.loc + (Form.List + [ sym eq.loc "set"; e; + Form.make (Form.List [ sym eq.loc (List.assoc op assign_ops); e; v ]) + (span p e.loc) ]) + | _ -> e + +(* [fn(a, b) = body] is a lambda; [fn(...)] followed by anything else is the + fallback call spelling of [(fn ...)]. *) +and fn_expr p = + let t = advance p in + let lp = advance p in + let args = items p RP lp.loc ~what:"parameters" in + match (peek p).tok with + | NAME "=" -> + ignore (advance p); + let ps = lambda_params args in + let body, _ = expr p in + (mk p t.loc + (Form.List + [ sym t.loc "fn"; Form.make (Form.Vec ps) (span_of_list lp.loc args); body ]), + 0) + | _ -> (mk p t.loc (Form.List (sym t.loc "fn" :: args)), 9) + +and span_of_list l args = + match List.rev args with + | [] -> l + | (x : Form.t) :: _ -> { l with Loc.eline = x.loc.Loc.eline; ecol = x.loc.Loc.ecol } + +and lambda_params args = + List.map + (fun (a : Form.t) -> + match a.v with + | Form.Sym _ -> a + | _ -> + failk "lambda-param" a.loc + "a lambda's parameter is a name, and this is %s. Take the value \ + under a name and destructure it in the body" + (text_of a)) + args + +(* Comma-separated values up to [closer]. [const T] is two elements without a + comma, for [Ptr(const u8)]: const is a reserved word in a type and never a + value. *) +and items p closer open_loc ~what = + let opener = if closer = RB then '[' else '(' in + let rec go acc = + let t = peek p in + if t.tok = closer then (ignore (advance p); List.rev acc) + else if t.tok = EOF then unclosed p opener open_loc + else + match t.tok, peek_at p 1 with + | NAME "const", n when n.sp && starts_value n.tok -> + ignore (advance p); + go (sym t.loc "const" :: acc) + | _ -> + let e, _ = expr p in + (match (peek p).tok with + | COMMA -> ignore (advance p); go (e :: acc) + | tk when tk = closer -> ignore (advance p); List.rev (e :: acc) + | EOF -> unclosed p opener open_loc + | _ -> + let n = peek p in + if starts_value n.tok && n.sp && not (negative_literal n.tok) then + failk "missing-comma" n.loc + "%s follows %s with no comma between them. Separate %s with \ + commas: f(a, b)" + (show n.tok) (text_of e) what + else stray p ~after:(text_of e)) + in + go [] + +(* [[a b c]] or [[a, b + 1]]: whitespace separates only single terms. *) +and vec_items p open_loc = + (* One separator per bracket: [1 2, 3] mixes them, and which elements the + comma was meant to part is a guess. *) + let commas = ref false and spaces = ref false in + let mixed at = + failk "mixed-separators" at + "this bracket separates some elements with commas and some with only \ + spaces. Use one: [1, 2, 3] or [1 2 3]" + in + let rec go acc prev_ws = + let t = peek p in + match t.tok with + | RB -> ignore (advance p); List.rev acc + | EOF -> unclosed p '[' open_loc + | _ -> + let e, lvl = expr p in + if lvl < 8 && prev_ws then refuse_ws t.loc e; + (match (peek p).tok with + | COMMA -> + if !spaces then mixed (peek p).loc; + commas := true; + ignore (advance p); go (e :: acc) false + | RB -> ignore (advance p); List.rev (e :: acc) + | EOF -> unclosed p '[' open_loc + | tk when starts_value tk && (peek p).sp -> + if lvl < 8 then refuse_ws t.loc e; + if !commas then mixed (peek p).loc; + spaces := true; + go (e :: acc) true + | _ -> stray p ~after:(text_of e)) + in + go [] false + +(* Braces pair a key with a value, so a value may be any expression; after + one that has an operator in it, the next entry needs a comma. *) +and map_items p open_loc = + let rec go acc = + let t = peek p in + match t.tok with + | RC -> ignore (advance p); List.rev acc + | EOF -> unclosed p '{' open_loc + | _ -> + let e, lvl = expr p in + (match (peek p).tok with + | COMMA -> ignore (advance p); go (e :: acc) + | RC -> ignore (advance p); List.rev (e :: acc) + | EOF -> unclosed p '{' open_loc + | tk when starts_value tk && (peek p).sp -> + if lvl < 8 then refuse_ws ~brace:true t.loc e; + go (e :: acc) + | _ -> stray p ~after:(text_of e)) + in + go [] + + +(* A type after [:] or [->]: a postfix term, plus the arrow of a function + type, [Fn(A, B) -> R], which reads as [(Fn [A B] R)]. *) +let rec ty p : Form.t = + let l0 = (peek p).loc in + let f, _ = postfix p in + match f.v, (peek p).tok with + | Form.List (({ v = Form.Sym ("Fn" | "CFn"); _ } as h) :: args), NAME "->" + when (last p).tok = RP -> + ignore (advance p); + let r = ty p in + mk p l0 (Form.List [ h; Form.make (Form.Vec args) h.loc; r ]) + | _ -> f + +(* ── Statements ────────────────────────────────────────────────────── *) + +(* The let-statements this reader built, so that a [let] whose whole body is + another one merges into one binding vector (spec §2), and a [let] written + as a call does not. *) +type st = { p : p; mutable lets : Form.t list } + +(* A block of several lines is a [do] spanning its lines, from the first + statement to the end of the last — not from the header above it, which is + another form's. *) +let blk (s : st) l (ss : Form.t list) = + match ss with + | [ x ] -> x + | (first : Form.t) :: _ -> mk s.p first.loc (Form.List (sym first.loc "do" :: ss)) + | [] -> mk s.p l (Form.List [ sym l "do" ]) + +let is_lambda_candidate (e : Form.t) = + match e.v with + | Form.List ({ v = Form.Sym "fn"; _ } :: args) -> + List.for_all (fun (a : Form.t) -> match a.v with Form.Sym _ -> true | _ -> false) args + | _ -> false + +let header_follow p s = + let n = peek_at p 1 in + let plain_name = function + | NAME x -> not (is_op_word x || x = "=" || List.mem_assoc x assign_ops) + | _ -> false + in + match s with + | "fn" | "fn-" | "def" | "once" | "const" | "struct" | "union" | "data" + | "enum" | "import" -> + n.sp && plain_name n.tok + | "if" | "while" | "until" | "match" | "let" | "for" -> + n.sp && starts_value n.tok + && (match n.tok with + | NAME x when x = "=" || List.mem_assoc x assign_ops -> false + | NAME x when is_binop x -> + let a = peek_at p 2 in + a.tok = LP && not a.sp + | _ -> true) + | "return" -> n.tok = NEWLINE || (n.sp && starts_value n.tok) + | "break" | "continue" -> + n.tok = NEWLINE || (n.sp && (match n.tok with KW _ -> true | _ -> false)) + | "defer" -> + (n.tok = NEWLINE && (peek_at p 2).tok = INDENT) || (n.sp && starts_value n.tok) + | "handler-case" | "handler-bind" | "restart-case" -> + n.tok = NEWLINE || (n.sp && starts_value n.tok) + | "quote" -> + (n.tok = NEWLINE && (peek_at p 2).tok = INDENT) || (n.sp && starts_value n.tok) + | _ -> false + +let name_tok p ~what = + let t = peek p in + match t.tok with + | NAME s when not (String.length s > 0 && s.[0] = '.') -> + ignore (advance p); + check_name t s; + sym t.loc s + | tk -> failk "expected-name" (where_ p) "expected %s here, and found %s" what (show tk) + +let glued_lp p ~what = + let t = peek p in + if t.tok = LP && not t.sp then advance p + else failk "expected" (where_ p) "expected %s here, and found %s" what (show t.tok) + +(* [(a: i32, b)] as name/type pairs, [dyn] written out for the untyped: the + reader never leaves a vector for [Check.pair_params] to guess at. *) +let params p (lp : token) = + let rec go acc = + let t = peek p in + match t.tok with + | RP -> ignore (advance p); List.rev acc + | EOF -> unclosed p '(' lp.loc + | _ -> + (match t.tok with + | NAME "&" -> + failk "rest-parameter" t.loc + "a function's parameters are a fixed list of names, each with an \ + optional : Type, and & (a rest parameter) is not one. Take the rest \ + as one parameter, xs: [T]" + | _ -> ()); + let n = name_tok p ~what:"a parameter's name" in + let typed = (peek p).tok = COLON in + let tyf = + match (peek p).tok with + | COLON -> ignore (advance p); ty p + | _ -> sym n.loc "dyn" + in + (match (peek p).tok with + | COMMA -> ignore (advance p) + | RP -> () + | _ -> stray p ~after:(text_of (if typed then tyf else n))); + go (tyf :: n :: acc) + in + go [] + +let rec stmts (s : st) : Form.t list = + let p = s.p in + match (peek p).tok with + | DEDENT -> ignore (advance p); [] + | EOF -> [] + | NAME "let" when header_follow p "let" -> let_stmt s + | _ -> + let f = stmt s in + f :: stmts s + +and block (s : st) ~after : Form.t list = + let p = s.p in + match (peek p).tok with + | INDENT -> ignore (advance p); stmts s + | _ -> + failk "expected-block" (where_ p) + "%s takes an indented block on the lines under it, and the next line is \ + not indented" + after + +(* The rest of a line read as a value, through its end: [= v], or [=] and an + indented block that reduces to one form, or a lambda with a block body. *) +and value_line ?(block_ok = false) (s : st) ~after : Form.t = + let p = s.p in + let l0 = where_ p in + if (peek p).tok = NEWLINE && (peek_at p 1).tok = INDENT then begin + ignore (advance p); + blk s l0 (block s ~after) + end + else + match (peek p).tok with + (* [let r = match a] with its arms under it, and [let r = if c] with its + branches: a header read as the value, block and all. *) + | NAME (("match" | "handler-case" | "handler-bind" | "restart-case") as w) + when header_follow p w -> + header s w + | NAME "if" when header_follow p "if" && not (then_on_line p) -> header s "if" + | _ -> + let e, _ = expr p in + match (peek p).tok with + (* [let v = with-foo(a):] and its block: the call takes the block, as it + would on a line of its own. *) + | COLON when (match e.v, (last p).tok with + | Form.List (_ :: _), RP | Form.Sym _, NAME _ -> true + | _ -> false) -> + ignore (advance p); + (match (peek p).tok with + | NEWLINE -> ignore (advance p) + | _ -> stray p ~after:":"); + let body = block s ~after:(text_of e ^ ":") in + (match e.v with + | Form.List items -> mk p e.loc (Form.List (items @ body)) + | _ -> mk p e.loc (Form.List (e :: body))) + | COMMA -> + failk "one-binding" (peek p).loc + "%s is followed by a comma, and one line binds one name. Put each \ + binding on its own line, one after the other" + (text_of e) + | _ -> lambda_block ~block_ok s e ~after:(text_of e) + +(* Whether this line has a [then] at depth zero: a one-line if. *) +and then_on_line p = + let rec go k depth = + let t = peek_at p k in + match t.tok with + | NEWLINE | EOF -> false + | NAME "then" when depth = 0 -> true + | LP | LB | LC -> go (k + 1) (depth + 1) + | RP | RB | RC -> go (k + 1) (max 0 (depth - 1)) + | _ -> go (k + 1) depth + in + go 1 0 + +and lambda_block ?(block_ok = false) (s : st) (e : Form.t) ~after = + let p = s.p in + if is_lambda_candidate e && (last p).tok = RP && (peek p).tok = NEWLINE + && (peek_at p 1).tok = INDENT + then begin + ignore (advance p); + let body = block s ~after in + match e.v with + | Form.List (h :: args) -> + mk p e.loc + (Form.List (h :: Form.make (Form.Vec args) (span_of_list e.loc args) :: body)) + | _ -> assert false + end + else begin + if block_ok && (peek p).tok = NEWLINE then ignore (advance p) + else expect_eol p ~after; + e + end + +and let_stmt (s : st) : Form.t list = + let p = s.p in + let t = advance p in + let target, _ = unary p in + (* [let x: T = v] is [(let [x (the T v)])]: a let binding has no type slot + of its own, and [the] is the form that says what a value is. *) + let annot = + match (peek p).tok with + | COLON -> ignore (advance p); Some (ty p) + | _ -> None + in + (match (peek p).tok with + | NAME "=" -> ignore (advance p) + | _ -> + failk "let-equals" (where_ p) + "a let is let name = value, and %s is not followed by =" (text_of target)); + let v = value_line ~block_ok:true s ~after:("let " ^ text_of target) in + let v = + match annot with + | Some tyf -> + Form.make (Form.List [ sym tyf.loc "the"; tyf; v ]) (span p tyf.loc) + | None -> v + in + let make bindings body = + let f = + mk p t.loc + (Form.List + (sym t.loc "let" :: Form.make (Form.Vec bindings) (span_of_list target.loc bindings) + :: body)) + in + s.lets <- f :: s.lets; + f + in + let merged body = + match body with + | [ ({ Form.v = Form.List (_ :: { v = Form.Vec bs; _ } :: body); _ } as inner) ] + when List.memq inner s.lets -> + make (target :: v :: bs) body + | _ -> make [ target; v ] body + in + if (peek p).tok = INDENT then begin + let f = merged (block s ~after:"let") in + f :: stmts s + end + else [ merged (stmts s) ] + +and stmt (s : st) : Form.t = + let p = s.p in + let t = peek p in + match t.tok with + | NAME w when header_follow p w -> header s w + | NAME (("else" | "elif") as w) -> + failk "orphan-else" t.loc + "%s is not under an if at this column. It goes at the same column as \ + the if it belongs to, right after that if's block" + w + | _ -> expr_stmt s + +and expr_stmt (s : st) : Form.t = + let p = s.p in + let i0 = p.i in + let t0 = peek p in + let e, _ = expr p in + match (peek p).tok with + | NAME "=" -> + let eq = advance p in + let v = value_line s ~after:(text_of e ^ " =") in + mk p t0.loc (Form.List [ sym eq.loc "set"; e; v ]) + | NAME op when List.mem_assoc op assign_ops -> + let eq = advance p in + let v = value_line s ~after:(text_of e ^ " " ^ op) in + let o = List.assoc op assign_ops in + mk p t0.loc + (Form.List + [ sym eq.loc "set"; e; + Form.make (Form.List [ sym eq.loc o; e; v ]) (span p e.loc) ]) + | COLON -> + let before = (last p).tok in + let c = advance p in + (* [f(x):] and, with no arguments, [comment:] — a bare name — open a + block; anything else has no call to hang it on. *) + (match e.v, before with + | Form.List (_ :: _), RP -> () + | Form.Sym _, NAME _ -> () + | _ -> + failk "colon-block" c.loc + "a trailing colon gives a call an indented block, and %s is not a \ + call. Write it as one, as in f(x): or comment:" + (text_of e)); + (match (peek p).tok with + | NEWLINE -> ignore (advance p) + | _ -> stray p ~after:":"); + let body = block s ~after:(text_of e ^ ":") in + (match e.v with + | Form.List items -> mk p t0.loc (Form.List (items @ body)) + | _ -> mk p t0.loc (Form.List (e :: body))) + | _ -> + (* [()] alone on a line is the empty statement, spec §2 "Unit". *) + let e = + if p.i - i0 = 2 && t0.tok = LP && e.v = Form.List [] then + Form.make (Form.List [ sym t0.loc "do" ]) e.loc + else e + in + lambda_block s e ~after:(text_of e) + +and header (s : st) w : Form.t = + let p = s.p in + let t = advance p in + let l0 = t.loc in + let form items = mk p l0 (Form.List (sym l0 w :: items)) in + let named head items = mk p l0 (Form.List (sym l0 head :: items)) in + match w with + | "fn" | "fn-" -> + let name = name_tok p ~what:"the function's name" in + let lp = glued_lp p ~what:"the parameters, in parentheses glued to the name" in + let ps = params p lp in + let rp = last p in + let ret = + match (peek p).tok with + | NAME "->" -> ignore (advance p); ty p + | _ -> + let n = match name.v with Form.Sym n -> n | _ -> "" in + failk "return-type" rp.loc + "fn %s has no return type after its parameters, and a .fln \ + function states one for now. Write it after an arrow: fn %s(...) \ + -> i32, or -> dyn, or -> () when it returns nothing" + n n + in + let where_clause = + match (peek p).tok with + | NAME "where" -> + let wt = advance p in + let rec preds acc = + let e, _ = expr p in + match (peek p).tok with + | COMMA -> ignore (advance p); preds (e :: acc) + | _ -> List.rev (e :: acc) + in + let es = preds [] in + let v = + match es with + | [ e ] -> e + | _ -> Form.make (Form.Vec es) (span p wt.loc) + in + [ mk p wt.loc (Form.Map [ Form.make (Form.Kw "where") wt.loc; v ]) ] + | _ -> [] + in + let body = + match (peek p).tok with + | NAME "=" -> + ignore (advance p); + if (peek p).tok = NEWLINE && (peek_at p 1).tok = INDENT then begin + ignore (advance p); + block s ~after:"fn" + end + else [ value_line s ~after:"=" ] + | NEWLINE -> + ignore (advance p); + if (peek p).tok = INDENT then block s ~after:"fn" else [] + | _ -> stray p ~after:(text_of ret) + in + named (if w = "fn" then "defn" else "defn-") + (name :: Form.make (Form.Vec ps) lp.loc :: ret :: (where_clause @ body)) + | "def" | "once" | "const" -> + let name = name_tok p ~what:"the name being defined" in + let tyf = + match (peek p).tok with + | COLON -> ignore (advance p); Some (ty p) + | _ -> None + in + let v = + match (peek p).tok with + | NAME "=" -> + ignore (advance p); + Some (value_line s ~after:(w ^ " " ^ text_of name ^ " =")) + | _ -> + expect_eol p ~after:(match tyf with Some f -> text_of f | None -> text_of name); + None + in + let head = + match w with "def" -> "def" | "once" -> "defonce" | _ -> "defconst" + in + let items = + match w, tyf, v with + | "const", None, Some v -> [ name; v ] + | "const", Some t, Some v -> [ name; t; v ] + | "const", _, None -> + failk "const-value" l0 + "a const needs its value: const %s = 3" (text_of name) + | _, None, Some v -> [ name; sym name.loc "dyn"; v ] + | _, Some t, None -> [ name; t ] + | _, Some t, Some v -> [ name; t; v ] + | _, None, None -> + failk "def-empty" l0 + "%s %s names neither a type nor a value. Give it one or both: %s %s: \ + i32 = 0" + w (text_of name) w (text_of name) + in + named head items + | "struct" | "union" -> + let name = name_tok p ~what:"the type's name" in + expect_eol_block p ~after:(w ^ " " ^ text_of name); + let fields = + lines s (fun () -> + let f = name_tok p ~what:"a field's name" in + let tf = + match (peek p).tok with + | COLON -> ignore (advance p); ty p + | _ -> sym f.loc "dyn" + in + expect_eol p ~after:(text_of tf); + [ f; tf ]) + in + named (if w = "struct" then "defstruct" else "defunion") + [ name; Form.make (Form.Vec fields) (span p name.loc) ] + | "data" -> + let name = name_tok p ~what:"the type's name" in + expect_eol_block p ~after:("data " ^ text_of name); + let cases = + lines s (fun () -> + let c = name_tok p ~what:"a case's name" in + let f = + match (peek p).tok with + | LP when not (peek p).sp -> + let lp = advance p in + let ps = params p lp in + mk p c.loc (Form.List [ c; Form.make (Form.Vec ps) lp.loc ]) + | _ -> c + in + expect_eol p ~after:(text_of f); + [ f ]) + in + named "defdata" [ name; Form.make (Form.Vec cases) (span p name.loc) ] + | "enum" -> + let name = name_tok p ~what:"the enum's name" in + expect_eol_block p ~after:("enum " ^ text_of name); + let members = + lines s (fun () -> + let m = name_tok p ~what:"a member's name" in + match (peek p).tok with + | NAME "=" -> + ignore (advance p); + let v, _ = unary p in + expect_eol p ~after:(text_of v); + [ m; v ] + | _ -> expect_eol p ~after:(text_of m); [ m ]) + in + named "defenum" [ name; Form.make (Form.Vec members) (span p name.loc) ] + | "import" -> + let alias = name_tok p ~what:"the package's alias" in + let path = + match (peek p).tok with + | ATOM (Form.Str _ as v) -> let pt = advance p in Form.make v pt.loc + | tk -> + failk "import-path" (where_ p) + "an import is import alias \"collection:path\", and found %s where \ + the path goes" + (show tk) + in + expect_eol p ~after:(text_of path); + form [ alias; path ] + | "if" -> + let c, _ = binary p 1 in + (match (peek p).tok with + | NAME "then" -> + ignore (advance p); + let a = inline_stmt p in + let f = + match (peek p).tok with + | NAME "else" -> + ignore (advance p); + let b = inline_stmt p in + form [ c; a; b ] + | NAME "elif" -> + failk "one-line-elif" (peek p).loc + "a one-line if has then and else and no elif. Chain another if \ + after the else — if a then x else if b then y else z — or write \ + the if over several lines, where elif goes" + | _ -> named "when" [ c; a ] + in + expect_eol p ~after:(text_of f); + f + | _ -> + expect_line_end p ~after:("if " ^ text_of c); + let body = block s ~after:("if " ^ text_of c) in + let rec elifs acc = + match (peek p).tok with + | NAME "elif" -> + ignore (advance p); + let c, _ = binary p 1 in + (match (peek p).tok with + | NAME "then" -> + failk "elif-then" (peek p).loc + "elif takes its block on the indented lines under it, with no \ + then. Put the branch on the next line, indented" + | _ -> ()); + expect_line_end p ~after:("elif " ^ text_of c); + let b = block s ~after:"elif" in + elifs ((c, b) :: acc) + | _ -> List.rev acc + in + let els_ = elifs [] in + let else_ = + match (peek p).tok with + | NAME "else" -> + let et = advance p in + (match (peek p).tok with + | NEWLINE -> ignore (advance p) + | NAME "if" -> + failk "else-if" (where_ p) + "else takes its block on the lines under it. For another test \ + at this level, write elif c" + | _ -> stray p ~after:"else"); + Some (et.loc, block s ~after:"else") + | _ -> None + in + (match els_, else_ with + | [], None -> named "when" (c :: body) + | [], Some (el, e) -> form [ c; blk s l0 body; blk s el e ] + | _ -> + let pairs = + List.concat_map (fun (c, b) -> [ c; blk s c.Form.loc b ]) ((c, body) :: els_) + in + let tail = + match else_ with + | Some (el, e) -> [ Form.make (Form.Kw "else") el; blk s el e ] + | None -> [] + in + named "cond" (pairs @ tail))) + | "while" | "until" -> + let label = + match (peek p).tok, (peek_at p 1).tok with + | KW k, n when n <> NEWLINE -> let kt = advance p in [ Form.make (Form.Kw k) kt.loc ] + | _ -> [] + in + let c, _ = expr p in + expect_line_end p ~after:(w ^ " " ^ text_of c); + let body = block s ~after:w in + form (label @ (c :: body)) + | "for" -> + let label = + match (peek p).tok with + | KW k -> let kt = advance p in [ Form.make (Form.Kw k) kt.loc ] + | _ -> [] + in + let v = name_tok p ~what:"the loop variable" in + expect_name p "in" ~what:"in, as in for i in range(n)"; + let rt = peek p in + expect_name p "range" ~what:"range(n), range(a, b) or range(a, b, step)"; + let lp = glued_lp p ~what:"range's bounds in parentheses" in + let bs = items p RP lp.loc ~what:"bounds" in + if bs = [] || List.length bs > 3 then + failk "range-arity" rt.loc + "range takes one, two or three bounds: range(stop), range(start, stop) \ + or range(start, stop, step)"; + expect_line_end p ~after:"range(...)"; + let body = block s ~after:"for" in + named "dotimes" + (label @ (Form.make (Form.Vec (v :: bs)) (span_of_list v.loc bs) :: body)) + | "return" -> + (match (peek p).tok with + | NEWLINE -> expect_eol p ~after:"return"; form [] + | _ -> + let e, _ = expr p in + expect_eol p ~after:(text_of e); + form [ e ]) + | "break" | "continue" -> + (match (peek p).tok with + | KW k -> + let kt = advance p in + expect_eol p ~after:(":" ^ k); + form [ Form.make (Form.Kw k) kt.loc ] + | _ -> expect_eol p ~after:w; form []) + | "defer" -> + (match (peek p).tok with + | NEWLINE -> + ignore (advance p); + form (block s ~after:"defer") + | _ -> + let e = inline_stmt p in + expect_eol p ~after:(text_of e); + form [ e ]) + | "match" -> + let scrut, _ = expr p in + expect_eol_block p ~after:("match " ^ text_of scrut); + let arms = + lines s (fun () -> + let pat, _ = unary p in + expect_name p "->" ~what:"-> and the arm's value"; + let body = + if (peek p).tok = NEWLINE && (peek_at p 1).tok = INDENT then begin + let nl = advance p in + blk s nl.loc (block s ~after:"->") + end + else begin + let e = inline_stmt p in + expect_eol p ~after:(text_of e); + e + end + in + [ pat; body ]) + in + form (scrut :: arms) + | "handler-case" | "handler-bind" -> + clause_header_end p w; + let body = block s ~after:w in + let rec clauses acc = + match (peek p).tok, (peek_at p 1) with + | NAME "on", n when n.sp -> + let ot = advance p in + let head, _ = postfix p in + let ty, var = + match head.v with + | Form.List [ ty; ({ v = Form.Sym _; _ } as var) ] -> (ty, var) + | _ -> + failk "on-clause" head.loc + "a handler clause is on Type(name), naming the condition type \ + and the name it is bound to, as in on FileError(c)" + in + clause_end p ("on " ^ text_of ty ^ "(" ^ text_of var ^ ")"); + let b = block s ~after:"on" in + let c = + mk p ot.loc + (Form.List (ty :: Form.make (Form.Vec [ var ]) var.loc :: b)) + in + clauses (c :: acc) + | _ -> List.rev acc + in + let cs = clauses [] in + let vec = Form.make (Form.Vec cs) (span p l0) in + if w = "handler-case" then form [ blk s l0 body; vec ] + else form (vec :: body) + | "restart-case" -> + clause_header_end p w; + let body = block s ~after:w in + let rec clauses acc = + match (peek p).tok, (peek_at p 1) with + | NAME "restart", n when n.sp -> + ignore (advance p); + let name = name_tok p ~what:"the restart's name" in + let lp = glued_lp p ~what:"the restart's parameters in parentheses" in + let ps = params p lp in + clause_end p ("restart " ^ text_of name ^ "(...)"); + let b = block s ~after:"restart" in + let c = + mk p name.loc (Form.List (name :: Form.make (Form.Vec ps) lp.loc :: b)) + in + clauses (c :: acc) + | _ -> List.rev acc + in + let cs = clauses [] in + form (blk s l0 body :: cs) + | "quote" -> + (* One line, [quote ~x + 1], is the quasiquote of that expression. *) + (match (peek p).tok with + | NEWLINE -> + ignore (advance p); + let body = block s ~after:"quote" in + named "quasiquote" [ blk s l0 body ] + | _ -> + let e, _ = expr p in + expect_eol p ~after:(text_of e); + named "quasiquote" [ e ]) + | _ -> assert false + +(* handler-case, handler-bind and restart-case take nothing on their own line. *) +and clause_header_end p w = + match (peek p).tok with + | NEWLINE -> ignore (advance p) + | _ -> + failk "clause-header" (peek p).loc + "%s takes its body on the indented lines under it, and its %s clauses \ + at its own column after that, each with its block under it:\n\ + %s\n body\n%s" + w (if w = "restart-case" then "restart" else "on") w + (if w = "restart-case" then "restart name()\n value" else "on Type(c)\n value") + +and clause_end p head = + match (peek p).tok with + | NEWLINE -> ignore (advance p) + | _ -> + failk "clause-body" (peek p).loc + "the body of %s goes on the indented lines under it, not on its line. \ + Move it to the next line, indented" + head + +(* The end of a header line whose block must follow. *) +and expect_line_end p ~after = + match (peek p).tok with + | NEWLINE -> ignore (advance p) + | _ -> stray p ~after + +and expect_eol_block p ~after = + expect_line_end p ~after + +(* An indented run of one-line entries — a struct's fields, a match's arms. + None at all is allowed for the declarations and is refused later, by the + form, where it matters. *) +and lines (s : st) (one : unit -> Form.t list) : Form.t list = + let p = s.p in + if (peek p).tok <> INDENT then [] + else begin + ignore (advance p); + let rec go acc = + match (peek p).tok with + | DEDENT -> ignore (advance p); List.rev acc + | EOF -> List.rev acc + | _ -> go (List.rev_append (one ()) acc) + in + go [] + end + +(** All top-level forms in a [.fln] source string. [col] is the column the + text's top level starts at, 1 for a file. *) +let read_all ?(line = 1) ?col ~file src = + let snippet = col <> None in + let col = Option.value col ~default:1 in + let saved = !source in + (* The quoted text is indexed by the buffer's lines, so a snippet that + starts on line 40 is padded to start there. *) + source := + (file, Array.of_list (String.split_on_char '\n' + (String.make (line - 1) '\n' ^ String.make (col - 1) ' ' ^ src))); + Fun.protect ~finally:(fun () -> source := saved) (fun () -> + let toks = layout ~snippet ~base:col (lex ~line ~col ~file src) in + let s = { p = { toks; i = 0 }; lets = [] } in + let fs = stmts s in + (match (peek s.p).tok with + | EOF -> () + | tk -> failk "unexpected-token" (where_ s.p) "unexpected %s" (show tk)); + fs) + +let read_file path = + let ic = open_in_bin path in + Fun.protect ~finally:(fun () -> close_in ic) (fun () -> + let n = in_channel_length ic in + read_all ~file:path (really_input_string ic n)) diff --git a/lib/js.ml b/lib/js.ml index 221faf9e..74f86563 100644 --- a/lib/js.ml +++ b/lib/js.ml @@ -135,7 +135,7 @@ {1 Where this stops, and what the next lane picks up} - [spike/js/survey.sh] is the standing measurement: 24 MATCH, 0 DIFFER, 77 + [test/survey-js.sh] is the standing measurement: 24 MATCH, 0 DIFFER, 77 refused by name, 0 that node would not run, over the corpus and this file's own two probes. What the refusals say about the order to work in: diff --git a/lib/load.ml b/lib/load.ml index a6f70b98..70bb75cb 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -94,14 +94,14 @@ let rec find_collection dir name = let parent = Filename.dirname dir in if String.equal parent dir then None else find_collection parent name -(* A package is a directory, or a single [.flan] file named outright. The file +(* A package is a directory, or a single source file named outright. The file form is for the program that is also a library: sand.flan sits beside three other loose .flan files, so naming its directory would import all four, and moving it into one of its own would be arranging the tree around a limitation. A file carries no [.c] and no [link] — those belong to a directory, and a package that needs them has one. *) let is_package_file path = - Filename.check_suffix path ".flan" && Sys.file_exists path + Source.is_source path && Sys.file_exists path && not (Sys.is_directory path) (* [Filename.concat] of a directory and "." leaves the dot on the end, and the @@ -117,8 +117,8 @@ let resolve_dir ~file loc path = match split_path path with | None, rel -> let d = Filename.concat here rel in - if ok d then d else fail loc "no package at %s — wanted a directory or a \ - .flan file" d + if ok d then d else fail loc "no package at %s — wanted a directory, a \ + .flan file or a .fln file" d | Some collection, rel -> (match find_collection here collection with | None -> @@ -141,6 +141,14 @@ let entries dir suffix = |> List.sort String.compare |> List.map (Filename.concat dir) +(* A package directory's source files, in either syntax. *) +let source_entries dir = + Sys.readdir dir + |> Array.to_list + |> List.filter Source.is_source + |> List.sort String.compare + |> List.map (Filename.concat dir) + (* ── Qualifying an imported package ────────────────────────────────── *) let qualify alias n = alias ^ "/" ^ n @@ -1205,12 +1213,26 @@ let rec import ~seen ~open_ ~loc alias dir = Hashtbl.replace seen dir' (alias, []); let open_ = open_ @ [ (dir', alias) ] in let one_file = is_package_file dir in - let files = if one_file then [ dir ] else entries dir ".flan" in - if files = [] then fail loc "the package at %s has no .flan file" dir; + let files = if one_file then [ dir ] else source_entries dir in + if files = [] then fail loc "the package at %s has no .flan or .fln file" dir; + (* geo.flan beside geo.fln is one file written twice — a conversion that + kept its original — and loading both would report every definition in + it as defined twice, pointing at neither file as the cause. *) + List.iter + (fun f -> + if Filename.check_suffix f Source.paren_ext then + let twin = Filename.remove_extension f ^ Source.indented_ext in + if List.mem twin files then + fail loc + "the package at %s has both %s and %s. They are one file in two \ + syntaxes, and a package reads every source file it has, so \ + keep one of them" + dir (Filename.basename f) (Filename.basename twin)) + files; (* Read once. The forms are wanted twice — for the imports below and for the macros at the end — and reading a file twice is the kind of second opinion this module spends its comments warning about. *) - let sources = List.map (fun f -> (f, Reader.read_file f)) files in + let sources = List.map (fun f -> (f, Source.read_file f)) files in (* What this package imports, resolved first and relative to itself. Its declarations come back already qualified under their own aliases, so the rename below leaves them alone: they are not in [owned]. diff --git a/lib/paren_printer.ml b/lib/paren_printer.ml new file mode 100644 index 00000000..ed72d06e --- /dev/null +++ b/lib/paren_printer.ml @@ -0,0 +1,129 @@ +(** [Form.t] to paren text, for [flan convert] of a [.fln] file: the other + direction of [Indent_printer]. It keeps what [Form.pretty] cannot — the + source's number spellings and comments, through [Source_text] — and lays + a form out the way the corpus is written: flat when it fits, otherwise + the head and the arguments that name the form on the first line and the + rest one per line, two columns in. *) + +let width = 80 + +let rec flat spell (f : Form.t) = + let seq l = String.concat " " (List.map (flat spell) l) in + match f.v with + | Form.Int _ | Form.Float _ -> + (match spell f with Some t -> t | None -> Form.to_source f) + | Form.List l -> "(" ^ seq l ^ ")" + | Form.Vec l -> "[" ^ seq l ^ "]" + | Form.Map l -> "{" ^ seq l ^ "}" + | _ -> Form.to_source f + +(* How many arguments stay on the head's line when the form is broken. *) +let kept head = + match head with + | "defn" | "defn-" | "defmethod" -> 3 + | "defmacro" | "def" | "defonce" | "defconst" | "defstruct" | "defunion" + | "defdata" | "defenum" | "import" | "defalias" -> 2 + | "do" | "cond" | "comment" | "restart-case" | "handler-case" -> 0 + | _ -> 1 + +(* [inside l] says whether a comment sits on a line of [f] before its last, + where a flat [f] would leave it nowhere to go: such a form is broken. *) +let rec layout ?(inside = fun _ -> false) spell col (f : Form.t) : string list = + let layout = layout ~inside in + let one = flat spell f in + let tagl (x : Form.t) = function + | first :: rest -> Source_text.tag x.loc.Loc.line first :: rest + | [] -> [] + in + if col + String.length one <= width && not (inside f) then [ one ] + else + let bracket o c items ~keep = + let placed inner x = + match layout spell inner x with + | first :: more -> + (* The pad goes after any tags, which lead the line. *) + let tags, body = Source_text.untag first in + let padded = + List.fold_left (fun l t -> Source_text.tag t l) (String.make inner ' ' ^ body) tags + in + tagl x (padded :: more) + | [] -> [] + in + let lines = + let head_len k = + col + 1 + String.length + (String.concat " " (List.map (flat spell) (List.filteri (fun i _ -> i < k) items))) + in + let keep = if keep > 1 && head_len keep > width then 1 else keep in + if keep > 0 then + let first = List.filteri (fun i _ -> i < keep) items in + let rest = List.filteri (fun i _ -> i >= keep) items in + let before = List.filteri (fun i _ -> i < keep - 1) first in + match List.nth first (keep - 1) with + (* A binding vector with a comment inside it — [(let [a 1 ; first + b 2] ...)] — goes a pair to a line, each line carrying its pair's + source line, so a comment after a binding stays on it. *) + | { Form.v = Form.Vec vs; _ } as v + when keep > 1 && inside v && List.length vs mod 2 = 0 -> + let lead = o ^ String.concat " " (List.map (flat spell) before) ^ " [" in + let pad = String.make (col + String.length lead) ' ' in + let rec pairs k = function + | (a : Form.t) :: b :: more -> + Source_text.tag a.loc.Loc.line + ((if k = 0 then lead else pad) ^ flat spell a ^ " " ^ flat spell b) + :: pairs (k + 1) more + | _ -> [] + in + let ps = pairs 0 vs in + let np = List.length ps in + List.mapi (fun i l -> if i = np - 1 then l ^ "]" else l) ps + @ List.concat_map (placed (col + 2)) rest + | _ -> + (o ^ String.concat " " (List.map (flat spell) first)) + :: List.concat_map (placed (col + 2)) rest + else + match items with + | [] -> [ o ] + | x :: xs -> + (match layout spell (col + 1) x with + | first :: more -> + let tags, body = Source_text.untag first in + List.fold_left (fun l t -> Source_text.tag t l) (o ^ body) tags :: more + | [] -> [ o ]) + @ List.concat_map (placed (col + 1)) xs + in + let n = List.length lines in + List.mapi (fun i l -> if i = n - 1 then l ^ c else l) lines + in + match f.v with + | Form.List (({ v = Form.Sym h; _ }) :: _ as items) -> + bracket "(" ")" items ~keep:(1 + min (kept h) (List.length items - 1)) + | Form.List items -> bracket "(" ")" items ~keep:0 + | Form.Vec items -> bracket "[" "]" items ~keep:0 + | Form.Map items -> bracket "{" "}" items ~keep:0 + | _ -> [ one ] + +(** A whole file, with [source]'s comments and spellings when given. *) +let program ?source (fs : Form.t list) : string = + let spell = + match source with Some src -> Source_text.spelling src | None -> fun _ -> None + in + let cs = match source with Some src -> Source_text.comments src | None -> [] in + let inside (f : Form.t) = + List.exists + (fun (c : Source_text.comment) -> + f.loc.Loc.line <= c.line && c.line < f.loc.Loc.eline) + cs + in + let text = + String.concat "\n\n" + (List.map + (fun (f : Form.t) -> + String.concat "\n" + (match layout ~inside spell 0 f with + | first :: rest -> Source_text.tag f.loc.Loc.line first :: rest + | [] -> [])) + fs) + ^ "\n" + in + Source_text.weave ~starts:(Source_text.form_starts fs) cs text diff --git a/lib/prelude.ml b/lib/prelude.ml index 904da3c9..92110375 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -554,16 +554,42 @@ let source = {flan| ;; in. Owned by the caller: (free v), or let a (free-all a) take the region. ;; ;; This is the one that proves the containers and the generics compose. It -;; allocates — (vec-new t), push, returns (Vec t) — and the type-erased Vec +;; allocates — (vec-new $t), push, returns (Vec $t) — and the type-erased Vec ;; runtime needed no change at all, because SizeOf and AlignOf are computed at ;; the instantiation site, where the element type is concrete. (defn filter [s [const $t] keep? (Fn [$t] bool)] (Vec $t) - (let [v (vec-new t)] + (let [v (vec-new $t)] (dotimes [i (length s)] (when (keep? (at s i)) (push v (at s i)))) v)) +;; A map's keys, and its values, as a new Vec the caller owns. In block order, +;; which is the hash's and not the insertion's — sort what comes back if the +;; order matters. A string key is copied as the view it is, so the Vec reads +;; the map's own key bytes and is good for as long as they are. +(defn map-keys [m (Map $k $v)] (Vec $k) + {:where (hashable? $k)} + (let [out (vec-new $k) + cur (i64 0) + key (the $k (zeroed))] + (while (map-next m (addr cur) (addr key)) + (push out key)) + out)) + +(defn map-values [m (Map $k $v)] (Vec $v) + {:where (hashable? $k)} + ;; Walked by key and read back with get, because a place to copy a value + ;; into would have to be zeroed first, and a function value cannot be. + (let [out (vec-new $v) + cur (i64 0) + key (the $k (zeroed))] + (while (map-next m (addr cur) (addr key)) + (match (get m key) + (Some val) (push out val) + None (do))) + out)) + ;; ── The sign questions, over every numeric type at once ─────────────── ;; ;; The family the whole of generics was asked for. Three questions about a @@ -1925,15 +1951,6 @@ let source = {flan| ;; that did not come with them, because it is one copy ;; per *ordered pair* of types rather than per type, ;; which is where a per-type family stops being honest. -;; map-keys, map-values Generics — and the reason changed, which is the -;; point of naming them separately. It used to be the -;; missing Map iterator; `map-next` is that iterator -;; and walking a map is expressible now. What a defn -;; still cannot say is (defn map-keys [m {K V}] (Vec K)): -;; a prelude function has to name its types, and there -;; is no K. The loop is three lines at the call site, -;; where K is known, and that is where it stays until -;; there are generics. ;; ;; Builder Not refused — declined. strings.Builder in Odin ;; wraps a [dynamic]u8; here the (Vec u8) *is* that and diff --git a/lib/session.ml b/lib/session.ml index 14a2fc2a..08876510 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -268,7 +268,7 @@ let of_forms ~debug ~x86 ~file forms = built = record_built env p p.Tast.fns SM.empty; live = SM.empty }, l) let create ?(debug = false) ?(x86 = false) ~file () = - of_forms ~debug ~x86 ~file (Reader.read_file file) + of_forms ~debug ~x86 ~file (Source.read_file file) (* ── A file loaded a form at a time, keeping what compiles ─────────── *) @@ -348,7 +348,7 @@ let create_dev ?(debug = false) ?(x86 = false) ~file () = of_forms ~debug ~x86 ~file (if declares_main forms then forms else forms @ stub_main ()) in - let (t, l), _, errs = pruned build (Reader.read_file file) in + let (t, l), _, errs = pruned build (Source.read_file file) in (t, l, errs) (* What a macro may call, for the same reason [macros] is held: an evaluation @@ -807,7 +807,7 @@ let rehost t = there. *) let eval ?(origin = "") ?base ?forms ?pause ?(running = true) t src : change = let forms = - match forms with Some f -> f | None -> Reader.read_all ~file:origin src + match forms with Some f -> f | None -> Source.read_code ~file:origin src in (* What an annotated listing quotes for this form is what was sent, not what the file on disk said when it was last read. *) @@ -2222,7 +2222,7 @@ let write_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path List.map (fun (at, _, tty, code) -> let form = - match Reader.read_all ~file:origin code with + match Source.read_code ~expr:true ~file:origin code with | [ f ] -> f | [] -> fail loc "nothing to store into %s" at | _ :: f :: _ -> fail f.Form.loc "one value at a time" @@ -2346,7 +2346,7 @@ let arm_restart ?(origin = "") t ~index ~(params : Types.t list) List.map2 (fun ty code -> let form = - match Reader.read_all ~file:origin code with + match Source.read_code ~expr:true ~file:origin code with | [ f ] -> f | [] -> fail loc "a value for a %s is empty" (Types.to_string ty) | _ :: f :: _ -> fail f.Form.loc "one value for each parameter" @@ -2527,7 +2527,7 @@ let render_globals ?(origin = "") t ~(globals : Tast.global list) declaration to live in. *) let eval_expr ?(origin = "") ?(pause = false) t src : change = let form = - match Reader.read_all ~file:origin src with + match Source.read_code ~expr:true ~file:origin src with | [ f ] -> f | [] -> fail Loc.unknown "nothing to evaluate" | _ :: f :: _ -> fail f.Form.loc "one expression at a time" @@ -2705,7 +2705,7 @@ type expansion = { [C-u] refuses. *) let macroexpand ?(origin = "") ~(all : bool) t (src : string) : expansion = let form = - match Reader.read_all ~file:origin src with + match Source.read_code ~file:origin src with | [ f ] -> f | [] -> fail Loc.unknown "nothing to expand" | _ :: f :: _ -> fail f.Form.loc "one form at a time" diff --git a/lib/source.ml b/lib/source.ml new file mode 100644 index 00000000..102da4fd --- /dev/null +++ b/lib/source.ml @@ -0,0 +1,76 @@ +(** A program source file, read by the reader its extension names: [.fln] is + the indented syntax ([Indent_reader]), anything else the paren syntax + ([Reader]). Both give the same [Form.t], so nothing past this point knows + which one a file was written in, and a program may mix them freely. + + Only program sources come through here. The prelude, the wire protocol and + the registry's spellings are paren text the compiler writes itself, and + read it with [Reader] directly. *) + +let indented_ext = ".fln" +let paren_ext = ".flan" + +let is_indented path = Filename.check_suffix path indented_ext + +(** A file a package directory contributes, in either syntax. *) +let is_source path = + Filename.check_suffix path paren_ext || is_indented path + +let read_file path = + if is_indented path then Indent_reader.read_file path else Reader.read_file path + +(* ── Code from the editor ───────────────────────────────────────────── + + The dev loop's code-carrying requests say which syntax their [:code] is in + ([:syntax]), and where in the buffer it starts ([:line], [:col]), rather + than having it guessed from [:file]: an expansion shown in paren syntax is + sent back under the name of the .fln file it came from, and a REPL line has + no file at all. [Dev] sets these for the length of one request, and every + place the session reads editor code reads it through [read_code]. *) + +type syntax = Paren | Indented + +let code_syntax = ref Paren +let code_at : (int * int) option ref = ref None + +let syntax_of_field = function + | Some ("indented" | "fln") -> Indented + | _ -> Paren + +let with_code ~syntax ~at f = + let s = !code_syntax and a = !code_at in + code_syntax := syntax; + code_at := at; + Fun.protect ~finally:(fun () -> code_syntax := s; code_at := a) f + +(* The paren reader started at a line and column: [Reader.read_all] always + starts at 1:1. *) +let read_paren ?(line = 1) ?(col = 1) ~file src = + let st = Reader.of_string ~file src in + st.Reader.line <- line; + st.Reader.col <- col; + let rec go acc = + Reader.skip_ignorable st; + if Reader.at_end st then List.rev acc else go (Reader.read_form st :: acc) + in + go [] + +(** Editor code, in the request's syntax and at its position. With [expr], an + indented snippet of several statements is one expression, [(do ...)]: a + block of lines means its lines in order. *) +let read_code ?(expr = false) ~file code = + let line, col = + match !code_at with Some (l, c) -> (l, c) | None -> (1, 1) + in + match !code_syntax with + | Paren -> read_paren ~line ~col ~file code + | Indented -> + (match Indent_reader.read_all ~line ~col ~file code with + | (first :: _ :: _ as forms) when expr -> + let last = List.nth forms (List.length forms - 1) in + let loc = + { first.Form.loc with Loc.eline = last.Form.loc.Loc.eline; + ecol = last.Form.loc.Loc.ecol } + in + [ Form.make (Form.List (Form.make (Form.Sym "do") first.Form.loc :: forms)) loc ] + | forms -> forms) diff --git a/lib/source_text.ml b/lib/source_text.ml new file mode 100644 index 00000000..e876f58f --- /dev/null +++ b/lib/source_text.ml @@ -0,0 +1,208 @@ +(** What a printer needs from the text a program was read from and a + [Form.t] does not carry: the comments, and the spelling of each number. + [flan convert] reads both here and puts them back (author's decision 83), + so a converted file keeps its [;] notes and its [0xFFF00FFF]s. + + Both syntaxes share the lexical rules this depends on: a comment runs + from [;] to the end of its line, a string is ["..."] with backslash + escapes, and [\c] is a character — so [\;] is not a comment. *) + +type comment = { + line : int; (* 1-based *) + text : string; (* from the [;] to the end of the line *) + own_line : bool; (* nothing but spaces before it on its line *) + gap_after : bool; (* the line after it is blank *) +} + +let comments (src : string) : comment list = + let n = String.length src in + let out = ref [] in + let line = ref 1 and line_start = ref 0 in + let i = ref 0 in + while !i < n do + (match src.[!i] with + | '\n' -> incr line; line_start := !i + 1; incr i + | '"' -> + incr i; + while !i < n && src.[!i] <> '"' do + if src.[!i] = '\\' then incr i; + if !i < n && src.[!i] = '\n' then (incr line; line_start := !i + 1); + incr i + done; + incr i + | '\\' -> i := !i + 2 + | ';' -> + let j = ref !i in + while !j < n && src.[!j] <> '\n' do incr j done; + let text = String.sub src !i (!j - !i) in + let text = + if text <> "" && text.[String.length text - 1] = '\r' + then String.sub text 0 (String.length text - 1) else text + in + let before = String.sub src !line_start (!i - !line_start) in + let k = ref (!j + 1) in + while !k < n && (src.[!k] = ' ' || src.[!k] = '\r') do incr k done; + let gap_after = !j < n && (!k >= n || src.[!k] = '\n') in + out := { line = !line; text; own_line = String.trim before = ""; gap_after } :: !out; + i := !j + | _ -> incr i) + done; + List.rev !out + +(** A number's text as written, when it reads back to the same value: the + text under its span. [Form.Int] keeps only the value. *) +let spelling (src : string) : Form.t -> string option = + let lines = Array.of_list (String.split_on_char '\n' src) in + fun (f : Form.t) -> + let l = f.loc in + if l.Loc.line < 1 || l.Loc.line > Array.length lines || l.Loc.eline <> l.Loc.line + then None + else + let text = lines.(l.Loc.line - 1) in + let a = l.Loc.col - 1 and b = l.Loc.ecol - 1 in + if a < 0 || b > String.length text || b <= a then None + else + let t = String.sub text a (b - a) in + match f.v with + | Form.Int i when Int64.of_string_opt t = Some i -> Some t + | Form.Float x + when String.exists (fun c -> c = '.' || c = 'e' || c = 'E') t + && (match float_of_string_opt t with + | Some y -> Int64.equal (Int64.bits_of_float x) (Int64.bits_of_float y) + | None -> false) -> + Some t + | _ -> None + +(* ── Lines tagged with where they came from ─────────────────────────── + + A printer marks the first line of each form it lays out with the source + line that form started on. [weave] reads the marks back out and uses them + to put each comment where it was: an own-line comment above the first + line that came from after it, a trailing comment at the end of the line + the code it followed was printed on. *) + +(* A line can come from several forms — a statement and the test at its + start — so it carries every line they started on. *) +let untag (text : string) : int list * string = + if String.length text > 0 && text.[0] = '\001' then + match String.index_opt text '\002' with + | Some k -> + (List.filter_map int_of_string_opt + (String.split_on_char ',' (String.sub text 1 (k - 1))), + String.sub text (k + 1) (String.length text - k - 1)) + | None -> ([], text) + else ([], text) + +let tag (line : int) (text : string) = + let tags, body = untag text in + let tags = if line > 0 && not (List.mem line tags) then line :: tags else tags in + if tags = [] then body + else "\001" ^ String.concat "," (List.map string_of_int tags) ^ "\002" ^ body + +let indent_of s = + let n = String.length s in + let rec go i = if i < n && s.[i] = ' ' then go (i + 1) else i in + go 0 + +(** Where every form in [fs] starts, as (line, col), in source order. *) +let form_starts (fs : Form.t list) : (int * int) list = + let out = ref [] in + let rec walk (f : Form.t) = + out := (f.loc.Loc.line, f.loc.Loc.col) :: !out; + match f.v with + | Form.List l | Form.Vec l | Form.Map l -> List.iter walk l + | _ -> () + in + List.iter walk fs; + List.sort_uniq compare !out + +let weave ?(starts = []) (cs : comment list) (text : string) : string = + let lines = Array.of_list (List.map untag (String.split_on_char '\n' text)) in + let n = Array.length lines in + let all = Array.map fst lines and body = Array.map snd lines in + (* For ordering, a line is as early as the earliest form on it. *) + let tags = + Array.map (function [] -> None | l -> Some (List.fold_left min max_int l)) all + in + let before = Array.make (n + 1) [] and trailing = Array.make n [] in + List.iter + (fun c -> + (* The line printed from exactly [line], when one was: a printer + may reorder forms — handler-bind's clauses go after its body — so a + comment goes with the form, not with whatever line follows. *) + let exact line = + let r = ref (-1) in + Array.iteri (fun i t -> if List.mem line t && !r < 0 then r := i) all; + !r + in + if c.own_line then begin + (* The form it precedes: the first to start after it. *) + let owner = + List.find_opt (fun (l, _) -> l > c.line) starts |> Option.map fst + in + let rec find i = + if i >= n then n + else match tags.(i) with Some t when t > c.line -> i | _ -> find (i + 1) + in + let i = + match owner with + | Some l when exact l >= 0 -> exact l + | _ -> find 0 + in + before.(i) <- c :: before.(i) + end + else begin + (* The line the code before it went to: the one printed from its own + line, or else the latest line tagged at or before it. *) + let last_exact = + let r = ref (-1) in + Array.iteri (fun i t -> if List.mem c.line t then r := i) all; + !r + in + if last_exact >= 0 then trailing.(last_exact) <- c :: trailing.(last_exact) + else begin + let best = ref (-1) and best_tag = ref 0 in + Array.iteri + (fun i t -> + match t with + | Some t when t <= c.line && t >= !best_tag -> best := i; best_tag := t + | _ -> ()) + tags; + if !best < 0 then before.(0) <- c :: before.(0) + else trailing.(!best) <- c :: trailing.(!best) + end + end) + cs; + let b = Buffer.create (String.length text + 256) in + let emit s = Buffer.add_string b s; Buffer.add_char b '\n' in + for i = 0 to n do + let ind = + if i < n then indent_of body.(i) + else 0 + in + List.iter + (fun c -> + emit (String.make ind ' ' ^ c.text); + (* A comment set apart from what follows it, at the top level, stays + set apart: a file's header, a section rule. *) + if c.gap_after && ind = 0 && i < n then emit "") + (List.rev before.(i)); + if i < n then begin + match List.rev trailing.(i) with + | [] -> emit body.(i) + | first :: more -> + emit (body.(i) ^ " " ^ first.text); + (* A second trailing comment for the same printed line goes on its + own line under it, which reads the same and keeps both. *) + let ind = if i + 1 < n then indent_of body.(i + 1) else indent_of body.(i) in + List.iter (fun c -> emit (String.make ind ' ' ^ c.text)) more + end + done; + (* [text] ended in a newline, which split into a last empty line. *) + let s = Buffer.contents b in + let rec trim s = + let k = String.length s in + if k >= 2 && s.[k - 1] = '\n' && s.[k - 2] = '\n' then trim (String.sub s 0 (k - 1)) + else s + in + trim s diff --git a/lib/x86.ml b/lib/x86.ml index b48d64d6..e781201d 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -1,6 +1,6 @@ (** Tast -> x86-64, by hand. The dev backend; LLVM stays the release one. - Grown out of [spike/backend/x86.ml], which proved the shape. What is new + Grown out of a spike's [x86.ml], which proved the shape and is in git history. What is new here is everything the spike enumerated and did not do: aggregates, floats, globals, string literals, the transfer channel, and a whole program rather than one function. @@ -4284,7 +4284,7 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false) transfer exit are dead because no path names that exit. This used to be a refusal, on the theory that a function with a defer and no transfer exit was a sign the reasoning had gone wrong. It is not — it is every leaf - function with a defer, and [spike/x86/p9-dead-defers.flan] is ten lines + function with a defer, and [test/programs/x86-p9-dead-defers.flan] is ten lines of it. [emit.ml]'s [emit_fn] writes the whole exit under the same [if f.unwound], and so drops them too. @@ -4523,9 +4523,10 @@ let emit_main ?(ann = false) ?(startup = false) ?(gc = false) xor_rr b ~dst:rax ~src:rax; call_sym b "flan_gc_init" end; - (* A program that can make a collector-owned closure environment has the - collector told of every Vec block from here on; see [Emit.emit_main]. *) - if md.Emit.gcfn then begin + (* A program that can make a collector-owned closure environment, or holds + a dyn, has the collector told of every Vec and Map block from here on; + see [Emit.emit_main]. *) + if md.Emit.gcfn || gc then begin xor_rr b ~dst:rax ~src:rax; call_sym b "flan_dyn_track_vecs" end; @@ -5059,7 +5060,7 @@ let program ~checks ?(dev = false) ?(debug = false) ?(annotate = false) # installed while the process runs is reached by the next call.\n\ #\n\ # What is not here are mnemonics. The bytes are a blob so that every\n\ - # offset stays exactly known, and spike/x86/dump.sh puts objdump's\n\ + # offset stays exactly known, and tools/dump.sh puts objdump's\n\ # disassembly of this same object beside this file: that one says what,\n\ # and this one says why.\n"; (* A numbered [.file] is what stops clang's integrated assembler from diff --git a/plan.org b/plan.org index 060ad2dd..cc973a99 100644 --- a/plan.org +++ b/plan.org @@ -525,7 +525,7 @@ on. machine code directly and is selected with ~--x86~; it exists because ~llc~ is most of the 19ms above. It is a different route from the same typed IR to the same observable behaviour, not a different semantics, and what holds it to that -is ~spike/x86/survey.sh~: every program in the corpus is built both ways and +is ~test/survey-x86.sh~: every program in the corpus is built both ways and byte-compared on stdout, stderr and exit status. At the time of writing that is 103 MATCH, 0 DIFFER, 0 refused by name. It handles conditions, bounds checks, indirection cells, redefinition modules and DWARF line tables; what it does not diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index 208f1952..ea488a33 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -131,6 +131,8 @@ typedef uint64_t flan_dyn; * - [vecs]: a (Vec T) header whose elements hold words of their own, with the * element's descriptor. The marker reads the header's pointer and length * where they are, so a push that reallocated is seen. + * - [maps]: a (Map K V) header whose values hold words of their own, with the + * value's descriptor. Read the same way, and walked over the full slots. * * [size] is the stride of one instance as the compiler's element-size * arithmetic counts it, which is what a Vec's elements are laid out at. The @@ -149,6 +151,8 @@ typedef struct flan_desc { const int64_t *envs; int64_t nvec; const flan_desc_vec *vecs; + int64_t nmap; + const flan_desc_vec *maps; } flan_desc; #define DYN_QNAN 0xFFF8000000000000ULL @@ -248,6 +252,38 @@ void flan_dyn_vec_hdr_layout(int64_t out[6]) { out[5] = (int64_t)offsetof(flan_dyn_vec_hdr, epoch); } +/* flan_map, restated for the same reason and read the same way: only + * [data], [log2cap], [alloc] and [epoch]. With it, the three numbers of the + * block's geometry the marker needs — flan_rt.c's FLAN_MAP_HEAD, _GROUP and + * _ALIGN. If either file's table changes, change both. */ +typedef struct flan_dyn_map_hdr { + void *data; + int64_t len; + int64_t log2cap; + void *alloc; + int64_t epoch; +} flan_dyn_map_hdr; + +#define DYN_MAP_HEAD 24 +#define DYN_MAP_GROUP 8 +#define DYN_MAP_ALIGN 64 +#define DYN_MAP_FULL 0x80 + +/* This mirror's numbers, compared against flan_rt.c's [flan_map_layout] by + * test/dyn_ops.c's "layout" mode. */ +void flan_dyn_map_hdr_layout(int64_t out[10]) { + out[0] = (int64_t)sizeof(flan_dyn_map_hdr); + out[1] = (int64_t)offsetof(flan_dyn_map_hdr, data); + out[2] = (int64_t)offsetof(flan_dyn_map_hdr, len); + out[3] = (int64_t)offsetof(flan_dyn_map_hdr, log2cap); + out[4] = (int64_t)offsetof(flan_dyn_map_hdr, alloc); + out[5] = (int64_t)offsetof(flan_dyn_map_hdr, epoch); + out[6] = DYN_MAP_HEAD; + out[7] = DYN_MAP_GROUP; + out[8] = DYN_MAP_ALIGN; + out[9] = DYN_MAP_FULL; +} + /* flan_allocator's prefix, far enough to read the one word a stale-container * check needs. The struct has more fields after [epoch]; this file never * touches them; and the alignment of a leading same-typed prefix is the same @@ -1259,6 +1295,64 @@ typedef struct { char *p; int64_t n; const flan_desc *e; } vec_work; static vec_work *vstack; static int64_t vstack_n, vstack_cap; +/* Maps still to walk: a live block's control run, its slots, the slot count, + * the stride and value offset the block's own head records, and the value's + * descriptor. Queued for the Vec queue's reason. */ +typedef struct { + const uint8_t *ctrl; char *slots; int64_t cap, stride, voff; + const flan_desc *e; +} map_work; +static map_work *mapstack; +static int64_t mapstack_n, mapstack_cap; + +/* A live block, not reset since it was made: the checks a Vec's block and a + * Map's share. The allocator header is never freed, so its epoch is always + * readable. */ +static vblock *live_block(void *p) { + vblock *b = vblock_find((uintptr_t)p); + if (b == NULL) return NULL; + if (b->alloc != NULL + && (int64_t)((flan_dyn_alloc_hdr *)b->alloc)->epoch != b->epoch) + return NULL; + return b; +} + +/* Queue the map whose header is at [h]. The slot count comes from the + * header and everything else from the block, and the walk is bounded by the + * block's recorded size, so a stale header copy naming a block another map + * now owns reads nothing outside that block. */ +static void queue_map(const flan_dyn_map_hdr *h, const flan_desc *e) { + vblock *b; + const int64_t *head; + int64_t cap, ctrl, stride, voff; + if (e == NULL || h->data == NULL || h->log2cap <= 0 || h->log2cap > 40) + return; + b = live_block(h->data); + if (b == NULL || b->bytes < DYN_MAP_HEAD) return; + cap = (int64_t)1 << h->log2cap; + ctrl = (DYN_MAP_HEAD + cap + (DYN_MAP_GROUP - 1) + (DYN_MAP_ALIGN - 1)) + & ~(int64_t)(DYN_MAP_ALIGN - 1); + head = (const int64_t *)h->data; + stride = head[1]; + voff = head[2]; + if (stride <= 0 || voff < 0 || voff + e->size > stride) return; + if (ctrl > b->bytes || (b->bytes - ctrl) / stride < cap) return; + if (mapstack_n == mapstack_cap) { + int64_t c = mapstack_cap ? mapstack_cap * 2 : 16; + map_work *m = (map_work *)realloc(mapstack, (size_t)c * sizeof *m); + if (m == NULL) trap_oom(NULL, 0, c * (int64_t)sizeof *m); + mapstack = m; + mapstack_cap = c; + } + mapstack[mapstack_n].ctrl = (const uint8_t *)h->data + DYN_MAP_HEAD; + mapstack[mapstack_n].slots = (char *)h->data + ctrl; + mapstack[mapstack_n].cap = cap; + mapstack[mapstack_n].stride = stride; + mapstack[mapstack_n].voff = voff; + mapstack[mapstack_n].e = e; + mapstack_n++; +} + /* The words [d] names inside the instance at [base]. A Vec entry is checked * against the live blocks above and queued; [mark_desc] drains the queue * before it returns. */ @@ -1266,17 +1360,17 @@ static void mark_words(char *base, const flan_desc *d) { int64_t j; for (j = 0; j < d->n; j++) mark_value(*(flan_dyn *)(base + d->offs[j])); for (j = 0; j < d->nenv; j++) mark_env(*(uintptr_t *)(base + d->envs[j])); + for (j = 0; j < d->nmap; j++) + queue_map((const flan_dyn_map_hdr *)(base + d->maps[j].off), + d->maps[j].elem); for (j = 0; j < d->nvec; j++) { flan_dyn_vec_hdr *h = (flan_dyn_vec_hdr *)(base + d->vecs[j].off); const flan_desc *e = d->vecs[j].elem; vblock *b; int64_t n; if (e == NULL || e->size <= 0 || h->len <= 0) continue; - b = vblock_find((uintptr_t)h->ptr); + b = live_block(h->ptr); if (b == NULL) continue; - if (b->alloc != NULL - && (int64_t)((flan_dyn_alloc_hdr *)b->alloc)->epoch != b->epoch) - continue; n = b->bytes / e->size; if (h->len < n) n = h->len; if (vstack_n == vstack_cap) { @@ -1295,10 +1389,17 @@ static void mark_words(char *base, const flan_desc *d) { static void mark_desc(char *base, const flan_desc *d) { mark_words(base, d); - while (vstack_n > 0) { - vec_work w = vstack[--vstack_n]; + while (vstack_n > 0 || mapstack_n > 0) { int64_t i; - for (i = 0; i < w.n; i++) mark_words(w.p + i * w.e->size, w.e); + if (vstack_n > 0) { + vec_work w = vstack[--vstack_n]; + for (i = 0; i < w.n; i++) mark_words(w.p + i * w.e->size, w.e); + } else { + map_work w = mapstack[--mapstack_n]; + for (i = 0; i < w.cap; i++) + if (w.ctrl[i] & DYN_MAP_FULL) + mark_words(w.slots + i * w.stride + w.voff, w.e); + } } } @@ -1355,7 +1456,8 @@ static void gc_sweep(void) { void *flan_dyn_env_new(int64_t size, const flan_desc *d) { flan_obj *o = gc_alloc(OBJ_ENV, size); o->len = size; - o->u.env.desc = (d != NULL && (d->n > 0 || d->nenv > 0 || d->nvec > 0)) + o->u.env.desc = (d != NULL && (d->n > 0 || d->nenv > 0 || d->nvec > 0 + || d->nmap > 0)) ? d : NULL; memset(o + 1, 0, (size_t)size); envset_put((uintptr_t)(o + 1)); @@ -1384,7 +1486,7 @@ void flan_dyn_root_push(flan_dyn *slot) { root_add(slot, NULL); } * compiler found no dyn in — but it still occupies an entry, because the count * is what the epilogue knows, and it is turned into an empty descriptor rather * than stored as NULL, which on this stack means something else. */ -static const flan_desc desc_empty = { 0, 0, NULL, 0, NULL, 0, NULL }; +static const flan_desc desc_empty = { 0, 0, NULL, 0, NULL, 0, NULL, 0, NULL }; void flan_dyn_root_push_desc(void *base, const flan_desc *d) { root_add(base, d == NULL ? &desc_empty : d); @@ -2930,6 +3032,33 @@ flan_dyn flan_dyn_at(flan_dyn v, flan_dyn i, const uint8_t *loc, return o->u.v.items[k]; } +/* (slice s lo) and (slice s lo hi) over a text; nil for [hi] is the length. + * The typed slice of a string is a view, and this is a copy: a text is + * immutable, so no program can tell the two apart. A vec's slice would have + * to share its elements with the vec to mean what the typed one means, which + * a copy does not, so a vec traps by type rather than answering differently. */ +flan_dyn flan_dyn_slice(flan_dyn v, flan_dyn lo, flan_dyn hi, + const uint8_t *loc, int64_t loclen) { + int64_t a, b, len; + flan_obj *o; + if (!is_text(v)) + trap2(loc, loclen, TYPE_TRAP, "slice", "only a text is sliced", v, lo); + o = dyn_obj(v); + len = o->len; + a = need_index(loc, loclen, "slice", v, lo); + b = flan_dyn_tag(hi) == FLAN_DYN_TAG_NIL + ? len : need_index(loc, loclen, "slice", v, hi); + if (a < 0 || b < a || b > len) { + char sv[SAY_MAX]; + say(sv, SAY_MAX, v); + flan_say(loc, loclen, + "dyn slice: [%lld %lld) is out of bounds for text of length %lld " + "— %s", (long long)a, (long long)b, (long long)len, sv); + flan_trap((const uint8_t *)"DynRange", 8); + } + return flan_dyn_from_bytes(obj_text_bytes(o) + a, b - a); +} + void flan_dyn_set_at(flan_dyn v, flan_dyn i, flan_dyn x, const uint8_t *loc, int64_t loclen) { int64_t k; diff --git a/runtime/flan_dyn.h b/runtime/flan_dyn.h index abe83d2a..7667650b 100644 --- a/runtime/flan_dyn.h +++ b/runtime/flan_dyn.h @@ -56,8 +56,11 @@ typedef uint64_t flan_dyn; * pointer-sized, holding a collector-allocated environment, null, or a * widened function's code address, told apart by the collector's own set of * environments and never by dereferencing — and [vecs], each a (Vec T) - * header at [off] whose live elements are marked through [elem]. A descriptor - * with only dyn words leaves the last four fields zero. + * header at [off] whose live elements are marked through [elem] — and + * [maps], each a (Map K V) header at [off] whose full slots' values are marked + * through [elem]; a key never holds a word the collector follows, because no + * such type is a key. A descriptor with only dyn words leaves the last six + * fields zero. * * Nothing in this ABI ever writes a descriptor. See [flan_dyn_root_push_desc] * and [flan_dyn_env_new]. */ @@ -75,6 +78,8 @@ typedef struct flan_desc { const int64_t *envs; int64_t nvec; const flan_desc_vec *vecs; + int64_t nmap; + const flan_desc_vec *maps; } flan_desc; /* ── Constructors ──────────────────────────────────────────────────── */ @@ -217,6 +222,11 @@ flan_dyn flan_dyn_len(flan_dyn v); flan_dyn flan_dyn_at(flan_dyn v, flan_dyn i, const uint8_t *loc, int64_t loclen); +/* A copy of the text's bytes [lo, hi); nil for [hi] is the length. A vec, or + * any other value, traps: see the definition. */ +flan_dyn flan_dyn_slice(flan_dyn v, flan_dyn lo, flan_dyn hi, + const uint8_t *loc, int64_t loclen); + /* Vec only — a text is immutable and says so rather than being copied. */ void flan_dyn_set_at(flan_dyn v, flan_dyn i, flan_dyn x, const uint8_t *loc, int64_t loclen); @@ -498,6 +508,10 @@ void flan_gc_set_floor(int64_t bytes); * otherwise does. */ void flan_dyn_vec_hdr_layout(int64_t out[6]); +/* flan_dyn.c's mirror of flan_map and of the block geometry the marker reads, + * compared against flan_rt.c's [flan_map_layout] the same way. */ +void flan_dyn_map_hdr_layout(int64_t out[10]); + #ifdef __cplusplus } #endif diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index b759c63a..a02103e8 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -2561,13 +2561,14 @@ void flan_vec_region_only(flan_vec *v, const uint8_t *loc, int64_t loclen) { loc, loclen); } -/* Told of every Vec block this file allocates, moves or frees: the old block - * (or NULL), the new one (or NULL), its size in bytes, and the allocator and - * epoch it was made under. NULL unless flan_dyn.c's [flan_dyn_track_vecs] has - * installed its own — a program that can make a collector-owned closure - * environment, which may sit in a Vec, installs it so the collector never - * reads a block a stale header copy still names. A pointer rather than a - * call so this file names nothing in flan_dyn.c. */ +/* Told of every Vec block and every Map block this file allocates, moves or + * frees: the old block (or NULL), the new one (or NULL), its size in bytes, + * and the allocator and epoch it was made under. NULL unless flan_dyn.c's + * [flan_dyn_track_vecs] has installed its own — a program that can make a + * collector-owned closure environment or holds a dyn, either of which may sit + * in a Vec or a Map, installs it so the collector never reads a block a stale + * header copy still names. A pointer rather than a call so this file names + * nothing in flan_dyn.c. */ void (*flan_vec_block_hook)(void *old, void *fresh, int64_t bytes, void *alloc, int64_t epoch) = NULL; @@ -2824,6 +2825,22 @@ typedef struct flan_map { int64_t epoch; } flan_map; +/* The header's layout and the block geometry's constants, for the same check + * [flan_vec_layout] exists for: flan_dyn.c restates both to walk a map's full + * slots, and test/dyn_ops.c's "layout" mode compares the two. */ +void flan_map_layout(int64_t out[10]) { + out[0] = (int64_t)sizeof(flan_map); + out[1] = (int64_t)offsetof(flan_map, data); + out[2] = (int64_t)offsetof(flan_map, len); + out[3] = (int64_t)offsetof(flan_map, log2cap); + out[4] = (int64_t)offsetof(flan_map, alloc); + out[5] = (int64_t)offsetof(flan_map, epoch); + out[6] = FLAN_MAP_HEAD; + out[7] = FLAN_MAP_GROUP; + out[8] = FLAN_MAP_ALIGN; + out[9] = FLAN_CTRL_FULL; +} + /* ── Hashing ────────────────────────────────────────────────────────── * * FNV-1a over the bytes, then a final avalanche. FNV alone leaves the low bits @@ -3339,6 +3356,10 @@ static int8_t flan_map_rebuild(flan_map *m, int64_t log2cap, int64_t ksize, a->proc(a, FLAN_ALLOC_FREE, m->data, flan_map_block_size(ksize, vsize, old_cap), 0, FLAN_MAP_ALIGN); } + if (flan_vec_block_hook) + flan_vec_block_hook(m->data, fresh.data, + flan_map_block_size(ksize, vsize, flan_map_cap(&fresh)), + m->alloc, m->epoch); m->data = fresh.data; m->log2cap = fresh.log2cap; return 1; @@ -3546,7 +3567,8 @@ int8_t flan_map_next(flan_map *m, int64_t *cursor, void *kout, void *vout, for (; i < cap; i++) { if (!(g.ctrl[i] & FLAN_CTRL_FULL)) continue; memcpy(kout, flan_map_k(&g, i), (size_t)ksize); - memcpy(vout, flan_map_v(&g, i), (size_t)vsize); + /* NULL from (map-next m cur k), the keys-only walk. */ + if (vout) memcpy(vout, flan_map_v(&g, i), (size_t)vsize); *cursor = i + 1; return 1; } @@ -3586,6 +3608,8 @@ void flan_map_free(flan_map *m, int64_t ksize, int64_t vsize, m->alloc->proc(m->alloc, FLAN_ALLOC_FREE, m->data, flan_map_block_size(ksize, vsize, flan_map_cap(m)), 0, FLAN_MAP_ALIGN); + if (m->data && flan_vec_block_hook) + flan_vec_block_hook(m->data, NULL, 0, NULL, 0); m->data = NULL; m->len = 0; m->log2cap = 0; diff --git a/spec-syntax.md b/spec-syntax.md index 4800e773..c62dcd24 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -99,61 +99,76 @@ Each item: the proposal, then the reason in one line. ### Lexical - **Extension `.fln`.** Short; `.flan` keeps meaning parens, so - `generated.flan` and every existing path stay valid. -- **Comments stay `;`.** Nothing else wants the character. + `generated.flan` and every existing path stay valid. **Built.** +- **Comments stay `;`.** Nothing else wants the character. **Built.** - **Spaces only.** A tab in indentation is an error. The corpus has no tabs. + **Built.** - **Indentation is measured in columns, any width.** A dedent must land on a column already on the stack (GDScript `gdscript_tokenizer.cpp:1291-1296`). + **Built.** - **Blank and comment-only lines never open or close a block** (GDScript - 1170-1239). + 1170-1239). **Built.** - **Inside `(` `[` `{`, newlines and indentation are ignored** except where a trailing block is allowed. Make it parser-driven, the way GDScript's `push_multiline` is (`gdscript_parser.cpp` 658-672, 3695-3770), not a paren counter in the lexer, or a block inside a call can't work. + *Built as a depth counter instead: inside brackets a line break is always + whitespace, so no block opens inside a call's parentheses (§3.1's blocks all + open after the `)`; a lambda with a block body is a statement or a value, + `let f = fn(x)` plus a block).* - **Continuation outside brackets:** a line that starts with a spaced infix operator (`+`, `and`, `==`, …) continues the previous line; so does a line after one that ends in a spaced infix operator. (F# `LexFilter.fs` 360-380, - 1850-1870, 2345-2360.) No `\` continuation. + 1850-1870, 2345-2360.) No `\` continuation. **Built** (`=` does not + continue: `let x =` plus a block is a block value). A continuation line must + sit deeper than the line it continues; one that does not is refused. - **Minus.** `-` glued to a digit is a negative literal (`-1`; 269 in the corpus). `-` glued to a name is negation (`-x` becomes `(- x)`; no name starts with `-` except two prelude sentinels, `lib/prelude.ml:2280,2285`, which rename). `a - b` is subtraction. `a -1` is an error: "separate with a comma or - space the minus". -- **`->` needs spaces as the return arrow.** `dyn->f64` stays a name. + space the minus". **Built.** +- **`->` needs spaces as the return arrow.** `dyn->f64` stays a name. **Built.** - **Character literals stay `\c`**, lexed before brackets and operators: `\(`, `\,`, `\space`. 277 uses, many of them delimiters of the new syntax. + **Built.** ### Collections and separators - **Commas separate elements. With no commas, whitespace does, but only between single terms.** `[1 2 3]`, `[i n]`, `{.x 1 .y 2}` and `[4 f32]` read as today. `[a - 1 b]` is refused: "separate elements with commas". This keeps - the Lisp look for data and is refusable by shape. + the Lisp look for data and is refusable by shape. **Built** (in braces a + value may have an operator in it, `{.x a + 1, .y 2}`; the comma after it is + what is required). - **Struct literal:** `Vector2{.x 1, .y 2}` (brace glued to the name) reads `(Vector2 {.x 1 .y 2})`. A bare `{.x 1}` is today's bare literal. `{:a 1}` is a - dyn map. + dyn map. **Built.** - **No set literal.** Flan has none today: `#{1 2}` reads as the symbol `#` and - a map. Adding sets is a language change, not a syntax one. + a map. Adding sets is a language change, not a syntax one. *In a `.fln` file + `#{1 2}` reads `(# {1 2})`, a brace glued to a name.* ### Expressions - **Precedence**, low to high: `or` < `and` < `not` < comparisons (`== != < <= > >=`) < `<< >>` < `+ -` < `* / %` < unary `-` < postfix (call, - index, field). + index, field). **Built.** Mixing comparison operators in one chain, + `a < b <= c`, is refused. An operator glued to `(` is always a call. - **`==` is `=`; `=` is assignment.** `x = v` reads `(set x v)`, `a[i] = v` reads `(set (at a i) v)`, `p.x = v` reads `(set (.x p) v)`. `x += v` reads - `(set x (+ x v))`; like `++` today, the place is evaluated twice. + `(set x (+ x v))`; like `++` today, the place is evaluated twice. **Built** + (also `-=`, `*=`, `/=`). - **A run of the same operator flattens** (variadics, section 3): `a + b + c` reads `(+ a b c)`, `a < b < c` reads `(< a b c)` (Flan's chain semantics, `test/programs/chain.flan`). This keeps the converter round trip - exact (section 4). + exact (section 4). **Built.** - **Field access is postfix:** `camera.target.x` reads `(.x (.target camera))`. A capitalised left side is a qualified case, not a field: `Shape.Rect` stays one symbol. `test/programs/dev-rerun.flan:65` names a global - `.init-once.counter`; rename it. -- **`and`, `or`, `not` are words**, since they are Flan's own names. + `.init-once.counter`; rename it. **Built**, without the rename: it prints and + reads back through the fallback, `defonce(.init-once.counter, i64, 7)`. +- **`and`, `or`, `not` are words**, since they are Flan's own names. **Built.** - **Casts and type-taking builtins are calls:** `i32(x)`, `vec-new(u8)`, - `max-value(u8)`, `the([3 f32], [1 2 3.5])`. + `max-value(u8)`, `the([3 f32], [1 2 3.5])`. **Built.** ### Statements and blocks @@ -163,16 +178,21 @@ Each item: the proposal, then the reason in one line. which is how the printer writes a `let` that has siblings after it. Destructuring: `let {.x .y} = p`, `let [head & tail] = xs`. (`defer` is function-scoped, not let-scoped, `TODO.org` "defer may be written in a let", - so merging never moves a cleanup.) + so merging never moves a cleanup.) **Built**; `let x =` with the value as an + indented block also reads, and so does `def`/`once`/`const`. - **`if`/`elif`/`else`.** `else` and `elif` sit at the `if`'s column. No `elif` reads as `if` (with else) or `when` (without); with `elif` it reads as `cond`. - One-line form: `if c then a else b`, for use in a `let`. -- **`while c`, `until c`**, optional label first: `while :outer c`. + One-line form: `if c then a else b`, for use in a `let`. **Built** (a block + of one line is that line; of more, `(do …)`). +- **`while c`, `until c`**, optional label first: `while :outer c`. **Built.** - **`for i in range(n)`**, `range(a, b)`, `range(a, b, step)` read as `dotimes`. `range` here is syntax, not a function. `..` is avoided because - `a..b` would lex as one name. + `a..b` would lex as one name. **Built** (a label goes first here too: + `for :outer i in range(n)`). - **`return v`, `break`, `break :outer`, `continue`, `defer expr`** (or `defer` - plus a block). + plus a block). **Built**; `defer` plus a block reads `(defer a b …)`. + `break`, `continue`, `return v` and `x = v`/`x += v` also fit the one-line + slots: a match arm's value, `then`/`else`, and after `defer`. - **`match`:** ``` @@ -182,7 +202,8 @@ Each item: the proposal, then the reason in one line. :north -> 0 _ -> 0 ``` - An arm's body can be an indented block, which reads as `(do …)`. + An arm's body can be an indented block, which reads as `(do …)`. **Built** (a + one-line block reads as that line). - **Conditions**, clauses at the header's column: ``` @@ -199,24 +220,30 @@ Each item: the proposal, then the reason in one line. v * 2 ``` `handler-bind` takes the same `on` clauses; the reader moves them in front of - the body, where the form wants them. -- **Unit:** `()` as a statement reads `(do)`; in a type it is `()`. -- **Lambda:** `fn(i, j) = i * 10 + j`, or `fn(i, j)` plus a block. + the body, where the form wants them. **Built.** +- **Unit:** `()` as a statement reads `(do)`; in a type it is `()`. **Built**; + inside an expression `()` stays `()`, and the printer writes a lone `()` + statement as `(())`. +- **Lambda:** `fn(i, j) = i * 10 + j`, or `fn(i, j)` plus a block. **Built**; + its parameters are bare names, as `(fn [i j] …)` wants, with no `dyn`. + `fn(…)` followed by anything else is the fallback call. ### Definitions - `fn name(a: i32, b) -> R` plus a block; `fn name(a) = expr` for one expression. Reads `(defn name [a i32 b dyn] R …)`. A `{:where …}` constraint - becomes `where ordered?($t)` after the return type. + becomes `where ordered?($t)` after the return type. **Built**, with `-> R` + required until step 6; several predicates are `where p, q`. - `def x = v`, `def x: T = v`, `once x: T`, `once x = v`, `const n = 3`, - `def scratch: [4 u8] = uninit`. + `def scratch: [4 u8] = uninit`. **Built.** `def x = v` and `once x = v` read + with `dyn`; `const n = 3` reads `(defconst n 3)`, its type inferred as today. - `struct Cell` with a `name: Type` line per field. `data Shape` with a line per case: `Circle(r: f32)`, `Empty`. `enum K` with `lo = -1`, `mid`. `union U` like - `struct`. -- `import rl "vendor:raylib"`. + `struct`. **Built** (an untyped field is `dyn`; `Empty()` is `(Empty [])`). +- `import rl "vendor:raylib"`. **Built.** - **Every other form uses the fallback** (next item) until someone asks for sugar: `defclass`, `defgeneric`, `defmulti`, `defmethod`, `declare`, - `declare-c`, `defalias`, `defmacro`, `loop`/`recur`, `array-fill`. + `declare-c`, `defalias`, `defmacro`, `loop`/`recur`, `array-fill`. **Built.** ### The fallback @@ -225,14 +252,17 @@ plus an indented block, reads as `(head arg … block…)`. Commas vanish into t `defmethod(describe, :square, [s]):` plus a block is `(defmethod describe :square [s] …)`. So every form is reachable on day one, the printer has something to fall back on, and the sugar above can land one -piece at a time. +piece at a time. **Built**; a header word glued to `(` is always this call, +`if(c, a)`, `let([x 1], x)`. A bare name with a trailing colon takes a block too, +`comment:` (author's decision 85). ### Types After `:` and `->`, a small type grammar that reads to today's type forms: `i32`, `$t`, `()`, `[T]`, `[const T]`, `[n T]`, `Vec(T)`, `Map(K, V)`, `Option(T)`, `Ptr(T)`, `Ptr(const T)`, `Fn(A, B) -> R`, `CFn(A) -> R`, -`rl/Vector2`. +`rl/Vector2`. **Built** (the arrow is read only in a type position; inside a +value, `vec-new(Fn([i32], i32))` is the call spelling). ### Macro templates @@ -246,7 +276,9 @@ defmacro(with-mode-2d, [camera & body]): `quote` plus a block is a quasiquote; `~x` and `~@xs` are unquote and splice, the Clojure spellings the reader already has. (An earlier sketch used `$x`; -that collides with type variables such as `$t`.) +that collides with type variables such as `$t`.) **Built**: one line reads +`(quasiquote line)`, more read `(quasiquote (do …))`; `~` takes the atom right +after it, so `~name(x)` is `((unquote name) x)`, and `~(f(x))` unquotes a call. ## 3. Settled after review (2026-09-25) @@ -305,7 +337,10 @@ Each step lands on its own, with `dune test --root .` green. paren-syntax expansion text under the original file's name. Replace the space-padding in `flan--text-at` (`emacs/flan.el:2602-2622`), which breaks significant indentation, with `:line`/`:col` fields; the reader seeds its - indent stack with that column. + indent stack with that column. **Built** (also `load-file` and restart + arguments; no `:syntax` means paren, except a `load-file` of a `.fln` + file; several indented statements sent as one expression read as + `(do …)`). 5. **Emacs mode** for `.fln`: - A top-level form runs from a column-0 line that isn't `else`, `elif`, `on` or `restart` to just before the next one, minus trailing blank and diff --git a/spike/backend/driver.ml b/spike/backend/driver.ml deleted file mode 100644 index fde8ce49..00000000 --- a/spike/backend/driver.ml +++ /dev/null @@ -1,177 +0,0 @@ -(* The spike's harness: run the real frontend, lower the functions it produced - with [X86], put the bytes in executable memory, call them, and compare with - what the language says they should answer. - - The comparison is the whole point. Reading the bytes proves nothing -- a - disassembly that looks right and a program that returns the wrong number is - the normal outcome of hand-encoding, which is why the oracle here is the - arithmetic and not objdump. [oracle.sh] disassembles the same buffer, and - that is a debugging aid, not the evidence. *) - -external jit_alloc : int -> nativeint = "spike_jit_alloc" -external jit_write : nativeint -> string -> unit = "spike_jit_write" -external jit_protect : nativeint -> int -> unit = "spike_jit_protect" -external call1 : nativeint -> int64 -> int64 = "spike_call1" -external call2 : nativeint -> int64 -> int64 -> int64 = "spike_call2" -external sym : string -> nativeint = "spike_sym" - -let failures = ref 0 -let checks = ref 0 - -let check name got want = - incr checks; - if got = want then Printf.printf " ok %-28s = %Ld\n" name got - else begin - incr failures; - Printf.printf " FAIL %-28s = %Ld, want %Ld\n" name got want - end - -(* One page per function, so that a function that runs off its own end lands in - an unmapped page and segfaults at the fault rather than in the middle of the - next function. This is the crudest possible version of the code-object - question the whole exercise is really about. *) -let page = 4096 - -let install (code : string) : nativeint = - if String.length code > page then failwith "function exceeds one page"; - let p = jit_alloc page in - jit_write p code; - jit_protect p page; - p - -let run src = - let decls = - Flan.Load.program ~file:src (Flan.Parse.program_all (Flan.Reader.read_file src)) - in - let prog = Flan.Check.program_all decls.Flan.Load.decls in - Printf.printf "frontend: %d fns, %d globals, %d structs, %d externs\n" - (List.length prog.Flan.Tast.fns) (List.length prog.Flan.Tast.globals) - (List.length prog.Flan.Tast.structs) (List.length prog.Flan.Tast.externs); - - (* Two passes, because [spike-calls] calls functions whose addresses are not - known until they are installed. Pass one installs every function at a - fixed page; pass two emits the real code into it. A real backend does this - with relocations; the spike does it by emitting twice, which is the same - answer with none of the machinery. *) - let addrs : (string, nativeint) Hashtbl.t = Hashtbl.create 16 in - let unsupported = ref [] in - let lowerable = - List.filter - (fun (fd : Flan.Tast.fn) -> - try - ignore (X86.fn ~resolve:(fun _ -> 0L) fd); - true - with X86.Unsupported m -> - unsupported := (fd.Flan.Tast.name, m) :: !unsupported; - false) - prog.Flan.Tast.fns - in - List.iter - (fun (fd : Flan.Tast.fn) -> - Hashtbl.replace addrs fd.Flan.Tast.name (jit_alloc page)) - lowerable; - let resolve name = - match Hashtbl.find_opt addrs name with - | Some p -> Int64.of_nativeint p - | None -> - (* Not a Flan function: a runtime entry point, looked up the way a dev - build already reaches the host's symbols -- through the dynamic symbol - table, which --dev links with -rdynamic. *) - Int64.of_nativeint (sym name) - in - let bytes = Hashtbl.create 16 in - List.iter - (fun (fd : Flan.Tast.fn) -> - let code = X86.fn ~resolve fd in - Hashtbl.replace bytes fd.Flan.Tast.name code; - let p = Hashtbl.find addrs fd.Flan.Tast.name in - jit_write p code; - jit_protect p page) - lowerable; - - Printf.printf "lowered: %d of %d functions\n" - (List.length lowerable) (List.length prog.Flan.Tast.fns); - List.iter (fun (n, m) -> Printf.printf " skipped %-20s %s\n" n m) - (List.rev !unsupported); - Hashtbl.iter (fun n c -> Printf.printf " %-20s %4d bytes at %nx\n" - n (String.length c) (Hashtbl.find addrs n)) bytes; - - (* The bytes that actually ran, dumped where run.sh can objdump them. - A debugging aid and not the evidence: a disassembly that reads correctly - next to a function that answers 656 when it should answer 650 is the - normal outcome of hand-encoding, which is why the checks below compare - numbers. *) - (match Sys.getenv_opt "SPIKE_DUMP" with - | None -> () - | Some dir -> - Hashtbl.iter - (fun n c -> - let oc = open_out_bin (Filename.concat dir (n ^ ".bin")) in - output_string oc c; close_out oc) - bytes); - - (* ── The SysV boundary ────────────────────────────────────────────── - Three synthetic functions, built as Tast by hand rather than written in - Flan, because the surface language has no way to spell a call to an - arbitrary C symbol with eight arguments. [Tast.Rt] is the node a runtime - call already uses and the one a [declare-c] shim lands on, so this is the - real path with a made-up callee. *) - let loc = Flan.Loc.unknown in - let i64 = Flan.Types.Int Flan.Types.I64 in - let ex e = { Flan.Tast.e; ty = i64; loc } in - let lit n = ex (Flan.Tast.Int (Int64.of_int n, Flan.Types.I64)) in - let probe name params body = - { Flan.Tast.name; params; slots = Array.make (List.length params) i64; - snames = Array.make (List.length params) None; ret = i64; - body = [ body ]; fdefers = []; fparent = None; floc = loc } - in - let arg0 = ex (Flan.Tast.Local 0) in - let probes = [ - (* Eight integers: six in registers and two on the stack, which is the case - a register-only convention gets silently wrong. *) - probe "abi-8" [ i64 ] - (ex (Flan.Tast.Prim (Flan.Tast.Rt "spike_probe8", - [ arg0; lit 2; lit 3; lit 4; lit 5; lit 6; lit 7; lit 8 ]))); - (* rsp % 16 == 0 at the call. The callee does an aligned 16-byte spill and - answers -1 if it was entered misaligned. *) - probe "abi-align" [ i64 ] - (ex (Flan.Tast.Prim (Flan.Tast.Rt "spike_probe_align", [ arg0 ]))); - (* The same call, but underneath a binary operator -- so it is evaluated - with the left operand spilled on the stack. This is the one that matters: - alignment at a call site is not a property of the prologue, it is a - property of how much the expression evaluator has pushed. *) - probe "abi-align-nested" [ i64 ] - (ex (Flan.Tast.Prim (Flan.Tast.Add, - [ lit 0; - ex (Flan.Tast.Prim (Flan.Tast.Rt "spike_probe_align", [ arg0 ])) ]))); - ] in - List.iter - (fun (fd : Flan.Tast.fn) -> - let code = X86.fn ~resolve fd in - let p = jit_alloc page in - jit_write p code; jit_protect p page; - Hashtbl.replace addrs fd.Flan.Tast.name p) - probes; - - print_endline "results:"; - let at n = Hashtbl.find addrs n in - check "spike-add 3 4" (call2 (at "spike-add") 3L 4L) 7L; - check "spike-add -5 2" (call2 (at "spike-add") (-5L) 2L) (-3L); - check "spike-arith 10 4" (call2 (at "spike-arith") 10L 4L) 19L; - check "spike-let 6" (call1 (at "spike-let") 6L) 1332L; - check "spike-if 1 2" (call2 (at "spike-if") 1L 2L) 1L; - check "spike-if 9 2" (call2 (at "spike-if") 9L 2L) 7L; - check "spike-calls 5" (call1 (at "spike-calls") 5L) 656L; - check "abi-8 1" (call1 (at "abi-8") 1L) 87654321L; - check "abi-align 10" (call1 (at "abi-align") 10L) 13L; - check "abi-align-nested 10" (call1 (at "abi-align-nested") 10L) 13L; - - Printf.printf "\n%d checks, %d failures\n" !checks !failures; - exit (if !failures = 0 then 0 else 1) - -(* The frontend's diagnostics printed rather than swallowed: a spike that says - [Fatal error: exception Errors(_)] costs an hour. *) -let () = - try run Sys.argv.(1) with - | Flan.Loc.Error d -> prerr_endline (Flan.Loc.report d); exit 2 - | Flan.Loc.Errors ds -> prerr_endline (Flan.Loc.report_all ds); exit 2 diff --git a/spike/backend/hist.ml b/spike/backend/hist.ml deleted file mode 100644 index b8d05ea1..00000000 --- a/spike/backend/hist.ml +++ /dev/null @@ -1,87 +0,0 @@ -(* Histogram of Tast expr_kind constructors over the reachable program. A - measurement, not a backend: it answers "what would a whole-program x86 - build actually have to lower for this input", which is the question that - decides whether whole-program coverage is reachable at all. *) -let tbl : (string, int) Hashtbl.t = Hashtbl.create 64 - -let bump k = - Hashtbl.replace tbl k (1 + (try Hashtbl.find tbl k with Not_found -> 0)) - -let name (k : Flan.Tast.expr_kind) = - match k with - | Int _ -> "Int" | Float _ -> "Float" | Bool _ -> "Bool" | Str _ -> "Str" - | Unit -> "Unit" | Zero _ -> "Zero" | Uninit _ -> "Uninit" - | Local _ -> "Local" | Global _ -> "Global" | Prim _ -> "Prim" - | Call _ -> "Call" | FnAddr _ -> "FnAddr" | CallPtr _ -> "CallPtr" - | Do _ -> "Do" | Let _ -> "Let" | If _ -> "If" | While _ -> "While" - | Return _ -> "Return" | Break _ -> "Break" | Continue _ -> "Continue" - | Set _ -> "Set" | Field _ -> "Field" | Addr _ -> "Addr" | Deref _ -> "Deref" - | Make _ -> "Make" | MakeCase _ -> "MakeCase" | CaseField _ -> "CaseField" - | Arr _ -> "Arr" | Some_ _ -> "Some" | None_ -> "None" | Match _ -> "Match" - | UnwrapSome _ -> "UnwrapSome" | Signal _ -> "Signal" | Handled _ -> "Handled" - | RestartCase _ -> "RestartCase" | WithAlloc _ -> "WithAlloc" - | InvokeRestart _ -> "InvokeRestart" - -let pname (p : Flan.Tast.prim) = - match p with - | Add -> "Add" | Sub -> "Sub" | Mul -> "Mul" | Div -> "Div" | Rem -> "Rem" - | Eq -> "Eq" | Ne -> "Ne" | Lt -> "Lt" | Le -> "Le" | Gt -> "Gt" | Ge -> "Ge" - | Not -> "Not" | BitAnd -> "BitAnd" | BitOr -> "BitOr" | BitXor -> "BitXor" - | Shl -> "Shl" | Shr -> "Shr" | Len -> "Len" | At -> "At" | Slice -> "Slice" - | Bytes -> "Bytes" | BytesToF64 -> "BytesToF64" | BytesToI64 -> "BytesToI64" - | F64ToBytes -> "F64ToBytes" | I64ToBytes -> "I64ToBytes" - | StrOfBytes -> "StrOfBytes" | U64ToBytes -> "U64ToBytes" - | EscapeBytes -> "EscapeBytes" | WriteStdout -> "WriteStdout" | Exit -> "Exit" - | Argv -> "Argv" | Rt s -> "Rt:" ^ s | SizeOf _ -> "SizeOf" - | AlignOf _ -> "AlignOf" | AddrOf -> "AddrOf" | Cast _ -> "Cast" - -let rec ex (e : Flan.Tast.expr) = - bump (name e.e); - match e.e with - | Prim (p, xs) -> bump ("prim/" ^ pname p); List.iter ex xs - | Call (_, xs) | Arr xs -> List.iter ex xs - | Make (_, xs) | MakeCase (_, _, xs) -> List.iter ex xs - | CallPtr (f, xs) -> ex f; List.iter ex xs - | Do xs | Handled (_, xs) -> List.iter ex xs - | Let (bs, body) -> List.iter (fun (_, x) -> ex x) bs; List.iter ex body - | If (a, b, c) -> ex a; ex b; ex c - | While (c, b, l) -> ex c; List.iter ex b; List.iter ex l - | Return (Some x) | Some_ x | Deref x | UnwrapSome x | Field (x, _) - | CaseField (x, _, _) | Signal (_, _, x) -> ex x - | Set (p, x) -> pl p; ex x - | Addr p -> pl p - | Match (x, arms) -> - ex x; - List.iter (fun (a : Flan.Tast.arm) -> List.iter ex a.abody) arms - | RestartCase (cs, x) -> - List.iter (fun (c : Flan.Tast.rclause) -> List.iter ex c.rbody) cs; ex x - | WithAlloc (a, b) -> ex a; List.iter ex b - | InvokeRestart (_, _, xs, _, _, _) -> List.iter ex xs - | _ -> () - -and pl (p : Flan.Tast.place) = - match p with - | Plocal _ -> bump "place/Plocal" - | Pglobal _ -> bump "place/Pglobal" - | Pfield (x, _) -> bump "place/Pfield"; ex x - | Pindex (x, ys) -> bump "place/Pindex"; ex x; List.iter ex ys - | Pderef x -> bump "place/Pderef"; ex x - -let () = - let src = Sys.argv.(1) in - let l = - Flan.Load.program ~file:src - (Flan.Parse.program_all (Flan.Reader.read_file src)) - in - let p = Flan.Check.program_all l.Flan.Load.decls in - let p, _, _ = Flan.Reach.link l p in - List.iter - (fun (f : Flan.Tast.fn) -> List.iter ex f.body; List.iter ex f.fdefers) - p.Flan.Tast.fns; - List.iter (fun (g : Flan.Tast.global) -> ex g.Flan.Tast.ginit) - p.Flan.Tast.globals; - Printf.printf "%s: %d reachable fns\n" (Filename.basename src) - (List.length p.Flan.Tast.fns); - let rows = Hashtbl.fold (fun k v a -> (k, v) :: a) tbl [] in - let rows = List.sort (fun (a, _) (b, _) -> compare a b) rows in - List.iter (fun (k, v) -> Printf.printf " %-24s %d\n" k v) rows diff --git a/spike/backend/jit_stubs.c b/spike/backend/jit_stubs.c deleted file mode 100644 index 04f78441..00000000 --- a/spike/backend/jit_stubs.c +++ /dev/null @@ -1,100 +0,0 @@ -/* The three things OCaml cannot do for itself: get executable memory, put - * bytes in it, and jump to them. Everything interesting is in x86.ml; this - * file is deliberately dumb. - * - * Shaped after lib/dynload_stubs.c's rule, which spike/embed took verbatim for - * the same reason: the boundary passes pointers and scalars, never an OCaml - * [value] into foreign storage. Nothing here keeps anything. - * - * RW then mprotect to R+X, never RWX in one mmap: a hardened kernel may refuse - * a writable-executable anonymous mapping outright, and a policy denial that - * comes back as a null pointer reads exactly like an encoding bug. */ - -#include -#include -#include -#include - -#include -#include -#include -#include -#include - -value spike_jit_alloc(value vlen) { - size_t len = (size_t)Long_val(vlen); - void *p = mmap(NULL, len, PROT_READ | PROT_WRITE, - MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); - if (p == MAP_FAILED) caml_failwith("spike_jit_alloc: mmap failed"); - return caml_copy_nativeint((intnat)p); -} - -value spike_jit_write(value vp, value vbytes) { - char *p = (char *)Nativeint_val(vp); - memcpy(p, String_val(vbytes), caml_string_length(vbytes)); - return Val_unit; -} - -value spike_jit_protect(value vp, value vlen) { - void *p = (void *)Nativeint_val(vp); - if (mprotect(p, (size_t)Long_val(vlen), PROT_READ | PROT_EXEC) != 0) - caml_failwith("spike_jit_protect: mprotect failed"); - return Val_unit; -} - -/* Every Flan function's emitted signature is its parameters followed by the - * transfer channel (emit.ml, [signature]), so the trampolines below all pass a - * trailing pointer. Nothing in the spike transfers, so it is NULL. */ -typedef int64_t (*fn1)(int64_t, void *); -typedef int64_t (*fn2)(int64_t, int64_t, void *); - -value spike_call1(value vp, value a) { - return caml_copy_int64(((fn1)Nativeint_val(vp))(Int64_val(a), NULL)); -} -value spike_call2(value vp, value a, value b) { - return caml_copy_int64(((fn2)Nativeint_val(vp))(Int64_val(a), Int64_val(b), NULL)); -} - -value spike_sym(value vname) { - void *h = dlsym(RTLD_DEFAULT, String_val(vname)); - if (h == NULL) caml_failwith("spike_sym: not found"); - return caml_copy_nativeint((intnat)h); -} - -/* ── The C side of the ABI probes ──────────────────────────────────── */ - -/* Eight integers: six in registers, two on the stack, which is the case a - * register-only convention silently gets wrong. The answer is positional so a - * swapped pair cannot pass. */ -int64_t spike_probe8(int64_t a, int64_t b, int64_t c, int64_t d, - int64_t e, int64_t f, int64_t g, int64_t h) { - return a * 1 + b * 10 + c * 100 + d * 1000 + e * 10000 + f * 100000 - + g * 1000000 + h * 10000000; -} - -/* The alignment check, and it has to be done with an aligned load rather than - * by reading rsp, because that is how raylib finds out: the SysV ABI promises - * rsp % 16 == 0 at the call instruction, so on entry rsp+8 is aligned, and a - * callee that spills an __m128 to its frame faults when it is not. -O2 is what - * turns this into an actual movaps; without it the bug hides. */ -__attribute__((noinline)) -int64_t spike_probe_align(int64_t x) { - volatile double v[2] __attribute__((aligned(16))) = { 1.0, 2.0 }; - /* Reading rsp as well, so a failure says which of the two it was. */ - uintptr_t sp; - __asm__ volatile ("mov %%rsp, %0" : "=r"(sp)); - if ((sp % 16) != 8) return -1; /* entry rsp is call-site rsp minus 8 */ - return x + (int64_t)(v[0] + v[1]); -} - -/* No float probe either, for a plainer reason: this emitter has no SSE, so - * there is nothing here that could call one. Floats are counted as work in - * docs/BUILT.md, "Layout was already owned, and that is why the drift fear - * was misplaced", rather than claimed as done. - * - * And no struct-by-value probe, and that is a finding rather than an - * omission: check.ml rejects an aggregate in a [declare] signature and the - * generated shim flattens every one, so no Flan-emitted call ever passes a - * struct to C. The aggregate problem is real but it is on the Flan-to-Flan - * side, which is measured in docs/BUILT.md, "The obstacle that was named - * first, and dissolved", and not from here. */ diff --git a/spike/backend/probe.flan b/spike/backend/probe.flan deleted file mode 100644 index 0fab0e65..00000000 --- a/spike/backend/probe.flan +++ /dev/null @@ -1,24 +0,0 @@ -;; The spike's input. Ordinary Flan, run through the ordinary frontend -- -;; Reader, Parse, Load, Check -- so that what the emitter below lowers is the -;; same Tast.fn the LLVM backend gets and not a literal someone typed to make -;; the exercise come out. - -(defn spike-add [a i64 b i64] i64 - (+ a b)) - -(defn spike-arith [a i64 b i64] i64 - (- (* a 3) (+ b 7))) - -(defn spike-let [a i64] i64 - (let [x (* a a) - y (+ x 1)] - (* x y))) - -(defn spike-if [a i64 b i64] i64 - (if (< a b) (- b a) (- a b))) - -(defn spike-calls [a i64] i64 - (spike-add (spike-arith a 2) (spike-let a))) - -(defn main [] i32 - 0) diff --git a/spike/backend/run.sh b/spike/backend/run.sh deleted file mode 100644 index bdef39bc..00000000 --- a/spike/backend/run.sh +++ /dev/null @@ -1,48 +0,0 @@ -#!/usr/bin/env bash -# The spike, end to end: the real frontend produces a Tast, x86.ml turns it -# into bytes, the bytes go into an mmap, and the mmap gets called. -# -# Driven by hand with ocamlfind and clang against the flan.cmxa dune already -# builds, exactly as spike/embed does and for the same reason: nothing under -# spike/ is wired into the build, so there is no dune file here and `dune test` -# cannot see any of it. -set -u -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -cd "$root" || exit 1 - -dune build --root . lib/flan.cmxa 2>&1 | head -20 - -out=$(mktemp -d); trap 'rm -rf "$out"' EXIT - -# The C stubs. -O2 on purpose: spike_probe_align's aligned load only becomes a -# real movaps with optimisation on, and an alignment bug that only shows up in -# a release build is the one this is looking for. -clang -O2 -c -I"$(ocamlopt -where)" "$here/jit_stubs.c" -o "$out/jit_stubs.o" || exit 1 - -ocamlfind ocamlopt -thread -package unix,threads.posix -linkpkg \ - -I "$root/_build/default/lib/.flan.objs/byte" \ - -I "$root/_build/default/lib/.flan.objs/native" \ - -I "$out" -I "$here" \ - -o "$out/spike" \ - "$root/_build/default/lib/flan.cmxa" \ - -cclib -rdynamic -ccopt -L"$root/_build/default/lib" \ - "$out/jit_stubs.o" \ - "$here/x86.ml" "$here/driver.ml" 2>&1 | head -40 - -test -x "$out/spike" || { echo "build failed"; exit 1; } - -SPIKE_DUMP=$out "$out/spike" "$here/probe.flan" -rc=$? - -# Disassembly on request. objdump over the raw buffer, which is what to reach -# for when a function answers the wrong number -- not what proves it answers -# the right one. -if [ "${SPIKE_DISASM:-}" = 1 ]; then - for f in "$out"/*.bin; do - echo; echo "== $(basename "$f" .bin)" - objdump -D -b binary -m i386:x86-64 -M intel "$f" | tail -n +7 - done -fi -echo "exit: $rc" -exit $rc diff --git a/spike/backend/x86.ml b/spike/backend/x86.ml deleted file mode 100644 index 9f486fed..00000000 --- a/spike/backend/x86.ml +++ /dev/null @@ -1,379 +0,0 @@ -(* A spike: Tast -> x86-64 machine code, in memory, called. Not a backend. - The point is to find out what breaks, so the subset is deliberately tiny - and every case it cannot do raises with the node that defeated it -- an - honest [Unsupported] is the measurement, and a silently wrong answer is - the one outcome that would waste the exercise. - - Register allocation is the trivial one the brief allows: every slot is a - stack slot at [rbp - 8*(i+1)], every value is computed into rax, and a - binary operator pushes its left operand. Two registers are enough for - everything below and nothing is kept live across a statement. That is what - makes an instruction selector tractable in an afternoon; it is also why the - code it produces is four times the size of clang -O0's. - - Conventions, all of them SysV's, because raylib is called from this code: - - integer arguments in rdi rsi rdx rcx r8 r9, then right-to-left on the - stack; integer result in rax. - - rsp % 16 == 0 at the [call] instruction. raylib spills xmm registers - with movaps and faults far from the cause when this is wrong. - - rbx rbp r12-r15 are callee-saved. This emitter touches none of them - except rbp, which it saves. - - every Flan function takes the transfer channel as a trailing ptr - (emit.ml, [signature]), so a Flan function of n parameters is an n+1 - argument C function. *) - -exception Unsupported of string - -let unsupported fmt = Printf.ksprintf (fun s -> raise (Unsupported s)) fmt - -(* ── Bytes ───────────────────────────────────────────────────────────── *) - -type buf = { mutable bytes : Buffer.t } - -let create () = { bytes = Buffer.create 256 } -let len b = Buffer.length b.bytes -let contents b = Buffer.contents b.bytes -let u8 b n = Buffer.add_char b.bytes (Char.chr (n land 0xff)) - -let u32 b n = - for i = 0 to 3 do u8 b ((n asr (i * 8)) land 0xff) done - -let i32 b (n : int) = - if n < -0x80000000 || n > 0x7fffffff then unsupported "displacement %d" n; - u32 b n - -let u64 b (n : int64) = - for i = 0 to 7 do - u8 b (Int64.to_int (Int64.logand (Int64.shift_right_logical n (i * 8)) 0xffL)) - done - -(* ── Registers and modrm ─────────────────────────────────────────────── *) - -(* The encoding order, not the ABI order: this numbering *is* the three bits - the modrm byte wants, which is why rsp is 4 and rbp is 5 rather than - anything more memorable. *) -let rax = 0 and rcx = 1 and rdx = 2 and _rbx = 3 -let rsp = 4 and rbp = 5 and rsi = 6 and rdi = 7 -let r8 = 8 and r9 = 9 - -(* REX.W is always set: everything here is 64-bit. R extends the reg field and - B the r/m field, which is the whole of what r8-r15 need. *) -let rex b ~r ~m = u8 b (0x48 lor (if r >= 8 then 4 else 0) lor (if m >= 8 then 1 else 0)) -let modrm b ~md ~r ~m = u8 b ((md lsl 6) lor ((r land 7) lsl 3) lor (m land 7)) - -(* reg, reg *) -let rr b op ~r ~m = rex b ~r ~m; u8 b op; modrm b ~md:3 ~r ~m - -(* reg, [rbp + disp32]. Always disp32 rather than the shorter disp8 form: a - frame can outgrow 128 bytes and a one-byte displacement that silently wraps - is exactly the bug this spike would not find. *) -let rm_rbp b op ~r ~disp = - rex b ~r ~m:rbp; u8 b op; modrm b ~md:2 ~r ~m:rbp; i32 b disp - -let mov_rr b ~dst ~src = rr b 0x89 ~r:src ~m:dst (* mov dst, src *) -let mov_load b ~dst ~disp = rm_rbp b 0x8b ~r:dst ~disp (* mov dst, [rbp+d] *) -let mov_store b ~src ~disp = rm_rbp b 0x89 ~r:src ~disp (* mov [rbp+d], src *) - -let movabs b ~dst (n : int64) = - rex b ~r:0 ~m:dst; u8 b (0xb8 lor (dst land 7)); u64 b n - -let push b r = if r >= 8 then u8 b 0x41; u8 b (0x50 lor (r land 7)) -let pop b r = if r >= 8 then u8 b 0x41; u8 b (0x58 lor (r land 7)) - -let add_rr b ~dst ~src = rr b 0x01 ~r:src ~m:dst -let sub_rr b ~dst ~src = rr b 0x29 ~r:src ~m:dst -let and_rr b ~dst ~src = rr b 0x21 ~r:src ~m:dst -let or_rr b ~dst ~src = rr b 0x09 ~r:src ~m:dst -let xor_rr b ~dst ~src = rr b 0x31 ~r:src ~m:dst -let imul_rr b ~dst ~src = (* 0f af /r *) - rex b ~r:dst ~m:src; u8 b 0x0f; u8 b 0xaf; modrm b ~md:3 ~r:dst ~m:src -let cmp_rr b ~a ~bb = rr b 0x39 ~r:bb ~m:a (* cmp a, b *) - -let add_imm32 b ~dst n = rex b ~r:0 ~m:dst; u8 b 0x81; modrm b ~md:3 ~r:0 ~m:dst; i32 b n -let sub_imm32 b ~dst n = rex b ~r:0 ~m:dst; u8 b 0x81; modrm b ~md:3 ~r:5 ~m:dst; i32 b n - -let call_r b r = if r >= 8 then u8 b 0x41; u8 b 0xff; modrm b ~md:3 ~r:2 ~m:r -let leave b = u8 b 0xc9 -let ret b = u8 b 0xc3 -let ud2 b = u8 b 0x0f; u8 b 0x0b - -(* setcc al, then movzx rax, al -- a compare's result is a bool, which is one - byte in Flan's layout (i1 in LLVM, and the ABI zero-extends it). *) -let setcc b cc = u8 b 0x0f; u8 b (0x90 lor cc); modrm b ~md:3 ~r:0 ~m:rax -let movzx_al b = u8 b 0x48; u8 b 0x0f; u8 b 0xb6; modrm b ~md:3 ~r:rax ~m:rax - -(* jcc rel32 and jmp rel32, patched once the target is known. *) -let jcc b cc = u8 b 0x0f; u8 b (0x80 lor cc); let at = len b in u32 b 0; at -let jmp b = u8 b 0xe9; let at = len b in u32 b 0; at - -let patch b ~at ~target = - let rel = target - (at + 4) in - let s = Buffer.contents b.bytes in - let s = Bytes.of_string s in - for i = 0 to 3 do - Bytes.set s (at + i) (Char.chr ((rel asr (i * 8)) land 0xff)) - done; - let nb = Buffer.create (Bytes.length s) in - Buffer.add_bytes nb s; - b.bytes <- nb - -(* ── Lowering ────────────────────────────────────────────────────────── *) - -type fnctx = { - b : buf; - nslots : int; - (* How many 8-byte words this expression's evaluation has pushed since the - prologue. rsp is 16-aligned at the end of the prologue, so [depth] even - means rsp is aligned and [depth] odd means it is 8 out. - - This counter is the answer to the one bug the ABI probe found. Alignment - is not a property of the prologue: the evaluator spills the left operand - across the right one's evaluation, so a call written in the right operand - runs with one word outstanding. Deriving it from a count kept here is the - only way that stays correct as the evaluator grows cases, and it is what - clang's [sub rsp, 8] before a call is doing. *) - mutable depth : int; - (* A symbol the code calls, resolved to an absolute address by the driver - before emission. movabs + call r is what a JIT does anyway: a rel32 call - cannot reach an arbitrary mmap, and the 2-byte indirect call is cheaper - than the relocation machinery a real backend would grow here. *) - resolve : string -> int64; -} - -let slot_disp i = -8 * (i + 1) - -(* Every stack movement goes through these two, so that nothing can move rsp - without the counter noticing. *) -let pushv f r = push f.b r; f.depth <- f.depth + 1 -let popv f r = pop f.b r; f.depth <- f.depth - 1 - -(* Every type this spike handles is one 8-byte integer register. Everything - else is the real backend's problem and is enumerated in the verdict rather - than guessed at here. *) -let word_ty (t : Flan.Types.t) = - match t with - | Flan.Types.Int _ | Flan.Types.Bool | Flan.Types.Ptr _ -> true - | _ -> false - -let check_word what (t : Flan.Types.t) = - if not (word_ty t) then - unsupported "%s of type %s: not a single integer register" what - (Flan.Types.to_string t) - -let cc_of signed (p : Flan.Tast.prim) = - match p, signed with - | Flan.Tast.Eq, _ -> 0x4 | Flan.Tast.Ne, _ -> 0x5 - | Flan.Tast.Lt, true -> 0xc | Flan.Tast.Lt, false -> 0x2 - | Flan.Tast.Le, true -> 0xe | Flan.Tast.Le, false -> 0x6 - | Flan.Tast.Gt, true -> 0xf | Flan.Tast.Gt, false -> 0x7 - | Flan.Tast.Ge, true -> 0xd | Flan.Tast.Ge, false -> 0x3 - | _ -> assert false - -let arg_regs = [| rdi; rsi; rdx; rcx; r8; r9 |] - -(* Value into rax. Everything is a subexpression of something that will - immediately consume rax, so nothing is kept live and no allocator is - needed. *) -let rec value f (e : Flan.Tast.expr) : unit = - let b = f.b in - match e.Flan.Tast.e with - | Flan.Tast.Int (n, _) -> movabs b ~dst:rax n - | Flan.Tast.Bool v -> movabs b ~dst:rax (if v then 1L else 0L) - | Flan.Tast.Local i -> - check_word "local" e.Flan.Tast.ty; - if i >= f.nslots then unsupported "slot %d out of range" i; - mov_load b ~dst:rax ~disp:(slot_disp i) - | Flan.Tast.Do body -> block f body - | Flan.Tast.Let (binds, body) -> - List.iter - (fun (i, e) -> - value f e; - check_word "binding" e.Flan.Tast.ty; - mov_store b ~src:rax ~disp:(slot_disp i)) - binds; - block f body - | Flan.Tast.Set (Flan.Tast.Plocal i, rhs) -> - value f rhs; - check_word "assignment" rhs.Flan.Tast.ty; - mov_store b ~src:rax ~disp:(slot_disp i) - | Flan.Tast.If (c, t, e') -> emit_if f c t e' - | Flan.Tast.Return (Some x) -> - value f x; - leave b; ret b - | Flan.Tast.Return None -> leave b; ret b - | Flan.Tast.Prim (p, args) -> prim f e p args - | Flan.Tast.Call (name, args) -> call f (f.resolve name) args ~xfer:true - | Flan.Tast.Unit -> () - | k -> unsupported "expression: %s" (node_name k) - -and block f body = - match body with - | [] -> () - | [ last ] -> value f last - | x :: rest -> value f x; block f rest - -and prim f e (p : Flan.Tast.prim) args = - let b = f.b in - match p, args with - | (Flan.Tast.Add | Flan.Tast.Sub | Flan.Tast.Mul - | Flan.Tast.BitAnd | Flan.Tast.BitOr | Flan.Tast.BitXor), [ x; y ] -> - check_word "arithmetic" x.Flan.Tast.ty; - binop f x y; - (* left in rax, right in rcx *) - (match p with - | Flan.Tast.Add -> add_rr b ~dst:rax ~src:rcx - | Flan.Tast.Sub -> sub_rr b ~dst:rax ~src:rcx - | Flan.Tast.Mul -> imul_rr b ~dst:rax ~src:rcx - | Flan.Tast.BitAnd -> and_rr b ~dst:rax ~src:rcx - | Flan.Tast.BitOr -> or_rr b ~dst:rax ~src:rcx - | _ -> xor_rr b ~dst:rax ~src:rcx) - | (Flan.Tast.Eq | Flan.Tast.Ne | Flan.Tast.Lt | Flan.Tast.Le - | Flan.Tast.Gt | Flan.Tast.Ge), [ x; y ] -> - let signed = - match x.Flan.Tast.ty with - | Flan.Types.Int k -> Flan.Types.signed k - | Flan.Types.Bool -> false - | t -> unsupported "comparison on %s" (Flan.Types.to_string t) - in - binop f x y; - cmp_rr b ~a:rax ~bb:rcx; - setcc b (cc_of signed p); - movzx_al b - | Flan.Tast.Rt sym, args -> call f (f.resolve sym) args ~xfer:false - | _ -> unsupported "primitive in %s" (Flan.Types.to_string e.Flan.Tast.ty) - -(* Left into rax, right into rcx, with the left spilled across the right's - evaluation. Left-to-right, which emit.ml's [map_lr] is explicit about being - required rather than a preference -- a call in either operand has effects. - The push/pop pair keeps rsp 16-aligned in pairs, which matters only because - [call] below re-derives alignment from a counter rather than tracking rsp. *) -and binop f x y = - let b = f.b in - value f x; - pushv f rax; - value f y; - mov_rr b ~dst:rcx ~src:rax; - popv f rax - -and emit_if f c t e = - let b = f.b in - value f c; - (* cmp rax, 0: 48 83 f8 00 -- written out because the helper above takes - registers only and a zero-compare is the one immediate form worth having. *) - u8 b 0x48; u8 b 0x83; modrm b ~md:3 ~r:7 ~m:rax; u8 b 0x00; - let to_else = jcc b 0x4 in (* je *) - value f t; - let to_end = jmp b in - patch b ~at:to_else ~target:(len b); - value f e; - patch b ~at:to_end ~target:(len b) - -(* A call, and this is the part that has to be exactly right. - - [xfer] appends the transfer channel, which every Flan function's signature - carries and a C entry point does not. The spike passes NULL: nothing here - signals, and a real backend would pass the caller's own channel pointer. - - Alignment: rsp is 16-aligned at function entry minus the 8 the [call] - pushed, so after [push rbp] it is aligned again, and the frame is rounded to - a multiple of 16. Every push here is paired with a pop before the next call - can happen, so rsp is aligned at every call site by construction. Stack - arguments are pushed in pairs to keep it that way -- an odd count gets a - dummy push, which is what clang's [sub rsp, 8] is doing when you see it. *) -and call f (addr : int64) args ~xfer = - let b = f.b in - let n = List.length args + (if xfer then 1 else 0) in - (* Bring rsp to 16 first, so everything below can count in pairs. *) - let pad = f.depth land 1 = 1 in - if pad then (sub_imm32 b ~dst:rsp 8; f.depth <- f.depth + 1); - let stacked = List.filteri (fun i _ -> i >= 6) args in - let nstack = List.length stacked + (if xfer && n > 6 then 1 else 0) in - (* The stack half, evaluated right to left so that the seventh argument ends - up at [rsp] and the eighth above it. The transfer channel is the last - argument of all, so it is pushed first. *) - if nstack land 1 = 1 then (sub_imm32 b ~dst:rsp 8; f.depth <- f.depth + 1); - if xfer && n > 6 then (movabs b ~dst:rax 0L; pushv f rax); - List.iter (fun a -> value f a; pushv f rax) (List.rev stacked); - (* The register half needs a spill of its own: rdi..r9 are argument registers - and rax is where every value lands, so an earlier argument would be - clobbered by a later one's evaluation. Push each, then pop them into their - registers in reverse. *) - let inreg = List.filteri (fun i _ -> i < 6) args in - List.iter (fun a -> value f a; pushv f rax) inreg; - let nreg = List.length inreg in - List.iteri (fun i _ -> popv f arg_regs.(nreg - 1 - i)) inreg; - if xfer && n <= 6 then movabs b ~dst:arg_regs.(nreg) 0L; - (* al = the number of vector registers used. Required only for a variadic - callee and set unconditionally because it is two bytes: a wrong al on a - printf-shaped entry point -- raylib's TraceLog is one -- is a crash that - looks like anything else. After the argument registers, since al is rax's - low byte. *) - u8 b 0xb0; u8 b 0x00; (* mov al, 0 *) - (* r11 always, never r9: r11 is the scratch register SysV reserves and is the - one register guaranteed not to be carrying an argument. Choosing the - target conditionally is how a six-argument call gets quietly wrong. *) - u8 b 0x49; u8 b 0xbb; u64 b addr; (* movabs r11, addr *) - assert (f.depth land 1 = 0); - call_r b 11; - let back = 8 * (nstack + (nstack land 1)) in - if back > 0 then (add_imm32 b ~dst:rsp back; f.depth <- f.depth - (back / 8)); - if pad then (add_imm32 b ~dst:rsp 8; f.depth <- f.depth - 1) - -and node_name (k : Flan.Tast.expr_kind) = - match k with - | Flan.Tast.Int _ -> "Int" | Flan.Tast.Float _ -> "Float" - | Flan.Tast.Bool _ -> "Bool" | Flan.Tast.Str _ -> "Str" - | Flan.Tast.Unit -> "Unit" | Flan.Tast.Zero _ -> "Zero" - | Flan.Tast.Uninit _ -> "Uninit" | Flan.Tast.Local _ -> "Local" - | Flan.Tast.Global _ -> "Global" | Flan.Tast.Prim _ -> "Prim" - | Flan.Tast.Call _ -> "Call" | Flan.Tast.FnAddr _ -> "FnAddr" - | Flan.Tast.CallPtr _ -> "CallPtr" | Flan.Tast.Do _ -> "Do" - | Flan.Tast.Let _ -> "Let" | Flan.Tast.If _ -> "If" - | Flan.Tast.While _ -> "While" | Flan.Tast.Return _ -> "Return" - | Flan.Tast.Break _ -> "Break" | Flan.Tast.Continue _ -> "Continue" - | Flan.Tast.Set _ -> "Set" | Flan.Tast.Field _ -> "Field" - | Flan.Tast.Addr _ -> "Addr" | Flan.Tast.Deref _ -> "Deref" - | Flan.Tast.Make _ -> "Make" | Flan.Tast.MakeCase _ -> "MakeCase" - | Flan.Tast.CaseField _ -> "CaseField" | Flan.Tast.Arr _ -> "Arr" - | Flan.Tast.Some_ _ -> "Some" | Flan.Tast.None_ -> "None" - | Flan.Tast.Match _ -> "Match" | Flan.Tast.UnwrapSome _ -> "UnwrapSome" - | Flan.Tast.Signal _ -> "Signal" | Flan.Tast.Handled _ -> "Handled" - | Flan.Tast.RestartCase _ -> "RestartCase" - | Flan.Tast.WithAlloc _ -> "WithAlloc" - | Flan.Tast.InvokeRestart _ -> "InvokeRestart" - -(* ── A whole function ────────────────────────────────────────────────── *) - -let fn ~resolve (fd : Flan.Tast.fn) : string = - let b = create () in - let nslots = Array.length fd.Flan.Tast.slots in - let f = { b; nslots; resolve; depth = 0 } in - push b rbp; - mov_rr b ~dst:rbp ~src:rsp; - (* Round the frame to 16 so that rsp is aligned at every call site. One - extra word for the transfer channel's slot, which is not a Flan slot and - has no index -- the spike never reads it, but a real backend must, and - leaving no room for it is the kind of thing that is cheap now and - expensive later. *) - let frame = (nslots + 1) * 8 in - let frame = (frame + 15) land lnot 15 in - if frame > 0 then sub_imm32 b ~dst:rsp frame; - (* Parameters arrive in registers and are stored into their slots at once, - which is also emit.ml's rule: slots 0..n-1 are the parameters, in order. *) - let np = List.length fd.Flan.Tast.params in - if np > 6 then unsupported "more than six parameters"; - List.iteri - (fun i ty -> - check_word "parameter" ty; - mov_store b ~src:arg_regs.(i) ~disp:(slot_disp i)) - fd.Flan.Tast.params; - (* The transfer channel is the last argument and goes just past the slots. *) - if np < 6 then mov_store b ~src:arg_regs.(np) ~disp:(slot_disp nslots); - block f fd.Flan.Tast.body; - leave b; ret b; - (* Anything that falls off the end of a Never-returning body lands here and - traps rather than running into the next function. LLVM's [unreachable] is - undefined behaviour; ud2 is a defined SIGILL, and the difference is one of - the audit's findings. *) - ud2 b; - contents b diff --git a/spike/embed/.gitignore b/spike/embed/.gitignore deleted file mode 100644 index 441349b2..00000000 --- a/spike/embed/.gitignore +++ /dev/null @@ -1,14 +0,0 @@ -# Spike artifacts. run.sh rebuilds all of them from the sources beside it. -*.o -*.cmi -*.cmx -baseline -spike1 -spike2 -spike3 -spike4 -spike5 -spike6 -spike5b -spike5b_std -stubs5b.o diff --git a/spike/embed/baseline.c b/spike/embed/baseline.c deleted file mode 100644 index 4c181ae7..00000000 --- a/spike/embed/baseline.c +++ /dev/null @@ -1,4 +0,0 @@ -/* The floor: what a C binary with no OCaml in it weighs, so the delta the dev - build actually pays can be stated honestly. */ -#include -int main(void) { printf("baseline\n"); return 0; } diff --git a/spike/embed/dynload_stubs.c b/spike/embed/dynload_stubs.c deleted file mode 100644 index e32add72..00000000 --- a/spike/embed/dynload_stubs.c +++ /dev/null @@ -1,149 +0,0 @@ -/* Loading a compiled macro into the compiler's own process. - * - * TODO.org, "The expander design: running a macro means dlopening it": there - * is no interpreter, so running a macro means - * compiling it and dlopening it. The reload primitive does exactly this - * already, but its host is a running Flan program written in C; here the host - * is the OCaml compiler, which has no dlopen of its own -- Dynlink loads - * OCaml, not ELF. So the boundary needs stubs, and this is all of them. - * - * Two rules shape what is here: - * - * - Nothing but pointers and scalars crosses. A Flan `string`/slice is - * {ptr,len} and a `Form` is {i32, [2 x i64]}, and LLVM's calling - * convention for an aggregate passed or returned *by value* in hand-written - * IR is not promised to be clang's C ABI for the equivalent struct. The - * unions lane verified memory layout, so memory is the agreement we have: - * every macro is reached through a thunk taking (ptr,i64,ptr,ptr) and - * writing its result through the out pointer. - * - * - The macro module is self-contained: it links the runtime in and has no - * undefined Flan symbols, so the OCaml executable needs no -rdynamic and - * nothing in it has to be exported. - * - * The peek/poke family is how the marshaller writes a Form image into memory - * the macro can read. OCaml cannot address raw memory, so the bytes are laid - * out from here one field at a time. - */ - -#include -#include -#include -#include - -#include -#include -#include -#include - -CAMLprim value flan_dl_open(value path) { - CAMLparam1(path); - void *h = dlopen(String_val(path), RTLD_NOW | RTLD_LOCAL); - if (!h) caml_failwith(dlerror()); - CAMLreturn(caml_copy_nativeint((intnat)h)); -} - -CAMLprim value flan_dl_sym(value handle, value name) { - CAMLparam2(handle, name); - void *p = dlsym((void *)Nativeint_val(handle), String_val(name)); - if (!p) caml_failwith(dlerror()); - CAMLreturn(caml_copy_nativeint((intnat)p)); -} - -CAMLprim value flan_dl_close(value handle) { - dlclose((void *)Nativeint_val(handle)); - return Val_unit; -} - -/* The one call shape a macro is reached through. See the thunk Emit writes. */ -typedef void (*flan_macro_fn)(void *args, int64_t n, void *out, void *xfer); - -CAMLprim value flan_macro_call(value fn, value args, value n, value out) { - CAMLparam4(fn, args, n, out); - /* The transfer channel every Flan signature carries (spec-conditions.md, - section 6). A macro that signals a condition with nothing above it to - handle it aborts inside the compiler, which is loud rather than silent; - the channel still has to be a real, zeroed slot. */ - int64_t xfer[4] = { 0, 0, 0, 0 }; - ((flan_macro_fn)Nativeint_val(fn))((void *)Nativeint_val(args), - Int64_val(n), - (void *)Nativeint_val(out), xfer); - CAMLreturn(Val_unit); -} - -CAMLprim value flan_mem_alloc(value n) { - CAMLparam1(n); - /* Zeroed, because ZII is the language's rule and an unwritten Form field - must read as the zero of its type rather than as whatever malloc had. */ - void *p = calloc((size_t)Long_val(n), 1); - if (!p) caml_failwith("out of memory laying out a macro's arguments"); - CAMLreturn(caml_copy_nativeint((intnat)p)); -} - -CAMLprim value flan_mem_free(value p) { - free((void *)Nativeint_val(p)); - return Val_unit; -} - -CAMLprim value flan_poke_i32(value p, value off, value x) { - int32_t v = (int32_t)Int32_val(x); - memcpy((char *)Nativeint_val(p) + Long_val(off), &v, 4); - return Val_unit; -} - -CAMLprim value flan_poke_i64(value p, value off, value x) { - int64_t v = Int64_val(x); - memcpy((char *)Nativeint_val(p) + Long_val(off), &v, 8); - return Val_unit; -} - -CAMLprim value flan_poke_f64(value p, value off, value x) { - double v = Double_val(x); - memcpy((char *)Nativeint_val(p) + Long_val(off), &v, 8); - return Val_unit; -} - -CAMLprim value flan_poke_ptr(value p, value off, value q) { - void *v = (void *)Nativeint_val(q); - memcpy((char *)Nativeint_val(p) + Long_val(off), &v, sizeof v); - return Val_unit; -} - -CAMLprim value flan_poke_bytes(value p, value off, value s) { - memcpy((char *)Nativeint_val(p) + Long_val(off), String_val(s), - caml_string_length(s)); - return Val_unit; -} - -CAMLprim value flan_peek_i32(value p, value off) { - int32_t v; - memcpy(&v, (char *)Nativeint_val(p) + Long_val(off), 4); - return caml_copy_int32(v); -} - -CAMLprim value flan_peek_i64(value p, value off) { - int64_t v; - memcpy(&v, (char *)Nativeint_val(p) + Long_val(off), 8); - return caml_copy_int64(v); -} - -CAMLprim value flan_peek_f64(value p, value off) { - double v; - memcpy(&v, (char *)Nativeint_val(p) + Long_val(off), 8); - return caml_copy_double(v); -} - -CAMLprim value flan_peek_ptr(value p, value off) { - void *v; - memcpy(&v, (char *)Nativeint_val(p) + Long_val(off), sizeof v); - return caml_copy_nativeint((intnat)v); -} - -CAMLprim value flan_peek_bytes(value p, value off, value n) { - CAMLparam3(p, off, n); - CAMLlocal1(s); - s = caml_alloc_string((mlsize_t)Long_val(n)); - memcpy((char *)Bytes_val(s), (char *)Nativeint_val(p) + Long_val(off), - (size_t)Long_val(n)); - CAMLreturn(s); -} diff --git a/spike/embed/gc_ml.ml b/spike/embed/gc_ml.ml deleted file mode 100644 index e8b63ebf..00000000 --- a/spike/embed/gc_ml.ml +++ /dev/null @@ -1,21 +0,0 @@ -(* Step 6: the OCaml GC beside Flan's arenas. - Allocate hard, then compact -- the most disruptive thing the collector does, - since compaction is what actually moves blocks. C checks its arena after. *) - -external note : nativeint -> unit = "spike_note_arena" - -let () = - Callback.register "spike_churn" (fun (rounds : int) -> - let keep = ref [] in - for i = 1 to rounds do - (* Garbage, plus a little that survives, so the heap really grows. *) - for _ = 1 to 2000 do ignore (Bytes.create 512) done; - if i mod 10 = 0 then keep := Bytes.create 4096 :: !keep - done; - Gc.full_major (); - Gc.compact (); - let s = Gc.quick_stat () in - Printf.sprintf - "allocated %.0f words, %d major collections, %d compactions, heap %d words" - s.Gc.minor_words s.Gc.major_collections s.Gc.compactions s.Gc.heap_words); - ignore note diff --git a/spike/embed/harness1.c b/spike/embed/harness1.c deleted file mode 100644 index 63d6c29a..00000000 --- a/spike/embed/harness1.c +++ /dev/null @@ -1,14 +0,0 @@ -/* A C main() that owns the process and starts the OCaml runtime underneath it. */ -#include -#include -#include - -int main(int argc, char **argv) { - (void)argc; - caml_startup(argv); - const value *f = caml_named_value("spike_greet"); - if (!f) { fprintf(stderr, "spike: greet not registered\n"); return 1; } - printf("%s\n", String_val(caml_callback(*f, Val_int(42)))); - printf("spike: C main still owns the process\n"); - return 0; -} diff --git a/spike/embed/harness2.c b/spike/embed/harness2.c deleted file mode 100644 index ab960f51..00000000 --- a/spike/embed/harness2.c +++ /dev/null @@ -1,54 +0,0 @@ -/* Step 2: the whole compiler inside a C binary, and what it costs to start. - * - * The startup number is measured around caml_startup itself, not with time(1) - * on the process -- what a merged dev build would pay is the runtime coming up - * and every module initialiser running, not exec and dynamic linking, which it - * pays today anyway. */ -#include -#include -#include -#include -#include - -#ifndef FLANSRC -#define FLANSRC "test/programs/edn.flan" -#endif - -static double ms_since(struct timespec a) { - struct timespec b; - clock_gettime(CLOCK_MONOTONIC, &b); - return (b.tv_sec - a.tv_sec) * 1e3 + (b.tv_nsec - a.tv_nsec) / 1e6; -} - -static const value *need(const char *n) { - const value *f = caml_named_value(n); - if (!f) fprintf(stderr, "spike: %s not registered\n", n); - return f; -} - -int main(int argc, char **argv) { - struct timespec t0; - const char *src = argc > 1 ? argv[1] : FLANSRC; - const value *f; - - clock_gettime(CLOCK_MONOTONIC, &t0); - caml_startup(argv); - printf("caml_startup (runtime + every module initialiser): %.3f ms\n", ms_since(t0)); - - f = need("spike_footprint"); - if (f) printf("linked-module footprint: %s\n", String_val(caml_callback(*f, Val_unit))); - - f = need("spike_compile"); - if (f) { - clock_gettime(CLOCK_MONOTONIC, &t0); - printf("%s\n", String_val(caml_callback(*f, caml_copy_string(src)))); - printf("first in-process compile (read+parse+check+emit): %.3f ms\n", ms_since(t0)); - - clock_gettime(CLOCK_MONOTONIC, &t0); - caml_callback(*f, caml_copy_string(src)); - printf("second, warm: %.3f ms\n", ms_since(t0)); - } - - printf("spike: C main() still owns the process\n"); - return 0; -} diff --git a/spike/embed/harness3.c b/spike/embed/harness3.c deleted file mode 100644 index 09b069f4..00000000 --- a/spike/embed/harness3.c +++ /dev/null @@ -1,14 +0,0 @@ -/* Step 3: does -output-complete-obj carry the project's C stubs through? */ -#include -#include -#include - -int main(int argc, char **argv) { - const value *f; - (void)argc; - caml_startup(argv); - f = caml_named_value("spike_stubs"); - if (!f) { fprintf(stderr, "spike: stubs not registered\n"); return 1; } - printf("stubs reached from embedded runtime: %s\n", String_val(caml_callback(*f, Val_unit))); - return 0; -} diff --git a/spike/embed/harness4.c b/spike/embed/harness4.c deleted file mode 100644 index 49e789d8..00000000 --- a/spike/embed/harness4.c +++ /dev/null @@ -1,106 +0,0 @@ -/* Step 4: the macOS shape, and the discriminating test of the whole spike. - * - * main() is the game: it takes the thread the window needs and runs a loop it - * never leaves until the compiler says stop. The OCaml runtime is started on a - * pthread that C spawned -- exactly where vendor/agent/flan_agent.c already - * puts its listener. - * - * Two separate claims get tested: - * a. caml_startup works on a non-main, C-created thread at all. - * b. a *different* C thread, one the runtime never created, can call into - * OCaml after caml_c_thread_register(). - * (b) is the one that matters for the agent: its listener thread is spawned by - * flan_agent_start and would have to be able to reach the compiler. - */ -#include -#include -#include -#include -#include -#include -#include -#include -#include - -static char **g_argv; -static const char *g_src = "test/programs/edn.flan"; -static atomic_int compiler_up = 0; -static atomic_int quit = 0; -static pthread_t main_tid; - -static void nap(long ms) { - struct timespec t = { ms / 1000, (ms % 1000) * 1000000L }; - nanosleep(&t, NULL); -} - -static const value *need(const char *n) { - const value *f = caml_named_value(n); - if (!f) fprintf(stderr, "spike: %s not registered\n", n); - return f; -} - -/* The compiler thread: starts the OCaml runtime off the main thread. */ -static void *compiler_thread(void *unused) { - const value *f; - (void)unused; - printf(" [compiler thread] is main thread? %s\n", - pthread_equal(pthread_self(), main_tid) ? "YES (wrong)" : "no (correct)"); - caml_startup(g_argv); - printf(" [compiler thread] caml_startup returned off the main thread\n"); - - f = need("spike_domains"); - if (f) printf(" [compiler thread] %s\n", String_val(caml_callback(*f, Val_unit))); - - f = need("spike_thread_compile"); - if (f) printf(" [compiler thread] %s\n", - String_val(caml_callback(*f, caml_copy_string(g_src)))); - - /* Hand the runtime over so another C thread can borrow it, and prove the - main loop kept running throughout. */ - atomic_store(&compiler_up, 1); - caml_release_runtime_system(); - nap(300); - caml_acquire_runtime_system(); - atomic_store(&quit, 1); - return NULL; -} - -/* A second C thread, like the agent's listener: never created by OCaml. */ -static void *listener_thread(void *unused) { - const value *f; - (void)unused; - while (!atomic_load(&compiler_up)) nap(5); - if (caml_c_thread_register() == 0) { - printf(" [listener thread] caml_c_thread_register FAILED\n"); - return NULL; - } - caml_acquire_runtime_system(); - f = need("spike_thread_compile"); - if (f) printf(" [listener thread] %s\n", - String_val(caml_callback(*f, caml_copy_string(g_src)))); - caml_release_runtime_system(); - caml_c_thread_unregister(); - printf(" [listener thread] registered, called OCaml, unregistered\n"); - return NULL; -} - -int main(int argc, char **argv) { - pthread_t comp, lst; - long frames = 0; - g_argv = argv; - if (argc > 1) g_src = argv[1]; - main_tid = pthread_self(); - - if (pthread_create(&comp, NULL, compiler_thread, NULL) != 0) return 1; - if (pthread_create(&lst, NULL, listener_thread, NULL) != 0) return 1; - - /* The game loop. This thread never calls into OCaml and never blocks on it -- - it is the window's thread, and on macOS it has to be this one. */ - while (!atomic_load(&quit)) { frames++; nap(1); } - - pthread_join(comp, NULL); - pthread_join(lst, NULL); - printf(" [main thread] ran %ld frames without ever entering OCaml\n", frames); - printf("spike: the game kept the main thread\n"); - return 0; -} diff --git a/spike/embed/harness5.c b/spike/embed/harness5.c deleted file mode 100644 index 0e9f2143..00000000 --- a/spike/embed/harness5.c +++ /dev/null @@ -1,91 +0,0 @@ -/* Step 5: who owns SIGSEGV. - * - * The OCaml runtime installs a SIGSEGV handler to turn a stack-guard-page hit - * into the Stack_overflow exception. The break loop wants SIGSEGV for the - * crash case. This is the one real collision, so it is measured in both - * directions: - * - * a. what the disposition is before caml_startup, and after it; - * b. whether a handler installed AFTER caml_startup actually receives a - * genuine fault in program memory -- i.e. whether the break loop can have - * what it wants by installing last. - * - * SIGPIPE is not probed: flan_agent.c sends with MSG_NOSIGNAL throughout and - * does not rely on a disposition. - */ -#include -#include -#include -#include -#include -#include - -static void describe(const char *when, int sig) { - struct sigaction old; - memset(&old, 0, sizeof old); - sigaction(sig, NULL, &old); - printf(" %-22s %-8s handler=%p flags=%#x %s%s\n", when, - sig == SIGSEGV ? "SIGSEGV" : sig == SIGINT ? "SIGINT" : "SIGFPE", - (old.sa_flags & SA_SIGINFO) ? (void *)old.sa_sigaction : (void *)old.sa_handler, - (unsigned)old.sa_flags, - (old.sa_flags & SA_ONSTACK) ? "ONSTACK " : "", - old.sa_handler == SIG_DFL ? "(SIG_DFL)" - : old.sa_handler == SIG_IGN ? "(SIG_IGN)" : "(custom)"); -} - -static sigjmp_buf escape; -static volatile sig_atomic_t ours_ran = 0; - -static void our_segv(int sig, siginfo_t *info, void *ctx) { - (void)sig; (void)ctx; - ours_ran = 1; - /* What a break loop would do here is stop and serve; the spike just proves - the handler was reached, with the faulting address in hand. */ - printf(" our SIGSEGV handler ran, fault address = %p\n", info->si_addr); - siglongjmp(escape, 1); -} - -int main(int argc, char **argv) { - struct sigaction sa, ocaml_segv; - volatile int *bad = (int *)0x10; - (void)argc; - - printf("before caml_startup:\n"); - describe("before startup", SIGSEGV); - describe("before startup", SIGINT); - describe("before startup", SIGFPE); - - caml_startup(argv); - - printf("after caml_startup:\n"); - describe("after startup", SIGSEGV); - describe("after startup", SIGINT); - describe("after startup", SIGFPE); - memset(&ocaml_segv, 0, sizeof ocaml_segv); - sigaction(SIGSEGV, NULL, &ocaml_segv); - - /* Now install ours last, the way the break loop would. */ - memset(&sa, 0, sizeof sa); - sa.sa_sigaction = our_segv; - sa.sa_flags = SA_SIGINFO | SA_ONSTACK; - sigemptyset(&sa.sa_mask); - sigaction(SIGSEGV, &sa, NULL); - printf("break loop installs last:\n"); - describe("after break loop", SIGSEGV); - - if (sigsetjmp(escape, 1) == 0) { - printf(" dereferencing %p ...\n", (void *)bad); - *bad = 1; - printf(" no fault -- UNEXPECTED\n"); - } else { - printf(" recovered; a handler installed after caml_startup does receive " - "a real fault: %s\n", ours_ran ? "yes" : "no"); - } - - /* And the cost of taking it: OCaml's own handler is now displaced, so its - stack-overflow detection is gone unless ours chains to the saved one. */ - printf(" OCaml's displaced SIGSEGV handler was %p -- chaining to it is what " - "keeps Stack_overflow working\n", - (void *)ocaml_segv.sa_sigaction); - return 0; -} diff --git a/spike/embed/harness5b.c b/spike/embed/harness5b.c deleted file mode 100644 index 1b164121..00000000 --- a/spike/embed/harness5b.c +++ /dev/null @@ -1,110 +0,0 @@ -/* Step 5b: the SIGSEGV question, asked properly. - * - * 5a read the disposition either side of caml_startup and found SIG_DFL both - * times, which would mean no collision at all. That is too good, and it is - * because OCaml 5 installs the handler per *domain*, on the domain's own - * thread, not once during startup. So this asks at four moments, and then asks - * the only question that decides anything: with the break loop holding SIGSEGV, - * does an OCaml stack overflow still raise Stack_overflow, or does it become a - * hard crash? - * - * Two ways of taking it are compared: - * take_segv -- install ours and discard OCaml's, the naive thing; - * chain_segv -- install ours, keep OCaml's, and forward to it. - */ -#include -#include -#include -#include -#include -#include -#include - -static struct sigaction ocaml_segv; -static int have_ocaml_segv = 0; - -CAMLprim value spike_show_segv(value when) { - struct sigaction cur; - memset(&cur, 0, sizeof cur); - sigaction(SIGSEGV, NULL, &cur); - printf(" SIGSEGV %-46s handler=%p flags=%#x%s\n", String_val(when), - (cur.sa_flags & SA_SIGINFO) ? (void *)cur.sa_sigaction - : (void *)cur.sa_handler, - (unsigned)cur.sa_flags, - cur.sa_handler == SIG_DFL ? " (SIG_DFL)" : ""); - fflush(stdout); - return Val_unit; -} - -/* The break loop's handler. It does not long-jump here -- the point is only to - * see whether it is reached and whether OCaml still works around it. */ -static void break_segv(int sig, siginfo_t *info, void *ctx) { - (void)sig; - if (have_ocaml_segv && ocaml_segv.sa_sigaction && - ocaml_segv.sa_handler != SIG_DFL && ocaml_segv.sa_handler != SIG_IGN) { - /* Chained: hand the fault to OCaml, which turns a guard-page hit into - * Stack_overflow and re-raises anything else. */ - ocaml_segv.sa_sigaction(sig, info, ctx); - return; - } - /* Taken outright: nothing below us. A real break loop would stop and serve; - * here we can only abort, which is the honest cost of discarding OCaml's. */ - printf(" break loop caught SIGSEGV at %p with nothing to chain to\n", - info->si_addr); - fflush(stdout); - _exit(9); -} - -static void install(int keep_old) { - struct sigaction sa; - memset(&sa, 0, sizeof sa); - memset(&ocaml_segv, 0, sizeof ocaml_segv); - sigaction(SIGSEGV, NULL, &ocaml_segv); - have_ocaml_segv = keep_old; - sa.sa_sigaction = break_segv; - sa.sa_flags = SA_SIGINFO | SA_ONSTACK | SA_NODEFER; - sigemptyset(&sa.sa_mask); - sigaction(SIGSEGV, &sa, NULL); -} - -/* A sweep, so "the OCaml runtime installs handlers" can be stated as a list - * rather than a worry. Called from OCaml with the runtime and a domain up. */ -CAMLprim value spike_sweep(value u) { - static const int sigs[] = { SIGSEGV, SIGBUS, SIGFPE, SIGILL, SIGINT, SIGTERM, - SIGPIPE, SIGCHLD, SIGUSR1, SIGUSR2, SIGABRT, - SIGALRM, SIGPROF, SIGVTALRM, SIGWINCH }; - static const char *names[] = { "SEGV", "BUS", "FPE", "ILL", "INT", "TERM", - "PIPE", "CHLD", "USR1", "USR2", "ABRT", - "ALRM", "PROF", "VTALRM", "WINCH" }; - struct sigaction c; - unsigned i; - (void)u; - for (i = 0; i < sizeof sigs / sizeof *sigs; i++) { - memset(&c, 0, sizeof c); - sigaction(sigs[i], NULL, &c); - if (c.sa_handler != SIG_DFL) - printf(" SIG%-8s %s\n", names[i], - c.sa_handler == SIG_IGN ? "SIG_IGN" : "custom handler"); - } - printf(" (every signal not named above is SIG_DFL)\n"); - fflush(stdout); - return Val_unit; -} - -CAMLprim value spike_take_segv(value u) { (void)u; install(0); return Val_unit; } -CAMLprim value spike_chain_segv(value u) { (void)u; install(1); return Val_unit; } - -#ifndef SPIKE_NO_MAIN -int main(int argc, char **argv) { - struct sigaction cur; - (void)argc; - memset(&cur, 0, sizeof cur); - sigaction(SIGSEGV, NULL, &cur); - printf(" SIGSEGV %-46s handler=%p%s\n", "before caml_startup", - (void *)cur.sa_handler, cur.sa_handler == SIG_DFL ? " (SIG_DFL)" : ""); - /* Everything else runs from sig_ml.ml's module initialiser, so the readings - * happen on the runtime's own thread at the moments that matter. */ - caml_startup(argv); - return 0; -} -#endif diff --git a/spike/embed/harness6.c b/spike/embed/harness6.c deleted file mode 100644 index 670e854e..00000000 --- a/spike/embed/harness6.c +++ /dev/null @@ -1,61 +0,0 @@ -/* Step 6: does OCaml's collector touch memory it does not own? - * - * Flan's arenas, Vecs and Maps are plain malloc'd memory. The claim is that - * OCaml never sees them, so a compaction cannot move or scribble on them. The - * probe: fill an arena with a checkable pattern, hold raw interior pointers - * into it across a full major collection AND a compaction, then verify every - * byte and every pointer. - * - * What this proves is narrow and worth stating narrowly: OCaml traces its own - * roots only. It does NOT license storing an OCaml `value` in this arena -- - * that would need caml_register_global_root, and is the way the assumption - * actually breaks. - */ -#include -#include -#include -#include -#include -#include - -#define ARENA (8u << 20) /* 8 MiB, the shape of a Flan arena */ - -static uint8_t *arena; -static uint64_t *interior[64]; - -CAMLprim value spike_note_arena(value p) { (void)p; return Val_unit; } - -static uint8_t pattern(size_t i) { return (uint8_t)(i * 31u + 7u); } - -int main(int argc, char **argv) { - const value *f; - size_t i, bad = 0; - uint8_t *before; - (void)argc; - - arena = malloc(ARENA); - if (!arena) return 1; - for (i = 0; i < ARENA; i++) arena[i] = pattern(i); - for (i = 0; i < 64; i++) interior[i] = (uint64_t *)(arena + i * 4096); - before = arena; - - caml_startup(argv); - - f = caml_named_value("spike_churn"); - if (!f) { fprintf(stderr, "spike: churn not registered\n"); return 1; } - printf("%s\n", String_val(caml_callback(*f, Val_int(200)))); - - for (i = 0; i < ARENA; i++) if (arena[i] != pattern(i)) bad++; - printf("arena base %s (%p -> %p)\n", before == arena ? "unmoved" : "MOVED", - (void *)before, (void *)arena); - printf("arena bytes altered by the GC: %zu of %u\n", bad, ARENA); - - bad = 0; - for (i = 0; i < 64; i++) - if (interior[i] != (uint64_t *)(arena + i * 4096)) bad++; - printf("raw interior pointers invalidated: %zu of 64\n", bad); - printf("spike: %s\n", bad == 0 ? "foreign memory is invisible to the collector" - : "FOREIGN MEMORY WAS DISTURBED"); - free(arena); - return 0; -} diff --git a/spike/embed/hello_ml.ml b/spike/embed/hello_ml.ml deleted file mode 100644 index dbef30c1..00000000 --- a/spike/embed/hello_ml.ml +++ /dev/null @@ -1,5 +0,0 @@ -(* Step 1: the smallest thing that proves OCaml code can be reached from a C - [main]. One function, registered by name, called back from C. *) -let () = - Callback.register "spike_greet" (fun (n : int) -> - Printf.sprintf "ocaml saw %d, unix says pid %d" n (Unix.getpid ())) diff --git a/spike/embed/merged.sh b/spike/embed/merged.sh deleted file mode 100644 index c9639640..00000000 --- a/spike/embed/merged.sh +++ /dev/null @@ -1,66 +0,0 @@ -#!/usr/bin/env bash -# Step 8: the thing the whole spike is really asking about -- ONE binary that -# is both a compiled Flan program and the OCaml compiler, with clang doing the -# final link. -# -# Everything before this proved a piece. This proves the shape: the Flan -# program's own main() is renamed out of the way, a C main() takes the main -# thread and runs the program there, and caml_startup happens on a side thread -# beside it. That is exactly item 11's inversion, built for real. -# -# It is NOT the merged architecture -- nothing is wired up, the compiler and the -# program do not talk. It is a link and a size and a startup number. -set -u -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -src=${1:-test/programs/edn.flan} -cd "$root" || exit 1 -out=$(mktemp -d); trap 'rm -rf "$out"' EXIT - -FLAN=_build/default/bin/main.exe -OCAMLLIB=$(ocamlopt -where) -SYSLIBS="-lm -lpthread -ldl -lzstd" - -echo "program: $src" - -# 1. The Flan program, as it is built today, for the baseline sizes. -"$FLAN" build "$src" -o "$out/rel" || exit 1 -"$FLAN" build "$src" --dev -o "$out/dev" || exit 1 - -# 2. The same program as an object, with its main renamed so a C main can own -# the process. Emit writes @main literally; sed is enough to move it. -"$FLAN" emit "$src" --dev > "$out/prog.ll" || exit 1 -sed -i 's/define i32 @main(/define i32 @flan_program_main(/' "$out/prog.ll" -grep -q 'define i32 @flan_program_main(' "$out/prog.ll" || { - echo "could not find @main in the emitted IR -- adjust the rename"; exit 1; } -clang -c -x ir "$out/prog.ll" -o "$out/prog.o" || exit 1 - -# 3. The runtime the program needs, and the agent beside it. -clang -c -O2 runtime/flan_rt.c -o "$out/rt.o" || exit 1 -clang -c -O2 runtime/flan_dev.c -o "$out/dev.o" || exit 1 -clang -c -O2 vendor/agent/flan_agent.c -o "$out/ag.o" || exit 1 - -# 4. The whole OCaml compiler as one object. -ocamlfind ocamlopt -thread -package unix,threads.posix -linkpkg \ - -output-complete-obj \ - -I "$root/_build/default/lib/.flan.objs/byte" \ - -I "$root/_build/default/lib/.flan.objs/native" \ - -o "$out/compiler.o" "$root/_build/default/lib/flan.cmxa" \ - "$here/thread_ml.ml" || exit 1 - -# 5. One link. clang, as the project already does it. -clang -I"$OCAMLLIB" "$here/merged_main.c" "$out/prog.o" "$out/rt.o" "$out/dev.o" \ - "$out/ag.o" "$out/compiler.o" -o "$out/merged" $SYSLIBS || exit 1 - -echo -echo "sizes:" -for f in rel dev merged; do - printf ' %-30s %9d bytes\n' "$f" "$(stat -c%s "$out/$f")" -done -printf ' %-30s %9d bytes\n' "what the compiler adds to a dev build" \ - "$(( $(stat -c%s "$out/merged") - $(stat -c%s "$out/dev") ))" - -echo -echo "running the merged binary:" -"$out/merged" "$src" -echo "exit: $?" diff --git a/spike/embed/merged_main.c b/spike/embed/merged_main.c deleted file mode 100644 index 85d0bccf..00000000 --- a/spike/embed/merged_main.c +++ /dev/null @@ -1,77 +0,0 @@ -/* One process: the Flan program on the main thread, the OCaml compiler beside - * it on a domain of its own. - * - * This is the shape item 11 settles on, and the reason it is written this way - * round rather than the other: on macOS the window has to be on the main - * thread, so the game keeps main() and the compiler moves to the side -- - * beside the listener vendor/agent/flan_agent.c already starts there. - * - * The program and the compiler do not talk to each other here. Wiring them up - * is the real work; this only shows they can share an address space, a link, - * and a process, with clang doing the final link. */ -#include -#include -#include -#include -#include -#include -#include -#include - -/* The Flan program's entry point, renamed out of main's way by merged.sh. */ -extern int flan_program_main(int argc, char **argv); - -static char **g_argv; -static const char *g_src; -/* The Flan program's main calls exit(), so the compiler has to be up before it - * starts -- which is the honest ordering anyway: the image comes up and serves, - * then the program runs, the way starting an SBCL image does. */ -static atomic_int compiler_ready = 0; - -static double ms_since(struct timespec a) { - struct timespec b; - clock_gettime(CLOCK_MONOTONIC, &b); - return (b.tv_sec - a.tv_sec) * 1e3 + (b.tv_nsec - a.tv_nsec) / 1e6; -} - -static void *compiler_side(void *unused) { - struct timespec t0; - const value *f; - (void)unused; - clock_gettime(CLOCK_MONOTONIC, &t0); - caml_startup(g_argv); - printf("[compiler] up on a side thread in %.3f ms\n", ms_since(t0)); - f = caml_named_value("spike_thread_compile"); - if (f) { - clock_gettime(CLOCK_MONOTONIC, &t0); - printf("[compiler] %s\n", String_val(caml_callback(*f, caml_copy_string(g_src)))); - printf("[compiler] compiled the running program from inside it, in %.3f ms\n", - ms_since(t0)); - } - caml_release_runtime_system(); - atomic_store(&compiler_ready, 1); - return NULL; -} - -int main(int argc, char **argv) { - pthread_t comp; - int rc; - g_argv = argv; - g_src = argc > 1 ? argv[1] : "test/programs/edn.flan"; - - if (pthread_create(&comp, NULL, compiler_side, NULL) != 0) return 1; - - while (!atomic_load(&compiler_ready)) { - struct timespec t = { 0, 2000000L }; - nanosleep(&t, NULL); - } - - /* The main thread is the program's, and it never enters OCaml. */ - printf("[program] running on the main thread\n"); - rc = flan_program_main(argc, argv); - printf("[program] returned %d\n", rc); - - pthread_join(comp, NULL); - printf("one process: a Flan program and the OCaml compiler, same binary\n"); - return 0; -} diff --git a/spike/embed/run.sh b/spike/embed/run.sh deleted file mode 100644 index 51fdcc10..00000000 --- a/spike/embed/run.sh +++ /dev/null @@ -1,76 +0,0 @@ -#!/usr/bin/env bash -# Spike: what it costs to link the OCaml compiler into a native Flan dev build. -# -# Deliberately NOT a dune target. The root `dune` only excludes old-ocaml/, so a -# dune file here would land in @default and make the spike part of the build. -# Instead this drives ocamlfind and clang by hand, against the flan.cmxa that -# dune already produces. Run it from anywhere: bash spike/embed/run.sh -set -u - -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -cd "$here" || exit 1 - -OCAMLLIB=$(ocamlopt -where) -CAMLINC="-I$OCAMLLIB" -# OCaml 5.2's marshaller is compressed, so -output-complete-obj pulls in zstd. -SYSLIBS="-lm -lpthread -ldl -lzstd" - -step() { printf '\n=== %s ===\n' "$1"; } - -# ---------------------------------------------------------------- 1. smallest -step "1. smallest link: C main() -> caml_startup -> OCaml callback" -ocamlfind ocamlopt -package unix -linkpkg -output-complete-obj \ - -o embed1.o hello_ml.ml || exit 1 -clang $CAMLINC harness1.c embed1.o -o spike1 $SYSLIBS || exit 1 -./spike1 || echo "spike1 FAILED" -ls -l spike1 | awk '{print "spike1 size: " $5 " bytes"}' - -# ------------------------------------------------------- 2. the real compiler -step "2. link the whole flan compiler (flan.cmxa) into a C binary" -CMXA="$root/_build/default/lib/flan.cmxa" -if [ ! -f "$CMXA" ]; then - echo "no $CMXA -- run 'dune build --root .' first"; exit 1 -fi -ocamlfind ocamlopt -package unix -linkpkg -output-complete-obj \ - -I "$root/_build/default/lib/.flan.objs/byte" \ - -I "$root/_build/default/lib/.flan.objs/native" \ - -o embed2.o "$CMXA" whole_ml.ml || exit 1 -clang $CAMLINC harness2.c embed2.o -o spike2 $SYSLIBS || exit 1 -(cd "$root" && "$here/spike2" test/programs/edn.flan) || echo "spike2 FAILED" -ls -l spike2 | awk '{print "spike2 size: " $5 " bytes"}' -ls -l "$root/_build/default/bin/main.exe" | awk '{print "main.exe size: " $5 " bytes"}' -clang $CAMLINC baseline.c -o baseline -ls -l baseline | awk '{print "bare C baseline: " $5 " bytes"}' - -# ------------------------------------------------------------- 3. with stubs -step "3. the same, with the project's own C stubs compiled in" -ocamlfind ocamlopt -package unix -linkpkg -output-complete-obj \ - -I "$root/_build/default/lib/.flan.objs/byte" \ - -I "$root/_build/default/lib/.flan.objs/native" \ - -o embed3.o "$CMXA" stubs_ml.ml dynload_stubs.c || exit 1 -clang $CAMLINC harness3.c embed3.o -o spike3 $SYSLIBS || exit 1 -./spike3 || echo "spike3 FAILED" - -# ------------------------------------------ 4. threads: game owns main thread -step "4. threads: C main runs the 'game loop', OCaml starts on another thread" -ocamlfind ocamlopt -thread -package unix,threads.posix -linkpkg -output-complete-obj \ - -I "$root/_build/default/lib/.flan.objs/byte" \ - -I "$root/_build/default/lib/.flan.objs/native" \ - -o embed4.o "$CMXA" thread_ml.ml || exit 1 -clang $CAMLINC harness4.c embed4.o -o spike4 $SYSLIBS || exit 1 -(cd "$root" && "$here/spike4" test/programs/edn.flan) || echo "spike4 FAILED" - -# ------------------------------------------------------------ 5. signals -step "5. signals: who owns SIGSEGV across caml_startup" -clang $CAMLINC harness5.c embed2.o -o spike5 $SYSLIBS || exit 1 -./spike5 || echo "spike5 exited nonzero" - -# ------------------------------------------------------- 6. GC vs raw memory -step "6. GC: does a compaction move or touch a C-owned arena" -ocamlfind ocamlopt -package unix -linkpkg -output-complete-obj \ - -o embed6.o gc_ml.ml || exit 1 -clang $CAMLINC harness6.c embed6.o -o spike6 $SYSLIBS || exit 1 -./spike6 || echo "spike6 FAILED" - -printf '\nspike: done\n' diff --git a/spike/embed/sig.sh b/spike/embed/sig.sh deleted file mode 100644 index 6b6a2383..00000000 --- a/spike/embed/sig.sh +++ /dev/null @@ -1,23 +0,0 @@ -#!/usr/bin/env bash -# Step 5b on its own: the SIGSEGV question, embedded and standalone side by -# side. The standalone build is the control -- if OCaml behaves the same in a -# plain ocamlopt executable, then embedding changed nothing about signals. -set -u -here=$(cd "$(dirname "$0")" && pwd) -cd "$here" || exit 1 -OCAMLLIB=$(ocamlopt -where) -SYSLIBS="-lm -lpthread -ldl -lzstd" - -echo "=== 5b-embedded: caml_startup called from a C main() ===" -ocamlfind ocamlopt -package unix -linkpkg -output-complete-obj \ - -o embed5b.o sig_ml.ml || exit 1 -clang -I"$OCAMLLIB" harness5b.c embed5b.o -o spike5b $SYSLIBS || exit 1 -./spike5b; echo "exit: $?" - -echo -echo "=== 5b-standalone: the same OCaml, as a plain ocamlopt executable ===" -# The control. Same stubs, but OCaml owns main(). -clang -c -I"$OCAMLLIB" -DSPIKE_NO_MAIN harness5b.c -o stubs5b.o || exit 1 -ocamlfind ocamlopt -package unix -linkpkg -o spike5b_std sig_ml.ml stubs5b.o \ - -cclib -lzstd || exit 1 -./spike5b_std; echo "exit: $?" diff --git a/spike/embed/sig_ml.ml b/spike/embed/sig_ml.ml deleted file mode 100644 index 5d96ba2b..00000000 --- a/spike/embed/sig_ml.ml +++ /dev/null @@ -1,34 +0,0 @@ -(* Step 5b: OCaml 5.2 installs its SIGSEGV handler per-domain, not once at - startup, so "read the disposition after caml_startup" is not the whole - question. This asks it at four moments, and then asks the thing that - actually matters: does Stack_overflow still get raised once the break loop - has taken SIGSEGV? *) - -external show : string -> unit = "spike_show_segv" -external take_segv : unit -> unit = "spike_take_segv" -external chain_segv : unit -> unit = "spike_chain_segv" -external sweep : unit -> unit = "spike_sweep" - -let rec deep n = if n <= 0 then 0 else 1 + deep (n - 1) + (if n < 0 then deep n else 0) - -let overflow_result () = - try - let n = deep 100_000_000 in - Printf.sprintf "returned %d (no overflow)" n - with Stack_overflow -> "Stack_overflow raised" - -let () = - show "at module init (main domain up)"; - let d = Domain.spawn (fun () -> show "inside a spawned domain") in - Domain.join d; - show "after Domain.join"; - print_endline "every signal the OCaml runtime is holding:"; - sweep (); - Printf.sprintf "before touching SIGSEGV: %s" (overflow_result ()) |> print_endline; - take_segv (); - show "after the break loop takes SIGSEGV outright"; - Printf.sprintf "with SIGSEGV taken outright: %s" (overflow_result ()) - |> print_endline; - chain_segv (); - show "after the break loop chains to OCaml's handler"; - Printf.sprintf "with SIGSEGV chained: %s" (overflow_result ()) |> print_endline diff --git a/spike/embed/stubs_ml.ml b/spike/embed/stubs_ml.ml deleted file mode 100644 index 34a2664a..00000000 --- a/spike/embed/stubs_ml.ml +++ /dev/null @@ -1,26 +0,0 @@ -(* Step 3: the project's own C stubs, in the same link as the compiler. - lib/dynload_stubs.c is taken verbatim from 9e0ae3a (the unmerged dlopen - branch) -- it is the only C the compiler itself is built from, and it is the - case that -output-complete-obj has to carry through. *) - -external dl_open : string -> nativeint = "flan_dl_open" -external dl_sym : nativeint -> string -> nativeint = "flan_dl_sym" -external mem_alloc : int -> nativeint = "flan_mem_alloc" -external mem_free : nativeint -> unit = "flan_mem_free" -external poke_i64 : nativeint -> int -> int64 -> unit = "flan_poke_i64" -external peek_i64 : nativeint -> int -> int64 = "flan_peek_i64" - -let () = - Callback.register "spike_stubs" (fun () -> - (* peek/poke: the raw memory the marshaller lays a Form image out in. *) - let p = mem_alloc 64 in - poke_i64 p 8 0xfeedfacedeadbeefL; - let got = peek_i64 p 8 in - mem_free p; - (* dlopen from inside the embedded runtime, on the process's own image. *) - let h = dl_open "libm.so.6" in - let s = dl_sym h "sqrt" in - Printf.sprintf "peek/poke %s; dlopen+dlsym %s" - (if got = 0xfeedfacedeadbeefL then "ok" else "WRONG") - (if s <> 0n then "ok" else "WRONG")); - ignore dl_open diff --git a/spike/embed/symbols.sh b/spike/embed/symbols.sh deleted file mode 100644 index 34e4bed8..00000000 --- a/spike/embed/symbols.sh +++ /dev/null @@ -1,50 +0,0 @@ -#!/usr/bin/env bash -# Step 7: the integration hazard nobody asks about until the link fails. -# -# Today runtime/flan_rt.c, runtime/flan_dev.c and vendor/agent/flan_agent.c are -# compiled into the *program*, and lib/dynload_stubs.c into the *compiler*. -# Merging the processes puts all four and the OCaml runtime in one link. This -# checks, symbol by symbol, whether anything collides. -set -u -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -out=$(mktemp -d) -trap 'rm -rf "$out"' EXIT -cd "$root" || exit 1 - -defs() { nm --defined-only "$@" 2>/dev/null | awk 'NF==3 {print $3}' | sort -u; } - -clang -c runtime/flan_rt.c -o "$out/rt.o" || exit 1 -clang -c runtime/flan_dev.c -o "$out/dev.o" || exit 1 -clang -c vendor/agent/flan_agent.c -o "$out/ag.o" || exit 1 -clang -c -I"$(ocamlopt -where)" "$here/dynload_stubs.c" -o "$out/dl.o" || exit 1 - -defs "$out/rt.o" "$out/dev.o" "$out/ag.o" "$out/dl.o" > "$out/flan.syms" -defs /home/joe/.opam/default/lib/ocaml/libasmrun.a > "$out/ml.syms" 2>/dev/null -[ -s "$out/ml.syms" ] || defs "$(ocamlopt -where)/libasmrun.a" > "$out/ml.syms" - -echo "Flan's own C defines $(wc -l < "$out/flan.syms") symbols;" \ - "libasmrun defines $(wc -l < "$out/ml.syms")." -echo "collisions between Flan's C and the OCaml runtime:" -if comm -12 "$out/flan.syms" "$out/ml.syms" | grep . ; then - echo " ^^ those would have to be renamed" -else - echo " none" -fi - -echo "collisions among Flan's own four .c files:" -for a in rt dev ag dl; do defs "$out/$a.o" > "$out/$a.syms"; done -found=0 -for a in rt dev ag dl; do - for b in rt dev ag dl; do - [ "$a" \< "$b" ] || continue - c=$(comm -12 "$out/$a.syms" "$out/$b.syms") - [ -n "$c" ] && { echo " $a vs $b:"; echo "$c" | sed 's/^/ /'; found=1; } - done -done -[ $found -eq 0 ] && echo " none" - -echo "what Flan's C needs that the OCaml runtime also exports (shared libc etc):" -nm --undefined-only "$out/rt.o" "$out/ag.o" 2>/dev/null | awk 'NF==2{print $2}' \ - | sort -u > "$out/need.syms" -comm -12 "$out/need.syms" "$out/ml.syms" | sed 's/^/ /' | head -20 diff --git a/spike/embed/thread_ml.ml b/spike/embed/thread_ml.ml deleted file mode 100644 index 81d0fad2..00000000 --- a/spike/embed/thread_ml.ml +++ /dev/null @@ -1,32 +0,0 @@ -(* Step 4: the macOS shape. The game owns the main thread; the compiler and the - listener run beside it. - - The question is NOT "can OCaml use threads" -- it is whether caml_startup can - be called from a pthread that C spawned, while main() goes on to run a - window loop it never returns from. That is the inversion item 11 settles on, - and it is the one that has to be measured rather than assumed. *) - -let compile file = - let l = Flan.Load.program ~file (Flan.Parse.program (Flan.Reader.read_file file)) in - let p = Flan.Check.program l.Flan.Load.decls in - String.length (Flan.Emit.program ~dev:true p) - -let () = - Callback.register "spike_thread_compile" (fun (file : string) -> - let tid = Thread.id (Thread.self ()) in - match compile file with - | n -> - Printf.sprintf "compiled on OCaml thread %d: %d bytes of LLVM IR" tid n - | exception e -> Printf.sprintf "FAILED: %s" (Printexc.to_string e)); - Callback.register "spike_domains" (fun () -> - (* A second domain doing real work while the main thread is elsewhere -- - 5.2's multicore runtime, which is the objection item 12 says has gone - away. Confirmed rather than assumed. *) - let d = Domain.spawn (fun () -> - let s = ref 0 in - for i = 1 to 5_000_000 do s := !s + i done; - (Domain.self () :> int), !s) - in - let id, s = Domain.join d in - Printf.sprintf "domain %d summed to %d; recommended_domain_count = %d" - id s (Domain.recommended_domain_count ())) diff --git a/spike/embed/whole_ml.ml b/spike/embed/whole_ml.ml deleted file mode 100644 index 38c0197b..00000000 --- a/spike/embed/whole_ml.ml +++ /dev/null @@ -1,40 +0,0 @@ -(* Step 2: reach enough of the compiler that the linker cannot drop it, and do - real compiler work in-process so the measurement is of a working compiler - rather than of dead code that happened to link. - - The work is the driver's own path, the one bin/main.ml takes: - read -> Parse.program -> Load.program -> Check.program -> Emit.program. That - is the whole front end and the whole back end short of [llc]. Check.program - prepends the prelude itself, so the prelude is in the measurement without - being fed in twice. *) - -let compile file = - let l = Flan.Load.program ~file (Flan.Parse.program (Flan.Reader.read_file file)) in - let p = Flan.Check.program l.Flan.Load.decls in - let ir = Flan.Emit.program ~dev:true p in - (List.length l.Flan.Load.decls, String.length ir) - -(* Touched only so the linker keeps the modules a merged dev build would carry. - Nothing here is called for its effect. *) -let footprint () = - String.concat "," - [ Flan.Build.clang; - string_of_int (String.length Flan.Shim.header); - string_of_int (String.length Flan.Runtime_src.source); - string_of_int (String.length Flan.Runtime_src.dev_source); - string_of_int (List.length Flan.Session.externs); - string_of_int (Flan.Render.max_span); - string_of_int (String.length (Flan.Wire.ints [ 1; 2 ])) ] - -let () = - Callback.register "spike_compile" (fun (file : string) -> - match compile file with - | d, n -> Printf.sprintf "%s: %d decls, %d bytes of LLVM IR" file d n - | exception e -> Printf.sprintf "FAILED: %s" (Printexc.to_string e)); - Callback.register "spike_footprint" footprint; - (* Dev.start and Cimport are never run here, but naming them keeps the socket - server and the C importer in the link -- a dev build pays for them. *) - Callback.register "spike_unused" (fun () -> - ignore (Flan.Dev.start : ?debug:bool -> file:string -> sock:string -> unit -> unit); - ignore (Flan.Cimport.decl_source : Flan.Ast.decl -> string); - "ok") diff --git a/spike/generics/id.flan b/spike/generics/id.flan deleted file mode 100644 index 4e029682..00000000 --- a/spike/generics/id.flan +++ /dev/null @@ -1,7 +0,0 @@ -(defn id [x $t] t x) - -(defn main [] () - (println (id 3)) - (println (id 4.5)) - (println (id 7)) - (println (id true))) diff --git a/spike/generics/measure.ml b/spike/generics/measure.ml deleted file mode 100644 index 457795a5..00000000 --- a/spike/generics/measure.ml +++ /dev/null @@ -1,171 +0,0 @@ -(* What redefining a generic function costs the dev loop, measured. - - The question the spike exists to answer: C-c C-c on a concrete function is - about 35 ms today, and a generic function that is redefined has to rebuild - *every* instantiation. So the sweep is one generic called at N concrete - types, N = 1..8, against the handwritten N-copies program it replaces, and - the three things a C-c C-c actually pays for are timed separately: - - check Check.program_with_env over the whole accumulated program — - which is what Session.eval does on every evaluation, so this is - paid whether the redefined function is generic or not. - emit Emit.redefinition for the fns being installed. - build llc + ld -shared, from Build.shared — the dominant term. - - Nothing here modifies the session or the dev loop; it drives the real ones. *) - -let tys = [| "i8"; "i16"; "i32"; "i64"; "u8"; "u16"; "u32"; "f32" |] - -let time f = - let t0 = Unix.gettimeofday () in - let x = f () in - (x, (Unix.gettimeofday () -. t0) *. 1000.) - -(* Best of k, because llc and the linker are processes and the machine is - noisy; a median would hide a systematic cost and a mean would report the - scheduler. *) -let best k f = - let rec go i acc = if i = 0 then acc else - let _, ms = time f in go (i - 1) (min acc ms) in - go k infinity - -let generic_src n = - let b = Buffer.create 1024 in - Buffer.add_string b - "(defn gswap [xs [$t] i i32 j i32] ()\n\ - \ (let [tmp (at xs i)]\n\ - \ (set (at xs i) (at xs j))\n\ - \ (set (at xs j) tmp)))\n\n\ - (defn gsort [s [$t] before? (Fn [$t $t] bool)] ()\n\ - \ (let [i 1]\n\ - \ (while (< i (length s))\n\ - \ (let [j i]\n\ - \ (while (and (> j 0) (before? (at s j) (at s (- j 1))))\n\ - \ (gswap s (- j 1) j)\n\ - \ (set j (- j 1))))\n\ - \ (set i (+ i 1)))))\n\n"; - for i = 0 to n - 1 do - Buffer.add_string b (Printf.sprintf "(defonce xs-%s [8 %s])\n" tys.(i) tys.(i)) - done; - Buffer.add_string b "\n(defn main [] ()\n"; - for i = 0 to n - 1 do - Buffer.add_string b - (Printf.sprintf " (gsort (slice xs-%s 0 8) (fn [a b] (< a b)))\n" tys.(i)) - done; - Buffer.add_string b " )\n"; - Buffer.contents b - -(* The same program as it is written today: one copy of each function per - element type, by hand. This is prelude.ml's shape. *) -let mono_src n = - let b = Buffer.create 1024 in - for i = 0 to n - 1 do - let t = tys.(i) in - Buffer.add_string b - (Printf.sprintf - "(defn mswap-%s [xs [%s] i i32 j i32] ()\n\ - \ (let [tmp (at xs i)]\n\ - \ (set (at xs i) (at xs j))\n\ - \ (set (at xs j) tmp)))\n\n\ - (defn msort-%s [s [%s] before? (Fn [%s %s] bool)] ()\n\ - \ (let [i 1]\n\ - \ (while (< i (length s))\n\ - \ (let [j i]\n\ - \ (while (and (> j 0) (before? (at s j) (at s (- j 1))))\n\ - \ (mswap-%s s (- j 1) j)\n\ - \ (set j (- j 1))))\n\ - \ (set i (+ i 1)))))\n\n" - t t t t t t t); - Buffer.add_string b (Printf.sprintf "(defonce xs-%s [8 %s])\n\n" t t) - done; - Buffer.add_string b "(defn main [] ()\n"; - for i = 0 to n - 1 do - Buffer.add_string b - (Printf.sprintf " (msort-%s (slice xs-%s 0 8) (fn [a b] (< a b)))\n" - tys.(i) tys.(i)) - done; - Buffer.add_string b " )\n"; - Buffer.contents b - -let write path s = - let oc = open_out path in output_string oc s; close_out oc - -let dir = - let d = Filename.concat (Filename.get_temp_dir_name ()) "flan-generics-spike" in - (try Unix.mkdir d 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()); - d - -let decls_of path = - (Flan.Load.program ~file:path - (Flan.Parse.program (Flan.Reader.read_file path))).Flan.Load.decls - -(* Every function the program ended up with whose name starts with one of the - generic names — the instantiations, which is exactly what a redefinition of - the generic would have to rebuild. *) -let instantiations (p : Flan.Tast.program) = - List.filter_map - (fun (f : Flan.Tast.fn) -> - let n = f.Flan.Tast.name in - if String.length n > 6 && String.sub n 0 6 = "gswap-" then Some n - else if String.length n > 6 && String.sub n 0 6 = "gsort-" then Some n - else None) - p.Flan.Tast.fns - -let build_ms ir = - let out = Filename.concat dir "redef.so" in - best 3 (fun () -> - ignore - (Flan.Build.shared - ~opts:{ Flan.Build.default with dev = true } ~ir ~out ())) - -let () = - Printf.printf - "n check-gen check-mono emit-1 emit-N build-1 build-N fns\n"; - (try - for n = 1 to 8 do - let gpath = Filename.concat dir (Printf.sprintf "gen%d.flan" n) in - let mpath = Filename.concat dir (Printf.sprintf "mono%d.flan" n) in - write gpath (generic_src n); - write mpath (mono_src n); - let gd = decls_of gpath and md = decls_of mpath in - let check_gen = best 3 (fun () -> ignore (Flan.Check.program_with_env gd)) in - let check_mono = best 3 (fun () -> ignore (Flan.Check.program_with_env md)) in - let p, _ = Flan.Check.program_with_env gd in - let insts = instantiations p in - let one = [ List.hd insts ] in - let ir_one = - Flan.Emit.redefinition ~dev:true ~known:(fun _ -> true) p ~fns:one - in - let ir_all = - Flan.Emit.redefinition ~dev:true ~known:(fun _ -> true) p ~fns:insts - in - let emit1 = - best 3 (fun () -> - ignore (Flan.Emit.redefinition ~dev:true ~known:(fun _ -> true) p ~fns:one)) - and emitn = - best 3 (fun () -> - ignore (Flan.Emit.redefinition ~dev:true ~known:(fun _ -> true) p ~fns:insts)) - in - let b1 = build_ms ir_one and bn = build_ms ir_all in - Printf.printf "%d %8.1f %10.1f %7.1f %7.1f %8.1f %8.1f %d\n%!" - n check_gen check_mono emit1 emitn b1 bn (List.length insts) - done - with Flan.Loc.Error d -> prerr_endline (Flan.Loc.report d); exit 1); - (* And what the session actually does when the generic itself is redefined. - This is the real C-c C-c path — Session.eval on the form the editor sent - — and what it reports is the finding, not the timing. *) - let gpath = Filename.concat dir "gen4.flan" in - let t, _ = Flan.Session.create ~file:gpath () in - let form = - "(defn gswap [xs [$t] i i32 j i32] ()\n\ - \ (let [tmp (at xs i)]\n\ - \ (set (at xs i) (at xs j))\n\ - \ (set (at xs j) tmp)))\n" - in - let c, ms = time (fun () -> Flan.Session.eval ~origin:gpath t form) in - Printf.printf - "\nSession.eval on the generic gswap itself: %.1f ms, installs=%b, \ - fns=[%s], names=[%s]\n" - ms c.Flan.Session.installs - (String.concat " " c.Flan.Session.fns) - (String.concat " " c.Flan.Session.names) diff --git a/spike/generics/prelude-shapes.flan b/spike/generics/prelude-shapes.flan deleted file mode 100644 index 519a737a..00000000 --- a/spike/generics/prelude-shapes.flan +++ /dev/null @@ -1,51 +0,0 @@ -;; Which of prelude.ml's per-type families collapse as they are written, and -;; which need their signature changed. Nothing here is installed in the -;; prelude; it is the same bodies, over $t, checked and run. - -(defn keep [s [$t] keep? (Fn [$t] bool)] (Vec $t) - (let [v (vec-new t)] - (dotimes [i (length s)] - (when (keep? (at s i)) - (push v (at s i)))) - v)) - -(defn apply! [s [$t] f (Fn [$t] $t)] () - (dotimes [i (length s)] - (set (at s i) (f (at s i))))) - -(defn fold [s [$t] init $t f (Fn [$t $t] $t)] t - (let [acc init] - (dotimes [i (length s)] - (set acc (f acc (at s i)))) - acc)) - -(defn flip! [s [$t]] () - (let [i 0 - j (- (length s) 1)] - (while (< i j) - (let [tmp (at s i)] - (set (at s i) (at s j)) - (set (at s j) tmp)) - (set i (+ i 1)) - (set j (- j 1))))) - -(defonce ns [5 i32]) -(defonce fs [5 f32]) - -(defn main [] () - (let [xs (slice ns 0 5) - ys (slice fs 0 5)] - (dotimes [i 5] - (set (at xs i) (+ i 1)) - (set (at ys i) (f32 (* 2 (+ i 1))))) - (apply! xs (fn [x] (* x 10))) - (apply! ys (fn [x] (* x (f32 2)))) - (flip! xs) - (flip! ys) - (println (fold xs 0 (fn [a b] (+ a b)))) - (println (fold ys (f32 0) (fn [a b] (+ a b)))) - (let [evens (keep xs (fn [x] (= (% x 20) 0)))] - (println (length evens)) - (free evens)) - (println (at xs 0)) - (println (at ys 0)))) diff --git a/spike/generics/reject.flan b/spike/generics/reject.flan deleted file mode 100644 index 8aeb7f96..00000000 --- a/spike/generics/reject.flan +++ /dev/null @@ -1,4 +0,0 @@ -(defn add2 [a $t b $t] t (+ a b)) - -(defn main [] () - (println (add2 1 2))) diff --git a/spike/generics/run.sh b/spike/generics/run.sh deleted file mode 100644 index 7771e36b..00000000 --- a/spike/generics/run.sh +++ /dev/null @@ -1,28 +0,0 @@ -#!/usr/bin/env bash -# The generics spike's measurement, driven by hand with ocamlfind against the -# flan.cmxa dune already builds — the same arrangement spike/backend uses, and -# for the same reason: nothing under spike/ is wired into the build, there is -# no dune file here, and `dune test --root .` cannot see any of it. -# -# The three .flan programs beside this file are run with the ordinary driver: -# dune exec --root . bin/main.exe -- run spike/generics/sort.flan -set -u -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -cd "$root" || exit 1 - -dune build --root . lib/flan.cmxa 2>&1 | head -20 - -out=$(mktemp -d); trap 'rm -rf "$out"' EXIT - -ocamlfind ocamlopt -thread -package unix,threads.posix -linkpkg \ - -I "$root/_build/default/lib/.flan.objs/byte" \ - -I "$root/_build/default/lib/.flan.objs/native" \ - -I "$out" -I "$here" \ - -o "$out/measure" \ - "$root/_build/default/lib/flan.cmxa" \ - -cclib -rdynamic -ccopt -L"$root/_build/default/lib" \ - "$here/measure.ml" 2>&1 | head -40 - -test -x "$out/measure" || { echo "build failed"; exit 1; } -"$out/measure" diff --git a/spike/generics/runaway.flan b/spike/generics/runaway.flan deleted file mode 100644 index 9423840a..00000000 --- a/spike/generics/runaway.flan +++ /dev/null @@ -1,3 +0,0 @@ -(defn grow [x $t] () - (grow [x x])) -(defn main [] () (grow 1)) diff --git a/spike/generics/sort.flan b/spike/generics/sort.flan deleted file mode 100644 index 632ed1bb..00000000 --- a/spike/generics/sort.flan +++ /dev/null @@ -1,25 +0,0 @@ -;; The shape prelude.ml's sort-i32-by! / sort-f32-by! pair would collapse into: -;; one generic body, the comparison passed in as a function value because an -;; unconstrained type variable has no < of its own. - -(defn swap! [xs [$t] i i32 j i32] () - (let [tmp (at xs i)] - (set (at xs i) (at xs j)) - (set (at xs j) tmp))) - -(defn sort-by! [s [$t] before? (Fn [$t $t] bool)] () - (let [i 1] - (while (< i (length s)) - (let [j i] - (while (and (> j 0) (before? (at s j) (at s (- j 1)))) - (swap! s (- j 1) j) - (set j (- j 1)))) - (set i (+ i 1))))) - -(defn main [] () - (let [ns [5 3 9 1] - fs [2.5 0.5 1.5]] - (sort-by! (slice ns 0 4) (fn [a b] (< a b))) - (sort-by! (slice fs 0 3) (fn [a b] (> a b))) - (dotimes [i 4] (println (at ns i))) - (dotimes [i 3] (println (at fs i))))) diff --git a/spike/generics/swap.flan b/spike/generics/swap.flan deleted file mode 100644 index 8d69ae4b..00000000 --- a/spike/generics/swap.flan +++ /dev/null @@ -1,19 +0,0 @@ -;; One generic function over one type variable, called at two concrete types -;; in one program. The sigil binds ($t), a bare use reads it (t). - -(defn swap! [xs [$t] i i32 j i32] () - (let [tmp (at xs i)] - (set (at xs i) (at xs j)) - (set (at xs j) tmp))) - -(defn main [] () - (let [ns [10 20 30] - fs [1.5 2.5 3.5]] - (swap! (slice ns 0 3) 0 2) - (swap! (slice fs 0 3) 0 1) - (swap! (slice ns 0 3) 1 2) - (println (at ns 0)) - (println (at ns 1)) - (println (at ns 2)) - (println (at fs 0)) - (println (at fs 1)))) diff --git a/spike/generics/two-vars.flan b/spike/generics/two-vars.flan deleted file mode 100644 index fe3b300a..00000000 --- a/spike/generics/two-vars.flan +++ /dev/null @@ -1,5 +0,0 @@ -(defn fst [a $t b $u] t a) -(defn main [] () - (println (fst 1 2.5)) - (println (fst true (i64 9))) - (println (fst 3 false))) diff --git a/spike/x86/COST.md b/spike/x86/COST.md deleted file mode 100644 index 1500e62e..00000000 --- a/spike/x86/COST.md +++ /dev/null @@ -1,210 +0,0 @@ -# What the hand-written x86-64 backend costs - -`survey.sh` has said for three handoffs that this backend agrees with LLVM on all 97 corpus programs it can build. -Item 7 of `docs/handoffs/HANDOFF-x86-rt.md` is the other half of that sentence — nobody had a number for what the agreement -costs — and it came with a list of suspects: a guard after every call, three frame temporaries per bounds check, -every intermediate in memory, `rep movsb` block copies, and an extra load per call site in a dev build. This is -the measurement. It does not change anything; two of the five suspects turn out not to matter, and the one that -matters most is not on the list. - -Produced by `spike/x86/cost.sh` (the corpus, for size) and `spike/x86/bench.sh` (four purpose-written programs, -for speed). Both are documented in their own headers. Machine: 16-core x86-64, Fedora, clang as the assembler and -linker on both sides, and other work running on it throughout — which is why every time below is the *minimum* of -five or seven runs and why nothing here rests on a difference of a few percent. - -The rows behind the tables are committed beside this file as `cost-corpus.tsv` and `cost-bench.tsv`, so a later -lane can recompute a ratio rather than believe one. - -## What is being compared, and against what - -The interesting column is not the size of the executable. A Flan binary is mostly `flan_rt.o` and libc glue, the -same object on both sides, and it drowns the signal: over the corpus the whole file is only **1.09×** bigger -through this backend and `.text` only **1.18×**, which would be a reassuring number and a meaningless one. - -So the measurement is the sum of the sizes of the defined symbols the compiler *named itself* — everything called -`flan.`. The runtime's C is `flan_` with an underscore, so the two never collide, and a -runtime symbol has the same size on both sides (`flan_map_clone`, `0x4b3` either way), which is the check that -says the difference really is codegen and not a differently-linked runtime. - -There is a third column, and it is what makes the second readable: **LLVM with `--debug`, which forces `-O0`**. -This backend has no optimiser at all, so measuring it against LLVM at `-O2` charges it for the whole of mem2reg, -inlining and constant folding. `-O0` is LLVM's instruction selection with none of that, which is the comparison -that says something about *this* backend rather than about the absence of a middle end. (`--x86 --debug` is -refused — the backend emits no DWARF — so the column exists on one side only. DWARF lands in `.debug_*` sections -and not in `.text`, checked, so it does not contaminate the symbol sums.) - -## The corpus: size - -Ninety-seven programs — the same set `survey.sh` matches on, minus the two that run forever. Summed over all of -them: - -| | LLVM -O2 | LLVM -O0 | x86 | -|---|---|---|---| -| own code, all 97 programs | 221,608 | 444,504 | 851,638 | -| against LLVM -O2 | 1.00× | 2.01× | **3.84×** | -| against LLVM -O0 | | 1.00× | **1.92×** | - -So the headline is two numbers, not one. **This backend emits 3.8× the code LLVM does at `-O2`, and half of that -factor is the optimiser Flan ships with rather than anything about the backend; against LLVM with the optimiser -off it is 1.9×.** Per program the second ratio is tight — median 2.21, quartiles 1.94 and 2.98, the whole range -1.32 to 5.44 — which is itself a finding: the cost is not a few bad nodes, it is a constant tax on everything. - -The ten largest programs, which are where the bytes actually are: - -| program | LLVM -O2 | LLVM -O0 | x86 | x86 / -O2 | x86 / -O0 | -|---|---|---|---|---|---| -| `strings` | 13,395 | 22,681 | 33,265 | 2.48× | 1.47× | -| `maps` | 12,833 | 19,850 | 40,445 | 3.15× | 2.04× | -| `edn` | 12,057 | 34,556 | 48,532 | 4.03× | 1.40× | -| `generics` | 10,137 | 20,427 | 39,241 | 3.87× | 1.92× | -| `slurp` | 9,744 | 14,813 | 24,656 | 2.53× | 1.66× | -| `into` | 8,277 | 12,345 | 21,320 | 2.58× | 1.73× | -| `vec` | 8,039 | 12,089 | 22,770 | 2.83× | 1.88× | -| `map-iter` | 7,211 | 10,374 | 21,715 | 3.01× | 2.09× | -| `algorithms` | 6,776 | 16,616 | 30,875 | 4.56× | 1.86× | -| `slices` | 2,393 | 9,057 | 17,753 | 7.42× | 1.96× | - -And the two ends of the distribution, both of which are more interesting than the middle: - -| program | LLVM -O2 | LLVM -O0 | x86 | x86 / -O2 | x86 / -O0 | why | -|---|---|---|---|---|---|---| -| `bounds` | 363 | 1,951 | 4,039 | **11.13×** | 2.07× | LLVM at `-O2` proves the indices and deletes the checks | -| `array-ctor` | 357 | 1,840 | 3,880 | 10.87× | 2.11× | the same, over a constructor's worth of stores | -| `p2-loop-print` | 283 | 106 | 577 | 2.04× | **5.44×** | a `-O0` build *smaller* than `-O2`: LLVM unrolls the five-iteration loop and `-O0` does not | -| `pkg-return` | 7,024 | 23,635 | 31,716 | 4.52× | 1.34× | mostly prelude, where `-O0` is already fat | - -`bounds` is the clearest case in the table of why the `-O0` column had to exist. Eleven times is a shocking -number and it is not about this backend at all: the program's whole point is indexing, LLVM at `-O2` can see the -indices are in range and removes the check, and neither LLVM at `-O0` nor this backend can. Against the compiler -that also keeps every check, `bounds` is 2.07× — a completely ordinary row. - -## Where the size goes - -Every one of these is from the disassembly of the benchmark programs, which are small enough to read whole. - -**Every intermediate goes through the frame, and so does every constant.** This is the big one and it is not one -feature, it is the shape of the whole backend. `(step acc 1)` in `b1-calls` compiles to: - - movabs $0x1,%rax ; a 10-byte immediate ... - mov %rax,-0x30(%rbp) ; ... stored to a frame slot ... - mov -0x30(%rbp),%rsi ; ... and loaded back into the argument register - -Three instructions and 24 bytes where LLVM writes `mov $1,%esi`, five. The loop bound gets the same treatment -*every iteration* — `movabs $0x1312d00` into a slot, sign-extended out of it, compared — because nothing is -hoisted. So does the loop condition: `cmp`/`setl`/`movzbq`/store a byte to the frame/reload it/`test`/`jne`, -seven instructions for what is `cmp`/`jge` anywhere else. This is most of the 2× against `-O0` and essentially -all of the difference on the programs at the bottom of the table, which have no calls, no bounds checks and no -aggregates in them at all. - -**The guard after every call is four instructions and one dependent load.** - - call 4009f8 - mov -0x18(%rbp),%r11 ; the condition frame, from its own slot - mov 0x0(%r11),%r11 ; ... dereferenced - test %r11,%r11 - jne - -Roughly 25 bytes per call site. Real, cheap, and third in size behind the two above it — on a program that is -nothing *but* calls (`b1`) the whole backend is 2.8× LLVM `-O0`, and the guard is a minority of that. - -**The bounds check is three frame temporaries, as suspected, and it costs code and not time.** The index is -widened, stored, reloaded, stored again, the limit goes to a third slot, and then `cmp`/`jb` — with the failure -path, its `.rodata` location string and its length, inline at the branch target. On `b2-bounds`, `flan.main` is -`0x4b1` with checks and `0x3c0` without: **241 bytes, a quarter of the function.** In time it is 112.6ms against -105.0ms over 20.5 million checked loads — **about 0.4ns, a cycle or two a check** — because the branch predicts -perfectly and the loads were going to memory anyway. That contradicts the way the handoff's list reads. The three -temporaries are a code-size item. They are not a speed item. - -**`rep movsb` is real and it is the most expensive single instruction here.** A 64-byte struct copy lowers to -`lea`/`lea`/`movabs $0x40,%rcx`/`rep movsb`, and `b4-copy` runs 2 million of them in 20.8ms against LLVM `-O0`'s -7.2ms: **about 6.8ns of the difference per copy, some twenty cycles**, which is `rep movsb`'s startup cost and -almost none of it the 64 bytes. It is also the one place where the backend loses to `-O0` by a factor (2.9×) it -does not lose by on straight-line code, and the one item on the suspect list where a targeted fix — inline -16-byte moves under some size threshold — would pay for itself. - -## The corpus: speed, and why there is barely any - -Almost nothing. **Every program in `test/programs` runs in about 2.5 milliseconds, nearly all of it `execve` and -the dynamic loader**, and both backends produce the same 2.5 milliseconds. Best-of-five does not rescue a signal -that is not there. There is exactly one corpus program whose own code is a measurable part of its runtime, and it -is the right one: - -| program | LLVM -O2 | LLVM -O0 | x86 | what it is | -|---|---|---|---|---| -| `recur` | ~1ms | 10ms | 60ms | a ten-million-iteration counting loop, written to prove `recur` is a jump | - -Read that carefully, because the 25× against `-O2` is not a fact about this backend: LLVM folds the loop to its -answer and runs nothing. Against `-O0`, which also runs ten million iterations, it is **6×** — about 6ns an -iteration against 1ns, or roughly eighteen cycles for `i+1` and a compare. That is the frame-slot round trip -above, four or five times over, and it is the honest number. - -## The benchmarks - -Four programs in `spike/x86/bench/`, each written so that one suspected cost is most of what the program does. -They are in a subdirectory on purpose: `survey.sh` globs `spike/x86/*.flan` and a benchmark is not a case. -Times are best-of-seven, in milliseconds. - -| bench | what it is | LLVM -O2 | LLVM -O0 | x86 | x86 / -O0 | own code, -O0 → x86 | -|---|---|---|---|---|---|---| -| `b1-calls` | 20M calls of a one-instruction function | 2.1 | 36.8 | 104.3 | 2.8× | 200 → 807 | -| `b2-bounds` | 20.5M bounds-checked array loads | 4.7 | 27.0 | 112.6 | 4.2× | 407 → 1390 | -| `b3-spill` | 5M iterations of a six-deep arithmetic tree | 22.2 | 29.0 | 137.3 | 4.7× | 248 → 1117 | -| `b4-copy` | 2M copies of a 64-byte struct | 2.0 | 7.2 | 20.8 | 2.9× | 348 → 877 | - -`b2` with `--no-bounds-checks` on both sides: LLVM 4.5ms, x86 105.0ms — the 7.6ms the check costs over 20.5 -million of them, and the 241 bytes it costs in `flan.main`, are the whole of it. - -`b3`'s ratio is the one to distrust slightly: its expression ends in a `%`, which is an `idiv`, and an `idiv` is -twenty-odd cycles on every side. That is most of LLVM's own 22.2ms and a good part of its 29.0ms, so the -denominator is largely a hardware latency this backend cannot do anything about. The absolute gap — 108ms over -5 million iterations, about 21ns of extra work each — is the honest reading of that row. - - - -`b1-calls` and `b3-spill` are the pair to read together, with the `idiv` caveat above in mind. `b1` is 20 million -calls of a one-instruction function and lands at 2.8× `-O0`; `b3` has no calls at all and pays 21ns an iteration -for six dependent arithmetic temporaries. **The backend is worse at arithmetic than it is at calling**, which is -the opposite of what the suspect list implies, and it is because a call already costs enough that four extra -instructions beside it disappear, while an add that should be one instruction costs five. `recur`, which is a -counting loop and nothing else, says the same thing on a corpus program: 6× LLVM `-O0`. - -The `-O2` column in `b1` and `b4` is 2ms — the loop is gone. That is a true fact about the toolchain Flan ships -and a useless one about code generation, which is the whole reason the `-O0` column exists. - -## `--dev`, which is the one axis both backends pay - -`SURVEY_FLAGS=--dev` reported 97 MATCH for the lane before this one, so the comparison is available. The suspected cost was the extra -load per call site — every cross-function call going through its indirection cell. **It is not measurable.** On -`b1-calls`, 20 million calls, x86 release is 104.3ms and x86 `--dev` is 100.9ms: the same number, and the dev -build is nominally the *faster* of the two, which is what a difference below the noise floor looks like. The load -is from a `.data` cell that is in L1 after the first call and the machine was already waiting on the frame. - -What a dev build actually costs is something else entirely, and both backends pay it. `b1-calls` is a program -with two functions in it: - -| build | own code | -|---|---| -| LLVM, release | 82 bytes | -| x86, release | 807 bytes | -| LLVM, `--dev` | 32,714 bytes | -| x86, `--dev` | 83,018 bytes | - -**A dev build emits the entire prelude**, because anything might be redefined and so nothing may be dropped. That -is four hundred times the code for this program, and it dwarfs every item on the suspect list put together. It is -also not a backend cost — LLVM pays a 400× of its own — so it is `Reach`'s business and not `x86.ml`'s. The -backend's share of it is the same ~2.5× it charges everywhere else. - -## What this says to the lane rewriting `lib/x86.ml` - -Ranked by what the numbers actually support, and not by the order of the list in the handoff: - -1. **Keep values in registers across a single expression.** Not a register allocator — just not routing every - constant and every subexpression through a frame slot, and not re-materialising a loop bound every iteration. - This is most of the 2× against `-O0` and most of `recur`'s 6×, and it is what `b3`'s 21ns an iteration buys. -2. **Inline small aggregate copies** instead of `rep movsb`. One instruction, twenty cycles, on a copy that is - four `movdqu` pairs. -3. **`flan_dev_reg_note` in a release build** (item 2 of the old handoff's list) is worth doing and is small. -4. **The call guard is fine.** Four instructions and 25 bytes, invisible in time. Leave it. -5. **The bounds check is fine on time and fat on code.** If it is ever worth touching, it is worth touching for - the 241 bytes — hoisting the failure path out of line would get most of that back without changing a cycle. -6. **The dev call cell is free.** Whatever the redefinition emitter costs, it does not cost this. diff --git a/spike/x86/annot.sh b/spike/x86/annot.sh deleted file mode 100755 index cb5991c6..00000000 --- a/spike/x86/annot.sh +++ /dev/null @@ -1,101 +0,0 @@ -#!/usr/bin/env bash -# Does annotation change a single byte of what the backend emits? -# -# `flan emit --x86` annotates: a comment per Flan form, a frame map per -# function, and a name for each piece of bookkeeping the compiler adds. All of -# that is comments, plus the splitting of one long `.byte` directive into -# several. Both are supposed to be invisible to the assembler -- and "supposed -# to be" is exactly the kind of claim this repo measures rather than asserts, -# because the whole licence for annotating at all is that the bytes are the -# bytes. -# -# So: emit every program in the corpus both ways, assemble both, and compare -# each section of the two objects byte for byte. No linking and no running -- -# survey.sh is what says the programs still behave, and this says nothing they -# are built from moved. -# -# Three settings, because they are three different emitters. The default; --dev, -# which adds the indirection cells and the ABI marker; and --debug, which adds -# the line table, the labels its rows hang off, and the CFI directives. The -# debug case is the sharp one: a `.debug_line` row is an address expressed as a -# label, and annotation emits no labels precisely so that those cannot move. -# -# Usage: spike/x86/annot.sh [name-substring ...] -set -u -orig=$(pwd) -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -cd "$root" || exit 1 - -if [ -n "${FLAN:-}" ]; then - case $FLAN in /*) flan=$FLAN;; *) flan=$orig/$FLAN;; esac -else - dune build --root . bin/main.exe 2>&1 | head -30 - flan=$root/_build/default/bin/main.exe -fi -test -x "$flan" || { echo "build failed"; exit 1; } - -corpus=${SURVEY_CORPUS:-$root} -tmp=$(mktemp -d "${TMPDIR:-/tmp}/flan-annot.XXXXXX") -trap 'rm -rf "$tmp"' EXIT - -same=0; differ=0; skip=0 - -# Every section either object has, not a fixed list: a section that exists on -# one side and not the other is itself a difference, and comparing a named list -# would miss one that annotation invented. -sections () { - objdump -h "$1" | awk '$1 ~ /^[0-9]+$/ { print $2 }' -} - -check () { - src=$1; shift - name=$(basename "$src" .flan) - tag="$name${*:+ $*}" - a=$tmp/a.s; b=$tmp/b.s - - if ! "$flan" emit --x86 "$@" "$src" > "$a" 2>"$tmp/err"; then - skip=$((skip + 1)); echo "SKIP $tag"; return - fi - if ! "$flan" emit --x86 --no-annotate "$@" "$src" > "$b" 2>/dev/null; then - skip=$((skip + 1)); echo "SKIP $tag"; return - fi - if ! as --64 -o "$tmp/a.o" "$a" 2>"$tmp/err"; then - differ=$((differ + 1)) - echo "BADASM $tag -- the annotated listing does not assemble" - head -3 "$tmp/err"; return - fi - if ! as --64 -o "$tmp/b.o" "$b" 2>/dev/null; then - skip=$((skip + 1)); echo "SKIP $tag"; return - fi - - bad= - for sec in $(sections "$tmp/a.o"; sections "$tmp/b.o"); do - case " $bad " in *" $sec "*) continue;; esac - objcopy -O binary --only-section="$sec" "$tmp/a.o" "$tmp/a.bin" 2>/dev/null - objcopy -O binary --only-section="$sec" "$tmp/b.o" "$tmp/b.bin" 2>/dev/null - cmp -s "$tmp/a.bin" "$tmp/b.bin" || bad="$bad $sec" - done - - if [ -z "$bad" ]; then - same=$((same + 1)); echo "SAME $tag" - else - differ=$((differ + 1)); echo "DIFFER $tag --$bad" - fi -} - -for src in "$corpus"/test/programs/*.flan "$corpus"/spike/x86/*.flan; do - [ -f "$src" ] || continue - if [ $# -gt 0 ]; then - hit= - for pat in "$@"; do case $src in *"$pat"*) hit=1;; esac; done - [ -n "$hit" ] || continue - fi - check "$src" - check "$src" --dev - check "$src" --debug -done - -echo -echo "$same SAME / $differ DIFFER / $skip SKIP" -[ "$differ" -eq 0 ] diff --git a/spike/x86/bench.sh b/spike/x86/bench.sh deleted file mode 100755 index 0899f150..00000000 --- a/spike/x86/bench.sh +++ /dev/null @@ -1,86 +0,0 @@ -#!/usr/bin/env bash -# The speed half of cost.sh, on programs that are long enough to time. -# -# Why this exists beside cost.sh rather than inside it: every program in -# test/programs runs in about two and a half milliseconds, of which nearly -# all is fork, exec and the dynamic loader. Best-of-five does not rescue a -# signal that is not there, and a table of 97 rows that all say "2.5ms vs -# 2.6ms" would be a measurement of execve. So the corpus answers the size -# question and these four answer the speed one, each written so that one -# suspected cost is most of what the program does. -# -# Four builds of each, and the third column is the one to read: -# -# llvm as shipped, -O2. Frequently the loop is simply gone; that is a -# true number about the toolchain and a useless one about codegen. -# llvm -O0 via --debug, which forces it. LLVM's instruction selection with -# its optimiser off -- the fair comparison for a backend that has -# no optimiser. -# x86 this backend. -# x86 nbc --no-bounds-checks, for b2, where the difference is the check. -# -# And --dev on both sides, which is the one suspected cost the two backends -# share: every cross-function call goes through an indirection cell, so it is -# a load and an indirect call where a release build has a direct one. b1 is -# where that has to show. -# -# Usage: spike/x86/bench.sh [name-substring ...] -set -u -orig=$(pwd) -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -cd "$root" || exit 1 - -if [ -n "${FLAN:-}" ]; then - case $FLAN in /*) flan=$FLAN;; *) flan=$orig/$FLAN;; esac -else - dune build --root . bin/main.exe 2>&1 | head -30 - flan=$root/_build/default/bin/main.exe -fi -test -x "$flan" || { echo "build failed" >&2; exit 1; } - -out=${COST_OUT:-${TMPDIR:-/tmp}/flan-bench.$$} -mkdir -p "$out" || exit 1 -trap 'rm -rf "$out"' EXIT - -REPS=${COST_REPS:-5} - -best () { - min= - for i in $(seq "$REPS"); do - t0=$(date +%s%N) - timeout 120 "$1" >/dev/null 2>&1 /dev/null \ - | awk 'NF==4 && ($3=="T"||$3=="t") && $4 ~ /^flan\./ {n+=strtonum("0x"$2)} END{print n+0}' -} - -printf 'name\tllvm_us\to0_us\tx86_us\tllvm_nbc_us\tx86_nbc_us\tllvm_dev_us\tx86_dev_us\tllvm_own\to0_own\tx86_own\tx86_dev_own\n' - -for src in "$root"/spike/x86/bench/*.flan; do - name=$(basename "$src" .flan) - if [ $# -gt 0 ]; then - want=0 - for pat in "$@"; do case "$name" in *"$pat"*) want=1;; esac; done - [ $want = 1 ] || continue - fi - "$flan" build "$src" -o "$out/l" >/dev/null 2>&1 || { echo "$name: llvm build failed" >&2; continue; } - "$flan" build "$src" --debug -o "$out/d" >/dev/null 2>&1 || { echo "$name: -O0 build failed" >&2; continue; } - "$flan" build "$src" --x86 -o "$out/x" >/dev/null 2>&1 || { echo "$name: x86 build failed" >&2; continue; } - "$flan" build "$src" --no-bounds-checks -o "$out/ln" >/dev/null 2>&1 - "$flan" build "$src" --x86 --no-bounds-checks -o "$out/xn" >/dev/null 2>&1 - "$flan" build "$src" --dev -o "$out/lv" >/dev/null 2>&1 - "$flan" build "$src" --x86 --dev -o "$out/xv" >/dev/null 2>&1 - printf '%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\n' "$name" \ - "$(best "$out/l")" "$(best "$out/d")" "$(best "$out/x")" \ - "$(best "$out/ln")" "$(best "$out/xn")" \ - "$(best "$out/lv")" "$(best "$out/xv")" \ - "$(own "$out/l")" "$(own "$out/d")" "$(own "$out/x")" "$(own "$out/xv")" -done diff --git a/spike/x86/bench/b1-calls.flan b/spike/x86/bench/b1-calls.flan deleted file mode 100644 index 2cf2f50c..00000000 --- a/spike/x86/bench/b1-calls.flan +++ /dev/null @@ -1,20 +0,0 @@ -;;;; A hot loop that does nothing but call. -;;;; -;;;; The suspected cost is the guard this backend emits after every call -- -;;;; and, in a dev build, the load of the indirection cell before it. Neither -;;;; is visible in the corpus, where a program's whole run is process startup. -;;;; Here the call is the program: the body is one add, so whatever separates -;;;; this from LLVM at -O0 is the call sequence and not the arithmetic. -;;;; -;;;; Not in spike/x86 proper, where survey.sh would pick it up: the survey's -;;;; counts are quoted in three handoffs and a benchmark is not a case. - -(defn step [a i64 b i64] i64 - (+ a b)) - -(defn main [] i32 - (let [acc (i64 0)] - (dotimes [i 20000000] - (set acc (step acc 1))) - (print acc) (println "")) - 0) diff --git a/spike/x86/bench/b2-bounds.flan b/spike/x86/bench/b2-bounds.flan deleted file mode 100644 index 3df3841e..00000000 --- a/spike/x86/bench/b2-bounds.flan +++ /dev/null @@ -1,20 +0,0 @@ -;;;; A hot loop that does nothing but index a bounds-checked array. -;;;; -;;;; The suspected cost is three frame temporaries per check. This one has an -;;;; A/B that the others do not: --no-bounds-checks builds the same program -;;;; with the check gone, on both sides, so the difference between the two -;;;; x86 numbers is the check and nothing else, and the same difference on -;;;; the LLVM side says what the check costs when a compiler is allowed to -;;;; hoist it out of the loop. - -(defonce xs [1024 i32]) - -(defn main [] i32 - (dotimes [i 1024] - (set (at xs i) i)) - (let [acc (i64 0)] - (dotimes [r 20000] - (dotimes [i 1024] - (set acc (+ acc (i64 (at xs i)))))) - (print acc) (println "")) - 0) diff --git a/spike/x86/bench/b3-spill.flan b/spike/x86/bench/b3-spill.flan deleted file mode 100644 index d0bdd9fd..00000000 --- a/spike/x86/bench/b3-spill.flan +++ /dev/null @@ -1,21 +0,0 @@ -;;;; A hot loop of arithmetic and nothing else: no calls, no arrays, no -;;;; copies. -;;;; -;;;; The suspected cost is that every intermediate lives in a frame slot -- -;;;; this backend allocates no registers, so an expression tree becomes a -;;;; chain of stores and reloads. The tree here is deliberately deep and -;;;; entirely dependent, so a register allocator would keep all of it in -;;;; registers and this backend cannot keep any of it. - -(defn main [] i32 - (let [acc (i64 1)] - (dotimes [i 5000000] - (let [a (+ acc 3) - b (* a 2) - c (- b 1) - d (bit-xor c 7) - e (+ d (* a 5)) - f (- e (bit-and d 15))] - (set acc (+ (% f 1000003) 1)))) - (print acc) (println "")) - 0) diff --git a/spike/x86/bench/b4-copy.flan b/spike/x86/bench/b4-copy.flan deleted file mode 100644 index 200c2452..00000000 --- a/spike/x86/bench/b4-copy.flan +++ /dev/null @@ -1,20 +0,0 @@ -;;;; A hot loop of struct copies. -;;;; -;;;; The suspected cost is `rep movsb`: this backend copies an aggregate by -;;;; block-moving bytes, where LLVM either keeps the thing in registers or -;;;; emits a handful of wide moves. Eight i64 fields is 64 bytes -- big -;;;; enough that a copy is a real copy, small enough that `rep movsb` is -;;;; paying its setup cost on every one of them, which is the shape the -;;;; instruction is worst at. - -(defstruct Big [a i64 b i64 c i64 d i64 e i64 f i64 g i64 h i64]) - -(defn main [] i32 - (let [acc (i64 0) - v (Big {.a 1 .b 2 .c 3 .d 4 .e 5 .f 6 .g 7 .h 8})] - (dotimes [i 2000000] - (let [w v] - (set (.a v) (+ (.h w) 1)) - (set acc (+ acc (.a w))))) - (print acc) (println "")) - 0) diff --git a/spike/x86/cost-bench.tsv b/spike/x86/cost-bench.tsv deleted file mode 100644 index a231e38d..00000000 --- a/spike/x86/cost-bench.tsv +++ /dev/null @@ -1,5 +0,0 @@ -name llvm_us o0_us x86_us llvm_nbc_us x86_nbc_us llvm_dev_us x86_dev_us llvm_own o0_own x86_own x86_dev_own -b1-calls 2108 36764 104266 1959 103336 26827 100874 82 200 807 83018 -b2-bounds 4711 27047 112567 4548 104951 4663 111295 355 407 1390 83596 -b3-spill 22184 28982 137347 22772 132053 22659 132913 168 248 1117 83323 -b4-copy 2043 7170 20792 1980 19559 2058 18497 140 348 877 83083 diff --git a/spike/x86/cost-corpus.tsv b/spike/x86/cost-corpus.tsv deleted file mode 100644 index d8b36d4c..00000000 --- a/spike/x86/cost-corpus.tsv +++ /dev/null @@ -1,98 +0,0 @@ -name llvm_file llvm_text llvm_own o0_own x86_file x86_text x86_own llvm_us x86_us -agent-longname 82224 42002 79 134 82264 42450 519 -1 -1 -agent-queue 82352 42306 340 567 86488 43698 1747 2491 2546 -agent 82336 42434 454 798 86472 44162 2218 2609 2496 -algorithms 76680 39282 6776 16616 101296 63234 30875 2499 2605 -allocators 67760 33650 1297 1719 71896 37490 5130 3170 3034 -array-ctor 67784 32722 357 1840 71920 36242 3880 2442 2664 -bounds-condition 76416 37074 4641 6963 84648 45858 13493 2673 2469 -bounds 67720 32738 363 1951 71856 36418 4039 3194 2654 -break 82296 42754 819 1182 86432 44482 2549 -1 -1 -bytes2 72120 37010 4576 10893 88544 52018 19654 2573 2510 -cleanup 68176 33986 1583 2077 72312 36946 4583 2351 2402 -conditions 68064 33586 1212 1209 68104 35346 2984 2436 2513 -debug-permuted 67720 32610 261 410 67760 33794 1433 2479 2442 -debug 67720 32610 261 429 67760 33794 1433 2494 2494 -defer-let 67928 34018 1625 1784 72064 36754 4396 2548 2543 -destructure 67792 33650 1290 4577 80120 40946 8583 2534 2523 -dev-break-bounds 82440 42546 588 648 86576 43762 1830 -1 -1 -dev-break 82368 42418 459 715 86504 43682 1755 -1 -1 -dev-globals 82456 42162 206 534 86584 43538 1614 -1 -1 -dev-inspect 82408 42610 652 704 86544 43698 1765 -1 -1 -dev-locals 82336 42418 465 623 86472 43650 1721 -1 -1 -dev-noagent 67720 32434 83 109 67760 32866 507 3116 2939 -dev-pause 82336 42066 112 244 82376 42802 877 -1 -1 -dev-ptr 86632 43954 1970 2859 90768 47490 5543 -1 -1 -dev-repl 82336 42066 112 244 82376 42802 877 -1 -1 -dev-robust 82336 42066 112 244 82376 42802 877 -1 -1 -edn 91208 44706 12057 34556 124016 80898 48532 3218 3165 -embed 67800 33330 977 2461 71936 37906 5550 2440 2650 -enum-compare 67752 32562 201 581 67792 33970 1611 2607 2805 -enum-convert 67752 33202 830 1522 71888 37042 4675 2737 2512 -error 67744 32498 131 163 67784 32946 591 2614 2587 -exhausted-unhandled 67688 33090 749 1156 67728 34850 2491 2442 2591 -exhausted 76192 35778 3415 5139 80336 42674 10321 2409 2469 -fn-values 68296 34226 1745 5124 80632 43026 10672 2405 2406 -format 76032 36802 4413 7076 84264 45394 13038 2449 2388 -frame-rollback 68440 34466 2020 3424 80768 39762 7402 2383 2394 -free-all-refused 67688 32370 28 28 67728 32658 299 2418 2497 -generics 81368 42786 10137 20427 114184 71602 39241 2474 2516 -handles 75880 35826 3482 6289 84112 46338 13981 2520 2470 -higher-order 76648 37154 4652 10329 88976 51314 18948 2413 2439 -into 80256 40658 8277 12345 92584 53682 21320 2428 2412 -loops 67736 33378 1016 1720 71872 37634 5269 2370 2315 -machine 67960 33186 821 1925 72096 37394 5042 2515 2456 -macro-unless 67720 32642 288 615 67760 34610 2243 2466 2457 -macros 67688 32802 461 793 67728 35250 2896 2532 2409 -map-exhausted 76152 36162 3805 5994 84392 44530 12171 2393 2506 -map-iter 76096 39586 7211 10374 92520 54082 21715 2541 2531 -map-stale-region 67688 33650 1307 2106 71824 36898 4537 2354 2407 -maps 88504 45266 12833 19850 117216 72802 40445 3162 3082 -math 67832 33986 1611 3288 72024 39362 7000 2384 2405 -math2 67784 33506 1148 2862 72024 39010 6644 2300 2482 -pkg-diamond 67880 32626 252 616 67928 34162 1801 2353 2227 -pkg-macro-idle 67688 32338 3 3 67728 32562 210 2440 2410 -pkg-macro 67800 32722 354 450 67840 33986 1626 2455 2429 -pkg-return 78416 39570 7024 23635 103032 64082 31716 2432 2375 -pkg-shadow 67848 32642 277 371 67888 33618 1258 2408 2236 -pkg-shared 74560 34066 1676 5593 86888 45650 13283 2422 2648 -pkg-unused 69704 32386 35 35 69744 34658 2298 2351 2271 -pool-stale-region 67688 33282 932 1675 71824 35746 3379 2389 2466 -printers 82464 42098 168 452 82504 43282 1348 -1 -1 -println 76256 36098 3737 7587 88584 50114 17753 2312 2460 -raylib-audio 79536 35522 2478 5610 87768 44178 11225 2574 2769 -raylib-ffi 85848 39538 6245 11506 102272 55650 22537 2607 2852 -raylib-font 79088 35538 2622 6260 83232 43186 10350 2661 2658 -raylib-image 80152 37698 4504 8285 88384 47058 13966 2684 2946 -raylib-imported 70344 33202 612 1003 74480 36658 4066 2688 2602 -reach-walk 67992 33170 774 1082 68032 34802 2443 2552 2308 -recur 67792 34594 2233 4070 76024 40674 8314 2468 62674 -registry 72008 35330 2940 4604 80240 41010 8608 2515 2329 -reload-generic 67944 32930 520 1390 67992 35442 3076 2341 2241 -restarts 77200 39010 6430 9268 89528 49442 17065 2356 2304 -rl-with 69704 32386 35 35 69744 34658 2298 2550 2461 -sand-headless 74728 34546 2139 6326 87056 47634 15269 2783 9172 -signedness 67688 32594 246 386 67728 33938 1576 2418 2411 -slice-from-ptr 67752 33106 755 2549 75984 37458 5101 2421 2367 -slices 68128 34802 2393 9057 88648 50114 17753 2504 2271 -slurp-unhandled 67688 33522 1173 1601 67728 35298 2945 2340 2354 -slurp 80288 42114 9744 14813 100808 57010 24656 2358 2408 -stale-region 67688 33490 1148 1681 71824 35842 3483 2332 2286 -string-of-bytes 67856 33490 981 1925 71992 36338 3817 2319 2353 -strings 88912 45890 13395 22681 109432 65618 33265 2455 2391 -text 72296 37122 4666 8007 84624 49378 17018 2310 2397 -unions 76016 36498 4131 17714 92440 55810 23456 2323 2413 -unit-main 67688 32386 33 33 67728 32674 307 2459 2377 -utf8 81216 39714 7170 21515 114024 73106 40745 2563 2380 -values 67720 32530 180 667 67760 34082 1719 2531 2378 -vec 80080 40402 8039 12089 92408 55122 22770 2370 2389 -virtual-controls-headless 70896 33666 1271 1295 75032 38962 6601 2319 3201 -web-files 67736 33058 706 1000 67776 34610 2246 2321 2382 -p1-exit 67688 32338 3 3 67728 32562 210 2436 2377 -p2-loop-print 67688 32626 283 106 67728 32930 577 2269 2364 -p3-fizz 67720 32530 169 225 67760 33282 928 2512 2359 -p4-convention 67824 32786 405 1005 67864 35138 2778 2436 2332 -p5-core 67792 33346 993 1507 71928 37218 4865 2346 2444 -p6-transfer 68096 34354 1944 2801 72232 37618 5252 2386 2310 -p7-slice-from-ptr 67840 33698 1336 1498 71984 35682 3318 2493 2392 -p8-cell 67752 32514 146 270 67800 33202 847 2402 2381 diff --git a/spike/x86/cost.sh b/spike/x86/cost.sh deleted file mode 100755 index 59fba226..00000000 --- a/spike/x86/cost.sh +++ /dev/null @@ -1,135 +0,0 @@ -#!/usr/bin/env bash -# What does the hand-written backend cost, against LLVM, on the same programs? -# -# survey.sh answers "does it agree". This answers "what does agreeing cost", -# which is item 7 of docs/handoffs/HANDOFF-x86-rt.md and the one thing about this backend -# nobody had a number for. It builds each program the same two ways the -# survey does, and for each records three sizes and a time: -# -# file the whole executable on disk. Mostly runtime and libc glue, and -# the least interesting of the three -- it is here because it is -# the number anybody looks at first, and it should be visible how -# much of it is noise. -# text the .text section, from `size -A`. Still contains flan_rt.o, -# which is the same object on both sides. -# own the sum of the sizes of the defined symbols named `flan.` -# -- the program's *own* code and nothing else. The runtime's C is -# `flan_` with an underscore, so the two do not collide, and -# spot-checking a runtime symbol on both sides (flan_map_clone, -# 0x4b3 either way) says the runtime really is byte-identical and -# the difference in `own` is all codegen. -# -# The `own` column is the measurement; the other two are context. -# -# A fourth build, LLVM with --debug, is the reference that makes the number -# readable. --debug forces -O0, so it is LLVM's codegen with its optimiser -# switched off -- the closest thing available to what this backend is doing, -# which has no optimiser at all. Without it every ratio silently blames the -# backend for the whole of mem2reg and inlining. (--x86 --debug is refused, -# so the column exists on one side only, and that is the point of it.) -# -# Time is best-of-N, not a mean: a mean measures the other tenants of the -# machine. Even so, a corpus program is mostly process startup -- these are -# milliseconds -- so read the time column only where it is tens of -# milliseconds or more, and read the rest as size. -# -# Usage: spike/x86/cost.sh [name-substring ...] -> a TSV on stdout -# COST_FLAGS=--dev extra flags, given to both sides, as SURVEY_FLAGS is -# COST_REPS=5 timing repetitions -# COST_O0=0 skip the LLVM -O0 reference column -set -u -orig=$(pwd) -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -cd "$root" || exit 1 - -if [ -n "${FLAN:-}" ]; then - case $FLAN in /*) flan=$FLAN;; *) flan=$orig/$FLAN;; esac -else - dune build --root . bin/main.exe 2>&1 | head -30 - flan=$root/_build/default/bin/main.exe -fi -test -x "$flan" || { echo "build failed" >&2; exit 1; } - -# Not mktemp under /tmp by default: this writes a few hundred executables of -# a megabyte or two, and a full /tmp on this machine has already frozen one -# session. The guard is cheap and a wedged run is not. -# A directory of this run's own, made with a plain mkdir so that a second -# copy of this script cannot land in the first one's: two runs sharing a -# scratch directory overwrite each other's `l` and `x` between the build and -# the timing, and the result is a row of numbers that belong to two different -# programs. That happened once here and the numbers looked entirely ordinary. -work=${COST_OUT:-${TMPDIR:-/tmp}/flan-cost} -mkdir -p "$work" || exit 1 -out=$work/run.$$ -mkdir "$out" || exit 1 -trap 'rm -rf "$out"' EXIT -free=$(df -Pk "$out" | awk 'NR==2 {print $4}') -[ "$free" -gt 2000000 ] || { echo "less than 2GB free at $out" >&2; exit 1; } - -forever="dev-loop dev-watch" -REPS=${COST_REPS:-5} -read -r -a extra <<<"${COST_FLAGS:-}" -o0=${COST_O0:-1} -[ -z "${COST_FLAGS:-}" ] || o0=0 - -# The sum of the defined text symbols the compiler itself named. `nm -S` -# prints value, size, type, name; a symbol with no size is not printed with -# four fields at all, which is why the guard is on NF. -own () { - nm --defined-only -S "$1" 2>/dev/null \ - | awk 'NF==4 && ($3=="T"||$3=="t") && $4 ~ /^flan\./ {n+=strtonum("0x"$2)} END{print n+0}' -} -text () { size -A "$1" 2>/dev/null | awk '$1==".text" {print $2}'; } - -# Best of REPS, in whole microseconds. A program that fails on one run and -# not another would make this meaningless, so the exit status of the first -# run is remembered and a run that disagrees with it poisons the row as -1. -# A program that hits the timeout is not timed at all: several of the corpus -# programs are agents or daemons that sit waiting for something that is not -# there, and five repetitions of a twenty-second wait, twice, is most of an -# afternoon spent measuring `timeout`. -best () { - exe=$1; min=; rc0= - for i in $(seq "$REPS"); do - t0=$(date +%s%N) - ( cd "$out" && timeout 20 "$exe" >/dev/null 2>&1 /dev/null 2>&1 || continue - # No main is a link failure, and it leaves nothing behind to measure. - test -x "$out/l" || continue - "$flan" build "$src" --x86 "${extra[@]}" -o "$out/x" >/dev/null 2>&1 || continue - test -x "$out/x" || continue - - d0=0 - if [ "$o0" = 1 ] && "$flan" build "$src" --debug -o "$out/d" >/dev/null 2>&1; then - d0=$(own "$out/d") - fi - - printf '%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\n' "$name" \ - "$(stat -c %s "$out/l")" "$(text "$out/l")" "$(own "$out/l")" "$d0" \ - "$(stat -c %s "$out/x")" "$(text "$out/x")" "$(own "$out/x")" \ - "$(best "$out/l")" "$(best "$out/x")" -done diff --git a/spike/x86/cell-override.c b/test/cell-override.c similarity index 94% rename from spike/x86/cell-override.c rename to test/cell-override.c index 98be2686..d9c8a3d4 100644 --- a/spike/x86/cell-override.c +++ b/test/cell-override.c @@ -13,7 +13,7 @@ * * A release build has no cells, dlsym answers NULL, and this does nothing -- * which is the control: it shows the change below comes from the indirection - * and not from ordinary symbol interposition. See spike/x86/cells.sh. + * and not from ordinary symbol interposition. See test/cells.sh. */ #define _GNU_SOURCE #include diff --git a/spike/x86/cells.sh b/test/cells.sh similarity index 97% rename from spike/x86/cells.sh rename to test/cells.sh index 81c1d4f2..3935df90 100755 --- a/spike/x86/cells.sh +++ b/test/cells.sh @@ -23,7 +23,7 @@ # from ordinary symbol interposition. set -u here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) +root=$(cd "$here/.." && pwd) # FLAN overrides the compiler, and when it is set nothing is built here. The # @cells alias sets it, because a dune action that shells out to dune waits on a # lock it cannot get; main.exe is in that rule's deps instead. Resolved to an @@ -47,7 +47,7 @@ test -x "$flan" || { echo "no compiler at $flan"; exit 1; } out=$(mktemp -d); trap 'rm -rf "$out"' EXIT cc -shared -fPIC -o "$out/override.so" "$here/cell-override.c" || exit 1 -src=$here/p8-cell.flan +src=$here/programs/x86-p8-cell.flan fail=0 run() { # run